From 621ab524f62fdf9781b8f34b3c0113a178795bbe Mon Sep 17 00:00:00 2001 From: Pierre Roux Date: Mon, 14 Oct 2024 13:09:04 +0200 Subject: [PATCH 1/4] Remove stdlib (moved to its own repo) --- dune | 2 - stdlib/.gitignore | 1 - stdlib/INSTALL.md | 49 - stdlib/LICENSE | 458 -- stdlib/Makefile | 15 - stdlib/README.md | 77 - stdlib/coq-stdlib.opam | 32 - stdlib/dev/lint-commits.sh | 80 - stdlib/dev/lint-repository.sh | 52 - stdlib/dev/tools/check-eof-newline.sh | 54 - stdlib/dev/tools/dune | 2 - stdlib/dev/tools/hash.ml | 2 - stdlib/dev/tools/hash.mli | 0 stdlib/dev/tools/list-contributors.sh | 29 - stdlib/dev/tools/markdown-toc | 69 - stdlib/dev/with-rocq-wrap.sh | 47 - stdlib/doc/README.md | 112 - stdlib/doc/changelog/01-misc/00000-title.rst | 4 - stdlib/doc/common/macros.tex | 546 --- .../common/styles/html/coqremote/cover.html | 109 - .../common/styles/html/coqremote/footer.html | 34 - .../common/styles/html/coqremote/header.html | 42 - .../common/styles/html/coqremote/hevea.css | 36 - .../html/coqremote/modules/node/node.css | 43 - .../coqremote/modules/system/defaults.css | 52 - .../html/coqremote/modules/system/system.css | 543 --- .../html/coqremote/modules/user/user.css | 58 - .../common/styles/html/coqremote/styles.hva | 81 - .../doc/common/styles/html/simple/cover.html | 61 - .../doc/common/styles/html/simple/footer.html | 2 - .../doc/common/styles/html/simple/header.html | 12 - .../doc/common/styles/html/simple/hevea.css | 36 - .../doc/common/styles/html/simple/style.css | 13 - .../doc/common/styles/html/simple/styles.hva | 45 - stdlib/doc/common/title.tex | 69 - stdlib/doc/dune | 58 - stdlib/doc/sphinx/README.rst | 5 - stdlib/doc/sphinx/README.template.rst | 321 -- stdlib/doc/sphinx/_static/CoqNotations.ttf | Bin 37988 -> 0 bytes stdlib/doc/sphinx/_static/ansi-dark.css | 144 - stdlib/doc/sphinx/_static/ansi.css | 145 - stdlib/doc/sphinx/_static/coqnotations.sty | 93 - stdlib/doc/sphinx/_static/notations.css | 283 -- stdlib/doc/sphinx/_static/notations.js | 43 - stdlib/doc/sphinx/_static/pre-text.css | 29 - stdlib/doc/sphinx/_templates/versions.html | 48 - stdlib/doc/sphinx/biblio.bib | 677 --- stdlib/doc/sphinx/conf.py | 499 -- stdlib/doc/sphinx/dune | 1 - stdlib/doc/sphinx/index.html.rst | 24 - stdlib/doc/sphinx/index.latex.rst | 27 - stdlib/doc/sphinx/introduction.rst | 6 - stdlib/doc/sphinx/language/coq-library.rst | 393 -- stdlib/doc/sphinx/license.rst | 7 - stdlib/doc/sphinx/refman-preamble.rst | 36 - stdlib/doc/sphinx/refman-preamble.sty | 69 - stdlib/doc/sphinx/zebibliography.html.rst | 17 - stdlib/doc/sphinx/zebibliography.latex.rst | 6 - stdlib/doc/stdlib/Library.tex | 66 - stdlib/doc/stdlib/dune | 43 - stdlib/doc/stdlib/hidden-files | 171 - stdlib/doc/stdlib/index-list.html.template | 619 --- stdlib/doc/stdlib/make-library-index | 52 - stdlib/doc/tools/coqrst/__init__.py | 10 - stdlib/doc/tools/coqrst/checkdeps.py | 53 - stdlib/doc/tools/coqrst/coqdoc/__init__.py | 10 - stdlib/doc/tools/coqrst/coqdoc/main.py | 96 - stdlib/doc/tools/coqrst/coqdomain.py | 1492 ------ .../tools/coqrst/notations/CoqNotations.ttf | Bin 37988 -> 0 bytes stdlib/doc/tools/coqrst/notations/Makefile | 27 - .../tools/coqrst/notations/TacticNotations.g | 52 - .../coqrst/notations/TacticNotations.tokens | 14 - .../coqrst/notations/TacticNotationsLexer.py | 86 - .../notations/TacticNotationsLexer.tokens | 14 - .../coqrst/notations/TacticNotationsParser.py | 993 ---- .../notations/TacticNotationsVisitor.py | 88 - .../tools/coqrst/notations/UbuntuMono-B.ttf | Bin 191400 -> 0 bytes stdlib/doc/tools/coqrst/notations/__init__.py | 0 .../doc/tools/coqrst/notations/fontsupport.py | 83 - stdlib/doc/tools/coqrst/notations/html.py | 86 - stdlib/doc/tools/coqrst/notations/parsing.py | 65 - stdlib/doc/tools/coqrst/notations/plain.py | 64 - stdlib/doc/tools/coqrst/notations/regexp.py | 60 - stdlib/doc/tools/coqrst/notations/sphinx.py | 146 - stdlib/doc/tools/coqrst/regen_readme.py | 65 - stdlib/doc/tools/coqrst/repl/__init__.py | 0 stdlib/doc/tools/coqrst/repl/ansicolors.py | 102 - stdlib/doc/tools/coqrst/repl/coqtop.py | 126 - stdlib/dune-project | 63 - stdlib/rocq-stdlib.opam | 46 - stdlib/rocq-stdlib.opam.template | 15 - stdlib/test-suite/.csdp.cache.test-suite | Bin 137304 -> 0 bytes stdlib/test-suite/Makefile | 353 -- stdlib/test-suite/README.md | 97 - stdlib/test-suite/_CoqProject | 1 - stdlib/test-suite/bugs/bug_10025.v | 39 - stdlib/test-suite/bugs/bug_10407.v | 55 - stdlib/test-suite/bugs/bug_10533.v | 8 - stdlib/test-suite/bugs/bug_11030.v | 29 - stdlib/test-suite/bugs/bug_11321.v | 10 - stdlib/test-suite/bugs/bug_11890.v | 10 - stdlib/test-suite/bugs/bug_12257.v | 3 - stdlib/test-suite/bugs/bug_1243.v | 9 - stdlib/test-suite/bugs/bug_12860.v | 10 - stdlib/test-suite/bugs/bug_12889.v | 28 - stdlib/test-suite/bugs/bug_12907.v | 7 - stdlib/test-suite/bugs/bug_13307.v | 15 - stdlib/test-suite/bugs/bug_1362.v | 17 - stdlib/test-suite/bugs/bug_13698.v | 5 - stdlib/test-suite/bugs/bug_13979.v | 22 - stdlib/test-suite/bugs/bug_1414.v | 42 - stdlib/test-suite/bugs/bug_14374.v | 73 - stdlib/test-suite/bugs/bug_1448.v | 28 - stdlib/test-suite/bugs/bug_14731.v | 99 - stdlib/test-suite/bugs/bug_15043.v | 61 - stdlib/test-suite/bugs/bug_15568.v | 18 - stdlib/test-suite/bugs/bug_1584.v | 5 - stdlib/test-suite/bugs/bug_16043.v | 52 - stdlib/test-suite/bugs/bug_1614.v | 21 - stdlib/test-suite/bugs/bug_1618.v | 23 - stdlib/test-suite/bugs/bug_16181.v | 38 - stdlib/test-suite/bugs/bug_16728.v | 8 - stdlib/test-suite/bugs/bug_16738.v | 11 - stdlib/test-suite/bugs/bug_16803.v | 102 - stdlib/test-suite/bugs/bug_16906.v | 8 - stdlib/test-suite/bugs/bug_16960.v | 44 - stdlib/test-suite/bugs/bug_1738.v | 30 - stdlib/test-suite/bugs/bug_17423.v | 11 - stdlib/test-suite/bugs/bug_17466_3.v | 309 -- stdlib/test-suite/bugs/bug_17584.v | 6 - stdlib/test-suite/bugs/bug_1779.v | 25 - stdlib/test-suite/bugs/bug_1784.v | 99 - stdlib/test-suite/bugs/bug_17936.v | 51 - stdlib/test-suite/bugs/bug_17960.v | 67 - stdlib/test-suite/bugs/bug_17983.v | 11 - stdlib/test-suite/bugs/bug_18151.v | 43 - stdlib/test-suite/bugs/bug_18260_1.v | 108 - stdlib/test-suite/bugs/bug_1844.v | 217 - stdlib/test-suite/bugs/bug_1859.v | 20 - stdlib/test-suite/bugs/bug_18680.v | 63 - stdlib/test-suite/bugs/bug_18850.v | 15 - stdlib/test-suite/bugs/bug_18920.v | 8 - stdlib/test-suite/bugs/bug_1912.v | 6 - stdlib/test-suite/bugs/bug_1935.v | 21 - stdlib/test-suite/bugs/bug_1956.v | 15 - stdlib/test-suite/bugs/bug_1962.v | 55 - stdlib/test-suite/bugs/bug_1963.v | 20 - stdlib/test-suite/bugs/bug_2016.v | 65 - stdlib/test-suite/bugs/bug_2083.v | 27 - stdlib/test-suite/bugs/bug_2136.v | 61 - stdlib/test-suite/bugs/bug_2137.v | 52 - stdlib/test-suite/bugs/bug_2141.v | 16 - stdlib/test-suite/bugs/bug_2145.v | 19 - stdlib/test-suite/bugs/bug_2281.v | 50 - stdlib/test-suite/bugs/bug_2347.v | 10 - stdlib/test-suite/bugs/bug_2388.v | 9 - stdlib/test-suite/bugs/bug_2393.v | 14 - stdlib/test-suite/bugs/bug_2456.v | 58 - stdlib/test-suite/bugs/bug_2464.v | 39 - stdlib/test-suite/bugs/bug_2467.v | 49 - stdlib/test-suite/bugs/bug_2473.v | 40 - stdlib/test-suite/bugs/bug_2586.v | 6 - stdlib/test-suite/bugs/bug_2590.v | 19 - stdlib/test-suite/bugs/bug_2613.v | 17 - stdlib/test-suite/bugs/bug_2668.v | 6 - stdlib/test-suite/bugs/bug_2729.v | 116 - stdlib/test-suite/bugs/bug_2734.v | 15 - stdlib/test-suite/bugs/bug_2814.v | 6 - stdlib/test-suite/bugs/bug_2830.v | 230 - stdlib/test-suite/bugs/bug_2883.v | 37 - stdlib/test-suite/bugs/bug_2900.v | 29 - stdlib/test-suite/bugs/bug_3036.v | 171 - stdlib/test-suite/bugs/bug_3037.v | 12 - stdlib/test-suite/bugs/bug_3164.v | 49 - stdlib/test-suite/bugs/bug_3258.v | 37 - stdlib/test-suite/bugs/bug_3344.v | 59 - stdlib/test-suite/bugs/bug_3350.v | 121 - stdlib/test-suite/bugs/bug_3652.v | 101 - stdlib/test-suite/bugs/bug_3786.v | 33 - stdlib/test-suite/bugs/bug_3938.v | 9 - stdlib/test-suite/bugs/bug_3978.v | 27 - stdlib/test-suite/bugs/bug_4035.v | 14 - stdlib/test-suite/bugs/bug_4057.v | 211 - stdlib/test-suite/bugs/bug_4132.v | 31 - stdlib/test-suite/bugs/bug_4151.v | 405 -- stdlib/test-suite/bugs/bug_4187.v | 715 --- stdlib/test-suite/bugs/bug_4232.v | 20 - stdlib/test-suite/bugs/bug_4280.v | 24 - stdlib/test-suite/bugs/bug_4306.v | 32 - stdlib/test-suite/bugs/bug_4397.v | 4 - stdlib/test-suite/bugs/bug_4433.v | 30 - stdlib/test-suite/bugs/bug_4456.v | 652 --- stdlib/test-suite/bugs/bug_4684.v | 32 - stdlib/test-suite/bugs/bug_4717.v | 33 - stdlib/test-suite/bugs/bug_4725.v | 39 - stdlib/test-suite/bugs/bug_4763.v | 13 - stdlib/test-suite/bugs/bug_4785.v | 34 - stdlib/test-suite/bugs/bug_4852.v | 53 - stdlib/test-suite/bugs/bug_4858.v | 7 - stdlib/test-suite/bugs/bug_4863.v | 33 - stdlib/test-suite/bugs/bug_4880.v | 11 - stdlib/test-suite/bugs/bug_5019.v | 5 - stdlib/test-suite/bugs/bug_5066.v | 7 - stdlib/test-suite/bugs/bug_5096.v | 220 - stdlib/test-suite/bugs/bug_5123.v | 33 - stdlib/test-suite/bugs/bug_5161.v | 27 - stdlib/test-suite/bugs/bug_5208.v | 222 - stdlib/test-suite/bugs/bug_5315.v | 10 - stdlib/test-suite/bugs/bug_5359.v | 221 - stdlib/test-suite/bugs/bug_5445.v | 11 - stdlib/test-suite/bugs/bug_5493.v | 9 - stdlib/test-suite/bugs/bug_5521.v | 68 - stdlib/test-suite/bugs/bug_5618.v | 9 - stdlib/test-suite/bugs/bug_5692.v | 88 - stdlib/test-suite/bugs/bug_5713.v | 15 - stdlib/test-suite/bugs/bug_5744.v | 7 - stdlib/test-suite/bugs/bug_5777.v | 29 - stdlib/test-suite/bugs/bug_6191.v | 16 - stdlib/test-suite/bugs/bug_6378.v | 27 - stdlib/test-suite/bugs/bug_6529.v | 16 - stdlib/test-suite/bugs/bug_7017.v | 32 - stdlib/test-suite/bugs/bug_8119.v | 46 - stdlib/test-suite/bugs/bug_8121.v | 46 - stdlib/test-suite/bugs/bug_8459.v | 24 - stdlib/test-suite/bugs/bug_9201.v | 22 - stdlib/test-suite/bugs/bug_9268.v | 46 - stdlib/test-suite/bugs/bug_9512.v | 31 - stdlib/test-suite/bugs/bug_9580.v | 13 - stdlib/test-suite/bugs/bug_9652.v | 19 - stdlib/test-suite/bugs/bug_9741.v | 21 - stdlib/test-suite/bugs/bug_9851.v | 18 - .../ConstructiveCauchyRealsPerformance.v | 249 - stdlib/test-suite/complexity/bug_13227_1.v | 28 - stdlib/test-suite/complexity/bug_13227_2.v | 28 - stdlib/test-suite/complexity/bug_13227_3.v | 46 - stdlib/test-suite/complexity/bug_13227_4.v | 45 - stdlib/test-suite/complexity/bug_13227_5.v | 79 - stdlib/test-suite/complexity/bug_13227_6.v | 16 - stdlib/test-suite/complexity/pretyping.v | 2659 ----------- stdlib/test-suite/complexity/ring.v | 8 - stdlib/test-suite/complexity/ring2.v | 53 - stdlib/test-suite/complexity/vm_extgcd.v | 10 - stdlib/test-suite/ltac2/notations.v | 43 - stdlib/test-suite/ltac2/preterm_antiquot.v | 62 - stdlib/test-suite/micromega/bertot.v | 23 - stdlib/test-suite/micromega/bound.v | 29 - stdlib/test-suite/micromega/bug_10158.v | 48 - stdlib/test-suite/micromega/bug_11089.v | 13 - stdlib/test-suite/micromega/bug_11191a.v | 6 - stdlib/test-suite/micromega/bug_11191b.v | 6 - stdlib/test-suite/micromega/bug_11270.v | 6 - stdlib/test-suite/micromega/bug_11436.v | 19 - stdlib/test-suite/micromega/bug_11656.v | 11 - stdlib/test-suite/micromega/bug_12184.v | 8 - stdlib/test-suite/micromega/bug_12210.v | 19 - stdlib/test-suite/micromega/bug_12790.v | 8 - stdlib/test-suite/micromega/bug_12791.v | 9 - stdlib/test-suite/micromega/bug_13227_1.v | 75 - stdlib/test-suite/micromega/bug_13794.v | 39 - stdlib/test-suite/micromega/bug_14054.v | 47 - stdlib/test-suite/micromega/bug_14604.v | 15 - stdlib/test-suite/micromega/bug_15481.v | 12 - stdlib/test-suite/micromega/bug_15583.v | 37 - stdlib/test-suite/micromega/bug_15791.v | 17 - stdlib/test-suite/micromega/bug_18158.v | 91 - stdlib/test-suite/micromega/bug_9162.v | 8 - stdlib/test-suite/micromega/div_mod.v | 30 - .../evars_loops_in_8_10_fixed_8_11.v | 4 - stdlib/test-suite/micromega/example.v | 427 -- stdlib/test-suite/micromega/example_nia.v | 536 --- stdlib/test-suite/micromega/heap3_vcgen_25.v | 38 - stdlib/test-suite/micromega/non_lin_ci.v | 278 -- stdlib/test-suite/micromega/qexample.v | 76 - stdlib/test-suite/micromega/reify_bool.v | 18 - stdlib/test-suite/micromega/rexample.v | 126 - stdlib/test-suite/micromega/rsyntax.v | 66 - stdlib/test-suite/micromega/sint63.v | 41 - stdlib/test-suite/micromega/square.v | 58 - stdlib/test-suite/micromega/uint63.v | 28 - stdlib/test-suite/micromega/witness_tactics.v | 54 - stdlib/test-suite/micromega/zify.v | 324 -- stdlib/test-suite/micromega/zomicron.v | 249 - stdlib/test-suite/misc/7595.sh | 5 - stdlib/test-suite/misc/7595/FOO.v | 39 - stdlib/test-suite/misc/7595/base.v | 28 - stdlib/test-suite/misc/PStringExtraction.out | 58 - stdlib/test-suite/misc/PStringExtraction.sh | 15 - stdlib/test-suite/misc/PStringExtraction.v | 25 - stdlib/test-suite/modules/Nat.v | 19 - stdlib/test-suite/modules/PO.v | 57 - stdlib/test-suite/modules/_CoqProject | 1 - .../output/BinaryPrintingNotations.out | Bin 384 -> 0 bytes .../output/BinaryPrintingNotations.v | Bin 18453 -> 0 bytes stdlib/test-suite/output/Binder.out | 12 - stdlib/test-suite/output/Binder.v | 7 - stdlib/test-suite/output/CoercionsString.out | 2 - stdlib/test-suite/output/CoercionsString.v | 8 - .../output/DependentInductionErrors.out | 6 - .../output/DependentInductionErrors.v | 17 - stdlib/test-suite/output/ExtractionString.out | 52 - stdlib/test-suite/output/ExtractionString.v | 25 - .../Extraction_Haskell_String_12258.out | 80 - .../output/Extraction_Haskell_String_12258.v | 52 - stdlib/test-suite/output/Fixpoint.out | 96 - stdlib/test-suite/output/Fixpoint.v | 126 - stdlib/test-suite/output/FloatExtraction.out | 83 - stdlib/test-suite/output/FloatExtraction.v | 33 - stdlib/test-suite/output/FunExt.out | 18 - stdlib/test-suite/output/FunExt.v | 169 - stdlib/test-suite/output/Function.out | 3 - stdlib/test-suite/output/Function.v | 37 - stdlib/test-suite/output/InfoMicromega.out | 2 - stdlib/test-suite/output/InfoMicromega.v | 17 - stdlib/test-suite/output/Intuition.out | 6 - stdlib/test-suite/output/Intuition.v | 5 - stdlib/test-suite/output/MExtraction.out | 2645 ----------- stdlib/test-suite/output/MExtraction.v | 68 - stdlib/test-suite/output/NNumberSyntax.out | 86 - stdlib/test-suite/output/NNumberSyntax.v | 50 - stdlib/test-suite/output/NoAxiomFromR.out | 1 - stdlib/test-suite/output/NoAxiomFromR.v | 10 - stdlib/test-suite/output/NotationSyntax.out | 48 - stdlib/test-suite/output/NotationSyntax.v | 53 - .../output/NotationsCoercionsString.out | 6 - .../output/NotationsCoercionsString.v | 23 - stdlib/test-suite/output/NotationsZArith.out | 22 - stdlib/test-suite/output/NotationsZArith.v | 61 - stdlib/test-suite/output/PosSyntax.out | 95 - stdlib/test-suite/output/PosSyntax.v | 50 - .../output/PrintAssumptionsArith.out | 14 - .../test-suite/output/PrintAssumptionsArith.v | 69 - stdlib/test-suite/output/QArithSyntax.out | 72 - stdlib/test-suite/output/QArithSyntax.v | 39 - stdlib/test-suite/output/RealNumberSyntax.out | 84 - stdlib/test-suite/output/RealNumberSyntax.v | 64 - stdlib/test-suite/output/Search_2.out | 37 - stdlib/test-suite/output/Search_2.v | 5 - stdlib/test-suite/output/Search_3.out | 32 - stdlib/test-suite/output/Search_3.v | 40 - .../test-suite/output/Sint63NumberSyntax.out | 80 - stdlib/test-suite/output/Sint63NumberSyntax.v | 49 - stdlib/test-suite/output/StringSyntax.out | 1110 ----- stdlib/test-suite/output/StringSyntax.v | 117 - .../output/StringSyntaxPrimitive.out | 20 - .../test-suite/output/StringSyntaxPrimitive.v | 159 - stdlib/test-suite/output/Unicode.out | 41 - stdlib/test-suite/output/Unicode.v | 28 - stdlib/test-suite/output/ZNumberSyntax.out | 148 - stdlib/test-suite/output/ZNumberSyntax.v | 82 - stdlib/test-suite/output/allBytes.out | 4 - stdlib/test-suite/output/allBytes.v | 123 - .../output/btauto_counterexample.out | 3 - .../test-suite/output/btauto_counterexample.v | 13 - stdlib/test-suite/output/bug_13942.out | 163 - stdlib/test-suite/output/bug_13942.v | 314 -- stdlib/test-suite/output/bug_15709.out | 2 - stdlib/test-suite/output/bug_15709.v | 4 - stdlib/test-suite/output/bug_19702.out | 21 - stdlib/test-suite/output/bug_19702.v | 30 - stdlib/test-suite/output/bug_9370.out | 12 - stdlib/test-suite/output/bug_9370.v | 12 - .../output/primitive_tokens_string.out | 21 - .../output/primitive_tokens_string.v | 13 - stdlib/test-suite/output/simpl.out | 443 -- stdlib/test-suite/output/simpl.v | 320 -- .../output/sint63NumberNotation.out | 24 - .../test-suite/output/sint63NumberNotation.v | 36 - stdlib/test-suite/prerequisite/admit.v | 2 - .../test-suite/prerequisite/make_notation.v | 14 - stdlib/test-suite/report.sh | 43 - .../stm/Nijmegen_QArithSternBrocot_Zaux.v | 3042 ------------- stdlib/test-suite/success/Abstract.v | 25 - stdlib/test-suite/success/DiscrR.v | 41 - stdlib/test-suite/success/EquivDec.v | 6 - stdlib/test-suite/success/Field.v | 97 - stdlib/test-suite/success/Funind.v | 523 --- stdlib/test-suite/success/Injection.v | 178 - stdlib/test-suite/success/LraTest.v | 14 - stdlib/test-suite/success/MatchFail.v | 29 - stdlib/test-suite/success/NatRing.v | 10 - stdlib/test-suite/success/Nia.v | 673 --- stdlib/test-suite/success/Nsatz.v | 537 --- stdlib/test-suite/success/NumberScopes.v | 41 - stdlib/test-suite/success/Omega.v | 93 - stdlib/test-suite/success/Omega0.v | 145 - stdlib/test-suite/success/Omega2.v | 27 - stdlib/test-suite/success/OmegaPre.v | 124 - .../test-suite/success/PrintSortedUniverses.v | 2 - stdlib/test-suite/success/ProgramCases.v | 33 - stdlib/test-suite/success/ProgramWf.v | 146 - stdlib/test-suite/success/ProgramWfPoly.v | 178 - stdlib/test-suite/success/ROmega.v | 95 - stdlib/test-suite/success/ROmega0.v | 170 - stdlib/test-suite/success/ROmega2.v | 43 - stdlib/test-suite/success/ROmega4.v | 26 - stdlib/test-suite/success/ROmegaPre.v | 120 - stdlib/test-suite/success/RecTutorial.v | 1211 ----- stdlib/test-suite/success/Record.v | 125 - stdlib/test-suite/success/Reg.v | 144 - .../test-suite/success/SchemeEqualityZArith.v | 66 - stdlib/test-suite/success/TestRefine.v | 223 - stdlib/test-suite/success/ZModulo.v | 1083 ----- .../test-suite/success/add_field_pre_post.v | 75 - stdlib/test-suite/success/apply.v | 606 --- stdlib/test-suite/success/btauto.v | 9 - stdlib/test-suite/success/conv_pbs.v | 228 - stdlib/test-suite/success/dependentind.v | 162 - stdlib/test-suite/success/extraction.v | 687 --- stdlib/test-suite/success/extraction_bigint.v | 108 - stdlib/test-suite/success/fix.v | 119 - stdlib/test-suite/success/import_lib.v | 203 - stdlib/test-suite/success/programequality.v | 13 - .../test-suite/success/rewrite_Proper_map.v | 183 - stdlib/test-suite/success/rewrite_dep.v | 34 - stdlib/test-suite/success/search_lia.v | 7 - .../test-suite/success/setoid_ring_module.v | 40 - .../success/strong_and_binary_induction.v | 64 - stdlib/test-suite/success/unicode_utf8.v | 102 - stdlib/test-suite/success/unification_delta.v | 47 - stdlib/theories/Arith/Arith.v | 12 - stdlib/theories/Arith/Arith_base.v | 373 -- stdlib/theories/Arith/Between.v | 212 - stdlib/theories/Arith/Bool_nat.v | 56 - stdlib/theories/Arith/Cantor.v | 88 - stdlib/theories/Arith/Compare.v | 58 - stdlib/theories/Arith/Compare_dec.v | 252 - stdlib/theories/Arith/EqNat.v | 63 - stdlib/theories/Arith/Euclid.v | 56 - stdlib/theories/Arith/Factorial.v | 42 - stdlib/theories/Arith/PeanoNat.v | 1367 ------ stdlib/theories/Arith/Peano_dec.v | 62 - stdlib/theories/Arith/Wf_nat.v | 273 -- stdlib/theories/Array/ArrayAxioms.v | 1 - stdlib/theories/Array/PArray.v | 67 - stdlib/theories/Array/PrimArray.v | 1 - stdlib/theories/BinNums/IntDef.v | 1 - stdlib/theories/BinNums/NatDef.v | 1 - stdlib/theories/BinNums/PosDef.v | 1 - stdlib/theories/Bool/Bool.v | 989 ---- stdlib/theories/Bool/BoolEq.v | 74 - stdlib/theories/Bool/BoolOrder.v | 106 - stdlib/theories/Bool/Bvector.v | 142 - stdlib/theories/Bool/DecBool.v | 33 - stdlib/theories/Bool/IfProp.v | 51 - stdlib/theories/Bool/Zerob.v | 44 - stdlib/theories/Classes/CEquivalence.v | 153 - stdlib/theories/Classes/CMorphisms.v | 1 - stdlib/theories/Classes/CRelationClasses.v | 1 - stdlib/theories/Classes/DecidableClass.v | 72 - stdlib/theories/Classes/EquivDec.v | 178 - stdlib/theories/Classes/Equivalence.v | 1 - stdlib/theories/Classes/Init.v | 1 - stdlib/theories/Classes/Morphisms.v | 1 - stdlib/theories/Classes/Morphisms_Prop.v | 1 - stdlib/theories/Classes/Morphisms_Relations.v | 61 - stdlib/theories/Classes/RelationClasses.v | 1 - stdlib/theories/Classes/RelationPairs.v | 191 - stdlib/theories/Classes/SetoidClass.v | 147 - stdlib/theories/Classes/SetoidDec.v | 138 - stdlib/theories/Classes/SetoidTactics.v | 1 - stdlib/theories/Compat/AdmitAxiom.v | 17 - stdlib/theories/Compat/Coq818.v | 1 - stdlib/theories/Compat/Coq819.v | 1 - stdlib/theories/Compat/Coq820.v | 1 - stdlib/theories/Compat/README.md | 9 - stdlib/theories/Compat/Stdlib818.v | 55 - stdlib/theories/FSets/FMapAVL.v | 2516 ---------- stdlib/theories/FSets/FMapFacts.v | 2297 ---------- stdlib/theories/FSets/FMapFullAVL.v | 852 ---- stdlib/theories/FSets/FMapInterface.v | 324 -- stdlib/theories/FSets/FMapList.v | 1299 ------ stdlib/theories/FSets/FMapPositive.v | 1128 ----- stdlib/theories/FSets/FMapWeakList.v | 1008 ---- stdlib/theories/FSets/FMaps.v | 18 - stdlib/theories/FSets/FSetAVL.v | 55 - stdlib/theories/FSets/FSetBridge.v | 821 ---- stdlib/theories/FSets/FSetCompat.v | 421 -- stdlib/theories/FSets/FSetDecide.v | 901 ---- stdlib/theories/FSets/FSetEqProperties.v | 958 ---- stdlib/theories/FSets/FSetFacts.v | 509 --- stdlib/theories/FSets/FSetInterface.v | 512 --- stdlib/theories/FSets/FSetList.v | 29 - stdlib/theories/FSets/FSetPositive.v | 1197 ----- stdlib/theories/FSets/FSetProperties.v | 1193 ----- stdlib/theories/FSets/FSetToFiniteSet.v | 156 - stdlib/theories/FSets/FSetWeakList.v | 30 - stdlib/theories/FSets/FSets.v | 25 - stdlib/theories/Floats/FloatAxioms.v | 1 - stdlib/theories/Floats/FloatClass.v | 1 - stdlib/theories/Floats/FloatLemmas.v | 334 -- stdlib/theories/Floats/FloatOps.v | 1 - stdlib/theories/Floats/Floats.v | 31 - stdlib/theories/Floats/PrimFloat.v | 1 - stdlib/theories/Floats/SpecFloat.v | 1 - stdlib/theories/Init/Byte.v | 1 - stdlib/theories/Init/Datatypes.v | 1 - stdlib/theories/Init/Decimal.v | 1 - stdlib/theories/Init/Hexadecimal.v | 1 - stdlib/theories/Init/Logic.v | 1 - stdlib/theories/Init/Ltac.v | 1 - stdlib/theories/Init/Nat.v | 1 - stdlib/theories/Init/Notations.v | 1 - stdlib/theories/Init/Number.v | 1 - stdlib/theories/Init/Peano.v | 1 - stdlib/theories/Init/Prelude.v | 1 - stdlib/theories/Init/Specif.v | 1 - stdlib/theories/Init/Sumbool.v | 1 - stdlib/theories/Init/Tactics.v | 1 - stdlib/theories/Init/Tauto.v | 1 - stdlib/theories/Init/Wf.v | 1 - stdlib/theories/Lists/List.v | 4053 ----------------- stdlib/theories/Lists/ListDec.v | 128 - stdlib/theories/Lists/ListDef.v | 1 - stdlib/theories/Lists/ListSet.v | 497 -- stdlib/theories/Lists/ListTactics.v | 81 - stdlib/theories/Lists/SetoidList.v | 1110 ----- stdlib/theories/Lists/SetoidPermutation.v | 206 - stdlib/theories/Lists/StreamMemo.v | 209 - stdlib/theories/Lists/Streams.v | 250 - stdlib/theories/Logic/Adjointification.v | 113 - stdlib/theories/Logic/Berardi.v | 156 - stdlib/theories/Logic/ChoiceFacts.v | 1326 ------ stdlib/theories/Logic/Classical.v | 16 - stdlib/theories/Logic/ClassicalChoice.v | 51 - stdlib/theories/Logic/ClassicalDescription.v | 87 - stdlib/theories/Logic/ClassicalEpsilon.v | 102 - stdlib/theories/Logic/ClassicalFacts.v | 896 ---- stdlib/theories/Logic/ClassicalUniqueChoice.v | 94 - stdlib/theories/Logic/Classical_Pred_Type.v | 74 - stdlib/theories/Logic/Classical_Prop.v | 126 - stdlib/theories/Logic/ConstructiveEpsilon.v | 448 -- stdlib/theories/Logic/Decidable.v | 239 - stdlib/theories/Logic/Description.v | 21 - stdlib/theories/Logic/Diaconescu.v | 308 -- stdlib/theories/Logic/Epsilon.v | 71 - stdlib/theories/Logic/Eqdep.v | 41 - stdlib/theories/Logic/EqdepFacts.v | 504 -- stdlib/theories/Logic/Eqdep_dec.v | 406 -- .../Logic/ExtensionalFunctionRepresentative.v | 26 - stdlib/theories/Logic/ExtensionalityFacts.v | 139 - stdlib/theories/Logic/FinFun.v | 431 -- .../theories/Logic/FunctionalExtensionality.v | 262 -- stdlib/theories/Logic/HLevels.v | 149 - stdlib/theories/Logic/Hurkens.v | 721 --- stdlib/theories/Logic/IndefiniteDescription.v | 39 - stdlib/theories/Logic/JMeq.v | 169 - stdlib/theories/Logic/ProofIrrelevance.v | 22 - stdlib/theories/Logic/ProofIrrelevanceFacts.v | 64 - stdlib/theories/Logic/PropExtensionality.v | 23 - .../theories/Logic/PropExtensionalityFacts.v | 111 - stdlib/theories/Logic/PropFacts.v | 52 - stdlib/theories/Logic/RelationalChoice.v | 17 - stdlib/theories/Logic/SetIsType.v | 19 - stdlib/theories/Logic/SetoidChoice.v | 62 - stdlib/theories/Logic/StrictProp.v | 37 - stdlib/theories/Logic/WKL.v | 272 -- stdlib/theories/Logic/WeakFan.v | 104 - stdlib/theories/MSets/MSetAVL.v | 1040 ----- stdlib/theories/MSets/MSetDecide.v | 901 ---- stdlib/theories/MSets/MSetEqProperties.v | 941 ---- stdlib/theories/MSets/MSetFacts.v | 555 --- stdlib/theories/MSets/MSetGenTree.v | 1169 ----- stdlib/theories/MSets/MSetInterface.v | 991 ---- stdlib/theories/MSets/MSetList.v | 935 ---- stdlib/theories/MSets/MSetPositive.v | 1100 ----- stdlib/theories/MSets/MSetProperties.v | 1199 ----- stdlib/theories/MSets/MSetRBT.v | 1999 -------- stdlib/theories/MSets/MSetToFiniteSet.v | 156 - stdlib/theories/MSets/MSetWeakList.v | 547 --- stdlib/theories/MSets/MSets.v | 23 - stdlib/theories/NArith/BinNat.v | 1157 ----- stdlib/theories/NArith/BinNatDef.v | 347 -- stdlib/theories/NArith/NArith.v | 34 - stdlib/theories/NArith/Ndec.v | 311 -- stdlib/theories/NArith/Ndiv_def.v | 30 - stdlib/theories/NArith/Ngcd_def.v | 24 - stdlib/theories/NArith/Nnat.v | 294 -- stdlib/theories/NArith/Nsqrt_def.v | 16 - stdlib/theories/Numbers/AltBinNotations.v | 69 - stdlib/theories/Numbers/BinNums.v | 1 - .../Numbers/Cyclic/Abstract/CyclicAxioms.v | 437 -- .../Numbers/Cyclic/Abstract/DoubleType.v | 61 - .../Numbers/Cyclic/Abstract/NZCyclic.v | 242 - .../theories/Numbers/Cyclic/Int63/CarryType.v | 1 - .../theories/Numbers/Cyclic/Int63/Cyclic63.v | 323 -- .../theories/Numbers/Cyclic/Int63/PrimInt63.v | 1 - stdlib/theories/Numbers/Cyclic/Int63/Ring63.v | 67 - stdlib/theories/Numbers/Cyclic/Int63/Sint63.v | 440 -- .../Numbers/Cyclic/Int63/Sint63Axioms.v | 1 - stdlib/theories/Numbers/Cyclic/Int63/Uint63.v | 1855 -------- .../Numbers/Cyclic/Int63/Uint63Axioms.v | 1 - stdlib/theories/Numbers/DecimalFacts.v | 703 --- stdlib/theories/Numbers/DecimalN.v | 109 - stdlib/theories/Numbers/DecimalNat.v | 304 -- stdlib/theories/Numbers/DecimalPos.v | 400 -- stdlib/theories/Numbers/DecimalQ.v | 461 -- stdlib/theories/Numbers/DecimalR.v | 315 -- stdlib/theories/Numbers/DecimalString.v | 265 -- stdlib/theories/Numbers/DecimalZ.v | 125 - stdlib/theories/Numbers/HexadecimalFacts.v | 718 --- stdlib/theories/Numbers/HexadecimalN.v | 109 - stdlib/theories/Numbers/HexadecimalNat.v | 323 -- stdlib/theories/Numbers/HexadecimalPos.v | 448 -- stdlib/theories/Numbers/HexadecimalQ.v | 461 -- stdlib/theories/Numbers/HexadecimalR.v | 305 -- stdlib/theories/Numbers/HexadecimalString.v | 286 -- stdlib/theories/Numbers/HexadecimalZ.v | 165 - .../theories/Numbers/Integer/Abstract/ZAdd.v | 295 -- .../Numbers/Integer/Abstract/ZAddOrder.v | 285 -- .../Numbers/Integer/Abstract/ZAxioms.v | 127 - .../theories/Numbers/Integer/Abstract/ZBase.v | 37 - .../theories/Numbers/Integer/Abstract/ZBits.v | 2024 -------- .../Numbers/Integer/Abstract/ZDivEucl.v | 640 --- .../Numbers/Integer/Abstract/ZDivFloor.v | 686 --- .../Numbers/Integer/Abstract/ZDivTrunc.v | 668 --- .../theories/Numbers/Integer/Abstract/ZGcd.v | 287 -- .../theories/Numbers/Integer/Abstract/ZLcm.v | 488 -- .../theories/Numbers/Integer/Abstract/ZLt.v | 134 - .../Numbers/Integer/Abstract/ZMaxMin.v | 181 - .../theories/Numbers/Integer/Abstract/ZMul.v | 75 - .../Numbers/Integer/Abstract/ZMulOrder.v | 221 - .../Numbers/Integer/Abstract/ZParity.v | 55 - .../theories/Numbers/Integer/Abstract/ZPow.v | 141 - .../Numbers/Integer/Abstract/ZProperties.v | 32 - .../Numbers/Integer/Abstract/ZSgnAbs.v | 380 -- .../theories/Numbers/Integer/Binary/ZBinary.v | 56 - .../Numbers/Integer/NatPairs/ZNatPairs.v | 361 -- stdlib/theories/Numbers/NaryFunctions.v | 164 - stdlib/theories/Numbers/NatInt/NZAdd.v | 124 - stdlib/theories/Numbers/NatInt/NZAddOrder.v | 177 - stdlib/theories/Numbers/NatInt/NZAxioms.v | 264 -- stdlib/theories/Numbers/NatInt/NZBase.v | 106 - stdlib/theories/Numbers/NatInt/NZBits.v | 67 - stdlib/theories/Numbers/NatInt/NZDiv.v | 569 --- stdlib/theories/Numbers/NatInt/NZDomain.v | 383 -- stdlib/theories/Numbers/NatInt/NZGcd.v | 313 -- stdlib/theories/Numbers/NatInt/NZLog.v | 897 ---- stdlib/theories/Numbers/NatInt/NZMul.v | 111 - stdlib/theories/Numbers/NatInt/NZMulOrder.v | 430 -- stdlib/theories/Numbers/NatInt/NZOrder.v | 679 --- stdlib/theories/Numbers/NatInt/NZParity.v | 283 -- stdlib/theories/Numbers/NatInt/NZPow.v | 414 -- stdlib/theories/Numbers/NatInt/NZProperties.v | 21 - stdlib/theories/Numbers/NatInt/NZSqrt.v | 737 --- .../theories/Numbers/Natural/Abstract/NAdd.v | 80 - .../Numbers/Natural/Abstract/NAddOrder.v | 57 - .../Numbers/Natural/Abstract/NAxioms.v | 70 - .../theories/Numbers/Natural/Abstract/NBase.v | 192 - .../theories/Numbers/Natural/Abstract/NBits.v | 1787 -------- .../Numbers/Natural/Abstract/NDefOps.v | 454 -- .../theories/Numbers/Natural/Abstract/NDiv.v | 258 -- .../theories/Numbers/Natural/Abstract/NDiv0.v | 340 -- .../theories/Numbers/Natural/Abstract/NGcd.v | 260 -- .../theories/Numbers/Natural/Abstract/NIso.v | 103 - .../theories/Numbers/Natural/Abstract/NLcm.v | 302 -- .../theories/Numbers/Natural/Abstract/NLcm0.v | 144 - .../theories/Numbers/Natural/Abstract/NLog.v | 25 - .../Numbers/Natural/Abstract/NMaxMin.v | 137 - .../Numbers/Natural/Abstract/NMulOrder.v | 99 - .../Numbers/Natural/Abstract/NOrder.v | 294 -- .../Numbers/Natural/Abstract/NParity.v | 66 - .../theories/Numbers/Natural/Abstract/NPow.v | 170 - .../Numbers/Natural/Abstract/NProperties.v | 40 - .../theories/Numbers/Natural/Abstract/NSqrt.v | 77 - .../Numbers/Natural/Abstract/NStrongRec.v | 196 - .../theories/Numbers/Natural/Abstract/NSub.v | 365 -- .../theories/Numbers/Natural/Binary/NBinary.v | 51 - stdlib/theories/Numbers/NumPrelude.v | 25 - stdlib/theories/PArith/BinPos.v | 2199 --------- stdlib/theories/PArith/BinPosDef.v | 385 -- stdlib/theories/PArith/PArith.v | 13 - stdlib/theories/PArith/POrderedType.v | 38 - stdlib/theories/PArith/Pnat.v | 530 --- stdlib/theories/Program/Basics.v | 1 - stdlib/theories/Program/Combinators.v | 68 - stdlib/theories/Program/Equality.v | 475 -- stdlib/theories/Program/Program.v | 17 - stdlib/theories/Program/Subset.v | 119 - stdlib/theories/Program/Syntax.v | 31 - stdlib/theories/Program/Tactics.v | 1 - stdlib/theories/Program/Utils.v | 1 - stdlib/theories/Program/Wf.v | 1 - stdlib/theories/Program/WfExtensionality.v | 51 - stdlib/theories/QArith/QArith.v | 13 - stdlib/theories/QArith/QArith_base.v | 1514 ------ stdlib/theories/QArith/QOrderedType.v | 62 - stdlib/theories/QArith/Qabs.v | 218 - stdlib/theories/QArith/Qcabs.v | 131 - stdlib/theories/QArith/Qcanon.v | 546 --- stdlib/theories/QArith/Qfield.v | 164 - stdlib/theories/QArith/Qminmax.v | 69 - stdlib/theories/QArith/Qpower.v | 475 -- stdlib/theories/QArith/Qreals.v | 183 - stdlib/theories/QArith/Qreduction.v | 170 - stdlib/theories/QArith/Qring.v | 11 - stdlib/theories/QArith/Qround.v | 150 - .../theories/Reals/Abstract/ConstructiveAbs.v | 370 -- .../theories/Reals/Abstract/ConstructiveLUB.v | 465 -- .../Reals/Abstract/ConstructiveLimits.v | 525 --- .../Reals/Abstract/ConstructiveMinMax.v | 710 --- .../Reals/Abstract/ConstructivePower.v | 275 -- .../Reals/Abstract/ConstructiveReals.v | 1235 ----- .../Abstract/ConstructiveRealsMorphisms.v | 1217 ----- .../theories/Reals/Abstract/ConstructiveSum.v | 699 --- stdlib/theories/Reals/Alembert.v | 633 --- stdlib/theories/Reals/AltSeries.v | 416 -- stdlib/theories/Reals/ArithProp.v | 157 - stdlib/theories/Reals/Binomial.v | 192 - .../Reals/Cauchy/ConstructiveCauchyAbs.v | 983 ---- .../Reals/Cauchy/ConstructiveCauchyReals.v | 1001 ---- .../Cauchy/ConstructiveCauchyRealsMult.v | 1128 ----- .../theories/Reals/Cauchy/ConstructiveExtra.v | 76 - .../Reals/Cauchy/ConstructiveRcomplete.v | 751 --- stdlib/theories/Reals/Cauchy/PosExtra.v | 32 - stdlib/theories/Reals/Cauchy/QExtra.v | 257 -- stdlib/theories/Reals/Cauchy_prod.v | 234 - .../Reals/ClassicalConstructiveReals.v | 333 -- .../theories/Reals/ClassicalDedekindReals.v | 718 --- stdlib/theories/Reals/Cos_plus.v | 718 --- stdlib/theories/Reals/Cos_rel.v | 324 -- stdlib/theories/Reals/DiscrR.v | 69 - stdlib/theories/Reals/Exp_prop.v | 755 --- stdlib/theories/Reals/Integration.v | 13 - stdlib/theories/Reals/MVT.v | 670 --- stdlib/theories/Reals/Machin.v | 184 - stdlib/theories/Reals/NewtonInt.v | 753 --- stdlib/theories/Reals/PSeries_reg.v | 611 --- stdlib/theories/Reals/PartSum.v | 623 --- stdlib/theories/Reals/RIneq.v | 2865 ------------ stdlib/theories/Reals/RList.v | 739 --- stdlib/theories/Reals/ROrderedType.v | 98 - stdlib/theories/Reals/R_Ifp.v | 418 -- stdlib/theories/Reals/R_sqr.v | 358 -- stdlib/theories/Reals/R_sqrt.v | 486 -- stdlib/theories/Reals/Ranalysis.v | 30 - stdlib/theories/Reals/Ranalysis1.v | 1765 ------- stdlib/theories/Reals/Ranalysis2.v | 409 -- stdlib/theories/Reals/Ranalysis3.v | 716 --- stdlib/theories/Reals/Ranalysis4.v | 394 -- stdlib/theories/Reals/Ranalysis5.v | 1399 ------ stdlib/theories/Reals/Ranalysis_reg.v | 813 ---- stdlib/theories/Reals/Ratan.v | 2143 --------- stdlib/theories/Reals/Raxioms.v | 487 -- stdlib/theories/Reals/Rbase.v | 14 - stdlib/theories/Reals/Rbasic_fun.v | 686 --- stdlib/theories/Reals/Rcomplete.v | 193 - stdlib/theories/Reals/Rdefinitions.v | 390 -- stdlib/theories/Reals/Rderiv.v | 434 -- stdlib/theories/Reals/Reals.v | 33 - stdlib/theories/Reals/Rfunctions.v | 941 ---- stdlib/theories/Reals/Rgeom.v | 202 - stdlib/theories/Reals/RiemannInt.v | 3165 ------------- stdlib/theories/Reals/RiemannInt_SF.v | 2396 ---------- stdlib/theories/Reals/Rlimit.v | 507 --- stdlib/theories/Reals/Rlogic.v | 220 - stdlib/theories/Reals/Rminmax.v | 127 - stdlib/theories/Reals/Rpow_def.v | 17 - stdlib/theories/Reals/Rpower.v | 879 ---- stdlib/theories/Reals/Rprod.v | 196 - stdlib/theories/Reals/Rregisternames.v | 34 - stdlib/theories/Reals/Rseries.v | 422 -- stdlib/theories/Reals/Rsigma.v | 129 - stdlib/theories/Reals/Rsqrt_def.v | 738 --- stdlib/theories/Reals/Rtopology.v | 1866 -------- stdlib/theories/Reals/Rtrigo.v | 27 - stdlib/theories/Reals/Rtrigo1.v | 1692 ------- stdlib/theories/Reals/Rtrigo_alt.v | 297 -- stdlib/theories/Reals/Rtrigo_calc.v | 374 -- stdlib/theories/Reals/Rtrigo_def.v | 350 -- stdlib/theories/Reals/Rtrigo_facts.v | 284 -- stdlib/theories/Reals/Rtrigo_fun.v | 101 - stdlib/theories/Reals/Rtrigo_reg.v | 426 -- stdlib/theories/Reals/Runcountable.v | 440 -- stdlib/theories/Reals/SeqProp.v | 1204 ----- stdlib/theories/Reals/SeqSeries.v | 400 -- stdlib/theories/Reals/SplitAbsolu.v | 25 - stdlib/theories/Reals/SplitRmult.v | 20 - stdlib/theories/Reals/Sqrt_reg.v | 326 -- .../theories/Relations/Operators_Properties.v | 456 -- .../theories/Relations/Relation_Definitions.v | 1 - .../theories/Relations/Relation_Operators.v | 274 -- stdlib/theories/Relations/Relations.v | 30 - stdlib/theories/Setoids/Setoid.v | 1 - stdlib/theories/Sets/Classical_sets.v | 129 - stdlib/theories/Sets/Constructive_sets.v | 147 - stdlib/theories/Sets/Cpo.v | 111 - stdlib/theories/Sets/Ensembles.v | 101 - stdlib/theories/Sets/Finite_sets.v | 83 - stdlib/theories/Sets/Finite_sets_facts.v | 236 - stdlib/theories/Sets/Image.v | 203 - stdlib/theories/Sets/Infinite_sets.v | 242 - stdlib/theories/Sets/Integers.v | 159 - stdlib/theories/Sets/Multiset.v | 194 - stdlib/theories/Sets/Partial_Order.v | 104 - stdlib/theories/Sets/Permut.v | 89 - stdlib/theories/Sets/Powerset.v | 211 - .../theories/Sets/Powerset_Classical_facts.v | 345 -- stdlib/theories/Sets/Powerset_facts.v | 355 -- stdlib/theories/Sets/Relations_1.v | 69 - stdlib/theories/Sets/Relations_1_facts.v | 118 - stdlib/theories/Sets/Relations_2.v | 60 - stdlib/theories/Sets/Relations_2_facts.v | 153 - stdlib/theories/Sets/Relations_3.v | 67 - stdlib/theories/Sets/Relations_3_facts.v | 172 - stdlib/theories/Sets/Uniset.v | 223 - stdlib/theories/Sorting/CPermutation.v | 288 -- stdlib/theories/Sorting/Heap.v | 322 -- stdlib/theories/Sorting/Mergesort.v | 272 -- stdlib/theories/Sorting/PermutEq.v | 231 - stdlib/theories/Sorting/PermutSetoid.v | 546 --- stdlib/theories/Sorting/Permutation.v | 966 ---- stdlib/theories/Sorting/Sorted.v | 163 - stdlib/theories/Sorting/Sorting.v | 12 - stdlib/theories/Strings/Ascii.v | 291 -- stdlib/theories/Strings/BinaryString.v | 149 - stdlib/theories/Strings/Byte.v | 1211 ----- stdlib/theories/Strings/HexString.v | 231 - stdlib/theories/Strings/OctalString.v | 181 - stdlib/theories/Strings/PString.v | 659 --- stdlib/theories/Strings/PrimString.v | 1 - stdlib/theories/Strings/PrimStringAxioms.v | 1 - stdlib/theories/Strings/String.v | 559 --- stdlib/theories/Structures/DecidableType.v | 164 - stdlib/theories/Structures/DecidableTypeEx.v | 96 - stdlib/theories/Structures/Equalities.v | 285 -- stdlib/theories/Structures/EqualitiesFacts.v | 239 - stdlib/theories/Structures/GenericMinMax.v | 662 --- stdlib/theories/Structures/OrderedType.v | 522 --- stdlib/theories/Structures/OrderedTypeAlt.v | 120 - stdlib/theories/Structures/OrderedTypeEx.v | 548 --- stdlib/theories/Structures/Orders.v | 368 -- stdlib/theories/Structures/OrdersAlt.v | 248 - stdlib/theories/Structures/OrdersEx.v | 251 - stdlib/theories/Structures/OrdersFacts.v | 466 -- stdlib/theories/Structures/OrdersLists.v | 169 - stdlib/theories/Structures/OrdersTac.v | 279 -- stdlib/theories/Unicode/Utf8.v | 26 - stdlib/theories/Unicode/Utf8_core.v | 34 - stdlib/theories/Vectors/Fin.v | 329 -- stdlib/theories/Vectors/Vector.v | 90 - stdlib/theories/Vectors/VectorDef.v | 342 -- stdlib/theories/Vectors/VectorEq.v | 87 - stdlib/theories/Vectors/VectorSpec.v | 790 ---- stdlib/theories/Wellfounded/Disjoint_Union.v | 55 - stdlib/theories/Wellfounded/Inclusion.v | 33 - stdlib/theories/Wellfounded/Inverse_Image.v | 84 - .../Lexicographic_Exponentiation.v | 212 - .../Wellfounded/Lexicographic_Product.v | 192 - stdlib/theories/Wellfounded/List_Extension.v | 137 - .../theories/Wellfounded/Transitive_Closure.v | 48 - stdlib/theories/Wellfounded/Union.v | 75 - stdlib/theories/Wellfounded/Well_Ordering.v | 74 - stdlib/theories/Wellfounded/Wellfounded.v | 19 - stdlib/theories/ZArith/BinInt.v | 1852 -------- stdlib/theories/ZArith/BinIntDef.v | 314 -- stdlib/theories/ZArith/Int.v | 463 -- stdlib/theories/ZArith/Wf_Z.v | 207 - stdlib/theories/ZArith/ZArith.v | 53 - stdlib/theories/ZArith/ZArith_base.v | 40 - stdlib/theories/ZArith/ZArith_dec.v | 201 - stdlib/theories/ZArith/Zabs.v | 104 - stdlib/theories/ZArith/Zbitwise.v | 178 - stdlib/theories/ZArith/Zbool.v | 196 - stdlib/theories/ZArith/Zcompare.v | 192 - stdlib/theories/ZArith/Zcomplements.v | 167 - stdlib/theories/ZArith/Zdiv.v | 822 ---- stdlib/theories/ZArith/Zdiv_facts.v | 40 - stdlib/theories/ZArith/Zeuclid.v | 65 - stdlib/theories/ZArith/Zeven.v | 295 -- stdlib/theories/ZArith/Zgcd_alt.v | 277 -- stdlib/theories/ZArith/Zhints.v | 104 - stdlib/theories/ZArith/Zmax.v | 53 - stdlib/theories/ZArith/Zmin.v | 50 - stdlib/theories/ZArith/Zminmax.v | 24 - stdlib/theories/ZArith/Zmisc.v | 31 - stdlib/theories/ZArith/Znat.v | 1155 ----- stdlib/theories/ZArith/Znumtheory.v | 955 ---- stdlib/theories/ZArith/Zorder.v | 644 --- stdlib/theories/ZArith/Zpow_alt.v | 85 - stdlib/theories/ZArith/Zpow_def.v | 33 - stdlib/theories/ZArith/Zpow_facts.v | 241 - stdlib/theories/ZArith/Zpower.v | 353 -- stdlib/theories/ZArith/Zquot.v | 449 -- stdlib/theories/ZArith/Zwf.v | 93 - stdlib/theories/ZArith/auxiliary.v | 95 - stdlib/theories/_CoqProject | 1 - stdlib/theories/btauto/Algebra.v | 595 --- stdlib/theories/btauto/Btauto.v | 3 - stdlib/theories/btauto/Reflect.v | 410 -- stdlib/theories/derive/Derive.v | 1 - stdlib/theories/dune | 14 - stdlib/theories/extraction/ExtrHaskellBasic.v | 1 - .../theories/extraction/ExtrHaskellNatInt.v | 15 - .../extraction/ExtrHaskellNatInteger.v | 15 - .../theories/extraction/ExtrHaskellNatNum.v | 37 - .../theories/extraction/ExtrHaskellString.v | 64 - stdlib/theories/extraction/ExtrHaskellZInt.v | 26 - .../theories/extraction/ExtrHaskellZInteger.v | 25 - stdlib/theories/extraction/ExtrHaskellZNum.v | 23 - stdlib/theories/extraction/ExtrOCamlFloats.v | 62 - stdlib/theories/extraction/ExtrOCamlInt63.v | 62 - stdlib/theories/extraction/ExtrOCamlPArray.v | 25 - stdlib/theories/extraction/ExtrOCamlPString.v | 37 - stdlib/theories/extraction/ExtrOcamlBasic.v | 1 - stdlib/theories/extraction/ExtrOcamlChar.v | 50 - stdlib/theories/extraction/ExtrOcamlIntConv.v | 101 - .../theories/extraction/ExtrOcamlNatBigInt.v | 79 - stdlib/theories/extraction/ExtrOcamlNatInt.v | 84 - .../extraction/ExtrOcamlNativeString.v | 85 - stdlib/theories/extraction/ExtrOcamlString.v | 18 - stdlib/theories/extraction/ExtrOcamlZBigInt.v | 153 - stdlib/theories/extraction/ExtrOcamlZInt.v | 85 - stdlib/theories/extraction/Extraction.v | 1 - stdlib/theories/funind/FunInd.v | 12 - stdlib/theories/funind/Recdef.v | 52 - stdlib/theories/micromega/DeclConstant.v | 82 - stdlib/theories/micromega/Env.v | 101 - stdlib/theories/micromega/EnvRing.v | 1115 ----- stdlib/theories/micromega/Fourier.v | 5 - stdlib/theories/micromega/Fourier_util.v | 34 - stdlib/theories/micromega/Lia.v | 34 - stdlib/theories/micromega/Lqa.v | 57 - stdlib/theories/micromega/Lra.v | 58 - stdlib/theories/micromega/MExtraction.v | 67 - stdlib/theories/micromega/OrderedRing.v | 473 -- stdlib/theories/micromega/Psatz.v | 63 - stdlib/theories/micromega/QMicromega.v | 273 -- stdlib/theories/micromega/RMicromega.v | 571 --- stdlib/theories/micromega/Refl.v | 152 - stdlib/theories/micromega/RingMicromega.v | 1108 ----- stdlib/theories/micromega/Tauto.v | 2085 --------- stdlib/theories/micromega/VarMap.v | 84 - stdlib/theories/micromega/ZArith_hints.v | 65 - stdlib/theories/micromega/ZCoeff.v | 174 - stdlib/theories/micromega/ZMicromega.v | 1811 -------- stdlib/theories/micromega/Zify.v | 38 - stdlib/theories/micromega/ZifyBool.v | 208 - stdlib/theories/micromega/ZifyClasses.v | 286 -- stdlib/theories/micromega/ZifyComparison.v | 89 - stdlib/theories/micromega/ZifyInst.v | 650 --- stdlib/theories/micromega/ZifyN.v | 58 - stdlib/theories/micromega/ZifyNat.v | 58 - stdlib/theories/micromega/ZifyPow.v | 1 - stdlib/theories/micromega/ZifySint63.v | 205 - stdlib/theories/micromega/ZifyUint63.v | 209 - stdlib/theories/micromega/Ztac.v | 146 - stdlib/theories/nsatz/Nsatz.v | 93 - stdlib/theories/nsatz/NsatzTactic.v | 514 --- stdlib/theories/omega/OmegaLemmas.v | 263 -- stdlib/theories/omega/PreOmega.v | 238 - stdlib/theories/rtauto/Bintree.v | 387 -- stdlib/theories/rtauto/Rtauto.v | 410 -- stdlib/theories/setoid_ring/Algebra_syntax.v | 33 - stdlib/theories/setoid_ring/ArithRing.v | 80 - stdlib/theories/setoid_ring/BinList.v | 82 - stdlib/theories/setoid_ring/Cring.v | 278 -- stdlib/theories/setoid_ring/Field.v | 12 - stdlib/theories/setoid_ring/Field_tac.v | 613 --- stdlib/theories/setoid_ring/Field_theory.v | 1830 -------- stdlib/theories/setoid_ring/InitialRing.v | 944 ---- stdlib/theories/setoid_ring/Integral_domain.v | 61 - stdlib/theories/setoid_ring/NArithRing.v | 23 - stdlib/theories/setoid_ring/Ncring.v | 324 -- stdlib/theories/setoid_ring/Ncring_initial.v | 234 - stdlib/theories/setoid_ring/Ncring_polynom.v | 614 --- stdlib/theories/setoid_ring/Ncring_tac.v | 348 -- stdlib/theories/setoid_ring/RealField.v | 161 - stdlib/theories/setoid_ring/Ring.v | 46 - stdlib/theories/setoid_ring/Ring_base.v | 18 - stdlib/theories/setoid_ring/Ring_polynom.v | 1511 ------ stdlib/theories/setoid_ring/Ring_tac.v | 470 -- stdlib/theories/setoid_ring/Ring_theory.v | 619 --- stdlib/theories/setoid_ring/Rings_Q.v | 53 - stdlib/theories/setoid_ring/Rings_R.v | 58 - stdlib/theories/setoid_ring/Rings_Z.v | 27 - stdlib/theories/setoid_ring/ZArithRing.v | 59 - stdlib/theories/ssr/ssrbool.v | 1 - stdlib/theories/ssr/ssrclasses.v | 1 - stdlib/theories/ssr/ssreflect.v | 1 - stdlib/theories/ssr/ssrfun.v | 1 - stdlib/theories/ssr/ssrsetoid.v | 1 - stdlib/theories/ssr/ssrunder.v | 1 - stdlib/theories/ssrmatching/ssrmatching.v | 1 - stdlib/tools/dune | 3 - stdlib/tools/gen_all.ml | 50 - 985 files changed, 230309 deletions(-) delete mode 100644 stdlib/.gitignore delete mode 100644 stdlib/INSTALL.md delete mode 100644 stdlib/LICENSE delete mode 100644 stdlib/Makefile delete mode 100644 stdlib/README.md delete mode 100644 stdlib/coq-stdlib.opam delete mode 100755 stdlib/dev/lint-commits.sh delete mode 100755 stdlib/dev/lint-repository.sh delete mode 100755 stdlib/dev/tools/check-eof-newline.sh delete mode 100644 stdlib/dev/tools/dune delete mode 100644 stdlib/dev/tools/hash.ml delete mode 100644 stdlib/dev/tools/hash.mli delete mode 100755 stdlib/dev/tools/list-contributors.sh delete mode 100755 stdlib/dev/tools/markdown-toc delete mode 100755 stdlib/dev/with-rocq-wrap.sh delete mode 100644 stdlib/doc/README.md delete mode 100644 stdlib/doc/changelog/01-misc/00000-title.rst delete mode 100644 stdlib/doc/common/macros.tex delete mode 100644 stdlib/doc/common/styles/html/coqremote/cover.html delete mode 100644 stdlib/doc/common/styles/html/coqremote/footer.html delete mode 100644 stdlib/doc/common/styles/html/coqremote/header.html delete mode 100644 stdlib/doc/common/styles/html/coqremote/hevea.css delete mode 100644 stdlib/doc/common/styles/html/coqremote/modules/node/node.css delete mode 100644 stdlib/doc/common/styles/html/coqremote/modules/system/defaults.css delete mode 100644 stdlib/doc/common/styles/html/coqremote/modules/system/system.css delete mode 100644 stdlib/doc/common/styles/html/coqremote/modules/user/user.css delete mode 100644 stdlib/doc/common/styles/html/coqremote/styles.hva delete mode 100644 stdlib/doc/common/styles/html/simple/cover.html delete mode 100644 stdlib/doc/common/styles/html/simple/footer.html delete mode 100644 stdlib/doc/common/styles/html/simple/header.html delete mode 100644 stdlib/doc/common/styles/html/simple/hevea.css delete mode 100644 stdlib/doc/common/styles/html/simple/style.css delete mode 100644 stdlib/doc/common/styles/html/simple/styles.hva delete mode 100644 stdlib/doc/common/title.tex delete mode 100644 stdlib/doc/dune delete mode 100644 stdlib/doc/sphinx/README.rst delete mode 100644 stdlib/doc/sphinx/README.template.rst delete mode 100644 stdlib/doc/sphinx/_static/CoqNotations.ttf delete mode 100644 stdlib/doc/sphinx/_static/ansi-dark.css delete mode 100644 stdlib/doc/sphinx/_static/ansi.css delete mode 100644 stdlib/doc/sphinx/_static/coqnotations.sty delete mode 100644 stdlib/doc/sphinx/_static/notations.css delete mode 100644 stdlib/doc/sphinx/_static/notations.js delete mode 100644 stdlib/doc/sphinx/_static/pre-text.css delete mode 100644 stdlib/doc/sphinx/_templates/versions.html delete mode 100644 stdlib/doc/sphinx/biblio.bib delete mode 100644 stdlib/doc/sphinx/conf.py delete mode 100644 stdlib/doc/sphinx/dune delete mode 100644 stdlib/doc/sphinx/index.html.rst delete mode 100644 stdlib/doc/sphinx/index.latex.rst delete mode 100644 stdlib/doc/sphinx/introduction.rst delete mode 100644 stdlib/doc/sphinx/language/coq-library.rst delete mode 100644 stdlib/doc/sphinx/license.rst delete mode 100644 stdlib/doc/sphinx/refman-preamble.rst delete mode 100644 stdlib/doc/sphinx/refman-preamble.sty delete mode 100644 stdlib/doc/sphinx/zebibliography.html.rst delete mode 100644 stdlib/doc/sphinx/zebibliography.latex.rst delete mode 100644 stdlib/doc/stdlib/Library.tex delete mode 100644 stdlib/doc/stdlib/dune delete mode 100644 stdlib/doc/stdlib/hidden-files delete mode 100644 stdlib/doc/stdlib/index-list.html.template delete mode 100755 stdlib/doc/stdlib/make-library-index delete mode 100644 stdlib/doc/tools/coqrst/__init__.py delete mode 100644 stdlib/doc/tools/coqrst/checkdeps.py delete mode 100644 stdlib/doc/tools/coqrst/coqdoc/__init__.py delete mode 100644 stdlib/doc/tools/coqrst/coqdoc/main.py delete mode 100644 stdlib/doc/tools/coqrst/coqdomain.py delete mode 100644 stdlib/doc/tools/coqrst/notations/CoqNotations.ttf delete mode 100644 stdlib/doc/tools/coqrst/notations/Makefile delete mode 100644 stdlib/doc/tools/coqrst/notations/TacticNotations.g delete mode 100644 stdlib/doc/tools/coqrst/notations/TacticNotations.tokens delete mode 100644 stdlib/doc/tools/coqrst/notations/TacticNotationsLexer.py delete mode 100644 stdlib/doc/tools/coqrst/notations/TacticNotationsLexer.tokens delete mode 100644 stdlib/doc/tools/coqrst/notations/TacticNotationsParser.py delete mode 100644 stdlib/doc/tools/coqrst/notations/TacticNotationsVisitor.py delete mode 100644 stdlib/doc/tools/coqrst/notations/UbuntuMono-B.ttf delete mode 100644 stdlib/doc/tools/coqrst/notations/__init__.py delete mode 100755 stdlib/doc/tools/coqrst/notations/fontsupport.py delete mode 100644 stdlib/doc/tools/coqrst/notations/html.py delete mode 100644 stdlib/doc/tools/coqrst/notations/parsing.py delete mode 100644 stdlib/doc/tools/coqrst/notations/plain.py delete mode 100644 stdlib/doc/tools/coqrst/notations/regexp.py delete mode 100644 stdlib/doc/tools/coqrst/notations/sphinx.py delete mode 100755 stdlib/doc/tools/coqrst/regen_readme.py delete mode 100644 stdlib/doc/tools/coqrst/repl/__init__.py delete mode 100644 stdlib/doc/tools/coqrst/repl/ansicolors.py delete mode 100644 stdlib/doc/tools/coqrst/repl/coqtop.py delete mode 100644 stdlib/dune-project delete mode 100644 stdlib/rocq-stdlib.opam delete mode 100644 stdlib/rocq-stdlib.opam.template delete mode 100644 stdlib/test-suite/.csdp.cache.test-suite delete mode 100644 stdlib/test-suite/Makefile delete mode 100644 stdlib/test-suite/README.md delete mode 100644 stdlib/test-suite/_CoqProject delete mode 100644 stdlib/test-suite/bugs/bug_10025.v delete mode 100644 stdlib/test-suite/bugs/bug_10407.v delete mode 100644 stdlib/test-suite/bugs/bug_10533.v delete mode 100644 stdlib/test-suite/bugs/bug_11030.v delete mode 100644 stdlib/test-suite/bugs/bug_11321.v delete mode 100644 stdlib/test-suite/bugs/bug_11890.v delete mode 100644 stdlib/test-suite/bugs/bug_12257.v delete mode 100644 stdlib/test-suite/bugs/bug_1243.v delete mode 100644 stdlib/test-suite/bugs/bug_12860.v delete mode 100644 stdlib/test-suite/bugs/bug_12889.v delete mode 100644 stdlib/test-suite/bugs/bug_12907.v delete mode 100644 stdlib/test-suite/bugs/bug_13307.v delete mode 100644 stdlib/test-suite/bugs/bug_1362.v delete mode 100644 stdlib/test-suite/bugs/bug_13698.v delete mode 100644 stdlib/test-suite/bugs/bug_13979.v delete mode 100644 stdlib/test-suite/bugs/bug_1414.v delete mode 100644 stdlib/test-suite/bugs/bug_14374.v delete mode 100644 stdlib/test-suite/bugs/bug_1448.v delete mode 100644 stdlib/test-suite/bugs/bug_14731.v delete mode 100644 stdlib/test-suite/bugs/bug_15043.v delete mode 100644 stdlib/test-suite/bugs/bug_15568.v delete mode 100644 stdlib/test-suite/bugs/bug_1584.v delete mode 100644 stdlib/test-suite/bugs/bug_16043.v delete mode 100644 stdlib/test-suite/bugs/bug_1614.v delete mode 100644 stdlib/test-suite/bugs/bug_1618.v delete mode 100644 stdlib/test-suite/bugs/bug_16181.v delete mode 100644 stdlib/test-suite/bugs/bug_16728.v delete mode 100644 stdlib/test-suite/bugs/bug_16738.v delete mode 100644 stdlib/test-suite/bugs/bug_16803.v delete mode 100644 stdlib/test-suite/bugs/bug_16906.v delete mode 100644 stdlib/test-suite/bugs/bug_16960.v delete mode 100644 stdlib/test-suite/bugs/bug_1738.v delete mode 100644 stdlib/test-suite/bugs/bug_17423.v delete mode 100644 stdlib/test-suite/bugs/bug_17466_3.v delete mode 100644 stdlib/test-suite/bugs/bug_17584.v delete mode 100644 stdlib/test-suite/bugs/bug_1779.v delete mode 100644 stdlib/test-suite/bugs/bug_1784.v delete mode 100644 stdlib/test-suite/bugs/bug_17936.v delete mode 100644 stdlib/test-suite/bugs/bug_17960.v delete mode 100644 stdlib/test-suite/bugs/bug_17983.v delete mode 100644 stdlib/test-suite/bugs/bug_18151.v delete mode 100644 stdlib/test-suite/bugs/bug_18260_1.v delete mode 100644 stdlib/test-suite/bugs/bug_1844.v delete mode 100644 stdlib/test-suite/bugs/bug_1859.v delete mode 100644 stdlib/test-suite/bugs/bug_18680.v delete mode 100644 stdlib/test-suite/bugs/bug_18850.v delete mode 100644 stdlib/test-suite/bugs/bug_18920.v delete mode 100644 stdlib/test-suite/bugs/bug_1912.v delete mode 100644 stdlib/test-suite/bugs/bug_1935.v delete mode 100644 stdlib/test-suite/bugs/bug_1956.v delete mode 100644 stdlib/test-suite/bugs/bug_1962.v delete mode 100644 stdlib/test-suite/bugs/bug_1963.v delete mode 100644 stdlib/test-suite/bugs/bug_2016.v delete mode 100644 stdlib/test-suite/bugs/bug_2083.v delete mode 100644 stdlib/test-suite/bugs/bug_2136.v delete mode 100644 stdlib/test-suite/bugs/bug_2137.v delete mode 100644 stdlib/test-suite/bugs/bug_2141.v delete mode 100644 stdlib/test-suite/bugs/bug_2145.v delete mode 100644 stdlib/test-suite/bugs/bug_2281.v delete mode 100644 stdlib/test-suite/bugs/bug_2347.v delete mode 100644 stdlib/test-suite/bugs/bug_2388.v delete mode 100644 stdlib/test-suite/bugs/bug_2393.v delete mode 100644 stdlib/test-suite/bugs/bug_2456.v delete mode 100644 stdlib/test-suite/bugs/bug_2464.v delete mode 100644 stdlib/test-suite/bugs/bug_2467.v delete mode 100644 stdlib/test-suite/bugs/bug_2473.v delete mode 100644 stdlib/test-suite/bugs/bug_2586.v delete mode 100644 stdlib/test-suite/bugs/bug_2590.v delete mode 100644 stdlib/test-suite/bugs/bug_2613.v delete mode 100644 stdlib/test-suite/bugs/bug_2668.v delete mode 100644 stdlib/test-suite/bugs/bug_2729.v delete mode 100644 stdlib/test-suite/bugs/bug_2734.v delete mode 100644 stdlib/test-suite/bugs/bug_2814.v delete mode 100644 stdlib/test-suite/bugs/bug_2830.v delete mode 100644 stdlib/test-suite/bugs/bug_2883.v delete mode 100644 stdlib/test-suite/bugs/bug_2900.v delete mode 100644 stdlib/test-suite/bugs/bug_3036.v delete mode 100644 stdlib/test-suite/bugs/bug_3037.v delete mode 100644 stdlib/test-suite/bugs/bug_3164.v delete mode 100644 stdlib/test-suite/bugs/bug_3258.v delete mode 100644 stdlib/test-suite/bugs/bug_3344.v delete mode 100644 stdlib/test-suite/bugs/bug_3350.v delete mode 100644 stdlib/test-suite/bugs/bug_3652.v delete mode 100644 stdlib/test-suite/bugs/bug_3786.v delete mode 100644 stdlib/test-suite/bugs/bug_3938.v delete mode 100644 stdlib/test-suite/bugs/bug_3978.v delete mode 100644 stdlib/test-suite/bugs/bug_4035.v delete mode 100644 stdlib/test-suite/bugs/bug_4057.v delete mode 100644 stdlib/test-suite/bugs/bug_4132.v delete mode 100644 stdlib/test-suite/bugs/bug_4151.v delete mode 100644 stdlib/test-suite/bugs/bug_4187.v delete mode 100644 stdlib/test-suite/bugs/bug_4232.v delete mode 100644 stdlib/test-suite/bugs/bug_4280.v delete mode 100644 stdlib/test-suite/bugs/bug_4306.v delete mode 100644 stdlib/test-suite/bugs/bug_4397.v delete mode 100644 stdlib/test-suite/bugs/bug_4433.v delete mode 100644 stdlib/test-suite/bugs/bug_4456.v delete mode 100644 stdlib/test-suite/bugs/bug_4684.v delete mode 100644 stdlib/test-suite/bugs/bug_4717.v delete mode 100644 stdlib/test-suite/bugs/bug_4725.v delete mode 100644 stdlib/test-suite/bugs/bug_4763.v delete mode 100644 stdlib/test-suite/bugs/bug_4785.v delete mode 100644 stdlib/test-suite/bugs/bug_4852.v delete mode 100644 stdlib/test-suite/bugs/bug_4858.v delete mode 100644 stdlib/test-suite/bugs/bug_4863.v delete mode 100644 stdlib/test-suite/bugs/bug_4880.v delete mode 100644 stdlib/test-suite/bugs/bug_5019.v delete mode 100644 stdlib/test-suite/bugs/bug_5066.v delete mode 100644 stdlib/test-suite/bugs/bug_5096.v delete mode 100644 stdlib/test-suite/bugs/bug_5123.v delete mode 100644 stdlib/test-suite/bugs/bug_5161.v delete mode 100644 stdlib/test-suite/bugs/bug_5208.v delete mode 100644 stdlib/test-suite/bugs/bug_5315.v delete mode 100644 stdlib/test-suite/bugs/bug_5359.v delete mode 100644 stdlib/test-suite/bugs/bug_5445.v delete mode 100644 stdlib/test-suite/bugs/bug_5493.v delete mode 100644 stdlib/test-suite/bugs/bug_5521.v delete mode 100644 stdlib/test-suite/bugs/bug_5618.v delete mode 100644 stdlib/test-suite/bugs/bug_5692.v delete mode 100644 stdlib/test-suite/bugs/bug_5713.v delete mode 100644 stdlib/test-suite/bugs/bug_5744.v delete mode 100644 stdlib/test-suite/bugs/bug_5777.v delete mode 100644 stdlib/test-suite/bugs/bug_6191.v delete mode 100644 stdlib/test-suite/bugs/bug_6378.v delete mode 100644 stdlib/test-suite/bugs/bug_6529.v delete mode 100644 stdlib/test-suite/bugs/bug_7017.v delete mode 100644 stdlib/test-suite/bugs/bug_8119.v delete mode 100644 stdlib/test-suite/bugs/bug_8121.v delete mode 100644 stdlib/test-suite/bugs/bug_8459.v delete mode 100644 stdlib/test-suite/bugs/bug_9201.v delete mode 100644 stdlib/test-suite/bugs/bug_9268.v delete mode 100644 stdlib/test-suite/bugs/bug_9512.v delete mode 100644 stdlib/test-suite/bugs/bug_9580.v delete mode 100644 stdlib/test-suite/bugs/bug_9652.v delete mode 100644 stdlib/test-suite/bugs/bug_9741.v delete mode 100644 stdlib/test-suite/bugs/bug_9851.v delete mode 100644 stdlib/test-suite/complexity/ConstructiveCauchyRealsPerformance.v delete mode 100644 stdlib/test-suite/complexity/bug_13227_1.v delete mode 100644 stdlib/test-suite/complexity/bug_13227_2.v delete mode 100644 stdlib/test-suite/complexity/bug_13227_3.v delete mode 100644 stdlib/test-suite/complexity/bug_13227_4.v delete mode 100644 stdlib/test-suite/complexity/bug_13227_5.v delete mode 100644 stdlib/test-suite/complexity/bug_13227_6.v delete mode 100644 stdlib/test-suite/complexity/pretyping.v delete mode 100644 stdlib/test-suite/complexity/ring.v delete mode 100644 stdlib/test-suite/complexity/ring2.v delete mode 100644 stdlib/test-suite/complexity/vm_extgcd.v delete mode 100644 stdlib/test-suite/ltac2/notations.v delete mode 100644 stdlib/test-suite/ltac2/preterm_antiquot.v delete mode 100644 stdlib/test-suite/micromega/bertot.v delete mode 100644 stdlib/test-suite/micromega/bound.v delete mode 100644 stdlib/test-suite/micromega/bug_10158.v delete mode 100644 stdlib/test-suite/micromega/bug_11089.v delete mode 100644 stdlib/test-suite/micromega/bug_11191a.v delete mode 100644 stdlib/test-suite/micromega/bug_11191b.v delete mode 100644 stdlib/test-suite/micromega/bug_11270.v delete mode 100644 stdlib/test-suite/micromega/bug_11436.v delete mode 100644 stdlib/test-suite/micromega/bug_11656.v delete mode 100644 stdlib/test-suite/micromega/bug_12184.v delete mode 100644 stdlib/test-suite/micromega/bug_12210.v delete mode 100644 stdlib/test-suite/micromega/bug_12790.v delete mode 100644 stdlib/test-suite/micromega/bug_12791.v delete mode 100644 stdlib/test-suite/micromega/bug_13227_1.v delete mode 100644 stdlib/test-suite/micromega/bug_13794.v delete mode 100644 stdlib/test-suite/micromega/bug_14054.v delete mode 100644 stdlib/test-suite/micromega/bug_14604.v delete mode 100644 stdlib/test-suite/micromega/bug_15481.v delete mode 100644 stdlib/test-suite/micromega/bug_15583.v delete mode 100644 stdlib/test-suite/micromega/bug_15791.v delete mode 100644 stdlib/test-suite/micromega/bug_18158.v delete mode 100644 stdlib/test-suite/micromega/bug_9162.v delete mode 100644 stdlib/test-suite/micromega/div_mod.v delete mode 100644 stdlib/test-suite/micromega/evars_loops_in_8_10_fixed_8_11.v delete mode 100644 stdlib/test-suite/micromega/example.v delete mode 100644 stdlib/test-suite/micromega/example_nia.v delete mode 100644 stdlib/test-suite/micromega/heap3_vcgen_25.v delete mode 100644 stdlib/test-suite/micromega/non_lin_ci.v delete mode 100644 stdlib/test-suite/micromega/qexample.v delete mode 100644 stdlib/test-suite/micromega/reify_bool.v delete mode 100644 stdlib/test-suite/micromega/rexample.v delete mode 100644 stdlib/test-suite/micromega/rsyntax.v delete mode 100644 stdlib/test-suite/micromega/sint63.v delete mode 100644 stdlib/test-suite/micromega/square.v delete mode 100644 stdlib/test-suite/micromega/uint63.v delete mode 100644 stdlib/test-suite/micromega/witness_tactics.v delete mode 100644 stdlib/test-suite/micromega/zify.v delete mode 100644 stdlib/test-suite/micromega/zomicron.v delete mode 100755 stdlib/test-suite/misc/7595.sh delete mode 100644 stdlib/test-suite/misc/7595/FOO.v delete mode 100644 stdlib/test-suite/misc/7595/base.v delete mode 100644 stdlib/test-suite/misc/PStringExtraction.out delete mode 100755 stdlib/test-suite/misc/PStringExtraction.sh delete mode 100644 stdlib/test-suite/misc/PStringExtraction.v delete mode 100644 stdlib/test-suite/modules/Nat.v delete mode 100644 stdlib/test-suite/modules/PO.v delete mode 100644 stdlib/test-suite/modules/_CoqProject delete mode 100644 stdlib/test-suite/output/BinaryPrintingNotations.out delete mode 100644 stdlib/test-suite/output/BinaryPrintingNotations.v delete mode 100644 stdlib/test-suite/output/Binder.out delete mode 100644 stdlib/test-suite/output/Binder.v delete mode 100644 stdlib/test-suite/output/CoercionsString.out delete mode 100644 stdlib/test-suite/output/CoercionsString.v delete mode 100644 stdlib/test-suite/output/DependentInductionErrors.out delete mode 100644 stdlib/test-suite/output/DependentInductionErrors.v delete mode 100644 stdlib/test-suite/output/ExtractionString.out delete mode 100644 stdlib/test-suite/output/ExtractionString.v delete mode 100644 stdlib/test-suite/output/Extraction_Haskell_String_12258.out delete mode 100644 stdlib/test-suite/output/Extraction_Haskell_String_12258.v delete mode 100644 stdlib/test-suite/output/Fixpoint.out delete mode 100644 stdlib/test-suite/output/Fixpoint.v delete mode 100644 stdlib/test-suite/output/FloatExtraction.out delete mode 100644 stdlib/test-suite/output/FloatExtraction.v delete mode 100644 stdlib/test-suite/output/FunExt.out delete mode 100644 stdlib/test-suite/output/FunExt.v delete mode 100644 stdlib/test-suite/output/Function.out delete mode 100644 stdlib/test-suite/output/Function.v delete mode 100644 stdlib/test-suite/output/InfoMicromega.out delete mode 100644 stdlib/test-suite/output/InfoMicromega.v delete mode 100644 stdlib/test-suite/output/Intuition.out delete mode 100644 stdlib/test-suite/output/Intuition.v delete mode 100644 stdlib/test-suite/output/MExtraction.out delete mode 100644 stdlib/test-suite/output/MExtraction.v delete mode 100644 stdlib/test-suite/output/NNumberSyntax.out delete mode 100644 stdlib/test-suite/output/NNumberSyntax.v delete mode 100644 stdlib/test-suite/output/NoAxiomFromR.out delete mode 100644 stdlib/test-suite/output/NoAxiomFromR.v delete mode 100644 stdlib/test-suite/output/NotationSyntax.out delete mode 100644 stdlib/test-suite/output/NotationSyntax.v delete mode 100644 stdlib/test-suite/output/NotationsCoercionsString.out delete mode 100644 stdlib/test-suite/output/NotationsCoercionsString.v delete mode 100644 stdlib/test-suite/output/NotationsZArith.out delete mode 100644 stdlib/test-suite/output/NotationsZArith.v delete mode 100644 stdlib/test-suite/output/PosSyntax.out delete mode 100644 stdlib/test-suite/output/PosSyntax.v delete mode 100644 stdlib/test-suite/output/PrintAssumptionsArith.out delete mode 100644 stdlib/test-suite/output/PrintAssumptionsArith.v delete mode 100644 stdlib/test-suite/output/QArithSyntax.out delete mode 100644 stdlib/test-suite/output/QArithSyntax.v delete mode 100644 stdlib/test-suite/output/RealNumberSyntax.out delete mode 100644 stdlib/test-suite/output/RealNumberSyntax.v delete mode 100644 stdlib/test-suite/output/Search_2.out delete mode 100644 stdlib/test-suite/output/Search_2.v delete mode 100644 stdlib/test-suite/output/Search_3.out delete mode 100644 stdlib/test-suite/output/Search_3.v delete mode 100644 stdlib/test-suite/output/Sint63NumberSyntax.out delete mode 100644 stdlib/test-suite/output/Sint63NumberSyntax.v delete mode 100644 stdlib/test-suite/output/StringSyntax.out delete mode 100644 stdlib/test-suite/output/StringSyntax.v delete mode 100644 stdlib/test-suite/output/StringSyntaxPrimitive.out delete mode 100644 stdlib/test-suite/output/StringSyntaxPrimitive.v delete mode 100644 stdlib/test-suite/output/Unicode.out delete mode 100644 stdlib/test-suite/output/Unicode.v delete mode 100644 stdlib/test-suite/output/ZNumberSyntax.out delete mode 100644 stdlib/test-suite/output/ZNumberSyntax.v delete mode 100644 stdlib/test-suite/output/allBytes.out delete mode 100644 stdlib/test-suite/output/allBytes.v delete mode 100644 stdlib/test-suite/output/btauto_counterexample.out delete mode 100644 stdlib/test-suite/output/btauto_counterexample.v delete mode 100644 stdlib/test-suite/output/bug_13942.out delete mode 100644 stdlib/test-suite/output/bug_13942.v delete mode 100644 stdlib/test-suite/output/bug_15709.out delete mode 100644 stdlib/test-suite/output/bug_15709.v delete mode 100644 stdlib/test-suite/output/bug_19702.out delete mode 100644 stdlib/test-suite/output/bug_19702.v delete mode 100644 stdlib/test-suite/output/bug_9370.out delete mode 100644 stdlib/test-suite/output/bug_9370.v delete mode 100644 stdlib/test-suite/output/primitive_tokens_string.out delete mode 100644 stdlib/test-suite/output/primitive_tokens_string.v delete mode 100644 stdlib/test-suite/output/simpl.out delete mode 100644 stdlib/test-suite/output/simpl.v delete mode 100644 stdlib/test-suite/output/sint63NumberNotation.out delete mode 100644 stdlib/test-suite/output/sint63NumberNotation.v delete mode 100644 stdlib/test-suite/prerequisite/admit.v delete mode 100644 stdlib/test-suite/prerequisite/make_notation.v delete mode 100755 stdlib/test-suite/report.sh delete mode 100644 stdlib/test-suite/stm/Nijmegen_QArithSternBrocot_Zaux.v delete mode 100644 stdlib/test-suite/success/Abstract.v delete mode 100644 stdlib/test-suite/success/DiscrR.v delete mode 100644 stdlib/test-suite/success/EquivDec.v delete mode 100644 stdlib/test-suite/success/Field.v delete mode 100644 stdlib/test-suite/success/Funind.v delete mode 100644 stdlib/test-suite/success/Injection.v delete mode 100644 stdlib/test-suite/success/LraTest.v delete mode 100644 stdlib/test-suite/success/MatchFail.v delete mode 100644 stdlib/test-suite/success/NatRing.v delete mode 100644 stdlib/test-suite/success/Nia.v delete mode 100644 stdlib/test-suite/success/Nsatz.v delete mode 100644 stdlib/test-suite/success/NumberScopes.v delete mode 100644 stdlib/test-suite/success/Omega.v delete mode 100644 stdlib/test-suite/success/Omega0.v delete mode 100644 stdlib/test-suite/success/Omega2.v delete mode 100644 stdlib/test-suite/success/OmegaPre.v delete mode 100644 stdlib/test-suite/success/PrintSortedUniverses.v delete mode 100644 stdlib/test-suite/success/ProgramCases.v delete mode 100644 stdlib/test-suite/success/ProgramWf.v delete mode 100644 stdlib/test-suite/success/ProgramWfPoly.v delete mode 100644 stdlib/test-suite/success/ROmega.v delete mode 100644 stdlib/test-suite/success/ROmega0.v delete mode 100644 stdlib/test-suite/success/ROmega2.v delete mode 100644 stdlib/test-suite/success/ROmega4.v delete mode 100644 stdlib/test-suite/success/ROmegaPre.v delete mode 100644 stdlib/test-suite/success/RecTutorial.v delete mode 100644 stdlib/test-suite/success/Record.v delete mode 100644 stdlib/test-suite/success/Reg.v delete mode 100644 stdlib/test-suite/success/SchemeEqualityZArith.v delete mode 100644 stdlib/test-suite/success/TestRefine.v delete mode 100644 stdlib/test-suite/success/ZModulo.v delete mode 100644 stdlib/test-suite/success/add_field_pre_post.v delete mode 100644 stdlib/test-suite/success/apply.v delete mode 100644 stdlib/test-suite/success/btauto.v delete mode 100644 stdlib/test-suite/success/conv_pbs.v delete mode 100644 stdlib/test-suite/success/dependentind.v delete mode 100644 stdlib/test-suite/success/extraction.v delete mode 100644 stdlib/test-suite/success/extraction_bigint.v delete mode 100644 stdlib/test-suite/success/fix.v delete mode 100644 stdlib/test-suite/success/import_lib.v delete mode 100644 stdlib/test-suite/success/programequality.v delete mode 100644 stdlib/test-suite/success/rewrite_Proper_map.v delete mode 100644 stdlib/test-suite/success/rewrite_dep.v delete mode 100644 stdlib/test-suite/success/search_lia.v delete mode 100644 stdlib/test-suite/success/setoid_ring_module.v delete mode 100644 stdlib/test-suite/success/strong_and_binary_induction.v delete mode 100644 stdlib/test-suite/success/unicode_utf8.v delete mode 100644 stdlib/test-suite/success/unification_delta.v delete mode 100644 stdlib/theories/Arith/Arith.v delete mode 100644 stdlib/theories/Arith/Arith_base.v delete mode 100644 stdlib/theories/Arith/Between.v delete mode 100644 stdlib/theories/Arith/Bool_nat.v delete mode 100644 stdlib/theories/Arith/Cantor.v delete mode 100644 stdlib/theories/Arith/Compare.v delete mode 100644 stdlib/theories/Arith/Compare_dec.v delete mode 100644 stdlib/theories/Arith/EqNat.v delete mode 100644 stdlib/theories/Arith/Euclid.v delete mode 100644 stdlib/theories/Arith/Factorial.v delete mode 100644 stdlib/theories/Arith/PeanoNat.v delete mode 100644 stdlib/theories/Arith/Peano_dec.v delete mode 100644 stdlib/theories/Arith/Wf_nat.v delete mode 100644 stdlib/theories/Array/ArrayAxioms.v delete mode 100644 stdlib/theories/Array/PArray.v delete mode 100644 stdlib/theories/Array/PrimArray.v delete mode 100644 stdlib/theories/BinNums/IntDef.v delete mode 100644 stdlib/theories/BinNums/NatDef.v delete mode 100644 stdlib/theories/BinNums/PosDef.v delete mode 100644 stdlib/theories/Bool/Bool.v delete mode 100644 stdlib/theories/Bool/BoolEq.v delete mode 100644 stdlib/theories/Bool/BoolOrder.v delete mode 100644 stdlib/theories/Bool/Bvector.v delete mode 100644 stdlib/theories/Bool/DecBool.v delete mode 100644 stdlib/theories/Bool/IfProp.v delete mode 100644 stdlib/theories/Bool/Zerob.v delete mode 100644 stdlib/theories/Classes/CEquivalence.v delete mode 100644 stdlib/theories/Classes/CMorphisms.v delete mode 100644 stdlib/theories/Classes/CRelationClasses.v delete mode 100644 stdlib/theories/Classes/DecidableClass.v delete mode 100644 stdlib/theories/Classes/EquivDec.v delete mode 100644 stdlib/theories/Classes/Equivalence.v delete mode 100644 stdlib/theories/Classes/Init.v delete mode 100644 stdlib/theories/Classes/Morphisms.v delete mode 100644 stdlib/theories/Classes/Morphisms_Prop.v delete mode 100644 stdlib/theories/Classes/Morphisms_Relations.v delete mode 100644 stdlib/theories/Classes/RelationClasses.v delete mode 100644 stdlib/theories/Classes/RelationPairs.v delete mode 100644 stdlib/theories/Classes/SetoidClass.v delete mode 100644 stdlib/theories/Classes/SetoidDec.v delete mode 100644 stdlib/theories/Classes/SetoidTactics.v delete mode 100644 stdlib/theories/Compat/AdmitAxiom.v delete mode 100644 stdlib/theories/Compat/Coq818.v delete mode 100644 stdlib/theories/Compat/Coq819.v delete mode 100644 stdlib/theories/Compat/Coq820.v delete mode 100644 stdlib/theories/Compat/README.md delete mode 100644 stdlib/theories/Compat/Stdlib818.v delete mode 100644 stdlib/theories/FSets/FMapAVL.v delete mode 100644 stdlib/theories/FSets/FMapFacts.v delete mode 100644 stdlib/theories/FSets/FMapFullAVL.v delete mode 100644 stdlib/theories/FSets/FMapInterface.v delete mode 100644 stdlib/theories/FSets/FMapList.v delete mode 100644 stdlib/theories/FSets/FMapPositive.v delete mode 100644 stdlib/theories/FSets/FMapWeakList.v delete mode 100644 stdlib/theories/FSets/FMaps.v delete mode 100644 stdlib/theories/FSets/FSetAVL.v delete mode 100644 stdlib/theories/FSets/FSetBridge.v delete mode 100644 stdlib/theories/FSets/FSetCompat.v delete mode 100644 stdlib/theories/FSets/FSetDecide.v delete mode 100644 stdlib/theories/FSets/FSetEqProperties.v delete mode 100644 stdlib/theories/FSets/FSetFacts.v delete mode 100644 stdlib/theories/FSets/FSetInterface.v delete mode 100644 stdlib/theories/FSets/FSetList.v delete mode 100644 stdlib/theories/FSets/FSetPositive.v delete mode 100644 stdlib/theories/FSets/FSetProperties.v delete mode 100644 stdlib/theories/FSets/FSetToFiniteSet.v delete mode 100644 stdlib/theories/FSets/FSetWeakList.v delete mode 100644 stdlib/theories/FSets/FSets.v delete mode 100644 stdlib/theories/Floats/FloatAxioms.v delete mode 100644 stdlib/theories/Floats/FloatClass.v delete mode 100644 stdlib/theories/Floats/FloatLemmas.v delete mode 100644 stdlib/theories/Floats/FloatOps.v delete mode 100644 stdlib/theories/Floats/Floats.v delete mode 100644 stdlib/theories/Floats/PrimFloat.v delete mode 100644 stdlib/theories/Floats/SpecFloat.v delete mode 100644 stdlib/theories/Init/Byte.v delete mode 100644 stdlib/theories/Init/Datatypes.v delete mode 100644 stdlib/theories/Init/Decimal.v delete mode 100644 stdlib/theories/Init/Hexadecimal.v delete mode 100644 stdlib/theories/Init/Logic.v delete mode 100644 stdlib/theories/Init/Ltac.v delete mode 100644 stdlib/theories/Init/Nat.v delete mode 100644 stdlib/theories/Init/Notations.v delete mode 100644 stdlib/theories/Init/Number.v delete mode 100644 stdlib/theories/Init/Peano.v delete mode 100644 stdlib/theories/Init/Prelude.v delete mode 100644 stdlib/theories/Init/Specif.v delete mode 100644 stdlib/theories/Init/Sumbool.v delete mode 100644 stdlib/theories/Init/Tactics.v delete mode 100644 stdlib/theories/Init/Tauto.v delete mode 100644 stdlib/theories/Init/Wf.v delete mode 100644 stdlib/theories/Lists/List.v delete mode 100644 stdlib/theories/Lists/ListDec.v delete mode 100644 stdlib/theories/Lists/ListDef.v delete mode 100644 stdlib/theories/Lists/ListSet.v delete mode 100644 stdlib/theories/Lists/ListTactics.v delete mode 100644 stdlib/theories/Lists/SetoidList.v delete mode 100644 stdlib/theories/Lists/SetoidPermutation.v delete mode 100644 stdlib/theories/Lists/StreamMemo.v delete mode 100644 stdlib/theories/Lists/Streams.v delete mode 100644 stdlib/theories/Logic/Adjointification.v delete mode 100644 stdlib/theories/Logic/Berardi.v delete mode 100644 stdlib/theories/Logic/ChoiceFacts.v delete mode 100644 stdlib/theories/Logic/Classical.v delete mode 100644 stdlib/theories/Logic/ClassicalChoice.v delete mode 100644 stdlib/theories/Logic/ClassicalDescription.v delete mode 100644 stdlib/theories/Logic/ClassicalEpsilon.v delete mode 100644 stdlib/theories/Logic/ClassicalFacts.v delete mode 100644 stdlib/theories/Logic/ClassicalUniqueChoice.v delete mode 100644 stdlib/theories/Logic/Classical_Pred_Type.v delete mode 100644 stdlib/theories/Logic/Classical_Prop.v delete mode 100644 stdlib/theories/Logic/ConstructiveEpsilon.v delete mode 100644 stdlib/theories/Logic/Decidable.v delete mode 100644 stdlib/theories/Logic/Description.v delete mode 100644 stdlib/theories/Logic/Diaconescu.v delete mode 100644 stdlib/theories/Logic/Epsilon.v delete mode 100644 stdlib/theories/Logic/Eqdep.v delete mode 100644 stdlib/theories/Logic/EqdepFacts.v delete mode 100644 stdlib/theories/Logic/Eqdep_dec.v delete mode 100644 stdlib/theories/Logic/ExtensionalFunctionRepresentative.v delete mode 100644 stdlib/theories/Logic/ExtensionalityFacts.v delete mode 100644 stdlib/theories/Logic/FinFun.v delete mode 100644 stdlib/theories/Logic/FunctionalExtensionality.v delete mode 100644 stdlib/theories/Logic/HLevels.v delete mode 100644 stdlib/theories/Logic/Hurkens.v delete mode 100644 stdlib/theories/Logic/IndefiniteDescription.v delete mode 100644 stdlib/theories/Logic/JMeq.v delete mode 100644 stdlib/theories/Logic/ProofIrrelevance.v delete mode 100644 stdlib/theories/Logic/ProofIrrelevanceFacts.v delete mode 100644 stdlib/theories/Logic/PropExtensionality.v delete mode 100644 stdlib/theories/Logic/PropExtensionalityFacts.v delete mode 100644 stdlib/theories/Logic/PropFacts.v delete mode 100644 stdlib/theories/Logic/RelationalChoice.v delete mode 100644 stdlib/theories/Logic/SetIsType.v delete mode 100644 stdlib/theories/Logic/SetoidChoice.v delete mode 100644 stdlib/theories/Logic/StrictProp.v delete mode 100644 stdlib/theories/Logic/WKL.v delete mode 100644 stdlib/theories/Logic/WeakFan.v delete mode 100644 stdlib/theories/MSets/MSetAVL.v delete mode 100644 stdlib/theories/MSets/MSetDecide.v delete mode 100644 stdlib/theories/MSets/MSetEqProperties.v delete mode 100644 stdlib/theories/MSets/MSetFacts.v delete mode 100644 stdlib/theories/MSets/MSetGenTree.v delete mode 100644 stdlib/theories/MSets/MSetInterface.v delete mode 100644 stdlib/theories/MSets/MSetList.v delete mode 100644 stdlib/theories/MSets/MSetPositive.v delete mode 100644 stdlib/theories/MSets/MSetProperties.v delete mode 100644 stdlib/theories/MSets/MSetRBT.v delete mode 100644 stdlib/theories/MSets/MSetToFiniteSet.v delete mode 100644 stdlib/theories/MSets/MSetWeakList.v delete mode 100644 stdlib/theories/MSets/MSets.v delete mode 100644 stdlib/theories/NArith/BinNat.v delete mode 100644 stdlib/theories/NArith/BinNatDef.v delete mode 100644 stdlib/theories/NArith/NArith.v delete mode 100644 stdlib/theories/NArith/Ndec.v delete mode 100644 stdlib/theories/NArith/Ndiv_def.v delete mode 100644 stdlib/theories/NArith/Ngcd_def.v delete mode 100644 stdlib/theories/NArith/Nnat.v delete mode 100644 stdlib/theories/NArith/Nsqrt_def.v delete mode 100644 stdlib/theories/Numbers/AltBinNotations.v delete mode 100644 stdlib/theories/Numbers/BinNums.v delete mode 100644 stdlib/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v delete mode 100644 stdlib/theories/Numbers/Cyclic/Abstract/DoubleType.v delete mode 100644 stdlib/theories/Numbers/Cyclic/Abstract/NZCyclic.v delete mode 100644 stdlib/theories/Numbers/Cyclic/Int63/CarryType.v delete mode 100644 stdlib/theories/Numbers/Cyclic/Int63/Cyclic63.v delete mode 100644 stdlib/theories/Numbers/Cyclic/Int63/PrimInt63.v delete mode 100644 stdlib/theories/Numbers/Cyclic/Int63/Ring63.v delete mode 100644 stdlib/theories/Numbers/Cyclic/Int63/Sint63.v delete mode 100644 stdlib/theories/Numbers/Cyclic/Int63/Sint63Axioms.v delete mode 100644 stdlib/theories/Numbers/Cyclic/Int63/Uint63.v delete mode 100644 stdlib/theories/Numbers/Cyclic/Int63/Uint63Axioms.v delete mode 100644 stdlib/theories/Numbers/DecimalFacts.v delete mode 100644 stdlib/theories/Numbers/DecimalN.v delete mode 100644 stdlib/theories/Numbers/DecimalNat.v delete mode 100644 stdlib/theories/Numbers/DecimalPos.v delete mode 100644 stdlib/theories/Numbers/DecimalQ.v delete mode 100644 stdlib/theories/Numbers/DecimalR.v delete mode 100644 stdlib/theories/Numbers/DecimalString.v delete mode 100644 stdlib/theories/Numbers/DecimalZ.v delete mode 100644 stdlib/theories/Numbers/HexadecimalFacts.v delete mode 100644 stdlib/theories/Numbers/HexadecimalN.v delete mode 100644 stdlib/theories/Numbers/HexadecimalNat.v delete mode 100644 stdlib/theories/Numbers/HexadecimalPos.v delete mode 100644 stdlib/theories/Numbers/HexadecimalQ.v delete mode 100644 stdlib/theories/Numbers/HexadecimalR.v delete mode 100644 stdlib/theories/Numbers/HexadecimalString.v delete mode 100644 stdlib/theories/Numbers/HexadecimalZ.v delete mode 100644 stdlib/theories/Numbers/Integer/Abstract/ZAdd.v delete mode 100644 stdlib/theories/Numbers/Integer/Abstract/ZAddOrder.v delete mode 100644 stdlib/theories/Numbers/Integer/Abstract/ZAxioms.v delete mode 100644 stdlib/theories/Numbers/Integer/Abstract/ZBase.v delete mode 100644 stdlib/theories/Numbers/Integer/Abstract/ZBits.v delete mode 100644 stdlib/theories/Numbers/Integer/Abstract/ZDivEucl.v delete mode 100644 stdlib/theories/Numbers/Integer/Abstract/ZDivFloor.v delete mode 100644 stdlib/theories/Numbers/Integer/Abstract/ZDivTrunc.v delete mode 100644 stdlib/theories/Numbers/Integer/Abstract/ZGcd.v delete mode 100644 stdlib/theories/Numbers/Integer/Abstract/ZLcm.v delete mode 100644 stdlib/theories/Numbers/Integer/Abstract/ZLt.v delete mode 100644 stdlib/theories/Numbers/Integer/Abstract/ZMaxMin.v delete mode 100644 stdlib/theories/Numbers/Integer/Abstract/ZMul.v delete mode 100644 stdlib/theories/Numbers/Integer/Abstract/ZMulOrder.v delete mode 100644 stdlib/theories/Numbers/Integer/Abstract/ZParity.v delete mode 100644 stdlib/theories/Numbers/Integer/Abstract/ZPow.v delete mode 100644 stdlib/theories/Numbers/Integer/Abstract/ZProperties.v delete mode 100644 stdlib/theories/Numbers/Integer/Abstract/ZSgnAbs.v delete mode 100644 stdlib/theories/Numbers/Integer/Binary/ZBinary.v delete mode 100644 stdlib/theories/Numbers/Integer/NatPairs/ZNatPairs.v delete mode 100644 stdlib/theories/Numbers/NaryFunctions.v delete mode 100644 stdlib/theories/Numbers/NatInt/NZAdd.v delete mode 100644 stdlib/theories/Numbers/NatInt/NZAddOrder.v delete mode 100644 stdlib/theories/Numbers/NatInt/NZAxioms.v delete mode 100644 stdlib/theories/Numbers/NatInt/NZBase.v delete mode 100644 stdlib/theories/Numbers/NatInt/NZBits.v delete mode 100644 stdlib/theories/Numbers/NatInt/NZDiv.v delete mode 100644 stdlib/theories/Numbers/NatInt/NZDomain.v delete mode 100644 stdlib/theories/Numbers/NatInt/NZGcd.v delete mode 100644 stdlib/theories/Numbers/NatInt/NZLog.v delete mode 100644 stdlib/theories/Numbers/NatInt/NZMul.v delete mode 100644 stdlib/theories/Numbers/NatInt/NZMulOrder.v delete mode 100644 stdlib/theories/Numbers/NatInt/NZOrder.v delete mode 100644 stdlib/theories/Numbers/NatInt/NZParity.v delete mode 100644 stdlib/theories/Numbers/NatInt/NZPow.v delete mode 100644 stdlib/theories/Numbers/NatInt/NZProperties.v delete mode 100644 stdlib/theories/Numbers/NatInt/NZSqrt.v delete mode 100644 stdlib/theories/Numbers/Natural/Abstract/NAdd.v delete mode 100644 stdlib/theories/Numbers/Natural/Abstract/NAddOrder.v delete mode 100644 stdlib/theories/Numbers/Natural/Abstract/NAxioms.v delete mode 100644 stdlib/theories/Numbers/Natural/Abstract/NBase.v delete mode 100644 stdlib/theories/Numbers/Natural/Abstract/NBits.v delete mode 100644 stdlib/theories/Numbers/Natural/Abstract/NDefOps.v delete mode 100644 stdlib/theories/Numbers/Natural/Abstract/NDiv.v delete mode 100644 stdlib/theories/Numbers/Natural/Abstract/NDiv0.v delete mode 100644 stdlib/theories/Numbers/Natural/Abstract/NGcd.v delete mode 100644 stdlib/theories/Numbers/Natural/Abstract/NIso.v delete mode 100644 stdlib/theories/Numbers/Natural/Abstract/NLcm.v delete mode 100644 stdlib/theories/Numbers/Natural/Abstract/NLcm0.v delete mode 100644 stdlib/theories/Numbers/Natural/Abstract/NLog.v delete mode 100644 stdlib/theories/Numbers/Natural/Abstract/NMaxMin.v delete mode 100644 stdlib/theories/Numbers/Natural/Abstract/NMulOrder.v delete mode 100644 stdlib/theories/Numbers/Natural/Abstract/NOrder.v delete mode 100644 stdlib/theories/Numbers/Natural/Abstract/NParity.v delete mode 100644 stdlib/theories/Numbers/Natural/Abstract/NPow.v delete mode 100644 stdlib/theories/Numbers/Natural/Abstract/NProperties.v delete mode 100644 stdlib/theories/Numbers/Natural/Abstract/NSqrt.v delete mode 100644 stdlib/theories/Numbers/Natural/Abstract/NStrongRec.v delete mode 100644 stdlib/theories/Numbers/Natural/Abstract/NSub.v delete mode 100644 stdlib/theories/Numbers/Natural/Binary/NBinary.v delete mode 100644 stdlib/theories/Numbers/NumPrelude.v delete mode 100644 stdlib/theories/PArith/BinPos.v delete mode 100644 stdlib/theories/PArith/BinPosDef.v delete mode 100644 stdlib/theories/PArith/PArith.v delete mode 100644 stdlib/theories/PArith/POrderedType.v delete mode 100644 stdlib/theories/PArith/Pnat.v delete mode 100644 stdlib/theories/Program/Basics.v delete mode 100644 stdlib/theories/Program/Combinators.v delete mode 100644 stdlib/theories/Program/Equality.v delete mode 100644 stdlib/theories/Program/Program.v delete mode 100644 stdlib/theories/Program/Subset.v delete mode 100644 stdlib/theories/Program/Syntax.v delete mode 100644 stdlib/theories/Program/Tactics.v delete mode 100644 stdlib/theories/Program/Utils.v delete mode 100644 stdlib/theories/Program/Wf.v delete mode 100644 stdlib/theories/Program/WfExtensionality.v delete mode 100644 stdlib/theories/QArith/QArith.v delete mode 100644 stdlib/theories/QArith/QArith_base.v delete mode 100644 stdlib/theories/QArith/QOrderedType.v delete mode 100644 stdlib/theories/QArith/Qabs.v delete mode 100644 stdlib/theories/QArith/Qcabs.v delete mode 100644 stdlib/theories/QArith/Qcanon.v delete mode 100644 stdlib/theories/QArith/Qfield.v delete mode 100644 stdlib/theories/QArith/Qminmax.v delete mode 100644 stdlib/theories/QArith/Qpower.v delete mode 100644 stdlib/theories/QArith/Qreals.v delete mode 100644 stdlib/theories/QArith/Qreduction.v delete mode 100644 stdlib/theories/QArith/Qring.v delete mode 100644 stdlib/theories/QArith/Qround.v delete mode 100644 stdlib/theories/Reals/Abstract/ConstructiveAbs.v delete mode 100644 stdlib/theories/Reals/Abstract/ConstructiveLUB.v delete mode 100644 stdlib/theories/Reals/Abstract/ConstructiveLimits.v delete mode 100644 stdlib/theories/Reals/Abstract/ConstructiveMinMax.v delete mode 100644 stdlib/theories/Reals/Abstract/ConstructivePower.v delete mode 100644 stdlib/theories/Reals/Abstract/ConstructiveReals.v delete mode 100644 stdlib/theories/Reals/Abstract/ConstructiveRealsMorphisms.v delete mode 100644 stdlib/theories/Reals/Abstract/ConstructiveSum.v delete mode 100644 stdlib/theories/Reals/Alembert.v delete mode 100644 stdlib/theories/Reals/AltSeries.v delete mode 100644 stdlib/theories/Reals/ArithProp.v delete mode 100644 stdlib/theories/Reals/Binomial.v delete mode 100644 stdlib/theories/Reals/Cauchy/ConstructiveCauchyAbs.v delete mode 100644 stdlib/theories/Reals/Cauchy/ConstructiveCauchyReals.v delete mode 100644 stdlib/theories/Reals/Cauchy/ConstructiveCauchyRealsMult.v delete mode 100644 stdlib/theories/Reals/Cauchy/ConstructiveExtra.v delete mode 100644 stdlib/theories/Reals/Cauchy/ConstructiveRcomplete.v delete mode 100644 stdlib/theories/Reals/Cauchy/PosExtra.v delete mode 100644 stdlib/theories/Reals/Cauchy/QExtra.v delete mode 100644 stdlib/theories/Reals/Cauchy_prod.v delete mode 100644 stdlib/theories/Reals/ClassicalConstructiveReals.v delete mode 100644 stdlib/theories/Reals/ClassicalDedekindReals.v delete mode 100644 stdlib/theories/Reals/Cos_plus.v delete mode 100644 stdlib/theories/Reals/Cos_rel.v delete mode 100644 stdlib/theories/Reals/DiscrR.v delete mode 100644 stdlib/theories/Reals/Exp_prop.v delete mode 100644 stdlib/theories/Reals/Integration.v delete mode 100644 stdlib/theories/Reals/MVT.v delete mode 100644 stdlib/theories/Reals/Machin.v delete mode 100644 stdlib/theories/Reals/NewtonInt.v delete mode 100644 stdlib/theories/Reals/PSeries_reg.v delete mode 100644 stdlib/theories/Reals/PartSum.v delete mode 100644 stdlib/theories/Reals/RIneq.v delete mode 100644 stdlib/theories/Reals/RList.v delete mode 100644 stdlib/theories/Reals/ROrderedType.v delete mode 100644 stdlib/theories/Reals/R_Ifp.v delete mode 100644 stdlib/theories/Reals/R_sqr.v delete mode 100644 stdlib/theories/Reals/R_sqrt.v delete mode 100644 stdlib/theories/Reals/Ranalysis.v delete mode 100644 stdlib/theories/Reals/Ranalysis1.v delete mode 100644 stdlib/theories/Reals/Ranalysis2.v delete mode 100644 stdlib/theories/Reals/Ranalysis3.v delete mode 100644 stdlib/theories/Reals/Ranalysis4.v delete mode 100644 stdlib/theories/Reals/Ranalysis5.v delete mode 100644 stdlib/theories/Reals/Ranalysis_reg.v delete mode 100644 stdlib/theories/Reals/Ratan.v delete mode 100644 stdlib/theories/Reals/Raxioms.v delete mode 100644 stdlib/theories/Reals/Rbase.v delete mode 100644 stdlib/theories/Reals/Rbasic_fun.v delete mode 100644 stdlib/theories/Reals/Rcomplete.v delete mode 100644 stdlib/theories/Reals/Rdefinitions.v delete mode 100644 stdlib/theories/Reals/Rderiv.v delete mode 100644 stdlib/theories/Reals/Reals.v delete mode 100644 stdlib/theories/Reals/Rfunctions.v delete mode 100644 stdlib/theories/Reals/Rgeom.v delete mode 100644 stdlib/theories/Reals/RiemannInt.v delete mode 100644 stdlib/theories/Reals/RiemannInt_SF.v delete mode 100644 stdlib/theories/Reals/Rlimit.v delete mode 100644 stdlib/theories/Reals/Rlogic.v delete mode 100644 stdlib/theories/Reals/Rminmax.v delete mode 100644 stdlib/theories/Reals/Rpow_def.v delete mode 100644 stdlib/theories/Reals/Rpower.v delete mode 100644 stdlib/theories/Reals/Rprod.v delete mode 100644 stdlib/theories/Reals/Rregisternames.v delete mode 100644 stdlib/theories/Reals/Rseries.v delete mode 100644 stdlib/theories/Reals/Rsigma.v delete mode 100644 stdlib/theories/Reals/Rsqrt_def.v delete mode 100644 stdlib/theories/Reals/Rtopology.v delete mode 100644 stdlib/theories/Reals/Rtrigo.v delete mode 100644 stdlib/theories/Reals/Rtrigo1.v delete mode 100644 stdlib/theories/Reals/Rtrigo_alt.v delete mode 100644 stdlib/theories/Reals/Rtrigo_calc.v delete mode 100644 stdlib/theories/Reals/Rtrigo_def.v delete mode 100644 stdlib/theories/Reals/Rtrigo_facts.v delete mode 100644 stdlib/theories/Reals/Rtrigo_fun.v delete mode 100644 stdlib/theories/Reals/Rtrigo_reg.v delete mode 100644 stdlib/theories/Reals/Runcountable.v delete mode 100644 stdlib/theories/Reals/SeqProp.v delete mode 100644 stdlib/theories/Reals/SeqSeries.v delete mode 100644 stdlib/theories/Reals/SplitAbsolu.v delete mode 100644 stdlib/theories/Reals/SplitRmult.v delete mode 100644 stdlib/theories/Reals/Sqrt_reg.v delete mode 100644 stdlib/theories/Relations/Operators_Properties.v delete mode 100644 stdlib/theories/Relations/Relation_Definitions.v delete mode 100644 stdlib/theories/Relations/Relation_Operators.v delete mode 100644 stdlib/theories/Relations/Relations.v delete mode 100644 stdlib/theories/Setoids/Setoid.v delete mode 100644 stdlib/theories/Sets/Classical_sets.v delete mode 100644 stdlib/theories/Sets/Constructive_sets.v delete mode 100644 stdlib/theories/Sets/Cpo.v delete mode 100644 stdlib/theories/Sets/Ensembles.v delete mode 100644 stdlib/theories/Sets/Finite_sets.v delete mode 100644 stdlib/theories/Sets/Finite_sets_facts.v delete mode 100644 stdlib/theories/Sets/Image.v delete mode 100644 stdlib/theories/Sets/Infinite_sets.v delete mode 100644 stdlib/theories/Sets/Integers.v delete mode 100644 stdlib/theories/Sets/Multiset.v delete mode 100644 stdlib/theories/Sets/Partial_Order.v delete mode 100644 stdlib/theories/Sets/Permut.v delete mode 100644 stdlib/theories/Sets/Powerset.v delete mode 100644 stdlib/theories/Sets/Powerset_Classical_facts.v delete mode 100644 stdlib/theories/Sets/Powerset_facts.v delete mode 100644 stdlib/theories/Sets/Relations_1.v delete mode 100644 stdlib/theories/Sets/Relations_1_facts.v delete mode 100644 stdlib/theories/Sets/Relations_2.v delete mode 100644 stdlib/theories/Sets/Relations_2_facts.v delete mode 100644 stdlib/theories/Sets/Relations_3.v delete mode 100644 stdlib/theories/Sets/Relations_3_facts.v delete mode 100644 stdlib/theories/Sets/Uniset.v delete mode 100644 stdlib/theories/Sorting/CPermutation.v delete mode 100644 stdlib/theories/Sorting/Heap.v delete mode 100644 stdlib/theories/Sorting/Mergesort.v delete mode 100644 stdlib/theories/Sorting/PermutEq.v delete mode 100644 stdlib/theories/Sorting/PermutSetoid.v delete mode 100644 stdlib/theories/Sorting/Permutation.v delete mode 100644 stdlib/theories/Sorting/Sorted.v delete mode 100644 stdlib/theories/Sorting/Sorting.v delete mode 100644 stdlib/theories/Strings/Ascii.v delete mode 100644 stdlib/theories/Strings/BinaryString.v delete mode 100644 stdlib/theories/Strings/Byte.v delete mode 100644 stdlib/theories/Strings/HexString.v delete mode 100644 stdlib/theories/Strings/OctalString.v delete mode 100644 stdlib/theories/Strings/PString.v delete mode 100644 stdlib/theories/Strings/PrimString.v delete mode 100644 stdlib/theories/Strings/PrimStringAxioms.v delete mode 100644 stdlib/theories/Strings/String.v delete mode 100644 stdlib/theories/Structures/DecidableType.v delete mode 100644 stdlib/theories/Structures/DecidableTypeEx.v delete mode 100644 stdlib/theories/Structures/Equalities.v delete mode 100644 stdlib/theories/Structures/EqualitiesFacts.v delete mode 100644 stdlib/theories/Structures/GenericMinMax.v delete mode 100644 stdlib/theories/Structures/OrderedType.v delete mode 100644 stdlib/theories/Structures/OrderedTypeAlt.v delete mode 100644 stdlib/theories/Structures/OrderedTypeEx.v delete mode 100644 stdlib/theories/Structures/Orders.v delete mode 100644 stdlib/theories/Structures/OrdersAlt.v delete mode 100644 stdlib/theories/Structures/OrdersEx.v delete mode 100644 stdlib/theories/Structures/OrdersFacts.v delete mode 100644 stdlib/theories/Structures/OrdersLists.v delete mode 100644 stdlib/theories/Structures/OrdersTac.v delete mode 100644 stdlib/theories/Unicode/Utf8.v delete mode 100644 stdlib/theories/Unicode/Utf8_core.v delete mode 100644 stdlib/theories/Vectors/Fin.v delete mode 100644 stdlib/theories/Vectors/Vector.v delete mode 100644 stdlib/theories/Vectors/VectorDef.v delete mode 100644 stdlib/theories/Vectors/VectorEq.v delete mode 100644 stdlib/theories/Vectors/VectorSpec.v delete mode 100644 stdlib/theories/Wellfounded/Disjoint_Union.v delete mode 100644 stdlib/theories/Wellfounded/Inclusion.v delete mode 100644 stdlib/theories/Wellfounded/Inverse_Image.v delete mode 100644 stdlib/theories/Wellfounded/Lexicographic_Exponentiation.v delete mode 100644 stdlib/theories/Wellfounded/Lexicographic_Product.v delete mode 100644 stdlib/theories/Wellfounded/List_Extension.v delete mode 100644 stdlib/theories/Wellfounded/Transitive_Closure.v delete mode 100644 stdlib/theories/Wellfounded/Union.v delete mode 100644 stdlib/theories/Wellfounded/Well_Ordering.v delete mode 100644 stdlib/theories/Wellfounded/Wellfounded.v delete mode 100644 stdlib/theories/ZArith/BinInt.v delete mode 100644 stdlib/theories/ZArith/BinIntDef.v delete mode 100644 stdlib/theories/ZArith/Int.v delete mode 100644 stdlib/theories/ZArith/Wf_Z.v delete mode 100644 stdlib/theories/ZArith/ZArith.v delete mode 100644 stdlib/theories/ZArith/ZArith_base.v delete mode 100644 stdlib/theories/ZArith/ZArith_dec.v delete mode 100644 stdlib/theories/ZArith/Zabs.v delete mode 100644 stdlib/theories/ZArith/Zbitwise.v delete mode 100644 stdlib/theories/ZArith/Zbool.v delete mode 100644 stdlib/theories/ZArith/Zcompare.v delete mode 100644 stdlib/theories/ZArith/Zcomplements.v delete mode 100644 stdlib/theories/ZArith/Zdiv.v delete mode 100644 stdlib/theories/ZArith/Zdiv_facts.v delete mode 100644 stdlib/theories/ZArith/Zeuclid.v delete mode 100644 stdlib/theories/ZArith/Zeven.v delete mode 100644 stdlib/theories/ZArith/Zgcd_alt.v delete mode 100644 stdlib/theories/ZArith/Zhints.v delete mode 100644 stdlib/theories/ZArith/Zmax.v delete mode 100644 stdlib/theories/ZArith/Zmin.v delete mode 100644 stdlib/theories/ZArith/Zminmax.v delete mode 100644 stdlib/theories/ZArith/Zmisc.v delete mode 100644 stdlib/theories/ZArith/Znat.v delete mode 100644 stdlib/theories/ZArith/Znumtheory.v delete mode 100644 stdlib/theories/ZArith/Zorder.v delete mode 100644 stdlib/theories/ZArith/Zpow_alt.v delete mode 100644 stdlib/theories/ZArith/Zpow_def.v delete mode 100644 stdlib/theories/ZArith/Zpow_facts.v delete mode 100644 stdlib/theories/ZArith/Zpower.v delete mode 100644 stdlib/theories/ZArith/Zquot.v delete mode 100644 stdlib/theories/ZArith/Zwf.v delete mode 100644 stdlib/theories/ZArith/auxiliary.v delete mode 100644 stdlib/theories/_CoqProject delete mode 100644 stdlib/theories/btauto/Algebra.v delete mode 100644 stdlib/theories/btauto/Btauto.v delete mode 100644 stdlib/theories/btauto/Reflect.v delete mode 100644 stdlib/theories/derive/Derive.v delete mode 100644 stdlib/theories/dune delete mode 100644 stdlib/theories/extraction/ExtrHaskellBasic.v delete mode 100644 stdlib/theories/extraction/ExtrHaskellNatInt.v delete mode 100644 stdlib/theories/extraction/ExtrHaskellNatInteger.v delete mode 100644 stdlib/theories/extraction/ExtrHaskellNatNum.v delete mode 100644 stdlib/theories/extraction/ExtrHaskellString.v delete mode 100644 stdlib/theories/extraction/ExtrHaskellZInt.v delete mode 100644 stdlib/theories/extraction/ExtrHaskellZInteger.v delete mode 100644 stdlib/theories/extraction/ExtrHaskellZNum.v delete mode 100644 stdlib/theories/extraction/ExtrOCamlFloats.v delete mode 100644 stdlib/theories/extraction/ExtrOCamlInt63.v delete mode 100644 stdlib/theories/extraction/ExtrOCamlPArray.v delete mode 100644 stdlib/theories/extraction/ExtrOCamlPString.v delete mode 100644 stdlib/theories/extraction/ExtrOcamlBasic.v delete mode 100644 stdlib/theories/extraction/ExtrOcamlChar.v delete mode 100644 stdlib/theories/extraction/ExtrOcamlIntConv.v delete mode 100644 stdlib/theories/extraction/ExtrOcamlNatBigInt.v delete mode 100644 stdlib/theories/extraction/ExtrOcamlNatInt.v delete mode 100644 stdlib/theories/extraction/ExtrOcamlNativeString.v delete mode 100644 stdlib/theories/extraction/ExtrOcamlString.v delete mode 100644 stdlib/theories/extraction/ExtrOcamlZBigInt.v delete mode 100644 stdlib/theories/extraction/ExtrOcamlZInt.v delete mode 100644 stdlib/theories/extraction/Extraction.v delete mode 100644 stdlib/theories/funind/FunInd.v delete mode 100644 stdlib/theories/funind/Recdef.v delete mode 100644 stdlib/theories/micromega/DeclConstant.v delete mode 100644 stdlib/theories/micromega/Env.v delete mode 100644 stdlib/theories/micromega/EnvRing.v delete mode 100644 stdlib/theories/micromega/Fourier.v delete mode 100644 stdlib/theories/micromega/Fourier_util.v delete mode 100644 stdlib/theories/micromega/Lia.v delete mode 100644 stdlib/theories/micromega/Lqa.v delete mode 100644 stdlib/theories/micromega/Lra.v delete mode 100644 stdlib/theories/micromega/MExtraction.v delete mode 100644 stdlib/theories/micromega/OrderedRing.v delete mode 100644 stdlib/theories/micromega/Psatz.v delete mode 100644 stdlib/theories/micromega/QMicromega.v delete mode 100644 stdlib/theories/micromega/RMicromega.v delete mode 100644 stdlib/theories/micromega/Refl.v delete mode 100644 stdlib/theories/micromega/RingMicromega.v delete mode 100644 stdlib/theories/micromega/Tauto.v delete mode 100644 stdlib/theories/micromega/VarMap.v delete mode 100644 stdlib/theories/micromega/ZArith_hints.v delete mode 100644 stdlib/theories/micromega/ZCoeff.v delete mode 100644 stdlib/theories/micromega/ZMicromega.v delete mode 100644 stdlib/theories/micromega/Zify.v delete mode 100644 stdlib/theories/micromega/ZifyBool.v delete mode 100644 stdlib/theories/micromega/ZifyClasses.v delete mode 100644 stdlib/theories/micromega/ZifyComparison.v delete mode 100644 stdlib/theories/micromega/ZifyInst.v delete mode 100644 stdlib/theories/micromega/ZifyN.v delete mode 100644 stdlib/theories/micromega/ZifyNat.v delete mode 100644 stdlib/theories/micromega/ZifyPow.v delete mode 100644 stdlib/theories/micromega/ZifySint63.v delete mode 100644 stdlib/theories/micromega/ZifyUint63.v delete mode 100644 stdlib/theories/micromega/Ztac.v delete mode 100644 stdlib/theories/nsatz/Nsatz.v delete mode 100644 stdlib/theories/nsatz/NsatzTactic.v delete mode 100644 stdlib/theories/omega/OmegaLemmas.v delete mode 100644 stdlib/theories/omega/PreOmega.v delete mode 100644 stdlib/theories/rtauto/Bintree.v delete mode 100644 stdlib/theories/rtauto/Rtauto.v delete mode 100644 stdlib/theories/setoid_ring/Algebra_syntax.v delete mode 100644 stdlib/theories/setoid_ring/ArithRing.v delete mode 100644 stdlib/theories/setoid_ring/BinList.v delete mode 100644 stdlib/theories/setoid_ring/Cring.v delete mode 100644 stdlib/theories/setoid_ring/Field.v delete mode 100644 stdlib/theories/setoid_ring/Field_tac.v delete mode 100644 stdlib/theories/setoid_ring/Field_theory.v delete mode 100644 stdlib/theories/setoid_ring/InitialRing.v delete mode 100644 stdlib/theories/setoid_ring/Integral_domain.v delete mode 100644 stdlib/theories/setoid_ring/NArithRing.v delete mode 100644 stdlib/theories/setoid_ring/Ncring.v delete mode 100644 stdlib/theories/setoid_ring/Ncring_initial.v delete mode 100644 stdlib/theories/setoid_ring/Ncring_polynom.v delete mode 100644 stdlib/theories/setoid_ring/Ncring_tac.v delete mode 100644 stdlib/theories/setoid_ring/RealField.v delete mode 100644 stdlib/theories/setoid_ring/Ring.v delete mode 100644 stdlib/theories/setoid_ring/Ring_base.v delete mode 100644 stdlib/theories/setoid_ring/Ring_polynom.v delete mode 100644 stdlib/theories/setoid_ring/Ring_tac.v delete mode 100644 stdlib/theories/setoid_ring/Ring_theory.v delete mode 100644 stdlib/theories/setoid_ring/Rings_Q.v delete mode 100644 stdlib/theories/setoid_ring/Rings_R.v delete mode 100644 stdlib/theories/setoid_ring/Rings_Z.v delete mode 100644 stdlib/theories/setoid_ring/ZArithRing.v delete mode 100644 stdlib/theories/ssr/ssrbool.v delete mode 100644 stdlib/theories/ssr/ssrclasses.v delete mode 100644 stdlib/theories/ssr/ssreflect.v delete mode 100644 stdlib/theories/ssr/ssrfun.v delete mode 100644 stdlib/theories/ssr/ssrsetoid.v delete mode 100644 stdlib/theories/ssr/ssrunder.v delete mode 100644 stdlib/theories/ssrmatching/ssrmatching.v delete mode 100644 stdlib/tools/dune delete mode 100644 stdlib/tools/gen_all.ml diff --git a/dune b/dune index 10ea974b7839..5ce2643ae26a 100644 --- a/dune +++ b/dune @@ -96,5 +96,3 @@ (source_tree plugins))) ; (dirs (:standard _build_ci)) - -(dirs :standard \ stdlib) diff --git a/stdlib/.gitignore b/stdlib/.gitignore deleted file mode 100644 index d8a02bc33b7a..000000000000 --- a/stdlib/.gitignore +++ /dev/null @@ -1 +0,0 @@ -/.wrappers diff --git a/stdlib/INSTALL.md b/stdlib/INSTALL.md deleted file mode 100644 index 150bcc431cfe..000000000000 --- a/stdlib/INSTALL.md +++ /dev/null @@ -1,49 +0,0 @@ -Installing From Sources -======================= - -To install and use Coq, we recommend relying on [the Coq -platform](https://github.com/coq/platform/) or on a package manager -(e.g. opam or Nix). - -See https://coq.inria.fr/download and -https://github.com/coq/coq/wiki#coq-installation to learn more. - -If you need to build the stdlib from sources manually (e.g. to -contribute to the stdlib or to write a Coq package), the remainder of this -file explains how to do so. - -Build Requirements ------------------- - -To compile the stdlib yourself, you need: - -- [Coq](https://github.comq/coq/coq) - Look into [rocq-stdlib.opam](./rocq-stdlib.opam) for supported versions. - -Opam (https://opam.ocaml.org/) is recommended to install Coq. - - $ opam switch create coq --packages="ocaml-variants.4.14.1+options,ocaml-option-flambda" - $ eval $(opam env) - $ opam install rocq-core - -should get you a reasonable Coq environment to compile the stdlib. -See the OPAM documentation for more help. - -Nix users can also get all the required dependencies by running: - - $ nix-shell - -Build and install procedure ---------------------------- - -To build and install the stdlib do: - - $ make - $ make install - -Then, the recommended way to require standard library modules is `From -Stdlib Require {Import,Export,} .`, except for `Byte` -(use `From Stdlib.Strings` or `From Stdlib.Init`), `Tactics` (use -`From Stdlib.Program` or `From Stdlib.Init`), `Tauto` (use `From -Stdlib.micromega` of `From Stdlib.Init`) and `Wf` (use `From -Stdlib.Program` or `From Stdlib.Init`). diff --git a/stdlib/LICENSE b/stdlib/LICENSE deleted file mode 100644 index 27950e8d2057..000000000000 --- a/stdlib/LICENSE +++ /dev/null @@ -1,458 +0,0 @@ - GNU LESSER GENERAL PUBLIC LICENSE - Version 2.1, February 1999 - - Copyright (C) 1991, 1999 Free Software Foundation, Inc. - 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - Everyone is permitted to copy and distribute verbatim copies - of this license document, but changing it is not allowed. - -[This is the first released version of the Lesser GPL. It also counts - as the successor of the GNU Library Public License, version 2, hence - the version number 2.1.] - - Preamble - - The licenses for most software are designed to take away your -freedom to share and change it. By contrast, the GNU General Public -Licenses are intended to guarantee your freedom to share and change -free software--to make sure the software is free for all its users. - - This license, the Lesser General Public License, applies to some -specially designated software packages--typically libraries--of the -Free Software Foundation and other authors who decide to use it. You -can use it too, but we suggest you first think carefully about whether -this license or the ordinary General Public License is the better -strategy to use in any particular case, based on the explanations below. - - When we speak of free software, we are referring to freedom of use, -not price. Our General Public Licenses are designed to make sure that -you have the freedom to distribute copies of free software (and charge -for this service if you wish); that you receive source code or can get -it if you want it; that you can change the software and use pieces of -it in new free programs; and that you are informed that you can do -these things. - - To protect your rights, we need to make restrictions that forbid -distributors to deny you these rights or to ask you to surrender these -rights. These restrictions translate to certain responsibilities for -you if you distribute copies of the library or if you modify it. - - For example, if you distribute copies of the library, whether gratis -or for a fee, you must give the recipients all the rights that we gave -you. You must make sure that they, too, receive or can get the source -code. If you link other code with the library, you must provide -complete object files to the recipients, so that they can relink them -with the library after making changes to the library and recompiling -it. And you must show them these terms so they know their rights. - - We protect your rights with a two-step method: (1) we copyright the -library, and (2) we offer you this license, which gives you legal -permission to copy, distribute and/or modify the library. - - To protect each distributor, we want to make it very clear that -there is no warranty for the free library. Also, if the library is -modified by someone else and passed on, the recipients should know -that what they have is not the original version, so that the original -author's reputation will not be affected by problems that might be -introduced by others. - - Finally, software patents pose a constant threat to the existence of -any free program. We wish to make sure that a company cannot -effectively restrict the users of a free program by obtaining a -restrictive license from a patent holder. Therefore, we insist that -any patent license obtained for a version of the library must be -consistent with the full freedom of use specified in this license. - - Most GNU software, including some libraries, is covered by the -ordinary GNU General Public License. This license, the GNU Lesser -General Public License, applies to certain designated libraries, and -is quite different from the ordinary General Public License. We use -this license for certain libraries in order to permit linking those -libraries into non-free programs. - - When a program is linked with a library, whether statically or using -a shared library, the combination of the two is legally speaking a -combined work, a derivative of the original library. The ordinary -General Public License therefore permits such linking only if the -entire combination fits its criteria of freedom. The Lesser General -Public License permits more lax criteria for linking other code with -the library. - - We call this license the "Lesser" General Public License because it -does Less to protect the user's freedom than the ordinary General -Public License. It also provides other free software developers Less -of an advantage over competing non-free programs. These disadvantages -are the reason we use the ordinary General Public License for many -libraries. However, the Lesser license provides advantages in certain -special circumstances. - - For example, on rare occasions, there may be a special need to -encourage the widest possible use of a certain library, so that it becomes -a de-facto standard. To achieve this, non-free programs must be -allowed to use the library. A more frequent case is that a free -library does the same job as widely used non-free libraries. In this -case, there is little to gain by limiting the free library to free -software only, so we use the Lesser General Public License. - - In other cases, permission to use a particular library in non-free -programs enables a greater number of people to use a large body of -free software. For example, permission to use the GNU C Library in -non-free programs enables many more people to use the whole GNU -operating system, as well as its variant, the GNU/Linux operating -system. - - Although the Lesser General Public License is Less protective of the -users' freedom, it does ensure that the user of a program that is -linked with the Library has the freedom and the wherewithal to run -that program using a modified version of the Library. - - The precise terms and conditions for copying, distribution and -modification follow. Pay close attention to the difference between a -"work based on the library" and a "work that uses the library". The -former contains code derived from the library, whereas the latter must -be combined with the library in order to run. - - GNU LESSER GENERAL PUBLIC LICENSE - TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION - - 0. This License Agreement applies to any software library or other -program which contains a notice placed by the copyright holder or -other authorized party saying it may be distributed under the terms of -this Lesser General Public License (also called "this License"). -Each licensee is addressed as "you". - - A "library" means a collection of software functions and/or data -prepared so as to be conveniently linked with application programs -(which use some of those functions and data) to form executables. - - The "Library", below, refers to any such software library or work -which has been distributed under these terms. A "work based on the -Library" means either the Library or any derivative work under -copyright law: that is to say, a work containing the Library or a -portion of it, either verbatim or with modifications and/or translated -straightforwardly into another language. (Hereinafter, translation is -included without limitation in the term "modification".) - - "Source code" for a work means the preferred form of the work for -making modifications to it. For a library, complete source code means -all the source code for all modules it contains, plus any associated -interface definition files, plus the scripts used to control compilation -and installation of the library. - - Activities other than copying, distribution and modification are not -covered by this License; they are outside its scope. The act of -running a program using the Library is not restricted, and output from -such a program is covered only if its contents constitute a work based -on the Library (independent of the use of the Library in a tool for -writing it). Whether that is true depends on what the Library does -and what the program that uses the Library does. - - 1. You may copy and distribute verbatim copies of the Library's -complete source code as you receive it, in any medium, provided that -you conspicuously and appropriately publish on each copy an -appropriate copyright notice and disclaimer of warranty; keep intact -all the notices that refer to this License and to the absence of any -warranty; and distribute a copy of this License along with the -Library. - - You may charge a fee for the physical act of transferring a copy, -and you may at your option offer warranty protection in exchange for a -fee. - - 2. You may modify your copy or copies of the Library or any portion -of it, thus forming a work based on the Library, and copy and -distribute such modifications or work under the terms of Section 1 -above, provided that you also meet all of these conditions: - - a) The modified work must itself be a software library. - - b) You must cause the files modified to carry prominent notices - stating that you changed the files and the date of any change. - - c) You must cause the whole of the work to be licensed at no - charge to all third parties under the terms of this License. - - d) If a facility in the modified Library refers to a function or a - table of data to be supplied by an application program that uses - the facility, other than as an argument passed when the facility - is invoked, then you must make a good faith effort to ensure that, - in the event an application does not supply such function or - table, the facility still operates, and performs whatever part of - its purpose remains meaningful. - - (For example, a function in a library to compute square roots has - a purpose that is entirely well-defined independent of the - application. Therefore, Subsection 2d requires that any - application-supplied function or table used by this function must - be optional: if the application does not supply it, the square - root function must still compute square roots.) - -These requirements apply to the modified work as a whole. If -identifiable sections of that work are not derived from the Library, -and can be reasonably considered independent and separate works in -themselves, then this License, and its terms, do not apply to those -sections when you distribute them as separate works. But when you -distribute the same sections as part of a whole which is a work based -on the Library, the distribution of the whole must be on the terms of -this License, whose permissions for other licensees extend to the -entire whole, and thus to each and every part regardless of who wrote -it. - -Thus, it is not the intent of this section to claim rights or contest -your rights to work written entirely by you; rather, the intent is to -exercise the right to control the distribution of derivative or -collective works based on the Library. - -In addition, mere aggregation of another work not based on the Library -with the Library (or with a work based on the Library) on a volume of -a storage or distribution medium does not bring the other work under -the scope of this License. - - 3. You may opt to apply the terms of the ordinary GNU General Public -License instead of this License to a given copy of the Library. To do -this, you must alter all the notices that refer to this License, so -that they refer to the ordinary GNU General Public License, version 2, -instead of to this License. (If a newer version than version 2 of the -ordinary GNU General Public License has appeared, then you can specify -that version instead if you wish.) Do not make any other change in -these notices. - - Once this change is made in a given copy, it is irreversible for -that copy, so the ordinary GNU General Public License applies to all -subsequent copies and derivative works made from that copy. - - This option is useful when you wish to copy part of the code of -the Library into a program that is not a library. - - 4. You may copy and distribute the Library (or a portion or -derivative of it, under Section 2) in object code or executable form -under the terms of Sections 1 and 2 above provided that you accompany -it with the complete corresponding machine-readable source code, which -must be distributed under the terms of Sections 1 and 2 above on a -medium customarily used for software interchange. - - If distribution of object code is made by offering access to copy -from a designated place, then offering equivalent access to copy the -source code from the same place satisfies the requirement to -distribute the source code, even though third parties are not -compelled to copy the source along with the object code. - - 5. A program that contains no derivative of any portion of the -Library, but is designed to work with the Library by being compiled or -linked with it, is called a "work that uses the Library". Such a -work, in isolation, is not a derivative work of the Library, and -therefore falls outside the scope of this License. - - However, linking a "work that uses the Library" with the Library -creates an executable that is a derivative of the Library (because it -contains portions of the Library), rather than a "work that uses the -library". The executable is therefore covered by this License. -Section 6 states terms for distribution of such executables. - - When a "work that uses the Library" uses material from a header file -that is part of the Library, the object code for the work may be a -derivative work of the Library even though the source code is not. -Whether this is true is especially significant if the work can be -linked without the Library, or if the work is itself a library. The -threshold for this to be true is not precisely defined by law. - - If such an object file uses only numerical parameters, data -structure layouts and accessors, and small macros and small inline -functions (ten lines or less in length), then the use of the object -file is unrestricted, regardless of whether it is legally a derivative -work. (Executables containing this object code plus portions of the -Library will still fall under Section 6.) - - Otherwise, if the work is a derivative of the Library, you may -distribute the object code for the work under the terms of Section 6. -Any executables containing that work also fall under Section 6, -whether or not they are linked directly with the Library itself. - - 6. As an exception to the Sections above, you may also combine or -link a "work that uses the Library" with the Library to produce a -work containing portions of the Library, and distribute that work -under terms of your choice, provided that the terms permit -modification of the work for the customer's own use and reverse -engineering for debugging such modifications. - - You must give prominent notice with each copy of the work that the -Library is used in it and that the Library and its use are covered by -this License. You must supply a copy of this License. If the work -during execution displays copyright notices, you must include the -copyright notice for the Library among them, as well as a reference -directing the user to the copy of this License. Also, you must do one -of these things: - - a) Accompany the work with the complete corresponding - machine-readable source code for the Library including whatever - changes were used in the work (which must be distributed under - Sections 1 and 2 above); and, if the work is an executable linked - with the Library, with the complete machine-readable "work that - uses the Library", as object code and/or source code, so that the - user can modify the Library and then relink to produce a modified - executable containing the modified Library. (It is understood - that the user who changes the contents of definitions files in the - Library will not necessarily be able to recompile the application - to use the modified definitions.) - - b) Use a suitable shared library mechanism for linking with the - Library. A suitable mechanism is one that (1) uses at run time a - copy of the library already present on the user's computer system, - rather than copying library functions into the executable, and (2) - will operate properly with a modified version of the library, if - the user installs one, as long as the modified version is - interface-compatible with the version that the work was made with. - - c) Accompany the work with a written offer, valid for at - least three years, to give the same user the materials - specified in Subsection 6a, above, for a charge no more - than the cost of performing this distribution. - - d) If distribution of the work is made by offering access to copy - from a designated place, offer equivalent access to copy the above - specified materials from the same place. - - e) Verify that the user has already received a copy of these - materials or that you have already sent this user a copy. - - For an executable, the required form of the "work that uses the -Library" must include any data and utility programs needed for -reproducing the executable from it. However, as a special exception, -the materials to be distributed need not include anything that is -normally distributed (in either source or binary form) with the major -components (compiler, kernel, and so on) of the operating system on -which the executable runs, unless that component itself accompanies -the executable. - - It may happen that this requirement contradicts the license -restrictions of other proprietary libraries that do not normally -accompany the operating system. Such a contradiction means you cannot -use both them and the Library together in an executable that you -distribute. - - 7. You may place library facilities that are a work based on the -Library side-by-side in a single library together with other library -facilities not covered by this License, and distribute such a combined -library, provided that the separate distribution of the work based on -the Library and of the other library facilities is otherwise -permitted, and provided that you do these two things: - - a) Accompany the combined library with a copy of the same work - based on the Library, uncombined with any other library - facilities. This must be distributed under the terms of the - Sections above. - - b) Give prominent notice with the combined library of the fact - that part of it is a work based on the Library, and explaining - where to find the accompanying uncombined form of the same work. - - 8. You may not copy, modify, sublicense, link with, or distribute -the Library except as expressly provided under this License. Any -attempt otherwise to copy, modify, sublicense, link with, or -distribute the Library is void, and will automatically terminate your -rights under this License. However, parties who have received copies, -or rights, from you under this License will not have their licenses -terminated so long as such parties remain in full compliance. - - 9. You are not required to accept this License, since you have not -signed it. However, nothing else grants you permission to modify or -distribute the Library or its derivative works. These actions are -prohibited by law if you do not accept this License. Therefore, by -modifying or distributing the Library (or any work based on the -Library), you indicate your acceptance of this License to do so, and -all its terms and conditions for copying, distributing or modifying -the Library or works based on it. - - 10. Each time you redistribute the Library (or any work based on the -Library), the recipient automatically receives a license from the -original licensor to copy, distribute, link with or modify the Library -subject to these terms and conditions. You may not impose any further -restrictions on the recipients' exercise of the rights granted herein. -You are not responsible for enforcing compliance by third parties with -this License. - - 11. If, as a consequence of a court judgment or allegation of patent -infringement or for any other reason (not limited to patent issues), -conditions are imposed on you (whether by court order, agreement or -otherwise) that contradict the conditions of this License, they do not -excuse you from the conditions of this License. If you cannot -distribute so as to satisfy simultaneously your obligations under this -License and any other pertinent obligations, then as a consequence you -may not distribute the Library at all. For example, if a patent -license would not permit royalty-free redistribution of the Library by -all those who receive copies directly or indirectly through you, then -the only way you could satisfy both it and this License would be to -refrain entirely from distribution of the Library. - -If any portion of this section is held invalid or unenforceable under any -particular circumstance, the balance of the section is intended to apply, -and the section as a whole is intended to apply in other circumstances. - -It is not the purpose of this section to induce you to infringe any -patents or other property right claims or to contest validity of any -such claims; this section has the sole purpose of protecting the -integrity of the free software distribution system which is -implemented by public license practices. Many people have made -generous contributions to the wide range of software distributed -through that system in reliance on consistent application of that -system; it is up to the author/donor to decide if he or she is willing -to distribute software through any other system and a licensee cannot -impose that choice. - -This section is intended to make thoroughly clear what is believed to -be a consequence of the rest of this License. - - 12. If the distribution and/or use of the Library is restricted in -certain countries either by patents or by copyrighted interfaces, the -original copyright holder who places the Library under this License may add -an explicit geographical distribution limitation excluding those countries, -so that distribution is permitted only in or among countries not thus -excluded. In such case, this License incorporates the limitation as if -written in the body of this License. - - 13. The Free Software Foundation may publish revised and/or new -versions of the Lesser General Public License from time to time. -Such new versions will be similar in spirit to the present version, -but may differ in detail to address new problems or concerns. - -Each version is given a distinguishing version number. If the Library -specifies a version number of this License which applies to it and -"any later version", you have the option of following the terms and -conditions either of that version or of any later version published by -the Free Software Foundation. If the Library does not specify a -license version number, you may choose any version ever published by -the Free Software Foundation. - - 14. If you wish to incorporate parts of the Library into other free -programs whose distribution conditions are incompatible with these, -write to the author to ask for permission. For software which is -copyrighted by the Free Software Foundation, write to the Free -Software Foundation; we sometimes make exceptions for this. Our -decision will be guided by the two goals of preserving the free status -of all derivatives of our free software and of promoting the sharing -and reuse of software generally. - - NO WARRANTY - - 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO -WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. -EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR -OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY -KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE -IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE -LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME -THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. - - 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN -WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY -AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU -FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR -CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE -LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING -RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A -FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF -SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH -DAMAGES. - - END OF TERMS AND CONDITIONS diff --git a/stdlib/Makefile b/stdlib/Makefile deleted file mode 100644 index de1bbcf3bc4b..000000000000 --- a/stdlib/Makefile +++ /dev/null @@ -1,15 +0,0 @@ -all: - dune build -p rocq-stdlib @install - -install: - dune install --root . rocq-stdlib - -# Make of individual .vo -theories/%.vo: - dune build $@ - -refman-html: - dune build --root . --no-buffer @refman-html - -stdlib-html: - dune build --root . @stdlib-html diff --git a/stdlib/README.md b/stdlib/README.md deleted file mode 100644 index a82da56af162..000000000000 --- a/stdlib/README.md +++ /dev/null @@ -1,77 +0,0 @@ -# The Standard Library of Coq - -[![Zulip][zulip-badge]][zulip-link] -[![Discourse][discourse-badge]][discourse-link] - -[discourse-badge]: https://img.shields.io/badge/Discourse-forum-informational.svg -[discourse-link]: https://coq.discourse.group/ - -[zulip-badge]: https://img.shields.io/badge/Zulip-chat-informational.svg -[zulip-link]: https://coq.zulipchat.com/ - -[Coq](https://coq.inria.fr) 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. - -This repository contains the standard library of Coq. - -## Installation - -Please see https://coq.inria.fr/download. -Information on how to build and install from sources can be found in -[`INSTALL.md`](INSTALL.md). - -Then, the recommended way to require standard library modules is `From -Stdlib Require {Import,Export,} .`, except for `Byte` -(use `From Stdlib.Strings` or `From Stdlib.Init`), `Tactics` (use -`From Stdlib.Program` or `From Stdlib.Init`), `Tauto` (use `From -Stdlib.micromega` of `From Stdlib.Init`) and `Wf` (use `From -Stdlib.Program` or `From Stdlib.Init`). - -## Documentation - -The sources of the documentation can be found in directory [`doc`](doc). -See [`doc/README.md`](/doc/README.md) to learn more about the documentation, -in particular how to build it. The -documentation of the last released version is available on the Coq -web site at [coq.inria.fr/documentation](http://coq.inria.fr/documentation). - -The documentation of the master branch is continuously deployed. See: -- [Reference Manual (master)][refman-master] -- [Documentation of the standard library (master)][stdlib-master] - -[refman-master]: https://coq.github.io/doc/master/refman/ -[stdlib-master]: https://coq.github.io/doc/master/stdlib/ - -## Changes - -The [Recent -changes](https://coq.github.io/doc/master/refman/changes.html) chapter -of the reference manual explains the differences and the -incompatibilities of each new version of the standard library. If you upgrade, -please read it carefully as it contains important advice on how to -approach some problems you may encounter. - -## Questions and discussion - -We have a number of channels to reach the user community and the -development team: - -- Our [Zulip chat][zulip-link], for casual and high traffic discussions. -- Our [Discourse forum][discourse-link], for more structured and easily browsable discussions and Q&A. -- Our historical mailing list, the [Coq-Club](https://sympa.inria.fr/sympa/info/coq-club). - -See also [coq.inria.fr/community](https://coq.inria.fr/community.html), which -lists several other active platforms. - -## Bug reports - -Please report any bug / feature request in [our issue tracker](https://github.com/coq-community/stdlib/issues). - -To be effective, bug reports should mention -the Coq version (`coqtop -v`), the configuration -used, and include a complete source example leading to the bug. - -## Contributing to the Standard Library of Coq - -Guidelines for contributing in various ways are listed in the [contributor's guide](CONTRIBUTING.md). diff --git a/stdlib/coq-stdlib.opam b/stdlib/coq-stdlib.opam deleted file mode 100644 index b8c1af48aa2a..000000000000 --- a/stdlib/coq-stdlib.opam +++ /dev/null @@ -1,32 +0,0 @@ -# This file is generated by dune, edit dune-project instead -opam-version: "2.0" -version: "dev" -synopsis: - "Compatibility metapackage for Coq Stdlib library after the Rocq renaming" -maintainer: ["The Rocq standard library development team"] -authors: ["The Rocq development team, INRIA, CNRS, and contributors"] -license: "LGPL-2.1-only" -homepage: "https://coq.inria.fr/" -doc: "https://coq.github.io/doc/" -bug-reports: "https://github.com/coq/coq/issues" -depends: [ - "dune" {>= "3.8"} - "coq-core" - "rocq-stdlib" {= version} - "odoc" {with-doc} -] -build: [ - ["dune" "subst"] {dev} - [ - "dune" - "build" - "-p" - name - "-j" - jobs - "@install" - "@runtest" {with-test} - "@doc" {with-doc} - ] -] -dev-repo: "git+https://github.com/coq/coq.git" diff --git a/stdlib/dev/lint-commits.sh b/stdlib/dev/lint-commits.sh deleted file mode 100755 index caabb8490541..000000000000 --- a/stdlib/dev/lint-commits.sh +++ /dev/null @@ -1,80 +0,0 @@ -#!/usr/bin/env bash - -# A script to check prettyness for a range of commits -set -e - -CALLNAME="$0" - -function usage -{ - >&2 echo "usage: $CALLNAME " - >&2 echo "The order of commits is as given to 'git diff'" -} - -if [ "$#" != 2 ]; -then - usage - exit 1 -fi - -REDBOLD="\033[31;1m" -RESET="\033[0m" - -function redprint -{ - if true || [ "$COQ_CI_COLOR" ]; then - printf "$REDBOLD%s$RESET\n" "$1" - else - printf '%s\n' "$1" - fi -} - -BASE_COMMIT="$1" -HEAD_COMMIT="$2" - -tmp=$(mktemp -d) -git worktree add "$tmp" "$HEAD_COMMIT" -pushd "$tmp" - -bad_ws=() -bad_compile=() -while IFS= read -r commit; do - echo Checking "$commit" - git checkout "$commit" - - # git diff --check - # uses .gitattributes to know what to check - if ! git diff --check "${commit}^" "$commit"; - then bad_ws+=("$commit") - fi - - if ! make check - then bad_compile+=("$commit") - fi -done < <(git rev-list "$HEAD_COMMIT" --not "$BASE_COMMIT" --) - -popd -git worktree remove "$tmp" - -# report errors - -CODE=0 - -if [ "${#bad_ws[@]}" != 0 ] -then - >&2 redprint "Whitespace errors!" - >&2 echo "In commits ${bad_ws[*]}" - >&2 echo "If you use emacs, you can prevent this kind of error from reoccurring by installing ws-butler and enabling ws-butler-convert-leading-tabs-or-spaces." - >&2 echo - CODE=1 -fi - -if [ "${#bad_compile[@]}" != 0 ] -then - >&2 redprint "Compilation errors!" - >&2 echo "In commits ${bad_compile[*]}" - >&2 echo - CODE=1 -fi - -exit $CODE diff --git a/stdlib/dev/lint-repository.sh b/stdlib/dev/lint-repository.sh deleted file mode 100755 index b956b8547c7d..000000000000 --- a/stdlib/dev/lint-repository.sh +++ /dev/null @@ -1,52 +0,0 @@ -#!/usr/bin/env bash - -# A script to check prettyness over the repository. - -# lint-commits.sh seeks to prevent the worsening of already present -# problems, such as tab indentation in ml files. lint-repository.sh -# also seeks to prevent the (re-)introduction of solved problems, such -# as newlines at the end of .v files. - -CODE=0 - -# if COQ_CI_COLOR is set (from the environment) keep it intact (even when it's the empty string)' -if ! [ "${COQ_CI_COLOR+1}" ]; then - # NB: in CI TERM is unset in the environment - # when TERM is unset, bash sets it to "dumb" as a bash variable (not exported?) - if { [ -t 1 ] && ! [ "$TERM" = dumb ]; } || [ "$CI" ] - then export COQ_CI_COLOR=1 - else export COQ_CI_COLOR= - fi -fi - -if [[ $(git log -n 1 --pretty='format:%s') == "[CI merge]"* ]]; then - # The second parent of bot merges is from the PR, the first is - # current master - head=$(git rev-parse HEAD^2) -else - head=$(git rev-parse HEAD) -fi - -# We assume that all non-bot merge commits are from the main branch -# For Coq it is extremely rare for this assumption to be broken -read -r base < <(git log -n 1 --merges --pretty='format:%H' "$head") - -dev/lint-commits.sh "$base" "$head" || CODE=1 - -# Check that the files with 'whitespace' gitattribute end in a newline. -# xargs exit status is 123 if any file failed the test -echo Checking end of file newlines -find . "(" -path ./.git -prune ")" -o -type f -print0 | - xargs -0 dev/tools/check-eof-newline.sh || CODE=1 - -echo Checking overlays -dev/tools/check-overlays.sh || CODE=1 - -echo Checking CACHEKEY -dev/tools/check-cachekey.sh || CODE=1 - -# Check that doc/tools/docgram/fullGrammar is up-to-date -echo Checking grammar files -make SHOW='@true ""' doc_gram_verify || CODE=1 - -exit $CODE diff --git a/stdlib/dev/tools/check-eof-newline.sh b/stdlib/dev/tools/check-eof-newline.sh deleted file mode 100755 index d0537d2ecfd9..000000000000 --- a/stdlib/dev/tools/check-eof-newline.sh +++ /dev/null @@ -1,54 +0,0 @@ -#!/usr/bin/env bash - -# Usage: check-eof-newline.sh [--fix] FILES... -# Detect missing end of file newlines for FILES. -# Files are skipped if untracked by git and depending on gitattributes. -# With --fix, automatically append a newline. -# Exit status: -# Without --fix: 1 if any file had a missing newline, 0 otherwise. -# With --fix: 1 if any non writable file had a missing newline, 0 otherwise. - -FIX= -if [ "$1" = --fix ]; -then - FIX=1 - shift -fi - -REDBOLD="\033[31m" -YELLOW="\033[33m" -RESET="\033[0m" - -function colorprint -{ - if [ "$COQ_CI_COLOR" ]; then - printf "$1%s$RESET\n" "$2" - else - printf '%s\n' "$2" - fi -} - -CODE=0 -for f in "$@"; do - if git ls-files --error-unmatch "$f" >/dev/null 2>&1 && \ - git check-attr whitespace -- "$f" | grep -q -v -e 'unset$' -e 'unspecified$' && \ - [ -n "$(tail -c 1 "$f")" ] - then - if [ -n "$FIX" ]; - then - if [ -w "$f" ]; - then - echo >> "$f" - colorprint "$YELLOW" "Newline appended to file $f!" - else - colorprint "$REDBOLD" "File $f is missing a newline and not writable!" - CODE=1 - fi - else - colorprint "$REDBOLD" "No newline at end of file $f!" - CODE=1 - fi - fi -done - -exit "$CODE" diff --git a/stdlib/dev/tools/dune b/stdlib/dev/tools/dune deleted file mode 100644 index 0ee2e772b54a..000000000000 --- a/stdlib/dev/tools/dune +++ /dev/null @@ -1,2 +0,0 @@ -(executable - (name hash)) diff --git a/stdlib/dev/tools/hash.ml b/stdlib/dev/tools/hash.ml deleted file mode 100644 index f2d9348dbbdd..000000000000 --- a/stdlib/dev/tools/hash.ml +++ /dev/null @@ -1,2 +0,0 @@ -let () = - Printf.printf "%s\n%!" Digest.(to_hex (input stdin)) diff --git a/stdlib/dev/tools/hash.mli b/stdlib/dev/tools/hash.mli deleted file mode 100644 index e69de29bb2d1..000000000000 diff --git a/stdlib/dev/tools/list-contributors.sh b/stdlib/dev/tools/list-contributors.sh deleted file mode 100755 index ba51e535ddf3..000000000000 --- a/stdlib/dev/tools/list-contributors.sh +++ /dev/null @@ -1,29 +0,0 @@ -#!/usr/bin/env bash -# For compat with OSX which has a non-gnu sed which doesn't support -z -SED=`(which gsed || which sed) 2> /dev/null` - -if [ $# != 1 ]; then - echo "usage: $0 rev0..rev1" - exit 1 -fi - -git shortlog -s -n --no-merges --group=author --group=trailer:Co-authored-by $1 | cut -f2 | sort -k 2 | grep -v -e "coqbot" -e "^$" > contributors.tmp - -cat contributors.tmp | wc -l | xargs echo "Contributors:" -cat contributors.tmp | $SED -z "s/\n/, /g" -echo -rm contributors.tmp - -git shortlog -s -n --merges --group=author --group=trailer:Co-authored-by $1 | cut -f2 | sort -k 2 | grep -v -e "coqbot" -e "^$" > assignees.tmp - -cat assignees.tmp | wc -l | xargs echo "Assignees:" -cat assignees.tmp | $SED -z "s/\n/, /g" -echo -rm assignees.tmp - -git shortlog -s -n --merges --group=trailer:reviewed-by --group=trailer:ack-by $1 | cut -f2 | sort -k 2 | grep -v -e "coqbot" -e "^$" > reviewers.tmp - -cat reviewers.tmp | wc -l | xargs echo "Reviewers:" -cat reviewers.tmp | $SED -z "s/\n/, /g" -echo -rm reviewers.tmp diff --git a/stdlib/dev/tools/markdown-toc b/stdlib/dev/tools/markdown-toc deleted file mode 100755 index 9b7d3e4224e0..000000000000 --- a/stdlib/dev/tools/markdown-toc +++ /dev/null @@ -1,69 +0,0 @@ -#!/usr/bin/env bash - -# from https://github.com/Lirt/markdown-toc-bash -# MIT license - -FILE=${1:?No file was specified as first argument} - -declare -a TOC -CODE_BLOCK=0 -CODE_BLOCK_REGEX='^```' -HEADING_REGEX='^#{1,}' - -while read -r LINE; do - # Treat code blocks - if [[ "${LINE}" =~ $CODE_BLOCK_REGEX ]]; then - # Ignore things until we see code block ending - CODE_BLOCK=$((CODE_BLOCK + 1)) - if [[ "${CODE_BLOCK}" -eq 2 ]]; then - # We hit the closing code block - CODE_BLOCK=0 - fi - continue - fi - - # Treat normal line - if [[ "${CODE_BLOCK}" == 0 ]]; then - # If we see heading, we save it to ToC map - if [[ "${LINE}" =~ ${HEADING_REGEX} ]]; then - TOC+=("${LINE}") - fi - fi -done < <(grep -v '## Table of Contents' "${FILE}") - -echo -e "## Table of Contents\n" -for LINE in "${TOC[@]}"; do - case "${LINE}" in - '#####'*) - echo -n " - " - ;; - '####'*) - echo -n " - " - ;; - '###'*) - echo -n " - " - ;; - '##'*) - echo -n " - " - ;; - '#'*) - echo -n "- " - ;; - esac - - LINK=${LINE} - # Detect markdown links in heading and remove link part from them - if grep -qE "\[.*\]\(.*\)" <<< "${LINK}"; then - LINK=$(sed 's/\(\]\)\((.*)\)/\1/' <<< "${LINK}") - fi - # Special characters (besides '-') in page links in markdown - # are deleted and spaces are converted to dashes - LINK=$(tr -dc "[:alnum:] _-" <<< "${LINK}") - LINK=${LINK/ /} - LINK=${LINK// /-} - LINK=${LINK,,} - LINK=$(tr -s "-" <<< "${LINK}") - - # Print in format [Very Special Heading](#very-special-heading) - echo "[${LINE#\#* }](#${LINK})" -done diff --git a/stdlib/dev/with-rocq-wrap.sh b/stdlib/dev/with-rocq-wrap.sh deleted file mode 100755 index b9dd254d8fc7..000000000000 --- a/stdlib/dev/with-rocq-wrap.sh +++ /dev/null @@ -1,47 +0,0 @@ -#!/usr/bin/env bash - -set -ex - -rocq=$(command -v rocq) -# NB on cygwin "$rocq" is a cygwin path (/foo/bar) -# but reading files from hash.exe needs windows paths (C:/cygwin/foo/bar) -# we avoid the problem by going through stdin -rocqhash=$(dune exec --root "$(dirname "$0")"/.. -- dev/tools/hash.exe < "$rocq") - -rm -rf .wrappers -mkdir .wrappers - -cat > .wrappers/coqc < .wrappers/coqdep < .wrappers/META.coq-core <, and the documentation of the -standard library for the development version at -. - -The reference manual is written is reStructuredText and compiled -using Sphinx. See [`sphinx/README.rst`](sphinx/README.rst) -to learn more about the format that is used. - -The documentation for the standard library is generated from -the `.v` source files using coqdoc. - -Dependencies ------------- - -### HTML documentation - -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 >= 4.5.0 - - sphinx_rtd_theme >= 1.0.0 - - beautifulsoup4 >= 4.8.2 - - antlr4-python3-runtime >= 4.7.1 & <= 4.9.3 - - pexpect >= 4.6.0 - - sphinxcontrib-bibtex >= 0.4.2 - -To install them, you should first install pip and setuptools (for instance, -with `apt install python3-pip python3-setuptools` on Debian / Ubuntu) then run: - - pip3 install sphinx sphinx_rtd_theme beautifulsoup4 \ - antlr4-python3-runtime==4.7.1 pexpect sphinxcontrib-bibtex - -Nix users should get the correct development environment to build the -HTML documentation from Coq's [`default.nix`](../default.nix) (note this -doesn't include the LaTeX packages needed to build the full documentation). - -You can check the dependencies using the `doc/tools/coqrst/checkdeps.py` script. - -### Other formats - -To produce the documentation in PDF and PostScript formats, the following -additional tools are required: - - - latex (latex2e) - - pdflatex - - dvips - - makeindex - - xelatex - - latexmk - -All of them are part of the TexLive distribution. E.g. on Debian / Ubuntu, -install them with: - - apt install texlive-full - -Or if you want to use less disk space: - - apt install texlive-latex-extra texlive-fonts-recommended texlive-xetex \ - latexmk fonts-freefont-otf - -### Setting the locale for Python - -Make sure that the locale is configured on your platform so that Python encodes -printed messages with utf-8 rather than generating runtime exceptions -for non-ascii characters. The `.UTF-8` in `export LANG=C.UTF-8` sets UTF-8 encoding. -The `C` can be replaced with any supported language code. You can set the default -for a Docker build with `ENV LANG C.UTF-8`. (Python may look at other -environment variables to determine the locale; see the -[Python documentation](https://docs.python.org/3/library/locale.html#locale.getdefaultlocale)). - -Compilation ------------ - -The current documentation targets are: - -- `make refman-html` - Build the reference manual in HTML form into `_build/default/doc/refman-html` - -- `make stdlib-html` - Build the standard library documentation into `_build/default/doc/stdlib/html` - -To build the Sphinx documentation without stopping at the first -warning, change the value of the `SPHINXWARNOPT` variable (default is -`-W`). The following will build the Sphinx documentation without -stopping at the first warning, and store all the warnings in the file -`/tmp/warn.log`: - -``` -SPHINXWARNOPT="-w/tmp/warn.log" make refman-html -``` - -Note that inspecting local copies of the docs may behave in unexpected ways if -opening the sources with a browser (eg with `firefox -_build/default/doc/refman-html/index.html`). In order to avoid this, either -inspect the version generated by the CI or run a local server, for example -with: -``` -cd _build/default/doc/refman-html/ && python3 -m http.server -``` diff --git a/stdlib/doc/changelog/01-misc/00000-title.rst b/stdlib/doc/changelog/01-misc/00000-title.rst deleted file mode 100644 index d64218c71324..000000000000 --- a/stdlib/doc/changelog/01-misc/00000-title.rst +++ /dev/null @@ -1,4 +0,0 @@ - -Misc -^^^^ - diff --git a/stdlib/doc/common/macros.tex b/stdlib/doc/common/macros.tex deleted file mode 100644 index 9c7732ad3d33..000000000000 --- a/stdlib/doc/common/macros.tex +++ /dev/null @@ -1,546 +0,0 @@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -% MACROS FOR THE REFERENCE MANUAL OF COQ % -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - -% For commentaries (define \com as {} for the release manual) -%\newcommand{\com}[1]{{\it(* #1 *)}} -%\newcommand{\com}[1]{} - -%%OPTIONS for HACHA -%\renewcommand{\cuttingunit}{section} - - -%BEGIN LATEX -\newenvironment{centerframe}% -{\bgroup -\dimen0=\textwidth -\advance\dimen0 by -2\fboxrule -\advance\dimen0 by -2\fboxsep -\setbox0=\hbox\bgroup -\begin{minipage}{\dimen0}% -\begin{center}}% -{\end{center}% -\end{minipage}\egroup -\centerline{\fbox{\box0}}\egroup -} -%END LATEX -%HEVEA \newenvironment{centerframe}{\begin{center}}{\end{center}} - -%HEVEA \renewcommand{\vec}[1]{\mathbf{#1}} -%\renewcommand{\ominus}{-} % Hevea does a good job translating these commands -%\renewcommand{\oplus}{+} -%\renewcommand{\otimes}{\times} -%\newcommand{\land}{\wedge} -%\newcommand{\lor}{\vee} -%HEVEA \renewcommand{\k}[1]{#1} % \k{a} is supposed to produce a with a little stroke -%HEVEA \newcommand{\phantom}[1]{\qquad} - -%%%%%%%%%%%%%%%%%%%%%%% -% Formatting commands % -%%%%%%%%%%%%%%%%%%%%%%% - -\newcommand{\ErrMsg}{\medskip \noindent {\bf Error message: }} -\newcommand{\ErrMsgx}{\medskip \noindent {\bf Error messages: }} -\newcommand{\variant}{\medskip \noindent {\bf Variant: }} -\newcommand{\variants}{\medskip \noindent {\bf Variants: }} -\newcommand{\SeeAlso}{\medskip \noindent {\bf See also: }} -\newcommand{\Rem}{\medskip \noindent {\bf Remark: }} -\newcommand{\Rems}{\medskip \noindent {\bf Remarks: }} -\newcommand{\Example}{\medskip \noindent {\bf Example: }} -\newcommand{\examples}{\medskip \noindent {\bf Examples: }} -\newcommand{\Warning}{\medskip \noindent {\bf Warning: }} -\newcommand{\Warns}{\medskip \noindent {\bf Warnings: }} -\newcounter{ex} -\newcommand{\firstexample}{\setcounter{ex}{1}} -\newcommand{\example}[1]{ -\medskip \noindent \textbf{Example \arabic{ex}: }\textit{#1} -\addtocounter{ex}{1}} - -\newenvironment{Variant}{\variant\begin{enumerate}}{\end{enumerate}} -\newenvironment{Variants}{\variants\begin{enumerate}}{\end{enumerate}} -\newenvironment{ErrMsgs}{\ErrMsgx\begin{enumerate}}{\end{enumerate}} -\newenvironment{Remarks}{\Rems\begin{enumerate}}{\end{enumerate}} -\newenvironment{Warnings}{\Warns\begin{enumerate}}{\end{enumerate}} -\newenvironment{Examples}{\medskip\noindent{\bf Examples:} -\begin{enumerate}}{\end{enumerate}} - -%\newcommand{\bd}{\noindent\bf} -%\newcommand{\sbd}{\vspace{8pt}\noindent\bf} -%\newcommand{\sdoll}[1]{\begin{small}$ #1~ $\end{small}} -%\newcommand{\sdollnb}[1]{\begin{small}$ #1 $\end{small}} -\newcommand{\kw}[1]{\textsf{#1}} -%\newcommand{\spec}[1]{\{\,#1\,\}} - -% Building regular expressions -\newcommand{\zeroone}[1]{\mbox{\sl [}{#1}\mbox{\sl ]}} -\newcommand{\zeroonelax}[1]{\mbox{\sl [}#1\mbox{\sl ]}} -%\newcommand{\zeroonemany}[1]{$\{$#1$\}$*} -%\newcommand{\onemany}[1]{$\{$#1$\}$+} -\newcommand{\nelistnosep}[1]{{#1} \mbox{\dots} {#1}} -\newcommand{\nelist}[2]{{#1} {\tt #2} \mbox{\dots} {\tt #2} {#1}} -\newcommand{\sequence}[2]{{\sl [}{#1} {\tt #2} \mbox{\dots} {\tt #2} {#1}{\sl ]}} -\newcommand{\nelistwithoutblank}[2]{#1{\tt #2}\mbox{\dots}{\tt #2}#1} -\newcommand{\sequencewithoutblank}[2]{$[$#1{\tt #2}\mbox{\dots}{\tt #2}#1$]$} - -% Used for RefMan-gal -%\newcommand{\ml}[1]{\hbox{\tt{#1}}} -%\newcommand{\op}{\,|\,} - -%%%%%%%%%%%%%%%%%%%%%%%% -% Trademarks and so on % -%%%%%%%%%%%%%%%%%%%%%%%% - -\newcommand{\Coq}{\textsc{Coq}} -\newcommand{\gallina}{\textsc{Gallina}} -\newcommand{\Gallina}{\textsc{Gallina}} -\newcommand{\CoqIDE}{\textsc{CoqIDE}} -\newcommand{\ocaml}{\textsc{OCaml}} -\newcommand{\camlpppp}{\textsc{Camlp5}} -\newcommand{\emacs}{\textsc{GNU Emacs}} -\newcommand{\ProofGeneral}{\textsc{Proof General}} -\newcommand{\CIC}{\textsc{Cic}} -\newcommand{\iCIC}{\textsc{Cic}} -\newcommand{\FW}{\ensuremath{F_{\omega}}} -\newcommand{\Program}{\textsc{Program}} -\newcommand{\Russell}{\textsc{Russell}} -\newcommand{\PVS}{\textsc{PVS}} -%\newcommand{\bn}{{\sf BNF}} - -%%%%%%%%%%%%%%%%%%% -% Name of tactics % -%%%%%%%%%%%%%%%%%%% - -%\newcommand{\Natural}{\mbox{\tt Natural}} - -%%%%%%%%%%%%%%%%% -% \rm\sl series % -%%%%%%%%%%%%%%%%% - -\newcommand{\nterm}[1]{\textrm{\textsl{#1}}} - -\newcommand{\qstring}{\nterm{string}} - -%% New syntax specific entries -\newcommand{\annotation}{\nterm{annotation}} -\newcommand{\assums}{\nterm{assums}} % vernac -\newcommand{\simpleassums}{\nterm{simple\_assums}} % assumptions -\newcommand{\binder}{\nterm{binder}} -\newcommand{\binders}{\nterm{binders}} -\newcommand{\caseitems}{\nterm{match\_items}} -\newcommand{\caseitem}{\nterm{match\_item}} -\newcommand{\eqn}{\nterm{equation}} -\newcommand{\ifitem}{\nterm{dep\_ret\_type}} -\newcommand{\hyplocation}{\nterm{hyp\_location}} -\newcommand{\convclause}{\nterm{conversion\_clause}} -\newcommand{\occclause}{\nterm{occurrence\_clause}} -\newcommand{\occgoalset}{\nterm{goal\_occurrences}} -\newcommand{\atoccurrences}{\nterm{at\_occurrences}} -\newcommand{\occlist}{\nterm{occurrences}} -\newcommand{\params}{\nterm{params}} % vernac -\newcommand{\returntype}{\nterm{return\_type}} -\newcommand{\idparams}{\nterm{ident\_with\_params}} -\newcommand{\statkwd}{\nterm{assertion\_keyword}} % vernac -\newcommand{\termarg}{\nterm{arg}} -\newcommand{\hintdef}{\nterm{hint\_definition}} - -\newcommand{\typecstr}{\zeroone{{\tt :}~{\term}}} -\newcommand{\typecstrwithoutblank}{\zeroone{{\tt :}{\term}}} -\newcommand{\typecstrtype}{\zeroone{{\tt :}~{\type}}} - -\newcommand{\Fwterm}{\nterm{Fwterm}} -\newcommand{\Index}{\nterm{index}} -\newcommand{\abbrev}{\nterm{abbreviation}} -\newcommand{\atomictac}{\nterm{atomic\_tactic}} -\newcommand{\bindinglist}{\nterm{bindings\_list}} -\newcommand{\cast}{\nterm{cast}} -\newcommand{\cofixpointbodies}{\nterm{cofix\_bodies}} -\newcommand{\cofixpointbody}{\nterm{cofix\_body}} -\newcommand{\commandtac}{\nterm{tactic\_invocation}} -\newcommand{\constructor}{\nterm{constructor}} -\newcommand{\convtactic}{\nterm{conv\_tactic}} -\newcommand{\assumptionkeyword}{\nterm{assumption\_keyword}} -\newcommand{\assumption}{\nterm{assumption}} -\newcommand{\definition}{\nterm{definition}} -\newcommand{\digit}{\nterm{digit}} -\newcommand{\exteqn}{\nterm{ext\_eqn}} -\newcommand{\field}{\nterm{field}} -\newcommand{\fielddef}{\nterm{field\_def}} -\newcommand{\firstletter}{\nterm{first\_letter}} -\newcommand{\fixpg}{\nterm{fix\_pgm}} -\newcommand{\fixpointbodies}{\nterm{fix\_bodies}} -\newcommand{\fixpointbody}{\nterm{fix\_body}} -\newcommand{\fixpoint}{\nterm{fixpoint}} -\newcommand{\flag}{\nterm{flag}} -\newcommand{\form}{\nterm{form}} -\newcommand{\entry}{\nterm{entry}} -\newcommand{\proditem}{\nterm{prod\_item}} -\newcommand{\taclevel}{\nterm{tactic\_level}} -\newcommand{\tacargtype}{\nterm{tactic\_argument\_type}} -\newcommand{\scope}{\nterm{scope}} -\newcommand{\delimkey}{\nterm{key}} -\newcommand{\optscope}{\nterm{opt\_scope}} -\newcommand{\declnotation}{\nterm{decl\_notation}} -\newcommand{\symbolentry}{\nterm{symbol}} -\newcommand{\modifiers}{\nterm{modifiers}} -\newcommand{\binderinterp}{\nterm{binder\_interp}} -\newcommand{\localdef}{\nterm{local\_def}} -\newcommand{\localdecls}{\nterm{local\_decls}} -\newcommand{\ident}{\nterm{ident}} -\newcommand{\accessident}{\nterm{access\_ident}} -\newcommand{\possiblybracketedident}{\nterm{possibly\_bracketed\_ident}} -\newcommand{\inductivebody}{\nterm{ind\_body}} -\newcommand{\inductive}{\nterm{inductive}} -\newcommand{\naturalnumber}{\nterm{natural}} -\newcommand{\integer}{\nterm{integer}} -\newcommand{\multpattern}{\nterm{mult\_pattern}} -\newcommand{\mutualcoinductive}{\nterm{mutual\_coinductive}} -\newcommand{\mutualinductive}{\nterm{mutual\_inductive}} -\newcommand{\nestedpattern}{\nterm{nested\_pattern}} -\newcommand{\name}{\nterm{name}} -\newcommand{\num}{\nterm{num}} -\newcommand{\pattern}{\nterm{pattern}} % pattern for pattern-matching -\newcommand{\orpattern}{\nterm{or\_pattern}} -\newcommand{\intropattern}{\nterm{intro\_pattern}} -\newcommand{\intropatternlist}{\nterm{intro\_pattern\_list}} -\newcommand{\disjconjintropattern}{\nterm{disj\_conj\_intro\_pattern}} -\newcommand{\namingintropattern}{\nterm{naming\_intro\_pattern}} -\newcommand{\termpattern}{\nterm{term\_pattern}} % term with holes -\newcommand{\pat}{\nterm{pat}} -\newcommand{\pgs}{\nterm{pgms}} -\newcommand{\pg}{\nterm{pgm}} -\newcommand{\abullet}{\nterm{bullet}} -%BEGIN LATEX -\newcommand{\proof}{\nterm{proof}} -%END LATEX -%HEVEA \renewcommand{\proof}{\nterm{proof}} -\newcommand{\record}{\nterm{record}} -\newcommand{\recordkw}{\nterm{record\_keyword}} -\newcommand{\rewrule}{\nterm{rewriting\_rule}} -\newcommand{\sentence}{\nterm{sentence}} -\newcommand{\simplepattern}{\nterm{simple\_pattern}} -\newcommand{\sort}{\nterm{sort}} -\newcommand{\specif}{\nterm{specif}} -\newcommand{\assertion}{\nterm{assertion}} -\newcommand{\str}{\nterm{string}} -\newcommand{\subsequentletter}{\nterm{subsequent\_letter}} -\newcommand{\switch}{\nterm{switch}} -\newcommand{\messagetoken}{\nterm{message\_token}} -\newcommand{\tac}{\nterm{tactic}} -\newcommand{\terms}{\nterm{terms}} -\newcommand{\term}{\nterm{term}} -\newcommand{\module}{\nterm{module}} -\newcommand{\modexpr}{\nterm{module\_expression}} -\newcommand{\modtype}{\nterm{module\_type}} -\newcommand{\onemodbinding}{\nterm{module\_binding}} -\newcommand{\modbindings}{\nterm{module\_bindings}} -\newcommand{\qualid}{\nterm{qualid}} -\newcommand{\qualidorstring}{\nterm{qualid\_or\_string}} -\newcommand{\class}{\nterm{class}} -\newcommand{\dirpath}{\nterm{dirpath}} -\newcommand{\typedidents}{\nterm{typed\_idents}} -\newcommand{\type}{\nterm{type}} -\newcommand{\vref}{\nterm{ref}} -\newcommand{\zarithformula}{\nterm{zarith\_formula}} -\newcommand{\zarith}{\nterm{zarith}} -\newcommand{\ltac}{\mbox{${\mathcal{L}}_{tac}$}} - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -% \mbox{\sf } series for roman text in maths formulas % -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - -\newcommand{\alors}{\mbox{\textsf{then}}} -\newcommand{\alter}{\mbox{\textsf{alter}}} -\newcommand{\bool}{\mbox{\textsf{bool}}} -\newcommand{\conc}{\mbox{\textsf{conc}}} -\newcommand{\cons}{\mbox{\textsf{cons}}} -\newcommand{\consf}{\mbox{\textsf{consf}}} -\newcommand{\emptyf}{\mbox{\textsf{emptyf}}} -\newcommand{\EqSt}{\mbox{\textsf{EqSt}}} -\newcommand{\false}{\mbox{\textsf{false}}} -\newcommand{\filter}{\mbox{\textsf{filter}}} -\newcommand{\forest}{\mbox{\textsf{forest}}} -\newcommand{\from}{\mbox{\textsf{from}}} -\newcommand{\hd}{\mbox{\textsf{hd}}} -\newcommand{\haslength}{\mbox{\textsf{has\_length}}} -\newcommand{\length}{\mbox{\textsf{length}}} -\newcommand{\haslengthA}{\mbox {\textsf{has\_length~A}}} -\newcommand{\List}{\mbox{\textsf{list}}} -\newcommand{\ListA}{\mbox{\textsf{list}}~\ensuremath{A}} -\newcommand{\nilhl}{\mbox{\textsf{nil\_hl}}} -\newcommand{\conshl}{\mbox{\textsf{cons\_hl}}} -\newcommand{\nat}{\mbox{\textsf{nat}}} -\newcommand{\nO}{\mbox{\textsf{O}}} -\newcommand{\nS}{\mbox{\textsf{S}}} -\newcommand{\node}{\mbox{\textsf{node}}} -\newcommand{\Nil}{\mbox{\textsf{nil}}} -\newcommand{\SProp}{\mbox{\textsf{SProp}}} -\newcommand{\Prop}{\mbox{\textsf{Prop}}} -\newcommand{\Set}{\mbox{\textsf{Set}}} -\newcommand{\si}{\mbox{\textsf{if}}} -\newcommand{\sinon}{\mbox{\textsf{else}}} -\newcommand{\Str}{\mbox{\textsf{Stream}}} -\newcommand{\tl}{\mbox{\textsf{tl}}} -\newcommand{\tree}{\mbox{\textsf{tree}}} -\newcommand{\true}{\mbox{\textsf{true}}} -\newcommand{\Type}{\mbox{\textsf{Type}}} -\newcommand{\unfold}{\mbox{\textsf{unfold}}} -\newcommand{\zeros}{\mbox{\textsf{zeros}}} -\newcommand{\even}{\mbox{\textsf{even}}} -\newcommand{\odd}{\mbox{\textsf{odd}}} -\newcommand{\evenO}{\mbox{\textsf{even\_O}}} -\newcommand{\evenS}{\mbox{\textsf{even\_S}}} -\newcommand{\oddS}{\mbox{\textsf{odd\_S}}} -\newcommand{\Prod}{\mbox{\textsf{prod}}} -\newcommand{\Pair}{\mbox{\textsf{pair}}} - -%%%%%%%%% -% Misc. % -%%%%%%%%% -\newcommand{\T}{\texttt{T}} -\newcommand{\U}{\texttt{U}} -\newcommand{\real}{\textsf{Real}} -\newcommand{\Data}{\textit{Data}} -\newcommand{\In} {{\textbf{in }}} -\newcommand{\AND} {{\textbf{and}}} -\newcommand{\If}{{\textbf{if }}} -\newcommand{\Else}{{\textbf{else }}} -\newcommand{\Then} {{\textbf{then }}} -%\newcommand{\Let}{{\textbf{let }}} % looks like this is never used -\newcommand{\Where}{{\textbf{where rec }}} -\newcommand{\Function}{{\textbf{function }}} -\newcommand{\Rec}{{\textbf{rec }}} -%\newcommand{\cn}{\centering} -\newcommand{\nth}{\mbox{$^{\mbox{\scriptsize th}}$}} - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -% Math commands and symbols % -%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - -\newcommand{\la}{\leftarrow} -\newcommand{\ra}{\rightarrow} -\newcommand{\Ra}{\Rightarrow} -\newcommand{\rt}{\Rightarrow} -\newcommand{\lla}{\longleftarrow} -\newcommand{\lra}{\longrightarrow} -\newcommand{\Llra}{\Longleftrightarrow} -\newcommand{\mt}{\mapsto} -\newcommand{\ov}{\overrightarrow} -\newcommand{\wh}{\widehat} -\newcommand{\up}{\uparrow} -\newcommand{\dw}{\downarrow} -\newcommand{\nr}{\nearrow} -\newcommand{\se}{\searrow} -\newcommand{\sw}{\swarrow} -\newcommand{\nw}{\nwarrow} -\newcommand{\mto}{.\;} - -\newcommand{\vm}[1]{\vspace{#1em}} -\newcommand{\vx}[1]{\vspace{#1ex}} -\newcommand{\hm}[1]{\hspace{#1em}} -\newcommand{\hx}[1]{\hspace{#1ex}} -\newcommand{\sm}{\mbox{ }} -\newcommand{\mx}{\mbox} - -%\newcommand{\nq}{\neq} -%\newcommand{\eq}{\equiv} -\newcommand{\fa}{\forall} -%\newcommand{\ex}{\exists} -\newcommand{\impl}{\rightarrow} -%\newcommand{\Or}{\vee} -%\newcommand{\And}{\wedge} -\newcommand{\ms}{\models} -\newcommand{\bw}{\bigwedge} -\newcommand{\ts}{\times} -\newcommand{\cc}{\circ} -%\newcommand{\es}{\emptyset} -%\newcommand{\bs}{\backslash} -\newcommand{\vd}{\vdash} -%\newcommand{\lan}{{\langle }} -%\newcommand{\ran}{{\rangle }} - -%\newcommand{\al}{\alpha} -\newcommand{\bt}{\beta} -%\newcommand{\io}{\iota} -\newcommand{\lb}{\lambda} -%\newcommand{\sg}{\sigma} -%\newcommand{\sa}{\Sigma} -%\newcommand{\om}{\Omega} -%\newcommand{\tu}{\tau} - -%%%%%%%%%%%%%%%%%%%%%%%%% -% Custom maths commands % -%%%%%%%%%%%%%%%%%%%%%%%%% - -\newcommand{\sumbool}[2]{\{#1\}+\{#2\}} -\newcommand{\myifthenelse}[3]{\kw{if} ~ #1 ~\kw{then} ~ #2 ~ \kw{else} ~ #3} -\newcommand{\fun}[2]{\item[]{\tt {#1}}. \quad\\ #2} -\newcommand{\WF}[2]{\ensuremath{{\mathcal{W\!F}}(#1)[#2]}} -\newcommand{\WFTWOLINES}[2]{\ensuremath{{\mathcal{W\!F}}\begin{array}{l}(#1)\\\mbox{}[{#2}]\end{array}}} -\newcommand{\WFE}[1]{\WF{E}{#1}} -\newcommand{\WT}[4]{\ensuremath{#1[#2] \vdash #3 : #4}} -\newcommand{\WTE}[3]{\WT{E}{#1}{#2}{#3}} -\newcommand{\WTEG}[2]{\WTE{\Gamma}{#1}{#2}} - -\newcommand{\WTM}[3]{\WT{#1}{}{#2}{#3}} -\newcommand{\WFT}[2]{\ensuremath{#1[] \vdash {\mathcal{W\!F}}(#2)}} -\newcommand{\WS}[3]{\ensuremath{#1[] \vdash #2 <: #3}} -\newcommand{\WSE}[2]{\WS{E}{#1}{#2}} -\newcommand{\WEV}[3]{\mbox{$#1[] \vdash #2 \lra #3$}} -\newcommand{\WEVT}[3]{\mbox{$#1[] \vdash #2 \lra$}\\ \mbox{$ #3$}} - -\newcommand{\WTRED}[5]{\mbox{$#1[#2] \vdash #3 #4 #5$}} -\newcommand{\WTERED}[4]{\mbox{$E[#1] \vdash #2 #3 #4$}} -\newcommand{\WTELECONV}[3]{\WTERED{#1}{#2}{\leconvert}{#3}} -\newcommand{\WTEGRED}[3]{\WTERED{\Gamma}{#1}{#2}{#3}} -\newcommand{\WTECONV}[3]{\WTERED{#1}{#2}{\convert}{#3}} -\newcommand{\WTEGCONV}[2]{\WTERED{\Gamma}{#1}{\convert}{#2}} -\newcommand{\WTEGLECONV}[2]{\WTERED{\Gamma}{#1}{\leconvert}{#2}} - -\newcommand{\lab}[1]{\mathit{labels}(#1)} -\newcommand{\dom}[1]{\mathit{dom}(#1)} - -\newcommand{\CI}[2]{\mbox{$\{#1\}^{#2}$}} -\newcommand{\CIP}[3]{\mbox{$\{#1\}_{#2}^{#3}$}} -\newcommand{\CIPV}[1]{\CIP{#1}{I_1.. I_k}{P_1.. P_k}} -\newcommand{\CIPI}[1]{\CIP{#1}{I}{P}} -\newcommand{\CIF}[1]{\mbox{$\{#1\}_{f_1.. f_n}$}} -%BEGIN LATEX -\newcommand{\NInd}[3]{\mbox{{\sf Ind}$(\begin{array}[t]{@{}l}#2:=#3 - \,)\end{array}$}} -\newcommand{\Ind}[4]{\mbox{{\sf Ind}$[#2](\begin{array}[t]{@{}l@{}}#3:=#4 - \,)\end{array}$}} -%END LATEX -%HEVEA \newcommand{\NInd}[3]{\mbox{{\sf Ind}$(#2\,:=\,#3)$}} -%HEVEA \newcommand{\Ind}[4]{\mbox{{\sf Ind}$[#2](#3\,:=\,#4)$}} - -\newcommand{\Indp}[5]{\mbox{{\sf Ind}$_{#5}(#1)[#2](\begin{array}[t]{@{}l}#3:=#4 - \,)\end{array}$}} -\newcommand{\Indpstr}[6]{\mbox{{\sf Ind}$_{#5}(#1)[#2](\begin{array}[t]{@{}l}#3:=#4 - \,)/{#6}\end{array}$}} -\newcommand{\Def}[4]{\mbox{{\sf Def}$(#1)(#2:=#3:#4)$}} -\newcommand{\Assum}[3]{\mbox{{\sf Assum}$(#1)(#2:#3)$}} -\newcommand{\Match}[3]{\mbox{$<\!#1\!>\!{\mbox{\tt Match}}~#2~{\mbox{\tt with}}~#3~{\mbox{\tt end}}$}} -\newcommand{\Case}[3]{\mbox{$\kw{case}(#2,#1,#3)$}} -\newcommand{\match}[3]{\mbox{$\kw{match}~ #2 ~\kw{with}~ #3 ~\kw{end}$}} -\newcommand{\Fix}[2]{\mbox{\tt Fix}~#1\{#2\}} -\newcommand{\CoFix}[2]{\mbox{\tt CoFix}~#1\{#2\}} -\newcommand{\With}[2]{\mbox{\tt ~with~}} -\newcommand{\letin}[3]{\kw{let}~#1:=#2~\kw{in}~#3} -\newcommand{\subst}[3]{#1\{#2/#3\}} -\newcommand{\substs}[4]{#1\{(#2/#3)_{#4}\}} -\newcommand{\Sort}{\mbox{$\mathcal{S}$}} -\newcommand{\convert}{=_{\beta\delta\iota\zeta\eta}} -\newcommand{\leconvert}{\leq_{\beta\delta\iota\zeta\eta}} -\newcommand{\NN}{\mathbb{N}} -\newcommand{\inference}[1]{$${#1}$$} - -\newcommand{\compat}[2]{\mbox{$[#1|#2]$}} -\newcommand{\tristackrel}[3]{\mathrel{\mathop{#2}\limits_{#3}^{#1}}} - -\newcommand{\Impl}{{\it Impl}} -\newcommand{\elem}{{\it e}} -\newcommand{\Mod}[3]{{\sf Mod}({#1}:{#2}\,\zeroone{:={#3}})} -\newcommand{\ModS}[2]{{\sf Mod}({#1}:{#2})} -\newcommand{\ModType}[2]{{\sf ModType}({#1}:={#2})} -\newcommand{\ModA}[2]{{\sf ModA}({#1}=={#2})} -\newcommand{\functor}[3]{\ensuremath{{\sf Functor}(#1:#2)\;#3}} -\newcommand{\funsig}[3]{\ensuremath{{\sf Funsig}(#1:#2)\;#3}} -\newcommand{\sig}[1]{\ensuremath{{\sf Sig}~#1~{\sf End}}} -\newcommand{\struct}[1]{\ensuremath{{\sf Struct}~#1~{\sf End}}} -\newcommand{\structe}[1]{\ensuremath{ - {\sf Struct}~\elem_1;\ldots;\elem_i;#1;\elem_{i+2};\ldots - ;\elem_n~{\sf End}}} -\newcommand{\structes}[2]{\ensuremath{ - {\sf Struct}~\elem_1;\ldots;\elem_i;#1;\elem_{i+2}\{#2\} - ;\ldots;\elem_n\{#2\}~{\sf End}}} -\newcommand{\with}[3]{\ensuremath{#1~{\sf with}~#2 := #3}} - -\newcommand{\Spec}{{\it Spec}} -\newcommand{\ModSEq}[3]{{\sf Mod}({#1}:{#2}:={#3})} - - -%\newbox\tempa -%\newbox\tempb -%\newdimen\tempc -%\newcommand{\mud}[1]{\hfil $\displaystyle{\mathstrut #1}$\hfil} -%\newcommand{\rig}[1]{\hfil $\displaystyle{#1}$} -% \newcommand{\irulehelp}[3]{\setbox\tempa=\hbox{$\displaystyle{\mathstrut #2}$}% -% \setbox\tempb=\vbox{\halign{##\cr -% \mud{#1}\cr -% \noalign{\vskip\the\lineskip} -% \noalign{\hrule height 0pt} -% \rig{\vbox to 0pt{\vss\hbox to 0pt{${\; #3}$\hss}\vss}}\cr -% \noalign{\hrule} -% \noalign{\vskip\the\lineskip} -% \mud{\copy\tempa}\cr}} -% \tempc=\wd\tempb -% \advance\tempc by \wd\tempa -% \divide\tempc by 2 } -% \newcommand{\irule}[3]{{\irulehelp{#1}{#2}{#3} -% \hbox to \wd\tempa{\hss \box\tempb \hss}}} - -\newcommand{\sverb}[1]{{\tt #1}} -\newcommand{\mover}[2]{{#1\over #2}} -\newcommand{\jd}[2]{#1 \vdash #2} -\newcommand{\mathline}[1]{\[#1\]} -\newcommand{\zrule}[2]{#2: #1} -\newcommand{\orule}[3]{#3: {\mover{#1}{#2}}} -\newcommand{\trule}[4]{#4: \mover{#1 \qquad #2} {#3}} -\newcommand{\thrule}[5]{#5: {\mover{#1 \qquad #2 \qquad #3}{#4}}} - - - -% placement of figures - -%BEGIN LATEX -\renewcommand{\topfraction}{.99} -\renewcommand{\bottomfraction}{.99} -\renewcommand{\textfraction}{.01} -\renewcommand{\floatpagefraction}{.9} -%END LATEX - -% Macros Bruno pour description de la syntaxe - -\def\bfbar{\ensuremath{|\hskip -0.22em{}|\hskip -0.24em{}|}} -\def\TERMbar{\bfbar} -\def\TERMbarbar{\bfbar\bfbar} - - -%% Macros pour les grammaires -\def\GR#1{\text{\large(}#1\text{\large)}} -\def\NT#1{\langle\textit{#1}\rangle} -\def\NTL#1#2{\langle\textit{#1}\rangle_{#2}} -\def\TERM#1{{\bf\textrm{\bf #1}}} -%\def\TERM#1{{\bf\textsf{#1}}} -\def\KWD#1{\TERM{#1}} -\def\ETERM#1{\TERM{#1}} -\def\CHAR#1{\TERM{#1}} - -\def\STAR#1{#1*} -\def\STARGR#1{\GR{#1}*} -\def\PLUS#1{#1+} -\def\PLUSGR#1{\GR{#1}+} -\def\OPT#1{#1?} -\def\OPTGR#1{\GR{#1}?} -%% Tableaux de definition de non-terminaux -\newenvironment{cadre} - {\begin{array}{|c|}\hline\\} - {\\\\\hline\end{array}} -\newenvironment{rulebox} - {$$\begin{cadre}\begin{array}{r@{~}c@{~}l@{}l@{}r}} - {\end{array}\end{cadre}$$} -\def\DEFNT#1{\NT{#1} & ::= &} -\def\EXTNT#1{\NT{#1} & ::= & ... \\&|&} -\def\RNAME#1{(\textsc{#1})} -\def\SEPDEF{\\\\} -\def\nlsep{\\&|&} -\def\nlcont{\\&&} -\newenvironment{rules} - {\begin{center}\begin{rulebox}} - {\end{rulebox}\end{center}} - - -%%% Local Variables: -%%% mode: latex -%%% TeX-master: "Reference-Manual" -%%% End: diff --git a/stdlib/doc/common/styles/html/coqremote/cover.html b/stdlib/doc/common/styles/html/coqremote/cover.html deleted file mode 100644 index b7c83bd2f9b2..000000000000 --- a/stdlib/doc/common/styles/html/coqremote/cover.html +++ /dev/null @@ -1,109 +0,0 @@ - - - - - - - - - - - - - - -Reference Manual | The Coq Proof Assistant - - - - - -
- - - - - -
- -
-

Reference Manual

- -

Version COQVERSION

-
- -

The Coq Development Team

-


- -

Copyright Ā© 1999-2019, Inria, CNRS and contributors

- -

This material 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/stdlib/doc/common/styles/html/coqremote/footer.html b/stdlib/doc/common/styles/html/coqremote/footer.html deleted file mode 100644 index 23dfccb62cc0..000000000000 --- a/stdlib/doc/common/styles/html/coqremote/footer.html +++ /dev/null @@ -1,34 +0,0 @@ -
- -
- - - - - - - - - diff --git a/stdlib/doc/common/styles/html/coqremote/header.html b/stdlib/doc/common/styles/html/coqremote/header.html deleted file mode 100644 index 42a56ad8e939..000000000000 --- a/stdlib/doc/common/styles/html/coqremote/header.html +++ /dev/null @@ -1,42 +0,0 @@ - - - - - - - - - - - - - -Standard Library | The Coq Proof Assistant - - - - - -
- - - - -
diff --git a/stdlib/doc/common/styles/html/coqremote/hevea.css b/stdlib/doc/common/styles/html/coqremote/hevea.css deleted file mode 100644 index 5f4edef6f130..000000000000 --- a/stdlib/doc/common/styles/html/coqremote/hevea.css +++ /dev/null @@ -1,36 +0,0 @@ - -.li-itemize{margin:1ex 0ex;} -.li-enumerate{margin:1ex 0ex;} -.dd-description{margin:0ex 0ex 1ex 4ex;} -.dt-description{margin:0ex;} -.toc{list-style:none;} -.thefootnotes{text-align:left;margin:0ex;} -.dt-thefootnotes{margin:0em;} -.dd-thefootnotes{margin:0em 0em 0em 2em;} -.footnoterule{margin:1em auto 1em 0px;width:50%;} -.caption{padding-left:2ex; padding-right:2ex; margin-left:auto; margin-right:auto} -.title{margin:2ex auto;text-align:center} -.center{text-align:center;margin-left:auto;margin-right:auto;} -.flushleft{text-align:left;margin-left:0ex;margin-right:auto;} -.flushright{text-align:right;margin-left:auto;margin-right:0ex;} -DIV TABLE{margin-left:inherit;margin-right:inherit;} -PRE{text-align:left;margin-left:0ex;margin-right:auto;} -BLOCKQUOTE{margin-left:4ex;margin-right:4ex;text-align:left;} -TD P{margin:0px;} -.boxed{border:1px solid black} -.textboxed{border:1px solid black} -.vbar{border:none;width:2px;background-color:black;} -.hbar{border:none;height:2px;width:100%;background-color:black;} -.hfill{border:none;height:1px;width:200%;background-color:black;} -.vdisplay{border-collapse:separate;border-spacing:2px;width:auto; empty-cells:show; border:2px solid red;} -.vdcell{white-space:nowrap;padding:0px;width:auto; border:2px solid green;} -.display{border-collapse:separate;border-spacing:2px;width:auto; border:none;} -.dcell{white-space:nowrap;padding:0px;width:auto; border:none;} -.dcenter{margin:0ex auto;} -.vdcenter{border:solid #FF8000 2px; margin:0ex auto;} -.minipage{text-align:left; margin-left:0em; margin-right:auto;} -.marginpar{border:solid thin black; width:20%; text-align:left;} -.marginparleft{float:left; margin-left:0ex; margin-right:1ex;} -.marginparright{float:right; margin-left:1ex; margin-right:0ex;} -.theorem{text-align:left;margin:1ex auto 1ex 0ex;} -.part{margin:2ex auto;text-align:center} diff --git a/stdlib/doc/common/styles/html/coqremote/modules/node/node.css b/stdlib/doc/common/styles/html/coqremote/modules/node/node.css deleted file mode 100644 index 60d01308e93c..000000000000 --- a/stdlib/doc/common/styles/html/coqremote/modules/node/node.css +++ /dev/null @@ -1,43 +0,0 @@ - -.node-unpublished { - background-color: #fff4f4; -} -.preview .node { - background-color: #ffffea; -} -#node-admin-filter ul { - list-style-type: none; - padding: 0; - margin: 0; - width: 100%; -} -#node-admin-buttons { - float: left; /* LTR */ - margin-left: 0.5em; /* LTR */ - clear: right; /* LTR */ -} -td.revision-current { - background: #ffc; -} -.node-form .form-text { - display: block; - width: 95%; -} -.node-form .container-inline .form-text { - display: inline; - width: auto; -} -.node-form .standard { - clear: both; -} -.node-form textarea { - display: block; - width: 95%; -} -.node-form .attachments fieldset { - float: none; - display: block; -} -.terms-inline { - display: inline; -} diff --git a/stdlib/doc/common/styles/html/coqremote/modules/system/defaults.css b/stdlib/doc/common/styles/html/coqremote/modules/system/defaults.css deleted file mode 100644 index eb983b7f817f..000000000000 --- a/stdlib/doc/common/styles/html/coqremote/modules/system/defaults.css +++ /dev/null @@ -1,52 +0,0 @@ - -/* -** HTML elements -*/ -fieldset { - margin-bottom: 1em; - padding: .5em; -} -form { - margin: 0; - padding: 0; -} -hr { - height: 1px; - border: 1px solid gray; -} -img { - border: 0; -} -table { - border-collapse: collapse; -} -th { - text-align: left; /* LTR */ - padding-right: 1em; /* LTR */ - border-bottom: 3px solid #ccc; -} - -/* -** Markup free clearing -** Details: http://www.positioniseverything.net/easyclearing.html -*/ -.clear-block:after { - content: "."; - display: block; - height: 0; - clear: both; - visibility: hidden; -} - -.clear-block { - display: inline-block; -} - -/* Hides from IE-mac \*/ -* html .clear-block { - height: 1%; -} -.clear-block { - display: block; -} -/* End hide from IE-mac */ diff --git a/stdlib/doc/common/styles/html/coqremote/modules/system/system.css b/stdlib/doc/common/styles/html/coqremote/modules/system/system.css deleted file mode 100644 index 9556c7882a3f..000000000000 --- a/stdlib/doc/common/styles/html/coqremote/modules/system/system.css +++ /dev/null @@ -1,543 +0,0 @@ - -/* -** HTML elements -*/ -body.drag { - cursor: move; -} -th.active img { - display: inline; -} -tr.even, tr.odd { - background-color: #eee; - border-bottom: 1px solid #ccc; - padding: 0.1em 0.6em; -} -tr.drag { - background-color: #fffff0; -} -tr.drag-previous { - background-color: #ffd; -} -td.active { - background-color: #ddd; -} -td.checkbox, th.checkbox { - text-align: center; -} -tbody { - border-top: 1px solid #ccc; -} -tbody th { - border-bottom: 1px solid #ccc; -} -thead th { - text-align: left; /* LTR */ - padding-right: 1em; /* LTR */ - border-bottom: 3px solid #ccc; -} - -/* -** Other common styles -*/ -.breadcrumb { - padding-bottom: .5em -} -div.indentation { - width: 20px; - height: 1.7em; - margin: -0.4em 0.2em -0.4em -0.4em; /* LTR */ - padding: 0.42em 0 0.42em 0.6em; /* LTR */ - float: left; /* LTR */ -} -div.tree-child { - background: url(../../misc/tree.png) no-repeat 11px center; /* LTR */ -} -div.tree-child-last { - background: url(../../misc/tree-bottom.png) no-repeat 11px center; /* LTR */ -} -div.tree-child-horizontal { - background: url(../../misc/tree.png) no-repeat -11px center; -} -.error { - color: #e55; -} -div.error { - border: 1px solid #d77; -} -div.error, tr.error { - background: #fcc; - color: #200; - padding: 2px; -} -.warning { - color: #e09010; -} -div.warning { - border: 1px solid #f0c020; -} -div.warning, tr.warning { - background: #ffd; - color: #220; - padding: 2px; -} -.ok { - color: #008000; -} -div.ok { - border: 1px solid #00aa00; -} -div.ok, tr.ok { - background: #dfd; - color: #020; - padding: 2px; -} -.item-list .icon { - color: #555; - float: right; /* LTR */ - padding-left: 0.25em; /* LTR */ - clear: right; /* LTR */ -} -.item-list .title { - font-weight: bold; -} -.item-list ul { - margin: 0 0 0.75em 0; - padding: 0; -} -.item-list ul li { - margin: 0 0 0.25em 1.5em; /* LTR */ - padding: 0; - list-style: disc; -} -ol.task-list li.active { - font-weight: bold; -} -.form-item { - margin-top: 1em; - margin-bottom: 1em; -} -tr.odd .form-item, tr.even .form-item { - margin-top: 0; - margin-bottom: 0; - white-space: nowrap; -} -tr.merge-down, tr.merge-down td, tr.merge-down th { - border-bottom-width: 0 !important; -} -tr.merge-up, tr.merge-up td, tr.merge-up th { - border-top-width: 0 !important; -} -.form-item input.error, .form-item textarea.error, .form-item select.error { - border: 2px solid red; -} -.form-item .description { - font-size: 0.85em; -} -.form-item label { - display: block; - font-weight: bold; -} -.form-item label.option { - display: inline; - font-weight: normal; -} -.form-checkboxes, .form-radios { - margin: 1em 0; -} -.form-checkboxes .form-item, .form-radios .form-item { - margin-top: 0.4em; - margin-bottom: 0.4em; -} -.marker, .form-required { - color: #f00; -} -.more-link { - text-align: right; /* LTR */ -} -.more-help-link { - font-size: 0.85em; - text-align: right; /* LTR */ -} -.nowrap { - white-space: nowrap; -} -.item-list .pager { - clear: both; - text-align: center; -} -.item-list .pager li { - background-image:none; - display:inline; - list-style-type:none; - padding: 0.5em; -} -.pager-current { - font-weight:bold; -} -.tips { - margin-top: 0; - margin-bottom: 0; - padding-top: 0; - padding-bottom: 0; - font-size: 0.9em; -} -dl.multiselect dd.b, dl.multiselect dd.b .form-item, dl.multiselect dd.b select { - font-family: inherit; - font-size: inherit; - width: 14em; -} -dl.multiselect dd.a, dl.multiselect dd.a .form-item { - width: 10em; -} -dl.multiselect dt, dl.multiselect dd { - float: left; /* LTR */ - line-height: 1.75em; - padding: 0; - margin: 0 1em 0 0; /* LTR */ -} -dl.multiselect .form-item { - height: 1.75em; - margin: 0; -} - -/* -** Inline items (need to override above) -*/ -.container-inline div, .container-inline label { - display: inline; -} - -/* -** Tab navigation -*/ -ul.primary { - border-collapse: collapse; - padding: 0 0 0 1em; /* LTR */ - white-space: nowrap; - list-style: none; - margin: 5px; - height: auto; - line-height: normal; - border-bottom: 1px solid #bbb; -} -ul.primary li { - display: inline; -} -ul.primary li a { - background-color: #ddd; - border-color: #bbb; - border-width: 1px; - border-style: solid solid none solid; - height: auto; - margin-right: 0.5em; /* LTR */ - padding: 0 1em; - text-decoration: none; -} -ul.primary li.active a { - background-color: #fff; - border: 1px solid #bbb; - border-bottom: #fff 1px solid; -} -ul.primary li a:hover { - background-color: #eee; - border-color: #ccc; - border-bottom-color: #eee; -} -ul.secondary { - border-bottom: 1px solid #bbb; - padding: 0.5em 1em; - margin: 5px; -} -ul.secondary li { - display: inline; - padding: 0 1em; - border-right: 1px solid #ccc; /* LTR */ -} -ul.secondary a { - padding: 0; - text-decoration: none; -} -ul.secondary a.active { - border-bottom: 4px solid #999; -} - -/* -** Autocomplete styles -*/ -/* Suggestion list */ -#autocomplete { - position: absolute; - border: 1px solid; - overflow: hidden; - z-index: 100; -} -#autocomplete ul { - margin: 0; - padding: 0; - list-style: none; -} -#autocomplete li { - background: #fff; - color: #000; - white-space: pre; - cursor: default; -} -#autocomplete li.selected { - background: #0072b9; - color: #fff; -} -/* Animated throbber */ -html.js input.form-autocomplete { - background-image: url(../../misc/throbber.gif); - background-repeat: no-repeat; - background-position: 100% 2px; /* LTR */ -} -html.js input.throbbing { - background-position: 100% -18px; /* LTR */ -} - -/* -** Collapsing fieldsets -*/ -html.js fieldset.collapsed { - border-bottom-width: 0; - border-left-width: 0; - border-right-width: 0; - margin-bottom: 0; - height: 1em; -} -html.js fieldset.collapsed * { - display: none; -} -html.js fieldset.collapsed legend { - display: block; -} -html.js fieldset.collapsible legend a { - padding-left: 15px; /* LTR */ - background: url(../../misc/menu-expanded.png) 5px 75% no-repeat; /* LTR */ -} -html.js fieldset.collapsed legend a { - background-image: url(../../misc/menu-collapsed.png); /* LTR */ - background-position: 5px 50%; /* LTR */ -} -/* Note: IE-only fix due to '* html' (breaks Konqueror otherwise). */ -* html.js fieldset.collapsed legend, -* html.js fieldset.collapsed legend *, -* html.js fieldset.collapsed table * { - display: inline; -} -/* For Safari 2 to prevent collapsible fieldsets containing tables from disappearing due to tableheader.js. */ -html.js fieldset.collapsible { - position: relative; -} -html.js fieldset.collapsible legend a { - display: block; -} -/* Avoid jumping around due to margins collapsing into collapsible fieldset border */ -html.js fieldset.collapsible .fieldset-wrapper { - overflow: auto; -} - -/* -** Resizable text areas -*/ -.resizable-textarea { - width: 95%; -} -.resizable-textarea .grippie { - height: 9px; - overflow: hidden; - background: #eee url(../../misc/grippie.png) no-repeat center 2px; - border: 1px solid #ddd; - border-top-width: 0; - cursor: s-resize; -} -html.js .resizable-textarea textarea { - margin-bottom: 0; - width: 100%; - display: block; -} - -/* -** Table drag and drop. -*/ -.draggable a.tabledrag-handle { - cursor: move; - float: left; /* LTR */ - height: 1.7em; - margin: -0.4em 0 -0.4em -0.5em; /* LTR */ - padding: 0.42em 1.5em 0.42em 0.5em; /* LTR */ - text-decoration: none; -} -a.tabledrag-handle:hover { - text-decoration: none; -} -a.tabledrag-handle .handle { - margin-top: 4px; - height: 13px; - width: 13px; - background: url(../../misc/draggable.png) no-repeat 0 0; -} -a.tabledrag-handle-hover .handle { - background-position: 0 -20px; -} - -/* -** Teaser splitter -*/ -.joined + .grippie { - height: 5px; - background-position: center 1px; - margin-bottom: -2px; -} -/* Keeps inner content contained in Opera 9. */ -.teaser-checkbox { - padding-top: 1px; -} -div.teaser-button-wrapper { - float: right; /* LTR */ - padding-right: 5%; /* LTR */ - margin: 0; -} -.teaser-checkbox div.form-item { - float: right; /* LTR */ - margin: 0 5% 0 0; /* LTR */ - padding: 0; -} -textarea.teaser { - display: none; -} -html.js .no-js { - display: none; -} - -/* -** Progressbar styles -*/ -.progress { - font-weight: bold; -} -.progress .bar { - background: #fff url(../../misc/progress.gif); - border: 1px solid #00375a; - height: 1.5em; - margin: 0 0.2em; -} -.progress .filled { - background: #0072b9; - height: 1em; - border-bottom: 0.5em solid #004a73; - width: 0%; -} -.progress .percentage { - float: right; /* LTR */ -} -.progress-disabled { - float: left; /* LTR */ -} -.ahah-progress { - float: left; /* LTR */ -} -.ahah-progress .throbber { - width: 15px; - height: 15px; - margin: 2px; - background: transparent url(../../misc/throbber.gif) no-repeat 0px -18px; - float: left; /* LTR */ -} -tr .ahah-progress .throbber { - margin: 0 2px; -} -.ahah-progress-bar { - width: 16em; -} - -/* -** Formatting for welcome page -*/ -#first-time strong { - display: block; - padding: 1.5em 0 .5em; -} - -/* -** To be used with tableselect.js -*/ -tr.selected td { - background: #ffc; -} - -/* -** Floating header for tableheader.js -*/ -table.sticky-header { - margin-top: 0; - background: #fff; -} - -/* -** Installation clean URLs -*/ -#clean-url.install { - display: none; -} - -/* -** For anything you want to hide on page load when JS is enabled, so -** that you can use the JS to control visibility and avoid flicker. -*/ -html.js .js-hide { - display: none; -} - -/* -** Styles for the system modules page (admin/build/modules) -*/ -#system-modules div.incompatible { - font-weight: bold; -} - -/* -** Styles for the system themes page (admin/build/themes) -*/ -#system-themes-form div.incompatible { - font-weight: bold; -} - -/* -** Password strength indicator -*/ -span.password-strength { - visibility: hidden; -} -input.password-field { - margin-right: 10px; /* LTR */ -} -div.password-description { - padding: 0 2px; - margin: 4px 0 0 0; - font-size: 0.85em; - max-width: 500px; -} -div.password-description ul { - margin-bottom: 0; -} -.password-parent { - margin: 0 0 0 0; -} -/* -** Password confirmation checker -*/ -input.password-confirm { - margin-right: 10px; /* LTR */ -} -.confirm-parent { - margin: 5px 0 0 0; -} -span.password-confirm { - visibility: hidden; -} -span.password-confirm span { - font-weight: normal; -} diff --git a/stdlib/doc/common/styles/html/coqremote/modules/user/user.css b/stdlib/doc/common/styles/html/coqremote/modules/user/user.css deleted file mode 100644 index 7b2163e3d39a..000000000000 --- a/stdlib/doc/common/styles/html/coqremote/modules/user/user.css +++ /dev/null @@ -1,58 +0,0 @@ - -#permissions td.module { - font-weight: bold; -} -#permissions td.permission { - padding-left: 1.5em; /* LTR */ -} -#access-rules .access-type, #access-rules .rule-type { - margin-right: 1em; /* LTR */ - float: left; /* LTR */ -} -#access-rules .access-type .form-item, #access-rules .rule-type .form-item { - margin-top: 0; -} -#access-rules .mask { - clear: both; -} -#user-login-form { - text-align: center; -} -#user-admin-filter ul { - list-style-type: none; - padding: 0; - margin: 0; - width: 100%; -} -#user-admin-buttons { - float: left; /* LTR */ - margin-left: 0.5em; /* LTR */ - clear: right; /* LTR */ -} -#user-admin-settings fieldset .description { - font-size: 0.85em; - padding-bottom: .5em; -} - -/* Generated by user.module but used by profile.module: */ -.profile { - clear: both; - margin: 1em 0; -} -.profile .picture { - float: right; /* LTR */ - margin: 0 1em 1em 0; /* LTR */ -} -.profile h3 { - border-bottom: 1px solid #ccc; -} -.profile dl { - margin: 0 0 1.5em 0; -} -.profile dt { - margin: 0 0 0.2em 0; - font-weight: bold; -} -.profile dd { - margin: 0 0 1em 0; -} diff --git a/stdlib/doc/common/styles/html/coqremote/styles.hva b/stdlib/doc/common/styles/html/coqremote/styles.hva deleted file mode 100644 index a09dc4f85f87..000000000000 --- a/stdlib/doc/common/styles/html/coqremote/styles.hva +++ /dev/null @@ -1,81 +0,0 @@ -\renewcommand{\@meta}{ -\begin{rawhtml} - - - - - - - - -\end{rawhtml}} - -% for HeVeA - -\htmlhead{\begin{rawhtml} -
- - - - - -
- -\end{rawhtml}} - -\htmlfoot{\begin{rawhtml} -
- -
- -
- - - -
-\end{rawhtml}} diff --git a/stdlib/doc/common/styles/html/simple/cover.html b/stdlib/doc/common/styles/html/simple/cover.html deleted file mode 100644 index 28ce2eb08747..000000000000 --- a/stdlib/doc/common/styles/html/simple/cover.html +++ /dev/null @@ -1,61 +0,0 @@ - - - - - - -Reference Manual | The Coq Proof Assistant - - - - - - - - -
- - -
- -
-

Reference Manual

- -

Version COQVERSION

-
- -

The Coq Development Team

-


- - -

Copyright Ā© 1999-2019, Inria, CNRS and contributors

- -

This material 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/stdlib/doc/common/styles/html/simple/footer.html b/stdlib/doc/common/styles/html/simple/footer.html deleted file mode 100644 index 308b1d01b6ca..000000000000 --- a/stdlib/doc/common/styles/html/simple/footer.html +++ /dev/null @@ -1,2 +0,0 @@ - - diff --git a/stdlib/doc/common/styles/html/simple/header.html b/stdlib/doc/common/styles/html/simple/header.html deleted file mode 100644 index 5134df997a7b..000000000000 --- a/stdlib/doc/common/styles/html/simple/header.html +++ /dev/null @@ -1,12 +0,0 @@ - - - - - - -The Coq Standard Library - - - diff --git a/stdlib/doc/common/styles/html/simple/hevea.css b/stdlib/doc/common/styles/html/simple/hevea.css deleted file mode 100644 index 5f4edef6f130..000000000000 --- a/stdlib/doc/common/styles/html/simple/hevea.css +++ /dev/null @@ -1,36 +0,0 @@ - -.li-itemize{margin:1ex 0ex;} -.li-enumerate{margin:1ex 0ex;} -.dd-description{margin:0ex 0ex 1ex 4ex;} -.dt-description{margin:0ex;} -.toc{list-style:none;} -.thefootnotes{text-align:left;margin:0ex;} -.dt-thefootnotes{margin:0em;} -.dd-thefootnotes{margin:0em 0em 0em 2em;} -.footnoterule{margin:1em auto 1em 0px;width:50%;} -.caption{padding-left:2ex; padding-right:2ex; margin-left:auto; margin-right:auto} -.title{margin:2ex auto;text-align:center} -.center{text-align:center;margin-left:auto;margin-right:auto;} -.flushleft{text-align:left;margin-left:0ex;margin-right:auto;} -.flushright{text-align:right;margin-left:auto;margin-right:0ex;} -DIV TABLE{margin-left:inherit;margin-right:inherit;} -PRE{text-align:left;margin-left:0ex;margin-right:auto;} -BLOCKQUOTE{margin-left:4ex;margin-right:4ex;text-align:left;} -TD P{margin:0px;} -.boxed{border:1px solid black} -.textboxed{border:1px solid black} -.vbar{border:none;width:2px;background-color:black;} -.hbar{border:none;height:2px;width:100%;background-color:black;} -.hfill{border:none;height:1px;width:200%;background-color:black;} -.vdisplay{border-collapse:separate;border-spacing:2px;width:auto; empty-cells:show; border:2px solid red;} -.vdcell{white-space:nowrap;padding:0px;width:auto; border:2px solid green;} -.display{border-collapse:separate;border-spacing:2px;width:auto; border:none;} -.dcell{white-space:nowrap;padding:0px;width:auto; border:none;} -.dcenter{margin:0ex auto;} -.vdcenter{border:solid #FF8000 2px; margin:0ex auto;} -.minipage{text-align:left; margin-left:0em; margin-right:auto;} -.marginpar{border:solid thin black; width:20%; text-align:left;} -.marginparleft{float:left; margin-left:0ex; margin-right:1ex;} -.marginparright{float:right; margin-left:1ex; margin-right:0ex;} -.theorem{text-align:left;margin:1ex auto 1ex 0ex;} -.part{margin:2ex auto;text-align:center} diff --git a/stdlib/doc/common/styles/html/simple/style.css b/stdlib/doc/common/styles/html/simple/style.css deleted file mode 100644 index 1b55028f5dab..000000000000 --- a/stdlib/doc/common/styles/html/simple/style.css +++ /dev/null @@ -1,13 +0,0 @@ -#footer { - border-top: solid black 1pt; - text-align: center; - text-indent: 0pt; -} - -.menu { } -.menu li { - display: inline; - margin: 0pt; - padding: .5ex 1em; - list-style: none -} diff --git a/stdlib/doc/common/styles/html/simple/styles.hva b/stdlib/doc/common/styles/html/simple/styles.hva deleted file mode 100644 index 3f9d556a6f58..000000000000 --- a/stdlib/doc/common/styles/html/simple/styles.hva +++ /dev/null @@ -1,45 +0,0 @@ -\renewcommand{\@meta}{ -\begin{rawhtml} - - - - - - -\end{rawhtml}} - -% for HeVeA - -\htmlhead{\begin{rawhtml} - -
- - - -
- -\end{rawhtml}} - -\htmlfoot{\begin{rawhtml} - - - -
-
-\end{rawhtml}} diff --git a/stdlib/doc/common/title.tex b/stdlib/doc/common/title.tex deleted file mode 100644 index a013bc529896..000000000000 --- a/stdlib/doc/common/title.tex +++ /dev/null @@ -1,69 +0,0 @@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -% File title.tex -% Page formatting commands -% Macro \coverpage -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - -%\setlength{\marginparwidth}{0pt} -%\setlength{\oddsidemargin}{0pt} -%\setlength{\evensidemargin}{0pt} -%\setlength{\marginparsep}{0pt} -%\setlength{\topmargin}{0pt} -%\setlength{\textwidth}{16.9cm} -%\setlength{\textheight}{22cm} -%\usepackage{fullpage} - -%\newcommand{\printingdate}{\today} -%\newcommand{\isdraft}{\Large\bf\today\\[20pt]} -%\newcommand{\isdraft}{\vspace{20pt}} - -\newcommand{\coverpage}[3]{ -\thispagestyle{empty} -\begin{center} -\bfseries % for the rest of this page, until \end{center} -\Huge -The Coq Proof Assistant\\[12pt] -#1\\[20pt] -\Large\today\\[20pt] -Version \coqversion\footnote[1]{This research was partly supported by IST working group ``Types''} - -\vspace{0pt plus .5fill} -#2 -\par\vfill -$\pi r^2$ Project (formerly LogiCal, then TypiCal) - -\vspace*{15pt} -\end{center} -\newpage - -\thispagestyle{empty} -\hbox{}\vfill % without \hbox \vfill does not work at the top of the page -\begin{flushleft} -%BEGIN LATEX -V\coqversion, \today -\par\vspace{20pt} -%END LATEX -\copyright 1999-2019, Inria, CNRS and contributors - -#3 -\end{flushleft} -} % end of \coverpage definition - - -% \newcommand{\shorttitle}[1]{ -% \begin{center} -% \begin{huge} -% \begin{bf} -% The Coq Proof Assistant\\ -% \vspace{10pt} -% #1\\ -% \end{bf} -% \end{huge} -% \end{center} -% \vspace{5pt} -% } - -% Local Variables: -% mode: LaTeX -% TeX-master: "" -% End: diff --git a/stdlib/doc/dune b/stdlib/doc/dune deleted file mode 100644 index b77a56d617f2..000000000000 --- a/stdlib/doc/dune +++ /dev/null @@ -1,58 +0,0 @@ -(alias - (name refman-deps) - (deps - ; We could use finer dependencies here so the build is faster: - ; - ; - vo files: generated by sphinx after parsing the doc, promoted, - ; - Static files: - ; + %{bin:coqdoc} etc... - ; + tools/coqdoc/coqdoc.css - (package rocq-stdlib) - (source_tree sphinx) - (source_tree tools/coqrst) - (env_var SPHINXWARNOPT))) - -(rule - (targets - (dir refman-html)) - (alias refman-html) - (package rocq-stdlib-doc) - ; Cannot use this deps alias because of ocaml/dune#3415 - ; (deps (alias refman-deps)) - ; EJGA: note this should've been fixed in dune master as of 05/03/2021 - (deps - (package rocq-stdlib) - (source_tree sphinx) - (source_tree tools/coqrst) - (env_var SPHINXWARNOPT)) - (action - (run env sphinx-build -q %{env:SPHINXWARNOPT=-W} -b html sphinx %{targets}))) - -(rule - (targets - (dir refman-pdf)) - (alias refman-pdf) - (package rocq-stdlib-doc) - ; Cannot use this deps alias because of ocaml/dune#3415 - ; (deps (alias refman-deps)) - ; EJGA: note this should've been fixed in dune master as of 05/03/2021 - (deps - (package coq-core) - (package rocq-stdlib) - (source_tree sphinx) - (source_tree tools/coqrst) - (env_var SPHINXWARNOPT)) - (action - (progn - (run env sphinx-build -q %{env:SPHINXWARNOPT=-W} -b latex sphinx %{targets}) - (chdir %{targets} (run make LATEXMKOPTS=-silent))))) - -(install - (dirs - (refman-html as html/refman) - (refman-pdf as pdf/refman)) - (section doc) - (package rocq-stdlib-doc)) - -(documentation - (package rocq-stdlib-doc)) diff --git a/stdlib/doc/sphinx/README.rst b/stdlib/doc/sphinx/README.rst deleted file mode 100644 index a81f8b2fd554..000000000000 --- a/stdlib/doc/sphinx/README.rst +++ /dev/null @@ -1,5 +0,0 @@ -============================= - Documenting Coq with Sphinx -============================= - -See the `README of Coq reference manual `_. diff --git a/stdlib/doc/sphinx/README.template.rst b/stdlib/doc/sphinx/README.template.rst deleted file mode 100644 index 374f91c44542..000000000000 --- a/stdlib/doc/sphinx/README.template.rst +++ /dev/null @@ -1,321 +0,0 @@ -============================= - Documenting Coq with Sphinx -============================= - -.. - README.rst is auto-generated from README.template.rst and the coqrst/*.py files - (in particular coqdomain.py). Use ``doc/tools/coqrst/regen_readme.py`` to rebuild it. - -Coq's reference manual is written in `reStructuredText `_ (ā€œreSTā€), and compiled with `Sphinx `_. -See `this README <../README.md>`_ for compilation instructions. - -In addition to standard reST directives (a directive is similar to a LaTeX environment) and roles (a role is similar to a LaTeX command), the ``coqrst`` plugin loaded by the documentation uses a custom *Coq domain* ā€” a set of Coq-specific directives that define *objects* like tactics, commands (vernacs), warnings, etc. ā€”, some custom *directives*, and a few custom *roles*. Finally, this manual uses a small DSL to describe tactic invocations and commands. - -Coq objects -=========== - -Our Coq domain define multiple `objects`_. Each object has a *signature* (think *type signature*), followed by an optional body (a description of that object). The following example defines two objects: a variant of the ``simpl`` tactic, and an error that it may raise:: - - .. tacv:: simpl @pattern at {+ @natural} - :name: simpl_at - - This applies ``simpl`` only to the :n:`{+ @natural}` occurrences of the subterms - matching :n:`@pattern` in the current goal. - - .. exn:: Too few occurrences - :undocumented: - -Objects are automatically collected into indices, and can be linked to using the role version of the object's directive. For example, you could link to the tactic variant above using ``:tacv:`simpl_at```, and to its exception using ``:exn:`Too few occurrences```. - -Names (link targets) are auto-generated for most simple objects, though they can always be overwritten using a ``:name:`` option, as shown above. - -- Options, errors, warnings have their name set to their signature, with ``...`` replacing all notation bits. For example, the auto-generated name of ``.. exn:: @qualid is not a module`` is ``... is not a module``, and a link to it would take the form ``:exn:`... is not a module```. -- Vernacs (commands) have their name set to the first word of their signature. For example, the auto-generated name of ``Axiom @ident : @term`` is ``Axiom``, and a link to it would take the form ``:cmd:`Axiom```. -- Vernac variants, tactic notations, and tactic variants do not have a default name. - -Most objects should have a body (i.e. a block of indented text following the signature, called ā€œcontentsā€ in Sphinx terms). Undocumented objects should have the ``:undocumented:`` flag instead, as shown above. When multiple objects have a single description, they can be grouped into a single object, like this (semicolons can be used to separate the names of the objects; names starting with ``_`` will be omitted from the indexes):: - - .. cmdv:: Lemma @ident {* @binder } : @type - Remark @ident {* @binder } : @type - Fact @ident {* @binder } : @type - Corollary @ident {* @binder } : @type - Proposition @ident {* @binder } : @type - :name: Lemma; Remark; Fact; Corollary; Proposition - - These commands are all synonyms of :n:`Theorem @ident {* @binder } : type`. - -Notations ---------- - -The signatures of most objects can be written using a succinct DSL for Coq notations (think regular expressions written with a Lispy syntax). A typical signature might look like ``Hint Extern @natural {? @pattern} => @tactic``, which means that the ``Hint Extern`` command takes a number (``natural``), followed by an optional pattern, and a mandatory tactic. The language has the following constructs (the full grammar is in `TacticNotations.g `_): - -``@ā€¦`` - A placeholder (``@ident``, ``@natural``, ``@tactic``\ ā€¦) - -``{? ā€¦}`` - an optional block - -``{* ā€¦}``, ``{+ ā€¦}`` - an optional (``*``) or mandatory (``+``) block that can be repeated, with repetitions separated by spaces - -``{*, ā€¦}``, ``{+, ā€¦}`` - an optional or mandatory repeatable block, with repetitions separated by commas - -``{| ā€¦ | ā€¦ | ā€¦ }`` - an alternative, indicating than one of multiple constructs can be used - -``%{``, ``%}``, ``%|`` - an escaped character (rendered without the leading ``%``). In most cases, - escaping is not necessary. In particular, the following expressions are - all parsed as plain text, and do not need escaping: ``{ xyz }``, ``x |- y``. - But the following escapes *are* needed: ``{| a b %| c | d }``, ``all: %{``. - (We use ``%`` instead of the usual ``\`` because you'd have to type ``\`` - twice in your reStructuredText file.) - - For more details and corner cases, see `Advanced uses of notations`_ below. - -.. - FIXME document the new subscript support - -As an exercise, what do the following patterns mean? - -.. code:: - - pattern {+, @term {? at {+ @natural}}} - generalize {+, @term at {+ @natural} as @ident} - fix @ident @natural with {+ (@ident {+ @binder} {? {struct @ident'}} : @type)} - -Objects -------- - -Here is the list of all objects of the Coq domain (The symbol :black_nib: indicates an object whose signature can be written using the notations DSL): - -[OBJECTS] - -Coq directives -============== - -In addition to the objects above, the ``coqrst`` Sphinx plugin defines the following directives: - -[DIRECTIVES] - -Coq roles -========= - -In addition to the objects and directives above, the ``coqrst`` Sphinx plugin defines the following roles: - -[ROLES] - -Common mistakes -=============== - -Improper nesting ----------------- - -DO - .. code:: - - .. cmd:: Foo @bar - - Foo the first instance of :token:`bar`\ s. - - .. cmdv:: Foo All - - Foo all the :token:`bar`\ s in - the current context - -DON'T - .. code:: - - .. cmd:: Foo @bar - - Foo the first instance of :token:`bar`\ s. - - .. cmdv:: Foo All - - Foo all the :token:`bar`\ s in - the current context - -You can set the ``report_undocumented_coq_objects`` setting in ``conf.py`` to ``"info"`` or ``"warning"`` to get a list of all Coq objects without a description. - -Overusing ``:token:`` ---------------------- - -DO - .. code:: - - This is equivalent to :n:`Axiom @ident : @term`. - -DON'T - .. code:: - - This is equivalent to ``Axiom`` :token:`ident` : :token:`term`. - -.. - -DO - .. code:: - - :n:`power_tac @term [@ltac]` - allows :tacn:`ring` and :tacn:`ring_simplify` to recognize ā€¦ - -DON'T - .. code:: - - power_tac :n:`@term` [:n:`@ltac`] - allows :tacn:`ring` and :tacn:`ring_simplify` to recognize ā€¦ - -.. - -DO - .. code:: - - :n:`name={*; attr}` - -DON'T - .. code:: - - ``name=``:n:`{*; attr}` - -Omitting annotations --------------------- - -DO - .. code:: - - .. tacv:: assert @form as @simple_intropattern - -DON'T - .. code:: - - .. tacv:: assert form as simple_intropattern - -Using the ``.. rocqtop::`` directive for syntax highlighting ------------------------------------------------------------ - -DO - .. code:: - - A tactic of the form: - - .. rocqdoc:: - - do [ t1 | ā€¦ | tn ]. - - is equivalent to the standard Ltac expression: - - .. rocqdoc:: - - first [ t1 | ā€¦ | tn ]. - -DON'T - .. code:: - - A tactic of the form: - - .. rocqtop:: in - - do [ t1 | ā€¦ | tn ]. - - is equivalent to the standard Ltac expression: - - .. rocqtop:: in - - first [ t1 | ā€¦ | tn ]. - -Overusing plain quotes ----------------------- - -DO - .. code:: - - The :tacn:`refine` tactic can raise the :exn:`Invalid argument` exception. - The term :g:`let a = 1 in a a` is ill-typed. - -DON'T - .. code:: - - The ``refine`` tactic can raise the ``Invalid argument`` exception. - The term ``let a = 1 in a a`` is ill-typed. - -Plain quotes produce plain text, without highlighting or cross-references. - -Overusing the ``example`` directive ------------------------------------ - -DO - .. code:: - - Here is a useful axiom: - - .. rocqdoc:: - - Axiom proof_irrelevance : forall (P : Prop) (x y : P), x=y. - -DO - .. code:: - - .. example:: Using proof-irrelevance - - If you assume the axiom above, ā€¦ - -DON'T - .. code:: - - Here is a useful axiom: - - .. example:: - - .. rocqdoc:: - - Axiom proof_irrelevance : forall (P : Prop) (x y : P), x=y. - -Tips and tricks -=============== - -Nested lemmas -------------- - -The ``.. rocqtop::`` directive does *not* reset Coq after running its contents. That is, the following will create two nested lemmas (which by default results in a failure):: - - .. rocqtop:: all - - Lemma l1: 1 + 1 = 2. - - .. rocqtop:: all - - Lemma l2: 2 + 2 <> 1. - -Add either ``abort`` to the first block or ``reset`` to the second block to avoid nesting lemmas. - -Abbreviations and macros ------------------------- - -Substitutions for specially-formatted names (like ``|Cic|``, ``|Ltac|`` and ``|Latex|``), along with some useful LaTeX macros, are defined in a `separate file `_. This file is automatically included in all manual pages. - -Emacs ------ - -The ``dev/tools/coqdev.el`` folder contains a convenient Emacs function to quickly insert Sphinx roles and quotes. It takes a single character (one of ``gntm:```), and inserts one of ``:g:``, ``:n:``, ``:t:``, or an arbitrary role, or double quotes. You can also select a region of text, and wrap it in single or double backticks using that function. - -Use the following snippet to bind it to `F12` in ``rst-mode``:: - - (with-eval-after-load 'rst - (define-key rst-mode-map (kbd "") #'coqdev-sphinx-rst-coq-action)) - - -Advanced uses of notations --------------------------- - - - - Use `%` to escape grammar literal strings that are the same as metasyntax, - such as ``{``, ``|``, ``}`` and ``{|``. (While this is optional for - ``|`` and ``{ ... }`` outside of ``{| ... }``, always using the escape - requires less thought.) - - - Literals such as ``|-`` and ``||`` don't need to be escaped. - - - The literal ``%`` shouldn't be escaped. - - - Don't use the escape for a ``|`` separator in ``{*`` and ``{+``. These - should appear as ``{*|`` and ``{+|``. diff --git a/stdlib/doc/sphinx/_static/CoqNotations.ttf b/stdlib/doc/sphinx/_static/CoqNotations.ttf deleted file mode 100644 index da8f2850dfa1d6e907230aeecc73dfd90f0e336e..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 37988 zcmd4433wFOnJ#=zRj<`sb$9i?Rqw6d)h)FaBy}N#kc9w=#R!Z*fDqWmATV)^5jJ*+ z7vk8yjwgR6lh`=%#JRq?j=T|*#UYN(WU(DPvALckaJd;zc9OaCC%H3DknVe`CBV+i zow?8R&-47<>N-`YwsXGo?caBf2qlC#u+b2?zkltD1AqP9zaZqH0n`SU^)2nEt@I5- z{?pw!&Mq5XwWjs8l`}YRz_GGy&AQ%K`u!Zom+35nwuj$o_7TI z8+PtKIJvQ4#Pe+j2)RYGYsc0J^4Twa7x(6IzP1Y${10de#}hbC?7HE=%?_h!E82qg z(c`=KZr}Q`FW=-K#PT+dKY7E}o2PU?;WXI48`sNww%)Mg(HC03LdZQg!dkMEhg8auzk`SYCAcv9n}y49#PuaI$qx8uVRk(9^= zwBm7kqgun$-*I1MXSuI($53-`qoij^g}jSelflUAIG)p-C*0gHk*`tj!lrNWip4}m zYhK`=j8fNs$8TZ^AZ%?^4`pBsH9^kvhHs)YnKB+hxRq>sdYfWr&ZY zi3N2gY>RkyGr0jhH;_+|Jn6wNNFpRbqIgCE=h!xcE&D|Pof?i85i9PN@Lhu1ui@uH zj~>Ui!HVDQ2)Wa zv3MexN@tp~xqP8mDmPcEEv>b-_Kwa)UEMu(WpVEkaFt~PR}C&7TCsA~@W|>lYu8=9 zessgeYc`E--ZH**;Z6T~xqo8Ewd7_pbv?Q1I(8N4W9J9e%Xd$+V*4Jpz2Pv~#>zkc z9Q^YtRO0Y3kM9~daGuoY`vmld`3o9|9h{Q zk=cD)aq2x+D!6j;eOD@tE0s%EQc>!nM=2i#{t=;@ulPQe>d&& z&K%h$7xEZc^)ET2N#eXb!>7i#ZQsSptvimz`_MzclB^w_QTni>Y@G+@(x=KLT)%Z3 zow$~PVPtfs6rY-r;=K)MqXG{}F1>cmsCrAIcIk|?WCp@`{;rwQQrrs^S$d2O3~L~J zR(xdiB&p7wf2u_eJX0ktWCLr*jC%P57({vuM!v_PX-i5xs@9Kq%(d`+1(jbp=0e%A;EmX+;*u;Cga6+8XH4fQ`_IAmm zG(Z+E!&~OBV0-U*4i5O_k^$U|61OfH2tgWH^q(GwsXvU1;Qkyhrg!Xcq8t?g6 zo7T9RHK<8mx})!k2EON^I8Yln|FnO(og9P3JTTA%0~^i()`vo#!@i8uh8Yh1RIAu1 zdgU21ERV)_#5cr&L(1?d8yp5}b$pkvi7y}7II52JJeI6|&r#!i`=xX9do$b;AYgw^ z9aJ`^>hUu5_|oCP`%YiAa9TcQh%aArjJ-KN|3D%iyK062WfhQXyQ8J?LfQ{b8Smd3 zmqoe%*w*Lgj%+*jl%gD)S~|X~6LfGae$~XW_?po!45mu>hXc2;*E`5^x_oVKArI!$ z`&69XJ@S-7?_RTU^rT3LeD~VXr#RZX0at>t0RZ5FOXUd$oaqg_j*V|%s7>4eB>w0O zjrWilF5dGL<#gs5A-m^>tQXZ`A8py*}PML*2AMl;bz;X^MPc??mLl{)x!` zB~6ii*q_=n5!u@ti0r}d+O18IojWEXJ8*8I*BaTrbt1AA^&3W-BBQ;o$oh2?k##t? z7W->PCL*hGZUn!fzNX0Fz(iyK=lc65B7LY^ve+Ie_11g2Pk$;Kv1HBbv{}tM@+t9C zoGoizXUYoe^jY0HnkDOuS;IO$%RzoUPsuZGs-@4<2bMo?Agh2Kzp?A+D*RZWJ zvT;Ut_Y7IL@tV=6D7|mPhd=sJ(i>Vn6IwGmb3C+R`OFdQkkC_Z(z_v-BRTbR09z=e zIohZ}F@K8fv1=~ZcnLQ{wA}T?%6^2*{T{#nm!5%!g>vqixr-b$YiOkZk)LTYO(yXh zCWrBwNtD;4goQHyIRq{0FtoTy9AA&}{hvdqI1FvBasJA)hsb?6^EsSZi#tCD-IskP z$usy4lVNB95XPjFbiy{7AX|84?vc4$p-`RX_CsI)Bd%RXvU6|Gt>^BVi;{bx&)>y; zmMo(@zBkjo+#&8c?g`pKucLoKHj+);3C_V4$^N+?a4&E6#zdM|yKdx5`$|1$p*jaly-6r>)Wc`+0}#xYIf9d|UEMyQPmyUzXl+nO!MYm+J|);J(`ZtS9K1^1SYq zyt}D~2&j^_(oAOQH zN9QZq&*u`k&fMnQbne02lezEY-p>6r-=81NPv&pVKau}Q{&xkb5G#}my@l%vcNRWV z_+`;t+*o|9_*%(P+EjYF%$2?6mhy1<;qpH;U)}slC0x0;a-#A|HCDZ;`u&z-%dwW9 zwr*^Fr6$(a)*i0?ysgqU-FB{BY5!b@x#Q-JcRGhVzq&|S^imhsRqUGXda=8qRf9{B z2k8oE@On~wijq>-(|XNUE>xbD6Csn;*QM#VE1-n`IU zrjnJ@$BTS7tvV%LJeF#0sZ}d(x|rAMHIrJsj=#@bmE|h?(FYTqEiJO#($blD?Bb6z zd8oa4nBN@i!yD)$^e(&)wwz+8dn~p+N`P_?1da!00({{4xl@YSXd4Iw11{@vo#i;G zzg&O0ghu4Xw(Prjjy1$}sU`8tyYvyQQP2)(1*5K4Ycy$>u|0Zc+27gI<@a~>ba~5H z?z6Ty=3b(I$Cc5N2)*tkiOijPMkFhOXu_9lA{kocp)Tw{V*M$hvkqM;fc2V1UQ ze|4-s8pzU?yRR{?1Ff~j$-WGDe=v*u?u78#!iVp9%Cm^-3&{g zarLqJ9}0D!ZJcdYeU<%OarGB(i|g@gt>Wjw=2&PlJRF(~^{jU7yanZOa5B`j$~E!a zu(XPPf_*0UOnwp{6mRZ<=^2~bOMk$9n6#0)5{(Gk%N?oh65sCkldU!1)_`qiF6Yzl zB(=NZJADC>)X!ePpS?r8KuZ@&7b+$3%$W<~xeG5fmpw(AZVS_DrPkU~t`ecksxAMZPCu}tZy{;)H7xcQWme#uF{ z*G!$w&Ssv2XQp27=qQ!O#>Pb8%vhcM{W|uCCUWuKy%it#-TBD$P!HRcl>cwQAP` zlEvz9SS?Z)cl~U9Xw|AA_RA&`*=#IEZ&53ThljH9II95kU2`YtPq;?tog9Djz7YvmwShLLCK*Mo2A*#SX@o z)VsET+fVq(!6h|zMFIEAwQ_B^#@8lFA{Fc9Rpl*ZzI;&VwS)>C_*Ux&TzvI_R#ZWJ zp?*PyAvTO-kG%<9;ISuk5Ek2@!6z~xN| zF9f?n?m#^2DNZ^>Ip&jm;hvy391a$HV&&1WJdnwBWh6(e7AtR(y%m2;zqNfl73+^p zCwgTuE5|Ahdb7Leb%28hV~|%AUd0L8O&@^#=srRAthP`Ja34|3{?Gui(DRmmuyCy6 z8LNAMjl-9WmH~@Z50_m1WhO&%WBYPj_Ptk#(C$l;gFeuUF7){QJw2WNUiQAtbG`IY z?rA2k6tju9ktscx?Jcii1EzV8o*o@*ak ze*T_gKU+T3{#8709iI1zh3Da6HWP0Z9K7ZjlXFx&T>&F%E+<=3j1RHFNcT{h+J^_; zaVs8p!yl%tIp%EjVgK0@{2oPXlY7MtF=*{Syhf`TQU zh?&C4uqhl42^vV|13IHgBZMPib0`ru#}aXiDH!zPdWYU-HGRt*i-iSmuV3(bB?G6^ z2zvyLC`kshoQRoa88^sgog|4GValM~qCi1@f}yt4fXjn3?LYFgxUrM(>Q@5<}h^Y@Xj(GSr!a5V8b%4>M~XoE6d zZ7w^buIN7MnEef{A+mvMA0>~{wR8<6&z6(KHh2CRU=dW7^GZZ?4(zZ|LAKh+kRano zC*z!s?Oms%6xXn8S*h6AwUpY)Ee6qYh-bY3*<5_BxeVsc_&eJq8E0p#h%q5IU0aJg zWS`CElO6HeAM-`CC+c=Z-R5FrY)f;4^kwb|^r4`*U^DR?Pi~@|1ce2Iz>Aa-CoPHJ zC*QbBn-kggu*jr4B*_<#Q17iL_;KbHk3+V;0oiIoEFn(TDJ{PZ&xN@+!t_*_-XDG> z%!MbsUL7%;CrHvUp-Vg!rN^T*3UxIQaM^YkwXPk!g^db0ZwZ4vrt*Uy{-VUl=mO*& zMqcgNysE6fLUN_ARH5J4bM3WzrgmPtXKyRmY^_plEl0fmaMNKVx!+KJCp^{FYeQMTObjJWX~i?noBnAtlnCxwa+MUz6#ba#wqc7ZjhcP6}aN zWo>^?dy7An4aTm{X54wOXSAycWB5&sVVN8`NeZB2NaH-CXOv7;VWp~qqhy*hJ2o-; z&SEDdTY$h#p6#i;Xx>ipG+zm8n^~Wlnru59j;K~=+zHlSzfh@TL{)ZpfpzjUbe4;+ ziEm!0E-1RdV-GO+lJ=O&QH*5|P?|~0g%ttyfoerHal}*x8hb zFZJaE8`@h|RJ_@Exi#3i@hZJw*6tMCwM=t*(%=YtVrh?kqa*1rDamA?Lt0tO4YY;; z3fMCN;KPrA4?0A%%8JKiG;DQQby}NS)ERal;APTV%zB0nK+lez?JK&J;%V7#on zzUl-zFvb*Z1#ZxgBbAIDT9ZqK`wKJ(P?F=o@IgAFV5f>o#$C$y;hOuSpQ5bwn9qhEKL$OAK z=)uiA0BaBZpUw<46@wJ_yTVRmHc?w%c6rK!)m=BVZacPCpBYk0CTHTe2EEZCgj%yc zDV(sEs*`eUAd?vEN#B0Y#$%hy*HUY=C2e4lJxZD})-PkMt)%G$*=jXz*Q(OZf`;pD z#vR%n1`T{>jPhA~&#H#A2ZI`Ijk?gJqkN*;6`1`KeJG%GSNb{;=D{GSRq=COl>yG*lWFf`ziIdIIDog%SvVplQ?C@j$&i`G0IosPK_9z(6P&K zKP#1#U>VSLv?8KU32coCcWPo7N^^UKck=OgQ+{Va+qBcv7({zVi7`W19j`+%M#1#L z3l7z29czdrRamRSi3upG>ck7Ec%{DV=9!szNk3-h;k=4WU&t2lp6cqZ(u%flzLb|; z#i8~M*KW5(TN1%=N4n6uRc3-Y-KUrQ<1${B~@N6hx=0D-j>+t>=7yK z^;^B|{!BJcA4nu(d9SB2zgJoR+<1uj1vs zxdk*f1C6!w;z~thV6gbZF~Hy#CD4DR*2a{3&|l07Gr-N**}OnjyPn1cI;wSMfyqW! z-0zM!jrl}vsOVY1w+uTFvmS{xsDY3=9adboUK6?EZ`jqYT*rJ@$T3q@F|-8%K3oBd>?Xso~d=&yxDZGmOAbiRUV(Dh(Bm zN!$#5Y<83SyKiz61UN`2ZCg>1V3iv*oF3|uPNRKq>tH@I3)0J;`I;T=OKQ^v z+NP!7ojnq#zS*C}>5*@KhPCfewS7w=f1if@4MPGqD}EBL7(A88K3h5h$EvM4oc}-! z2GdRlkEXs@zjzuZ4mhWH?qwMMV4qAgQqk_cQqrn%d9K8OF!wo{jd?OzS?-F*;+u;d zgIT*Lo{4+nRap#styXVX6vH0tV>%%-5R|e|o*a(NZg05Q?hTh=*QeZ{Oyvc4SdzkS z0cFGgcME-!y9E~gQo8XZ=>b21*4obai4z7wlvz^Ic4mk(Q3mt={DL+C)ts#8l);cX z6|f*xW(2VFh)g4jgRBU%O^9uRGB$q3s_czY5pbPbVGaOz7tcRycc?om$760r#`&0c z@mUck;8HxV>}Pvg_8tw}@NC1e4VAGWY%|tXc)ooL$%sXospSeEX)sY=+leJ>1HQ4`w4gI^XN(uaW;5?Vu@UgwSKXy&p zS6konurnjO_-}EXJpk*GBSy&9UqQB-h@14CBm%}D&BjYBvn`N6J&C{ za(WDGP&==DK^JSdZB>ERKsQP=A3By@zOy^pnhEG-&*E&TEf=_IO}Xxj_%~ej`M+9m z^O~H=Dr&abT(0KT-Pi4No3@Gph8GO}e+&4F$StcWf}!7LrwFO^G4fXI4CH=l@W(6z zA&wt#Hz196F$f9y|#_fuN4Hro-mnZqqj2FXA(xuI+8(Rv~~ zD0lDZPd8DyeMK=d)ETGTYgZo}it7#BCZjH~LQQ0%a7n&IUs3UPL<#6QSttvfU@>a? zWLl;iHR}cp3LL?36RTW?m5LRd&0sKU1}JA7VEEgxWvhGh?UW;qus_lB;fu zsH;vt_@^KJh&sBs-IMoDKB>wV_UeIvt0fNU(s40gOU%3f-((?fIQ{CW1qk5A72fzd+)S6&CM z#7T=1l#|+icf#CPwo|K`wRhYmf)l`lTT95vkT-~A47sNp?dSKm`SVbU4J~=r%K8fdM zVbh&}P3I&<#pe+FY^ZbD;O{a>PEH(fa7MGrPykuh5vG8dT-rLcF<6Q0(! zUG=r0lCN7XFZv!`{>j2{S6udN6T{V|w8Y+5KtFzge)!?f@Y(uA(&rDlv_hXDVB-Xr zmN#;`c^2#GU?949s*0gx&IWCfPXkC*JJh-=7%Y5~bhD|c(&jsK$X(7Q%pb9)D;<%D z(owW_C5Bh_dS~C^cF)cR`}%r=!M>rDiSWwN&3Uw88QQ>TNK5i3iIzE#Z3BpJ_ObAr zV!{EeP7c(fQVKjOxeMZHxJR{7ygW)@nLRX3jlj~2@8Ve=JnJl;6{LHg3(C+a-0UG{ zW;eMJdP508e_pu;I}TMLs5_{}LG21E>UL^jJ~fLBqA|->r~qcBg_vbnT4r_yjBG0z zGBG=BsBWTyf*0szrcUS^&NwI>@MxZgYl!I!&{a70EGpY@30Y7;;2XxXL>HBqDc5Ke zYgv6hu8CK&xTeyKI-7&)*mJaOQ_|M8oQCZQf=P5q9;ZXpYCZNo5xP~--REI8qsVF2>ZIF26GyS!eL*$9Hu{+eV6KH!$XgK<`c}-gz+q5JWpdhZDbAN zJ8TSO3uVq@MFQ;V8bsvHbu(w~v)c81pK6ziu*Y>GZ`N3#AZQj8ghq^}LE%hZ5oUI3 z5ouvKj5Y(8==SXPj=kH1?X3lIZ`ZC@cFj(3yYssy#}o9{ix08(Fn`aNAdk91pAnK* zd_VKjGj1yMNBqsZ?*e?`OE(_axr`-I+=k|SxC zo|SUSr9XVrwKwcPaNP|zzFSz;8H+7iSy(8KfA+J-@l)GUoBIZRo2$Yf;X@SG@+3!F5dbK*-32HPMM8ng?bD3!#^9FGY}C-Z3Qauj^2hxb5Cy1=8M zH=e)gjt||OKjbJB^AS_pR9V!uh^ubhvv>O&+;)wQ=dP#Rw@MwgLIXC}0XD~ogFu;8 zyj~It^_z7WXFo}s2QA(~qiBo`BGip0R4<%uK<9@QxNezAwg3(m0D~Yv4D9_73oxK; zTxVK0=>Nb6O(W|MzaMIJ8H3KfkJ^1v%c!`#UwY)8!pcQgg0C@#3~s*w+Yix6YELDi=G#5papjOBm(NUhHR~lI zP;cj|-pY!W+Nj50U%E8XwYTFPZW|H>xbHLeoiCQPbAnTtG zw9kC2dJ<7=l;UI^;Egi*GCa(PyVW%atcDzRT$vKJ+x?>8p^Z zK47HT(KjwlNt_fgG&qGBz|i@fdd|{NYwJ~23BU-V>#8pXTw#H3*{+rQr>>E*G;MIk z{Qj6^I3!h8_eOh0YxErEAP#f)u0@*0BpbtMsAKc_aiq$DILsJBU z9&l15r65uRCYBJXj!BrDjxyQ7j8T;Tq?B2tXBkgTOiJj8$qim_vq$Wl-K+K3Oc7Jb z#G6F7!OrPKP7C(}g9$Q5938M3Ph$iZaza%8t$NuIJxnuZH!rfk?5&kk#yfQ0P*fD< zpx1D_IbNuRy855|!Y3=`BX=HcX}RO>Bjv7#9{c?86|yx$Z&ch#Rhq?_y&ji=cdF$M zqg-`Is(BFL)vD{!i2iyM^oofmX6++3@U8h|9UL(@us$O~a9)iR3P*6Kk!=i&-$SoD zuLyVpuP{NYDh13BO4&(-4b>NB*rV|fR^nm^X|-ixcE~PvGfB-<0rq}o@+$(%>v6DZ zHHQe*;F?F6FBR6DTB^D_yIIRRi8q~6Y8Ko?>{?M{^2R+GO-PbVp}If?p^ps+XUdkt zG~5?zifg5eMhtOYgV>O{7#7t5iqrt+{u@KM3ZmB2(Qtt>NqYHnS8v4w`pX^s2=Hp;M<3nAyPT$-j4-NJ>FxDpEEz=7=B*L8{$n0m2fv40?`mou`BS zydn%8)=eggS(nfkzUpbK^5`y|aJGd*ovsfH=~9dLGaufzbNb;xOCct7wM_SP-P#fy z8r_tqiPNWN&t*4n9Afir7U)evlp*S{Bc0XSr_~)XKL8!U>~h;VivbxVyw+^cF`8lQ z8;Whc5j%dZ(ug;`%GmcjjUY0EmQ}-a))Wc_Ot(2x*>Z5YZB6Q^r=3dP{*}XW%lPI^ zm0$mQ{L7OAAHPy(u>*EirmaC=Ij?%vk*}j-B>0ZrskPc!V%oDtaX?f(2u5&eql3V} zWf$3Sk)7B%+knXF2K1`(d!ha+E#=@1%AL-^Q6#>WgDVKA0hEB%#sWx8?f+VCpr_4; z7~d{;rRS>rZ|EKLhrI``8!t}|WXE^kI>_|?eTe7YiFmFad@-;^M->Fyw@|7erf%f- z5QBEV&VdA2I8Yb#nAgU}@CU#&Y!`&BUB{2l{)&5I{Nnhy%Ili(%)e1%#975fdBWes zQHi7Qd}=t(0cR|8$Fd;tX*E8ayX!FQO=p$Hn{TDw+qftGbR3UC+it*fJ~ZDpzlPtV zpiTkkjC2^SMAP&lnudULqiM*2Q>7IKO&e`kSM)=(zdU}Nx=)OA$H&!Y!my#gqBHOl zHz|@9L3lkJu{?}ny#Wo}&n&fzuT~fuTqet;KCMrqeZSg!>#b8Kuf3)A!yndYtHmaoSA^zk(L`usM6*UJ=gn(W=S;#Z4uncu^n3N3 ze*JK4JjTUhHU_BmUVVlcEt&N;6CjjB>KB49NK8^i+e@%-nOGldV-|SB;fJ_`s;j)m z9B=px)gbC0rIghivpN$2u^i}JQIrDL^%kyb2_nLfDkt-`_+rWKSv$#byJ4l7-3~cO zkNGS8`PrZAL^08o&9=v^1~FC^3=;-3>s!yqw7KS^;Tv*!DQ&ezOy%~&;m)CS|8Ax*K64*sHOn4s&ivN zjIp*x%Eh0%$(T1JFZb@~&-TRwQgbT5C?Q@o8mjvp{=v$?&fdtom5qHVvvnI{A&Hi7 z@1OxG1LhQK6@zOKaD7sRYk-U^PUK9y6rhTqp7K-0M^Awx0JJP>s7f}O!I}YF=Nk!x z$QoxbK>b9&&L^yQoA~vj3RvdpV`e{^&U9KeMR05%`y%~{d2#Fvhjf&Aa^^EGJgsei zS!%KQt=5E;&rnxvTWQa}En~j208IVJ zcGz?hX~L(JHlLpi1=cttraB~RI%!@r1>mR5OlGe#ZvjJJXJct0T1atfTkqDFWhyt| zJywS=U3KfgXl=OE0Q!bL+WtaI_mN)jo2d|>o>kJPNydQ zor6V(Rh%$5bW$qp#e7!aOcXKa6NovRkmtJWByj@nX{KfcM|30OW@>H%6~?B(T{8Uo zNW>NfAD-o1zNBS}w4Da%=q0^;kntb-MGhL-eq#y{Bg-C2nTi^ z*zZ%}TnC&_0?sbdtJtk0ifP<51+~~CjSzkW$xsL@foV{;OJ~v9*Xv9i#mrb8lS2S& zox(>9Yv=WOE8SyXU=A)ocbg(<|LdQ7I}QBo z#{tL0+{4I+z8Y|hkfD=A2mQSW&yUA7GUcUpFC|{;jfzn@Iv(Z8T3I))o6_;RNN~MP z?*cy?MTS8g2?H!z$Cx#;y2n(v9t(tDA}wbFQ@bgK-rfK*4Hjj&P>|)~mr_fD<;7|7 zj*F3my&UFr$g54Hve}CdI;=s2jGvsG{c$#9fJVf4Mf2P$`T+OWsvl#8Vl#Nb2ppnq zgb*2L8Qh}KKS)$sOZ=i=_ACBj|CC?n7uPvGqak7hV`B&av+*2Kx>yNnYnJt1nrh>nHDG9Y|)g zm&W;L7-v5jQQTUh6Lqpq0Ti{mU^z(LCNjd(9h3kD+ZV8lVp*ILdC?CdgW<$$JvuFj zXI; zrAo==skOJby-NlLg1&lpo8ugCLZ$gn0S86_)0z?;CsTy0qt;~^F%AnXwVM~3^d?2L&HhHs^x$HYep=3Nk2Nj8&Fgb=MZxZLUXL|K0Ul*PP4XS}jQt zz2e3xeO(FlQbK%a^^pjTWPIymCP^Y8olcjutOs`2FQ^t~ zNtI{}QDG~O1D8%^~3HJTbusg0L3L*P!dum5?x@H`xqE z$-rwSoGzW+Fp(Y#`I~HzDnIv@2g|cRrE)Ol&}lS|VsP{Ba*E?-@1rjv)_?@w23`;W zdeSce^TG+!h{5F;QIS^!9uUc?6Lc&#v7ToQA5$e6lfn=L&V~|j1)az1(XAcrgE`Q7 z(HgKFqHh?*OH_{c-mlV42rDqWP5)7)o0Q`6uOUo?f=<>5atJDyM;+OQz-L5(S2YM? zA+aOOX;sQ?K!m<6caBslBa7tdqSfVQl(R1uD&=PO`&0X--bA8zQ+sWbl1M0<+Iv>6 z>`{h>)OOV8V|HfDBdftao!6DZ5_Bci4QvAhJRyF)-{iIm3u+Q$)R%N5s*XwgO7)20 zzB)j3v{JRoCUZv0XAeUqDwZmTV%y6%9H4zYt2MK;5aIo-S(uu+Td*EQlfX41XwwP! zqs)lawJH%Gnlg^5WSl2X)=WXx#r*4Z{Q8jI%NnGrMf0f?jD4uGV_tIDW2)k&O6oAj zBwd5?eJYoCC9TGYy;?mS?pRmzRLeQ>kf-WlIved{N*m=gt2=8Om4rqoXf8hVwAma} zHh~H^08hTF;z{%wr(r}*M>GLMCP};AYBDm3paMtrCKW-3&>I`DKm+J==4ebd`78eE z=ABE0WHx7~6C9#xI^FDN=<^OYc61B|hzmiF`7-pFW+nwn;7H7K;o{fGDVkyo$_TES zss`6s*xUr@zT!Z!5;ge9`kdZ34-}RHz{ZIwT{$)5jd|g&oE>w?3wPzzn0Y_kJB6|> z5O)UJi(yamP-}5j$Y~!al%h6Y)EVe3h22Px>b~0VjIY{lmaGo5S!Zy|$aMA zX}n&uS+rVF8LOm%Eh%?U*k$!L`j&uC;BEK>LS*tJCTE;dn4KZIWLMdB#Pxtn>(VoR zqh|!MS5GZ01{oQTP@@jAc$gdKrZ}Dp+hCv&<2sfEqXSE>o_!e!i4AVT6r3^fH5Q1> zogM=>aWWOBO^txgd*N8BzZx^V|N83>z5KG^@Qe0PAY`}4RwZ-2MK4t*Z<3BpzTlS~ z$ORG%*I^oDX0Wr-{zb@rI)U6L2dOB6eI(+b4oMhMO>Z_3)JTm^hhP-IFB(<_Q)^VM zol)`pixIYC^xI~y(i5?*9i4-~z(^q&oK6@Va_4ZF>i(d>m}aV~mDuP{>EGjh!%U++ z&nB_KeR7I9nJ`h}JX6IHu{f_zM}uZ~UU8Y=U$Q!k1kkZbywe7m(a=_qy@cE#mM_OF zn;g>6FFW$6{>8#r_I9H$7_wO8NXU3NJ6W)8`0ahEtJklN#a6GsI(6S~H#A^iLYsbp zHf5-Cl4RyyKY=!kXK0!=3(Z6MI%`%`#Z^>nY5w7hq>q{~5ZZ zdM%j0%wh>C??1~Dg_%@WcUX9p zol(QAJwUt+!ZL{niTHh5yJQk18S+ZfO4snst(s{JX#YzNxv^Xlx`OJ9V?I^75c^Vf z396^PCa2wQ6tM1!Wz6hySasKGjAo0|X3=lZS!{NY9Wr9BHKo0_NK11o=5JP7(bTP@x!0+7PB$)kw6WZTE4@!bgtz7>)Yw- zkNqUHxVOt&9hNggrC@ixC-@HVSVGR@+sJv0u^4egqS}zedt)OcVTpT3JRZSn7i@&R z`Rr-D8o^oEi$GNNNA(;1y^~-*(1RIiE9GXiG+_c8?TsB=VO0XyS;`;}6*c zx8yW%9lf_5JkXZuOgaR^PNTjY9sRp|l55wF#N#7t)}|Q0T>_Xq3z*o+`sWB{M{~@< z_MGZpV^;2$z~T)Kt(65qFar!x5JE(vkYQ+NSfU9HUndF%oo<~TNCAUDb+C<kztUq9j#k6ICU_9zM0lM_gIi*hGl5-{mq!_sb6SwBbc$N@Am@r!ill za^@oIDZDgAOfH-6VVJwrZPrCAce&rRqgM9Hn|2nulcGP;))w(&f@fhT=CGCjINxO{ z)sdXww&UaCSkh}By zUVp8u<~%+=_jSzoZY6BKcU*Bu`>dwDgw6N1*fB}xHZ$`YZo%9JG(t@XWBwr)M~B{g zWD^MBO|YE7(U5Zz#m%gbjCD-Wxb9^o&ocYpRHU3Bk3qztS}IS?TIh42J6r0(a{jLbeO(e#nJ?0qtjV8#X9Xz)1Z`!tb$L8&MWpBA`Zg zg6IwO?TV@`}pm$1v?eyf~I)@I5njhIvuWoj%Q+uJD!s z$1ou}is=u3?oM(2@}Y+~xQc%<`+z8LD^`SBmY3r7aMYFXyAnPt^-qeaR6?8_n66B= z^lq%Vt=4U3gTbGb8Le@cMCPYIp+AJa)I@&tToPLP3Wzgxnik4$Jp&=8iZ_7%x6^e72D&OeS}KgW!ubEnm)2CWKWXr@nT+no*fog7)^%2Q#Fz|Lx zL@sF~9gOJ)j*jX%hA2QGMwLvKVqRvc@c}`wKeoOD(-T-SR4%E`ErhxXG=g5h6oQ)S zRA7^Ps`S)d(|6x}_YP-MDk>axRTImSx0%B6v~%-acjb5OTHCWWHZ(X8R_++MZ#vvR zG!$Fg1N^zntMw#-bsLPFb`Js#2EA6~9fSoNUREc>o<38#SUCfN#MCmDkj1$5^z;{I zALhqrAI5W<=kBH7;C7J~(npRymu5)7)K5jgPPgKe$WSZ8lODEb=r8uSc8evYu5ii( z)Wl2>EC0CLCy23p)E^Ot=%S5cWX)`6Yb7sF(mKwA+3XXgH8id3`&q6V=BK8 zUqivBnyY3v5D3atTNvDxWtTLP3NFp5Z1^$N2^}mO1+D{Z89Kr7r6wFSCQGcA5{ZmA z8c!DD-Nk^Ma(X5IoVy=KQFME3}(zl!i2SmRkW&3?fjjxJQM*#AVZsVNx9X1~Bn z{7xif%(lDY$9M-1Nui@>>2JV0n#odf&q>nPuospvJ^@s(vjJRY24#0LvR~CfTUaTQ zkR4x7+imsCmdtG#KC{eon}YPg#kYm~r6U&q5q_10mU)U?7rv`o$(FTX;Wak52Ow+2Ntn%$tkkNi7o0(e#n?g%{%@9+@4h0&Ms-%d zLFW+y8QGERjN7D@E&U_jrdrq$#1w8{#bL28d5G)hIIGt!Qm-RXk-wueS9-#5muon| z8`SAm!kk7rI?2*+((gdIH6ga<#Tt-U08+2p0u(rCTD=7ej2zU0Ei!s%(KM}DFc<`# z1p!)(84qAuJVu-GIaCE_QKfTej9m#;v3(F>_muPpH8aVFE8G_xqghU z>Kz+X?xx?#JpOq0jqj;jhRbY@&IWpl{uSDUSgH0P$Lk2UUjyCiB2y~Pf_*08Bu3!+ z)U~r`=*KqxkfrY6zRUBb$@}I>YcA1;W1d3(Nu>~G&Gs#!DseH-4@9-C{2@D7IHc%qTH0+0o&F&z%!b&QF270_^QO_KN8WEbai2_EG#mXlNb<)uYs}fvmNEM+9TrJQI0Amzt}|)B`EQZqYb$=E(dM&A7ccp} zNwH$}NSLEG_-~UVz_XjYhIOt|;Bxj8$PM6cq#uK_hQ7ZFyh7A`HV60krq0NNdXN zPPImQR}L$lNW|ljWqQ<+V9O;X90R?|;3Q|P5P8?gLg%b?tP1Lm7%8~^+t%mt~MBbpLcckDVnL-*qr`H@qdO{uboyxvKVvur)yCityPb#q2k_e0m`Xp^ z(V?a-UYzrRK2T=-^ET$Myp+=)w2G=v7 zL$yRDN>wpdj{$x47>{Dd$|^XLhD0?lOk}=CQD&)MqGE(bZDacK7cqNM!Bb2}>ptr9 zMX+KPe>9S}r*oOaVWK^Z?BJjwNcg-YS`JI|u$kBO*vdJ~W;iWkd4bm|;wi9tMt>^d zF(DkpYQNe`CT%Dy>Fz>?Z_g$Y~9kr{&F6vFzeBhq(4RlE?=I#Q68m zb_xzb=T7<8a#-t^BCxy%_S~I_oAfA6vbk(NWq#d!-mEpRw#bgMvFh}v=uSEcnd4OiUKIRpoylr|`u!IC zUE-M^1MZZms%(@Sj;_|05`{@wwNjdo`d!hyyAZeNVq#N5(%QAdT7edYw8Im27)*6e z?{k`U_JqL%D}~%n2I%ML7l@TCQleG`6B#WEn~P|%nh$aZ^~7c+H&Wh2Ig3R!VM;%M z!)A{*CiS1bc=2UuAHYW#BA{hpp}N|{u?a^q5J>g=SF9cY3fN35Z7J96g%R+&LDEkj zr%$T!tO;gGsS1(mv<3O7PFs{};s{FSD`yImVZKz^od*?L(Db8{|EPjoNLhOz$wNS$5)E z$U{q}nYF4_w{(%J(ab)jYBbr*=O1r+{dIK{HyJrlby`0^vmH^kF$7e=!u6Lg7$M zAG}|~((<@iB>Di9()*p3s7H!gB#VT60!_q><$N@bdqs^mh}39aue;AoKB~P>b$`5E z5nmR8rJy3{b!y%}wv3wK!-1RjEtaY-zIj(86|Z64H&|M7LF7QWXj5?+@&_md1r|$I z&^V>vO(ce=Jq3C8kyyoBUnd2fbW-#Q)uprF#Bxzzd8nRF7ji>TMr;w!yB{~1wX@&y zG)bKH;$LuVX-`O32FG6kjvY@CisorADdq|f z#A*EgM7R)6X81xZugRI4H1T_58oTu`U7rly&Z#S+s8My+TQ%R7b@WAbxr^8Dx?))x zbP{QdsTPR3I(l~n({3#6b48Dnth2v*gKG-8?Pk9%Y;JOP%IR*moUqOwz0~#pqV~G3 zGi&21r`2S&xJ65=2eYRGF|SjgzgYmnLACo>Cj#>te~WpI8PbZiM|;SF%DS8kM93&u zEzZR@T|M1BUtH8BVaA0Lkf(Lluud}SbVi9+y6YKN-EhQ|Ji?ohCmS~L-g=Lw+uUVd zq^Wi0%O!Jb(?^SD`w?$r?SV@DtqQO}#epk?8x`L?Exx!w3RUnB5kOM2G8qy$!wp4p zL9VGWSyiy9#<>b8W}IuUL>1=xQ}H8gO2f6ZNOJqJl9C-04Xo|qma@g3b;b&TU{$1F zpT{3BLz?v}_~{gioy=lMG{`a49BXPK~E3@tI}Zl}-dZ=auVd6_X`#-lxr zUxhwUnSJvx_nV833U}<{P3p6+%?+sZb@#vege-~A$Lf37USygKrT{p*G-|6+jRHC zn!0~n&lGN?o=5a0q_k|&YxNGF?2SBP)!H~Cl6)JpBd{o<3X`{>cwZRX2jGmooO>O6 zs(4y}3gTtZbtqf21?bM)RP>NN91M%=ms{|k6Re}NFL6ej%hCWr%jV77YO^$3iyo&Dp z;SbeoA0uC(!?Xj|hvNiK1WXTkuyHZ-D>?1M$tkJK6zhe{grw3zat^w3x^f7JQ}@b$HzXlOYWLvI-Mlb zyB4M?Gr1Ybi-T`D({yM(4m|l6Y$qS% z&mlxOhAX@l<;nNp;#+;PsFn$}+7k}jiBhgOjWObl^e705mu%`J?ok7?s@S|i(C9_$ z)2?E8FwNpIn#9Utj~QJ`i=oKOw|H8HKOwj!z%G?pL~CIou$W9`WhQ*6z9`s1_B8(r z2VNj(vthiwtnyVGkJ-2z6Tf!7-^BdysXtZ=w3xliwa_3(<%gdc~q*6C;{+v)0Wyj-#;Q48ws7Lu8 z&;&~!`Z#`dk>02;&SWfQ`)(Qxg>+kbrD;8~;BB)>e}6XRnwrNqNaggiqx?mF3?(M( zV6)e%^k2gGvx+M$extp@UwYQy*PIpD>-1VPE}7H;lB^ndvE{RCj!B!!!dDM;9ercA zXrImo__2$PXP%Lji^{kF9i3i>(f^9&vSr4iuqge7c5F@Y39JzIQh&u+jo)yVE9MBg zK0dErXcl2MPagH`k2|cyZL0$$rMb<0XBscQb2mxgh@YJRZxT`+sA7I;g!)5_FYJ=p z$64*zXsy=!Uol-aeQcUB0b19uuC`THRQ+&Xb?Ci%l`4cZ8FZb{K``aN2#L!&X%hHv z@1imF_f1>3HJ|!X7M1%~d%dgUR9^+`+VBj25_JO>Ue+Ud782$Y&4_!g@S(4^iz~5{ zm%xfdmDN^bfZeI)B3|hYcy8RFnseh_g0z-Q}MrjjV#)YE;E>EaPPpXWTYLmfQ zZq*x21+7Y>m98x124iW#dpB?1)Y~maj55lKU<@zQBV;Ptu@Urf>=5=cpW=hyD*8fX zZ$q<&y^XSz>}^wT+J5pMJw4Lepd*O;7~%p#_H~8@@?20M_AlR^v(J%*?y6k%*l9ql(vyTxOwx#~6P@M%d#Y~dj=Gn3dpbHicus+C@wZ{W zA;2wFwSNT3jlkMTo-QUoOwM|HrS-Jgf2H_Zu~7Vm)_+BD4YQVSuwI~^;9qL; zpI$$FmGG-kBw0(4w+hluynVJc+?=h0UmI)Q`HxvI_gjJXfxBoM@~+bRSDN@rQ?F^n zL^V%k8iB~HWPVzFXs@uHF7{tBU&E^PHx&LW*x5qRX46O{5|Z>{m5}@nF5gAsuJPur z*(5d$v;%Z;KL4uNey`u;|5(p2={c=1dP1+z*NoVA*##hIqe)@af#6jKuyS(7>ah)~3OWH?#o4-5+eFc@#^0c^Y{PnH zl8mq-N|w4$uV1BQJU=7)$O$Q9Yh5FB08|r>9cc`)@>yeNdeIb|Ak)gcMpxawqN=uR zd2dr?L#?A!=NhfkmX;J^UB6@PU`^NNR&sRbYf5ajrFK`TroFMT?YPCW##3hXG}>3! zT7>P8lLf{iy~Xad)a~2YvAsvE?jG}2Hr7^SIax!4X}!-!?M0Ab1L)Wh?*q^4_;DQ{ z(Q%_r)CnK!exnm4Q}+`(zFWsv(h4$$=^A%|x8Op7;#$Ec1wwJbE0`70b78YOpxTW& z9KDKfWxB0}7%wV;-UCxOw&J*P`wH6M_|@B_H^$LMq|ae|pvln($KN`^VU~ag_)qz% z$<+7w_Q^pY_|kYIjn6@A+7jOWKQHI5!QG|DONG+<0;Qs+(pt{e7i!cOu+x$i_hD$WzWns2(9G8$28Kat8K=2 z2|fxh5NkYX$|&uUf~CQja7NDy2p?@`1!gER_#W4QG~3@_(zs%IN#w}UsPnDo01#T= z=5|*+_+V(`o)lqxj0N{>+YsWfaN$z(isep8UhRgQdlqu8gh5^zRM@45Jr_d@h zau(Bq897UxCcbIIwpKoL#qt(YVt>XkY=`F|_bfmg!J^z{cjLXOV7i=x>sD(xIgy(s z2POC>wJin*mwLe>8cgN2_Nsbc8^6D>%vPdy6?xVvb{Wr|dyTi8K9jok1O8j5x4Xyb z?CJIvnw+MBYEz}?bT$N>sV2CaUt}16<$b(iuo}@cH=_#Y~()?)sRhzHA z%3fP;GKiLsmZa3}gmK0xR+_2{Kyykxk5X0YLm8c9i-Ozy0$imbl;#U^_M^z!Cw@fS zH9PH9Vy|0pE=luWztnW;crFgBuuJD$U08zdEH39;BmM<+x43)6D!bEc(mO2txxDE9 zo;aF=-`HC;AG%4WeZiXi^y6zIso$F&29pK+c6e9v8%xst@TI1gUdzdE?1-8#-PyG| zPkulB#M;OU?p_DjZ7~@jU618O_D8wc4PdbyGwUETUYBGB?OF@9sk&Qgz$c9q9U)QB zXtaEOUB?f37UDWLlvU{UK*!_*+*;piv$fWj3;&?AYB7yaX?AL`UYL)|3RZFc{Oi2= zD`!&g{eXYw>Rs34aP+L}O_;1kjmBs-Eo*lfjjr}(PiW0Ljn!bPsv`Yv&pOz z)(R>JoD#?z6?UurLgkzV__;R;^os?HxzFY*(>TqQmHHB`RrlGwm-4%%4qJsDF3ISl zYjkF9sz6>!1@_|&V?LSWzm1W@Gbv*H5n$g^jU|oemnxD=`4?mq3Xk4?jvG_|CG5X- z>$|yH0{V|LlR4;ELfB;JI4=|7ylxRXex6HmL&u~p+@XVDNol8T8AtLF*%@kvvn6zV z5sFMp$z^5g`%BW4ABTprrSHGzped)!Ri<9eMUyHIQJdk@-(-tcVRR9qYL^hG%G7t3 zqG>5HnxW~nY_a*f93M^5zU z?PqyO>NmoHTelkSQ4rp18M4G*wv^9Vg!$r*hw?2#ZYf9de9J!|J72qT_YP z-A@fiE^-W%gUjPaTMK_yF8Ad9nAE>6_ib%%!d9oXjhjDow(BZZh~f&HuC?x;wlpr| zA1p2k`33*}_0`qu_xpX1cTbKrJ{)Km^f;ZK!G^%YjboGD$EhEznAwn3mL*z$9%WfC zmz@JLt}juRR~Hwjd6h+(dOTAW1!fFfYzW26qg$Lui5|_Czo+spmGD$4DDt3pSQpH7s2)W$MQZm1`+| zkw>{4*}CL|dn;BB^|Exa(4U#f^kL0FwdiCpk}B?1=j2hymVETloB0>K@t#x^KR>j; zzow>t{}4&dZOe}Y>Nj{C4$p@Az>($KCc95izb>^TAC}Ntd9Y#Sf^5jrX%GDoY{;qR z@?ZljLR#!M`fK6IjJ;*)jBmC~rX0%lp-eEF(?2 zk07^c2&d-861VqcrK_FUhcZ0{-QI~|TUJ_myf@w`D@$&T=QNe+g*Ad2V?+}_H@x2` zioX5BRPP>aI2x$i=n+LgMg@*GJUH2XlI*K&M$K;t{|S$(Vm9XO1ag9?-K{;Oy`oiW znTCrR^0>JIz6xXUGlos@785q9G^aT{XL^BQhJTLC;q=o+U#rL=wH*0^gtY=j zjR?LUIC&D;;`BLxCjeOS)q&J%>bSrc_hnco)1OW3>zOcz|L6Z?!dS(?38|ev3M`tV zRp9i2pC5lQ6IKE4>-|g^8{F~F5tDC3tEI|y>bQlORs zPzx=+fN8M+Oow`HK%Fnf@|qH0mz3gpGpy|8sGAk=QMAG5xe9v^)qpw&FdXoGu7;0m2V|Uwb%Eb&F*~&m*0)~fWqo*6{aBScfOoWk zZDgA;$u@*~bRXXF2v((UW~1x@wgokA47->=2o#^~>>;*;jkBHT6YOR|E?`5ZQ|w9h zWA+@o2`__ln63RbdlBAi3ihY$pV^n$*Vu2_XY8x&&)6CECR*2jv+uB%*zeda_Ir*! z8@U=z%>}@IDdak?=LR@97jq*o;U->+bz5+c>=3OE8kug<=N}27@8Avt&^`{IKk@_)esj z#J*TOsSO0$#8UUSRI#2r#=u5CJzL)$yhX& zpvXGZn$|&&M|$DuaF;CHCky*z;eJ_oy(~N+3lGkPyJYEi$ze|>Wmn{7* zS^8bF^!sG#_sP=llcnD$OTSN+exEG;K3V#Gvh;nj`2Di*pcF<+YhOLv(&*w&vy;Ro zp8+JSq`~#LcH$uE$pPa_dk7!L)d}`C!b<5EdW7RBWIyGNOc8n{9${r@wFj6d5==%R z=`2j)+b}9J%Y8%ZaeiRbhchJhjFbXa=|Uz`TJ!HXnW}I505n+t=oXRr?i(2v+34uV zeK>C!9TFiKDL#B1k$YOM&s_^rnse8RJJ$-tr~KxABdq|P5S)yM*ea4RYz;{s=9A7F zrStvK>4R~$B^IBEvh9h4dlh6dafR}wZ_+7gF3_1Y5|?C%T2H~g zgg(VI;wUmYPr%!wHK@mMPXJY;I4=~BYJn9;5ptwF6;e81LWsB^LZAK#w9#4i6!g$J zcAi~ePovj&k$r=G6LAcZ&NV{Ux-xokC-@kGA0O2$^~@(ogCqCxOzKppx)D=er>dno o)o`c2P~Q_D)C74*NHC8}{Ced70j1DE?f?J) diff --git a/stdlib/doc/sphinx/_static/ansi-dark.css b/stdlib/doc/sphinx/_static/ansi-dark.css deleted file mode 100644 index f02f522bdd00..000000000000 --- a/stdlib/doc/sphinx/_static/ansi-dark.css +++ /dev/null @@ -1,144 +0,0 @@ -/************************************************************************/ -/* * The Coq Proof Assistant / The Coq Development Team */ -/* v * Copyright INRIA, CNRS and contributors */ -/* -% \def\newcssclass#1#2{\expandafter\def\csname DUrole#1\endcsname ##1{#2}} -% - -\RequirePackage{adjustbox} -\RequirePackage{xcolor} -\RequirePackage{amsmath} - -\definecolor{nbordercolor}{HTML}{AAAAAA} -\definecolor{nbgcolor}{HTML}{EAEAEA} -\definecolor{nholecolor}{HTML}{4E9A06} - -\newlength{\nscriptsize} -\setlength{\nscriptsize}{0.8em} - -\newlength{\nboxsep} -\setlength{\nboxsep}{2pt} - -\newcommand*{\scriptsmallsquarebox}[1]{% - % Force width - \makebox[\nscriptsize]{% - % Force height and center vertically - \raisebox{\dimexpr .5\nscriptsize - .5\height \relax}[\nscriptsize][0pt]{% - % Cancel depth - \raisebox{\depth}{#1}}}} -\newcommand*{\nscriptdecoratedbox}[2][]{\adjustbox{cfbox=nbordercolor 0.5pt 0pt,bgcolor=nbgcolor}{#2}} -\newcommand*{\nscriptbox}[1]{\nscriptdecoratedbox{\scriptsmallsquarebox{\textbf{#1}}}} -\newcommand*{\nscript}[2]{\text{\hspace{-.5\nscriptsize}\raisebox{-#1\nscriptsize}{\nscriptbox{\small#2}}}} -\newcommand*{\nsup}[1]{^{\nscript{0.15}{#1}}} -\newcommand*{\nsub}[1]{_{\nscript{0.35}{#1}}} -\newcommand*{\nnotation}[1]{#1} -\newcommand*{\nbox}[1]{\adjustbox{cfbox=nbordercolor 0.5pt \nboxsep,bgcolor=nbgcolor}{#1}} -\newcommand*{\nrepeat}[1]{\text{\nbox{#1\hspace{.5\nscriptsize}}}} -\newcommand*{\nwrapper}[1]{\ensuremath{\displaystyle#1}} % https://tex.stackexchange.com/questions/310877/ -\newcommand*{\nhole}[1]{\textit{\color{nholecolor}#1}} - -% -% Make it easier to define new commands matching CSS classes -\newcommand{\newcssclass}[2]{% - \expandafter\def\csname DUrole#1\endcsname##1{#2} -} -% - -% https://tex.stackexchange.com/questions/490262/ -\def\naltsep{} -\newsavebox{\nsavedalt} -\newlength{\naltvruleht} -\newlength{\naltvruledp} -\def\naltvrule{\smash{\vrule height\naltvruleht depth\naltvruledp}} -\newcommand{\nalternative}[2]{% - % First measure the contents of the box without the bar - \bgroup% - \def\naltsep{}% - \savebox{\nsavedalt}{#1}% - \setlength{\naltvruleht}{\ht\nsavedalt}% - \setlength{\naltvruledp}{\dp\nsavedalt}% - \addtolength{\naltvruleht}{#2}% - \addtolength{\naltvruledp}{#2}% - % Then redraw it with the bar - \def\naltsep{\naltvrule}% - #1\egroup} - -\newcssclass{notation-sup}{\nsup{#1}} -\newcssclass{notation-sub}{\nsub{#1}} -\newcssclass{notation}{\nnotation{\textbf{#1}}} -\newcssclass{repeat}{\nrepeat{#1}} -\newcssclass{repeat-wrapper}{\nwrapper{#1}} -\newcssclass{repeat-wrapper-with-sub}{\nwrapper{#1}} -\newcssclass{hole}{\nhole{#1}} -\newcssclass{alternative}{\nalternative{\nbox{#1}}{0pt}} -\newcssclass{alternative-block}{#1} -\newcssclass{repeated-alternative}{\nalternative{#1}{\nboxsep}} -\newcssclass{alternative-separator}{\quad\naltsep{}\quad} -\newcssclass{prodn-table}{% - \begin{savenotes} - \sphinxattablestart - \begin{tabulary}{\linewidth}[t]{lLLL} - #1 - \end{tabulary} - \par - \sphinxattableend - \end{savenotes}} -% latex puts targets 1 line below where they should be; prodn-target corrects for this -\newcssclass{prodn-target}{\raisebox{\dimexpr \nscriptsize \relax}{#1}} -\newcssclass{prodn-cell-nonterminal}{#1 &} -\newcssclass{prodn-cell-op}{#1 &} -\newcssclass{prodn-cell-production}{#1 &} -\newcssclass{prodn-cell-tag}{#1\\} diff --git a/stdlib/doc/sphinx/_static/notations.css b/stdlib/doc/sphinx/_static/notations.css deleted file mode 100644 index e262a9305d8e..000000000000 --- a/stdlib/doc/sphinx/_static/notations.css +++ /dev/null @@ -1,283 +0,0 @@ -/************************************************************************/ -/* * The Coq Proof Assistant / The Coq Development Team */ -/* v * Copyright INRIA, CNRS and contributors */ -/* .repeat-wrapper { - margin-top: 0.28em; -} - -.prodn-table .notation > .repeat-wrapper-with-sub { - margin-top: 0.28em; - margin-bottom: 0.28em; -} - -.term-defn { - font-style: italic; -} - -.std-term { - color: #2980B9; /* override if :visited */ -} - -/* We can't display nested blocks otherwise */ -code, .rst-content tt, .rst-content code { - background: transparent !important; - border: none !important; - font-size: inherit !important; -} - -code { - padding: 0 !important; /* This padding doesn't make sense without a border */ -} - -dt > .property { - margin-right: 0.25em; -} - -.icon-home:visited { - color: #FFFFFF; -} - -/* Pygments for Coq is confused by ā€˜ā€¦ā€™ */ -code span.error { - background: inherit !important; - line-height: inherit !important; - margin-bottom: 0 !important; - padding: 0 !important; -} - -/* Red is too aggressive */ -.rst-content tt.literal, .rst-content tt.literal, .rst-content code.literal { - color: inherit !important; -} - - -.coqdoc-comment { - color: #808080 !important -} - -/* make the error message index readable */ -.indextable code { - white-space: inherit; /* break long lines */ -} - -.indextable tr td + td { - padding-left: 2em; /* indent 2nd & subsequent lines */ - text-indent: -2em; -} diff --git a/stdlib/doc/sphinx/_static/notations.js b/stdlib/doc/sphinx/_static/notations.js deleted file mode 100644 index d2eee1f5fa38..000000000000 --- a/stdlib/doc/sphinx/_static/notations.js +++ /dev/null @@ -1,43 +0,0 @@ -/************************************************************************/ -/* * The Coq Proof Assistant / The Coq Development Team */ -/* v * Copyright INRIA, CNRS and contributors */ -/* sup") - .attr("data-hint", function() { - return annotateSup($(this).text()); - }).addClass("hint--top hint--rounded"); - - $(".repeat-wrapper > sub") - .attr("data-hint", function() { - return annotateSub($(this).text()); - }).addClass("hint--bottom hint--rounded"); - //.text(function(i, text) { return translatePunctuation(text); }); -} - -$(annotateNotations); diff --git a/stdlib/doc/sphinx/_static/pre-text.css b/stdlib/doc/sphinx/_static/pre-text.css deleted file mode 100644 index aa4180d246fb..000000000000 --- a/stdlib/doc/sphinx/_static/pre-text.css +++ /dev/null @@ -1,29 +0,0 @@ -/************************************************************************/ -/* * The Coq Proof Assistant / The Coq Development Team */ -/* v * Copyright INRIA, CNRS and contributors */ -/* - - Other versions - v: {{ version }} - - -
-
-
{{ _('Versions') }}
- {% for slug, url in versions %} -
{{ slug }}
- {% endfor %} -
-
-
{{ _('Downloads') }}
- {% for type, url in downloads %} -
{{ type }}
- {% endfor %} -
-
- -{% endif %} diff --git a/stdlib/doc/sphinx/biblio.bib b/stdlib/doc/sphinx/biblio.bib deleted file mode 100644 index a68c07d918a4..000000000000 --- a/stdlib/doc/sphinx/biblio.bib +++ /dev/null @@ -1,677 +0,0 @@ -@String{jfp = "Journal of Functional Programming"} -@String{lncs = "Lecture Notes in Computer Science"} -@String{lnai = "Lecture Notes in Artificial Intelligence"} -@String{SV = "{Springer-Verlag}"} - -@InCollection{Asp00, - Title = {Proof General: A Generic Tool for Proof Development}, - Author = {Aspinall, David}, - Booktitle = {Tools and Algorithms for the Construction and - Analysis of Systems, {TACAS} 2000}, - Publisher = {Springer Berlin Heidelberg}, - Year = {2000}, - Editor = {Graf, Susanne and Schwartzbach, Michael}, - Pages = {38--43}, - Series = {Lecture Notes in Computer Science}, - Volume = {1785}, - Doi = {10.1007/3-540-46419-0_3}, - ISBN = {978-3-540-67282-1}, -} - -@Book{Bar81, - author = {H.P. Barendregt}, - publisher = {North-Holland}, - title = {The Lambda Calculus its Syntax and Semantics}, - year = {1981} -} - -@InProceedings{Bou97, - title = {Using reflection to build efficient and certified decision procedure -s}, - author = {S. Boutin}, - booktitle = {TACS'97}, - editor = {Martin Abadi and Takahashi Ito}, - publisher = SV, - series = lncs, - volume = 1281, - year = {1997} -} - -@Article{Bru72, - author = {N.J. de Bruijn}, - journal = {Indag. Math.}, - title = {{Lambda-Calculus Notation with Nameless Dummies, a Tool for Automatic Formula Manipulation, with Application to the Church-Rosser Theorem}}, - volume = {34}, - year = {1972} -} - -@inproceedings{CH85, - title={Constructions: a higher order proof system for mechanizing mathematics}, - author={Coquand, Thierry and Huet, GĆ©rard}, - booktitle={European Conference on Computer Algebra}, - pages={151--184}, - year={1985}, - issn = {1611-3349}, - doi = {10.1007/3-540-15983-5_13}, - url = {http://dx.doi.org/10.1007/3-540-15983-5_13}, - isbn = 9783540396840, - publisher = {Springer Berlin Heidelberg} -} - -@techreport{CH88 - TITLE = {{The calculus of constructions}}, - AUTHOR = {Coquand, T. and Huet, G{\'e}rard}, - URL = {https://hal.inria.fr/inria-00076024}, - NUMBER = {RR-0530}, - INSTITUTION = {{INRIA}}, - YEAR = {1986}, - MONTH = May, - PDF = {https://hal.inria.fr/inria-00076024/file/RR-0530.pdf}, - HAL_ID = {inria-00076024}, - HAL_VERSION = {v1}, -} - -@techreport{CH87, - TITLE = {{Concepts mathematiques et informatiques formalises dans le calcul des constructions}}, - AUTHOR = {Coquand, T. and Huet, G{\'e}rard}, - URL = {https://hal.inria.fr/inria-00076039}, - NUMBER = {RR-0515}, - INSTITUTION = {{INRIA}}, - YEAR = {1986}, - MONTH = Apr, - PDF = {https://hal.inria.fr/inria-00076039/file/RR-0515.pdf}, - HAL_ID = {inria-00076039}, - HAL_VERSION = {v1}, -} - -@techreport{C90, - TITLE = {{Metamathematical investigations of a calculus of constructions}}, - AUTHOR = {Coquand, T.}, - URL = {https://hal.inria.fr/inria-00075471}, - NUMBER = {RR-1088}, - INSTITUTION = {{INRIA}}, - YEAR = {1989}, - MONTH = Sep, - PDF = {https://hal.inria.fr/inria-00075471/file/RR-1088.pdf}, - HAL_ID = {inria-00075471}, - HAL_VERSION = {v1}, -} - -@PhDThesis{Coq85, - author = {Th. Coquand}, - month = jan, - school = {Universit\'e Paris~7}, - title = {Une Th\'eorie des Constructions}, - year = {1985} -} - -@InProceedings{Coq86, - author = {Th. Coquand}, - address = {Cambridge, MA}, - booktitle = {Symposium on Logic in Computer Science}, - publisher = {IEEE Computer Society Press}, - title = {{An Analysis of Girard's Paradox}}, - year = {1986} -} - -@InProceedings{Coq92, - author = {Th. Coquand}, - title = {{Pattern Matching with Dependent Types}}, - year = {1992}, - booktitle = {Proceedings of the 1992 Workshop on Types for Proofs and Programs} -} - -@InProceedings{DBLP:conf/types/CornesT95, - author = {Cristina Cornes and - Delphine Terrasse}, - title = {Automating Inversion of Inductive Predicates in Coq}, - booktitle = {TYPES}, - year = {1995}, - pages = {85-104}, - crossref = {DBLP:conf/types/1995}, - bibsource = {DBLP, http://dblp.uni-trier.de} -} - -@inproceedings{CP90, - title={Inductively defined types}, - author={Coquand, Thierry and Paulin, Christine}, - booktitle={COLOG-88}, - pages={50--66}, - year={1990}, - issn = {1611-3349}, - doi = {10.1007/3-540-52335-9_47}, - url = {http://dx.doi.org/10.1007/3-540-52335-9_47}, - isbn = 9783540469636, - publisher = {Springer Berlin Heidelberg} -} - -@Book{Cur58, - author = {Haskell B. Curry and Robert Feys and William Craig}, - title = {Combinatory Logic}, - volume = 1, - publisher = "North-Holland", - year = 1958, - note = {{\S{9E}}}, -} - -@Article{CSlessadhoc, - author = {Gonthier, Georges and Ziliani, Beta and Nanevski, Aleksandar and Dreyer, Derek}, - title = {How to Make Ad Hoc Proof Automation Less Ad Hoc}, - journal = {SIGPLAN Not.}, - issue_date = {September 2011}, - volume = {46}, - number = {9}, - month = sep, - year = {2011}, - issn = {0362-1340}, - pages = {163--175}, - numpages = {13}, - url = {http://doi.acm.org/10.1145/2034574.2034798}, - doi = {10.1145/2034574.2034798}, - acmid = {2034798}, - publisher = {ACM}, - address = {New York, NY, USA}, - keywords = {canonical structures, coq, custom proof automation, hoare type theory, interactive theorem proving, tactics, type classes}, -} - -@InProceedings{CSwcu, - hal_id = {hal-00816703}, - url = {http://hal.inria.fr/hal-00816703}, - title = {{Canonical Structures for the working Coq user}}, - author = {Mahboubi, Assia and Tassi, Enrico}, - booktitle = {{ITP 2013, 4th Conference on Interactive Theorem Proving}}, - publisher = {Springer}, - pages = {19-34}, - address = {Rennes, France}, - volume = {7998}, - editor = {Sandrine Blazy and Christine Paulin and David Pichardie }, - series = {LNCS }, - doi = {10.1007/978-3-642-39634-2_5}, - year = {2013}, -} - -@InProceedings{Del00, - author = {Delahaye, D.}, - title = {A {T}actic {L}anguage for the {S}ystem {Coq}}, - booktitle = {Proceedings of Logic for Programming and Automated Reasoning - (LPAR), Reunion Island}, - publisher = SV, - series = LNCS, - volume = {1955}, - pages = {85--95}, - month = {November}, - year = {2000}, - url = {http://www.lirmm.fr/%7Edelahaye/papers/ltac%20(LPAR%2700).pdf} -} - -@Article{Dyc92, - author = {Roy Dyckhoff}, - journal = {The Journal of Symbolic Logic}, - month = sep, - number = {3}, - title = {Contraction-free sequent calculi for intuitionistic logic}, - volume = {57}, - year = {1992} -} - -@Book{Fourier, - author = {Jean-Baptiste-Joseph Fourier}, - publisher = {Gauthier-Villars}, - title = {Fourier's method to solve linear - inequations/equations systems.}, - year = {1890} -} - -@article{Gilbert:POPL2019, - author = {Gilbert, Ga\"{e}tan and Cockx, Jesper and Sozeau, Matthieu and Tabareau, Nicolas}, - title = {{Definitional Proof Irrelevance Without K}}, - journal = {Proc. ACM Program. Lang.}, - issue_date = {January 2019}, - volume = {3}, - number = {POPL}, - year = {2019}, - issn = {2475-1421}, - pages = {3:1--3:28}, - articleno = {3}, - numpages = {28}, - url = {http://doi.acm.org/10.1145/3290316}, - acmid = {3290316}, - publisher = {ACM}, - address = {New York, NY, USA}, - keywords = {proof assistants, proof irrelevance, type theory}, -} - -@InProceedings{Gim94, - author = {E. Gim\'enez}, - booktitle = {Types'94 : Types for Proofs and Programs}, - note = {Extended version in LIP research report 95-07, ENS Lyon}, - publisher = SV, - series = LNCS, - title = {Codifying guarded definitions with recursive schemes}, - volume = {996}, - year = {1994} -} - -@TechReport{Gim98, - author = {E. Gim\'enez}, - title = {A Tutorial on Recursive Types in Coq}, - institution = {INRIA}, - year = 1998, - month = mar -} - -@Unpublished{GimCas05, - author = {E. Gim\'enez and P. Cast\'eran}, - title = {A Tutorial on [Co-]Inductive Types in Coq}, - institution = {INRIA}, - year = 2005, - month = jan, - note = {available at \url{http://coq.inria.fr/doc}} -} - -@InProceedings{Gimenez95b, - author = {E. Gim\'enez}, - booktitle = {Workshop on Types for Proofs and Programs}, - series = LNCS, - number = {1158}, - pages = {135-152}, - title = {An application of co-Inductive types in Coq: - verification of the Alternating Bit Protocol}, - editorS = {S. Berardi and M. Coppo}, - publisher = SV, - year = {1995} -} - -@Book{Gir89, - author = {J.-Y. Girard and Y. Lafont and P. Taylor}, - publisher = {Cambridge University Press}, - series = {Cambridge Tracts in Theoretical Computer Science 7}, - title = {Proofs and Types}, - year = {1989} -} - -@InCollection{How80, - author = {W.A. Howard}, - booktitle = {to H.B. Curry : Essays on Combinatory Logic, Lambda Calculus and Formalism.}, - editor = {J.P. Seldin and J.R. Hindley}, - note = {Unpublished 1969 Manuscript}, - publisher = {Academic Press}, - title = {The Formulae-as-Types Notion of Constructions}, - year = {1980} -} - -@inproceedings{H88, - title={Induction principles formalized in the Calculus of Constructions}, - author={Huet, G{\'e}rard}, - booktitle={Programming of Future Generation Computers. Elsevier Science}, - year={1988}, - issn = {1611-3349}, - doi = {10.1007/3-540-17660-8_62}, - url = {http://dx.doi.org/10.1007/3-540-17660-8_62}, - isbn = 9783540477464, - publisher = {Springer Berlin Heidelberg} -} - -@InProceedings{H89, - author = {G. Huet}, - booktitle = {A perspective in Theoretical Computer Science. Commemorative Volume for Gift Siromoney}, - editor = {R. Narasimhan}, - publisher = {World Scientific Publishing}, - title = {{The Constructive Engine}}, - year = {1989} -} - -@Article{LeeWerner11, - author = {Gyesik Lee and - Benjamin Werner}, - title = {Proof-irrelevant model of {CC} with predicative induction - and judgmental equality}, - journal = {Logical Methods in Computer Science}, - volume = {7}, - number = {4}, - year = {2011}, - ee = {http://dx.doi.org/10.2168/LMCS-7(4:5)2011}, - bibsource = {DBLP, http://dblp.uni-trier.de} -} - -@TechReport{Leroy90, - author = {X. Leroy}, - title = {The {ZINC} experiment: an economical implementation of the {ML} language}, - institution = {INRIA}, - number = {117}, - year = {1990} -} - -@InProceedings{Let02, - author = {P. Letouzey}, - title = {A New Extraction for Coq}, - booktitle = {TYPES}, - year = 2002, - crossref = {DBLP:conf/types/2002}, - url = {http://www.irif.fr/~letouzey/download/extraction2002.pdf} -} - -@InProceedings{Luttik97specificationof, - author = {Sebastiaan P. Luttik and Eelco Visser}, - booktitle = {2nd International Workshop on the Theory and Practice of Algebraic Specifications (ASF+SDF'97), Electronic Workshops in Computing}, - publisher = SV, - title = {Specification of Rewriting Strategies}, - year = {1997} -} - -@inproceedings{Visser98, - author = {Eelco Visser and - Zine{-}El{-}Abidine Benaissa and - Andrew P. Tolmach}, - title = {Building Program Optimizers with Rewriting Strategies}, - booktitle = {ICFP}, - pages = {13--26}, - year = {1998}, -} - -@inproceedings{Visser01, - author = {Eelco Visser}, - title = {Stratego: {A} Language for Program Transformation Based on Rewriting - Strategies}, - booktitle = {RTA}, - pages = {357--362}, - year = {2001}, - series = {LNCS}, - volume = {2051}, -} - -@InProceedings{DBLP:conf/types/McBride00, - author = {Conor McBride}, - title = {Elimination with a Motive}, - booktitle = {TYPES}, - year = {2000}, - pages = {197-216}, - ee = {http://link.springer.de/link/service/series/0558/bibs/2277/22770197.htm}, - crossref = {DBLP:conf/types/2000}, - bibsource = {DBLP, http://dblp.uni-trier.de} -} - -@InProceedings{Moh93, - author = {C. Paulin-Mohring}, - booktitle = {Proceedings of the conference Typed Lambda Calculi and Applications}, - editor = {M. Bezem and J.-F. Groote}, - note = {Also LIP research report 92-49, ENS Lyon}, - number = {664}, - publisher = SV, - series = {LNCS}, - title = {{Inductive Definitions in the System Coq - Rules and Properties}}, - year = {1993} -} - -@MastersThesis{Mun94, - author = {C. MuƱoz}, - month = sep, - school = {DEA d'Informatique Fondamentale, Universit\'e Paris 7}, - title = {D\'emonstration automatique dans la logique propositionnelle intuitionniste}, - year = {1994} -} - -@Article{Myers, - author = {Eugene Myers}, - title = {An {O(ND)} difference algorithm and its variations}, - journal = {Algorithmica}, - volume = {1}, - number = {2}, - year = {1986}, - bibsource = {https://link.springer.com/article/10.1007\%2FBF01840446}, - url = {http://www.xmailserver.org/diff2.pdf} -} - -@inproceedings{P86, - title={Algorithm development in the calculus of constructions}, - author={Mohring, Christine}, - booktitle={LICS}, - pages={84--91}, - year={1986} -} - -@inproceedings{P89, - title={Extracting $\Omega$'s programs from proofs in the calculus of constructions}, - author={Paulin-Mohring, Christine}, - booktitle={Proceedings of the 16th ACM SIGPLAN-SIGACT symposium on Principles of programming languages}, - pages={89--104}, - year={1989}, - doi = {10.1145/75277.75285}, - url = {http://dx.doi.org/10.1145/75277.75285}, - isbn = 0897912942, - organization = {ACM Press} -} - -@inproceedings{P93, - title={Inductive definitions in the system coq rules and properties}, - author={Paulin-Mohring, Christine}, - booktitle={International Conference on Typed Lambda Calculi and Applications}, - pages={328--345}, - year={1993}, - doi = {10.1007/bfb0037116}, - url = {http://dx.doi.org/10.1007/bfb0037116}, - isbn = 3540565175, - organization = {Springer-Verlag} -} - -@inproceedings{PP90, - title={Inductively defined types in the Calculus of Constructions}, - author={Pfenning, Frank and Paulin-Mohring, Christine}, - booktitle={International Conference on Mathematical Foundations of Programming Semantics}, - pages={209--228}, - year={1989}, - doi = {10.1007/bfb0040259}, - url = {http://dx.doi.org/10.1007/bfb0040259}, - isbn = 0387973753, - organization = {Springer-Verlag} -} - -@InProceedings{Parent95b, - author = {C. Parent}, - booktitle = {{Mathematics of Program Construction'95}}, - publisher = SV, - series = {LNCS}, - title = {{Synthesizing proofs from programs in -the Calculus of Inductive Constructions}}, - volume = {947}, - year = {1995} -} - -@InProceedings{Pit16, - Title = {Company-Coq: Taking Proof General one step closer to a real IDE}, - Author = {Pit-Claudel, ClĆ©ment and Courtieu, Pierre}, - Booktitle = {CoqPL'16: The Second International Workshop on Coq for PL}, - Year = {2016}, - Month = jan, - Doi = {10.5281/zenodo.44331}, -} - -@Book{RC95, - author = {di~Cosmo, R.}, - title = {Isomorphisms of Types: from $\lambda$-calculus to information - retrieval and language design}, - series = {Progress in Theoretical Computer Science}, - publisher = {Birkhauser}, - year = {1995}, - note = {ISBN-0-8176-3763-X} -} - -@Article{Rushby98, - title = {Subtypes for Specifications: Predicate Subtyping in - {PVS}}, - author = {John Rushby and Sam Owre and N. Shankar}, - journal = {IEEE Transactions on Software Engineering}, - pages = {709--720}, - volume = 24, - number = 9, - month = sep, - year = 1998 -} - -@InProceedings{sozeau06, - author = {Matthieu Sozeau}, - title = {Subset Coercions in {C}oq}, - year = {2007}, - booktitle = {TYPES'06}, - pages = {237-252}, - volume = {4502}, - publisher = "Springer", - series = {LNCS} -} - -@InProceedings{sozeau08, - Author = {Matthieu Sozeau and Nicolas Oury}, - booktitle = {TPHOLs'08}, - Pdf = {http://www.lri.fr/~sozeau/research/publications/drafts/classes.pdf}, - Title = {{F}irst-{C}lass {T}ype {C}lasses}, - Year = {2008}, -} - -@InProceedings{sugar, - author = {Alessandro Giovini and Teo Mora and Gianfranco Niesi and Lorenzo Robbiano and Carlo Traverso}, - title = {"One sugar cube, please" or Selection strategies in the Buchberger algorithm}, - booktitle = { Proceedings of the ISSAC'91, ACM Press}, - year = {1991}, - pages = {5--4}, - publisher = {} -} - -@PhDThesis{Wer94, - author = {B. Werner}, - school = {Universit\'e Paris 7}, - title = {Une th\'eorie des constructions inductives}, - type = {Th\`ese de Doctorat}, - year = {1994} -} - -@InProceedings{CompiledStrongReduction, - author = {Benjamin Gr{\'{e}}goire and - Xavier Leroy}, - editor = {Mitchell Wand and - Simon L. Peyton Jones}, - title = {A compiled implementation of strong reduction}, - booktitle = {Proceedings of the Seventh {ACM} {SIGPLAN} International Conference - on Functional Programming {(ICFP} '02), Pittsburgh, Pennsylvania, - USA, October 4-6, 2002.}, - pages = {235--246}, - publisher = {{ACM}}, - year = {2002}, - url = {http://doi.acm.org/10.1145/581478.581501}, - doi = {10.1145/581478.581501}, - timestamp = {Tue, 11 Jun 2013 13:49:16 +0200}, - biburl = {http://dblp.uni-trier.de/rec/bib/conf/icfp/GregoireL02}, - bibsource = {dblp computer science bibliography, http://dblp.org} -} - -@InProceedings{FullReduction, - author = {Mathieu Boespflug and - Maxime D{\'{e}}n{\`{e}}s and - Benjamin Gr{\'{e}}goire}, - editor = {Jean{-}Pierre Jouannaud and - Zhong Shao}, - title = {Full Reduction at Full Throttle}, - booktitle = {Certified Programs and Proofs - First International Conference, {CPP} - 2011, Kenting, Taiwan, December 7-9, 2011. Proceedings}, - series = {Lecture Notes in Computer Science}, - volume = {7086}, - pages = {362--377}, - publisher = {Springer}, - year = {2011}, - url = {http://dx.doi.org/10.1007/978-3-642-25379-9_26}, - doi = {10.1007/978-3-642-25379-9_26}, - timestamp = {Thu, 17 Nov 2011 13:33:48 +0100}, - biburl = {http://dblp.uni-trier.de/rec/bib/conf/cpp/BoespflugDG11}, - bibsource = {dblp computer science bibliography, http://dblp.org} -} - -@inproceedings{MilnerPrincipalTypeSchemes, - author = {Damas, Luis and Milner, Robin}, - title = {Principal Type-schemes for Functional Programs}, - booktitle = {Proceedings of the 9th ACM SIGPLAN-SIGACT Symposium on Principles of Programming Languages}, - series = {POPL '82}, - year = {1982}, - isbn = {0-89791-065-6}, - location = {Albuquerque, New Mexico}, - pages = {207--212}, - numpages = {6}, - url = {http://doi.acm.org/10.1145/582153.582176}, - doi = {10.1145/582153.582176}, - acmid = {582176}, - publisher = {ACM}, - address = {New York, NY, USA}, -} - -@techreport{abel19:failur_normal_impred_type_theor, - author = {Andreas Abel AND Thierry Coquand}, - title = {{Failure of Normalization in Impredicative Type - Theory with Proof-Irrelevant Propositional - Equality}}, - year = 2019, - institution = {Chalmers and Gothenburg University}, -} - -@inproceedings{ConchonFilliatre07wml, - author = {Sylvain Conchon and Jean-Christophe FilliĆ¢tre}, - title = {A Persistent Union-Find Data Structure}, - booktitle = {ACM SIGPLAN Workshop on ML}, - publisher = {ACM Press}, - pages = {37--45}, - year = 2007, - address = {Freiburg, Germany}, - month = {October}, - topics = {team, lri}, - type_publi = {icolcomlec}, - type_digiteo = {conf_isbn}, - x-pdf = {https://www.lri.fr/~filliatr/ftp/publis/puf-wml07.pdf}, - url = {https://www.lri.fr/~filliatr/ftp/publis/puf-wml07.pdf}, - abstract = { The problem of disjoint sets, also known as union-find, - consists in maintaining a partition of a finite set within a data - structure. This structure provides two operations: a function find - returning the class of an element and a function union merging two - classes. An optimal and imperative solution is known since 1975. - However, the imperative nature of this data structure may be a - drawback when it is used in a backtracking algorithm. This paper - details the implementation of a persistent union-find data structure - as efficient as its imperative counterpart. To achieve this result, - our solution makes heavy use of imperative features and thus it is a - significant example of a data structure whose side effects are - safely hidden behind a persistent interface. To strengthen this - last claim, we also detail a formalization using the Coq proof - assistant which shows both the correctness of our solution and its - observational persistence. }, - x-equipes = {demons PROVAL}, - x-type = {article}, - x-support = {actes_aux}, - x-cle-support = {ML} -} - -@phdthesis{Zimmermann19, - author = {Th{\'{e}}o Zimmermann}, - title = {Challenges in the collaborative evolution of a proof language and - its ecosystem.}, - school = {UniversitĆ© de Paris, France}, - year = {2019}, - url = {https://tel.archives-ouvertes.fr/tel-02451322}, - timestamp = {Tue, 21 Jul 2020 00:40:54 +0200}, - biburl = {https://dblp.org/rec/phd/hal/Zimmermann19.bib}, - bibsource = {dblp computer science bibliography, https://dblp.org} -} - -@article{TotR21, - author = {Cockx, Jesper and Tabareau, Nicolas and Winterhalter, Th\'{e}o}, - title = {The Taming of the Rew: A Type Theory with Computational Assumptions}, - year = {2021}, - issue_date = {January 2021}, - publisher = {Association for Computing Machinery}, - address = {New York, NY, USA}, - volume = {5}, - number = {POPL}, - url = {https://doi.org/10.1145/3434341}, - doi = {10.1145/3434341}, - abstract = {Dependently typed programming languages and proof assistants such as Agda and Coq rely on computation to automatically simplify expressions during type checking. To overcome the lack of certain programming primitives or logical principles in those systems, it is common to appeal to axioms to postulate their existence. However, one can only postulate the bare existence of an axiom, not its computational behaviour. Instead, users are forced to postulate equality proofs and appeal to them explicitly to simplify expressions, making axioms dramatically more complicated to work with than built-in primitives. On the other hand, the equality reflection rule from extensional type theory solves these problems by collapsing computation and equality, at the cost of having no practical type checking algorithm. This paper introduces Rewriting Type Theory (RTT), a type theory where it is possible to add computational assumptions in the form of rewrite rules. Rewrite rules go beyond the computational capabilities of intensional type theory, but in contrast to extensional type theory, they are applied automatically so type checking does not require input from the user. To ensure type soundness of RTTā€”as well as effective type checkingā€”we provide a framework where confluence of user-defined rewrite rules can be checked modularly and automatically, and where adding new rewrite rules is guaranteed to preserve subject reduction. The properties of RTT have been formally verified using the MetaCoq framework and an implementation of rewrite rules is already available in the Agda proof assistant.}, - journal = {Proc. ACM Program. Lang.}, - month = {jan}, - articleno = {60}, - numpages = {29}, - keywords = {termination, dependent types, rewriting theory, confluence, type theory} -} diff --git a/stdlib/doc/sphinx/conf.py b/stdlib/doc/sphinx/conf.py deleted file mode 100644 index 06e56bb66d38..000000000000 --- a/stdlib/doc/sphinx/conf.py +++ /dev/null @@ -1,499 +0,0 @@ -#!/usr/bin/env python3 -########################################################################## -## # The Coq Proof Assistant / The Coq Development Team ## -## v # Copyright INRIA, CNRS and contributors ## -## v documentation" by default. -#html_title = 'Coq 8.5 v8.5pl1' - -# A shorter title for the navigation bar. Default is the same as html_title. -#html_short_title = None - -# The name of an image file (relative to this directory) to place at the top -# of the sidebar. -#html_logo = None - -# The name of an image file (relative to this directory) to use as a favicon of -# the docs. This file should be a Windows icon file (.ico) being 16x16 or 32x32 -# pixels large. -#html_favicon = None - -# Add any paths that contain custom static files (such as style sheets) here, -# relative to this directory. They are copied after the builtin static files, -# so a file named "default.css" will overwrite the builtin "default.css". -html_static_path = ['_static'] - -# Add any extra paths that contain custom files (such as robots.txt or -# .htaccess) here, relative to this directory. These files are copied -# directly to the root of the documentation. -#html_extra_path = [] - -# If not None, a 'Last updated on:' timestamp is inserted at every page -# bottom, using the given strftime format. -# The empty string is equivalent to '%b %d, %Y'. -#html_last_updated_fmt = None - -# FIXME: this could be re-enabled after ensuring that smart quotes are locally -# disabled for all relevant directives -smartquotes = False - -# Custom sidebar templates, maps document names to template names. -#html_sidebars = {} - -# Additional templates that should be rendered to pages, maps page names to -# template names. -#html_additional_pages = {} - -# If false, no module index is generated. -#html_domain_indices = True - -# If false, no index is generated. -#html_use_index = True - -# If true, the index is split into individual pages for each letter. -#html_split_index = False - -# If true, links to the reST sources are added to the pages. -#html_show_sourcelink = True - -# If true, "Created using Sphinx" is shown in the HTML footer. Default is True. -#html_show_sphinx = True - -# If true, "(C) Copyright ..." is shown in the HTML footer. Default is True. -#html_show_copyright = True - -# If true, an OpenSearch description file will be output, and all pages will -# contain a tag referring to it. The value of this option must be the -# base URL from which the finished HTML is served. -#html_use_opensearch = '' - -# This is the file name suffix for HTML files (e.g. ".xhtml"). -#html_file_suffix = None - -# Language to be used for generating the HTML full-text search index. -# Sphinx supports the following languages: -# 'da', 'de', 'en', 'es', 'fi', 'fr', 'h', 'it', 'ja' -# 'nl', 'no', 'pt', 'ro', 'r', 'sv', 'tr', 'zh' -#html_search_language = 'en' - -# A dictionary with options for the search language support, empty by default. -# 'ja' uses this config value. -# 'zh' user can custom change `jieba` dictionary path. -#html_search_options = {'type': 'default'} - -# The name of a javascript file (relative to the configuration directory) that -# implements a search results scorer. If empty, the default will be used. -#html_search_scorer = 'scorer.js' - -# -- Options for LaTeX output --------------------------------------------- - -########################### -# Set things up for XeTeX # -########################### - -latex_elements = { - 'babel': '', - 'fontenc': '', - 'inputenc': '', - 'utf8extra': '', - 'cmappkg': '', - 'papersize': 'letterpaper', - 'classoptions': ',openany', # No blank pages - 'polyglossia': '\\usepackage{polyglossia}', - 'sphinxsetup': 'verbatimwithframe=false', - 'preamble': r""" - \usepackage{unicode-math} - \usepackage{microtype} - - % Macro definitions - \usepackage{refman-preamble} - - % Style definitions for notations - \usepackage{coqnotations} - - % Style tweaks - \newcssclass{sigannot}{\textrm{#1:}} - - % Silence 'LaTeX Warning: Command \nobreakspace invalid in math mode' - \everymath{\def\nobreakspace{\ }} - """ -} - -latex_engine = "xelatex" - -# Cf. https://github.com/sphinx-doc/sphinx/issues/7015 -latex_use_xindy = False - -######## -# done # -######## - -latex_additional_files = [ - "refman-preamble.sty", - "_static/coqnotations.sty" -] - -latex_documents = [('index', 'CoqRefMan.tex', 'The Coq Reference Manual', author, 'manual')] - -# The name of an image file (relative to this directory) to place at the top of -# the title page. -# latex_logo = "../../ide/coq.png" - -# If true, show page references after internal links. -#latex_show_pagerefs = False - -# If true, show URL addresses after external links. -latex_show_urls = 'footnote' - -# -- Options for manual page output --------------------------------------- - -# One entry per manual page. List of tuples -# (source start file, name, description, authors, manual section). -#man_pages = [ -# (master_doc, 'coq', 'Coq Documentation', -# [author], 1) -#] - -# If true, show URL addresses after external links. -#man_show_urls = False - - -# -- Options for Texinfo output ------------------------------------------- - -# Grouping the document tree into Texinfo files. List of tuples -# (source start file, target name, title, author, -# dir menu entry, description, category) -#texinfo_documents = [ -# (master_doc, 'Coq', 'Coq Documentation', -# author, 'Coq', 'One line description of project.', -# 'Miscellaneous'), -#] - -# Documents to append as an appendix to all manuals. -#texinfo_appendices = [] - -# If false, no module index is generated. -#texinfo_domain_indices = True - -# How to display URL addresses: 'footnote', 'no', or 'inline'. -#texinfo_show_urls = 'footnote' - -# If true, do not generate a @detailmenu in the "Top" node's menu. -#texinfo_no_detailmenu = False - - -# -- Options for Epub output ---------------------------------------------- - -# Bibliographic Dublin Core info. -#epub_title = project -#epub_author = author -#epub_publisher = author -#epub_copyright = copyright - -# The basename for the epub file. It defaults to the project name. -#epub_basename = project - -# The HTML theme for the epub output. Since the default themes are not -# optimized for small screen space, using the same theme for HTML and epub -# output is usually not wise. This defaults to 'epub', a theme designed to save -# visual space. -#epub_theme = 'epub' - -# The language of the text. It defaults to the language option -# or 'en' if the language is not set. -#epub_language = '' - -# The scheme of the identifier. Typical schemes are ISBN or URL. -#epub_scheme = '' - -# The unique identifier of the text. This can be a ISBN number -# or the project homepage. -#epub_identifier = '' - -# A unique identification for the text. -#epub_uid = '' - -# A tuple containing the cover image and cover page html template filenames. -#epub_cover = () - -# A sequence of (type, uri, title) tuples for the guide element of content.opf. -#epub_guide = () - -# HTML files that should be inserted before the pages created by sphinx. -# The format is a list of tuples containing the path and title. -#epub_pre_files = [] - -# HTML files that should be inserted after the pages created by sphinx. -# The format is a list of tuples containing the path and title. -#epub_post_files = [] - -# A list of files that should not be packed into the epub file. -epub_exclude_files = ['search.html'] - -# The depth of the table of contents in toc.ncx. -#epub_tocdepth = 3 - -# Allow duplicate toc entries. -#epub_tocdup = True - -# Choose between 'default' and 'includehidden'. -#epub_tocscope = 'default' - -# Fix unsupported image types using the Pillow. -#epub_fix_images = False - -# Scale large images. -#epub_max_image_width = 0 - -# How to display URL addresses: 'footnote', 'no', or 'inline'. -#epub_show_urls = 'inline' - -# If false, no index is generated. -#epub_use_index = True - -# navtree options -navtree_shift = True - -# since sphinxcontrib-bibtex version 2 we need this -bibtex_bibfiles = [ "biblio.bib" ] diff --git a/stdlib/doc/sphinx/dune b/stdlib/doc/sphinx/dune deleted file mode 100644 index 4136de32875b..000000000000 --- a/stdlib/doc/sphinx/dune +++ /dev/null @@ -1 +0,0 @@ -(dirs :standard _static _templates) diff --git a/stdlib/doc/sphinx/index.html.rst b/stdlib/doc/sphinx/index.html.rst deleted file mode 100644 index cbb48053725a..000000000000 --- a/stdlib/doc/sphinx/index.html.rst +++ /dev/null @@ -1,24 +0,0 @@ -========================== -Introduction and Contents -========================== - -.. include:: introduction.rst - -Contents --------- - -.. toctree:: - - self - -.. toctree:: - :caption: Overview - - language/coq-library - -.. toctree:: - :caption: Appendix - - zebibliography - -.. include:: license.rst diff --git a/stdlib/doc/sphinx/index.latex.rst b/stdlib/doc/sphinx/index.latex.rst deleted file mode 100644 index d73210fe231e..000000000000 --- a/stdlib/doc/sphinx/index.latex.rst +++ /dev/null @@ -1,27 +0,0 @@ -========================================= - The Rocq Prover Stdlib Reference Manual -========================================= - ------------- -Introduction ------------- - -.. include:: introduction.rst - -.. include:: license.rst - --------- -Overview --------- - -.. toctree:: - - language/coq-library - --------- -Appendix --------- - -.. toctree:: - - zebibliography diff --git a/stdlib/doc/sphinx/introduction.rst b/stdlib/doc/sphinx/introduction.rst deleted file mode 100644 index 4f014f1c2014..000000000000 --- a/stdlib/doc/sphinx/introduction.rst +++ /dev/null @@ -1,6 +0,0 @@ -The is the reference manual of the Standard Library of Coq. -It mostly presents a few tactics. - -.. only:: html - - The full table of contents is presented below: diff --git a/stdlib/doc/sphinx/language/coq-library.rst b/stdlib/doc/sphinx/language/coq-library.rst deleted file mode 100644 index befc0502bbde..000000000000 --- a/stdlib/doc/sphinx/language/coq-library.rst +++ /dev/null @@ -1,393 +0,0 @@ -The standard library --------------------- - -Survey -~~~~~~ - -The standard library is structured into the following -subdirectories: - - * **Logic** : Classical logic and dependent equality - * **Arith** : Basic Peano arithmetic - * **PArith** : Basic positive integer arithmetic - * **NArith** : Basic binary natural number arithmetic - * **ZArith** : Basic relative integer arithmetic - * **Numbers** : Various approaches to natural, integer and cyclic numbers (currently axiomatically and on top of 2^31 binary words) - * **Bool** : Booleans (basic functions and results) - * **Lists** : Monomorphic and polymorphic lists (basic functions and results), Streams (infinite sequences defined with coinductive types) - * **Sets** : Sets (classical, constructive, finite, infinite, power set, etc.) - * **FSets** : Specification and implementations of finite sets and finite maps (by lists and by AVL trees) - * **Reals** : Axiomatization of real numbers (classical, basic functions, integer part, fractional part, limit, derivative, Cauchy series, power series and results,...) - * **Floats** : Machine implementation of floating-point arithmetic (for the binary64 format) - * **Relations** : Relations (definitions and basic results) - * **Sorting** : Sorted list (basic definitions and heapsort correctness) - * **Strings** : 8-bits characters and strings - * **Wellfounded** : Well-founded relations (basic results) - - -These directories belong to the initial load path of the system, and -the modules they provide are compiled at installation time. So they -are directly accessible with the command ``Require``. - -The different modules of the Coq standard library are documented -online at https://coq.inria.fr/stdlib/. - -Peanoā€™s arithmetic (nat) -~~~~~~~~~~~~~~~~~~~~~~~~ - -.. index:: - single: Peano's arithmetic - single: nat_scope - -While in the initial state, many operations and predicates of Peano's -arithmetic are defined, further operations and results belong to other -modules. For instance, the decidability of the basic predicates are -defined here. This is provided by requiring the module ``Arith``. - -The following table describes the notations available in scope -``nat_scope`` : - -=============== =================== -Notation Interpretation -=============== =================== -``_ < _`` ``lt`` -``_ <= _`` ``le`` -``_ > _`` ``gt`` -``_ >= _`` ``ge`` -``x < y < z`` ``x < y /\ y < z`` -``x < y <= z`` ``x < y /\ y <= z`` -``x <= y < z`` ``x <= y /\ y < z`` -``x <= y <= z`` ``x <= y /\ y <= z`` -``_ + _`` ``plus`` -``_ - _`` ``minus`` -``_ * _`` ``mult`` -=============== =================== - - -Notations for integer arithmetic -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -.. index:: - single: Arithmetical notations - single: + (term) - single: * (term) - single: - (term) - singel: / (term) - single: <= (term) - single: >= (term) - single: < (term) - single: > (term) - single: ?= (term) - single: mod (term) - - -The following table describes the syntax of expressions -for integer arithmetic. It is provided by requiring and opening the module ``ZArith`` and opening scope ``Z_scope``. -It specifies how notations are interpreted and, when not -already reserved, the precedence and associativity. - -=============== ==================== ========== ============= -Notation Interpretation Precedence Associativity -=============== ==================== ========== ============= -``_ < _`` ``Z.lt`` -``_ <= _`` ``Z.le`` -``_ > _`` ``Z.gt`` -``_ >= _`` ``Z.ge`` -``x < y < z`` ``x < y /\ y < z`` -``x < y <= z`` ``x < y /\ y <= z`` -``x <= y < z`` ``x <= y /\ y < z`` -``x <= y <= z`` ``x <= y /\ y <= z`` -``_ ?= _`` ``Z.compare`` 70 no -``_ + _`` ``Z.add`` -``_ - _`` ``Z.sub`` -``_ * _`` ``Z.mul`` -``_ / _`` ``Z.div`` -``_ mod _`` ``Z.modulo`` 40 no -``- _`` ``Z.opp`` -``_ ^ _`` ``Z.pow`` -=============== ==================== ========== ============= - - -.. example:: - - .. rocqtop:: all reset - - From Stdlib Require Import ZArith. - Check (2 + 3)%Z. - Open Scope Z_scope. - Check 2 + 3. - - -Real numbers library -~~~~~~~~~~~~~~~~~~~~ - -Notations for real numbers -++++++++++++++++++++++++++ - -This is provided by requiring and opening the module ``Reals`` and -opening scope ``R_scope``. This set of notations is very similar to -the notation for integer arithmetic. The inverse function was added. - -=============== =================== -Notation Interpretation -=============== =================== -``_ < _`` ``Rlt`` -``_ <= _`` ``Rle`` -``_ > _`` ``Rgt`` -``_ >= _`` ``Rge`` -``x < y < z`` ``x < y /\ y < z`` -``x < y <= z`` ``x < y /\ y <= z`` -``x <= y < z`` ``x <= y /\ y < z`` -``x <= y <= z`` ``x <= y /\ y <= z`` -``_ + _`` ``Rplus`` -``_ - _`` ``Rminus`` -``_ * _`` ``Rmult`` -``_ / _`` ``Rdiv`` -``- _`` ``Ropp`` -``/ _`` ``Rinv`` -``_ ^ _`` ``pow`` -=============== =================== - -.. example:: - - .. rocqtop:: all reset - - From Stdlib Require Import Reals. - Check (2 + 3)%R. - Open Scope R_scope. - Check 2 + 3. - -Some tactics for real numbers -+++++++++++++++++++++++++++++ - -In addition to the powerful ``ring``, ``field`` and ``lra`` -tactics (see Chapters ring and micromega), there are also: - -.. tacn:: discrR - - Proves that two real integer constants are different. - -.. example:: - - .. rocqtop:: all reset - - From Stdlib Require Import DiscrR. - Open Scope R_scope. - Goal 5 <> 0. - discrR. - -.. tacn:: split_Rabs - - Allows unfolding the ``Rabs`` constant and splits corresponding conjunctions. - -.. example:: - - .. rocqtop:: all reset - - From Stdlib Require Import Reals. - Open Scope R_scope. - Goal forall x:R, x <= Rabs x. - intro; split_Rabs. - -.. tacn:: split_Rmult - - Splits a condition that a product is non-null into subgoals - corresponding to the condition on each operand of the product. - -.. example:: - - .. rocqtop:: all reset - - From Stdlib Require Import Reals. - Open Scope R_scope. - Goal forall x y z:R, x * y * z <> 0. - intros; split_Rmult. - -List library -~~~~~~~~~~~~ - -.. index:: - single: Notations for lists - single: length (term) - single: head (term) - single: tail (term) - single: app (term) - single: rev (term) - single: nth (term) - single: map (term) - single: flat_map (term) - single: fold_left (term) - single: fold_right (term) - -Some elementary operations on polymorphic lists are defined here. -They can be accessed by requiring module ``List``. - -It defines the following notions: - - * ``length`` - * ``head`` : first element (with default) - * ``tail`` : all but first element - * ``app`` : concatenation - * ``rev`` : reverse - * ``nth`` : accessing n-th element (with default) - * ``map`` : applying a function - * ``flat_map`` : applying a function returning lists - * ``fold_left`` : iterator (from head to tail) - * ``fold_right`` : iterator (from tail to head) - -The following table shows notations available when opening scope ``list_scope``. - -========== ============== ========== ============= -Notation Interpretation Precedence Associativity -========== ============== ========== ============= -``_ ++ _`` ``app`` 60 right -``_ :: _`` ``cons`` 60 right -========== ============== ========== ============= - -.. _floats_library: - -Floats library -~~~~~~~~~~~~~~ - -The standard library has a small ``Floats`` module for accessing -processor floating-point operations through the Coq kernel. -However, while this module supports computation and has a bit-level -specification, it doesn't include elaborate theorems, such as a link -to real arithmetic or various error bounds. To do proofs by -reflection, use ``Floats`` in conjunction with the complementary -`Flocq `_ library, which provides -many such theorems. - -The library of primitive floating-point arithmetic can be loaded by -requiring module ``Floats``: - -.. rocqtop:: in - - From Stdlib Require Import Floats. - -It exports the module ``PrimFloat`` that provides a primitive type -named ``float``, defined in the kernel -as well as two variant types ``float_comparison`` and ``float_class``: - - -.. rocqtop:: all - - Print float. - Print float_comparison. - Print float_class. - -It then defines the primitive operators below, using the processor -floating-point operators for binary64 in rounding-to-nearest even: - -* ``abs`` -* ``opp`` -* ``sub`` -* ``add`` -* ``mul`` -* ``div`` -* ``sqrt`` -* ``compare`` : compare two floats and return a ``float_comparison`` -* ``classify`` : analyze a float and return a ``float_class`` -* ``of_int63`` : round a primitive integer and convert it into a float -* ``normfr_mantissa`` : take a float in ``[0.5; 1.0)`` and return its mantissa -* ``frshiftexp`` : convert a float to fractional part in ``[0.5; 1.0)`` and integer part -* ``ldshiftexp`` : multiply a float by an integral power of ``2`` -* ``next_up`` : return the next float towards positive infinity -* ``next_down`` : return the next float towards negative infinity - -For special floating-point values, the following constants are also -defined: - -* ``zero`` -* ``neg_zero`` -* ``one`` -* ``two`` -* ``infinity`` -* ``neg_infinity`` -* ``nan`` : Not a Number (assumed to be unique: the "payload" of NaNs is ignored) - -The following table shows the notations available when opening scope -``float_scope``. - -=========== ============== -Notation Interpretation -=========== ============== -``- _`` ``opp`` -``_ - _`` ``sub`` -``_ + _`` ``add`` -``_ * _`` ``mul`` -``_ / _`` ``div`` -``_ =? _`` ``eqb`` -``_ The Coq Standard Library - -

Here is a short description of the Coq standard library. -It provides a set of modules directly available -through the Require Import command.

- -

The standard library is composed of the following subdirectories:

- -
-
Logic: - Classical logic, dependent equality, extensionality, choice axioms -
-
- theories/Logic/SetIsType.v - theories/Logic/StrictProp.v - theories/Logic/Classical_Pred_Type.v - theories/Logic/Classical_Prop.v - (theories/Logic/Classical.v) - theories/Logic/ClassicalFacts.v - theories/Logic/Decidable.v - theories/Logic/Eqdep_dec.v - theories/Logic/EqdepFacts.v - theories/Logic/Eqdep.v - theories/Logic/JMeq.v - theories/Logic/ChoiceFacts.v - theories/Logic/RelationalChoice.v - theories/Logic/ClassicalChoice.v - theories/Logic/ClassicalDescription.v - theories/Logic/ClassicalEpsilon.v - theories/Logic/ClassicalUniqueChoice.v - theories/Logic/SetoidChoice.v - theories/Logic/Berardi.v - theories/Logic/Diaconescu.v - theories/Logic/Hurkens.v - theories/Logic/ProofIrrelevance.v - theories/Logic/ProofIrrelevanceFacts.v - theories/Logic/ConstructiveEpsilon.v - theories/Logic/Description.v - theories/Logic/Epsilon.v - theories/Logic/IndefiniteDescription.v - theories/Logic/PropExtensionality.v - theories/Logic/PropExtensionalityFacts.v - theories/Logic/FunctionalExtensionality.v - theories/Logic/ExtensionalFunctionRepresentative.v - theories/Logic/ExtensionalityFacts.v - theories/Logic/WeakFan.v - theories/Logic/WKL.v - theories/Logic/FinFun.v - theories/Logic/PropFacts.v - theories/Logic/HLevels.v - theories/Logic/Adjointification.v -
- -
Structures: - Algebraic structures (types with equality, with order, ...). - DecidableType* and OrderedType* are there only for compatibility. -
-
- theories/Structures/Equalities.v - theories/Structures/EqualitiesFacts.v - theories/Structures/Orders.v - theories/Structures/OrdersTac.v - theories/Structures/OrdersAlt.v - theories/Structures/OrdersEx.v - theories/Structures/OrdersFacts.v - theories/Structures/OrdersLists.v - theories/Structures/GenericMinMax.v - theories/Structures/DecidableType.v - theories/Structures/DecidableTypeEx.v - theories/Structures/OrderedType.v - theories/Structures/OrderedTypeAlt.v - theories/Structures/OrderedTypeEx.v -
- -
Bool: - Booleans (basic functions and results) -
-
- theories/Bool/Bool.v - theories/Bool/BoolEq.v - theories/Bool/BoolOrder.v - theories/Bool/DecBool.v - theories/Bool/IfProp.v - theories/Bool/Zerob.v - theories/Bool/Bvector.v -
- -
Arith: - Basic Peano arithmetic -
-
- theories/Arith/PeanoNat.v - theories/Arith/Between.v - theories/Arith/Peano_dec.v - theories/Arith/Compare_dec.v - (theories/Arith/Arith_base.v) - (theories/Arith/Arith.v) - theories/Arith/Compare.v - theories/Arith/EqNat.v - theories/Arith/Euclid.v - theories/Arith/Factorial.v - theories/Arith/Wf_nat.v - theories/Arith/Cantor.v -
- -
PArith: - Binary positive integers -
-
- theories/PArith/BinPosDef.v - theories/PArith/BinPos.v - theories/PArith/Pnat.v - theories/PArith/POrderedType.v - (theories/PArith/PArith.v) -
- -
NArith: - Binary natural numbers -
-
- theories/NArith/BinNatDef.v - theories/NArith/BinNat.v - theories/NArith/Nnat.v - theories/NArith/Ndec.v - theories/NArith/Ndiv_def.v - theories/NArith/Ngcd_def.v - theories/NArith/Nsqrt_def.v - (theories/NArith/NArith.v) -
- -
ZArith: - Binary integers -
-
- theories/ZArith/BinIntDef.v - theories/ZArith/BinInt.v - theories/ZArith/Zorder.v - theories/ZArith/Zcompare.v - theories/ZArith/Znat.v - theories/ZArith/Zmin.v - theories/ZArith/Zmax.v - theories/ZArith/Zminmax.v - theories/ZArith/Zabs.v - theories/ZArith/Zeven.v - theories/ZArith/auxiliary.v - theories/ZArith/ZArith_dec.v - theories/ZArith/Zbool.v - theories/ZArith/Zmisc.v - theories/ZArith/Wf_Z.v - theories/ZArith/Zhints.v - (theories/ZArith/ZArith_base.v) - theories/ZArith/Zcomplements.v - theories/ZArith/Zpow_def.v - theories/ZArith/Zpow_alt.v - theories/ZArith/Zpower.v - theories/ZArith/Zdiv.v - theories/ZArith/Zquot.v - (theories/ZArith/ZArith.v) - theories/ZArith/Zgcd_alt.v - theories/ZArith/Zwf.v - theories/ZArith/Znumtheory.v - theories/ZArith/Int.v - theories/ZArith/Zpow_facts.v - theories/ZArith/Zdiv_facts.v - theories/ZArith/Zbitwise.v -
- -
QArith: - Rational numbers -
-
- theories/QArith/QArith_base.v - theories/QArith/Qabs.v - theories/QArith/Qpower.v - theories/QArith/Qreduction.v - theories/QArith/Qring.v - theories/QArith/Qfield.v - (theories/QArith/QArith.v) - theories/QArith/Qreals.v - theories/QArith/Qcanon.v - theories/QArith/Qcabs.v - theories/QArith/Qround.v - theories/QArith/QOrderedType.v - theories/QArith/Qminmax.v -
- -
Numbers: - An experimental modular architecture for arithmetic -
-
-
-
  Prelude: -
-
- theories/Numbers/NumPrelude.v - theories/Numbers/NaryFunctions.v - theories/Numbers/AltBinNotations.v - theories/Numbers/DecimalFacts.v - theories/Numbers/DecimalNat.v - theories/Numbers/DecimalPos.v - theories/Numbers/DecimalN.v - theories/Numbers/DecimalZ.v - theories/Numbers/DecimalQ.v - theories/Numbers/DecimalR.v - theories/Numbers/DecimalString.v - theories/Numbers/HexadecimalFacts.v - theories/Numbers/HexadecimalNat.v - theories/Numbers/HexadecimalPos.v - theories/Numbers/HexadecimalN.v - theories/Numbers/HexadecimalZ.v - theories/Numbers/HexadecimalQ.v - theories/Numbers/HexadecimalR.v - theories/Numbers/HexadecimalString.v -
- -
  NatInt: - Abstract mixed natural/integer/cyclic arithmetic -
-
- theories/Numbers/NatInt/NZAdd.v - theories/Numbers/NatInt/NZAddOrder.v - theories/Numbers/NatInt/NZAxioms.v - theories/Numbers/NatInt/NZBase.v - theories/Numbers/NatInt/NZMul.v - theories/Numbers/NatInt/NZDiv.v - theories/Numbers/NatInt/NZMulOrder.v - theories/Numbers/NatInt/NZOrder.v - theories/Numbers/NatInt/NZParity.v - theories/Numbers/NatInt/NZPow.v - theories/Numbers/NatInt/NZSqrt.v - theories/Numbers/NatInt/NZLog.v - theories/Numbers/NatInt/NZGcd.v - theories/Numbers/NatInt/NZBits.v -
- -
  Cyclic: - Abstract and 63-bits-based cyclic arithmetic -
-
- theories/Numbers/Cyclic/Abstract/CyclicAxioms.v - theories/Numbers/Cyclic/Abstract/NZCyclic.v - theories/Numbers/Cyclic/Abstract/DoubleType.v - theories/Numbers/Cyclic/Int63/Cyclic63.v - theories/Numbers/Cyclic/Int63/Uint63.v - theories/Numbers/Cyclic/Int63/Sint63.v - theories/Numbers/Cyclic/Int63/Ring63.v -
- -
  Natural: - Abstract and 63-bits-words-based natural arithmetic -
-
- theories/Numbers/Natural/Abstract/NAdd.v - theories/Numbers/Natural/Abstract/NAddOrder.v - theories/Numbers/Natural/Abstract/NAxioms.v - theories/Numbers/Natural/Abstract/NBase.v - theories/Numbers/Natural/Abstract/NMulOrder.v - theories/Numbers/Natural/Abstract/NOrder.v - theories/Numbers/Natural/Abstract/NStrongRec.v - theories/Numbers/Natural/Abstract/NSub.v - theories/Numbers/Natural/Abstract/NDiv.v - theories/Numbers/Natural/Abstract/NDiv0.v - theories/Numbers/Natural/Abstract/NMaxMin.v - theories/Numbers/Natural/Abstract/NParity.v - theories/Numbers/Natural/Abstract/NPow.v - theories/Numbers/Natural/Abstract/NSqrt.v - theories/Numbers/Natural/Abstract/NLog.v - theories/Numbers/Natural/Abstract/NGcd.v - theories/Numbers/Natural/Abstract/NLcm.v - theories/Numbers/Natural/Abstract/NLcm0.v - theories/Numbers/Natural/Abstract/NBits.v - theories/Numbers/Natural/Abstract/NProperties.v -
- -
  Integer: - Abstract and concrete (especially 63-bits-words-based) integer - arithmetic -
-
- theories/Numbers/Integer/Abstract/ZAdd.v - theories/Numbers/Integer/Abstract/ZAddOrder.v - theories/Numbers/Integer/Abstract/ZAxioms.v - theories/Numbers/Integer/Abstract/ZBase.v - theories/Numbers/Integer/Abstract/ZLt.v - theories/Numbers/Integer/Abstract/ZMul.v - theories/Numbers/Integer/Abstract/ZMulOrder.v - theories/Numbers/Integer/Abstract/ZSgnAbs.v - theories/Numbers/Integer/Abstract/ZMaxMin.v - theories/Numbers/Integer/Abstract/ZParity.v - theories/Numbers/Integer/Abstract/ZPow.v - theories/Numbers/Integer/Abstract/ZGcd.v - theories/Numbers/Integer/Abstract/ZLcm.v - theories/Numbers/Integer/Abstract/ZBits.v - theories/Numbers/Integer/Abstract/ZProperties.v - theories/Numbers/Integer/Abstract/ZDivFloor.v - theories/Numbers/Integer/Abstract/ZDivTrunc.v -
- -
  Floats: - Floating-point arithmetic -
-
- theories/Floats/FloatLemmas.v - (theories/Floats/Floats.v) -
-
-
- -
Relations: - Relations (definitions and basic results) -
-
- theories/Relations/Relation_Operators.v - theories/Relations/Relations.v - theories/Relations/Operators_Properties.v -
- -
Sets: - Sets (classical, constructive, finite, infinite, powerset, etc.) -
-
- theories/Sets/Classical_sets.v - theories/Sets/Constructive_sets.v - theories/Sets/Cpo.v - theories/Sets/Ensembles.v - theories/Sets/Finite_sets_facts.v - theories/Sets/Finite_sets.v - theories/Sets/Image.v - theories/Sets/Infinite_sets.v - theories/Sets/Integers.v - theories/Sets/Multiset.v - theories/Sets/Partial_Order.v - theories/Sets/Permut.v - theories/Sets/Powerset_Classical_facts.v - theories/Sets/Powerset_facts.v - theories/Sets/Powerset.v - theories/Sets/Relations_1_facts.v - theories/Sets/Relations_1.v - theories/Sets/Relations_2_facts.v - theories/Sets/Relations_2.v - theories/Sets/Relations_3_facts.v - theories/Sets/Relations_3.v - theories/Sets/Uniset.v -
- -
Classes: -
-
- theories/Classes/Morphisms_Relations.v - theories/Classes/CEquivalence.v - theories/Classes/EquivDec.v - theories/Classes/SetoidClass.v - theories/Classes/SetoidDec.v - theories/Classes/RelationPairs.v - theories/Classes/DecidableClass.v -
- -
Lists: - Polymorphic lists, Streams (infinite sequences) -
-
- theories/Lists/List.v - theories/Lists/ListDec.v - theories/Lists/ListSet.v - theories/Lists/SetoidList.v - theories/Lists/SetoidPermutation.v - theories/Lists/Streams.v - theories/Lists/StreamMemo.v - theories/Lists/ListTactics.v -
- -
Vectors: - Dependent datastructures storing their length -
-
- theories/Vectors/Fin.v - theories/Vectors/VectorDef.v - theories/Vectors/VectorSpec.v - theories/Vectors/VectorEq.v - (theories/Vectors/Vector.v) -
- -
Sorting: - Axiomatizations of sorts -
-
- theories/Sorting/Heap.v - theories/Sorting/Permutation.v - theories/Sorting/Sorting.v - theories/Sorting/PermutEq.v - theories/Sorting/PermutSetoid.v - theories/Sorting/Mergesort.v - theories/Sorting/Sorted.v - theories/Sorting/CPermutation.v -
- -
Wellfounded: - Well-founded Relations -
-
- theories/Wellfounded/Disjoint_Union.v - theories/Wellfounded/Inclusion.v - theories/Wellfounded/Inverse_Image.v - theories/Wellfounded/Lexicographic_Exponentiation.v - theories/Wellfounded/Lexicographic_Product.v - theories/Wellfounded/List_Extension.v - theories/Wellfounded/Transitive_Closure.v - theories/Wellfounded/Union.v - theories/Wellfounded/Wellfounded.v - theories/Wellfounded/Well_Ordering.v -
- -
MSets: - Modular implementation of finite sets using lists or - efficient trees. This is a modernization of FSets. -
-
- theories/MSets/MSetInterface.v - theories/MSets/MSetFacts.v - theories/MSets/MSetDecide.v - theories/MSets/MSetProperties.v - theories/MSets/MSetEqProperties.v - theories/MSets/MSetWeakList.v - theories/MSets/MSetList.v - theories/MSets/MSetGenTree.v - theories/MSets/MSetAVL.v - theories/MSets/MSetRBT.v - theories/MSets/MSetPositive.v - theories/MSets/MSetToFiniteSet.v - (theories/MSets/MSets.v) -
- -
FSets: - Modular implementation of finite sets/maps using lists or - efficient trees. For sets, please consider the more - modern MSets. -
-
- theories/FSets/FSetInterface.v - theories/FSets/FSetBridge.v - theories/FSets/FSetFacts.v - theories/FSets/FSetDecide.v - theories/FSets/FSetProperties.v - theories/FSets/FSetEqProperties.v - theories/FSets/FSetList.v - theories/FSets/FSetWeakList.v - theories/FSets/FSetCompat.v - theories/FSets/FSetAVL.v - theories/FSets/FSetPositive.v - (theories/FSets/FSets.v) - theories/FSets/FSetToFiniteSet.v - theories/FSets/FMapInterface.v - theories/FSets/FMapWeakList.v - theories/FSets/FMapList.v - theories/FSets/FMapPositive.v - theories/FSets/FMapFacts.v - (theories/FSets/FMaps.v) - theories/FSets/FMapAVL.v - theories/FSets/FMapFullAVL.v -
- -
Strings - Implementation of string as list of ascii characters -
-
- theories/Strings/Byte.v - theories/Strings/Ascii.v - theories/Strings/String.v - theories/Strings/BinaryString.v - theories/Strings/HexString.v - theories/Strings/OctalString.v -
- -
Reals: - Formalization of real numbers -
-
-
-
Classical Reals: - Real numbers with excluded middle, total order and least upper bounds -
-
- theories/Reals/Rdefinitions.v - theories/Reals/ClassicalDedekindReals.v - theories/Reals/ClassicalConstructiveReals.v - theories/Reals/Raxioms.v - theories/Reals/RIneq.v - theories/Reals/DiscrR.v - theories/Reals/ROrderedType.v - theories/Reals/Rminmax.v - (theories/Reals/Rbase.v) - theories/Reals/RList.v - theories/Reals/Ranalysis.v - theories/Reals/Rbasic_fun.v - theories/Reals/Rderiv.v - theories/Reals/Rfunctions.v - theories/Reals/Rgeom.v - theories/Reals/R_Ifp.v - theories/Reals/Rlimit.v - theories/Reals/Rseries.v - theories/Reals/Rsigma.v - theories/Reals/R_sqr.v - theories/Reals/Rtrigo_fun.v - theories/Reals/Rtrigo1.v - theories/Reals/Rtrigo.v - theories/Reals/Rtrigo_facts.v - theories/Reals/Ratan.v - theories/Reals/Machin.v - theories/Reals/SplitAbsolu.v - theories/Reals/SplitRmult.v - theories/Reals/Alembert.v - theories/Reals/AltSeries.v - theories/Reals/ArithProp.v - theories/Reals/Binomial.v - theories/Reals/Cauchy_prod.v - theories/Reals/Cos_plus.v - theories/Reals/Cos_rel.v - theories/Reals/Exp_prop.v - theories/Reals/Integration.v - theories/Reals/MVT.v - theories/Reals/NewtonInt.v - theories/Reals/PSeries_reg.v - theories/Reals/PartSum.v - theories/Reals/R_sqrt.v - theories/Reals/Ranalysis1.v - theories/Reals/Ranalysis2.v - theories/Reals/Ranalysis3.v - theories/Reals/Ranalysis4.v - theories/Reals/Ranalysis5.v - theories/Reals/Ranalysis_reg.v - theories/Reals/Rcomplete.v - theories/Reals/RiemannInt.v - theories/Reals/RiemannInt_SF.v - theories/Reals/Rpow_def.v - theories/Reals/Rpower.v - theories/Reals/Rprod.v - theories/Reals/Rsqrt_def.v - theories/Reals/Rtopology.v - theories/Reals/Rtrigo_alt.v - theories/Reals/Rtrigo_calc.v - theories/Reals/Rtrigo_def.v - theories/Reals/Rtrigo_reg.v - theories/Reals/SeqProp.v - theories/Reals/SeqSeries.v - theories/Reals/Sqrt_reg.v - theories/Reals/Rlogic.v - theories/Reals/Rregisternames.v - (theories/Reals/Reals.v) - theories/Reals/Runcountable.v -
-
Abstract Constructive Reals: - Interface of constructive reals, proof of equivalence of all implementations. EXPERIMENTAL -
-
- 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/ConstructiveMinMax.v - theories/Reals/Abstract/ConstructivePower.v - theories/Reals/Abstract/ConstructiveSum.v -
-
Constructive Cauchy Reals: - Cauchy sequences of rational numbers, implementation of the interface. EXPERIMENTAL -
-
- theories/Reals/Cauchy/ConstructiveRcomplete.v - theories/Reals/Cauchy/ConstructiveCauchyReals.v - theories/Reals/Cauchy/ConstructiveCauchyRealsMult.v - theories/Reals/Cauchy/ConstructiveCauchyAbs.v -
- -
-
- -
Program: - Support for dependently-typed programming -
-
- theories/Program/Subset.v - theories/Program/Equality.v - theories/Program/Syntax.v - theories/Program/WfExtensionality.v - theories/Program/Program.v - theories/Program/Combinators.v -
- -
Unicode: - Unicode-based notations -
-
- theories/Unicode/Utf8_core.v - theories/Unicode/Utf8.v -
- -
Compat: - Compatibility wrappers for previous versions of Coq -
-
- theories/Compat/AdmitAxiom.v - theories/Compat/Stdlib818.v -
- -
Array: - Persistent native arrays -
-
- theories/Array/PArray.v -
- -
Primitive strings - Native string type -
-
- theories/Strings/PString.v -
-
diff --git a/stdlib/doc/stdlib/make-library-index b/stdlib/doc/stdlib/make-library-index deleted file mode 100755 index c06797a3d0fa..000000000000 --- a/stdlib/doc/stdlib/make-library-index +++ /dev/null @@ -1,52 +0,0 @@ -#!/usr/bin/env bash - -# Instantiate links to library files in index template - -set -e - -FILE=$1 -HIDDEN=$2 -tmp=$(mktemp) -tmp2=$(mktemp) - -cp -f "$FILE.template" "$tmp" -echo -n "Building file index-list.prehtml... " - -LIBDIRS=$(find theories/* -type d ! -name .coq-native) - -for k in $LIBDIRS; do - BASE_PREFIX="Stdlib." - d=$(basename "$k") - for j in "$k"/*.v; do - if ! [ -e "$j" ]; then break; fi - b=$(basename "$j" .v) - - a=0; grep -q "$k/$b.v" "$tmp" || a=$? - h=0; grep -q "$k/$b.v" "$HIDDEN" || h=$? - if [ $a = 0 ]; then - if [ $h = 0 ]; then - echo "Error: $FILE and $HIDDEN both mention $k/$b.v" >&2 - exit 1 - else - p=$(echo "$k" | sed 's:^[^/]*/::' | sed 's:/:.:g') - sed -e "s:$k/$b.v:$b:g" "$tmp" > "$tmp2" - mv -f "$tmp2" "$tmp" - fi - else - if [ $h = 0 ]; then - # Skipping file from the index - : - else - echo "Error: none of $FILE and $HIDDEN mention $k/$b.v" >&2 - exit 1 - fi - - fi - done - sed -e "s/#$d#//" "$tmp" > "$tmp2" - mv -f "$tmp2" "$tmp" -done - -if a=$(grep theories "$tmp"); then echo Error: extra files: >&2; echo "$a" >&2; exit 1; fi -mv "$tmp" "$FILE" -echo Done diff --git a/stdlib/doc/tools/coqrst/__init__.py b/stdlib/doc/tools/coqrst/__init__.py deleted file mode 100644 index 5720cd9be0f4..000000000000 --- a/stdlib/doc/tools/coqrst/__init__.py +++ /dev/null @@ -1,10 +0,0 @@ -########################################################################## -## # The Coq Proof Assistant / The Coq Development Team ## -## v # Copyright INRIA, CNRS and contributors ## -## 0: - deps = " ".join(missing_deps) - eprint('Cannot find package(s) `%s` (needed to build documentation)' % deps) - eprint('You can run `pip3 install %s` to install it/them.' % deps) - sys.exit(1) - -try: - import sphinx_rtd_theme -except: - missing_dep('sphinx_rtd_theme') - -try: - import pexpect -except: - missing_dep('pexpect') - -try: - import antlr4 -except: - missing_dep('antlr4-python3-runtime') - -try: - import bs4 -except: - missing_dep('beautifulsoup4') - -try: - import sphinxcontrib.bibtex -except: - missing_dep('sphinxcontrib-bibtex') - -report_missing_deps() diff --git a/stdlib/doc/tools/coqrst/coqdoc/__init__.py b/stdlib/doc/tools/coqrst/coqdoc/__init__.py deleted file mode 100644 index 3fe688689722..000000000000 --- a/stdlib/doc/tools/coqrst/coqdoc/__init__.py +++ /dev/null @@ -1,10 +0,0 @@ -########################################################################## -## # The Coq Proof Assistant / The Coq Development Team ## -## v # Copyright INRIA, CNRS and contributors ## -## ", "<-", "<->", "=>", "<=", ">=", "<>", "~", "/\\", "\\/", "|-", "*", "forall", "exists"] -COQDOC_HEADER = "".join("(** remove printing {} *)".format(s) for s in COQDOC_SYMBOLS) - -def coqdoc(coq_code, coqdoc_bin=None): - """Get the output of coqdoc on coq_code.""" - coqdoc_bin = coqdoc_bin or os.path.join(os.getenv("COQBIN", ""), "coqdoc") - fd, filename = mkstemp(prefix="coqdoc_", suffix=".v") - if platform.system().startswith("CYGWIN"): - # coqdoc currently doesn't accept cygwin style paths in the form "/cygdrive/c/..." - filename = check_output(["cygpath", "-w", filename]).decode("utf-8").strip() - try: - os.write(fd, COQDOC_HEADER.encode("utf-8")) - os.write(fd, coq_code.encode("utf-8")) - os.close(fd) - return check_output([coqdoc_bin] + COQDOC_OPTIONS + [filename], timeout = 10).decode("utf-8") - finally: - os.remove(filename) - -def first_string_node(node): - """Return the first string node, or None if does not exist""" - while node.children: - node = next(node.children) - if isinstance(node, NavigableString): - return node - -def lex(source): - """Convert source into a stream of (css_classes, token_string).""" - coqdoc_output = coqdoc(source) - soup = BeautifulSoup(coqdoc_output, "html.parser") - root = soup.find(class_='code') - # strip the leading '\n' - first = first_string_node(root) - if first and first.string[0] == '\n': - first.string.replace_with(first.string[1:]) - for elem in root.children: - if isinstance(elem, NavigableString): - yield [], elem - elif elem.name == "span": - if elem.string: - cls = "coqdoc-{}".format(elem.get("title", "comment")) - yield [cls], elem.string - else: - # handle multi-line comments - children = list(elem.children) - mlc = children[0].startswith("(*") and children[-1].endswith ("*)") - for elem2 in children: - if isinstance(elem2, NavigableString): - cls = ["coqdoc-comment"] if mlc else [] - yield cls, elem2 - elif elem2.name == 'br': - pass - elif elem.name == 'br': - pass - else: - raise ValueError(elem) - -def main(): - """Lex stdin (for testing purposes)""" - import sys - for classes, text in lex(sys.stdin.read()): - print(repr(text) + "\t" ' '.join(classes)) - -if __name__ == '__main__': - main() diff --git a/stdlib/doc/tools/coqrst/coqdomain.py b/stdlib/doc/tools/coqrst/coqdomain.py deleted file mode 100644 index 278f5d35a27e..000000000000 --- a/stdlib/doc/tools/coqrst/coqdomain.py +++ /dev/null @@ -1,1492 +0,0 @@ -########################################################################## -## # The Coq Proof Assistant / The Coq Development Team ## -## v # Copyright INRIA, CNRS and contributors ## -## = (4, 5): - from sphinx.writers.latex import CR - - def visit_desc_signature(self, node): - hyper = '' - if node.parent['objtype'] != 'describe' and node['ids']: - for id in node['ids']: - hyper += self.hypertarget(id) - self.body.append(hyper) - if not self.in_desc_signature: - self.in_desc_signature = True - self.body.append(CR + r'\pysigstartsignatures') - if not node.get('is_multiline'): - self._visit_signature_line(node) - else: - self.body.append(CR + r'\pysigstartmultiline') -else: - def visit_desc_signature(self, node): - hyper = '' - if node.parent['objtype'] != 'describe' and node['ids']: - for id in node['ids']: - hyper += self.hypertarget(id) - self.body.append(hyper) - if not node.get('is_multiline'): - self._visit_signature_line(node) - else: - self.body.append('%\n\\pysigstartmultiline\n') -LaTeXTranslator.visit_desc_signature = visit_desc_signature - -PARSE_ERROR = """{}:{} Parse error in notation! -Offending notation: {} -Error message: {}""" - -def notation_to_sphinx(notation, source, line, rawtext=None): - """Parse notation and wrap it in an inline node""" - try: - node = nodes.inline(rawtext or notation, '', *sphinxify(notation), classes=['notation']) - node.source, node.line = source, line - return node - except ParseError as e: - raise ExtensionError(PARSE_ERROR.format(os.path.basename(source), line, notation, e.msg)) from e - -def notation_to_string(notation): - """Parse notation and format it as a string with ellipses.""" - try: - return stringify_with_ellipses(notation) - except ParseError as e: - # FIXME source and line aren't defined below ā€” see cc93f419e0 - raise ExtensionError(PARSE_ERROR.format(os.path.basename(source), line, notation, e.msg)) from e - -def highlight_using_coqdoc(sentence): - """Lex sentence using coqdoc, and yield inline nodes for each token""" - tokens = coqdoc.lex(utils.unescape(sentence, 1)) - for classes, value in tokens: - yield nodes.inline(value, value, classes=classes) - -def make_target(objtype, targetid): - """Create a target to an object of type objtype and id targetid""" - return "coq:{}.{}".format(objtype, targetid) - -def make_math_node(latex, docname, nowrap): - node = nodes.math_block(latex, latex) - node['label'] = None # Otherwise equations are numbered - node['nowrap'] = nowrap - node['docname'] = docname - node['number'] = None - return node - -# To support any character in tacn, ... names. -# see https://github.com/coq/coq/pull/13564 -def make_id(tag): - return tag.replace(" ", "-") - -class CoqObject(ObjectDescription): - """A generic Coq object for Sphinx; all Coq objects are subclasses of this. - - The fields and methods to override are listed at the top of this class' - implementation. Each object supports the :name: option, which gives an - explicit name to link to. - - See the comments and docstrings in CoqObject for more information. - """ - - # The semantic domain in which this object lives (eg. ā€œtacā€, ā€œcmdā€, ā€œchmā€ā€¦). - # It matches exactly one of the roles used for cross-referencing. - subdomain = None # type: str - - # The suffix to use in indices for objects of this type (eg. ā€œ(tac)ā€) - index_suffix = None # type: str - - # The annotation to add to headers of objects of this type - # (eg. ā€œCommandā€, ā€œTheoremā€) - annotation = None # type: str - - def __init__(self, *args, **kwargs): - super().__init__(*args, **kwargs) - self._sig_names = None - - def _name_from_signature(self, signature): # pylint: disable=no-self-use, unused-argument - """Convert a signature into a name to link to. - - ā€˜Signatureā€™ is Sphinx parlance for an object's header (think ā€œtype - signatureā€); for example, the signature of the simplest form of the - ``exact`` tactic is ``exact @id``. - - Generates a name for the directive. Override this method to return None - to avoid generating a name automatically. This is a convenient way - to automatically generate names (link targets) without having to write - explicit names everywhere. - - """ - m = re.match(r"[a-zA-Z0-9_ ]+", signature) - if m: - return m.group(0).strip() - - def _render_signature(self, signature, signode): - """Render a signature, placing resulting nodes into signode.""" - raise NotImplementedError(self) - - option_spec = { - # Explicit object naming - 'name': directives.unchanged, - # Silence warnings produced by report_undocumented_coq_objects - 'undocumented': directives.flag, - # noindex omits this object from its index - 'noindex': directives.flag - } - - def subdomain_data(self): - if self.subdomain is None: - raise ValueError() - return self.env.domaindata['coq']['objects'][self.subdomain] - - def _render_annotation(self, signode): - if self.annotation: - annot_node = nodes.inline(self.annotation, self.annotation, classes=['sigannot']) - signode += addnodes.desc_annotation(self.annotation, '', annot_node) - signode += nodes.Text(' ') - - def handle_signature(self, signature, signode): - """Prefix signature with the proper annotation, then render it using - ``_render_signature`` (for example, add ā€œCommandā€ in front of commands). - - :returns: the names given to the resulting node. - """ - self._render_annotation(signode) - self._render_signature(signature, signode) - names = self._sig_names.get(signature) - if names is None: - name = self._name_from_signature(signature) # pylint: disable=assignment-from-none - # remove trailing ā€˜.ā€™ found in commands, but not ā€˜...ā€™ (ellipsis) - if name is not None and name.endswith(".") and not name.endswith("..."): - name = name[:-1] - names = [name] if name else None - return names - - def _warn_if_duplicate_name(self, objects, name, signode): - """Check that two objects in the same domain don't have the same name.""" - if name in objects: - MSG = 'Duplicate name {} (other is in {}) attached to {}' - msg = MSG.format(name, self.env.doc2path(objects[name][0]), signode) - self.state_machine.reporter.warning(msg, line=self.lineno) - - def _record_name(self, name, target_id, signode): - """Record a `name` in the current subdomain, mapping it to `target_id`. - - Warns if another object of the same name already exists; `signode` is - used in the warning. - """ - names_in_subdomain = self.subdomain_data() - self._warn_if_duplicate_name(names_in_subdomain, name, signode) - names_in_subdomain[name] = (self.env.docname, self.objtype, target_id) - - def _target_id(self, name): - return make_target(self.objtype, make_id(name)) - - def _add_target(self, signode, name): - """Register a link target ā€˜nameā€™, pointing to signode.""" - targetid = self._target_id(name) - if targetid not in self.state.document.ids: - signode['ids'].append(targetid) - signode['names'].append(name) - signode['first'] = (not self.names) - self._record_name(name, targetid, signode) - else: - # We don't warn for duplicates in the SSReflect chapter, because - # it's the style of this chapter to repeat all the defined - # objects at the end. - if self.env.docname != 'proof-engine/ssreflect-proof-language': - self._warn_if_duplicate_name(self.subdomain_data(), name, signode) - return targetid - - def _add_index_entry(self, name, target): - """Add `name` (pointing to `target`) to the main index.""" - assert isinstance(name, str) - # remove trailing . , found in commands, but not ... (ellipsis) - trim = name.endswith(".") and not name.endswith("...") - index_text = name[:-1] if trim else name - if self.index_suffix: - index_text += " " + self.index_suffix - self.indexnode['entries'].append(('single', index_text, target, '', None)) - - def add_target_and_index(self, names, _, signode): - """Attach a link target to `signode` and index entries for `names`. - This is only called (from ``ObjectDescription.run``) if ``:noindex:`` isn't specified.""" - if names: - for name in names: - if isinstance(name, str) and name.startswith('_'): - continue - target = self._add_target(signode, name) - self._add_index_entry(name, target) - self.state.document.note_explicit_target(signode) - - def _prepare_names(self): - """Construct ``self._sig_names``, a map from signatures to names. - - A node may have either one signature with no name, multiple signatures - with one name per signatures, or one signature with multiple names. - """ - sigs = self.get_signatures() - names = self.options.get("name") - if names is None: - self._sig_names = {} - else: - names = [n.strip() for n in names.split(";")] - if len(names) != len(sigs): - if len(sigs) != 1: #Multiple names for one signature - ERR = ("Expected {} semicolon-separated names, got {}. " + - "Please provide one name per signature line.") - raise self.error(ERR.format(len(names), len(sigs))) - self._sig_names = { sigs[0]: names } - else: - self._sig_names = { sig: [name] for (sig, name) in zip(sigs, names) } - - def run(self): - self._prepare_names() - return super().run() - -class DocumentableObject(CoqObject): - - def _warn_if_undocumented(self): - document = self.state.document - config = document.settings.env.config - report = config.report_undocumented_coq_objects - if report and not self.content and "undocumented" not in self.options: - # This is annoyingly convoluted, but we don't want to raise warnings - # or interrupt the generation of the current node. For more details - # see https://github.com/sphinx-doc/sphinx/issues/4976. - msg = 'No contents in directive {}'.format(self.name) - node = document.reporter.info(msg, line=self.lineno) - getLogger(__name__).info(node.astext()) - if report == "warning": - raise self.warning(msg) - - def run(self): - self._warn_if_undocumented() - return super().run() - -class PlainObject(DocumentableObject): - """A base class for objects whose signatures should be rendered literally.""" - def _render_signature(self, signature, signode): - signode += addnodes.desc_name(signature, signature) - -class NotationObject(DocumentableObject): - """A base class for objects whose signatures should be rendered as nested boxes. - - Objects that inherit from this class can use the notation grammar (ā€œ{+ ā€¦}ā€, - ā€œ@ā€¦ā€, etc.) in their signature. - """ - def _render_signature(self, signature, signode): - position = self.state_machine.get_source_and_line(self.lineno) - tacn_node = notation_to_sphinx(signature, *position) - signode += addnodes.desc_name(signature, '', tacn_node) - -class GallinaObject(PlainObject): - r"""A theorem. - - Example:: - - .. thm:: Bound on the ceiling function - - Let :math:`p` be an integer and :math:`c` a rational constant. Then - :math:`p \ge c \rightarrow p \ge \lceil{c}\rceil`. - """ - subdomain = "thm" - index_suffix = "(theorem)" - annotation = "Theorem" - -class VernacObject(NotationObject): - """A Coq command. - - Example:: - - .. cmd:: Infix @string := @one_term {? ( {+, @syntax_modifier } ) } {? : @ident } - - This command is equivalent to :n:`ā€¦`. - """ - subdomain = "cmd" - index_suffix = "(command)" - annotation = "Command" - - def _name_from_signature(self, signature): - m = re.match(r"[a-zA-Z0-9_ ]+", signature) - return m.group(0).strip() if m else None - -class VernacVariantObject(VernacObject): - """A variant of a Coq command. - - Example:: - - .. cmd:: Axiom @ident : @term. - - This command links :token:`term` to the name :token:`term` as its specification in - the global environment. The fact asserted by :token:`term` is thus assumed as a - postulate. - - .. cmdv:: Parameter @ident : @term. - - This is equivalent to :n:`Axiom @ident : @term`. - """ - index_suffix = "(command variant)" - annotation = "Variant" - - def _name_from_signature(self, signature): - return None - -class TacticObject(NotationObject): - """A tactic, or a tactic notation. - - Example:: - - .. tacn:: do @natural @expr - - :token:`expr` is evaluated to ``v`` which must be a tactic value. ā€¦ - """ - subdomain = "tacn" - index_suffix = "(tactic)" - annotation = "Tactic" - -class AttributeObject(NotationObject): - """An attribute. - - Example:: - - .. attr:: local - """ - subdomain = "attr" - index_suffix = "(attribute)" - annotation = "Attribute" - - def _name_from_signature(self, signature): - return notation_to_string(signature) - -class TacticVariantObject(TacticObject): - """A variant of a tactic. - - Example:: - - .. tacn:: fail - - This is the always-failing tactic: it does not solve any goal. It is - useful for defining other tacticals since it can be caught by - :tacn:`try`, :tacn:`repeat`, :tacn:`match goal`, or the branching - tacticals. ā€¦ - - .. tacv:: fail @natural - - The number is the failure level. If no level is specified, it - defaults to 0. ā€¦ - """ - index_suffix = "(tactic variant)" - annotation = "Variant" - - def _name_from_signature(self, signature): - return None - -class OptionObject(NotationObject): - """A Coq option (a setting with non-boolean value, e.g. a string or numeric value). - - Example:: - - .. opt:: Hyps Limit @natural - :name Hyps Limit - - Controls the maximum number of hypotheses displayed in goals after - application of a tactic. - """ - subdomain = "opt" - index_suffix = "(option)" - annotation = "Option" - -class FlagObject(NotationObject): - """A Coq flag (i.e. a boolean setting). - - Example:: - - .. flag:: Nonrecursive Elimination Schemes - - Controls whether types declared with the keywords - :cmd:`Variant` and :cmd:`Record` get an automatic declaration of - induction principles. - """ - subdomain = "flag" - index_suffix = "(flag)" - annotation = "Flag" - -class TableObject(NotationObject): - """A Coq table, i.e. a setting that is a set of values. - - Example:: - - .. table:: Search Blacklist @string - :name: Search Blacklist - - Controls ... - """ - subdomain = "table" - index_suffix = "(table)" - annotation = "Table" - -class ProductionObject(CoqObject): - r"""A grammar production. - - Use ``.. prodn`` to document grammar productions instead of Sphinx - `production lists - `_. - - prodn displays multiple productions together with alignment similar to ``.. productionlist``, - however unlike ``.. productionlist``\ s, this directive accepts notation syntax. - - Example:: - - .. prodn:: occ_switch ::= { {? {| + | - } } {* @natural } } - term += let: @pattern := @term in @term - | second_production - - The first line defines "occ_switch", which must be unique in the document. The second - references and expands the definition of "term", whose main definition is elsewhere - in the document. The third form is for continuing the - definition of a nonterminal when it has multiple productions. It leaves the first - column in the output blank. - - """ - subdomain = "prodn" - #annotation = "Grammar production" - - # handle_signature is called for each line of input in the prodn:: - # 'signatures' accumulates them in order to combine the lines into a single table: - signatures = None # FIXME this should be in init, shouldn't it? - - def _render_signature(self, signature, signode): - raise NotImplementedError(self) - - SIG_ERROR = ("{}: Invalid syntax in ``.. prodn::`` directive" - + "\nExpected ``name ::= ...`` or ``name += ...``" - + " (e.g. ``pattern += constr:(@ident)``)\n" - + " in `{}`") - - def handle_signature(self, signature, signode): - parts = signature.split(maxsplit=1) - if parts[0].strip() == "|" and len(parts) == 2: - lhs = "" - op = "|" - rhs = parts[1].strip() - else: - parts = signature.split(maxsplit=2) - if len(parts) != 3: - loc = os.path.basename(get_node_location(signode)) - raise ExtensionError(ProductionObject.SIG_ERROR.format(loc, signature)) - lhs, op, rhs = (part.strip() for part in parts) - if op not in ["::=", "+="]: - loc = os.path.basename(get_node_location(signode)) - raise ExtensionError(ProductionObject.SIG_ERROR.format(loc, signature)) - - parts = rhs.split(" ", maxsplit=1) - rhs = parts[0].strip() - tag = parts[1].strip() if len(parts) == 2 else "" - - self.signatures.append((lhs, op, rhs, tag)) - return [('token', lhs)] if op == '::=' else None - - def _add_index_entry(self, name, target): - pass - - def _target_id(self, name): - return make_id('grammar-token-{}'.format(name[1])) - - def _record_name(self, name, targetid, signode): - env = self.state.document.settings.env - objects = env.domaindata['std']['objects'] - self._warn_if_duplicate_name(objects, name, signode) - objects[name] = env.docname, targetid - - def run(self): - self.signatures = [] - indexnode = super().run()[0] # makes calls to handle_signature - - table = nodes.inline(classes=['prodn-table']) - tgroup = nodes.inline(classes=['prodn-column-group']) - for _ in range(4): - tgroup += nodes.inline(classes=['prodn-column']) - table += tgroup - tbody = nodes.inline(classes=['prodn-row-group']) - table += tbody - - # create rows - for signature in self.signatures: - lhs, op, rhs, tag = signature - position = self.state_machine.get_source_and_line(self.lineno) - - row = nodes.inline(classes=['prodn-row']) - entry = nodes.inline(classes=['prodn-cell-nonterminal']) - if lhs != "": - target_name = make_id('grammar-token-' + 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']) - inline += target - entry += inline - entry += notation_to_sphinx('@'+lhs, *position) - else: - entry += nodes.literal('', '') - row += entry - - entry = nodes.inline(classes=['prodn-cell-op']) - entry += nodes.literal(op, op) - row += entry - - entry = nodes.inline(classes=['prodn-cell-production']) - entry += notation_to_sphinx(rhs, *position) - row += entry - - entry = nodes.inline(classes=['prodn-cell-tag']) - entry += nodes.literal(tag, tag) - row += entry - - tbody += row - - return [indexnode, table] # only this node goes into the doc - -class ExceptionObject(NotationObject): - """An error raised by a Coq command or tactic. - - This commonly appears nested in the ``.. tacn::`` that raises the - exception. - - Example:: - - .. tacv:: assert @form by @tactic - - This tactic applies :n:`@tactic` to solve the subgoals generated by - ``assert``. - - .. exn:: Proof is not complete - - Raised if :n:`@tactic` does not fully solve the goal. - """ - subdomain = "exn" - index_suffix = "(error)" - annotation = "Error" - # Uses ā€œexnā€ since ā€œerrā€ already is a CSS class added by ā€œwriter_auxā€. - - # Generate names automatically - def _name_from_signature(self, signature): - return notation_to_string(signature) - -class WarningObject(NotationObject): - """An warning raised by a Coq command or tactic.. - - Do not mistake this for ``.. warning::``; this directive is for warning - messages produced by Coq. - - - Example:: - - .. warn:: Ambiguous path - - When the coercion :token:`qualid` is added to the inheritance graph, non - valid coercion paths are ignored. - """ - subdomain = "warn" - index_suffix = "(warning)" - annotation = "Warning" - - # Generate names automatically - def _name_from_signature(self, signature): - return notation_to_string(signature) - -def NotationRole(role, rawtext, text, lineno, inliner, options={}, content=[]): - #pylint: disable=unused-argument, dangerous-default-value - """Any text using the notation syntax (``@id``, ``{+, ā€¦}``, etc.). - - Use this to explain tactic equivalences. For example, you might write - this:: - - :n:`generalize @term as @ident` is just like :n:`generalize @term`, but - it names the introduced hypothesis :token:`ident`. - - Note that this example also uses ``:token:``. That's because ``ident`` is - defined in the Coq manual as a grammar production, and ``:token:`` - creates a link to that. When referring to a placeholder that happens to be - a grammar production, ``:token:`ā€¦``` is typically preferable to ``:n:`@ā€¦```. - """ - notation = utils.unescape(text, 1) - position = inliner.reporter.get_source_and_line(lineno) - return [nodes.literal(rawtext, '', notation_to_sphinx(notation, *position, rawtext=rawtext))], [] - -def coq_code_role(role, rawtext, text, lineno, inliner, options={}, content=[]): - #pylint: disable=dangerous-default-value - """Coq code. - - Use this for Gallina and Ltac snippets:: - - :g:`apply plus_comm; reflexivity` - :g:`Set Printing All.` - :g:`forall (x: t), P(x)` - """ - options['language'] = 'Coq' - return code_role(role, rawtext, text, lineno, inliner, options, content) - ## Too heavy: - ## Forked from code_role to use our custom tokenizer; this doesn't work for - ## snippets though: for example CoqDoc swallows the parentheses around this: - ## ā€œ(a: A) (b: B)ā€ - # set_classes(options) - # classes = ['code', 'coq'] - # code = utils.unescape(text, 1) - # node = nodes.literal(rawtext, '', *highlight_using_coqdoc(code), classes=classes) - # return [node], [] - -CoqCodeRole = coq_code_role - -class CoqtopDirective(Directive): - r"""A reST directive to describe interactions with Coqtop. - - Usage:: - - .. rocqtop:: optionsā€¦ - - Coq code to send to coqtop - - Example:: - - .. rocqtop:: in reset - - Print nat. - Definition a := 1. - - The blank line after the directive is required. If you begin a proof, - use the ``abort`` option to reset coqtop for the next example. - - Here is a list of permissible options: - - - Display options (choose exactly one) - - - ``all``: Display input and output - - ``in``: Display only input - - ``out``: Display only output - - ``none``: Display neither (useful for setup commands) - - - Behavior options - - - ``reset``: Send a ``Reset Initial`` command before running this block - - ``fail``: Don't die if a command fails, implies ``warn`` (so no need to put both) - - ``warn``: Don't die if a command emits a warning - - ``restart``: Send a ``Restart`` command before running this block (only works in proof mode) - - ``abort``: Send an ``Abort All`` command after running this block (leaves all pending proofs if any) - - ``coqtop``\ 's state is preserved across consecutive ``.. rocqtop::`` blocks - of the same document (``coqrst`` creates a single ``coqtop`` process per - reST source file). Use the ``reset`` option to reset Coq's state. - """ - has_content = True - required_arguments = 1 - optional_arguments = 0 - final_argument_whitespace = True - option_spec = { 'name': directives.unchanged } - directive_name = "rocqtop" - - def run(self): - # Uses a ā€˜containerā€™ instead of a ā€˜literal_blockā€™ to disable - # Pygments-based post-processing (we could also set rawsource to '') - content = '\n'.join(self.content) - args = self.arguments[0].split() - node = nodes.container(content, coqtop_options = set(args), - classes=['coqtop', 'literal-block']) - self.add_name(node) - return [node] - -class CoqdocDirective(Directive): - """A reST directive to display Coqtop-formatted source code. - - Usage:: - - .. rocqdoc:: - - Coq code to highlight - - Example:: - - .. rocqdoc:: - - Definition test := 1. - """ - # TODO implement this as a Pygments highlighter? - has_content = True - required_arguments = 0 - optional_arguments = 0 - final_argument_whitespace = True - option_spec = { 'name': directives.unchanged } - directive_name = "rocqdoc" - - def run(self): - # Uses a ā€˜containerā€™ instead of a ā€˜literal_blockā€™ to disable - # Pygments-based post-processing (we could also set rawsource to '') - content = '\n'.join(self.content) - node = nodes.inline(content, '', *highlight_using_coqdoc(content)) - wrapper = nodes.container(content, node, classes=['coqdoc', 'literal-block']) - self.add_name(wrapper) - return [wrapper] - -class ExampleDirective(BaseAdmonition): - """A reST directive for examples. - - This behaves like a generic admonition; see - http://docutils.sourceforge.net/docs/ref/rst/directives.html#generic-admonition - for more details. - - Optionally, any text immediately following the ``.. example::`` header is - used as the example's title. - - Example:: - - .. example:: Adding a hint to a database - - The following adds ``plus_comm`` to the ``plu`` database: - - .. rocqdoc:: - - Hint Resolve plus_comm : plu. - """ - node_class = nodes.admonition - directive_name = "example" - optional_arguments = 1 - - def run(self): - # ā€˜BaseAdmonitionā€™ checks whether ā€˜node_classā€™ is ā€˜nodes.admonitionā€™, - # and uses arguments[0] as the title in that case (in other cases, the - # title is unset, and it is instead set in the HTML visitor). - assert len(self.arguments) <= 1 - self.arguments = [": ".join(['Example'] + self.arguments)] - self.options['classes'] = ['admonition', 'note'] - return super().run() - -class PreambleDirective(Directive): - r"""A reST directive to include a TeX file. - - Mostly useful to let MathJax know about `\def`\s and `\newcommand`\s. The - contents of the TeX file are wrapped in a math environment, as MathJax - doesn't process LaTeX definitions otherwise. - - Usage:: - - .. preamble:: preamble.tex - """ - has_content = False - required_arguments = 1 - optional_arguments = 0 - final_argument_whitespace = True - option_spec = {} - directive_name = "preamble" - - def run(self): - document = self.state.document - env = document.settings.env - - if not document.settings.file_insertion_enabled: - msg = 'File insertion disabled' - return [document.reporter.warning(msg, line=self.lineno)] - - rel_fname, abs_fname = env.relfn2path(self.arguments[0]) - env.note_dependency(rel_fname) - - with open(abs_fname, encoding="utf-8") as ltx: - latex = ltx.read() - - node = make_math_node(latex, env.docname, nowrap=False) - node['classes'] = ["math-preamble"] - set_source_info(self, node) - return [node] - -class InferenceDirective(Directive): - r"""A reST directive to format inference rules. - - This also serves as a small illustration of the way to create new Sphinx - directives. - - Usage:: - - .. inference:: name - - newline-separated premises - -------------------------- - conclusion - - Example:: - - .. inference:: Prod-Pro - - \WTEG{T}{s} - s \in \Sort - \WTE{\Gamma::(x:T)}{U}{\Prop} - ----------------------------- - \WTEG{\forall~x:T,U}{\Prop} - """ - required_arguments = 1 - optional_arguments = 0 - has_content = True - final_argument_whitespace = True - directive_name = "inference" - - @staticmethod - def prepare_latex_operand(op): - # TODO: Could use a fancier inference class in LaTeX - return '%\n\\hspace{3em}%\n'.join(op.strip().splitlines()) - - def prepare_latex(self, content): - parts = re.split('^ *----+ *$', content, flags=re.MULTILINE) - if len(parts) != 2: - raise self.error('Expected two parts in ā€˜inferenceā€™ directive, separated by a rule (----).') - - top, bottom = tuple(InferenceDirective.prepare_latex_operand(p) for p in parts) - return "%\n".join(("\\frac{", top, "}{", bottom, "}")) - - def run(self): - self.assert_has_content() - - title = self.arguments[0] - content = '\n'.join(self.content) - latex = self.prepare_latex(content) - docname = self.state.document.settings.env.docname - math_node = make_math_node(latex, docname, nowrap=False) - - tid = make_id(title) - target = nodes.target('', '', ids=['inference-' + tid]) - self.state.document.note_explicit_target(target) - - term, desc = nodes.term('', title), nodes.description('', math_node) - dli = nodes.definition_list_item('', term, desc) - dl = nodes.definition_list(content, target, dli) - set_source_info(self, dl) - return [dl] - -class AnsiColorsParser(): - """Parse ANSI-colored output from Coqtop into Sphinx nodes.""" - - # Coqtop's output crashes ansi.py, because it contains a bunch of extended codes - # This class is a fork of the original ansi.py, released under a BSD license in sphinx-contribs - - COLOR_PATTERN = re.compile('\x1b\\[([^m]+)m') - - def __init__(self): - self.new_nodes, self.pending_nodes = [], [] - - def _finalize_pending_nodes(self): - self.new_nodes.extend(self.pending_nodes) - self.pending_nodes = [] - - def _add_text(self, raw, beg, end): - if beg < end: - text = raw[beg:end] - if self.pending_nodes: - self.pending_nodes[-1].append(nodes.Text(text)) - else: - self.new_nodes.append(nodes.inline('', text)) - - def colorize_str(self, raw): - """Parse raw (an ANSI-colored output string from Coqtop) into Sphinx nodes.""" - last_end = 0 - for match in AnsiColorsParser.COLOR_PATTERN.finditer(raw): - self._add_text(raw, last_end, match.start()) - last_end = match.end() - classes = ansicolors.parse_ansi(match.group(1)) - if 'ansi-reset' in classes: - self._finalize_pending_nodes() - else: - node = nodes.inline() - self.pending_nodes.append(node) - node['classes'].extend(classes) - self._add_text(raw, last_end, len(raw)) - self._finalize_pending_nodes() - return self.new_nodes - -class CoqtopBlocksTransform(Transform): - """Filter handling the actual work for the coqtop directive - - Adds coqtop's responses, colorizes input and output, and merges consecutive - coqtop directives for better visual rendition. - """ - default_priority = 10 - - @staticmethod - def is_coqtop_block(node): - return isinstance(node, nodes.Element) and 'coqtop_options' in node - - @staticmethod - def is_coqtop_args_field(node): - return isinstance(node, nodes.field) and node.children[0].rawsource == 'COQTOP_ARGS' - - @staticmethod - def split_lines(source): - r"""Split Coq input into chunks, which may include single- or - multi-line comments. Nested comments are not supported. - - A chunk is a minimal sequence of consecutive lines of the input that - ends with a '.' or '*)' - - >>> split_lines('A.\nB.''') - ['A.', 'B.'] - - >>> split_lines('A.\n\nB.''') - ['A.', '\nB.'] - - >>> split_lines('A.\n\nB.\n''') - ['A.', '\nB.'] - - >>> split_lines("SearchPattern (_ + _ = _ + _).\n" - ... "SearchPattern (nat -> bool).\n" - ... "SearchPattern (forall l : list _, _ l l).") - ... # doctest: +NORMALIZE_WHITESPACE - ['SearchPattern (_ + _ = _ + _).', - 'SearchPattern (nat -> bool).', - 'SearchPattern (forall l : list _, _ l l).'] - - >>> split_lines('SearchHead le.\nSearchHead (@eq bool).') - ['SearchHead le.', 'SearchHead (@eq bool).'] - - >>> split_lines("(* *) x. (* *)\ny.\n") - ['(* *) x. (* *)', 'y.'] - - >>> split_lines("(* *) x (* \n *)\ny.\n") - ['(* *) x (* \n *)', 'y.'] - """ - return re.split(r"(?:(?<=(?` to display "text" - for the definition of "term", such as when "term" must be capitalized or plural - for grammatical reasons. The term will also appear in the Glossary Index. - - Examples:: - - A :gdef:`prime` number is divisible only by itself and 1. - :gdef:`Composite ` numbers are the non-prime numbers. - """ - #pylint: disable=dangerous-default-value, unused-argument - env = inliner.document.settings.env - std = env.domaindata['std']['objects'] - m = ReferenceRole.explicit_title_re.match(text) - if m: - (text, term) = m.groups() - text = text.strip() - else: - term = text - key = ('term', term) - - if key in std: - MSG = 'Duplicate object: {}; other is at {}' - msg = MSG.format(term, env.doc2path(std[key][0])) - inliner.document.reporter.warning(msg, line=lineno) - - targetid = make_id('term-{}'.format(term)) - std[key] = (env.docname, targetid) - target = nodes.target('', '', ids=[targetid], names=[term]) - inliner.document.note_explicit_target(target) - node = nodes.inline(rawtext, '', target, nodes.Text(text), classes=['term-defn']) - set_role_source_info(inliner, lineno, node) - return [node], [] - -GlossaryDefRole.role_name = "gdef" - -class CoqDomain(Domain): - """A domain to document Coq code. - - Sphinx has a notion of ā€œdomainsā€, used to tailor it to a specific language. - Domains mostly consist in descriptions of the objects that we wish to - describe (for Coq, this includes tactics, tactic notations, options, - exceptions, etc.), as well as domain-specific roles and directives. - - Each domain is responsible for tracking its objects, and resolving - references to them. In the case of Coq, this leads us to define Coq - ā€œsubdomainsā€, which classify objects into categories in which names must be - unique. For example, a tactic and a theorem may share a name, but two - tactics cannot be named the same. - """ - - name = 'coq' - label = 'Coq' - - object_types = { - # ObjType (= directive type) ā†’ (Local name, *xref-roles) - 'cmd': ObjType('cmd', 'cmd'), - 'cmdv': ObjType('cmdv', 'cmd'), - 'tacn': ObjType('tacn', 'tacn'), - 'tacv': ObjType('tacv', 'tacn'), - 'opt': ObjType('opt', 'opt'), - 'flag': ObjType('flag', 'flag'), - 'table': ObjType('table', 'table'), - 'attr': ObjType('attr', 'attr'), - 'thm': ObjType('thm', 'thm'), - 'prodn': ObjType('prodn', 'prodn'), - 'exn': ObjType('exn', 'exn'), - 'warn': ObjType('warn', 'exn'), - 'index': ObjType('index', 'index', searchprio=-1) - } - - directives = { - # Note that some directives live in the same semantic subdomain; ie - # there's one directive per object type, but some object types map to - # the same role. - 'cmd': VernacObject, - 'cmdv': VernacVariantObject, - 'tacn': TacticObject, - 'tacv': TacticVariantObject, - 'opt': OptionObject, - 'flag': FlagObject, - 'table': TableObject, - 'attr': AttributeObject, - 'thm': GallinaObject, - 'prodn' : ProductionObject, - 'exn': ExceptionObject, - 'warn': WarningObject, - } - - roles = { - # Each of these roles lives in a different semantic ā€œsubdomainā€ - 'cmd': XRefRole(warn_dangling=True), - 'tacn': XRefRole(warn_dangling=True), - 'opt': XRefRole(warn_dangling=True), - 'flag': XRefRole(warn_dangling=True), - 'table': XRefRole(warn_dangling=True), - 'attr': XRefRole(warn_dangling=True), - 'thm': XRefRole(warn_dangling=True), - 'prodn' : XRefRole(warn_dangling=True), - 'exn': XRefRole(warn_dangling=True), - 'warn': XRefRole(warn_dangling=True), - # This one is special - 'index': IndexXRefRole(), - # These are used for highlighting - 'n': NotationRole, - 'g': CoqCodeRole - } - - indices = [CoqVernacIndex, CoqTacticIndex, CoqOptionIndex, CoqGallinaIndex, CoqExceptionIndex, CoqAttributeIndex] - - data_version = 1 - initial_data = { - # Collect everything under a key that we control, since Sphinx adds - # others, such as ā€œversionā€ - 'objects' : { # subdomain ā†’ name ā†’ docname, objtype, targetid - 'cmd': {}, - 'tacn': {}, - 'opt': {}, - 'flag': {}, - 'table': {}, - 'attr': {}, - 'thm': {}, - 'prodn' : {}, - 'exn': {}, - 'warn': {}, - } - } - - @staticmethod - def find_index_by_name(targetid): - for index in CoqDomain.indices: - if index.name == targetid: - return index - return None - - def get_objects(self): - # Used for searching and object inventories (intersphinx) - for _, objects in self.data['objects'].items(): - for name, (docname, objtype, targetid) in objects.items(): - yield (name, name, objtype, docname, targetid, self.object_types[objtype].attrs['searchprio']) - for index in self.indices: - yield (index.name, index.localname, 'index', "coq-" + index.name, '', -1) - - def merge_domaindata(self, docnames, otherdata): - DUP = "Duplicate declaration: '{}' also defined in '{}'.\n" - for subdomain, their_objects in otherdata['objects'].items(): - our_objects = self.data['objects'][subdomain] - for name, (docname, objtype, targetid) in their_objects.items(): - if docname in docnames: - if name in our_objects: - self.env.warn(docname, DUP.format(name, our_objects[name][0])) - our_objects[name] = (docname, objtype, targetid) - - def resolve_xref(self, env, fromdocname, builder, role, targetname, node, contnode): - # ā€˜targetā€™ is the name that was written in the document - # ā€˜roleā€™ is where this xref comes from; it's exactly one of our subdomains - if role == 'index': - index = CoqDomain.find_index_by_name(targetname) - if index: - return make_refnode(builder, fromdocname, "coq-" + index.name, '', contnode, index.localname) - else: - resolved = self.data['objects'][role].get(targetname) - if resolved: - (todocname, _, targetid) = resolved - return make_refnode(builder, fromdocname, todocname, targetid, contnode, targetname) - return None - - def clear_doc(self, docname_to_clear): - for subdomain_objects in self.data['objects'].values(): - for name, (docname, _, _) in list(subdomain_objects.items()): - if docname == docname_to_clear: - del subdomain_objects[name] - -def is_coqtop_or_coqdoc_block(node): - return (isinstance(node, nodes.Element) and - ('coqtop' in node['classes'] or 'coqdoc' in node['classes'])) - -def simplify_source_code_blocks_for_latex(app, doctree, fromdocname): # pylint: disable=unused-argument - """Simplify coqdoc and coqtop blocks. - - In HTML mode, this does nothing; in other formats, such as LaTeX, it - replaces coqdoc and coqtop blocks by plain text sources, which will use - pygments if available. This prevents the LaTeX builder from getting - confused. - """ - is_html = app.builder.tags.has("html") - for node in doctree.traverse(is_coqtop_or_coqdoc_block): - if is_html: - node.rawsource = '' # Prevent pygments from kicking in - elif 'coqtop-hidden' in node['classes']: - node.parent.remove(node) - else: - node.replace_self(nodes.literal_block(node.rawsource, node.rawsource, language="Coq")) - -COQ_ADDITIONAL_DIRECTIVES = [CoqtopDirective, - CoqdocDirective, - ExampleDirective, - InferenceDirective, - PreambleDirective] - -COQ_ADDITIONAL_ROLES = [GrammarProductionRole, - GlossaryDefRole] - -def setup(app): - """Register the Coq domain""" - - # A few sanity checks: - subdomains = set(obj.subdomain for obj in CoqDomain.directives.values()) - found = set (obj for obj in chain(*(idx.subdomains for idx in CoqDomain.indices))) - assert subdomains.issuperset(found), "Missing subdomains: {}".format(found.difference(subdomains)) - - assert subdomains.issubset(CoqDomain.roles.keys()), \ - "Missing from CoqDomain.roles: {}".format(subdomains.difference(CoqDomain.roles.keys())) - - # Add domain, directives, and roles - app.add_domain(CoqDomain) - app.add_index_to_domain('std', StdGlossaryIndex) - - for role in COQ_ADDITIONAL_ROLES: - app.add_role(role.role_name, role) - - for directive in COQ_ADDITIONAL_DIRECTIVES: - app.add_directive(directive.directive_name, directive) - - app.add_transform(CoqtopBlocksTransform) - app.connect('doctree-resolved', simplify_source_code_blocks_for_latex) - app.connect('doctree-resolved', CoqtopBlocksTransform.merge_consecutive_coqtop_blocks) - - # Add extra styles - app.add_css_file("ansi.css") - app.add_css_file("coqdoc.css") - app.add_js_file("notations.js") - app.add_css_file("notations.css") - app.add_css_file("pre-text.css") - - # Tell Sphinx about extra settings - app.add_config_value("report_undocumented_coq_objects", None, 'env') - - # ``env_version`` is used by Sphinx to know when to invalidate - # coqdomain-specific bits in its caches. It should be incremented when the - # contents of ``env.domaindata['coq']`` change. See - # `https://github.com/sphinx-doc/sphinx/issues/4460`. - meta = { "version": "0.1", - "env_version": 2, - "parallel_read_safe": True } - return meta diff --git a/stdlib/doc/tools/coqrst/notations/CoqNotations.ttf b/stdlib/doc/tools/coqrst/notations/CoqNotations.ttf deleted file mode 100644 index da8f2850dfa1d6e907230aeecc73dfd90f0e336e..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 37988 zcmd4433wFOnJ#=zRj<`sb$9i?Rqw6d)h)FaBy}N#kc9w=#R!Z*fDqWmATV)^5jJ*+ z7vk8yjwgR6lh`=%#JRq?j=T|*#UYN(WU(DPvALckaJd;zc9OaCC%H3DknVe`CBV+i zow?8R&-47<>N-`YwsXGo?caBf2qlC#u+b2?zkltD1AqP9zaZqH0n`SU^)2nEt@I5- z{?pw!&Mq5XwWjs8l`}YRz_GGy&AQ%K`u!Zom+35nwuj$o_7TI z8+PtKIJvQ4#Pe+j2)RYGYsc0J^4Twa7x(6IzP1Y${10de#}hbC?7HE=%?_h!E82qg z(c`=KZr}Q`FW=-K#PT+dKY7E}o2PU?;WXI48`sNww%)Mg(HC03LdZQg!dkMEhg8auzk`SYCAcv9n}y49#PuaI$qx8uVRk(9^= zwBm7kqgun$-*I1MXSuI($53-`qoij^g}jSelflUAIG)p-C*0gHk*`tj!lrNWip4}m zYhK`=j8fNs$8TZ^AZ%?^4`pBsH9^kvhHs)YnKB+hxRq>sdYfWr&ZY zi3N2gY>RkyGr0jhH;_+|Jn6wNNFpRbqIgCE=h!xcE&D|Pof?i85i9PN@Lhu1ui@uH zj~>Ui!HVDQ2)Wa zv3MexN@tp~xqP8mDmPcEEv>b-_Kwa)UEMu(WpVEkaFt~PR}C&7TCsA~@W|>lYu8=9 zessgeYc`E--ZH**;Z6T~xqo8Ewd7_pbv?Q1I(8N4W9J9e%Xd$+V*4Jpz2Pv~#>zkc z9Q^YtRO0Y3kM9~daGuoY`vmld`3o9|9h{Q zk=cD)aq2x+D!6j;eOD@tE0s%EQc>!nM=2i#{t=;@ulPQe>d&& z&K%h$7xEZc^)ET2N#eXb!>7i#ZQsSptvimz`_MzclB^w_QTni>Y@G+@(x=KLT)%Z3 zow$~PVPtfs6rY-r;=K)MqXG{}F1>cmsCrAIcIk|?WCp@`{;rwQQrrs^S$d2O3~L~J zR(xdiB&p7wf2u_eJX0ktWCLr*jC%P57({vuM!v_PX-i5xs@9Kq%(d`+1(jbp=0e%A;EmX+;*u;Cga6+8XH4fQ`_IAmm zG(Z+E!&~OBV0-U*4i5O_k^$U|61OfH2tgWH^q(GwsXvU1;Qkyhrg!Xcq8t?g6 zo7T9RHK<8mx})!k2EON^I8Yln|FnO(og9P3JTTA%0~^i()`vo#!@i8uh8Yh1RIAu1 zdgU21ERV)_#5cr&L(1?d8yp5}b$pkvi7y}7II52JJeI6|&r#!i`=xX9do$b;AYgw^ z9aJ`^>hUu5_|oCP`%YiAa9TcQh%aArjJ-KN|3D%iyK062WfhQXyQ8J?LfQ{b8Smd3 zmqoe%*w*Lgj%+*jl%gD)S~|X~6LfGae$~XW_?po!45mu>hXc2;*E`5^x_oVKArI!$ z`&69XJ@S-7?_RTU^rT3LeD~VXr#RZX0at>t0RZ5FOXUd$oaqg_j*V|%s7>4eB>w0O zjrWilF5dGL<#gs5A-m^>tQXZ`A8py*}PML*2AMl;bz;X^MPc??mLl{)x!` zB~6ii*q_=n5!u@ti0r}d+O18IojWEXJ8*8I*BaTrbt1AA^&3W-BBQ;o$oh2?k##t? z7W->PCL*hGZUn!fzNX0Fz(iyK=lc65B7LY^ve+Ie_11g2Pk$;Kv1HBbv{}tM@+t9C zoGoizXUYoe^jY0HnkDOuS;IO$%RzoUPsuZGs-@4<2bMo?Agh2Kzp?A+D*RZWJ zvT;Ut_Y7IL@tV=6D7|mPhd=sJ(i>Vn6IwGmb3C+R`OFdQkkC_Z(z_v-BRTbR09z=e zIohZ}F@K8fv1=~ZcnLQ{wA}T?%6^2*{T{#nm!5%!g>vqixr-b$YiOkZk)LTYO(yXh zCWrBwNtD;4goQHyIRq{0FtoTy9AA&}{hvdqI1FvBasJA)hsb?6^EsSZi#tCD-IskP z$usy4lVNB95XPjFbiy{7AX|84?vc4$p-`RX_CsI)Bd%RXvU6|Gt>^BVi;{bx&)>y; zmMo(@zBkjo+#&8c?g`pKucLoKHj+);3C_V4$^N+?a4&E6#zdM|yKdx5`$|1$p*jaly-6r>)Wc`+0}#xYIf9d|UEMyQPmyUzXl+nO!MYm+J|);J(`ZtS9K1^1SYq zyt}D~2&j^_(oAOQH zN9QZq&*u`k&fMnQbne02lezEY-p>6r-=81NPv&pVKau}Q{&xkb5G#}my@l%vcNRWV z_+`;t+*o|9_*%(P+EjYF%$2?6mhy1<;qpH;U)}slC0x0;a-#A|HCDZ;`u&z-%dwW9 zwr*^Fr6$(a)*i0?ysgqU-FB{BY5!b@x#Q-JcRGhVzq&|S^imhsRqUGXda=8qRf9{B z2k8oE@On~wijq>-(|XNUE>xbD6Csn;*QM#VE1-n`IU zrjnJ@$BTS7tvV%LJeF#0sZ}d(x|rAMHIrJsj=#@bmE|h?(FYTqEiJO#($blD?Bb6z zd8oa4nBN@i!yD)$^e(&)wwz+8dn~p+N`P_?1da!00({{4xl@YSXd4Iw11{@vo#i;G zzg&O0ghu4Xw(Prjjy1$}sU`8tyYvyQQP2)(1*5K4Ycy$>u|0Zc+27gI<@a~>ba~5H z?z6Ty=3b(I$Cc5N2)*tkiOijPMkFhOXu_9lA{kocp)Tw{V*M$hvkqM;fc2V1UQ ze|4-s8pzU?yRR{?1Ff~j$-WGDe=v*u?u78#!iVp9%Cm^-3&{g zarLqJ9}0D!ZJcdYeU<%OarGB(i|g@gt>Wjw=2&PlJRF(~^{jU7yanZOa5B`j$~E!a zu(XPPf_*0UOnwp{6mRZ<=^2~bOMk$9n6#0)5{(Gk%N?oh65sCkldU!1)_`qiF6Yzl zB(=NZJADC>)X!ePpS?r8KuZ@&7b+$3%$W<~xeG5fmpw(AZVS_DrPkU~t`ecksxAMZPCu}tZy{;)H7xcQWme#uF{ z*G!$w&Ssv2XQp27=qQ!O#>Pb8%vhcM{W|uCCUWuKy%it#-TBD$P!HRcl>cwQAP` zlEvz9SS?Z)cl~U9Xw|AA_RA&`*=#IEZ&53ThljH9II95kU2`YtPq;?tog9Djz7YvmwShLLCK*Mo2A*#SX@o z)VsET+fVq(!6h|zMFIEAwQ_B^#@8lFA{Fc9Rpl*ZzI;&VwS)>C_*Ux&TzvI_R#ZWJ zp?*PyAvTO-kG%<9;ISuk5Ek2@!6z~xN| zF9f?n?m#^2DNZ^>Ip&jm;hvy391a$HV&&1WJdnwBWh6(e7AtR(y%m2;zqNfl73+^p zCwgTuE5|Ahdb7Leb%28hV~|%AUd0L8O&@^#=srRAthP`Ja34|3{?Gui(DRmmuyCy6 z8LNAMjl-9WmH~@Z50_m1WhO&%WBYPj_Ptk#(C$l;gFeuUF7){QJw2WNUiQAtbG`IY z?rA2k6tju9ktscx?Jcii1EzV8o*o@*ak ze*T_gKU+T3{#8709iI1zh3Da6HWP0Z9K7ZjlXFx&T>&F%E+<=3j1RHFNcT{h+J^_; zaVs8p!yl%tIp%EjVgK0@{2oPXlY7MtF=*{Syhf`TQU zh?&C4uqhl42^vV|13IHgBZMPib0`ru#}aXiDH!zPdWYU-HGRt*i-iSmuV3(bB?G6^ z2zvyLC`kshoQRoa88^sgog|4GValM~qCi1@f}yt4fXjn3?LYFgxUrM(>Q@5<}h^Y@Xj(GSr!a5V8b%4>M~XoE6d zZ7w^buIN7MnEef{A+mvMA0>~{wR8<6&z6(KHh2CRU=dW7^GZZ?4(zZ|LAKh+kRano zC*z!s?Oms%6xXn8S*h6AwUpY)Ee6qYh-bY3*<5_BxeVsc_&eJq8E0p#h%q5IU0aJg zWS`CElO6HeAM-`CC+c=Z-R5FrY)f;4^kwb|^r4`*U^DR?Pi~@|1ce2Iz>Aa-CoPHJ zC*QbBn-kggu*jr4B*_<#Q17iL_;KbHk3+V;0oiIoEFn(TDJ{PZ&xN@+!t_*_-XDG> z%!MbsUL7%;CrHvUp-Vg!rN^T*3UxIQaM^YkwXPk!g^db0ZwZ4vrt*Uy{-VUl=mO*& zMqcgNysE6fLUN_ARH5J4bM3WzrgmPtXKyRmY^_plEl0fmaMNKVx!+KJCp^{FYeQMTObjJWX~i?noBnAtlnCxwa+MUz6#ba#wqc7ZjhcP6}aN zWo>^?dy7An4aTm{X54wOXSAycWB5&sVVN8`NeZB2NaH-CXOv7;VWp~qqhy*hJ2o-; z&SEDdTY$h#p6#i;Xx>ipG+zm8n^~Wlnru59j;K~=+zHlSzfh@TL{)ZpfpzjUbe4;+ ziEm!0E-1RdV-GO+lJ=O&QH*5|P?|~0g%ttyfoerHal}*x8hb zFZJaE8`@h|RJ_@Exi#3i@hZJw*6tMCwM=t*(%=YtVrh?kqa*1rDamA?Lt0tO4YY;; z3fMCN;KPrA4?0A%%8JKiG;DQQby}NS)ERal;APTV%zB0nK+lez?JK&J;%V7#on zzUl-zFvb*Z1#ZxgBbAIDT9ZqK`wKJ(P?F=o@IgAFV5f>o#$C$y;hOuSpQ5bwn9qhEKL$OAK z=)uiA0BaBZpUw<46@wJ_yTVRmHc?w%c6rK!)m=BVZacPCpBYk0CTHTe2EEZCgj%yc zDV(sEs*`eUAd?vEN#B0Y#$%hy*HUY=C2e4lJxZD})-PkMt)%G$*=jXz*Q(OZf`;pD z#vR%n1`T{>jPhA~&#H#A2ZI`Ijk?gJqkN*;6`1`KeJG%GSNb{;=D{GSRq=COl>yG*lWFf`ziIdIIDog%SvVplQ?C@j$&i`G0IosPK_9z(6P&K zKP#1#U>VSLv?8KU32coCcWPo7N^^UKck=OgQ+{Va+qBcv7({zVi7`W19j`+%M#1#L z3l7z29czdrRamRSi3upG>ck7Ec%{DV=9!szNk3-h;k=4WU&t2lp6cqZ(u%flzLb|; z#i8~M*KW5(TN1%=N4n6uRc3-Y-KUrQ<1${B~@N6hx=0D-j>+t>=7yK z^;^B|{!BJcA4nu(d9SB2zgJoR+<1uj1vs zxdk*f1C6!w;z~thV6gbZF~Hy#CD4DR*2a{3&|l07Gr-N**}OnjyPn1cI;wSMfyqW! z-0zM!jrl}vsOVY1w+uTFvmS{xsDY3=9adboUK6?EZ`jqYT*rJ@$T3q@F|-8%K3oBd>?Xso~d=&yxDZGmOAbiRUV(Dh(Bm zN!$#5Y<83SyKiz61UN`2ZCg>1V3iv*oF3|uPNRKq>tH@I3)0J;`I;T=OKQ^v z+NP!7ojnq#zS*C}>5*@KhPCfewS7w=f1if@4MPGqD}EBL7(A88K3h5h$EvM4oc}-! z2GdRlkEXs@zjzuZ4mhWH?qwMMV4qAgQqk_cQqrn%d9K8OF!wo{jd?OzS?-F*;+u;d zgIT*Lo{4+nRap#styXVX6vH0tV>%%-5R|e|o*a(NZg05Q?hTh=*QeZ{Oyvc4SdzkS z0cFGgcME-!y9E~gQo8XZ=>b21*4obai4z7wlvz^Ic4mk(Q3mt={DL+C)ts#8l);cX z6|f*xW(2VFh)g4jgRBU%O^9uRGB$q3s_czY5pbPbVGaOz7tcRycc?om$760r#`&0c z@mUck;8HxV>}Pvg_8tw}@NC1e4VAGWY%|tXc)ooL$%sXospSeEX)sY=+leJ>1HQ4`w4gI^XN(uaW;5?Vu@UgwSKXy&p zS6konurnjO_-}EXJpk*GBSy&9UqQB-h@14CBm%}D&BjYBvn`N6J&C{ za(WDGP&==DK^JSdZB>ERKsQP=A3By@zOy^pnhEG-&*E&TEf=_IO}Xxj_%~ej`M+9m z^O~H=Dr&abT(0KT-Pi4No3@Gph8GO}e+&4F$StcWf}!7LrwFO^G4fXI4CH=l@W(6z zA&wt#Hz196F$f9y|#_fuN4Hro-mnZqqj2FXA(xuI+8(Rv~~ zD0lDZPd8DyeMK=d)ETGTYgZo}it7#BCZjH~LQQ0%a7n&IUs3UPL<#6QSttvfU@>a? zWLl;iHR}cp3LL?36RTW?m5LRd&0sKU1}JA7VEEgxWvhGh?UW;qus_lB;fu zsH;vt_@^KJh&sBs-IMoDKB>wV_UeIvt0fNU(s40gOU%3f-((?fIQ{CW1qk5A72fzd+)S6&CM z#7T=1l#|+icf#CPwo|K`wRhYmf)l`lTT95vkT-~A47sNp?dSKm`SVbU4J~=r%K8fdM zVbh&}P3I&<#pe+FY^ZbD;O{a>PEH(fa7MGrPykuh5vG8dT-rLcF<6Q0(! zUG=r0lCN7XFZv!`{>j2{S6udN6T{V|w8Y+5KtFzge)!?f@Y(uA(&rDlv_hXDVB-Xr zmN#;`c^2#GU?949s*0gx&IWCfPXkC*JJh-=7%Y5~bhD|c(&jsK$X(7Q%pb9)D;<%D z(owW_C5Bh_dS~C^cF)cR`}%r=!M>rDiSWwN&3Uw88QQ>TNK5i3iIzE#Z3BpJ_ObAr zV!{EeP7c(fQVKjOxeMZHxJR{7ygW)@nLRX3jlj~2@8Ve=JnJl;6{LHg3(C+a-0UG{ zW;eMJdP508e_pu;I}TMLs5_{}LG21E>UL^jJ~fLBqA|->r~qcBg_vbnT4r_yjBG0z zGBG=BsBWTyf*0szrcUS^&NwI>@MxZgYl!I!&{a70EGpY@30Y7;;2XxXL>HBqDc5Ke zYgv6hu8CK&xTeyKI-7&)*mJaOQ_|M8oQCZQf=P5q9;ZXpYCZNo5xP~--REI8qsVF2>ZIF26GyS!eL*$9Hu{+eV6KH!$XgK<`c}-gz+q5JWpdhZDbAN zJ8TSO3uVq@MFQ;V8bsvHbu(w~v)c81pK6ziu*Y>GZ`N3#AZQj8ghq^}LE%hZ5oUI3 z5ouvKj5Y(8==SXPj=kH1?X3lIZ`ZC@cFj(3yYssy#}o9{ix08(Fn`aNAdk91pAnK* zd_VKjGj1yMNBqsZ?*e?`OE(_axr`-I+=k|SxC zo|SUSr9XVrwKwcPaNP|zzFSz;8H+7iSy(8KfA+J-@l)GUoBIZRo2$Yf;X@SG@+3!F5dbK*-32HPMM8ng?bD3!#^9FGY}C-Z3Qauj^2hxb5Cy1=8M zH=e)gjt||OKjbJB^AS_pR9V!uh^ubhvv>O&+;)wQ=dP#Rw@MwgLIXC}0XD~ogFu;8 zyj~It^_z7WXFo}s2QA(~qiBo`BGip0R4<%uK<9@QxNezAwg3(m0D~Yv4D9_73oxK; zTxVK0=>Nb6O(W|MzaMIJ8H3KfkJ^1v%c!`#UwY)8!pcQgg0C@#3~s*w+Yix6YELDi=G#5papjOBm(NUhHR~lI zP;cj|-pY!W+Nj50U%E8XwYTFPZW|H>xbHLeoiCQPbAnTtG zw9kC2dJ<7=l;UI^;Egi*GCa(PyVW%atcDzRT$vKJ+x?>8p^Z zK47HT(KjwlNt_fgG&qGBz|i@fdd|{NYwJ~23BU-V>#8pXTw#H3*{+rQr>>E*G;MIk z{Qj6^I3!h8_eOh0YxErEAP#f)u0@*0BpbtMsAKc_aiq$DILsJBU z9&l15r65uRCYBJXj!BrDjxyQ7j8T;Tq?B2tXBkgTOiJj8$qim_vq$Wl-K+K3Oc7Jb z#G6F7!OrPKP7C(}g9$Q5938M3Ph$iZaza%8t$NuIJxnuZH!rfk?5&kk#yfQ0P*fD< zpx1D_IbNuRy855|!Y3=`BX=HcX}RO>Bjv7#9{c?86|yx$Z&ch#Rhq?_y&ji=cdF$M zqg-`Is(BFL)vD{!i2iyM^oofmX6++3@U8h|9UL(@us$O~a9)iR3P*6Kk!=i&-$SoD zuLyVpuP{NYDh13BO4&(-4b>NB*rV|fR^nm^X|-ixcE~PvGfB-<0rq}o@+$(%>v6DZ zHHQe*;F?F6FBR6DTB^D_yIIRRi8q~6Y8Ko?>{?M{^2R+GO-PbVp}If?p^ps+XUdkt zG~5?zifg5eMhtOYgV>O{7#7t5iqrt+{u@KM3ZmB2(Qtt>NqYHnS8v4w`pX^s2=Hp;M<3nAyPT$-j4-NJ>FxDpEEz=7=B*L8{$n0m2fv40?`mou`BS zydn%8)=eggS(nfkzUpbK^5`y|aJGd*ovsfH=~9dLGaufzbNb;xOCct7wM_SP-P#fy z8r_tqiPNWN&t*4n9Afir7U)evlp*S{Bc0XSr_~)XKL8!U>~h;VivbxVyw+^cF`8lQ z8;Whc5j%dZ(ug;`%GmcjjUY0EmQ}-a))Wc_Ot(2x*>Z5YZB6Q^r=3dP{*}XW%lPI^ zm0$mQ{L7OAAHPy(u>*EirmaC=Ij?%vk*}j-B>0ZrskPc!V%oDtaX?f(2u5&eql3V} zWf$3Sk)7B%+knXF2K1`(d!ha+E#=@1%AL-^Q6#>WgDVKA0hEB%#sWx8?f+VCpr_4; z7~d{;rRS>rZ|EKLhrI``8!t}|WXE^kI>_|?eTe7YiFmFad@-;^M->Fyw@|7erf%f- z5QBEV&VdA2I8Yb#nAgU}@CU#&Y!`&BUB{2l{)&5I{Nnhy%Ili(%)e1%#975fdBWes zQHi7Qd}=t(0cR|8$Fd;tX*E8ayX!FQO=p$Hn{TDw+qftGbR3UC+it*fJ~ZDpzlPtV zpiTkkjC2^SMAP&lnudULqiM*2Q>7IKO&e`kSM)=(zdU}Nx=)OA$H&!Y!my#gqBHOl zHz|@9L3lkJu{?}ny#Wo}&n&fzuT~fuTqet;KCMrqeZSg!>#b8Kuf3)A!yndYtHmaoSA^zk(L`usM6*UJ=gn(W=S;#Z4uncu^n3N3 ze*JK4JjTUhHU_BmUVVlcEt&N;6CjjB>KB49NK8^i+e@%-nOGldV-|SB;fJ_`s;j)m z9B=px)gbC0rIghivpN$2u^i}JQIrDL^%kyb2_nLfDkt-`_+rWKSv$#byJ4l7-3~cO zkNGS8`PrZAL^08o&9=v^1~FC^3=;-3>s!yqw7KS^;Tv*!DQ&ezOy%~&;m)CS|8Ax*K64*sHOn4s&ivN zjIp*x%Eh0%$(T1JFZb@~&-TRwQgbT5C?Q@o8mjvp{=v$?&fdtom5qHVvvnI{A&Hi7 z@1OxG1LhQK6@zOKaD7sRYk-U^PUK9y6rhTqp7K-0M^Awx0JJP>s7f}O!I}YF=Nk!x z$QoxbK>b9&&L^yQoA~vj3RvdpV`e{^&U9KeMR05%`y%~{d2#Fvhjf&Aa^^EGJgsei zS!%KQt=5E;&rnxvTWQa}En~j208IVJ zcGz?hX~L(JHlLpi1=cttraB~RI%!@r1>mR5OlGe#ZvjJJXJct0T1atfTkqDFWhyt| zJywS=U3KfgXl=OE0Q!bL+WtaI_mN)jo2d|>o>kJPNydQ zor6V(Rh%$5bW$qp#e7!aOcXKa6NovRkmtJWByj@nX{KfcM|30OW@>H%6~?B(T{8Uo zNW>NfAD-o1zNBS}w4Da%=q0^;kntb-MGhL-eq#y{Bg-C2nTi^ z*zZ%}TnC&_0?sbdtJtk0ifP<51+~~CjSzkW$xsL@foV{;OJ~v9*Xv9i#mrb8lS2S& zox(>9Yv=WOE8SyXU=A)ocbg(<|LdQ7I}QBo z#{tL0+{4I+z8Y|hkfD=A2mQSW&yUA7GUcUpFC|{;jfzn@Iv(Z8T3I))o6_;RNN~MP z?*cy?MTS8g2?H!z$Cx#;y2n(v9t(tDA}wbFQ@bgK-rfK*4Hjj&P>|)~mr_fD<;7|7 zj*F3my&UFr$g54Hve}CdI;=s2jGvsG{c$#9fJVf4Mf2P$`T+OWsvl#8Vl#Nb2ppnq zgb*2L8Qh}KKS)$sOZ=i=_ACBj|CC?n7uPvGqak7hV`B&av+*2Kx>yNnYnJt1nrh>nHDG9Y|)g zm&W;L7-v5jQQTUh6Lqpq0Ti{mU^z(LCNjd(9h3kD+ZV8lVp*ILdC?CdgW<$$JvuFj zXI; zrAo==skOJby-NlLg1&lpo8ugCLZ$gn0S86_)0z?;CsTy0qt;~^F%AnXwVM~3^d?2L&HhHs^x$HYep=3Nk2Nj8&Fgb=MZxZLUXL|K0Ul*PP4XS}jQt zz2e3xeO(FlQbK%a^^pjTWPIymCP^Y8olcjutOs`2FQ^t~ zNtI{}QDG~O1D8%^~3HJTbusg0L3L*P!dum5?x@H`xqE z$-rwSoGzW+Fp(Y#`I~HzDnIv@2g|cRrE)Ol&}lS|VsP{Ba*E?-@1rjv)_?@w23`;W zdeSce^TG+!h{5F;QIS^!9uUc?6Lc&#v7ToQA5$e6lfn=L&V~|j1)az1(XAcrgE`Q7 z(HgKFqHh?*OH_{c-mlV42rDqWP5)7)o0Q`6uOUo?f=<>5atJDyM;+OQz-L5(S2YM? zA+aOOX;sQ?K!m<6caBslBa7tdqSfVQl(R1uD&=PO`&0X--bA8zQ+sWbl1M0<+Iv>6 z>`{h>)OOV8V|HfDBdftao!6DZ5_Bci4QvAhJRyF)-{iIm3u+Q$)R%N5s*XwgO7)20 zzB)j3v{JRoCUZv0XAeUqDwZmTV%y6%9H4zYt2MK;5aIo-S(uu+Td*EQlfX41XwwP! zqs)lawJH%Gnlg^5WSl2X)=WXx#r*4Z{Q8jI%NnGrMf0f?jD4uGV_tIDW2)k&O6oAj zBwd5?eJYoCC9TGYy;?mS?pRmzRLeQ>kf-WlIved{N*m=gt2=8Om4rqoXf8hVwAma} zHh~H^08hTF;z{%wr(r}*M>GLMCP};AYBDm3paMtrCKW-3&>I`DKm+J==4ebd`78eE z=ABE0WHx7~6C9#xI^FDN=<^OYc61B|hzmiF`7-pFW+nwn;7H7K;o{fGDVkyo$_TES zss`6s*xUr@zT!Z!5;ge9`kdZ34-}RHz{ZIwT{$)5jd|g&oE>w?3wPzzn0Y_kJB6|> z5O)UJi(yamP-}5j$Y~!al%h6Y)EVe3h22Px>b~0VjIY{lmaGo5S!Zy|$aMA zX}n&uS+rVF8LOm%Eh%?U*k$!L`j&uC;BEK>LS*tJCTE;dn4KZIWLMdB#Pxtn>(VoR zqh|!MS5GZ01{oQTP@@jAc$gdKrZ}Dp+hCv&<2sfEqXSE>o_!e!i4AVT6r3^fH5Q1> zogM=>aWWOBO^txgd*N8BzZx^V|N83>z5KG^@Qe0PAY`}4RwZ-2MK4t*Z<3BpzTlS~ z$ORG%*I^oDX0Wr-{zb@rI)U6L2dOB6eI(+b4oMhMO>Z_3)JTm^hhP-IFB(<_Q)^VM zol)`pixIYC^xI~y(i5?*9i4-~z(^q&oK6@Va_4ZF>i(d>m}aV~mDuP{>EGjh!%U++ z&nB_KeR7I9nJ`h}JX6IHu{f_zM}uZ~UU8Y=U$Q!k1kkZbywe7m(a=_qy@cE#mM_OF zn;g>6FFW$6{>8#r_I9H$7_wO8NXU3NJ6W)8`0ahEtJklN#a6GsI(6S~H#A^iLYsbp zHf5-Cl4RyyKY=!kXK0!=3(Z6MI%`%`#Z^>nY5w7hq>q{~5ZZ zdM%j0%wh>C??1~Dg_%@WcUX9p zol(QAJwUt+!ZL{niTHh5yJQk18S+ZfO4snst(s{JX#YzNxv^Xlx`OJ9V?I^75c^Vf z396^PCa2wQ6tM1!Wz6hySasKGjAo0|X3=lZS!{NY9Wr9BHKo0_NK11o=5JP7(bTP@x!0+7PB$)kw6WZTE4@!bgtz7>)Yw- zkNqUHxVOt&9hNggrC@ixC-@HVSVGR@+sJv0u^4egqS}zedt)OcVTpT3JRZSn7i@&R z`Rr-D8o^oEi$GNNNA(;1y^~-*(1RIiE9GXiG+_c8?TsB=VO0XyS;`;}6*c zx8yW%9lf_5JkXZuOgaR^PNTjY9sRp|l55wF#N#7t)}|Q0T>_Xq3z*o+`sWB{M{~@< z_MGZpV^;2$z~T)Kt(65qFar!x5JE(vkYQ+NSfU9HUndF%oo<~TNCAUDb+C<kztUq9j#k6ICU_9zM0lM_gIi*hGl5-{mq!_sb6SwBbc$N@Am@r!ill za^@oIDZDgAOfH-6VVJwrZPrCAce&rRqgM9Hn|2nulcGP;))w(&f@fhT=CGCjINxO{ z)sdXww&UaCSkh}By zUVp8u<~%+=_jSzoZY6BKcU*Bu`>dwDgw6N1*fB}xHZ$`YZo%9JG(t@XWBwr)M~B{g zWD^MBO|YE7(U5Zz#m%gbjCD-Wxb9^o&ocYpRHU3Bk3qztS}IS?TIh42J6r0(a{jLbeO(e#nJ?0qtjV8#X9Xz)1Z`!tb$L8&MWpBA`Zg zg6IwO?TV@`}pm$1v?eyf~I)@I5njhIvuWoj%Q+uJD!s z$1ou}is=u3?oM(2@}Y+~xQc%<`+z8LD^`SBmY3r7aMYFXyAnPt^-qeaR6?8_n66B= z^lq%Vt=4U3gTbGb8Le@cMCPYIp+AJa)I@&tToPLP3Wzgxnik4$Jp&=8iZ_7%x6^e72D&OeS}KgW!ubEnm)2CWKWXr@nT+no*fog7)^%2Q#Fz|Lx zL@sF~9gOJ)j*jX%hA2QGMwLvKVqRvc@c}`wKeoOD(-T-SR4%E`ErhxXG=g5h6oQ)S zRA7^Ps`S)d(|6x}_YP-MDk>axRTImSx0%B6v~%-acjb5OTHCWWHZ(X8R_++MZ#vvR zG!$Fg1N^zntMw#-bsLPFb`Js#2EA6~9fSoNUREc>o<38#SUCfN#MCmDkj1$5^z;{I zALhqrAI5W<=kBH7;C7J~(npRymu5)7)K5jgPPgKe$WSZ8lODEb=r8uSc8evYu5ii( z)Wl2>EC0CLCy23p)E^Ot=%S5cWX)`6Yb7sF(mKwA+3XXgH8id3`&q6V=BK8 zUqivBnyY3v5D3atTNvDxWtTLP3NFp5Z1^$N2^}mO1+D{Z89Kr7r6wFSCQGcA5{ZmA z8c!DD-Nk^Ma(X5IoVy=KQFME3}(zl!i2SmRkW&3?fjjxJQM*#AVZsVNx9X1~Bn z{7xif%(lDY$9M-1Nui@>>2JV0n#odf&q>nPuospvJ^@s(vjJRY24#0LvR~CfTUaTQ zkR4x7+imsCmdtG#KC{eon}YPg#kYm~r6U&q5q_10mU)U?7rv`o$(FTX;Wak52Ow+2Ntn%$tkkNi7o0(e#n?g%{%@9+@4h0&Ms-%d zLFW+y8QGERjN7D@E&U_jrdrq$#1w8{#bL28d5G)hIIGt!Qm-RXk-wueS9-#5muon| z8`SAm!kk7rI?2*+((gdIH6ga<#Tt-U08+2p0u(rCTD=7ej2zU0Ei!s%(KM}DFc<`# z1p!)(84qAuJVu-GIaCE_QKfTej9m#;v3(F>_muPpH8aVFE8G_xqghU z>Kz+X?xx?#JpOq0jqj;jhRbY@&IWpl{uSDUSgH0P$Lk2UUjyCiB2y~Pf_*08Bu3!+ z)U~r`=*KqxkfrY6zRUBb$@}I>YcA1;W1d3(Nu>~G&Gs#!DseH-4@9-C{2@D7IHc%qTH0+0o&F&z%!b&QF270_^QO_KN8WEbai2_EG#mXlNb<)uYs}fvmNEM+9TrJQI0Amzt}|)B`EQZqYb$=E(dM&A7ccp} zNwH$}NSLEG_-~UVz_XjYhIOt|;Bxj8$PM6cq#uK_hQ7ZFyh7A`HV60krq0NNdXN zPPImQR}L$lNW|ljWqQ<+V9O;X90R?|;3Q|P5P8?gLg%b?tP1Lm7%8~^+t%mt~MBbpLcckDVnL-*qr`H@qdO{uboyxvKVvur)yCityPb#q2k_e0m`Xp^ z(V?a-UYzrRK2T=-^ET$Myp+=)w2G=v7 zL$yRDN>wpdj{$x47>{Dd$|^XLhD0?lOk}=CQD&)MqGE(bZDacK7cqNM!Bb2}>ptr9 zMX+KPe>9S}r*oOaVWK^Z?BJjwNcg-YS`JI|u$kBO*vdJ~W;iWkd4bm|;wi9tMt>^d zF(DkpYQNe`CT%Dy>Fz>?Z_g$Y~9kr{&F6vFzeBhq(4RlE?=I#Q68m zb_xzb=T7<8a#-t^BCxy%_S~I_oAfA6vbk(NWq#d!-mEpRw#bgMvFh}v=uSEcnd4OiUKIRpoylr|`u!IC zUE-M^1MZZms%(@Sj;_|05`{@wwNjdo`d!hyyAZeNVq#N5(%QAdT7edYw8Im27)*6e z?{k`U_JqL%D}~%n2I%ML7l@TCQleG`6B#WEn~P|%nh$aZ^~7c+H&Wh2Ig3R!VM;%M z!)A{*CiS1bc=2UuAHYW#BA{hpp}N|{u?a^q5J>g=SF9cY3fN35Z7J96g%R+&LDEkj zr%$T!tO;gGsS1(mv<3O7PFs{};s{FSD`yImVZKz^od*?L(Db8{|EPjoNLhOz$wNS$5)E z$U{q}nYF4_w{(%J(ab)jYBbr*=O1r+{dIK{HyJrlby`0^vmH^kF$7e=!u6Lg7$M zAG}|~((<@iB>Di9()*p3s7H!gB#VT60!_q><$N@bdqs^mh}39aue;AoKB~P>b$`5E z5nmR8rJy3{b!y%}wv3wK!-1RjEtaY-zIj(86|Z64H&|M7LF7QWXj5?+@&_md1r|$I z&^V>vO(ce=Jq3C8kyyoBUnd2fbW-#Q)uprF#Bxzzd8nRF7ji>TMr;w!yB{~1wX@&y zG)bKH;$LuVX-`O32FG6kjvY@CisorADdq|f z#A*EgM7R)6X81xZugRI4H1T_58oTu`U7rly&Z#S+s8My+TQ%R7b@WAbxr^8Dx?))x zbP{QdsTPR3I(l~n({3#6b48Dnth2v*gKG-8?Pk9%Y;JOP%IR*moUqOwz0~#pqV~G3 zGi&21r`2S&xJ65=2eYRGF|SjgzgYmnLACo>Cj#>te~WpI8PbZiM|;SF%DS8kM93&u zEzZR@T|M1BUtH8BVaA0Lkf(Lluud}SbVi9+y6YKN-EhQ|Ji?ohCmS~L-g=Lw+uUVd zq^Wi0%O!Jb(?^SD`w?$r?SV@DtqQO}#epk?8x`L?Exx!w3RUnB5kOM2G8qy$!wp4p zL9VGWSyiy9#<>b8W}IuUL>1=xQ}H8gO2f6ZNOJqJl9C-04Xo|qma@g3b;b&TU{$1F zpT{3BLz?v}_~{gioy=lMG{`a49BXPK~E3@tI}Zl}-dZ=auVd6_X`#-lxr zUxhwUnSJvx_nV833U}<{P3p6+%?+sZb@#vege-~A$Lf37USygKrT{p*G-|6+jRHC zn!0~n&lGN?o=5a0q_k|&YxNGF?2SBP)!H~Cl6)JpBd{o<3X`{>cwZRX2jGmooO>O6 zs(4y}3gTtZbtqf21?bM)RP>NN91M%=ms{|k6Re}NFL6ej%hCWr%jV77YO^$3iyo&Dp z;SbeoA0uC(!?Xj|hvNiK1WXTkuyHZ-D>?1M$tkJK6zhe{grw3zat^w3x^f7JQ}@b$HzXlOYWLvI-Mlb zyB4M?Gr1Ybi-T`D({yM(4m|l6Y$qS% z&mlxOhAX@l<;nNp;#+;PsFn$}+7k}jiBhgOjWObl^e705mu%`J?ok7?s@S|i(C9_$ z)2?E8FwNpIn#9Utj~QJ`i=oKOw|H8HKOwj!z%G?pL~CIou$W9`WhQ*6z9`s1_B8(r z2VNj(vthiwtnyVGkJ-2z6Tf!7-^BdysXtZ=w3xliwa_3(<%gdc~q*6C;{+v)0Wyj-#;Q48ws7Lu8 z&;&~!`Z#`dk>02;&SWfQ`)(Qxg>+kbrD;8~;BB)>e}6XRnwrNqNaggiqx?mF3?(M( zV6)e%^k2gGvx+M$extp@UwYQy*PIpD>-1VPE}7H;lB^ndvE{RCj!B!!!dDM;9ercA zXrImo__2$PXP%Lji^{kF9i3i>(f^9&vSr4iuqge7c5F@Y39JzIQh&u+jo)yVE9MBg zK0dErXcl2MPagH`k2|cyZL0$$rMb<0XBscQb2mxgh@YJRZxT`+sA7I;g!)5_FYJ=p z$64*zXsy=!Uol-aeQcUB0b19uuC`THRQ+&Xb?Ci%l`4cZ8FZb{K``aN2#L!&X%hHv z@1imF_f1>3HJ|!X7M1%~d%dgUR9^+`+VBj25_JO>Ue+Ud782$Y&4_!g@S(4^iz~5{ zm%xfdmDN^bfZeI)B3|hYcy8RFnseh_g0z-Q}MrjjV#)YE;E>EaPPpXWTYLmfQ zZq*x21+7Y>m98x124iW#dpB?1)Y~maj55lKU<@zQBV;Ptu@Urf>=5=cpW=hyD*8fX zZ$q<&y^XSz>}^wT+J5pMJw4Lepd*O;7~%p#_H~8@@?20M_AlR^v(J%*?y6k%*l9ql(vyTxOwx#~6P@M%d#Y~dj=Gn3dpbHicus+C@wZ{W zA;2wFwSNT3jlkMTo-QUoOwM|HrS-Jgf2H_Zu~7Vm)_+BD4YQVSuwI~^;9qL; zpI$$FmGG-kBw0(4w+hluynVJc+?=h0UmI)Q`HxvI_gjJXfxBoM@~+bRSDN@rQ?F^n zL^V%k8iB~HWPVzFXs@uHF7{tBU&E^PHx&LW*x5qRX46O{5|Z>{m5}@nF5gAsuJPur z*(5d$v;%Z;KL4uNey`u;|5(p2={c=1dP1+z*NoVA*##hIqe)@af#6jKuyS(7>ah)~3OWH?#o4-5+eFc@#^0c^Y{PnH zl8mq-N|w4$uV1BQJU=7)$O$Q9Yh5FB08|r>9cc`)@>yeNdeIb|Ak)gcMpxawqN=uR zd2dr?L#?A!=NhfkmX;J^UB6@PU`^NNR&sRbYf5ajrFK`TroFMT?YPCW##3hXG}>3! zT7>P8lLf{iy~Xad)a~2YvAsvE?jG}2Hr7^SIax!4X}!-!?M0Ab1L)Wh?*q^4_;DQ{ z(Q%_r)CnK!exnm4Q}+`(zFWsv(h4$$=^A%|x8Op7;#$Ec1wwJbE0`70b78YOpxTW& z9KDKfWxB0}7%wV;-UCxOw&J*P`wH6M_|@B_H^$LMq|ae|pvln($KN`^VU~ag_)qz% z$<+7w_Q^pY_|kYIjn6@A+7jOWKQHI5!QG|DONG+<0;Qs+(pt{e7i!cOu+x$i_hD$WzWns2(9G8$28Kat8K=2 z2|fxh5NkYX$|&uUf~CQja7NDy2p?@`1!gER_#W4QG~3@_(zs%IN#w}UsPnDo01#T= z=5|*+_+V(`o)lqxj0N{>+YsWfaN$z(isep8UhRgQdlqu8gh5^zRM@45Jr_d@h zau(Bq897UxCcbIIwpKoL#qt(YVt>XkY=`F|_bfmg!J^z{cjLXOV7i=x>sD(xIgy(s z2POC>wJin*mwLe>8cgN2_Nsbc8^6D>%vPdy6?xVvb{Wr|dyTi8K9jok1O8j5x4Xyb z?CJIvnw+MBYEz}?bT$N>sV2CaUt}16<$b(iuo}@cH=_#Y~()?)sRhzHA z%3fP;GKiLsmZa3}gmK0xR+_2{Kyykxk5X0YLm8c9i-Ozy0$imbl;#U^_M^z!Cw@fS zH9PH9Vy|0pE=luWztnW;crFgBuuJD$U08zdEH39;BmM<+x43)6D!bEc(mO2txxDE9 zo;aF=-`HC;AG%4WeZiXi^y6zIso$F&29pK+c6e9v8%xst@TI1gUdzdE?1-8#-PyG| zPkulB#M;OU?p_DjZ7~@jU618O_D8wc4PdbyGwUETUYBGB?OF@9sk&Qgz$c9q9U)QB zXtaEOUB?f37UDWLlvU{UK*!_*+*;piv$fWj3;&?AYB7yaX?AL`UYL)|3RZFc{Oi2= zD`!&g{eXYw>Rs34aP+L}O_;1kjmBs-Eo*lfjjr}(PiW0Ljn!bPsv`Yv&pOz z)(R>JoD#?z6?UurLgkzV__;R;^os?HxzFY*(>TqQmHHB`RrlGwm-4%%4qJsDF3ISl zYjkF9sz6>!1@_|&V?LSWzm1W@Gbv*H5n$g^jU|oemnxD=`4?mq3Xk4?jvG_|CG5X- z>$|yH0{V|LlR4;ELfB;JI4=|7ylxRXex6HmL&u~p+@XVDNol8T8AtLF*%@kvvn6zV z5sFMp$z^5g`%BW4ABTprrSHGzped)!Ri<9eMUyHIQJdk@-(-tcVRR9qYL^hG%G7t3 zqG>5HnxW~nY_a*f93M^5zU z?PqyO>NmoHTelkSQ4rp18M4G*wv^9Vg!$r*hw?2#ZYf9de9J!|J72qT_YP z-A@fiE^-W%gUjPaTMK_yF8Ad9nAE>6_ib%%!d9oXjhjDow(BZZh~f&HuC?x;wlpr| zA1p2k`33*}_0`qu_xpX1cTbKrJ{)Km^f;ZK!G^%YjboGD$EhEznAwn3mL*z$9%WfC zmz@JLt}juRR~Hwjd6h+(dOTAW1!fFfYzW26qg$Lui5|_Czo+spmGD$4DDt3pSQpH7s2)W$MQZm1`+| zkw>{4*}CL|dn;BB^|Exa(4U#f^kL0FwdiCpk}B?1=j2hymVETloB0>K@t#x^KR>j; zzow>t{}4&dZOe}Y>Nj{C4$p@Az>($KCc95izb>^TAC}Ntd9Y#Sf^5jrX%GDoY{;qR z@?ZljLR#!M`fK6IjJ;*)jBmC~rX0%lp-eEF(?2 zk07^c2&d-861VqcrK_FUhcZ0{-QI~|TUJ_myf@w`D@$&T=QNe+g*Ad2V?+}_H@x2` zioX5BRPP>aI2x$i=n+LgMg@*GJUH2XlI*K&M$K;t{|S$(Vm9XO1ag9?-K{;Oy`oiW znTCrR^0>JIz6xXUGlos@785q9G^aT{XL^BQhJTLC;q=o+U#rL=wH*0^gtY=j zjR?LUIC&D;;`BLxCjeOS)q&J%>bSrc_hnco)1OW3>zOcz|L6Z?!dS(?38|ev3M`tV zRp9i2pC5lQ6IKE4>-|g^8{F~F5tDC3tEI|y>bQlORs zPzx=+fN8M+Oow`HK%Fnf@|qH0mz3gpGpy|8sGAk=QMAG5xe9v^)qpw&FdXoGu7;0m2V|Uwb%Eb&F*~&m*0)~fWqo*6{aBScfOoWk zZDgA;$u@*~bRXXF2v((UW~1x@wgokA47->=2o#^~>>;*;jkBHT6YOR|E?`5ZQ|w9h zWA+@o2`__ln63RbdlBAi3ihY$pV^n$*Vu2_XY8x&&)6CECR*2jv+uB%*zeda_Ir*! z8@U=z%>}@IDdak?=LR@97jq*o;U->+bz5+c>=3OE8kug<=N}27@8Avt&^`{IKk@_)esj z#J*TOsSO0$#8UUSRI#2r#=u5CJzL)$yhX& zpvXGZn$|&&M|$DuaF;CHCky*z;eJ_oy(~N+3lGkPyJYEi$ze|>Wmn{7* zS^8bF^!sG#_sP=llcnD$OTSN+exEG;K3V#Gvh;nj`2Di*pcF<+YhOLv(&*w&vy;Ro zp8+JSq`~#LcH$uE$pPa_dk7!L)d}`C!b<5EdW7RBWIyGNOc8n{9${r@wFj6d5==%R z=`2j)+b}9J%Y8%ZaeiRbhchJhjFbXa=|Uz`TJ!HXnW}I505n+t=oXRr?i(2v+34uV zeK>C!9TFiKDL#B1k$YOM&s_^rnse8RJJ$-tr~KxABdq|P5S)yM*ea4RYz;{s=9A7F zrStvK>4R~$B^IBEvh9h4dlh6dafR}wZ_+7gF3_1Y5|?C%T2H~g zgg(VI;wUmYPr%!wHK@mMPXJY;I4=~BYJn9;5ptwF6;e81LWsB^LZAK#w9#4i6!g$J zcAi~ePovj&k$r=G6LAcZ&NV{Ux-xokC-@kGA0O2$^~@(ogCqCxOzKppx)D=er>dno o)o`c2P~Q_D)C74*NHC8}{Ced70j1DE?f?J) diff --git a/stdlib/doc/tools/coqrst/notations/Makefile b/stdlib/doc/tools/coqrst/notations/Makefile deleted file mode 100644 index dc3a647f9e0d..000000000000 --- a/stdlib/doc/tools/coqrst/notations/Makefile +++ /dev/null @@ -1,27 +0,0 @@ -########################################################################## -## # The Coq Proof Assistant / The Coq Development Team ## -## v # Copyright INRIA, CNRS and contributors ## -## ../tests/antlr-notations.html diff --git a/stdlib/doc/tools/coqrst/notations/TacticNotations.g b/stdlib/doc/tools/coqrst/notations/TacticNotations.g deleted file mode 100644 index 70107eba46ef..000000000000 --- a/stdlib/doc/tools/coqrst/notations/TacticNotations.g +++ /dev/null @@ -1,52 +0,0 @@ -/************************************************************************/ -/* * The Coq Proof Assistant / The Coq Development Team */ -/* v * Copyright INRIA, CNRS and contributors */ -/* ' | '%||' | '%|||' | '%||||'; // for SSR -PIPE: '|'; -ATOM: '@' | '_' | ~[@_{}| ]+; -ID: '@' ('_'? [a-zA-Z0-9])+; -SUB: '_' '_' [a-zA-Z0-9]+; -WHITESPACE: ' '+; diff --git a/stdlib/doc/tools/coqrst/notations/TacticNotations.tokens b/stdlib/doc/tools/coqrst/notations/TacticNotations.tokens deleted file mode 100644 index 2670e20aa640..000000000000 --- a/stdlib/doc/tools/coqrst/notations/TacticNotations.tokens +++ /dev/null @@ -1,14 +0,0 @@ -LALT=1 -LGROUP=2 -LBRACE=3 -RBRACE=4 -ESCAPED=5 -PIPE=6 -ATOM=7 -ID=8 -SUB=9 -WHITESPACE=10 -'{|'=1 -'{'=3 -'}'=4 -'|'=6 diff --git a/stdlib/doc/tools/coqrst/notations/TacticNotationsLexer.py b/stdlib/doc/tools/coqrst/notations/TacticNotationsLexer.py deleted file mode 100644 index a7ad55ad34d0..000000000000 --- a/stdlib/doc/tools/coqrst/notations/TacticNotationsLexer.py +++ /dev/null @@ -1,86 +0,0 @@ -# Generated from TacticNotations.g by ANTLR 4.7.2 -from antlr4 import * -from io import StringIO -from typing.io import TextIO -import sys - - -def serializedATN(): - with StringIO() as buf: - buf.write("\3\u608b\ua72a\u8133\ub9ed\u417c\u3be7\u7786\u5964\2\f") - buf.write("f\b\1\4\2\t\2\4\3\t\3\4\4\t\4\4\5\t\5\4\6\t\6\4\7\t\7") - buf.write("\4\b\t\b\4\t\t\t\4\n\t\n\4\13\t\13\3\2\3\2\3\2\3\3\3\3") - buf.write("\3\3\3\3\3\3\3\3\5\3!\n\3\3\4\3\4\3\5\3\5\3\6\3\6\3\6") - buf.write("\3\6\3\6\3\6\3\6\3\6\3\6\3\6\3\6\3\6\3\6\3\6\3\6\3\6\3") - buf.write("\6\3\6\3\6\3\6\3\6\3\6\3\6\3\6\3\6\3\6\3\6\3\6\3\6\3\6") - buf.write("\3\6\5\6F\n\6\3\7\3\7\3\b\3\b\6\bL\n\b\r\b\16\bM\5\bP") - buf.write("\n\b\3\t\3\t\5\tT\n\t\3\t\6\tW\n\t\r\t\16\tX\3\n\3\n\3") - buf.write("\n\6\n^\n\n\r\n\16\n_\3\13\6\13c\n\13\r\13\16\13d\2\2") - buf.write("\f\3\3\5\4\7\5\t\6\13\7\r\b\17\t\21\n\23\13\25\f\3\2\5") - buf.write("\4\2BBaa\6\2\"\"BBaa}\177\5\2\62;C\\c|\2v\2\3\3\2\2\2") - buf.write("\2\5\3\2\2\2\2\7\3\2\2\2\2\t\3\2\2\2\2\13\3\2\2\2\2\r") - buf.write("\3\2\2\2\2\17\3\2\2\2\2\21\3\2\2\2\2\23\3\2\2\2\2\25\3") - buf.write("\2\2\2\3\27\3\2\2\2\5 \3\2\2\2\7\"\3\2\2\2\t$\3\2\2\2") - buf.write("\13E\3\2\2\2\rG\3\2\2\2\17O\3\2\2\2\21Q\3\2\2\2\23Z\3") - buf.write("\2\2\2\25b\3\2\2\2\27\30\7}\2\2\30\31\7~\2\2\31\4\3\2") - buf.write("\2\2\32\33\7}\2\2\33!\7-\2\2\34\35\7}\2\2\35!\7,\2\2\36") - buf.write("\37\7}\2\2\37!\7A\2\2 \32\3\2\2\2 \34\3\2\2\2 \36\3\2") - buf.write("\2\2!\6\3\2\2\2\"#\7}\2\2#\b\3\2\2\2$%\7\177\2\2%\n\3") - buf.write("\2\2\2&\'\7\'\2\2\'F\7}\2\2()\7\'\2\2)F\7\177\2\2*+\7") - buf.write("\'\2\2+F\7~\2\2,-\7b\2\2-.\7\'\2\2.F\7}\2\2/\60\7B\2\2") - buf.write("\60\61\7\'\2\2\61F\7}\2\2\62\63\7\'\2\2\63\64\7~\2\2\64") - buf.write("F\7/\2\2\65\66\7\'\2\2\66\67\7~\2\2\678\7/\2\28F\7@\2") - buf.write("\29:\7\'\2\2:;\7~\2\2;F\7~\2\2<=\7\'\2\2=>\7~\2\2>?\7") - buf.write("~\2\2?F\7~\2\2@A\7\'\2\2AB\7~\2\2BC\7~\2\2CD\7~\2\2DF") - buf.write("\7~\2\2E&\3\2\2\2E(\3\2\2\2E*\3\2\2\2E,\3\2\2\2E/\3\2") - buf.write("\2\2E\62\3\2\2\2E\65\3\2\2\2E9\3\2\2\2E<\3\2\2\2E@\3\2") - buf.write("\2\2F\f\3\2\2\2GH\7~\2\2H\16\3\2\2\2IP\t\2\2\2JL\n\3\2") - buf.write("\2KJ\3\2\2\2LM\3\2\2\2MK\3\2\2\2MN\3\2\2\2NP\3\2\2\2O") - buf.write("I\3\2\2\2OK\3\2\2\2P\20\3\2\2\2QV\7B\2\2RT\7a\2\2SR\3") - buf.write("\2\2\2ST\3\2\2\2TU\3\2\2\2UW\t\4\2\2VS\3\2\2\2WX\3\2\2") - buf.write("\2XV\3\2\2\2XY\3\2\2\2Y\22\3\2\2\2Z[\7a\2\2[]\7a\2\2\\") - buf.write("^\t\4\2\2]\\\3\2\2\2^_\3\2\2\2_]\3\2\2\2_`\3\2\2\2`\24") - buf.write("\3\2\2\2ac\7\"\2\2ba\3\2\2\2cd\3\2\2\2db\3\2\2\2de\3\2") - buf.write("\2\2e\26\3\2\2\2\13\2 EMOSX_d\2") - return buf.getvalue() - - -class TacticNotationsLexer(Lexer): - - atn = ATNDeserializer().deserialize(serializedATN()) - - decisionsToDFA = [ DFA(ds, i) for i, ds in enumerate(atn.decisionToState) ] - - LALT = 1 - LGROUP = 2 - LBRACE = 3 - RBRACE = 4 - ESCAPED = 5 - PIPE = 6 - ATOM = 7 - ID = 8 - SUB = 9 - WHITESPACE = 10 - - channelNames = [ u"DEFAULT_TOKEN_CHANNEL", u"HIDDEN" ] - - modeNames = [ "DEFAULT_MODE" ] - - literalNames = [ "", - "'{|'", "'{'", "'}'", "'|'" ] - - symbolicNames = [ "", - "LALT", "LGROUP", "LBRACE", "RBRACE", "ESCAPED", "PIPE", "ATOM", - "ID", "SUB", "WHITESPACE" ] - - ruleNames = [ "LALT", "LGROUP", "LBRACE", "RBRACE", "ESCAPED", "PIPE", - "ATOM", "ID", "SUB", "WHITESPACE" ] - - grammarFileName = "TacticNotations.g" - - def __init__(self, input=None, output:TextIO = sys.stdout): - super().__init__(input, output) - self.checkVersion("4.7.2") - self._interp = LexerATNSimulator(self, self.atn, self.decisionsToDFA, PredictionContextCache()) - self._actions = None - self._predicates = None diff --git a/stdlib/doc/tools/coqrst/notations/TacticNotationsLexer.tokens b/stdlib/doc/tools/coqrst/notations/TacticNotationsLexer.tokens deleted file mode 100644 index 2670e20aa640..000000000000 --- a/stdlib/doc/tools/coqrst/notations/TacticNotationsLexer.tokens +++ /dev/null @@ -1,14 +0,0 @@ -LALT=1 -LGROUP=2 -LBRACE=3 -RBRACE=4 -ESCAPED=5 -PIPE=6 -ATOM=7 -ID=8 -SUB=9 -WHITESPACE=10 -'{|'=1 -'{'=3 -'}'=4 -'|'=6 diff --git a/stdlib/doc/tools/coqrst/notations/TacticNotationsParser.py b/stdlib/doc/tools/coqrst/notations/TacticNotationsParser.py deleted file mode 100644 index 4a2a73672af0..000000000000 --- a/stdlib/doc/tools/coqrst/notations/TacticNotationsParser.py +++ /dev/null @@ -1,993 +0,0 @@ -# Generated from TacticNotations.g by ANTLR 4.7.2 -# encoding: utf-8 -from antlr4 import * -from io import StringIO -from typing.io import TextIO -import sys - -def serializedATN(): - with StringIO() as buf: - buf.write("\3\u608b\ua72a\u8133\ub9ed\u417c\u3be7\u7786\u5964\3\f") - buf.write("\u0081\4\2\t\2\4\3\t\3\4\4\t\4\4\5\t\5\4\6\t\6\4\7\t\7") - buf.write("\4\b\t\b\4\t\t\t\4\n\t\n\4\13\t\13\4\f\t\f\4\r\t\r\4\16") - buf.write("\t\16\4\17\t\17\4\20\t\20\3\2\3\2\3\2\3\3\3\3\5\3&\n\3") - buf.write("\3\3\7\3)\n\3\f\3\16\3,\13\3\3\4\3\4\5\4\60\n\4\3\5\3") - buf.write("\5\3\5\3\5\3\5\3\5\5\58\n\5\3\6\3\6\5\6<\n\6\3\6\3\6\5") - buf.write("\6@\n\6\3\6\3\6\3\7\3\7\5\7F\n\7\3\7\3\7\5\7J\n\7\3\7") - buf.write("\3\7\6\7N\n\7\r\7\16\7O\3\b\3\b\5\bT\n\b\3\b\7\bW\n\b") - buf.write("\f\b\16\bZ\13\b\3\t\3\t\5\t^\n\t\3\t\3\t\3\t\5\tc\n\t") - buf.write("\3\t\3\t\3\n\3\n\5\ni\n\n\3\n\3\n\5\nm\n\n\3\n\3\n\3\13") - buf.write("\3\13\3\f\3\f\3\r\3\r\3\16\3\16\3\17\3\17\5\17{\n\17\3") - buf.write("\20\3\20\5\20\177\n\20\3\20\2\2\21\2\4\6\b\n\f\16\20\22") - buf.write("\24\26\30\32\34\36\2\3\3\2\b\t\2\u0086\2 \3\2\2\2\4#\3") - buf.write("\2\2\2\6/\3\2\2\2\b\67\3\2\2\2\n9\3\2\2\2\fC\3\2\2\2\16") - buf.write("Q\3\2\2\2\20[\3\2\2\2\22f\3\2\2\2\24p\3\2\2\2\26r\3\2") - buf.write("\2\2\30t\3\2\2\2\32v\3\2\2\2\34x\3\2\2\2\36|\3\2\2\2 ") - buf.write("!\5\4\3\2!\"\7\2\2\3\"\3\3\2\2\2#*\5\6\4\2$&\5\30\r\2") - buf.write("%$\3\2\2\2%&\3\2\2\2&\'\3\2\2\2\')\5\6\4\2(%\3\2\2\2)") - buf.write(",\3\2\2\2*(\3\2\2\2*+\3\2\2\2+\5\3\2\2\2,*\3\2\2\2-\60") - buf.write("\5\24\13\2.\60\5\b\5\2/-\3\2\2\2/.\3\2\2\2\60\7\3\2\2") - buf.write("\2\618\5\34\17\2\628\5\32\16\2\638\5\36\20\2\648\5\n\6") - buf.write("\2\658\5\20\t\2\668\5\22\n\2\67\61\3\2\2\2\67\62\3\2\2") - buf.write("\2\67\63\3\2\2\2\67\64\3\2\2\2\67\65\3\2\2\2\67\66\3\2") - buf.write("\2\28\t\3\2\2\29;\7\3\2\2:<\7\f\2\2;:\3\2\2\2;<\3\2\2") - buf.write("\2<=\3\2\2\2=?\5\f\7\2>@\7\f\2\2?>\3\2\2\2?@\3\2\2\2@") - buf.write("A\3\2\2\2AB\7\6\2\2B\13\3\2\2\2CM\5\16\b\2DF\7\f\2\2E") - buf.write("D\3\2\2\2EF\3\2\2\2FG\3\2\2\2GI\5\26\f\2HJ\7\f\2\2IH\3") - buf.write("\2\2\2IJ\3\2\2\2JK\3\2\2\2KL\5\16\b\2LN\3\2\2\2ME\3\2") - buf.write("\2\2NO\3\2\2\2OM\3\2\2\2OP\3\2\2\2P\r\3\2\2\2QX\5\b\5") - buf.write("\2RT\5\30\r\2SR\3\2\2\2ST\3\2\2\2TU\3\2\2\2UW\5\b\5\2") - buf.write("VS\3\2\2\2WZ\3\2\2\2XV\3\2\2\2XY\3\2\2\2Y\17\3\2\2\2Z") - buf.write("X\3\2\2\2[]\7\4\2\2\\^\t\2\2\2]\\\3\2\2\2]^\3\2\2\2^_") - buf.write("\3\2\2\2_`\7\f\2\2`b\5\4\3\2ac\7\f\2\2ba\3\2\2\2bc\3\2") - buf.write("\2\2cd\3\2\2\2de\7\6\2\2e\21\3\2\2\2fh\7\5\2\2gi\5\30") - buf.write("\r\2hg\3\2\2\2hi\3\2\2\2ij\3\2\2\2jl\5\4\3\2km\5\30\r") - buf.write("\2lk\3\2\2\2lm\3\2\2\2mn\3\2\2\2no\7\6\2\2o\23\3\2\2\2") - buf.write("pq\7\b\2\2q\25\3\2\2\2rs\7\b\2\2s\27\3\2\2\2tu\7\f\2\2") - buf.write("u\31\3\2\2\2vw\7\7\2\2w\33\3\2\2\2xz\7\t\2\2y{\7\13\2") - buf.write("\2zy\3\2\2\2z{\3\2\2\2{\35\3\2\2\2|~\7\n\2\2}\177\7\13") - buf.write("\2\2~}\3\2\2\2~\177\3\2\2\2\177\37\3\2\2\2\23%*/\67;?") - buf.write("EIOSX]bhlz~") - return buf.getvalue() - - -class TacticNotationsParser ( Parser ): - - grammarFileName = "TacticNotations.g" - - atn = ATNDeserializer().deserialize(serializedATN()) - - decisionsToDFA = [ DFA(ds, i) for i, ds in enumerate(atn.decisionToState) ] - - sharedContextCache = PredictionContextCache() - - literalNames = [ "", "'{|'", "", "'{'", "'}'", "", - "'|'" ] - - symbolicNames = [ "", "LALT", "LGROUP", "LBRACE", "RBRACE", - "ESCAPED", "PIPE", "ATOM", "ID", "SUB", "WHITESPACE" ] - - RULE_top = 0 - RULE_blocks = 1 - RULE_block = 2 - RULE_nopipeblock = 3 - RULE_alternative = 4 - RULE_altblocks = 5 - RULE_altblock = 6 - RULE_repeat = 7 - RULE_curlies = 8 - RULE_pipe = 9 - RULE_altsep = 10 - RULE_whitespace = 11 - RULE_escaped = 12 - RULE_atomic = 13 - RULE_hole = 14 - - ruleNames = [ "top", "blocks", "block", "nopipeblock", "alternative", - "altblocks", "altblock", "repeat", "curlies", "pipe", - "altsep", "whitespace", "escaped", "atomic", "hole" ] - - EOF = Token.EOF - LALT=1 - LGROUP=2 - LBRACE=3 - RBRACE=4 - ESCAPED=5 - PIPE=6 - ATOM=7 - ID=8 - SUB=9 - WHITESPACE=10 - - def __init__(self, input:TokenStream, output:TextIO = sys.stdout): - super().__init__(input, output) - self.checkVersion("4.7.2") - self._interp = ParserATNSimulator(self, self.atn, self.decisionsToDFA, self.sharedContextCache) - self._predicates = None - - - - class TopContext(ParserRuleContext): - - def __init__(self, parser, parent:ParserRuleContext=None, invokingState:int=-1): - super().__init__(parent, invokingState) - self.parser = parser - - def blocks(self): - return self.getTypedRuleContext(TacticNotationsParser.BlocksContext,0) - - - def EOF(self): - return self.getToken(TacticNotationsParser.EOF, 0) - - def getRuleIndex(self): - return TacticNotationsParser.RULE_top - - def accept(self, visitor:ParseTreeVisitor): - if hasattr( visitor, "visitTop" ): - return visitor.visitTop(self) - else: - return visitor.visitChildren(self) - - - - - def top(self): - - localctx = TacticNotationsParser.TopContext(self, self._ctx, self.state) - self.enterRule(localctx, 0, self.RULE_top) - try: - self.enterOuterAlt(localctx, 1) - self.state = 30 - self.blocks() - self.state = 31 - self.match(TacticNotationsParser.EOF) - except RecognitionException as re: - localctx.exception = re - self._errHandler.reportError(self, re) - self._errHandler.recover(self, re) - finally: - self.exitRule() - return localctx - - class BlocksContext(ParserRuleContext): - - def __init__(self, parser, parent:ParserRuleContext=None, invokingState:int=-1): - super().__init__(parent, invokingState) - self.parser = parser - - def block(self, i:int=None): - if i is None: - return self.getTypedRuleContexts(TacticNotationsParser.BlockContext) - else: - return self.getTypedRuleContext(TacticNotationsParser.BlockContext,i) - - - def whitespace(self, i:int=None): - if i is None: - return self.getTypedRuleContexts(TacticNotationsParser.WhitespaceContext) - else: - return self.getTypedRuleContext(TacticNotationsParser.WhitespaceContext,i) - - - def getRuleIndex(self): - return TacticNotationsParser.RULE_blocks - - def accept(self, visitor:ParseTreeVisitor): - if hasattr( visitor, "visitBlocks" ): - return visitor.visitBlocks(self) - else: - return visitor.visitChildren(self) - - - - - def blocks(self): - - localctx = TacticNotationsParser.BlocksContext(self, self._ctx, self.state) - self.enterRule(localctx, 2, self.RULE_blocks) - self._la = 0 # Token type - try: - self.enterOuterAlt(localctx, 1) - self.state = 33 - self.block() - self.state = 40 - self._errHandler.sync(self) - _alt = self._interp.adaptivePredict(self._input,1,self._ctx) - while _alt!=2 and _alt!=ATN.INVALID_ALT_NUMBER: - if _alt==1: - self.state = 35 - self._errHandler.sync(self) - _la = self._input.LA(1) - if _la==TacticNotationsParser.WHITESPACE: - self.state = 34 - self.whitespace() - - - self.state = 37 - self.block() - self.state = 42 - self._errHandler.sync(self) - _alt = self._interp.adaptivePredict(self._input,1,self._ctx) - - except RecognitionException as re: - localctx.exception = re - self._errHandler.reportError(self, re) - self._errHandler.recover(self, re) - finally: - self.exitRule() - return localctx - - class BlockContext(ParserRuleContext): - - def __init__(self, parser, parent:ParserRuleContext=None, invokingState:int=-1): - super().__init__(parent, invokingState) - self.parser = parser - - def pipe(self): - return self.getTypedRuleContext(TacticNotationsParser.PipeContext,0) - - - def nopipeblock(self): - return self.getTypedRuleContext(TacticNotationsParser.NopipeblockContext,0) - - - def getRuleIndex(self): - return TacticNotationsParser.RULE_block - - def accept(self, visitor:ParseTreeVisitor): - if hasattr( visitor, "visitBlock" ): - return visitor.visitBlock(self) - else: - return visitor.visitChildren(self) - - - - - def block(self): - - localctx = TacticNotationsParser.BlockContext(self, self._ctx, self.state) - self.enterRule(localctx, 4, self.RULE_block) - try: - self.state = 45 - self._errHandler.sync(self) - token = self._input.LA(1) - if token in [TacticNotationsParser.PIPE]: - self.enterOuterAlt(localctx, 1) - self.state = 43 - self.pipe() - pass - elif token in [TacticNotationsParser.LALT, TacticNotationsParser.LGROUP, TacticNotationsParser.LBRACE, TacticNotationsParser.ESCAPED, TacticNotationsParser.ATOM, TacticNotationsParser.ID]: - self.enterOuterAlt(localctx, 2) - self.state = 44 - self.nopipeblock() - pass - else: - raise NoViableAltException(self) - - except RecognitionException as re: - localctx.exception = re - self._errHandler.reportError(self, re) - self._errHandler.recover(self, re) - finally: - self.exitRule() - return localctx - - class NopipeblockContext(ParserRuleContext): - - def __init__(self, parser, parent:ParserRuleContext=None, invokingState:int=-1): - super().__init__(parent, invokingState) - self.parser = parser - - def atomic(self): - return self.getTypedRuleContext(TacticNotationsParser.AtomicContext,0) - - - def escaped(self): - return self.getTypedRuleContext(TacticNotationsParser.EscapedContext,0) - - - def hole(self): - return self.getTypedRuleContext(TacticNotationsParser.HoleContext,0) - - - def alternative(self): - return self.getTypedRuleContext(TacticNotationsParser.AlternativeContext,0) - - - def repeat(self): - return self.getTypedRuleContext(TacticNotationsParser.RepeatContext,0) - - - def curlies(self): - return self.getTypedRuleContext(TacticNotationsParser.CurliesContext,0) - - - def getRuleIndex(self): - return TacticNotationsParser.RULE_nopipeblock - - def accept(self, visitor:ParseTreeVisitor): - if hasattr( visitor, "visitNopipeblock" ): - return visitor.visitNopipeblock(self) - else: - return visitor.visitChildren(self) - - - - - def nopipeblock(self): - - localctx = TacticNotationsParser.NopipeblockContext(self, self._ctx, self.state) - self.enterRule(localctx, 6, self.RULE_nopipeblock) - try: - self.state = 53 - self._errHandler.sync(self) - token = self._input.LA(1) - if token in [TacticNotationsParser.ATOM]: - self.enterOuterAlt(localctx, 1) - self.state = 47 - self.atomic() - pass - elif token in [TacticNotationsParser.ESCAPED]: - self.enterOuterAlt(localctx, 2) - self.state = 48 - self.escaped() - pass - elif token in [TacticNotationsParser.ID]: - self.enterOuterAlt(localctx, 3) - self.state = 49 - self.hole() - pass - elif token in [TacticNotationsParser.LALT]: - self.enterOuterAlt(localctx, 4) - self.state = 50 - self.alternative() - pass - elif token in [TacticNotationsParser.LGROUP]: - self.enterOuterAlt(localctx, 5) - self.state = 51 - self.repeat() - pass - elif token in [TacticNotationsParser.LBRACE]: - self.enterOuterAlt(localctx, 6) - self.state = 52 - self.curlies() - pass - else: - raise NoViableAltException(self) - - except RecognitionException as re: - localctx.exception = re - self._errHandler.reportError(self, re) - self._errHandler.recover(self, re) - finally: - self.exitRule() - return localctx - - class AlternativeContext(ParserRuleContext): - - def __init__(self, parser, parent:ParserRuleContext=None, invokingState:int=-1): - super().__init__(parent, invokingState) - self.parser = parser - - def LALT(self): - return self.getToken(TacticNotationsParser.LALT, 0) - - def altblocks(self): - return self.getTypedRuleContext(TacticNotationsParser.AltblocksContext,0) - - - def RBRACE(self): - return self.getToken(TacticNotationsParser.RBRACE, 0) - - def WHITESPACE(self, i:int=None): - if i is None: - return self.getTokens(TacticNotationsParser.WHITESPACE) - else: - return self.getToken(TacticNotationsParser.WHITESPACE, i) - - def getRuleIndex(self): - return TacticNotationsParser.RULE_alternative - - def accept(self, visitor:ParseTreeVisitor): - if hasattr( visitor, "visitAlternative" ): - return visitor.visitAlternative(self) - else: - return visitor.visitChildren(self) - - - - - def alternative(self): - - localctx = TacticNotationsParser.AlternativeContext(self, self._ctx, self.state) - self.enterRule(localctx, 8, self.RULE_alternative) - self._la = 0 # Token type - try: - self.enterOuterAlt(localctx, 1) - self.state = 55 - self.match(TacticNotationsParser.LALT) - self.state = 57 - self._errHandler.sync(self) - _la = self._input.LA(1) - if _la==TacticNotationsParser.WHITESPACE: - self.state = 56 - self.match(TacticNotationsParser.WHITESPACE) - - - self.state = 59 - self.altblocks() - self.state = 61 - self._errHandler.sync(self) - _la = self._input.LA(1) - if _la==TacticNotationsParser.WHITESPACE: - self.state = 60 - self.match(TacticNotationsParser.WHITESPACE) - - - self.state = 63 - self.match(TacticNotationsParser.RBRACE) - except RecognitionException as re: - localctx.exception = re - self._errHandler.reportError(self, re) - self._errHandler.recover(self, re) - finally: - self.exitRule() - return localctx - - class AltblocksContext(ParserRuleContext): - - def __init__(self, parser, parent:ParserRuleContext=None, invokingState:int=-1): - super().__init__(parent, invokingState) - self.parser = parser - - def altblock(self, i:int=None): - if i is None: - return self.getTypedRuleContexts(TacticNotationsParser.AltblockContext) - else: - return self.getTypedRuleContext(TacticNotationsParser.AltblockContext,i) - - - def altsep(self, i:int=None): - if i is None: - return self.getTypedRuleContexts(TacticNotationsParser.AltsepContext) - else: - return self.getTypedRuleContext(TacticNotationsParser.AltsepContext,i) - - - def WHITESPACE(self, i:int=None): - if i is None: - return self.getTokens(TacticNotationsParser.WHITESPACE) - else: - return self.getToken(TacticNotationsParser.WHITESPACE, i) - - def getRuleIndex(self): - return TacticNotationsParser.RULE_altblocks - - def accept(self, visitor:ParseTreeVisitor): - if hasattr( visitor, "visitAltblocks" ): - return visitor.visitAltblocks(self) - else: - return visitor.visitChildren(self) - - - - - def altblocks(self): - - localctx = TacticNotationsParser.AltblocksContext(self, self._ctx, self.state) - self.enterRule(localctx, 10, self.RULE_altblocks) - self._la = 0 # Token type - try: - self.enterOuterAlt(localctx, 1) - self.state = 65 - self.altblock() - self.state = 75 - self._errHandler.sync(self) - _alt = 1 - while _alt!=2 and _alt!=ATN.INVALID_ALT_NUMBER: - if _alt == 1: - self.state = 67 - self._errHandler.sync(self) - _la = self._input.LA(1) - if _la==TacticNotationsParser.WHITESPACE: - self.state = 66 - self.match(TacticNotationsParser.WHITESPACE) - - - self.state = 69 - self.altsep() - self.state = 71 - self._errHandler.sync(self) - _la = self._input.LA(1) - if _la==TacticNotationsParser.WHITESPACE: - self.state = 70 - self.match(TacticNotationsParser.WHITESPACE) - - - self.state = 73 - self.altblock() - - else: - raise NoViableAltException(self) - self.state = 77 - self._errHandler.sync(self) - _alt = self._interp.adaptivePredict(self._input,8,self._ctx) - - except RecognitionException as re: - localctx.exception = re - self._errHandler.reportError(self, re) - self._errHandler.recover(self, re) - finally: - self.exitRule() - return localctx - - class AltblockContext(ParserRuleContext): - - def __init__(self, parser, parent:ParserRuleContext=None, invokingState:int=-1): - super().__init__(parent, invokingState) - self.parser = parser - - def nopipeblock(self, i:int=None): - if i is None: - return self.getTypedRuleContexts(TacticNotationsParser.NopipeblockContext) - else: - return self.getTypedRuleContext(TacticNotationsParser.NopipeblockContext,i) - - - def whitespace(self, i:int=None): - if i is None: - return self.getTypedRuleContexts(TacticNotationsParser.WhitespaceContext) - else: - return self.getTypedRuleContext(TacticNotationsParser.WhitespaceContext,i) - - - def getRuleIndex(self): - return TacticNotationsParser.RULE_altblock - - def accept(self, visitor:ParseTreeVisitor): - if hasattr( visitor, "visitAltblock" ): - return visitor.visitAltblock(self) - else: - return visitor.visitChildren(self) - - - - - def altblock(self): - - localctx = TacticNotationsParser.AltblockContext(self, self._ctx, self.state) - self.enterRule(localctx, 12, self.RULE_altblock) - self._la = 0 # Token type - try: - self.enterOuterAlt(localctx, 1) - self.state = 79 - self.nopipeblock() - self.state = 86 - self._errHandler.sync(self) - _alt = self._interp.adaptivePredict(self._input,10,self._ctx) - while _alt!=2 and _alt!=ATN.INVALID_ALT_NUMBER: - if _alt==1: - self.state = 81 - self._errHandler.sync(self) - _la = self._input.LA(1) - if _la==TacticNotationsParser.WHITESPACE: - self.state = 80 - self.whitespace() - - - self.state = 83 - self.nopipeblock() - self.state = 88 - self._errHandler.sync(self) - _alt = self._interp.adaptivePredict(self._input,10,self._ctx) - - except RecognitionException as re: - localctx.exception = re - self._errHandler.reportError(self, re) - self._errHandler.recover(self, re) - finally: - self.exitRule() - return localctx - - class RepeatContext(ParserRuleContext): - - def __init__(self, parser, parent:ParserRuleContext=None, invokingState:int=-1): - super().__init__(parent, invokingState) - self.parser = parser - - def LGROUP(self): - return self.getToken(TacticNotationsParser.LGROUP, 0) - - def WHITESPACE(self, i:int=None): - if i is None: - return self.getTokens(TacticNotationsParser.WHITESPACE) - else: - return self.getToken(TacticNotationsParser.WHITESPACE, i) - - def blocks(self): - return self.getTypedRuleContext(TacticNotationsParser.BlocksContext,0) - - - def RBRACE(self): - return self.getToken(TacticNotationsParser.RBRACE, 0) - - def ATOM(self): - return self.getToken(TacticNotationsParser.ATOM, 0) - - def PIPE(self): - return self.getToken(TacticNotationsParser.PIPE, 0) - - def getRuleIndex(self): - return TacticNotationsParser.RULE_repeat - - def accept(self, visitor:ParseTreeVisitor): - if hasattr( visitor, "visitRepeat" ): - return visitor.visitRepeat(self) - else: - return visitor.visitChildren(self) - - - - - def repeat(self): - - localctx = TacticNotationsParser.RepeatContext(self, self._ctx, self.state) - self.enterRule(localctx, 14, self.RULE_repeat) - self._la = 0 # Token type - try: - self.enterOuterAlt(localctx, 1) - self.state = 89 - self.match(TacticNotationsParser.LGROUP) - self.state = 91 - self._errHandler.sync(self) - _la = self._input.LA(1) - if _la==TacticNotationsParser.PIPE or _la==TacticNotationsParser.ATOM: - self.state = 90 - _la = self._input.LA(1) - if not(_la==TacticNotationsParser.PIPE or _la==TacticNotationsParser.ATOM): - self._errHandler.recoverInline(self) - else: - self._errHandler.reportMatch(self) - self.consume() - - - self.state = 93 - self.match(TacticNotationsParser.WHITESPACE) - self.state = 94 - self.blocks() - self.state = 96 - self._errHandler.sync(self) - _la = self._input.LA(1) - if _la==TacticNotationsParser.WHITESPACE: - self.state = 95 - self.match(TacticNotationsParser.WHITESPACE) - - - self.state = 98 - self.match(TacticNotationsParser.RBRACE) - except RecognitionException as re: - localctx.exception = re - self._errHandler.reportError(self, re) - self._errHandler.recover(self, re) - finally: - self.exitRule() - return localctx - - class CurliesContext(ParserRuleContext): - - def __init__(self, parser, parent:ParserRuleContext=None, invokingState:int=-1): - super().__init__(parent, invokingState) - self.parser = parser - - def LBRACE(self): - return self.getToken(TacticNotationsParser.LBRACE, 0) - - def blocks(self): - return self.getTypedRuleContext(TacticNotationsParser.BlocksContext,0) - - - def RBRACE(self): - return self.getToken(TacticNotationsParser.RBRACE, 0) - - def whitespace(self, i:int=None): - if i is None: - return self.getTypedRuleContexts(TacticNotationsParser.WhitespaceContext) - else: - return self.getTypedRuleContext(TacticNotationsParser.WhitespaceContext,i) - - - def getRuleIndex(self): - return TacticNotationsParser.RULE_curlies - - def accept(self, visitor:ParseTreeVisitor): - if hasattr( visitor, "visitCurlies" ): - return visitor.visitCurlies(self) - else: - return visitor.visitChildren(self) - - - - - def curlies(self): - - localctx = TacticNotationsParser.CurliesContext(self, self._ctx, self.state) - self.enterRule(localctx, 16, self.RULE_curlies) - self._la = 0 # Token type - try: - self.enterOuterAlt(localctx, 1) - self.state = 100 - self.match(TacticNotationsParser.LBRACE) - self.state = 102 - self._errHandler.sync(self) - _la = self._input.LA(1) - if _la==TacticNotationsParser.WHITESPACE: - self.state = 101 - self.whitespace() - - - self.state = 104 - self.blocks() - self.state = 106 - self._errHandler.sync(self) - _la = self._input.LA(1) - if _la==TacticNotationsParser.WHITESPACE: - self.state = 105 - self.whitespace() - - - self.state = 108 - self.match(TacticNotationsParser.RBRACE) - except RecognitionException as re: - localctx.exception = re - self._errHandler.reportError(self, re) - self._errHandler.recover(self, re) - finally: - self.exitRule() - return localctx - - class PipeContext(ParserRuleContext): - - def __init__(self, parser, parent:ParserRuleContext=None, invokingState:int=-1): - super().__init__(parent, invokingState) - self.parser = parser - - def PIPE(self): - return self.getToken(TacticNotationsParser.PIPE, 0) - - def getRuleIndex(self): - return TacticNotationsParser.RULE_pipe - - def accept(self, visitor:ParseTreeVisitor): - if hasattr( visitor, "visitPipe" ): - return visitor.visitPipe(self) - else: - return visitor.visitChildren(self) - - - - - def pipe(self): - - localctx = TacticNotationsParser.PipeContext(self, self._ctx, self.state) - self.enterRule(localctx, 18, self.RULE_pipe) - try: - self.enterOuterAlt(localctx, 1) - self.state = 110 - self.match(TacticNotationsParser.PIPE) - except RecognitionException as re: - localctx.exception = re - self._errHandler.reportError(self, re) - self._errHandler.recover(self, re) - finally: - self.exitRule() - return localctx - - class AltsepContext(ParserRuleContext): - - def __init__(self, parser, parent:ParserRuleContext=None, invokingState:int=-1): - super().__init__(parent, invokingState) - self.parser = parser - - def PIPE(self): - return self.getToken(TacticNotationsParser.PIPE, 0) - - def getRuleIndex(self): - return TacticNotationsParser.RULE_altsep - - def accept(self, visitor:ParseTreeVisitor): - if hasattr( visitor, "visitAltsep" ): - return visitor.visitAltsep(self) - else: - return visitor.visitChildren(self) - - - - - def altsep(self): - - localctx = TacticNotationsParser.AltsepContext(self, self._ctx, self.state) - self.enterRule(localctx, 20, self.RULE_altsep) - try: - self.enterOuterAlt(localctx, 1) - self.state = 112 - self.match(TacticNotationsParser.PIPE) - except RecognitionException as re: - localctx.exception = re - self._errHandler.reportError(self, re) - self._errHandler.recover(self, re) - finally: - self.exitRule() - return localctx - - class WhitespaceContext(ParserRuleContext): - - def __init__(self, parser, parent:ParserRuleContext=None, invokingState:int=-1): - super().__init__(parent, invokingState) - self.parser = parser - - def WHITESPACE(self): - return self.getToken(TacticNotationsParser.WHITESPACE, 0) - - def getRuleIndex(self): - return TacticNotationsParser.RULE_whitespace - - def accept(self, visitor:ParseTreeVisitor): - if hasattr( visitor, "visitWhitespace" ): - return visitor.visitWhitespace(self) - else: - return visitor.visitChildren(self) - - - - - def whitespace(self): - - localctx = TacticNotationsParser.WhitespaceContext(self, self._ctx, self.state) - self.enterRule(localctx, 22, self.RULE_whitespace) - try: - self.enterOuterAlt(localctx, 1) - self.state = 114 - self.match(TacticNotationsParser.WHITESPACE) - except RecognitionException as re: - localctx.exception = re - self._errHandler.reportError(self, re) - self._errHandler.recover(self, re) - finally: - self.exitRule() - return localctx - - class EscapedContext(ParserRuleContext): - - def __init__(self, parser, parent:ParserRuleContext=None, invokingState:int=-1): - super().__init__(parent, invokingState) - self.parser = parser - - def ESCAPED(self): - return self.getToken(TacticNotationsParser.ESCAPED, 0) - - def getRuleIndex(self): - return TacticNotationsParser.RULE_escaped - - def accept(self, visitor:ParseTreeVisitor): - if hasattr( visitor, "visitEscaped" ): - return visitor.visitEscaped(self) - else: - return visitor.visitChildren(self) - - - - - def escaped(self): - - localctx = TacticNotationsParser.EscapedContext(self, self._ctx, self.state) - self.enterRule(localctx, 24, self.RULE_escaped) - try: - self.enterOuterAlt(localctx, 1) - self.state = 116 - self.match(TacticNotationsParser.ESCAPED) - except RecognitionException as re: - localctx.exception = re - self._errHandler.reportError(self, re) - self._errHandler.recover(self, re) - finally: - self.exitRule() - return localctx - - class AtomicContext(ParserRuleContext): - - def __init__(self, parser, parent:ParserRuleContext=None, invokingState:int=-1): - super().__init__(parent, invokingState) - self.parser = parser - - def ATOM(self): - return self.getToken(TacticNotationsParser.ATOM, 0) - - def SUB(self): - return self.getToken(TacticNotationsParser.SUB, 0) - - def getRuleIndex(self): - return TacticNotationsParser.RULE_atomic - - def accept(self, visitor:ParseTreeVisitor): - if hasattr( visitor, "visitAtomic" ): - return visitor.visitAtomic(self) - else: - return visitor.visitChildren(self) - - - - - def atomic(self): - - localctx = TacticNotationsParser.AtomicContext(self, self._ctx, self.state) - self.enterRule(localctx, 26, self.RULE_atomic) - self._la = 0 # Token type - try: - self.enterOuterAlt(localctx, 1) - self.state = 118 - self.match(TacticNotationsParser.ATOM) - self.state = 120 - self._errHandler.sync(self) - _la = self._input.LA(1) - if _la==TacticNotationsParser.SUB: - self.state = 119 - self.match(TacticNotationsParser.SUB) - - - except RecognitionException as re: - localctx.exception = re - self._errHandler.reportError(self, re) - self._errHandler.recover(self, re) - finally: - self.exitRule() - return localctx - - class HoleContext(ParserRuleContext): - - def __init__(self, parser, parent:ParserRuleContext=None, invokingState:int=-1): - super().__init__(parent, invokingState) - self.parser = parser - - def ID(self): - return self.getToken(TacticNotationsParser.ID, 0) - - def SUB(self): - return self.getToken(TacticNotationsParser.SUB, 0) - - def getRuleIndex(self): - return TacticNotationsParser.RULE_hole - - def accept(self, visitor:ParseTreeVisitor): - if hasattr( visitor, "visitHole" ): - return visitor.visitHole(self) - else: - return visitor.visitChildren(self) - - - - - def hole(self): - - localctx = TacticNotationsParser.HoleContext(self, self._ctx, self.state) - self.enterRule(localctx, 28, self.RULE_hole) - self._la = 0 # Token type - try: - self.enterOuterAlt(localctx, 1) - self.state = 122 - self.match(TacticNotationsParser.ID) - self.state = 124 - self._errHandler.sync(self) - _la = self._input.LA(1) - if _la==TacticNotationsParser.SUB: - self.state = 123 - self.match(TacticNotationsParser.SUB) - - - except RecognitionException as re: - localctx.exception = re - self._errHandler.reportError(self, re) - self._errHandler.recover(self, re) - finally: - self.exitRule() - return localctx diff --git a/stdlib/doc/tools/coqrst/notations/TacticNotationsVisitor.py b/stdlib/doc/tools/coqrst/notations/TacticNotationsVisitor.py deleted file mode 100644 index aba696c89f72..000000000000 --- a/stdlib/doc/tools/coqrst/notations/TacticNotationsVisitor.py +++ /dev/null @@ -1,88 +0,0 @@ -# Generated from TacticNotations.g by ANTLR 4.7.2 -from antlr4 import * -if __name__ is not None and "." in __name__: - from .TacticNotationsParser import TacticNotationsParser -else: - from TacticNotationsParser import TacticNotationsParser - -# This class defines a complete generic visitor for a parse tree produced by TacticNotationsParser. - -class TacticNotationsVisitor(ParseTreeVisitor): - - # Visit a parse tree produced by TacticNotationsParser#top. - def visitTop(self, ctx:TacticNotationsParser.TopContext): - return self.visitChildren(ctx) - - - # Visit a parse tree produced by TacticNotationsParser#blocks. - def visitBlocks(self, ctx:TacticNotationsParser.BlocksContext): - return self.visitChildren(ctx) - - - # Visit a parse tree produced by TacticNotationsParser#block. - def visitBlock(self, ctx:TacticNotationsParser.BlockContext): - return self.visitChildren(ctx) - - - # Visit a parse tree produced by TacticNotationsParser#nopipeblock. - def visitNopipeblock(self, ctx:TacticNotationsParser.NopipeblockContext): - return self.visitChildren(ctx) - - - # Visit a parse tree produced by TacticNotationsParser#alternative. - def visitAlternative(self, ctx:TacticNotationsParser.AlternativeContext): - return self.visitChildren(ctx) - - - # Visit a parse tree produced by TacticNotationsParser#altblocks. - def visitAltblocks(self, ctx:TacticNotationsParser.AltblocksContext): - return self.visitChildren(ctx) - - - # Visit a parse tree produced by TacticNotationsParser#altblock. - def visitAltblock(self, ctx:TacticNotationsParser.AltblockContext): - return self.visitChildren(ctx) - - - # Visit a parse tree produced by TacticNotationsParser#repeat. - def visitRepeat(self, ctx:TacticNotationsParser.RepeatContext): - return self.visitChildren(ctx) - - - # Visit a parse tree produced by TacticNotationsParser#curlies. - def visitCurlies(self, ctx:TacticNotationsParser.CurliesContext): - return self.visitChildren(ctx) - - - # Visit a parse tree produced by TacticNotationsParser#pipe. - def visitPipe(self, ctx:TacticNotationsParser.PipeContext): - return self.visitChildren(ctx) - - - # Visit a parse tree produced by TacticNotationsParser#altsep. - def visitAltsep(self, ctx:TacticNotationsParser.AltsepContext): - return self.visitChildren(ctx) - - - # Visit a parse tree produced by TacticNotationsParser#whitespace. - def visitWhitespace(self, ctx:TacticNotationsParser.WhitespaceContext): - return self.visitChildren(ctx) - - - # Visit a parse tree produced by TacticNotationsParser#escaped. - def visitEscaped(self, ctx:TacticNotationsParser.EscapedContext): - return self.visitChildren(ctx) - - - # Visit a parse tree produced by TacticNotationsParser#atomic. - def visitAtomic(self, ctx:TacticNotationsParser.AtomicContext): - return self.visitChildren(ctx) - - - # Visit a parse tree produced by TacticNotationsParser#hole. - def visitHole(self, ctx:TacticNotationsParser.HoleContext): - return self.visitChildren(ctx) - - - -del TacticNotationsParser diff --git a/stdlib/doc/tools/coqrst/notations/UbuntuMono-B.ttf b/stdlib/doc/tools/coqrst/notations/UbuntuMono-B.ttf deleted file mode 100644 index 7bd6665765768ae885e2868623e7e9c2fd0cfc8a..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 191400 zcmcG%d3;pW`9J=gduQMGnaoUP?qrfo_DuE!0yBgV0t84{BrJgdA%L<3L-YWRJ2&s=o_p>& z&w0-FoaZbvAx1=25CvK4CypBFTQz$w32(0?N{f!1IJwT8oVJIAU)2)j){dW8TzbbB z^m`(<1+m(%s2|(9sP^g)hzx!rW$)a@v%9`s*&GAI3q-2h=3cu(stM$F5(N(<&b6Ig z^A}(HT>Swe&pNyh&!2sDS29T=_?Ls9X8xj8oy9+^HxX5=Cn3IQ!MxcW=Uxcf5EuNZ zasfP)74!t2C*e7B!QvGwD_$%r#`Ae1UB;rNb7!jt-O@-DswZ;PFP^=!OW&=181IoE zl9tR~Jn!zaU#%hGnsdnT9bHSWUQzbJ?sFtu-%V7st84kZu5Vjk`Xf4Fm;Xbea?fKXF{k30?PbO|iULpKkj3KO+gj5Vp#i7Y7z~fwUdUCq( z^L~FGDfMC8M`=MmCexLqMobG8(^U99q5d68gptV33HwM%Bmo`Zs*_ z8m*`jL_yI@Lb92p=>x3mhm9RZ5>fJ^@N{xIm54*>*LZyR3Zy7#gr^Zs;@rU}^?8D( zkc~1RgOmP1Ga*qC< zA+`h8aQHq4IPvZVv>*dw52ZoW1zB=v9c0>!D;KesBPP)__*Bw^vdOvjA=mt> z1tR^I5pRRY=?|A1?qL6wi5&7P2mI16T{&Km*9i@a#SKuHk1V~v;Tw- zWqUaasS07!AXDc5Kqh(cHV>s!2tFJm5$ZA|zr}MA{0E>-{#|zaAnyPw<$4Q)`&8tL zw}BMW5O)9(|? zvip!KbR(qUeJ6%I2a|{4s|6&4Dd8N7zi#$@LLIf6>Z) zG*#+exwH$x+lTiRi1QrHKq);T=THlpYC$}|yiM|U#8dchwaLqCpw+q&D%BEs{DHRO zMGi{(IrH}c@Z)VO6_3Z^C7K|K{B9j;A%s97bT$5SEv z-H4qba|%G}0@PDIa_xa6CMp9Lep&H67-hoU1+upDAZ!epT*8%#?*S(VVgC)&S^0ai zh^<7r1K=EaUNUg;{^SG~-jmyr0xuISB;a-8!V|AAUPn^Dw0?v%0(yXJhDzisNO9b` zM46y=lz<8SCsh}PxM!lAcx`wnE%`}ub@IyOVyaAbC#R7y*$p0X#7d0?=?Gbd(n_PB z(Qk0)BkpBavN!p9;`^jKS((gDUYA^nn3t~PRms(f?TJ4nUP}BP{C;#LrzJZRn-jlH z^dufie4F^TKebevpvjJ8d*bJbrxSYb z;zP*$qYJW(Ox%#zns`0&Tq2oB$a&zBa;bQ#oIB^iV_lX%?oR$X`B38J#7Bwm68}gR zC3$`R=t{OE+Y+}Ur%xmvO!Ovtf1EN(_`jw7LmFsl$@$5RsJq`l6aNN%dFBuNlQqe@ zWF*P;Qk=%o5?NL!+6R{zy*8PZ45IHh;tiKR8yA<2yN#&JD#V>4``-G4R7pp&KJo8l z8B)BJeuLaSk@$1sT+){`C1)ht{8kT7$1>nxYc=&IWzXTcq{TJF(257EK^U%)EqvvOV7Ra=avf(bGNb)<3#5tf* z$^|WvX({EwT}Jt!<)Gi9PZxq>oC2+qX*CtYT|-gOK~$3b27SL2v{t4=s0{9*R1O-W z3Q*{YkhxdpK2t)}wyUVZ0v%+CYPoU&Hp|w2^8-N6`?_(KHlv46K2#sfpsr zuQ1vS105&R@l*$QGYtoAp?c5>p#Oxm+W;~McG6_f`E&*70-6H4 zkXk{nl<8G8HQ5K7dm89snhv^zW`Hi0X&23edl~5Gu!UxUUQO-E&u9hB2E9h6*U}ug zucHpol{61@l}xXv&g4I6wM^I0e7M)r0?-@iO3)i++D%u%eUnUYrbTeyLW@Dy(Gt*G zK|jT)-UWKQOxM#gxbL9lpd09F(2by<&?dSD^e1#J=$$gXi>`xvGpz)@8}wtkhgN~! zOV@+mN2@{ar!}BIrM0k~eFMr5Um4!Sf<

;rag2I+`H)B>sPuoCWphrMol<79R&Rn z^v`sbUIG0ly$br3Ouwer;66vMgMLGYlkd^DGX0K@zGqkz7ZPu23EqVSR-p; z6WJ^_n_b6lWOuWB1h?Q5DupUxyl@ZJDP9p?6;6s)@iuXTxJleBJ|g}~>=9oT-%!j_ z%vD^Y_*dZ8z}G=%Fg-XTI5s#XI5jvu*cMzH+#Ng+d?)x}@XO%2U_x?AUMV1DNZC?U z8YIYTS zJX(>*v`cyH_+Rqaj6B}mpGW#ebzb*9lk>=u|4M$7Jd^xu^26kb1RGV{n7C= znZ1iYT5)<(@5DNxb zar&jx`%XW7`gaI*^Xcn9JRLsmID<+1dhK?!-M^;Va4Nk^^e9{dxa8UIz^Wv42SFe3 z&kq#k@_+I919aMp&{O=AqW?Yell|V$|M%Db;k)&+=htL+iY~_Zb`{3E>(M$VqJ2(g zSFkCpl@`kVaSofyI_MfUPkc{2F1{!p5?>RKiU-m6UKbCGN5nV8W8$0Q+u~c|JL0<- zO;?B;G2$-8xZQgR;m;i6<;ZpiVKRfN>TA|#g|G!@h`04uu)HeeLCUny+9 za@cy6u<@#4+YLfrsHGvW<6^MihEW}CwtCoV4Y1J~VVjMHP1XckY#e3=&9J>Dpf~YV z-YZ~ZwZgWV2AgUIY^j;Bq1s_PVP%%KVf5aPQFs@|(R~;*pTqe0JVwVCF%rInaqu8U zzE|i~jCqGKz8%5n_7>XoyJ)fR(VtOg8)4hrKsTf2?#8%#2ke(?=`Om3{SvmpQ|vL? z#GYU~pvgD02T*@o#XW30tegAULl}GCp$BLU-Oe7R4)!>E5cbYbVY97<f@SeE zJwv;h0k+>Yv;pG=+9}=3=CKYoizpszojhscgqG&<$DoRN~sV9Mg=3n4ee4-c6*N^JKWe<$e+Wr z;W7I%kM#66`KWw#<*elX%86haJXgl9p$)Wh1P5j_ppF4!=ly}q!3?b7RphlkJ8 z6&BDgogPj-Ts=AAu3ao=D3cvR&WJ&~1kxCJvOQwfh}j)I%`L4X>V2WmRN0S)%e;D2 z!+X>+FKJ;9WTuVMu7dp=Htn&{oc4S}N4R75jMg4;HX>~hM{L+|dyh50CpTQ*lY9Lc z4+?NzPeHhTL{EMgf{mGQDFN1_%(8@~4c`!i5BGfzsW0=H-S4ByvV24QCC}oeV(LM? z_ZJyKHb{v4g+g4GjeFuW2M;~nEv>0%iRSozPx0dXsXanFf3tt!jdL=8(>?I!QuOvP zN_IqeM0@|=wF^8w-E*YE0@SShm(`=l!h5Ml%x<4EcLBf8p0^=fj~t>bX;N!XydIAD z?EbIiG{ovT3UOG!(Ba&a9ygj;Q=ODBNk3OBQ~^lboK<>eI00@ol>hW z)DxeI;+q<7oi~-&QrOay+l%DzK?TaOkhlK`JrEe#?onrHq*lQvPUW=)52*npTvv-1 zmL65=k=JNlt<=hVG!P7_^oQWCAMwG1m^Hi+k#R@V;f=l!8n^uUKZxW@WdLIIXfDa5 zfDp~MpM$D_fOu!#8#e*zhKezubr@+gizc3(zhF51J&qHB>0JntK znjQi9l)ZQ@dZZp|mRiH}!c)U&L-FQTUOBw1<@y~nF+8SaTB}^!{jFrukDgNRt1rFl zcl8Lv(EuCrST41FxkGn(&y38+gj$eugA%7}Y~)vT=0RYFl|K zLDm3G8E%*zmMl`khS__P-E%hVipMu}jc8vm2>oC~cvQ!R@Wj?yRHoeV*ZQvK$=hfQ z8#Ae{umH-ZZdaJCZ`l=R>nBcY-HTljY5k`6{ijYujC;(`|5mE;)oHbJyY-pd# zn>M*nkoaRgEIgEYgz(T^Oi&qmbm4h*J^FAR_m6S^Sju0;{ng>R9_C_&6yJ93lHA}m zOFM!qmUje~56=xQgS%@)|(im^D~j7poI~u{AGf%ri_@ z<|!uAR?AkwoM)P>&(lp-=cy*MJesV{(@Ylg1dLyM7(L};O16h>9rt)mp~=&xx9(!>&Z)QlTdy5XSoT`sDdnx9Yk z@@EAoyPEP@$_KapSKP(J{NUpup@)>hRb=9TrTz`@HG7ZmX(hkLKJ-NaJKI<{{D1jb z16!gKXof{Xa5ckLCDQC#(la!$zASJR{hIBCPbhBRntU)Aa&0H0pUc^0HiL z!K&30qD?r5H35DyA@!Mo+vUK_0(Lox5^w<ds0;NP05cLzCMMO@z*(GKXa?Y~ zcL3nQ&r=xI6B!ZLQ~=;Sf_V~=#RIG)vf;h$1d&|>AdGzlun%V*5Z?jbE}TIYe7OODUj_J8Y{!Nt(yWRDJw(;G*IXbPv;vb-@EMHvweYJ&ydl-V9-^T@ z47_6dVOh2k4FkVn-9&Zez!swV^}ueT5r{wHbD{>w(Xf+fWD{_Xs1f(Zl>m5;Lio}5 z0m#!B$kQ|f*qp*x1<}|;MB_FQjsJwG`7lw7gJ=T6Oo0C+xF;jbWbl}L6zC;mXX`0P2A*U<+^n_?&3f9-`}y z0!VXpCeRG51hxZ*f%8ObBmn+v6#)3GMclRLh;Hx$O~48O;cr0r8zEEoHUK=k5%;D{ z0AX$d&zsARcdn@AHia57{@9kZ{R-*NY zyFLflLv#n?+<`b7;I{$%HY_08*bE@f#tS(7vkuq^90ic>PY~`W;CUy)+u5C8k&|I;l*TM%x`9-^P`26~Ae!1Dv}e{d@Rc^*7VwAByP14w%--u+@TfbhTg zgy0MdB;C;-1-A|Jn;0c-;H0B3O|2<{z7W5)%eUmYjhK`E5CX@K0)hb3{Fph<4%qQ!9y{ZYO$n8_{08|HC?> zeYHf-JBa?Yf@uFvq8IW0CCGAMeQN3Gl>(wen{dMH1kvkpEKVIDdZV7`%}a zP5|#u9tKVTp92?&P8k3{Pyob%Nx%YN4X_yizf*ev#5)CM^p*ny)& zUoRj!S55Ry6L5j(+eJj*!TsHNqVqe6{&gSGzai)Mi1R)CF6<_{xE`ybn}Dsbu)46K z6$iFq@3a*-N=#TpOjH27i77gWDQk(TqQuk%#5B#sv<~1LF&*CPHxV_C3;U~dQLf8=G4s&cLmU)y|76AnScx59@1o?|VuE;RB{Ie3@X0tUyAySPf*YSx0OT!Vd05}VdUY&_k>Zer;!n%><8` z`-#n(M68_v@Mu3wY_?GFF1#BfY4{_%q{dujxCIEh&i-^rf zy!i)!bHo-%0OBs#0~{i@5OOR;-WDDub|u1Gd5jqB3bqJg7cT(r1GW=e;s7#%a-bf7 zTuUJL5`}tflx|i6BE@IcfeJueyfqlfT+ks=h z2Z*gQ0J{OWuZL`_?<2NG14Mxn#MU+vyP*Ks3~VEIBi`NU0djzqz#__7LQG=om4KyKGw*u}2`=qaFZ$k3ojVE)d(khS=lq zdmMhhoJ8yi@PFbgv0pV4`}KNY3$TOOZ;;M!5a%~5fb+z5BK&W+5_=M5^5hv}zr(xV zL9U*a#CE}N*9l_3N8G0*AWCd^HL<7R|4c2hXK{ZP{GUbI&u%BS2lDSN0KoGPi2p|q zu#?!n8N{Ab00{GZJ+VI_&VD}t8TM}j4gnX4y@0qc)B;Ta;=h1*FZ2+5aS;Ibi{Seb zlK7O1m1^`{vq%_)JyEua$o_lh1hF&|GI+MVFLg;j;tj1#v}mgzX6_a90pDRp92?& zy@_yd`hf!g!oPWj*wH3n2CxV?3?Tf`&jEyg>nMOU-#Sa|Z32*&cN_rHJ%;q(-AwE~ z$ouDNV#gbSbHv_3A9NA>5aB=U0rmq&iJd^a6Q2O*iNRiArx529(mA~zI72Z#e*0Qme3 zY5(m!vA<^m%>crDjJO|{104Xue0&H%m`@6Tc3?fw10d|D2>U6*ehU9jA@`?yfL>z% zFaWgx()q_W0O|Y#JU)|vCSWD79f1F57l?hH1GEC*@%cXBb7Fl6+cybV10ZZ4!uBET z7YO?W{J-c1b^^zVeW?H-$CnF$Ex;iFVb4YZ@I8yLXA$-+!u}Is{|Wzp&H&Z}JplZ_ z(g4)}czm@5*bjU{>}v-Q2NnVF{~G>Z!~dKIXarUQJAmWFzR>{S{SA13vmV$D^b-5l z0Mr6qz&7A0vF{+qchx{UfUw^o>~{!z9%0YJ|9l6q8Q25B|6kz!FYx|XE6@$>0Kn&8 z=ZXDW0vdrXU<;aAfpAfr9Kon>P zHUs;Cv&0e-&1rt;V;5pgujUJ3dB`x1>jaj0X(Z_0Q|li zfWI1X)o}oE)tdpNrG^Ze?IdXNPP>K#T>$_Yb?borzy*8>BnN`rgDop~;O9ZOG=xio3~7zPA`-l3Q;*+f`d29A-CZ2;;4$e6tYfM3J` zAbey$2|0M5vyy~d1+Wg-M?xO>!$nv`1l~_1&#|#s7v^V`)8i)7G6yZydsXghtQLbnvDn2o zz^Lz7UrCfXOoBRGBvw?E*&V8IMs`JcWm&0<4HL1M->Foq#5)aTl2pdQUdgPfD3_#) z@|w);7f(bA3L@DB1w6ee>`wNu@C4Gsw}0YRw!~;&68AA-vu~TP$0z#sB=^S+T63e% z?{k{Asf^nw_HyjyVhEAnHf!0%Q(O?|B}u|RIC1(wt5Y^Aby`)OQma>v;W5l_Hg}g4a$dE&uKPV~$`znX9ils59Cyf-$A^G*5ZH4-t>M{;zSVp)itOhE|05`~n^v*zYdT0933C{V~cB@Mo>D^s(Z;;=a;i%X{zjSx)sGD2Y~OXGf}BuCmg~ zit-{Mg2rAxRH&*bbGlq^b#`_*L*;Y?1b0A`+nqD~LTs!(Te>1zU0@AG1L@TTK69ut zvb<=d!=FArFPdfaWqTuaQJ*DiNYQew%CDbePD>BkyiTiL=gq2!_{$4I+SxM{4$XXn zJ;QBrTFhE=D1T7IS5X*JUxiLBV5jCQVHNtm8SONJGbdj@9kJ+XY({_kkoF|cK7;3= zi)r>Gd*fQTRTB5$0n+4q?^7Q6el}j`Mhnc?meG?TW~|8xDt@QYKn{7+S)8=Gi@>cmyZs81d652atb%J z9$P91-s6wA9(f0gH=nXFD-&f^f3)-t91% ztX7lBk?5)|tE{c9EUVq@Fq&*OlhGkul?XSDAK%20mzkNDmyyA)mpz)BoASb8?tyI@ zoIF3zK0-a@;>6D|dT}p~SD%lYP|R6zbkdAC`Xkp}Pr-+G;+)-F6Ixns5317z*_5Pm3)F`a5N+TtP$G z5f!v}kpMN0X3raXS!qB(8LQFQE34cp*%3jHP@&cH(iRL_rVSSRy2J=wbF{k7>XUpUWQ)M>Lw8EKBRK)NRo^cN4!h)xNF z8Y4MFavZjBML0TL@|1eZ8jRKLkx)Z;ZMaS{=La)NZR|Q%p~p7Z=k=i$pswi;Yz-SC zj~_#xp(PWHjG?%@;|6bfBNH0wo^&L%20 z@Uf0r4wgb0VVEnIbrG+SNM$9leW zqu%fLAiPa&HtE^5hK!7WE^T<4&f{^aMU_IgSgWu)92!F?Gs6%JB1XudcGxWn-BPVW zA*!8jk1nk~O&17<V=+3>Ue3kT|CmZ zUoOeEBW-0DOOK>fn!G2EzL#$=! zQm70ryP{l*lvYQ>4YdVo&VLylz!}aV&}x>avHC2sM^e4x2&y>b3@u}}#20MHD!B|F zNq)m7K^8O3+KVsh^ge}F1hb_#9<ewHA!t>!C9v9oWUJqk@eG7V>e@i$_ljG%I29g2ctpM8}V0Q%`4hVq`k4HrYLkDHqI#ijv zLTp=zgE#hL4~H zm08Q2p^A6?jcGZa>grP4q}7S_oot#TsO{AHGqN2QzwhLyE*Ry5yn(X9nb^49J(u*6 zfNriOJKZ}!q}0tb802DrdH7!6LCY!LKIJKcNpzx7Wn#a7fO=^6Z96i5-##SC@MXp>U?TQx{N`P8vC+y4;tY>knO# zm*XlJF3XjRI(!LoMX7r)zIr8_%>}$aV`S#$3ct%{IPTnf=FfWGzw_WomyBq@x$e2y z1s20xDqsbr0c8o#Q*N$#p3N3gsu*g9fna`IuuQskC+3wPK~gI(|K%#P;3 z6;r4JZG)xTva>Rbn^q4WzB-Yx*ETliu(#ahHG}+YMPk#ud+wPQnY&10B4ty%inN?)cwINxQOr&PL(`gvLi(Z@>^a|@K_fCUc2FAJu3xU#Y; zZJFEd>GBAk;{3Vd zT-en6<2JpeQ7WQ&c6)mE{49lje)>Q^$HW1qL?4F!Ha=;vqi(s06oB56D?1|FQ6@p2 zBSV|HQLL4f|Fq}8TG2SdUT46r&C9GD6Lq?yqsta7u9&l7k~*g;UaYrgvTTi7YtyAy zZ#{m^-W0CKnfQFntu8)Y$<<3ax2|w6Vt8&U3C%)3?U-aBCJ?$#TqiT6W3 zJ&_7n8V`dW=ix(w2}7%vo6cGZu8JR`@0X*6xd&#w{LUxD6lQ$F6E|~r1`|uec7-L- zq2j?1pWoxzI%A`%rlNxv4dxpiuI!Fx7|zwDqFoG!a|`DCl)3ZusYT-#DZk~~<;gA*U1pu;a~ikI8WE|E_aFWJa^ir8-^v*+^)kxto!+TyWQ zfr8=!$ywA?J$2z+bErJiAE=2GR?L=4iUtL}#q4pabRePWPm9t2ODn6mfsg)|VZv0v#noB=fXo$E z7>c_}#gz6uv}CO_>~#h0+Jel=rl>2eWOV6*CFQg4n51aF!5d+tG-{1opH`OVwfeK2 z#igCW%8|L5V}?XFt(~@UX33Roc%zknZ%DQ;*n2`YzL9}#Z)!`{R;g^KdxHvIODLW2&8sk10DB^rRN?1mKA z)YwqtFM2Ge_S>*NVb5|amFlcQ)}4{~gn2R&-K^%3MT-|NdQ>jg99j(gHHG44 zfvJ>QQ4K3kAx_5E7-CpjL-W~hIaRv9G-WpNQ7(sVPt1_l;h9A>qw}opa8B4AE|V+)kICc-SS$gz z=`TuM&M3bXU%hiK5b&u;1&K2hqZ>;L|?zY-whpc7z@*dYVd{u9^1uw9a*Bf8XT}qyg zf)kMwffFWy5GTz;*bsAkC>y#;s)$y!SBMoO$5+m(6e?F~H2I;CcX=Mhkg_JfAucwH zLJ%iPR}F~|YaS*HTV9g8q_QL~1=mHY(dJ z2W68|UM?vu?O!C}y6LhH*H;6xjI4qAJvXS`vJt{NH6NxhO*M%>SlgKPt7ZSH3cko? z64)`{NN@JAsLz~PlV|rwi$a6*)0}0KW5tykz18nex79757|m^%R+`&bDZQ*Tr8$gd zjY)0ym{e7Iy}M+5P2T7#NomQh@HbpDwPDeyY@Ij-ZC=QndhgOj_fC(bRZbcDkUd9o ziiZTj%4hci@j>k~jAwd$C#!xhen6l%9^v(+lsLtK7@NVW7DTOE?@_pIjRp;dQ}iYg zzdnFIj#Va<8G7YG%Rzau18W=+tSnaAs>)n8w}=t1tVm?@(;xSD7fj2$tzb&-S30ZN zs9L2mn5}o+^(-sAeSPB1-?Oj7u^~f4p`k-!=>3&g_jy-X4vF~hT}_HRBMnxmp^Lh) zAA&E6VR7Cat>x{P3jQhSpMBerBvN zal#lhJ9C1Lny9TfYVt@{Q^4@Y>M@0OtyY+-(xw*=N-wB)xX0!05CpY7>?@3P=4QHl zW~Ct92_5CbIR7sCV~_?tV`?`tqd%Qz$gMFqriWY&qGTFvw2sz@{?X}aqftw-zITzI zcew)O<7Vl>HmE=)-w@y}Eg++&LP zL(_P#?I2c_uyF%RoLl1|XN+BU;lmG^O}MIaW9O5p`4~_84@g@}qvOTcCWJz=sN?Ex zwTLYNjasi!)HCjh<5Lhtr)gBF1g%CuLGh*iK6wrxr^s6)imWXk)+|pn#1pl~*y<$p z_9Dffb|${-Zzo65PQp|k_e)vI23Mw`K5AkngTW*TAsX!yHKVOs6Yq_E7<2d>gB5ez zs?UNMCrjBByh&7)Ve)yo{^3oARTtDotPS;guYR?wt!_|TU1nb6oN8zwv>8`iFiADz zqe~YG!bgeMHICetRn6m9O~{p-jR|{)+z!AY3%M=^$F+j4o{UOuy=)RY_0~qUL672& zLkWxcwL7Iokd+2RZ0p0K8|-<$?1qMn<|SWPps8T5tlqwQ^>*Q^i}y2Y;!EMGbLWsw zCDP&Z96c31qgQF`VP^1ZHKR2u4O*d5uMtt!yogKj$9eBRdGW-4lr8d&i51GW%vpK+ z?d*=*ZtG+ZcXlRb%eF!u`r$L+Ylp3nX0z0rk(SepwIz+iE?63Eg4Q4_6O=3$`QS{f zo@1ry2MyA{b-~kM&$ufl)y5{J7pD!8qJ!ULW8N%mt_@4>IhH`#2v*$LUtXUgJulV{ z(#-W1s`vVxN?pCiXBKo$rKlBD{i@Yn!;9$R{xVc0pV)_r#0Uzh%*vM!pjffs$7bqt zORLgWuXaWAGYuO}kP3E^>eRv)3=OOv_F@@^+X=8y1kQ^| zW(1)D!vpKE;AL?#2cI^jgyNFL`u7o$B;QAjm%z_#V=B%^$w{#?hObU@mrkd*I2~@g z&7xGgt@V}wzN+D>ck@^Q$h6eWO=q{@PIvkp4wqkWX>4}8-m1~_{XDey8kxcvUc-l= zd{5t7uVM;>-Gd=1o1@0^{;M9$28hptQh&G&SQY&XcHHK`M2XuQfE^8hHwE0nm~4sm zFrFS!J3St~!Rv8oI@LyO#x7GeO&g_L1~Xc(7OryEHH`~pjUN?vwmk5&pEt9=B>v4* ziD1+AN4E@1=~gWDv4f~jGfl*P3a3#wdTv@D%}WPW0va8<$l z&h|{U_Tv2*hxi!zK6IZQqhvum?PCvn&&6~NK`--$sKFsAN2hDequnsKF*KsD$cqD5 z-)ysAS{F#os??WlS#41}v!!6fspfYn+o@iA?ZU;&S6sRHYF1e|eo#in;Bkcm_ic|o zwhfTSM3l>MjEN@f*~j8~cSAdrnon)7*YUD(LJjG>I>FJXvg0C+#ylE^4CF#F6c<~5 z&~|)qwDXl?RTv9C=*wAvc8k4 z()pkiOQd`nHc%XV*9n6_Bs;t6KT6EU3uW45{p8W!Yp&C`Oj-M%rN+v5;cR-uniev) zTE;Xu9=@Y++~CVgkGCh-5-7J%QEvQ~BB#dFt)_ZSyRpmIZ4`~!-iCH%m$F+aDziiN zwtBwtA9w4ljm|8M4d3xJIt9DNq%msJ`^ysMCc08eyQfxy(3!A1&Pz14i^lr`^3z|k zsU<*OxbIb5F*HenHNf+7h)x=ZjSf%RQxI%PU*m-q?r{!P=!Y zXM{P}lowtrDPqDO_>vEPf$D469INn41k?6X0k3js4P`@nRu_KQq}|!&6r53CgM7FE z-N7vH*gA}s#{6R4Xi2ga(C8ekD{ZtqH#~@O+QzrSp;j>lTHe4uKAHvPSIKKxSlPe^ zk6cG7tM1bNH->L{f9jK9u1D+2$aDH@OQdCUYbK{>rVYuN;|NCV>9LB8Wmk`#;m-7p znPzmSo9zL&U8D2n3@(^5$7`8oa*VY3oEEj-S2(x=?pcQhbNjP8I5_PQ6*fYG|42Nd5qjZ8X zG_68oWw+ek9j(3Zv0shn^)WE6=CG^dt}J;Z3-dX8SVFs#XX}`V%gcW9 znFHu)d5KSp{JP`F6(5@T3?FOohx!l3;E9(5&ofryd*vNDT{mKCIni)k51Xntu0sl9 zoDZ_HLBQ7=8GniGIXS@`&KgYk9f2`G%aR57BMM9}9&11wOV zo*Py=auk+y!K1OH##>a2ywHekc)rZmhHW7Xv+kPIQX?NlfB5_`#Qxxi={)KUD{>Xw z&f*FMYvMSC6~Utu)ya^Y-K`e{VY#TnxZ3F|aJiz6PK^Nr?s5iyt=nl+vd#AD`f<7C z*R8p6aML3XKQJP8cU|nh*oX%oeq_wx8`fS|E;WrFYC~P?QQ_PsbW`WkHVLJKqe*f# z$#>KSHc&7v#|xv!U{Z-{Y$Do3vs*M{(qVP0-DsAg!Dd#djNE#Zv(Go;ilJqYb8L&b zYdAa>OmKKM`7q40guIAl?y52o*<~H}szCZ6=dHR(ak=NwTj$JQ^N_E+Fhf_iX6WD> z%Y03(utzcv9!#9hpE-3b-}0b={^r1He#mAu;j6LrN>#UEGwcI{(`6Nm8l2V;l?IK9 z_ZhCfVbsP_d$ezqruKD?aP{5aN3a6|$;w==gg!mpr@zsjofq}5shXI*&Rxx#-3{ZK zrLy*!Z6%+7HhXVp;H9-cj3?CM!P#wp(jyw8$$5 zT4-r4egu{AO{%yVfvjW|%#9X7)u@&Y-@e!pR-BI&p!|dRSRAsvk&opcGz~Nf%+~lu z4LA9p%WoW7m4>~v1+LPeqYA!YHw(_X6$@tok~^vzPS zI5xFsF&4+(wN_k08s&18O`dLFvSZ$8Yr`K3CN*!t_ONr?w!~+`AKNdsw_{wzJ_LBa zBJaiK#hpwf@mhg71cud4g&^2i>U;{{j6Ept!{*<u5&8*@G0E^KR; zd0HqbuPLc0H}1eM5MlF~sYFbI)fx!6oX^rO9x3I`;D>I>)Dd+A@_n}Sh8w!}E@Tyz zAAC^BU_C${4P^X0c@PGbJFXMJkS62%-h8u}523tKyHO(=b|&E;bQQvH5g5B#cnaa= zy>kY%rp!SIAVnj4jcfIhqVKk*YY8~ zt%}dQQww}p+n4Q>A5FtkYlQMf<@b(klOe-o&-7WMzCmM)9KI{-3P+XurOJlvXjVaG zc$mZLp45u(uL-N z%S%xG8*$ub!6&QV(2@`FRShilR5|;1oTug&I3gxfP#>*c8yGaHGTM=`+8gy0H57Zk zsB6$`lAz&ul+o+o$Rm3e(E5oV|-!K$CA?rkWh%lmZ zNODZ^sSQ(cc)qNp`{DOv|X&^qAM? z9bMWuzb^P$*|gyigK4f>@60L>3>&S{&eIvQ>$q4bS3l%>QZ82?wa4u^mvF$x;$F7j z%i?KlKePdgmha5TqngCanise#t;Ls46YYK<^OAaUnr@0qFHXUR3zr+KdwjYN(YZY< zAH{21#;+>*7+956J_*VA3J%{#z-bM4Mb*!X%gtVsDbrDq!<-p&ikB>#)s_~ut^Oj` zEZ}^GM&FP)r8nKY?CM+fy7zGW8?px>`&%eeFHRK9*oz;1-5;+?^HP&4*t-5-x|6U*PCYH2qxLoRw@Mi;b8jyNS4H0!2h>FseBb4@Yhx5(uU z3O@Cb%b1sQs)$qNDyx^&d6$9h`ihDl8jAa&yh2CVWO5l6G0)P~1ua?b^mtUt^XRAr*bEEwcC$C^uOK$!T7Hte9T9&#u(OxG1EEPKSM9G4k!mF zN;joFtg+SRJWF{)o^5p?&l=JRk2udLwLvUDCcgVu-5`ya_$e>POtjy3gqRq+toXQ{EnOZK^Dy!-PskFILhT`uCP}JxRhLRs1^rXZYA5trEA~5L*p%nHb6i>D z^mLoNoX0ntFLf<@|3Ya6s@|F^WaclDq{2c;Dtb11xIa29V!8QZFw+_h2yHmPnwgcC zckv#Z(O=P2^4reD$-G=GtRXIM3FhgWAunIU7#lZhJWvESi@AkJ!dqT$A=n-ia!ewx z#VdK^-ezx?SLL-#w!2&LGy70%ya8a!cnU|S`EFu<+r^_tV2KQDVO+KV8M!PEY_q>) zcqBR@J3DP;dNAX8R%0H>L9k|QvBP6uU`op>Wm7tD@6W)cdj1&o?4_2t3qRy%QAw&e zN>QouNBzvDrxt#sAnrqDr}?ZFOVrY35iMSHGEAC8rCX&$XX>}}ircVui4~wy7*Tu) zXu!T;K7cw?hK zEjFaeb_%V6mn-_c+zxtBu9fi+|1O5W|Lcp>*rILL@nh7Y4(nCA$$GL|rtl+t{p+{y zwY|&d+c2%N_-0&o1@GMhRs4?V%qR&?9(VJ_?DVWsjYH7sHS=b(yE+p>G{Ygv>Eg%_ z`!o9xy?9-GX1<@@XlH_xpHy^mby@6;IcGUdvKoU|z!di-Wgx=N+WGEPAYkM+qj%wl;|rm^>8m&VkDmv^= zl~vObX-fCznyp3bLr-*6N#bJ`^k>*qqQYL}pSdWSEeMIb*a1C`lj?C!U_b{zhuNv{ z8GVb!X={-iumx>_9CnpX#rGwqh+ObCc{JlAF*KFEf0ONpz8;Q+X4h1Y&PQJ_GWpD_ z*(+MhrLNA?MS22$J^X8S9Ag#lJK1rkcOvm&6n$l)PD+Q_<(6wUHR$t>fuvHMV&DKp zKv2rPH&r6+xHPDxw6tZg6dF7sT7rAx#lq5P3CHKv)9W%b>!w#%O&=Bx51U>c8#gW% z8#`8(BL@5PUF4hpXPZjQPy6kqfCKiDyaa4U3Aoe6DPFzHq#H1mxU#-vC-s|1*2_#J z-u`*PxL9jxnMu+cavTMDYhe}@6_>8gm>XTZ;^SD0$Px*SZsdr{>BBPJyM#r0(>jQR zvI#;aKAsq`M^_OKra_c;cNbQm!!)rA<6VY#vPztiuJ-(YoV^KrTxWSNeBN_rU(f9O z%$a@DXht(yEZMS-Em@YgNb)9|M6t-?Y>>oBD0L&pvT+kg0lQ)OfCe0XxsZN9uYHLf zYP!S(+bx$Q4gF#_K%Dw^ffjCn-coK$Yx(}4_sooB*-m;t*_tytdiBnG-sRb!|3d@f zqERz^f=CGGA6E$$#+DlqYormsr^_9_tizmeH5&Wk{o8s2japfLG|&i;-1g&DYb_@D zx1`DCy*H~Fozbkn{K>Cd?P>L9?310?EZ=2+jde>t?=emCus}_Xb#{L0uA^k z_D2_Sf-0yISuT9i7A41WM5N51thq*Xi=FZSApgo^o%N(CButf!q2{EJ+n?5n1g|oW zEF&u%565X{qL8Eo8z~0aHp6MIW6<5dtJIv4v?sExGal&L*wZ;4^SH(;)uc0&^h5@# zaX-S42DgVj>G5g1*Y3943?`q_m5uil0}lJ$`ar;Lbvf(?vp?C$#=3LRnj$NpW>_e=6pwddY_T#jgbz-14d>i-(zAX!ORBm;|Xy_d{C6c zxD!f>VBSW7F9wk1#>KM;{L`oj2|3g9tK@(zpPQyYa}smukg0=odsv94NN zlLpTohRcr5Z=b8dUP!&Se_%a!V4@O@ z&dO%DvV5Y(48K}6q-T4u7r<`WkND?JkW_n#62@RYIZZ|;BqdxTaU9-?OFZ=p(%~i5 zXN7&q;Wi7H9j90FIKeYCi3Jf$hzFv$G}3O$4YElz4SBGdyi}Pk9WaNYF}qz!#LW9j zyDK|?{_))Qsm-a>=Be$ukNiL3KBln00)N!*@_lcgRQoDTrRUkcDe1-HlN#JxJPHU**#9Xai_uV zbm7P$0_GlTKA7n4>Oq=hy<6$HZ|}j8sW0!yty=AWi8*BpV{}B zU}q_1n~U@Y0zJR;^wUY)mMHjn(Mj(8}oFVb6G>BfNpnO_6Un z;br=mR|=*kg^WENoD2jk4wuC#&?jF!hmVF+7WyK#DTEm^N^yBcQvfKrsI_I;8=iEo z9P(r#ytyUGZCY9w`kz!8Nx%^|q6g5Y_`?Ka0Aipr*kVCBQd!PVLd z1$wLg79s=W*GMu!q%)BigkC@vBryS05agdUY`SN_Zw-IcTMa7HcfV&%IMLgi2(Nk1 z-P202N_J>uc#6O65&+vf^uP@H2&*d->x=%>K! zCo+I_!+u3klH7m=9fZVVsG5H=JG)?;Ydv2<7*?~~*u*#&xL?ZMkGd=+#at8w??XPH zIr)&{#*?DMtDf{6asuiXF4L3Za3O1@^@I=_TaQhT2!_^vZr0yh3o5tVRT<36;Y43w zB8)`J%3Zf0td-fCkL=C$XPXb5?az7JkBv3)314MD2I?aShUy@*fmIQFNRJ519}=_&jv|s{9X7+wI&ZR`4p%!0Ui@q~+^qMc zy1wcQ`*ilOKNRZgOwfA=e_utMBXVvLqxqKjL0I#C;}i*nBX4$@N^)VFJFiTIm>J-#O?8zf3Y+`FWo}Ku>|Cp_Ue~O`jM4gVK9+JtO&)I| zbsZZES6@x~-J+hWuS@MMG!LR+yYe9WHY&(?psA%)XDSrUJM<=@;DsB7PY1UMUwGx> znG3JHa-FQMKCqdq(!6Y*Y$9Y#COaef90}<^@MM*cF{QMA-lQ|x18%8|An`^fruOEf z;cM=|A|1v4{2?j^Xt_`8)T$W@#intHLwlW40vT1~P#{I$UP>$Oy&(H^W%@d{|Pqn^4O!RSIv&Sy!+(I-L#Jf z@R=vMPwaiCP;lz>^WmmX5mycffGZE$>A;(iC*X4ln<*pTRx_!l2?T=$1>-|Li`V*) zYnS5zhv<0JDM~cB%dJyP0%!evogd@#^`>VGk|%fgX{WQ5F^I8tiY61x!0d5+-T%ZB zPuw>6zJdPt58m|z4fu(>_}P1q&BM?0JTk~tH6;?M78OWFWf9qNNbMK&M!3QB2BY{8 z1)@I&fm}vp2HYT;ldd05x_*cfh?FUFcSs+5yldyq#z)2ef|73X4+f z??xF3gD=pp!rX$bHM5Y}9ltg)9lz?hZIw3@S%w7Z4Gsv>T43&ew{5>6xIfX!It%;b zx%?)1fDP&s@OEdH5?=lZ0sxunrIXVz@t&8%t{ z%?G8g<3dqVq%&S1cn$f&SzLj%pvg2h}tx9*QwfTPwvG0UN9Zsj+?sPil?_S*0;Xu>b;k9dr zhet<;Gm4U-@8-|PI{v;gf4q5=gc(JL$QF#sghKk94 zW`+jxGcI04tR!4H@Q?KcSn}pOKk=bx+n)rBh20N{39`FHHQJ&3Ky3iqoU+$8dI zx!);=MylQ+M0$)k-3fQqExCt$M8qWDkbT^~3xPg)1=*Wh3_0(Z-{ct^htJhHW*4LD z&0=7^q=gT|IDwE*T45|Nc^F>>X?y!MKBgpTgDs~AMdoVXS?GmO%eC-&=COqwciwZ~ zZO*9U+ygsy%+CMP<#f8DX^+w1O-bUXzWk+6>%`qp?mo7Ax1N1kAM4#zt8MC~1U`mJ z9EaKa#lHZrK&}EXU4F~qwR)a}xI)8uouX(VUQ?EUUcGO{S?SKKcdk@YL} z@T}j|TAuZ*^?ek5lPyG1-9{Dq7>^kSX9i>TJga>Oab*PbEoC`JmSh$Kz3ST3VysOO zbwn{>UPP?>U-I!G$~N_>P*m~Ouwxvb(wmN80Wi!bJyx1=KFsM0 zuUvi$FPN2U=Hwc_99zPNTYR|^1)r|2=>+k;dYD;h^)+{Bk29c&e-)K>zJqc4Nb6>T z#j7XhE=jCsNz3A{%?0BkJLpL_5(@I-Jn6cUXrw)CAl4`Z0)<8_+D%vFP@$V%;UZ?B zzvYjXgil_T``ybvGXFu=e+zFbpzSYtTlWj(>K2=gPs=z96eiAoId9{QneZMlz`h_p z1K-!@Poan-Hv{kpA3B>v@3GtHXKwSL1o8#k8?=CR=w^KVd(rh`OUMW#o*XN5w7B^$;C7pOs_aT zWJiKJwIJ*F_OUPMJ&}}Gjzl7mVNJ{FCm((aJ6%DexYv=0x-C{qz?pX_{GA^vCFl_9 z)Vv9~zzD7H3Q$44fAbCy?sBomp^#KF$dkko@!P6Pyp+a#B}-^@l>-XsIbShEg~2^BZa$Hw20{ zf&ol4GK>l3djvg`;F&Ozbb{vs4h3IMS3eh13K6sTJ>nEMvoBRI{8jBa zI!6*}h5ifs2iRqELR}aX9wZC{o-s;0Oj4o%{F z*b~pXJ-Harudt3hZc6IFIv!6tza~!To zoxFtr(I&9+sYp0Bl81!IbJBBI`nNzY-+t>HkN5*-+2uE(tiA@QwY!&m#CqQuystD3g3iU4t1w zW=GnrkHzCj0RQO_Rwtmc9_-$LgkcHAt260MsWh@cQUNh)eHfb2!-_HCb(u_(OO%lt zsiiq-?4$7(Z4_)FI+96Fh&O~7RZ3*HQ>948 zf=odJl3eR%-D`3^gI4QcPfn)@`n$U1m~vMLDGL%&+#-hAe-XbZkPfe?vd?K&052&@ zL7V%iU^pray@JqFkjIOZHtuPuK6sGEqW7PP7K_nHsq{6v;#&--HRUqhy5h4W)aU+Z zb`ch*7`&uwgpZs;;c4y*8zwq|tv-aSy4Hr1JwV5Pyq|T`RTg3{{0sE$A1drB>@P@# zwSoOA(&AR_kB@ri?BO|S+|FtegL)^esLxf5E9TPN&8#I-Yq)cG2-54w;mp&k@q#T5 z^9B^nri*WZQj)cubLGBl(;3YT(-0g3&9sQNvbWZib;Zh2ha*~!%V~I}{AMMRj3Y^T z{%>j{Z2mR+jyy$>d8{g2B#=UvKKwONEe<)#(QY zZyAio@iKVxU?MSi^9KW+BOT@8PP7{?cZ_sm;Y8tX=3$=_e^amtW#N6QwMc~6LN7!= ziRcnDp-JU_yAs~$lD|Cz&u67*IaCYHgdPNJU&m2U%>zcGUD$UV0&5|=&rVzZCB*g+ zJR*gU5CLy|FT03|e&}{F+9?IASU3dFw(a z`!;(O_5>^9M}v|Mm~B?0VHdW+Uh8J`BJPD%fjbH*VpMOlm`oOf9RbKX8~n}Wsltl4 zWJtPFGU4~W1138E_Vo9^gPb?{d*8tpM+mzSb{Km7=Bit79eR?Dub!S(Kg?b&JojAb zdw;=SF(lCIicn&w8KE>H7FfSmlnjFSknTg6K@u)5f`n!XMkmQm-!p%KeWLV3SQAO+ zYT|E+26$aip0<51+|85mul!_?mv&^B@k5d1hk_U)KNVlKm{aZVE--{dDT#K?BC7o@62q-JZ=`veftvy?S$zH zYhxY{L*zCS4#H>a8I$O&Ihio$W%$PrS$HmCs2YY4(RM&PZDA5-QpiBC+?9)2I{sD4!Zra(xZ$ZU$~ zXFZ`=d(^T|_U|JH9EH_^O1*U%Y>%HTEqoacz(8vfaOVCa(UbH0b3KXGH%+L4L?RGS z6!Dv$48-O}#KM)W;<7{b+ShoKgLKyS zz}`8BF_nbBR;?)&XERAMheA}=(*#>ZnkN@tQ)GbCvz$;ronyrZHQ>!G0#3xyIuT$T3V|=VUb(lsS zu%~3bo}|lOiG)fCx7|8!H)`v>I7b3-=uAS61PL8bXW)D2V-Nq=$`?>bargnO!*U*L zc0mYYZ#XQI&sdLRLx%mrWB@s5NS-m<#)6@s#qTg6%GOF`Ukhe0a}|jm+M{Lm^&*mo zXFuff`XDI81K0-R*kF1m=p-V87zw zUWdDkkZ!r4sIg86y15*}&%U;CQ+m}c{k1!DcUo%x-T&aac?vjTVXNgo=EY;k=(;?v z@sTeI$AE|QUf9nmCi0v3X2MbUMejnSQ%Hc%Rgx`XzrpG-L99NHI1Ty2o0wC5YZbKs zjh^m2m~~$RC>YbLfit!?0$ke=Yk`};?T^Rl$Z}^ak96m+=NG$M(^9w}7hyXWX)3rl^ zSZvzx3x?Lk0FLarP^X&DtDWJnb`9;$rc-%DZe-b+((2AosB?9xG(y*rQn{)(jmCchTs^_n4IhR!C z{~MQ7It#!5T=BKn_$%fNX!cmFpJSbDkny8}BK&`+gs?U*q^eVZ73S+w^UCK7^Ts7} zM3i1SLFuSGg%cEuBPHPvcq-*a+&~yC#jo-dH@AGDZ*UD4k49C6Y%Va31#9 zlL2oML5E&Bspt|mz`g3+AC+~%C{lVQqv7K=;bZ!bbJNDzx_nl~PQ@vKyauxyx8Txg zfsFY5<(?Q)SFx8F?Ptgm*jC6=0i+>IGxps~W@0u_QRa`P z>cOFH-l&J|mP3}tn)z?v!3KZ*$)S9{Qr=i)4QC?o>rY#4`uRT(6uqMU@~5DZ<4fZ6 z_*2Yd3|zHCctBlcR=wC;3SLUZj&iBoajaPK7E8rW+iXziELV=CS^97$UWsQ5QYF=) zE8B{?^hZ-Vm*ca(&&3Xi95ItegVWRUJW+bkmpB~aYfmhKEyY7-ed$~`v9mtX7~6!I zQ)J_!C(hEt{`7ldG3IyK!p^v@=owJ*gMKCBm_O8h^sn-#9vU*(^y!?(VRhL3vb_gx zf>ITC=dX_56e-Nc(6np1wyI5LOCLsoTm5HbX%Ls<@9{R;(Ocd2IO#FVF(i zh%#$%#0_4v!C>}E>flhpH)NW#X6Ga;ay;W!DLAxJH)va7TdwOJ=%`g~J;jf8+FWx% z4WF()biR(A!1uu-CWc^_bMi}?nbp$fe#rmcVu%xS6|=gHD}hR^XubMb-f=jT2GNN6k|m`=J|i* z!W)@wVVpgunPaXm$hDR-ejOY(<253lXwtp+t{XtJg|_uAmHptL^nLO1>%p}-!y?%> zC^zqAP6J5uTtoxdm0!S-Z5J#Pj5!u)z|!^_4FJtxSAMCQ9mtzPd;5*sYjl9O{}r$$ zZqT02w>BQ_e1}n${tvJG3W!b$K0sta_*rb)5yvx7bjyqU89J6e!@u)qFibH0qGwpz ze$g{r;m<(r7d^w$_H9}Qwc92vYTO2ajWgbL9qRAz|iu z;iFlnmaEAjgzk;b2}kg|vOicHF*%WyV=V>EK42r5gF1a~y^I)`7Eqz)I>&~iDAU)@ zk`b^SaX^?!5ZE=9P*0A4tI_q?_lxW9SfLE2dwNQv%D~KUcK#{c{eb=imL6MKF8ZM#ixeB%y;?TUpXCt*h3y zy{_OpscsBH@^_4jeg%Kf^t)0W`%(51ds(mwk5INLm)N24(7A#LZ^8?*N`66{2G@V( z2&Z&IO@ilq10XZZZZ@K@kVQ0EQOE!$R4e}3Ee4)x!aeN7EAR$-24E@?u}vt16aq*L zqs+Kb6bd;-Wj#8&@3FP}_N}4+?7M4c_pN#Cv5|fI#`Zx@j$C;I`|lH=>v5dAkCSwB zNwq*c)Zo%63`89zoLs*x?Ky26?L7xt6759Cq9HfV z4B_^k!`QX>0E+q3;sX|q1#zxKtNhJ@Yxr7kfS(gC*@#*QY$3$kh}&qLBv{M|f-|>GASFSVDLk2ppA6H4ETm08Feeh9~>rfrEQH9(~jv z2({43JiG6?``(Ad`*t$IChM)&8klU3F+g$Ry~1N^1tvR)7Yct(@YgthjgmdjODx$# zFFcct0(({9E(jYFTlBWf79q67w#-eaE+k%*CM$jUsk%@$c#sy40LII&VjE)cmnpZ1 z3Z@~fptp% zOe2vL`eRq9L*&`;)UFlTJ7YhXw6=f4*;CGvxv0yOc3NBaD9obSU z78_{HC)u0Ti2)^8?BVp4V~z0m9ps2GgE0JaB+0125vtdso(a*}MXQSSU)t_4I1IJ( zbX9q~+6~&#KBRW0#`W4ggZ-p^?gyIf%!69H6<785#dbT|tB6XGM03|LK3H-t9~Yff zG$!iU9_P1P?b+>U?^W%RXzZnqCDB3)g-sWR;ydh zDkQIiT)`?bqYlH!Q6-rm~;du2RC=;Ce*2&;`luEv@383P$Imd*)fOo2H zD3r5LMU8|v05>j_T{2!$o(n0wFk#|K;W{^lR7rC$JE^;iOq_k4(hYG|tokLEPlKgv zwBoxi^oo6nIn?L1bgbM&dywOq@G~{mK2u!#y{wvxdBHd#>I$^Iuh;glSvxQOLXJ1g zH_yS+KJU?K?Tn@CwWIT*eRli2NQD7(DCz3sqAs^^UNp=C#P2b(>froeM4}o=-9J_V z7-j+RzEvaac&?>w5C5{+c3w66y}T{OhwZS z)$T8#W6`RNGpn~bY?5s$2K|zF3YvGfu?92LgZ-~%3Ic7 ze*hjy3IihKL&y+PI~QB?QnDu$Bt=iG=-$)_hq^X2yd5sRSH2}Y;!xb{2P^LneKuIO zmWmcn)D7`K46OL=)dTm8SJNvdJIk8}QVw&Vjx?))9I)YwuY|z-TBrAOSnt60ihW zQV(Ay5D{U=jtIA?a+vI|A?*d`6K>6h7lP9l1#dzz+o#-7;Zuf4G_*GyHv2y9G)kYI zGoOaH8$qQM!(VQ4ZHva;h<9W<{tcYpHd1-yVlug?)P(iZeW%)E-cnrCADk?#F?0%RR&7ygF4Z;R zl3XLIf5JcGm;6&JR@la)EIO68b{nJ~s7k0ei4BEEL#R1XDjtzVawCKwfU|*S!JXR- zzd~gm=(8)0EUDI#7Qi>RxV8#Xe3&-8# z=XX>)zd-vW`jJd2LU4lVTD)m#pZ7r8)cWktyj!35RJ1;end|l0i9O55$!=@+xhz%S z<0R&^u)qIOd=_o_IN5D5^3gcEQUyLv-V$eP$vBZW(H^Ig;eBS8^hr4uTA#a`eb$u> z?~}JgpH!pd`+Pq0G@oqOm5X?GE_r@WHK%eR*Mu150wwKB2~P8W0jmBB;G?J;1Z*u& z&@gEW??NnKM4{+;M1^vE4_|PMr?vXb?lE^F&SDnA)-q4|j1t#*!9H>DAUC}QLI)%I z`RTV_yNqBTp3u-l3FPo)bj-NQf{^NT&y&fFU$#V@vCxkbJIlLno4CnaaLj%xHu1Be z31GS}K?-C)_yO^prcD#v|Ev6L5$@sN;2Eeci>ju*a(s(U%m%i2EEzxZQ6RBLjBk^Z zQ#CSmhNp~N;+rO0dgB$u(1S?RIl2HkjVKe%q7N0THBho~_A$+u)`UC!YF}S^ruO~^ zZoL_>hI4a|&i|~^K;$hD4@-IRt}T~;-9k59w`IULzpM>=sO@>p&Q0`JvqL|L+kB1K zmH!O`*fn->P3|WetjY5&8Z6}&DH50$tzV+Syx%4b<`Vb6z#bmv_H(ihW1BAM9YlwD zzim1!mb$s#K`H|AW36A>`&z%ZEsPiaI=t8Km-fHbFSRH7E*3f$`h}!31e*8*(02t< zoc%F5pdj#!P~9eg>jqqTZeNjx5P+OA>r5jG{vzoKKcyd|cwduQT2e9v5}cOD0d5P! z3x#L%5SPW3Q`&@&`$Rd#ZxvIq1U!o=d@|Oou5vX&4-fe9FgO(njGgc*JB5DX;ZsOS zL9QCyQsntlR}ye#bxTU%xOoz4>lTFNk^U_YBKvC~JRaEvYzw>eP|r5dMr^C_=2 zsp7~@S&U@~o}O1UWJMzLFt<}M8!rU&<|}xkp;(p|DE$JR=WgE?s3n|tP5&>|q~m}V z><>774+jhcXSo#R(rk)^Je;;~Y~x&V${uL=0B^Zsb%bd->}vvofY0^ z`>Z%RdU>B*na5{q$7!E9HrWlKDRT}+G+M_0DgoZSYBYd zN)8=1d5$)|Gwr_4WVCs#mMT~E1@^}NjL##bQW*uB8*Lt$Y%`D)+;UEdLLXY3k_H7I zG^{c5$^NVAbVJ8>Oj=`DeF+$wwB5b1*$dH7AQ*YPjj{;}%NfG?S0II5C|^DewhUV^tNzSZB`+fO?M{w<90Z@J$%Al$AF>O_SX zI2u9Ju;NzT6G;0W3HVKls|L*c5vRpztJ=gD0c;vHj(M#*-E-e?FN;dSB5-?ADF5dY9O|wDA(1 z;QcoFDoJz#m@4(#WUB3cK_|3+*?U_yFN`;s;`TAF=F)!X1rMRxQAuGZN8aVx&Roi> zP?0-BM1U;g^dzvRBj8QWnp1U7ICajH%`@gR+1&tzx0sT|FyQaHd>a3WQ`FC2o<4)a zM&X_1#e8B>!KrkcIk1~JPe{g&YBi|lEdC}Rw0OFF;8fI?JuOu(-gU z0bCw!*o$p0(A?UQOd7N6h5eS}wKNe@0}Cj)N5RK!nx>ZT@Ma>eaG)}nX@TO(3#hn{ zwV!9eVRVLE;BsQDXG0Y*xo?*9W(S#T+IwoSz4k<-KgXqc0fNt>wa0q$y~-}Y*SVap zCnc?O3K^z15OY)r+yn({@tU{UEI@!Ij6ryd$V_k%CMV6F(^TCk+pdiOdo{MNcL}0z zd*6KxGVw;fK0$69y$>H4pt?W=04w@NW^`K3q@c?;rVH7`k<$py4Eja8yxwepxQ0^Ts?9wdY^Wqbh@n*yEq48`y!xAht2xFU*k$`M5zQkYWF zZT$<&Un3=fc9qBK7_)RlCx;^A5izn0-o!~x0>ij39``U$MaJXq$aMEt3U#O)%tB48AeQrNf1tmn~c*^m_%&+RpM7X9wbqmR04ic+mA zO08n=^0^#-mlB+vysdSUU3da@ceA--@ju?sneNm}xitIE{PJ6ONMiFo){1Jo{W0gk z#EppuxAeYMsE-96?AAW^e@;3%WrO;@+OfObJyYX`oHk%@2>K`Sf?cfuw5-f%|-Xpc

K6B~TIT$OQsY zjQsla>zZV6ojP)`sS~aSgmn;r08>n{OwRq#LryAFbI_uc8qv%^C1rC0yg;-#{f;#r zlnA<}#@xt;iF|6yjvZO{O-Ib0?CvNA7$GPi6Bcs7|20}PPUG{i;I1(jo5zlJ$c2Eys|=H35TU&=+{z`h^8>X-y|O zk7UQ!r_Tbx1~$lR0H!6#UTg`-^zGk{{Amkl`i|Z66#|+T-?wt*duZI)L#T6!Jw)Ty z^x`G?eIJ%9RU8+z`G z;>l(|M)s2MHP95a`YQK0p_Qo3C3vY7R@>398@3WvdBJRlQsL&fq!GM#dE^lVNFge) zLfl|MX1f!m6zwn?Qa!X5iv2l4vL<8gRXj+mG5FsbNUWl7krx|ecNa>f0>0-T)anlM zH4>L0#(;3(Z&ImBEYw-iU{F-sgiW+1LzBR80dueVn2(lDp>eqU+X4cx;9bNH5b@p` z%tb<;1vn|Gfme?Q6>P~uK_Y0AM~KT>W4rTexN!DhYml=|;P6lGzI<5&4rf<>MSBqQ zW*30vC_oSvMPPZ3=*>n{II~JNgI)lF5dNV8q|PLcp};N)_WU$cfDi?$pL?Am@riqR zARQ-ru$>U0&=)xWzvn;J*Kzyo`%s|gPj~+)@}4^LUg*_oXlQcXacCAR@wv!&1FW{! zHEFg_p60%fsM}+;==An&vh0*2!4_6J_nUL>)cVNgcBT&{j){*oHl>C3mhLO;I(S(v z+`Sk*{lVy#>Z#p-qipVeL7NKfYc0-@aqjrW;vNUynu;sYQOw&Zu48Jx zx2B(rF~8<};}o3w#92Yz!e*a~=RhUZa=W4sIk+j(UtuR9qLMhUwN)!HDb zv`S6JB&~*=7te0+Mg6dmKDAJ95~37Y>q)#l$HVivzb*@h@xsG!*#Zt^k~Y{>VY;VP zc5>}a){NWjaYw!JU4J^WxB}(pr*=THFu~@Hp>tmq_6>B(9u-9pTnQ&)DvXnq$DfNIh(&27})O#b3A8TJ*>sUl;0L za1j0$I{vS>Z0i9h1^o-;wv)$bF4*3+KFLnQ`)u23(31O`7u(){z-2J4&pY9Fcv6ch%B33qd#|Y#RV|=VjFr{pF<>$7PGWK!>Q$m?x^CIVwDMN>H0wZp$e$6(-$H4GQ=w;yjUp%S(*|Z)Q_! zbaj1f*(eu=Q#k$|YZ14vh9*K{Xl9b3-dPqeDzTqig3PLt81H4hQ&oYNqLIQX5Yna` zZc}z;)$cb|t(4PB5*)}a{$B=2BcL2!gP&TFD7!i3s|C{@g< z6RzUe2+{u6!k5Co2utDQGf886iIhc28vPJW z2{?La=v$~EjJgrr?ZcfT=K(ozcAD4qx#7b!O-I+(lrXZXB@ZVWb@8g=T2f{rswzvL zl~Rp-rQ!OwmQw7!Q~OaM4;_i;UH)>be(-l z92x@%wq{5EA!K$ZEZ%mjYC#;cg};(L`2>oMY^3BdHAC-Qz{LeNfH-2e+01sULl*60 zkh~0IHc3LbH5q)6B}TJIZl-f*p_U_MtXfCrEp%P7|Dvug*}RcLOZIMFU-z-cX7}x* z8oMWM|Jl!OKe3yyuT~c%D}3P;z@$%~ARib9HiwBCz~L9qDKgo8e<0ij5WAaGS&oB7PokN!>B+8BSA;M5nKRea7I}H= z1YhEbt>Go*MX+{S{5{#VwV3)3VC6LZK`dzT_f5w;+G;UQ6c?w(E>T;u>qtp0#;GNz zXnm4RTkEqePcbokRkA?4Pm-s!KB+D5)3YcLt36JVr+A+W@)Q%|1)fttVgFhzgEmf* zr+A+&c?y7lNglIB;Z+nzt&MX4d%Xy$WJb-D_Rodc17TL=TO<3L(v$XzqqQEw5Szw{^0!YwhKAmKmQRbSZ7eFI4pC@D=w4)UMV+-S0=8^4;dX52HF)yED%BU7j1~<^p*T}y-pL8qjO#(1 zZcZkky|@Zti`x>Q=qF)go^4LKtAg^H3xW7Y{~X$r__3zRCz=j79d zt%Gc~&2z{qMHzUgGH;1?cKr4qc%NE6&4Mf|gs#e`LEELVi>*HO`9-mdXt!V=806zz zWW(^fP4HL9+KDB(e;6%J@NsIkWok?G!m_w!yHE0I^F9&#)S_#G7pPw7)7_>QTA$?8 z=6&+EZJWd5#_fK|-lFxptKBbi`+2_$F@sCS+Qyg_u4>6ZZ?(Fc9-;5~XJ8Yhon%AI zlG*2(d`5tSgKk)HgDS%T3=|qPkM=IZ8-V0_aEXRXBOd`S_yHx;^*c+-X|jK!QkpjT zPLoWfH0ND-mZlDYXCbW*I@!ghrgibevM%U4L{7P`g}o0s8SS=T-R`eXEboS<(`wh0 z@z9QB2K3jm2mR=T3t4*Yc1^ho?MPlgJLqDN7L>fANej5C)p}&-VK>eqK6*rUJ5BJ< zn!NHhRJuZ9g+sGCa;@YdQH5qiF;_z11)+M<*Hmr1s#xRp-Sj!f+262X*pQs4Z!DN) zlk+H~G|(Hu?(uplo4jSV8D=olcbD=>NXqodSosN04hET`#(NP!-|vv!i)0FPz0JOSAYYCP4GdjV!>}}6$_Yf zuh_w!6}QUWY;0XMxo5 z_M7B&{d;aq@eu9oX=nviK!+USuM<6a|IK3D?~hCG@#lL)zbD(BG=h)hjLGh-Rx9>- zG00Yl&w_5azhVBAWD`DZ_zXHGN)3~0D-aFIV!x(Pb9{@ztfJ&{iUP|iM7ZB&zhbwG z-^RR0K>b4o69NK+{jz_*DJsqF3bCWmq&#zW;FtrLYY+7ca2p7B+`x?yU&}7p?bqdw z;w{%xxJkxpliv7@4lq&Az{iLU!1n-(X}0j92nm{r zN2+^&eWdzZ;{6YH{r2dCU59X9m(ufLSOS|dc>hZ^ca%6u=fOw#c(h+i(}!^$IbGwe zIa$|QU#IUyG`Re3yrM;et>vqEg*INw*VOpWhcK)bHgkCpqZKVZG%M8#Bd) zYkY|QMniKh4`RfkjK7due}Qo?Y&kMW- z+w|Z4@pvc{kNbnN!y(f*JH2yeW+#1D2L`IOe!$H5{W89>CwDSC+b0s1l1tbQge|Uv zIVFZf>(cGyf8pzEjz8s0|`zZ74O$NH8Ac>4CY$Tk8IQVS?!L@{7^F)08NG%0Ytn7B<1g0P^+IdvGNhYihjAOyKH z=g&9Q^)d>5LB~y!m*iP{y>OJd-5DilV2&Mgz1uf<2iI*aV~y{{Tt10&McCav!tZmN z3`Jvf(f+`8s1krT_y`$3VVnc}jDnfvK(c7X_4o|lSQVdN*vQjiO}&mxsTS8+BSH{( zd=m~4q9jkhO5o2O)<`fIu{w0UeU(N&sq;`(1F3Hafg8Yh;x10|B@*%#9f$JtH0A8$ zCtNf;1lb}MSQeEM)EJkBrSJC}d4x83g$#x^WDU}1*^|RJbu3e?N-*SiB^#-Hcfua^ zC&MrKVo`rK?sVS@oF}h8=610?)#cuJ+NtE7?o7m+jk(;>v>Ytiy~T(<7;yMQ221F$ zH4v~mBPNTV@5uw80Z(BbEr{ZJT(f+5F(cgKL2r1CH_Ri4-lh0GyMkoB?!#e@3Tgd5AE9A2&s}qap27ZXR$b@w zL#PIX%G-;yFYs8dCTr}Sa?K%r^#R(?Nt?7c;0sui)wrFu>FDThJf>SS>@>yM1-))O z$|>*U*ll~p#e{;53Yxzg^>z-k_oFbw1A;LBOU@fnnSymEW6I??{X;BT2-uWPB0mT zfoeYYzL2prXW-Qfxz~)q^`{XYNzzlFrY2~+uPM%e2Jiqiaz<-V-W(eGNU+cw%T*)h z-CIkQSWZp`)N;p)jB~m22mPwfhA5(-+xmA*9GvX*L@T}FU7sJ#5B2-4E4_hmWw~N3 z)ed&=-RO)5oxu4nWB3?<1ohg!&mKomS(or$s)BGyMU>8_Y606xMVdq7c!E_ELx~3x z`xA!~dLh9QhpXcL4%RX2t2?U+oUvWi2dew4$Eq(@P1RiZS(##X&z~c!IoZ+PhM|S~ z^a&}WFGco_KvS@7J|*8*cz$2L8^8tFa7L=x*htoU9z?~C=t!w!T||l9+FPAmkw#i; zwR3VXy;&b#Qz)*97<9}leFLR>^inL5ji<{>@48}XeXpYQt}p5L8I0kC5;2(W)9FB~ zMC7#m3wT;ys6)H@riS#0^n6O2JQ0b4{?MBc-cY0%f5Wwf%?hBmdV6}0HM+fx?#431 zY+{*XHnOaz??{DJ4tEy%eCD6S?9}Mh^>o|n)k2|Km&&!uOhv3bUDlcAEJ155W(`Vn z8MAASjO(8hh6vZVi5~6lhe3i$$6_*(ch&%U)EQ))X|R19^`VVN$4!sr>^mXSEdbIj z1@J3#D7qD%78G5;xh&RGjd3KpSlu=MlQxpyS2zsasNQP68ig+BZh_E=nWbQU63#Hq z?_SLB8eyIAy;DLrc9R7>r^ZvN33TiED2FQJ2)2CM!>wtjH#|VEkKV0YJG%DR*gEgn z*t*dT4orAt!`S-nSye3p3!wxv6wUWK-Pl^&Xn*f#2c^OR&R}BLx--Qi#pA_GMP2b} z>zpYDhlMupH0cX-4trqvZTQryLsit8<@0@3K1~SaNcKDPI^s~yJRvWEg#1rVy97{0 zZUN(Gm-aL0B~q1$$s0M6;=3%w>hCdDj0I#Ha1<6HEwX#wbye8cn&6903kP59^|!zm zU*LkU9%ta+P~-9;#HnQ=r40(Jgs-0x>R1>o6X)5uma$Okd+|n4WAuV@dK*^_tsFY0 zuJWqts+F*z%$9Srz6T9+h9ij1nC)6NEBl7k)khSj98N}7uhOZuA=^q_HWi7avQna^ z%qXJrbVAoNS1c~?oD15Q&skf`feg#`=GU~mCNSsgRQ^uB{Fnb&m0xbH1>rFwRT&wU zOW1b6Pj<&eJDw2(*XU^;BnJ#!3o_@poub=kcX{G@uQwm}I9yqg^{S0kSA_Nf_((eF z4LO{lQFj2yMjo5lzl%@)8b``ziF(};H=?b=E>{$&jPY7dbhJ*x{C1noXhqDCdDdVv zF?<6`kA0;Hc!?k=%s-uxu&^3a`ySy|;f<4HDugp$qvVj+hd3EEMYHb1tPc_`&Zyyt zurbYFlPZAOZ@G2))?+u{;=TEnn`e@<1I5|i0sNcUC6EkoR5%8*K07u%>od&Wv<(Y0 zGrg;}de^PGY1=Kfn{~^UHR5x%p_!rML(qYW&+!cx3M<=3zjwLTv%3%@9uY6R+R8sio==pv?$>GpWk?;^@5(SGo7>LhzHmr zOtF<}U_cFFB?oA^`}x~`s;&Uh?h+k8z5~2mjH44LOhBx|HqfBF3GzEn1T?{~m!8MT zq@Pa^wdDRW{DNQc3x35$!Sxae<0M5A<)y2-n>=dUrnXNV+q%uWb=%gRmDy+Fm*Qf4 z=P}_$+B&ON(AHUd6SmII?K_qq?4MZ1mgRO#>9*Up*|zEi4)p8l2Xc`}dYP^?S4*>* z^l_kLe184V(BufV(BzyG9=JA#lV2Hv=0jd}a5)@xzKt$SpCvlGu#*r~x?~Hr#Zc|d zjn6!GQ&WA)Hw}%Hr`FUG-;oMje-HiMP{ot%2uABJ86d6DVBN{EM}q5%#zLhF;rb1=URwA^(xe69|?a1h| z6$7gdH=Y?dJ|ONIcwpf0fHW|=MmJ&`wyoCHR?VzBzDip4^s)oXb)3U`P~f3B7mr)h zSnAr}tj1@**Iljiz(-2+GpS_A;w5bFtn!ek*Lif5Z0nZ|CngTSTmvUx${Z)MW znuVHw!(ej;+;@B{7=`7Vb-dHTFJ5PHzLBaGbK#+Sq*(6G{&UN&L^9>|Vx`(yJ=Rh2c2qjLilx}BqpP!4K6n%%3lAWOw{`@U zgu@1*R@HUdDz*+?YR+o)ln)d?7oJ1;Dx<|>M7^e(enx*BMeLr2P`ki7xoAVYlutgf zP(;MzP=Q{*{rc(l#0!9f;;KCy)*Q?FolXz&O0mroAEtv*4n=S<{yc*YVzVQ!3!1OKCc#jb+WEPr3Fyd@2gdi!=eJ+Hl<=N zlk`$2eYZ{)jG#&s3`Ixq>gTT{Nj?uDonJ{KZc<_~~)HHKH~R@orK=&GOX)h7?sQmmGmNgYo~si$ow z>-)vmJZvC+h8@(GgY+QHK=)i3GCMaM~ z3vSx5Y3$%pm8lP)isB|;e$z(X2HSeuI^ED*p->w;F#5T^xtiU2ps5GcGBcUu87cGm z79=qHof zjyM0HZb1d0-tI>Cv7TOUPfu?n4&^vIlwzp@un;PxKII@kSbaEbP?BxkwuUZMpDWaI ztd^U}9myTf>2gmeb#$cK=c}o%as6P=d4v`bX``b=jODen-+QS_Fn=CI-dEooHl!@V*&L)Ix9TGv84e0&vF0#vxl88Iz?xNp#Mt%|3@K!LN+cX)3i!a zQh>QUhS_w&C^}~_*n|V_&xPh}TKO`fMti_E%1wI%=NCLE2D6GP0m#^uFDw*8U{uKr z25GLpl8OZzb-)Onwz=&WX8gB+;|)}3Jb1mggl_u@{*)9n#gt3&FsRja+LR;?Zy$K;4g_zlXNodVJba zaOYg}{MyrFZzUI=`rR#7n-jgHfs&{t<`U8~|A(?S0g$UI z^TqGEwePp~z3SG!cU5o1umk@YPpsVUu-L5|8JKy=v zxBkBPiTK(08*yzo9*z$W3^ne{SBJd0p+W6{wcpy*HmsE+)rUwoh#KJ|tfkqqdT>PT z7=m334@XBoQ1>o;Abh)W*9U5h0P}bOgVDalzu!|cV9V?9`{)5{SFS{zQ~YfY{>8&9 z7o^RmIP2T{(=LQ@-lv5ppOX1mPr_5V3ENWTR9XiEspSURuX=i=r&sA@BKcSp3mNMj{!h+Hznsayk2L&u>cv2W6+WPdynib7c? z==4pn(d*r{?#FuSo}Qk1tuI^bgI*Nt>*=lDm&o_Z?}=J^>)IY`x0SYh;i2r2{6jE0 zw2s3yBdZzbjVFv6miDGsT`TR=gfr=C!N>Jg;!SYoTiYB|m)y3mi63uy zn*-y=Z{|f2b=(*Cc%1vrDpI#IGpMHD#OZrba0^Ljp54OZO1ez0O!PCv1CcpQj29-x z3(>0(z2f@Pwjik5O-6OC+f%D`ch!T@dijt^sMmUu_j$rS*+Z}6?C$B-)&SVjrHwok zJQ9A$V@>f>`mkG9I9#)`nswfK!m6?U86wC;PSTN7+!@uA@zx~ma3UbdE>M!{^%aC% zaVis6zTDkbk{Z3WHP>8edDluhE`Gmr3bR4=$Z4)nl_n<7y>BHQ*-zU??*~`wnQyf9 z%pCj@FFh?}VOW8p$Y?mMn8^^vU$}unP_(vl;?WsojZxsro1>q3tlhYp<<5yvgLkKcahvqR^=%hgaj_ z)6@!Olo4z-4_~^~<4Tdx(r)IL)YYP`5 z(_6(xM;TrGq%JOzdio)BOwT{Ap1{Mg7E&&bG{A;n8{od=kgGBSz)Z1|AyI>hN{;ZR?+)8eZ1 zV2>_(q!ycp^Y#<&4qXGwbS1sBqYzY~Zoa^k`)A2yntSO2y1q44n@gnpf9nYs(0RU1 z+z-En#-K*DRulcfHl;IfuR4%a#u|{0>4t_`LeWC}s-Ptj3#k)=_Wr_J(YgsJVf z^r@ArbI}t}?jCm7t$p2%UT-e$zGmMpmy26u53V{4=eVfhD?v7y%Kx3E_~}KCMaXTk z%Tzg2=aIy}e;Vl!oT_jH@n_N|PNv(oSt8lC%|bD>>7Y+=G}7~zBM{=UN43s&LN0kU zY*oCGY_s*6#-X!hhAHdFC|frSIkOaKEFN*Y!`vo2QVTOjn2||#0^oQs$J*j%;GUJ@ zW^VtooF^GiE1()=0IWI9&(3A10_-s&KmNU0pI1qwF?>+1lq-*QRXtr@)pEBc zeaHcKbs!Q-+y{*3A{JoDQC&lSIWh5xz>zS_;x@%|%Yulz*V=&rPHL!k2n`^~0mNQ5 ze2K)6>=&W(vQFY(O;ht~!M@7J|4-obklp6kz0BK7qMaSVDZ1p&e|0t4(7Z;KEfl9E zWXAQvgfPPvo)*@DV301zYCClj1{?SCBTVO`>y-NZgq(n18gD$|^$T0LoWUpb%s=5T z=o1_R$hE=wu#Mc?+Z5Ua+qgTsx{bkQAs`=<-rK6ax0P+7_qOo&wy5uIVMF*@C4-d` z1{seH&rD5DJvKe#nVz1R+#VY~RN6j$>AFMV)TMkN2rSdHvH@ei8OR}r9;u!{rc&=A z;bv&=hsMVa>4i&YwA0op>!fz@Fp|T=hr6t!hqE8wc(|v>0$*x?(OE7A{%k8s?#M&O zO(YyNOKKBsCmz__j~MaXYuGw`cR{RSt(P|y_7v@^&QC{?!duR_i|)5wP#x)~Sq>7p zmly*Wt4ra2QnxM|DrOhT#XoFEjDFUZkBh%_1u67z_OgSjne`P%;$p%7#ZQycuq-v% zH!W&t&%F5KHeWrgw;6dVfWFT42Y{5IF6%V%#wb^ILg~>cs0A14fzbmJ`Jg=PjqMez z5^|J#vU|0@?(l7igrRVo6RDfG8BnLN0^xm^fSxYIo619t-hB#rg?2^nw zSKqa6^qz&a(Z)o5VAuML&DNUzMX1;p>FZCgxwK}tlW8e(o&IM?y*8k8kMg9Qv?A2d zpz;DQnAu^|OGcwZD*?vKVAP6MON#(JfIUY^24EAl_JXRgDQUCba5d}bEU1B&UC(As z@Fh06Y?{P{1l%KJaC`26GS-*)`>TlPQ8O;AAcwh&vZtbuvdrYFT* z?syu&qTbQ+~a?T4J?NCR{VUUHurs;}^}U^j1YNO4J&9`iio5o;di5t0&0CSx0f zbUxEc8I#B+M;)&*IIiP;q$z?$N$+S@0odEQXF-@wIxw1CsZE5C0E#B))DxEq+<9Um z_8Z>7%Ge9*wpYsA*B8>osqZKIEWwg2m%^6r><=$3X4vk{*RPMq*I&PR-QB|rvxPe* za~t~;iT;hb$vX6FxZDrRBR0AXI*IPC3H2pdKKCgjUiNwUBZ=AZRT}1{Ew?t=<4$1|PK( zjwMb$sM=sCwKo`&68!GE27$bs!Stwn+(NyHjF+Hr)!`7pa0mlaG$Gk(u;~LX(`BCY3qjo&>C>7$st;|72&mr4# zKe2HqOAXeK1AtL0cYhmiQ%yEkb1mB$r%hJ12kc&t+Zzw+DxP}U*OdtbGF`rOzk{wS z*+3v$@ui!W0AIj|+Z+*_?zdivnza^8)yQP}QqF>pUiW1(4ZJ?!b z=S0(rVbBN+G!~6cfysIR@LLxj2E0>e_&`{R>2jG&Q^znA_Wa`E6bmfAnqr4B5E@LD z59Wczzgyt62%i5XdI263Z0Pa&hl=?YFT2IbZm~1Chk1`J{tWdN&;Ox}B2i|+!gMk; zEnNWb>Lk2#oeqvlw_O(4EkK%c+l@v$s%U~C$p^Se0KgmFc1aJrO@|Kdw6#Z&nu{oL zb*ZpmZa?L|fr^yK!V6W9=S&_SFdc2fPsKMKpRYecg=uys$%e z*=4u(^*QrvYu=D^8Mtz-XhX=uzp!|e-Lep@jMpO?3XNcowdVzy{TF;aUEGc*th=0W zNNMt_6+uC6lYm@|f@~n((io=nB#3wEnWATU2hx9I0UtUec@?k5I~9&mfrJu_BwNwE zV>Zpg+oR^77})MZu*fnCH2~9B|0e-mA_|Wl@hh2)f>n>-W&-sDV(g53s}h`j7ba73^K8`N93Dedv6Ch+psL*Sqokw~9Z( z=Lh)p4fsCw{#*I=_4xcl{O{k!uaDsS?&sI<FiT928dNIm{mFNL8c~P;oGg)CAE7DzVwYy5 z-=5Mt!ya?RX|HwZ#39k*B{mm6CHmP`@mXlMuBUVYGYMLh&k}U$i%@1*D$8RPUgo>e zxNc235*GdAGt!8&l;`8c-mSjPc&o9k;*+2MJYSEi&L3f)5`PIEu?Qvb%ywKqz^|?R zdcW`=><`#}d@dm^|GZE=|326s|A=cBaAb)mpJXopFGi2*$YJ6+e10$gd=3A+8`t09 z*Q5OUMqK{^zgGD5D6XI6*H>L|JjT2?aNR&1 z*)ym<)(f}t`w6q=*Zlf6e*F-B|0DeO-^G9bbLW4{Cd6C7SBG#yJo!=7=QZM5_KlfMR#R&2j%NQ(C1nSZ2{Iki!^uH48UG9)X@dJPHY%B( zaerw%Iy8`))|f4W+WuKrDmh>=hs>6NP*NwjG}&1g8xWQJ)WeZit)eJ`Kz&XVa4oeV zMGZDs-$|;L$8Uf$a@jCY14|k{F|`3HS_8Gw-MuWD8p-IQLGun{nCfn$7 zcWs+B1pEWFPdYXnBSUDmKt%3zc83CZS+gqoASEe1oM9uBE_8w zS8@x5bUDe`gWv+{S@R-nGzl8!RZqk9b&4tvsZ#YxJbPxy_ zR%uQ}{Dyyq1Gro8LZH+D?+n+J&FB$kOofFhH^(-imSN6hU>0ykHurYd!|_?$(x6ZC zgYGo7OrSBV#>i?500U3CRp@<{75_R^L+h|=AU1euqqaB6_WsKwrLreyx5q8De)g?Z zO!ldT#p4|gBwiEG{|fVX3G&K{INn+%2SjVyK_*zD!b}hiURuGlP>4kfOTTKtSUn>S{jB z2h6!bdg;4FUMdf#ZLOg}uH*~%GFNCZzGU-?HHo`#Pi`(ho*f+Q%^Q+p0z>sb5yE*^vFPEi7Ga z@$J8UWV+kyb?nwkc1wQh&Z&n!OXm?VIf0e%-wF{ngP;?sSiw>WRdQo5};&X!%R7tS8dW;jAO!L^Z8lk}d3)(RW<8=2Cc! z99R3i#hG_)n|}9X&Qeb6bXSQQNv62~{}H&cCD>I3#hbBr#b$&`CNY~gxMnSX=?iwc z#6oMPLmzt|evnRc*j0n#V{5zAmPVgXtl2SOi`nemgE3uerJGzGv|&#>A&`0I;L6QBSZhLN;3w zV{9n0U4eM8(L=;ACB<#Rj4x)M4O%p_Zd0`7KrMZKz77Ci{xur)jA!3BM|*OSjK8wJRM?UX zh6ZJm-;Lt9sys3lADHavo*qmrJ_oQgZ!qC9^c9PB7V$Rwn_h1>T7zbMX2;bQn`m&@ ztS)!Rlew-{+tP@H>zf8b#Z=U0OXu>=-g*!AFJV%D8$4qXrWL!6j72Ry=rv=MB=%)s zepzfr752}M3uYy&v8BoXa3vv&Af-{ipOXdOiOH_2>OBtpIrFTr!q_C&fy67gYw%vC7n z9G5JtPrUp3!Rg+BDBd_!LGpr~u`8&PyVWvpvYNErm%VfBlb`LLy0+m=xvrj?Mm=}} zXCTAg`#0!^cOnXL&r?|rw2C?+J{1H5`7@<`d>NC;C{S?mTB$l*Ek{p{$XyGS_eAx3 zZt)-XAN6be-Pyvvq=NqB*9f7I;7aQ3mVGW8pD3IqJdF+oodokiO!newbhYPQx4BNt zR97;=#VyHE#JS-#?>HaSV}LxCb$0hmyf^Dbp;oYbWg=g^ZMf^Qb@|~!Hk}&WTxjeo z6hkw)Y_qqCr8RkzA;0W31>6h%h^Nx(8yxorHYdB*=G_thF1s(DOTpYii;Hgqqx-MH zQ+}aK33!}ApLW~_^rwTN?NQ}Bqz_tEf~T1OwUk*? zv6Xx-yX5R)2hR&<&$_xUsrt3XJvwm|u$Opu3RKfupo%^^s}7!MSue0pow!9}M8d zm8WLH?C!7TdS%;&F-ypD&^NbkaBf{XJ9edb=kmch7|jfCE8KjYDE@TuTSiY|>dwiD zJEse@Crt3|QoP5Dy5e`Dl{WZ<5M$&N3z7|04Kl8<_7Fe?LR@%sGQ=aC=sg(RtMyI^ zxzt{}d&-sddYmj4V@{9O4?XXPDahfNHQyVB48DD&3LcKg0NRv8bNTUrVEsP zD#oWH1^ibm9WEU$JyO!xWK#_p<9`xv?nS#_kYxi%)dtt%hq%F1gt%u<-@LfhF`i>S^T`ZXu8JDTS1CyWL{7*{o9r zcvf|iv1U|^lSZx4<8n@k5=59HOya2XxM5^j4K0(TY1z=#*CaYc9$tjH18EPCTG+GP zGM~d>v2}n}%fV^^mqgrzW^5hl--fKMdmHcHvE%*hgZJ*(aqq(C_IzYv;UjxK2WK?n z{cX(RyP%^_KQ4^%>{%<~6>)DO5;5z>c)T%yHw>~b@C8YuGe^u3on~b}n>HI`M`Q8P z;jRZ-5`qZM;#A zZQIrgF8(7}`uxZJMcGZ>sLPxl_lMSfiJ<5(ZaP2z8MazRxJpUH1ssm3>XW6KG>N?O zTO_@dvk1PiNyPeZLEavTeL6-1+0<<0(|*0+vruyzUAwVOXDfn-X$}yJMAp-wECL?z ziLY*RqxNm(!rc26S0*J}|HReR-R%hu_E+uypEXymxDRdFX^nfFX1Apq`T-jJc>Rt3 zUVzE8T9M%BNYnKbQQAI}=7SD{NF9X>fD|7sdVzp9Y$mInv;uV4 zwzn)1ljl~e)7Fw6UTz0+j^MIr=+9BxJ~)Pnfjb>RR80W>8-n=d9L@f<-5TY{k@qaV z_r2L@y2sdVa&vh5GYgA9+Wx_IUli`^M$Z}OYMYgUFBl1hb#WJ$n`1YIMbElF zIeMg$o|@j4NKa2s#Fe{lyS8j`8?)mnBx&!~ne*MbaZYCs@M8V}`!Xv$N}U{eP90Az zL76#!h9u;P`-tBRFB7yOQA)+_vf#<7w^4s`Dop20c%)GXXgk@V^@&wURX%)OL zR0)78wwDmFuG~sMkmlos-k4=C`rw(+%|pM}8#1`edn=n_(UQ~IV-5GTD(uO{4Uwc< zZ_s9Xzy5qJhxniQ+@~xyRCJ@+$N9f$_x6YYy{%CVjsm-X`uXrHXfLK%q*gelnO2+c zMXe53+$FlAjwnOKMk9now`h}0_j6tJ#pigR4;*p?7WQrYkjIHPPD@~covU?>P7{+o z#XSR7d9b5qbnl7u_f@2u_kCyI;vI$cJ>ib7QQo&OpJsPKfyLg(Sxvn@+(P*&%aqaU zRQqo_u)zh7OK+A;lAX7dYdbK}U4V28RLpP>0?wdzyT;ULyQ9ZJwZ8}JH1e2cpHy3W zfM+z^kMTq3n2;#&aNVZF?}Nh@rj-;y-%ZIS&PQ*FiUimz3VI1mjyg)F5OGDZO3tV& zBIuJTwOh)#>66aZJ%FiK%(hlU_SgLInIp1`Sx8Bac4%2!8rQl{IN- zbU}6^SRP5GM#@M&Al-+0mHblt7VPngkXO9v8IN(Vy&9Sky5i%0ljTDNK0b;+(PqZ~ zWMJ_TscA|;`lO_aR6D59>_8^B(DGojNWa+os?TF4MDJJ+St>vr}xcdkt(t?_`x@34n##o=glQ)zVDw$ah8 zTS4C##{6UOPewo{-qV5;QYD8z;?8MTM&$vgZ6bkmIs1?M*^dsgI?e2z>FVZsihwt|o$Z|0tf;~ElYEMkRw4b^bo-570 z1RTN+Ht&jsT)DMDi5xc@$QV=Gg|L>C87dYB(h@!Q$nK&q+>;B;dr~@!-um1J`C%E9JNB^`p7x3ICf*uzeY^s>Pri`-x78i-pg@<646XU>;+K)(X= zX(3&h`?M4nHI1q!N0G3!SC@^MrY+pHi*B~RAXI=?BFEM>(5zV3;E zoA>;kD6Q~d?H2!MdAI=;m3;R*;R|>YzJQX@t%TwmTtWqyyi=xfayDXdduJV=Hr`*D z)$x!Dx7x54!2e=L(+J+kmIdXJ|`V9wcHf!ZF`f?K$X2fZ3Js;W!Ay z?J@g}x82oKx62l5-cv6Atg&-#+W#f-@!Hy)qy{TRyTu0PsXUnDmTs7cTXo^5y)WPPG6><2BmfALlkFBpA_`a}%Ee zolt1IiXElWxYNs!NDZC2$KQ70gUT=UUA87sZAN-48QXg-iDE6-Jb2LTe&=wv!D9}O z_KODsJzIMRuJ9FiU3FP9HhIP6nST(U9Akgm-NnSehFO9=zU`kol60gAr3@J;Y7;yx0rc#? zUQ)4n`XqOQ0&be50JAnWhtrm1btHG|{v?q8+_|`CcYZjOj&2{=vtRBRig=4jpD9q- z5s~&9oOaW$+4}lQ*kX{pVb?~FeU}v4JzE|E5WUgukGUODKj1g1-_36b#~XEJH!GG1 zq3%Uwq(~B{pM=##aVmNyr;JjzVMF+4a@xM`nYe`B)4haqk4ROyoHWEHfX+Odv}hE3 z>#PB464E>9hvQH19yV%@yBe!Nmh}qLtTT1)Em)a5%4hFm*8F7B6S{0f6%ok9GBjJ;|`6Iv23-vqXH^-e{(t@R{^BJDPm@4Co7ctr+PdiJwzdHYb;&E(Ja+5hRx7}*hB({4#9i1iA=#GQ0M2A?3;QkTFYhy@5 z_$~QE=p;bi7~~x?idAPZnXc?xj+Cvru^?Gep-?sBo87W?))KB|{{KKI5DfWkAr!AI=ykXNt_R5WM4RDHFDlfV@@xN^Ux5c6o<`yC%Gf5IR!~P zRZ1pTBA8sJFqMqSUGaP?t4|vfdW|p}G;sY8c#0%Ds5>(z^3thur{Fr9gToTtbsaF`iuM!jR4LRxXz>|>J72sn6q%PQ)f zEerYPpH)?d(=VJuju%pr+p*$Cop%6op3KFJyKK9zXU0E1BcF-oBph3%pl%RR?MEIoow&%JmK zDQ4uLbFWBYYI_m6hmQ0W?0RHuaZ-JF-@ZV7TeG;%74md>`io!tTD%DBB<6G`C(FgL zTCkJJWH;PkG*nWtg(rIR8iUz*ox?#S!nlK2XO%8PN^&0gOKu0UwRB?+eCBX6=NV)j zy3EE|`~5nhB@&%Zse_$+Ztg{to~XVPjF+h7LH`LpwrtPf_NP$0iw zP`&+2h7t%u{fhaq*ir1r^mw^%L(zF_Jex_>b0G#$Rk1SSDs5EzoP2okwr#^}wz3b) zQKQRb^;@bVrp3Rab|-vn1<1Hpxz5?GM6_t|C~T3Z9ENF2GBo8+1Pswxm&I=QESYwr zZLaBP$t70jzLL7)WJ@1h-wpBxTAlEV~l4tNVu|R z;q)Chnv&|lO@RjW)aEe`__$bGDY~FZOWVtc(~kuP$IH$eZe26gjrJ_AcpzEu8FbEM z)Z{VhZAtM!5i!+A9!!kx=x6sXzOT@qbi|rlD$VI;SfjatGW{6xGX=2RZIJJWR9^uO zGB^R=paTuQfwS~XSq+q>!Lu8>Fem9T<1=tHI>(UjA9Xu~h{hFjqk&~K=9VH6$*ln* zqYE)iuH2JMghPZp!>Y%$jr1%%cka14lqSqXHobLg zF*jQBTZ{`vV=;T{D@e3M|57}l|12!{FDX_ZkIlMxEELmz!s+5LK&O-iIB5;s*`p^S z=;yJZdh*=r=t0AOjmd~j3-r5Ir{wWEj4qv9)M^Bu$>c*;p6J%Oj1I3ya#|%nTFQG` zUJ;G?#Fj(R-J%n9#+I2XMP8c2AxJ*+71lmQ2-JUVl5x6$0eHaze8vdOP#Fd`DSi^{ zt3$QxkA*5;W?sD3SC{7>*zpVGS$cPD+g+Z{Eo>~$_wRmye9`MM_b1TXJ0N^dwLSs2 zr{;(0DYk*S79J?$EPMy1Jqgpx>3Yn{9<#6$zEi$4KFtaLDgPP2=7e-gIwNV0I!`!H zInOw?&*<1QTE>F{r%Y!|sDttOC8x{i)oXNGAz(I{%mD$J)OxSc<&^wBi`5wn1bJK0%@)1Uv>lyXVE=%L2w58G=EOT4S}Z-Qz7TrEUg1#%?j>U&3}h5Nbg08= zlwf~huY{-mFdO~J;(e}ycl2GZq~q&sjvcZ$lN0sI!sh5`d?Hlwa6fnmvgz-+UvNrA zkuG4BlQX7yU=Zc)*|1I@&PC$mKH=7^$&Nx1lg5ZRD9UCGI0MPB-~;Yx=x}&aH+PgP zleS7O%3$|QzTletz z=CLxn%2}?Kq=n7)u13RajFkt|3p-49$*|WEK!iTa&jYeAUdJ5L!U07}(gse-I7kz8 zn)1MIKUP~#Fi}?UnM`lXGKXac6ueB}n@;_E-y9*rM4mZdVNu_$)hd zc1jL-i3drLI=+izAtL-qDGH=@cGMA^C-CuN;;0z%v)!r5P3wkwFOB9x*NqQcxh^$1 z@2OTY7WT2l|FGpyHpgP!y`@?}+G9`pYvc8?E1lk+TFE}MAeE|RC-}GlTlI(FAv=t|L^YYKr$TnU)oM4Gq9(VL!Mc$B^G(>bd8+MlVM#Wi9wwK20a1fTRW4 zL*Kz%$Vc678v@X*3uFXVR~2axb8zCb@4WN&a9=fT3I;dU)(wV-cW*SBwANZ@bF&gy#s52lL%bT+c z3sPR%h&fQtf*-&ZEs_3WQL|&6Gu*}Kv^ZNr1$uc(o{E{NaReEsGA!+IIWz(N_?l=f z!5nC7V9xn+K3yEGVE5_B+3*~ELpXCr=jQ6_oRHb^!nrfAL5!;jogLTllH~3ZbI9#j zX`cH0D2@C}(> z8h1!D>o*&mE+iYgsHURw)DBt?B;$}nz~F>vy;MyobbjTL3*N;OF=%9e`-B{_tL=Q%KxEa-5hB0(xb-T=#o6)5K_P5Jp(6-Dd zNo+Zlc8eN^U5{b|l%btEcZPfhU^LX*&%yb4251v_rK(9yS^~twD87jwUhwnP&wS?4 zG5kC9nSY*|XQ{=P=cncuUtr~V8uw=q1Kdjf8U$DgzsGg{x1w275+s}~Rdj*5UrE(^ zo4$A==@$|bZ~<`mfIU_#lewM@GydA{w4~)I3|H7(4uE0 zg8t2^X=9_Wr`~-cek>vSj|GjD<5o@P_>wsW5&zuF-yzYCJP_1XU>i}?>?d=lP}YME z3(`wy8m8K4h@z=6tR{p!rmBkkI^#yK8UkqYE^jQ1SWm{?=MPrAMWy0DV~xdP)&t*i zMS?-;s;3w4*6FKpgEQtgY9C8pwmtK1*0}23t%$}T?$PPvo9_I>;!W>*cVli#YyZN+ z$lSTt*ljngzr2sEz)_`iU592S@sTB(eN2ggW=?-Ijt(2Xpr$Fo`yXmF8&b)YLAWtBt)@k2j1AwhCJ6UP_apMLq&c8pO*c9j zUp_7U9E96{u7qkzJkEWWjz&V_0U^mn{U*Y}Rr+5fTsR!E?EAVS==a-qt|naKB80O= zTiYhna~o@utxGaYwn7 z4nIBJ?7z?dm|yR2)O#Q4c_el$VfG#i=pD>1B#&Dx<>MMiJqnMJ5yEMSHWK?^eC{WZ zexTm|*GR8ZjZzeY?*}PijQ~rtlbPD%?`yhOQB$`Ra%noVZ9X){>!I;Y_DCrjjL!aV z>uO^Dx!q~fYAk*a%!a!-HSKoWy|?x5P%_T%xfh>bMavnvdrd4<%ldRI?EW{EoRE>O zw%)FTw3${0CM>%w&s$!xXf4yo-1oHXUOhqsvaY5(tb0SJ)sd_Hl=h5PtDR=r?H>KO z+hi31jZVpwAOzT{dJcZ9{okcDe#nrBb)TZ^rpRu%2(Gy>^)|6BYR5Pqmv+sz7+vjYzOD{y#E?}BNSk!VEoum(@*&SF%0 zT}`WKC;7N^7#A&b*y3ujba>`O;tb@^1A5cA=YG3cBkH!(P-)R{V5uE}Q3wbWKX_8% zPo=i;4Con0rbozEL{%-aQ1NNvrD_`y{3}vK}?YH?zs89$+@-(GS zYIT(!_RYoh{o`G3qfUH1p2@`JOorsU2K7sqp(pQ?@SR3+27f}a1!iOyY&IqULXV=~ zC%xeokAm+2Qi1*$D$u2tsd97ap3?KBS4!HF5(u|S83lJ`=%dUrAtj}h)MRQtrAwU= z-VnrH!p&IRa^~R@-B3CnGk9mh4+wynkXoAK_WO-+mX4k)kzWX)?bNZ8w2xBhSrVZo zym$c+q#%a>?Z}{MmrKS(|36)v7C#x>RCHW!i)c%COv5)Eey`6qyZNfwq)YbOW^I|V=HSjN zt{Pdq1Bp~0Wk9TJ>D|dFv1<3mYJkyNy7*dtOt2vXtRy_B_~n^+mSy20@kU!d1?rUV zKC;w_DJNaQme;Dlc|fTQ6VO304S%Sm&PC5Z(2wdT&{E~Tnn6L1%)|D_?4rG#nkhVB zcOH-250AIe%BQL4^K55~(B31{jCWq$e{O&2g;EKRi1}hANfu!vu9)=O^7b+n$`@bL z3rX@83)`j*?PD)Itaah@N;0PaD<`KQzU8A=K6=$PBj=eopFf;`1jiYX$pw<+`{If} z+Cmn!vlYLO5Y!a6FWQQjlwh=Fx=%4rn&;6{klru&!!5Ii?uISlY`X{P&Q zzToln{ZWfYZ`Mo4H5~tVnNsSphh#O-iIb@`w~Hu6PNS8nE|eJn^)L0dTfr6DT*)^R zj#-n0{vvVR>|1OI%8>COlCbzcSvHaP8I0oM-EXxuxQ=Lo(eX3h+ZkR3)I>sa6nHOq zk@>?~wCglPmUF1F`F9ekz>4o=fSVD} zhgs)b`pz`I^LzB2%&LCp>+OD}uj6Q(y%#_4qR=&k{XfGJI*d=RC5JctX;C z=vWkLf#(egD0oJchueBfQI~eO00IdnhK83Gt0#?r#p?_-);IT`zbpv@IT7$DKb!O; zr2#*Si?6<_#%1;_9$)G|zhm*wc>np6p?EwLip4_h=esv@K2vG;;|}crUm*xFl-8pI zeIO3%X-t&~(Ud^5crU0(ya% z{URw&zYORX1pPd3L%*i*7t}%XtYU|FtjKsM(E~KsvnTNkFhljD1ic%l2iWIl6?#!V z`AYWn?D?!FJJ2EcK%=KWbaE2hOL8*p3AN<@4#oTX?rrwg--hV0gWF_>HMN57s(>UG z_^**a!wsw7X8{(^WxA`m%YOeg80<==y0(GfOY0yktplp#JL}Nq@#-g|kEg)#`V~^6!||NUfrPxo@&7N%12>Jb7`Vj9t#}QGZ1gaJ0*d5}jAZXgXdLO#j0=D+##9JJEIRwF*Aky4 z?-Xdty;H=|Jo$$z^Eh-1F*58j9>Rro-%P099z;MXA&!dM$Rp4GE;}+=yzU(uR@*$B zL1Kw|!ifNzWf&*xR zSpl6j*sdr06u1g|h`WGqPR~k~dTYGU!@6XGJtw%DA9ej_msqCDGQTYUXIX@X#D9gJ z6%%fHA^+>Vm~FpH&-fy|oBefGOwz9=dC!g?C7DcDGXEm^KV^~k2E#k_tbS4C*AWr% zWHp@01Ir79B33zhD#v!^m;%U^e#z_8h$du|L-|FXtk)!Jj7>*>U!xg5c{cGzLVP~K zCV>TcOF}aNC!x0a3Yh=F6KKwIZ|!lR$cke6aRH#VqPK-oV#)L+02XoEk(70QT=GK` z=}G`l!#^&0C??v8V!@)u8sY=m4G5fE^#4*Km*R=>6y?>Bkqzy4#YuYMsmk_6k4Fys zD&?~GUSGLX^8Cu|1Vr7PfMs^3I~!%y`Fil+&X0fa$k^B)eE7l3*|$;yjbE z`EZ3yQuQ)ATe)7=Ia|@()X+Nw%}ndqG@)^fOo)!|RcFI$z9|ZyCmd(K`h1pW zgrv#1D~UW9+_{S!6wn)qDND{LnC!@dVtF8tIYx(#9%HL@uu}0{K62xc+}K=SvM(1j zBs>G6U4}EB3jTKPShsG+7mc1j{}fgHS?rQ_H*^#cP=uEwrg#?CZ&mo9;w>mR1M}(w zBK|1lR=YMRqm(01C}urV2=yaVsauw7vMA4(Lp4^o3!Y(eUWlXc|IYgJ_|GuW#kyvr z7K?&v?^y#CD$l{fMT2k59z`B=fKyQm&ZzVowMOUQ(rI?f1Am>;?|8Dtxn5sR-SzH z)|*_`Ymw9yN_pI7^KJWXI}rTN;E36{adNXp1h0?{bcWkNMdB;iU}=@FSRtMF%9AWq zSmG<9-Ba8K8YjMDyHvgs1Nm~oIw__rbSJ*Ef=~a2eaT!vgH>J8V6*iE9eL2=Ey4!e%Jw62CeBs3BmtbMg{hbD{k z-l#ySo~IGG=~P(!m@7@~JWn2lrYd4pJwgnJGPL;S&@3ftk(F;3*$#U>QY(i2J9kl0 zNW6O_Y7SW>qtEe`3rj9Op)+N|ezYO{)csUzvGW~c<)AU5$J-5oH-U!uXbfY#SRBnE)Q;iWaMfvat+cVSV z)?U^}l^LnEJDdHR2fF^HQvzko}1V305Gx5x)P(2mK>D?^E7w=W*T zf3#O_s8$Xds}}~RNJPU42c*5{UgMa7 zRb(Py|GX)*^42k_|3WnC_l!ef0WgQv^SxV%5m3m{kS65Ew0)R#O;+TivL+!j+1br~ zb9K!5VN|3a10hvXP}$811TR64HYwuAlV*@Ye{oX4c1HmUyppGR9ui4&ynGWi-a63q zW@@aCimZsuT|kYu3N8^X)LhUfp`%k==^e@?wytA{2h|Xk?4eLnx4(x@ETRW_E~K7X zjvdXhiQKN-%{fi(efsX$aYTrYBSIwEAGk<_i1=WR0u7Yni?Af-{lXka2>JbkLhSbr z2mQW*AZ{~XaApbjK|A6;Mi$Jb`I)usx4YoX!o6G<5<|s2KeN=+4LT&w!B@l^K+Ri~ za5Xdv02&2h%Fy(w=$Yu*s3w}COgNEO^ia8pH2pB**bl>>Z?H}uMT!f#EPSZ)GAF}k zKra}q2BSqZ8okHc6`*Ri0ncikLwFlOH=f^5kAzQ#blg4)Wkd5paJwVsp$I`bvP&zy zVZ-#*S5ME2M#*k>7}(XOXpjeL)nA}dC9j;N=vaB4%U8-+*3a|9S`j^{&+<%7g=M@Z-O!TRD ztNnQ3b4Feg`R$uj>6?L(=%nm7N;_7%SxEsNGPlmRAdf8no_oA(-pk_Ns&^DVj{%s4 zn*OA~{F>B2G8IillbZg>KyRbJ>pd22f9bH4YOzt+7u`|DqTP~K=xg5Fu>?=IO$wCq z65S{@rfq0&T|`Zb^)Fe0(0S*e^L6YE9ENLPvePk0)ktmQ550tO61ERb_yJYZBT&j` zJ?I9WaJuA>!|KiEivC}jCA-adr_pAUf?m7L=d;$ z+pu@-;SYS|QugAK@%Kd+{<&SQ69d)Fd|z?9kFSwx_k9|B#i1Z%E1HJMBhQ_vSj)DZ zw`7alw`7Yeih?>qJ{NV2Blx>%`abda z`PcA$p)YAfYH4MQ1rUqS7@`xRflgD*4BxNXy^rH})cGI(_qI*O8Z~Z{^>s|%l{Q(| z(%--#qsk#s$f&W7=n@^&?|yXYyXjugK{Sl0v5vkr9fmR5Z)<4Wz<60PZkpsjC^olE zFi(oiHNlvDY24g5CDOQCL>H09tI`(@iS2`PcS{j5Y;`a#({|TJcib$J^jYNp_Qr!9$htx z!J|NJ-ckP!(O&&KOSDJHrW&Jb8>bk%`u#L^_50hjXDp${=u}-CDWKA>f zi`h$iyDwdn?&?Bo$vy9BSu$RevpVEVH*;eHH&}xCXm_u}ezn`<@7dDmnv6tt_ix%e z5@MPgP=3UO&6wX;xji`Zq>19-6yqiYF`jSzb2C%?G5`bVLx@{hKs3nA=j2Viaz~ppJ)k|ljZcDQZ|(HBGDOZ zNq&iM@bj&NR~^3uMO>Lx(!;V6+HvHzPvU9#B)kG4w3HsPpFm>6)L|r?N5eqn(oD&$ z#zYng-Rlbm?)B5 zic;@}qU&I+=tPb=cRYyKct5K%QGV&-zyF_ggMdQ%Q}KA)<$yJ*K)?G2c+Mk~m5^mh zKywVy=yOfUo*HmUyl$iEercAVCNLb(oJ?}^LtmIIfLwt}=DIZ_lU3J2gC`wHTr%G zB>4gKpQmc_(K0K~x;!TFuHnXAk`?ZOXAw^Z9@!ifKGKjt7`Ve;1dU##vg`~z9>fTC zI5#*%jJ}N{NA*yBO%3-Fsu2!nHtSw?8W`9uJ}Fv?*gdGc%&oD_4DHRuazh30S^d`cnJqtXFP;wM z>)}K*=VcmZF{Q}Hu?2wR~dtQB_fSdh|(M85u+d9d<&)p(ehhifpu zUR{bA%et-^jecERbcj{|C?SB1)Kwf*%%3RnEXCPDif1WOtS%Gcl}nxywEpGE{oF~? zC92hh(8hTcZLVW2v_T+#d+i-VRbR-C4h!$p=`<{wNJN=NuYIS~a3r`_ z)q!>-qFU-m9<^qjyVBI#R1N$8#FHBRT?S*StG`zsoUYfW2jlhruB78Gy*3%I)cf=K zW)FL^(FjczQ=75_tzh`tf$ph+cw%s}I&f_`*c#Zpu{arOG!{QM+87ue9cYYVZ+5jY zcHq%`8b!8ePa+LENECr9T-f692?h!IQb{2u#l%2N7Zrr4E*8)w{Rvr&wc?_#eSL{`WeEFfskNpVWM+G6sLWygLazGa z^S+)no65X!Y~5|wU0t26j#YeG<7GN=(6zC&>m7HGFF-iLKHJG_$YR2_r=i53rJ6@x z)s8)|)#^6LIy4WD3v$F4kC~}?fmg3Xex-EW3V0xO$m*D>M38$AURoY8tXkUOe7ubn z1O5wp@5o5tCx2wAdYv|}iTq^r@36;4X#vkj)Y*G=N$P}Wd!$LpocTMm+Rr(O{n;yqss3j%%RITUS}F8>+3@b zH4d4G?Ly;9wIk7Ji1bW239{ixd`$35*wYz}B*77oNgAUq1u?@I^1_0mjD@rti6*p) zl&;K6Tj#iQlu#*nD&w;_9ZI?m!>W|&>&+po+e{JaHIIkjSiFx5FN z&B$p5#lz*{%;3x|Kw}uvpj}qgFnDVwpxD)1D*qmgDUtR3A2~#SHGYs4}qfh0`(U=B~}InJixW4#pOr-!hz8?{`MmWea9s zG6j8Kt9l>{H{}){wEQPcmKyOjee1ry@=%l6GT-b)8%SN?WIxb6uvF-SiSU6?n;$DsV;5PtY5bT|seho@K#*F-LbJ*8(4A=p`~P z@G{Z9k3XYE3eT@n8$P;L_W96Mujk~h^3COY%CDEtmvsux%MtSiAv7O446o+M&4X;P zfA}{tlTS`&=dTYeWof3RWx2GJpM?EJ)C+bB?>ru zMBRAQ}U^EG27@}HC6s(L=UBlKW$lqV{pksuM+}mI8a#Ywe z6;{yF!XAn@@7}A*95mH)w@Gf}^RK@8)(bLd4f`b{P+{yjYsh0W zTJUNok7-}HCVz>Y$79+;m&}deHCPS`5|R;*HN3zE=CZggx089Ef4OXjso%Y1124&K zA(`hkuzKg}^({ftJ@7QziTsy0t74|@OAF2TGMACO9qR6?)@UcPYz<3Ydj$dC2P;U5 zdM3p#y5UxAHNL3oince_+b`$^nFnvPjDZ!22XDP*k#+*5ntO2JI(>F&oyrxyPD|TH zT_{XsCNZzRxu`|ZJJ}3EFmd{th8u$T^on480k$ZseCJRfSO54c7Qa$q`d@?)P zKS5{o3-BnB4t*BrNK#8aHg6|eOJmPx^;1kE;8{nW0R;_-Co$_5pmuG7_H=>IbICV+9B<+<=#X3jZt&TMD)ea`IC zj7BrkXqRk_ZCRGbi#98Y7saxj*h!qmjQBWOco^r#u1F`)pL&zL>@8YuV z?A_UivX*Q&(d`PQ<8t>TB<-%K-X)yqbn7lpXQ#)dyRG)XTvCfjZ70YMgcsMGHX#aF zq#3>wDRE4m8bUER#an!+mY-=x@!?*XG`H-J-|9Erp3SHQ?S|ye-rD+{^R1pzwYF>E zo>$ioSjFWJt2@Jkr56G)YbaWfdQ4-h zQfn6DQYdVB!%*q_Q!mhj?8Z5F^AUo z#@a2qBxuvS(YS{MA3NVqU=eb2$k>9X>|gCj_cu#&)3P22m_9V!4|@Jr-n=hAkn^~W zPLyjc#-s7hq}!7nD0tciBM~dw1-g7z=WlB+&015OR-dZb^BeZ`_E5dn-}-;3XV>lQ z>D@Dyx6jQ?fm|=>UH*vxUYlUPJMsy<2vCp65YG8`VRNRi21DE~tU=Ed&C+NlqAbeD zWNvRx$eoG|4^oQdu8xPir$IqKoPI2+6(941nha|oV+~k61RVlGO|+(OdVg4gR#c-I zJV3GJswD}?lue)^uT{&1quUMkDly|JEG3TM1(CtZXnN=K+<&0+(-&{U4(Fi6dIBzHcFG6;r+p8o9W|bNY z?%*I;pdr)D1;lm(El4e9fs_U7Oa|b=f|pn^z^4)frHcI5+1TCaIlJT=$mchwPb9YY z^j+&S?AcDMGGbAz-UlC~9<)1bpSWZBKOcGUhpMoB)4dy>*OR~Y75%eNaZJbkF?ywc z1v;)mRo7nl^l;!UU%31a^#Q!_MfLWW*oJnFb;Nq=sCuu0IHM~!ZnIWnZBd`agQ6hO z;&F#c4X0>%UnkXsQlMoZp5Ri6IyEtF;HKjMa1Npz1pX?B zgb^XK2@xy@-aNym-(ywd z{iuu=EYrcO^8e$;ZSR^b3H+8|LvdO6+nm9NVaFhiehuiQc{cu=1T2iIGV8TbRcW>di5WpR>3T9r9Lvr|nX ziRPt?jME1Ci12*Cv*8$`8WC4;6TnyFzq$NdQ&UUteecit$o`-IeE(AALaj#j~@I=lTV!N58^Q# zht9oKie>tipUr4lu$(55=-u$UcHQVfHA~ zgGvTP3Wa2v+P2UFII;a?p(bD$i4F$AO^}PMY;LE8XcJy7S6$JJH#*Rn2zG7l?VOBz z^@(yNg=DWcI#fvnYBMALa6S=sIt;%S?ssJR%Z0X%SVk|F+7>`e=yBL3#cy=w620v~ zr{j8SFzC>9r$e#@Qng&Xn)do5E~_Z)kuCmIvDoI^Bdf^FvpuI+5Am#|xHa{(m7;aw zq&0y$1S^{Brc;iLkxtB|)Nn|0s0}wYI5d4Bj%z{ zI|nw5g;PD1N-PoA0$p0Fr(CQIX6;wPJFboMi*5FDDJ5MiTSB=~F4T(furU%w@SDQB zP+yy>yVY^Pu%>x$*5f!75CP_)qh+2fA~;JSw%*66F`1HBog_gNmDi8=WWxE7y+7|O z7Si^%j{Vi%slHfyhc6q~zc#eV?+S;)dV50B?9%>VFkW4o?wF0(BSs-)t`}Ls&q8)` zT(0i5&vIa$C~!CP-n_>(AJX199CG4lJZnv^P7DZ18*K- z7P<%G2d=mKB2F67Es^$AL{r@;wF-v(`hKhK(i&rtLOfuz2O@@_#zfetUxL^57;c#o zvRZdM!`UzY!;{2W^@Ypl>uU+sTF0X@?r$4kggg%oj5$<9u55O7kirfV=M(&S8()gs z6Sj~oVUL$WlC`Jd7Bej#IUF{IXMmMOkpnvP-7vh7o`MO|?7-73ODHgch80^2`a8$s zSESN_Y(?Iq&@xFR*$+g*+8OB0_O)wMllgTsoq8!dT3-G?>(^^xyC)shtL>hAyWJac zY9aMY16#^oo9#oB{0YexuMEXI#(cr;?d_8QvaIyiqaLq<@L{ZrS)2QP=(7-{yU75L zRiX0Mr>I{OqkK=$E7q&lR>$3Tg#ZlPf9P^gA%QjYmbhb#bGcoD%WLR7uj`;P%_Pw9 z+CJt|lOQy9Nl6skDQUOOam*{lFP)o+Y>l9h-ae(R(5c2sF0;pYY%QF+%?w zUbB68Wc$cUY?N`8{vMN)zRREFe+HY>g$PIx?S8sdXBea_HV;}11UMcAbk0yX=pD0$ z6q&QtVUSJOgF%aT!YVj?6Bb3_pJt&0MDYmT5$mUq+0QfA<5+`~HmN*#fHm zCty2gao)?wHuZD2*BhO)A!8+dFzCr9`jdSrLm9BCT}rpC%Y(Vxz+eqX)q%eGl$?CJ zU%xfm-E9qx0;fJ7l~q;w%p?Ug={}~c3m#|L96&?{Wd^E|)}_MGI?v(cnjO?k8-((c z8Tk#jasdWce}CH4GH54XV686t1NqUZV$2uV6zCfi_^-wSMs9sj_wU4d=;5)zn&EQ> z(lNnw&>@}|9L~_k1T;bU5k)Y?je&aP<~c2_T?JixljgNpwgkuHx81Ry*JD|aui)M? z<1w@~v_?GojQ$&Xx*UeDHB?XdeW5Wi%E!a@7)SQlG12FWG=e=@Fv`74$ucudH4QUs=5rzA{8s7B6Bu(rxas zXgDGl$gzNLQNG!4={ zt7}yGhhkkD3e}l>KD;TOO#kIy{v|&+IqB*&jB?oko$cVZiZA57-WkqyKR!Em@JqA& zBiUjxn=2ME&*}U&hGd)*OhKWVA(hHhdY|&`OOxQuTyFd-iaAE zeN%@S6XX9D{`{NvU3;S&&Dk}FH?6hzpdh?6a_x;LBprpY1~nKkPz{?Q+K`{jXuUr*yCkZ_s~J(4i%;q%ot4sGdLP{uuT+K`19#3fZmB=JzFgV z*}z-G(`?uvoj2q8$i(7OOUC-Addm9^yU*wGs-cii8eQ+N1UlB011FHGP1}{2v)l>7 z?|Rm$Ew7Jfq(k5diTWl`L)+v}YuML`*zeN2mu zi_)TYw{}{40)!uhw0kVz_2qTN>zW8;GMrs$(SA2iHRkamOhsH!-Ix$lvtBb50i<09 z#}&Na?5bKTGUjhaul}zKw{+CpnRLQ_Pp~HwTbh{A+uI9!%UJ|Qt0m#sf$RIO4n{^d zZcL6G8GQBCgM7#$ivnoBMX-LG_Ve@n%NToaJsMRs`!s0bV=nDhkE#Y7Tm{^=vjMbv zBa_ACx@Ml8X+hI*>_jXVw<4WNHaHMKQp_UAf8K6n3@ths|C2viTC=9>mW^tmqv+&! zgLx5l`JUN7{nOb$_XK$KOQCy@<;0*H!iYY6?ipW?C_m%m2zz@IPO*AEXjS1KH&e3&o1s@58`#lD7X+=kg5AZ9e{w%lkTC z`)TL?^3{hU{gK!}@bK09+uUa|uy+ga>+Y)ui>%bCKr;}h2FO|Y!%ZV7DEvSa-_BQNhtHRN5 zcZ1*(4S~oyeF;s#FllmIf`jOp^b!<b<9C5le9vYG()JnYIBvW_3~@7B`oC2wk|7=F)D zf3;F{CE`<=qZ{gN=iH@oQ9roFRqE~yDe>}1?!Z3D=1}%IT>E+}IA=EqF8%@3QFu8t zt&t_a!|8KiOdmrD%D27+8AAdE0>yAeejIf=Q_KqgRkF7b*d-LF04T)=OB?M;2} zK7`-G=iXmBx&goOlYf9N@K*tojLHkxFr|9Ha_gye}zkc^S<0d z{kFb(ya4)oDHVzl{f40N?-RbqX&76STU*aXo`~{CqI?yOOw8W!aE%wFmnC5e;PzNJ z;%fLG5F54!Xun^7iE$e=X(1LC&S8mH*A}C_kM^ToGudPag;9p; z^Z>*J8tz!Q;eEi-kRK4ZKW`@JNj;gQ4VW4>H@GU{xw=UG?BT(8eW5kI*IO?{&&P@% zc=%0}3vA8bIF9~$%H4Q8@ND36Knz$KYK(hAcm+`Wn70vrKyEl5;KeHg0{;e#(-ql} zSIvI)g7de%Yv9IXsSvSigi;ui$*v*%zaJ=m?D@A2X=QCVCI@k@@eB%@&OAj|1M8ob zPNXJ6347yl&$FJFJ(p3)h7CzXBjNZ{Zx9I-vXM~G0Nvj%fj0~UxbHATlT+a@-ZIAJ zZ*|Pgmrn_s-Zad^J?qx>9K-qv+!4XS-v`-=I@ zw3c(I-gpwa;Ot8;g4v5C=cRKC_|1&PcTSh`_x;yNQDOhv=RTp29uOYmZvb9U180?MDr z@3|&_N_c6ouWyi;VOIYfm^`h#WVxRc1^P)weL?DuK?#3tVh3A5K@l$ODgKY3i_G)B zp;RskZi(~ z-r-abbpzkqIt?onB}COA{KcC#moYN1v+>69ZK-$L8x;>vxsgc^NgtrxP@NI3K}{%P z;pqLY#u@*4FtmI@Y%m&X+ndKp!z6B`cM?Qe;Ah`5Okz@b%P<*X${W`(&fQpVcp4yh zJ8kDD?R)JfL5-E1jO~pHu~33*aMTs7E=@^`VBk3;S#fIae=z=NT!=@)|Har}JWI$n z5F1jqm>^z^HQ=45V4kJ7PNK<1@|JnDNJo%&H?jZ3QN*zS#20SjrO@($>I-;QTVUes z&G&Y!y!XBAy(U8Z7wC&>;Qaz0LOp`Lnb?O7jJm`h!S>7`-!mAdxKoH8L3&hG-Ua?Rt7h^0CV{~l6ojgV^$Ln1DRRI zCi)G=1$q#*@^_3Alz-o+lgaXyzJ#X$O3bKLwket1V5b&xEKLCwb)OXO+FY$PdSc?W ze7-VJvIxsRL!$~z5Nkw8vR7Gc=W}=^qi$@dxkkfwRS~d88bgZFxg;C|^;b@FwR*&1 zWP^e6@VJ->%?E=D=hPdDn2fd39}MD65a^d)r(T`_y&~gb<~kCr#+}j{WDTyw|M|A} zevq;osou6II*F_+hP#VN>6_=2Z4+jK!|}(zM+ps9givm+fxrsh~a1M_J1AOiO( zDkktftD9h4sHhfbeJ|4f;(N@~++UzJ1W18_LJGl(&9$~Rm;DUI9iC?Y1`yTI%@*(t zyn_8EM!A`Kjq!c9ojQY+DI2!?D$!BuEa>u1M2}$S?~CXi@e@e&*lvvq5m0JmPMFlF zl-*|Cut4;@Z~^VVusmkgwwcn?5&y#45GD@zaEgs}2MYd`m?Hm5v^V{(q_Dz~5zzePD1<9^i2KY`BoSvVb zzWQzE#TS;(3x|L7qt&w^`6Pe(>zEH!0UF$xi9n7zB0wI%ksZa z+n4(-qN_Z+;VH-(q-8ZP0IS8kQUe%|GG2ftJsipAO3k3~Jbn^2gG~1jnnd&JC<okX^ACB_}jRN86V{!V!$m~bCu_t}wZkc2Tz33+7I3F5g669B%6ONeB2nJQUrzf0( z-cZeMF5r`3`+~l^K!}m2<%N_GW}Zyq0-&O-g*03&e<1ML&Vk+a%!xZPd&>OY&-AUS zuPZ8u72V;lZW}ms5KV{o9bCSqv({JqGS6x>&9NQBSaTRFZ|XqEjSaC3BylC{825yY zE?kjXNYtH9&jiBa)(Kg$u+~8E4=B1_qBg}8TI?s}DnvQedxAgo+WpI)JP3hU-iLn4 z0_Q?Jiei^;WGo&fgfSKY(FQ+78{W{Mg8o3J{G3D&D?Kdqr~@!FHU;h^8cHw7*A>-p zRKc+%IzAQCKQ$>sU_zhbxfToOr=qThL;QqOu}y%J^5MvYVm5N1L1SNETex_^+*!OL zq?UQhF!#K_M*4!@sFCa!0u9}H*xP`eOob_GIwo#C>~Sf`y@RGo^Ui|C?=9tNh;?$ z15z$01;k2c7B#ziF_uimin?NzIJR2791D|HBbnwlM#y|Yu9YbdsOuWLk{qN2mQ7~;k9LdI~t}Pl6>K)ebEs`Oz)5q z&9wWA>%zj}{JP=6#DD%OJ~*;Izv;u1@y6UjXK{A>SakU!UyP1zpDlJS%r)ZEAKu93 z8pQb|u9yR+o4pE2KqAXb+aelemREtup0(T} zaYYV`s!tev3LB14vbSYQnDIqCBUW%gWq6IWp2+^A@s()={{&HaOE8?kLoT z149S4RS%cj?dkSPB;TE|4{qAe-&#T}Lb1E#1EFZVx+YoN?A3Slq{sTw;ot$Q({6Kx z47~`&NAkh+AI^vi{ho9uErh+PtaNdVr-{39E%9!O1;!~* zgsu%h4d@vs;w+I&z$F1jKfbg}kX*5@M&E)hoN5oR|N7mR9ucfV?>=^DvKtXj(yc*! z=!@+00bXd12lpKG7wWt4J;Rp@cj5bPHa;3J-GegMgTz*|`rSHqR638e9WAE=%PB#b z0qTHCDmqsbnE~Z0)AndF!hZ2zhn|O)$8ezO51V5ly9)h4@mYwaH9s3RA->PE@6mb} z`79b6GTB%wc3*YT!H9^H z;UZFq_ugL?k2505) zmfNr0RTg&mh6}Hj#{V7RBb)=f8|6;cwTMCNfd+Cn zC<}SzNst5s;m8OE>1%xuf8jRpr~XrQc}l)pen_^+@sQOvqYKpa@*%iPG3Tkru@o^q ze5>82DxT1-f>rzoLSobtsM+D1UAGiNWl*UM-OFY5UWX`&W`bhYH@N@4un2#i0SIkx=V(!<9O;_@(!2rN!Z zW`n?v1su=9fF2_ZWmN(Fz}QjK3x?!+A-Vog5TJib*`kXa&Ko`z)`D4XV#+YJ7&C$7 zfdA1)H(`UlwLjKE*^r~4FD(T-d`K%NmiW)-t8q=V@a0R7ydYY9Jv%pk8RKc5Ijjv> zj*h?*Q{6H@DepxwlXL{moPc?Yf+ATbS|FjbH50Xi3wGfaNG`(&u~YzAPW+3@L*TWT z*+(W)Z_{FH z3(Nss`Zb*a!V>(F|2D?t0S|hAJsBCV+ZJsgi}Z?PkAexEOIRB5I3J|`NfSJlAErgq zT)TiIziBdhncqSNo0)Re!QtI^zc+?dNRKxJEc;0tqPmzA}~RHeN#PQ zMdN>U@#}nNUw;|Pk;Zslz<8WEorp=Wo^|yONJ8KgXL?;Ts9bVSM3SyL2&m7iVwcKO zJDwRb;{K&+#`#dfU`xb=sA6w~!|;y0O~?n0ooyXiLkoZ_yaZ12m)_v2w0tl)Va)aB zVeau;qm_C#z9zls*th3zWUrJ@m&^R<;^OloQ{8^F)!zTDgP@k;hr5Tnm%oAGv$bv6 z#Tt+rqo4DSlWkB>!7Sz?cH5X+HsmVQhy`p72n97%6`SjBh|DOaaS|Sdtugg(VeNFF z3uts!w!G#|&0o0hw%m^LQrEvNe@}_HLdB$a^T6{r+z6tU#ft~O&a1&}bg)9>F>~v$ z!d}Tj&J%XkG0qu=AsG39nDcuYQM+c>xTt86TYf!DbD8aWscaiUM|{7n8aL!ZKYy}D_;@~v}HysZ*0t_vD+tk`d?Ik2ga+jP(ob??&xdo~}bj$|Bu z*M5uJskKkvHPyItM+-zDTuyQvE|A^yAWOkY0Jlko~`_w5@MecA35wH^ObtKE33{W#yZcw%!ryzb^5%l}(A z{EMyE4Ts{JPb{vT>j?yVcB~!U(Gv*tfHMGd^a}&cpEj|NC^eYGx!HqF+;akYm73pC$P#IR71z_t; zJqdrtPGVR!W_=Yd_GoTim&@~X1dhsR;L5_XW>l6nVlq1xnN)%>=U2tWSZoOvRzEVT ztJ-{mL-4td-P`-+T6cbZS1i@PrFh%5+3_1UCI*wszY;*jlZxmOk1bb73!7|8cyK5d zADkN)*)@{*t&i@ze^-x7lI7(OXh~0Gu#)hn%R$iVlASPi`Ty|W;$MMpTzvqS)?Cy$$P7?(*5Dso1iL znz-sw;Kl{zR<%uS^SkE^Z4`IToS!IjQB>Zv?oDmLJYU6DVhaKYYm1dI$E`$z@fP`wwoL!Pt_nc%VaS6`JJoo1o&f;Q3dXszy zGEtc43;TrP9B_OgS~WeC3&dR#-<3J`;<3LI6{p|zp@Z2y`wx_sAA0Tn`}toaH;!+J z^D53klQS9TV1nsXC+7b{%%B90t#uw^K)#!M2w1O~c7J;)8x}JOr`08DQl?!>Xp+{R z$XGkd9!M?Mu9Xs6Li3f>EE)s(B$s5Rh9LAG+jHU<9i-pQPLd(`!7bt?BHmnp`-`@! zjQkNsF=0P2rKS#m7figny*0jM3kLnlAv;QayqS@}A-R}ZOt&eA)NmrL`_jNx9a3Or zsf)bs>+b0Z#%jI&$=>_d8ArCi_{z4MbIA?s*F;j_DUStvdb)gH!xq0T`QNO3LT;z?+`mrq?kSX?=!k@uE{V6_OV*Y8%I|V5iZ+fSw-^Snm zGsYG|4#FW$TU^t3Hw(*XV5q^Ea7Ju1Tou^B=>Ywa54J`i98?1mC;D9I{_c`Q8gI+V z3Yn(Rr3IkQC_cncT{LWrxfx5LVAq#2o5PQIIw}=kc(AYR{IEUW(dj*YoKF?^w+9D? z`U0VKXQ^ta>tk(Lb_rBAuGpxW>Qs_FHdV0}t<~ z%TEm*U%IUe(?hKl$A1BHBp(H~__RylA4NP@5zY3~WC>aA!kkT2CDj7|foYNprn!Td z{4KA;O#)^c8jnm!=!GvVy>AKsfANd_#iyUfIzkRv4JEtdXV@OL&VtOXuLqxnGM|2e zKJ{?{6nngYzPZ+E7Gj_yfy01LtbcQjVvO-@SxGfZb!N zpX48Y(FJ5DBo0>!z9(Db@7OrT**Nl;`wN)649p3zUo;R4^{luXac$g8!0kxpC4+hj zd?-S-3pj$X+wlvC&li6C_;2x_Vjp*uaVxNTPV^?1IMj3EerNSuuw^7f0t(!1^-3Y` zFw#{-E6$|PgBo^*&=sSsQ`vnH_i5~gfeWrKQa;%#&al2hG0-GFj;1$l^5%jRb8L>Q zQEqcYl{UL27pe=$Z$fzit1v)sJX#i1eBg;%uk*0sQ0fFE3<1IbB`;vuW~oI#%HGWS z3i+>#xol}M+tHC-tZXRxyu}S&i}`icXr#KXz`x5nxn|8)iEnHipAatn;NzCUn%Qc3 z``R}71^=to6@s_wLu3T=muso}0FyGRDjqETXxW)oLe! z;%swPR6aqdz?X1_?JPY0bC=G+FQI$1Uwp(HasnFv!gBF08aR%#N%Mk=L zSims?8pWgh-TXuR8Q#KU!lDWWOsj24riu~bMDZW4shmlSXNnqp;5*6C9C0|&9k6f5`z(+eI*R)$-s zt46RItOv#5UCd(iQ37Q#a5NwUK0*Dca$MpQjO#Rr=zu#Lki2Rg`f5HBad_0!yo2?q zV2*cFchUH9Mp+ZR6}zMv;uuDqM8QlSn)ABXmvDzGxj?i$oXoCGExx|E_`#^5dC)Fg zOGWsK#o{fjEmhZK9h$!7tburM)@x@p(QjkTpc@uVl<0Qwe8B|QK47OM^()Y&a|JO2$DCl6iuAN=#E z6G{WQQr3M?*aoPF(e=X{MaPdSK>G8Ex_1g?&!TtE9)^UvouTr*JJQ4Pn}XTsg3g!ETmb=gb$%aX4xoPfH|mkB#t+A~#Ga3R7ogV|FT`f* z+9Dv>B0HIyH!z`foI#@)>gWN4G1{NzXGE{yn>h~)x8#?C^KLl>Vln#VzzNI*nal3Ov#l}W?cpqQW zd@e)s(~N;~C%)1=Sv-M%1vXb2XxD7o zkKVc{D2vTrPiCq(EgwN&>WqIbop$)7@VrAaJ+qboq4*k>LMy6(@@o|2_MsYtffCIS zgBed?db#$$W1YT}k->0B>NlS44G2n|ErwdMg}Xt7zdypBsG+I+keOXro{1ehydonOX%fg3`hQ z9XTYVAhfuxpHnj4=SzYncuAJ3N zXBQZL3pvGB{RHZlDb|1)ui$zZB$`TjOXJz7uhurPRr{;2Y15mVmAs7`HW;jU*X}$Z zYu&|#au=)H&9C1@c3&UHjQUmBWmhpf(BwG%48GsG>U+omPjMuPdoN_hL~VhEHPFU5 zRl%gGvF=_?UQCmBp8kz(OwSUo2lfw_fX9xNX|EHz#a@`Mr;_Bb3OVjUH~O1Ch&6gJ z9_$bSdC^>R2{j1LsP+>YQ@B@R;FRzK^EDy3DA&rhim0Ib{M3iqw)TSL#7zI98_@Rxr@4BgNkEx--_U6bbpemMCBtNd_FTb1#=WSVDd z6t*4Nvl>`5BkFY3MhFry2?A7U+Dhn_B+QDYUxo|YibSBKDs$i~B#V-iNYgjMiMj;; z2>RnqsGED1?mmvV6SJY0i?qi{#9aQD@DvbjBhc;n^0?PPx7o$a(TpXtHac!q`o}3k zv8H?8FdRdTHaRfwXtK(f<^c*?&ysFul?+t6+u||nhLQ&X!OCsaB5dmva$qzopt_jV zL?yLEZz-PjwU2g0+OjFHmYK<81ywCtP7RMI2dBHb(aVA#0{x;l2B){TSgd^~Ffi2b z4-U4+YdJsciQUNND{hB97)=KXhbH=Wu1zI}uUZ!=B1-1SwzYZ2Hmt{7&AQ)@pbo-7 zgsJO6)F?a)6Jxd-uLE!Db2;48s;s2y$WLLmc2P!z)ji>!Qyun?gyzkj(5T)ov4VOQ zc*J*S&O&PGn6@%0q_1&3Ltno+qjKjBndy!V8&vqr2MtH;DxRC3~d*ijzL`8YuVB~o=EIsmwug#ZT*PYlmGkBou8?lr# z7<1`K)#^og&AazJ?|)^_mR0uLP0QbZgRO@JZej}{*GaHm?kA4NGfxqt8#6|GD5{c+ zj@JPJz8g#!eN}z@G(@iVbohy|a2lP^1z)(_)>aPtETYk{p#sn3X>AewEU<(Y^9m?e zj0kqKf{@L~OBhkpRzkIXrzpZof(=493f(dZG1_8VdpVXx?=#S0pc8z^>2mV609~H} zO;Eiy_GcQx*jg}S789Z~4F9fZ=V;EUIb04kzrGq>o(i@Pq+~07Z_f-DSq;3{ihn@v zGMN8n6D8S3yugK7gR66ki0xXqzCd|a?X6~g$)qn^wOEVuE-k#$;m!;bVGkM9)10Si z-d?GEv8I8#fh*LU9>VrGj5JAe`usl_L(|=Knpz!VmS1r@#m>&QitLOiu4F87o1)vS z<&Jz+0UII;j3TcM>|USEuHQY->=iSv^sVdbl+irRk+xWCBi$tluW@Zcv0^y=6aRpvii zo4e+Yxs8AJr@z}(J^8-(_Viz~W2!V$*OQw-=$bOejaWNqo5`j@9im{so>OE8N;pId ze#w!vjJ5zWqF;2H7?A^O@xex^GfoXMX{q+i93*2bz#wVq`H!U6#jh_+=k7t?EU2OZ zfzu}YjB?6X0$jzTxP$!c-p{Sy`STCwubQ7pr+d3==-ZR@$l5+hbYobZm*@G{#6jqQ zB6si^l;fSL4^uJ6ld9Ii*?7gK*wE@Np9ociQDG8Z{F6ksjGKxtg*eg z?avO6Yz}3$@Zhx_H^%ykF>w!;E0~gZi_v1=3TSFsvu%2KO~qIfXW%K}5A;+u5lZ8D zg%XvNPWu25z~!5OoB1`1NQNo!#iaNkL@74}H!Krk)s5o5(Z+^Z}E|Jz&NU+xTmP1cOW3jsFSOe~7Y zR)O=Oxtezo;lDE6KICYp4ICh*3q&sG$5k||qIHR^WGBH-*#J!%P1QaD{IMucy7#(| zxJCCdTuk6hFf;qm?F;N;LRf)RJ>b#+bKqj8+K#uon*vwT{ZNH0-@m@IxA*v_P0737 zz5FwHiInvBr7N-Lu0IGc#n<)^4ej5s&-$0V;?G87g@9_#gW?PS4EZc@chpB>)0{?L zuc)Q%M@tpJsRI4I*LjK@nYH#XDN=!9a$k%0eO-Pb6 zsMR654W}9U!DeAn?hD;#7j7vLY8K!aYKqs41Myc}qvjoEUcswxGF(;LAMlj|xv}2l zb@M~l)iBZNRF0fVPfAmJ_$Oz(R$XE<_Cd)3w}w5-a=YvOvZNTc zWIUnd^67C-Toms{ax(8Q8w-uObCE_efkJE9Neyl|r$Vjb&2;+$2_6lcvEMkZ^GOe+~LD8CFV!V{V%ITP~&^HpF~5GNG^s+fYwE<~9M$eI;*E2Rt> zwIG}pNe;?l(@DkkL=)f#o$g>YvXnkh{f*l)ncA$kujVu~t>7)rv^gZvX8){kljb~i z%Z5Y7e3@^IPK!JYCaqB!PvDqju@B!B{t@;>_0O$;4$O`y6Q=pvH^niab%(ee)_cd z1OoG-s7Rls^fO#P3cq6w5X@siQI;8?90*d-|8}dHhq$>p-d6$M(Yf{Yv}_d}cDoZG z&uN~sh`Ps7$6F@c3U8l4kR0402o9Uv4GS3hbD)l)liZDnFv~Nu&W0;A#|$vOb0q zJdLn()|#5;CUNF7bttjZXXy(K{&V<{ldDU&(eA(WVBjQB0(n-k}yK(dT9ub7=_{n`} z6rhX3^2_F!N70+%@3AIn*eD%Fs2X}DB!=c~*)$IoOm$XuXdpckowr!f*qG-hQfgB2 z&!g!R_8RFY2s_T}a{&3UZiy@d^@ifAD_Lc_|AD#GQ~bwX%4NH@^~HkSll}ID6YU<9 z-p;-?=xedW@8plpOUB4-tu{N7;)Q)Yzj0uFT@=U>#2VW$Uc&ZOxMTHt=o5i1pTDbv zOIf9`t|Tn7BhN{)!y!vt-db^@wRSZR#G_T|&{K&-O78&r-H}v4as{9tG#I%9R~R6f zH3ObJ)9PxX0Lb=&pdoDzMFfKe$AvPEFmZ@j0MV%b773pm@P+5y|G$v%#oN~}|NAH3 z5ekp_JK+-(|3Ha5SRZyvj&dRrwCR3pCL0MB1HO{qYW0_VfnqQMGR|_e!xv20xOT~3 zQZs5q@=Nv!U2?vkz#DW}&DmrBT4`67du;+DP+>;ty;ZX%D907}1N_;yz#qZ``AAx? z%m-WW2j5`9pN_p5{4j8EB(t^f+Wjr?!`gdBQUkRW=mX{%WSlT}A!_*{FnrVj_~{|r zxn|&1jbK4F`nKDEn^*5R@HhyQHxx1l7B}3z;q(S^L!&pe8HD7UdyGo8B2*3y5F7b* zg?hcVxo|F3)78iB-` zT3$BKdkyPKn38c=S^dT7;kC)>brY&voT%kpKu2yG2c0Yk!5e+q#|mo;YyExlX;>ch z*i>v0K6b+odPzW%8J#=3wOLaZ$}=#<|1~Vxg>T}loTXa(cU&vxmGu&jJM`%l|N3p# z%KhfGlH0c=-WGcjT7^*w6$evqUMb*1+>W<`Q4X#~tfafsUW>U-EgW|Y*y#cndor8= zdzTy71!}tBSFO`>JnD2=tbSy~Z2)eCuj6oa;6&jhv9J@=;Q}2b>iJ0SX$ofriE`7G zfI;2V9{g4{SMCZfErCzYP#SXSSE$DVN&%qcXqd=jVxY_-!1*SC3JnwopC46?T+V&`cx>4BQBM)=!;|ad1IJou zlrI(!7K42QJ%Pkk<=5^v*D!{G{tI-q!TlBjN30~r#h!#8eTv#5P{|s5K`jv33sxP* zS|%uTz-4+E0nQ(_rqWg_>J~gMmu(WYTP|nPSpnJellGJ+ivELsi>$cZ4vT6MOpaaz zP@85+lSE9thBU$gV;W=GS~|!rml^;W>(lX^7|$ z7dU%CoiNx7f)244EG*oE0%u#&>U1IO!&_aF1jfark+?S&_1^0bM5n_^uRoTEs6mOd zdVn#)TNsXQ6~>5WOtU@DI3>w;hB_x9#Q)7nvo6NCyKs>;HTeos<<|})9+KZ1nJk7& zxrF_=b0ohpxwMqr$S1v(YSmvm+7YU6nlMIgE8l(xU_f8IiRK!`<7cStNOM;|!%2W- zLI$mvSiOiB_MoO)GFc=_K)q;;j_9$Xr_haiqLa`Pxbcg!tycZUk;gzNpze5E%Q8SE))@3SQUhh74E=SMbO z^_%Iz;dRAKW6S1rV*C8=VrENYV`BNA_+MOwu~Tj9kN9PbeZJnCHdF}YY4r)zb88fZEA`DID}fDqtvn&yU#(=V7NWU5)~Nwn+J}g z#oVzkZP*Yf<&x@0ogKA-NO*X#V*il6&{6gtFPD$=7uVh8@9M64fiLhC0sC7K8A zk#%PMAB`P#C-5`DyD7U7-UL)2;upq3Q^*Z-Vdy1M3V<_P5<*S$k`0tBXtHi05?}^~ zNy9kL-&ED-`F3VNe;}}-9`5eQXb&jSRMx#j^_Q3H_l*pGXlG*T>OIAlf--9^%(WzJ zSREyGR!xk%6A)xciYEfG>2Ne2&^R#|o`^w!SDJ1&eWn-9;lP$;JO0*A+gPygI1{mu z{82}~)aeWMRNI{&Qj?jSYiZjz&|$k9Sy85ZeCxJsX#wPbLBbxl^tcOo^q|X;bO?@V z7q3lI8B84j6+t!=2-KI=ifEK72y?O|h>AAXROmpnvtY?3O4^yD8NN~sf~qUoi6&diVKwYkyI@BF99%$` zR8dE9UdEbC8kj~1>u7^{jS42kuEBf5FAM68$kqnK6Va@rnu#sw!t1wS*e~9KFBrE8 zw7%sQL@(Itnkt$9{?4U?OG^jg#h}Eexwdfvp?`9LxaSJvVz8*%gKu+tG<>SAD3hUj857ONlH4n)PUiSgK?-?(a&w*d0vNj* zQ+i=-Cxxp)RiQ`080U?+Wo6&`Md9%GdEvf?*ImE4jpz69p3mZk4sLF^hy;)R>;?45&mi0KgAxY(D}gy;CXmfwd7K+-&y_wYYq^}=J^ z?>&Pa3rvO~53kgBLxwALJUZ!7rbh=oO6;+>$QQ?b!Ex)UTFs~qV`GQK;ZrVG62RoT z-96zN=MEUrjlRAT5KVo3VqGm+qn(YM7;J>1s3&@nGS*E1s}941`uVbrBrn;0@mp{u z&NU^SRSF{nzQW(Z_$gp(5nFkS|2eV3>Jh|Sk>6(f?iB8ird8@$nD5V`1>i`#XRzJ9 z;h@no*%vi7T(>b&NXGSKsvPVb&AWeJv<3{H&0+&1KTz0w-M`$KA^1WkcS%S zXss4ai=s|$o$jNjui?-thz%mNMr&H?E}6?p;iZ>Ai;1Ef7I^?hq~)3c4QyStbWQ4P zCyM3Xy2gd(YEnYt+|*L0w!Icftl2%189{@_T%^#Obo7bw>PRxuoe#QGU8%ru{)-k% z$nYvff9w<{A(!eimCmcj+O67kvKVUXjvfRGf!d+D)3t20zna$^y7iCrn8V_YCS27v z%BM%+dzp2;f7ry|Ue(0kewCd;!qcG67je9sZAD*pzG+nA0NAQ+sC0Zm-kUUDC4Dp&dTF1B7CpLmBA?| zg2{~+#w10x^U8#(${-tpW`se*Y?&9&ApmvGeU7RhNEbsX;-4mz@72fln>gQJ0Delh zEX~aUef-a?4t9ji#fiE65TE5k#Z_FiOv7IC`?vt26R6RKY2rdzsH&<~j|Cc#SthVm zQGvl+5$HoOTjGOZsp5mNt<6*t|HJ$>m8H)4+PEN-_ajkwBRyypkkJoBY%UVTqt z=lqmmOwC_SCKBe`920ybCZ(@Xxe(df)JBU6jh_sfQcK_C#(M=FnQ+yONim=Pxa(P$ z;L(xEgO1ic)@Up=7L0}jj-hz=I*&L7^w@AZb1dfZWEx^oTP%&sT09=rPI_|fozZu_=lJp4d!}-yf&=_iaD4le(Y>&HcV*_W z$7Zg1YX8I|m|JUoBVacU+UqbLto5Y9ZMD|pL~@b9OOY->)=CyU{2&e1Y?8%qk^D9d z(}|36G544&>W@W0VPcbHBvMY${u9O(b0N10Dr@yD-rz{k*1TZ`u*+eg^FK7U6}H{9 zbYvz!k$l4@-Sk&;H2$l;cH^pT;yDd+LiN&NAYt3>PD!>zT%6k@iUHtf#7O8#JrH$7 zLLRpu+C46dguq?Xzr*sffF0sAX7Sca)ea0ahztfu)c|5G*k2P{-u8^AHy-Ko-lt|u z)xab7?YMU7chYOa9mi_N*AAboMYmoJTtN1@=ayd{xU-je+9XFloSVOfEQjH17h#Oa zV0F>Gq9urCG$1tf1f$M~u38*kw*~#~WLUkSU=uNHiZ)$@6itI%Q@n&E12IMjc#52` z=0FQH(5AP|9|}ck!ALQ10&tCz@3-&Swdce~!rg)DVr|N3+ft3K8C@HD^&=nozR}3O z#$;W;d=399axpH%aW!pBalzghlXX@~69+hk6UR);&E=LS#0k5idcew!AAsaCi|lm@ zeup#6*)JkaMvE!Mg<)4iU$8KJ}mH+j!b@@ksC|GW$HS%DM zs1E>rekbG+b?!)f;pw~$$(Zms}R>7Hz)c_6_6}9K< zqtG^7)Tt<$}%64oD#3bqQ}V0 z!W}@zv{k;0u~U@;2ERaBW}$>46ykIM8Um|G$fC6Z0sOI&{9IY~2RxSISZ8>tm=s-r z9$+57%cJj(URYQCosXsCxEc7rV{mn>FZuYyeG%n0)!ReNf}N8c#PV| zx}r-7W6Tk?FD*I4j>Q{x9rLM}W1xcyoC&+V6yfVo$2X)qEsa{C0uET@SQ;X+t-%nKocV*;EKvWvP;(p4&w zZRzs`_t{GnRWWNx7#a_ztT_ijyJ!wH1z=0e@(C%!$2ZPiy;R+(CgtPD<&@IcVrlI9 zosU)QTeb_r-=Tbh$H-~yls`R>bqx|n3+jFShQI2s`z`*k;uvF6OXWsd$l7qbS-8YT z*(tW^Y(UL?FTuwswZfuUCbY#*yZjbfhNp8~am^ya@IMTp_4n)?`|=9TkKz8fEf^Pw zCxC&Y`t>$gc*mas1N5kSGy{s_a<972o(EIRkef^O}G1dw$`G;#CnT$ha5_%bDL}Ha$sA!HXAeI zy!YB&elX;_9k%l1O{3~`zbomqdji3NaN_-av)6U{^6tf}x9)1Nb@&g~^E3xE;NA89 zb_J)DQ9bKb+_$Ctmi+Vi@8&J}*)IW;ush6K!rAZ`(7&A>ky*EBL1&dL7^P@M;$X0I zoRZ2Nw^9*IJ1?})y8vVKYU$)WQmeEUUn49#oo6ftx;b7zu?Y-3#E~fAfVH6JMy&-{ zSpk+#&ae{tJ^~k-d1XI8z2~5`xnH#I5d~Mkb@jmX4xay>jwUg|l2Z?K$>~rqtKD?i zxp`EJx|~|T=1EF>u35Un9#RwSVa=s1YA!xg>m8_?@^F&LLy7AK(t90vA;@dO5{!0C zcI@pCJ7(MD9?s~lb_?CJJ|iBiIc8inqk9fOd6$`ina_w34J9R#IN#iRvNLJE=IMg& zz3|dm#A#{&7r%DbIhs|5k@x6>q=C(c9Qv z`)_36B$EL;3&-l4EA6B0Li_CA@R9JzFqm!laE4eiGF_2bu`g&D4jjm?wf z&qX5MyiCh<1Pj&N^)?E^pQSCQ90~(}Q&|yPgoW3^CH7p2;Huboa%o!ge#c$M`j{YK zKd%n2v%cfT>pB0vYiR3v&%wF3?mZfdnR~A|#CP$(W9~k~i$hO6%WV4&rY{)x7~{+P zYy8b>zC5lroC7SF>s;Y^Vs+cB=Jv;U@2Z;HuE7j-f9z;teJOYTbLhexx1(N7jr$6^ zX1C`HqB15?d&7JbQHjJN%AguSrv^?t1m}QyRKTKPa>bj*H+uL{HV>8ztO$n0pu7eY ziq}j%v#Z8TYBX8zuB6gmM6!Hose6CnH=X6db?M!QkKN&jIjuHbS-%0fbli@@vT*ok zLra7Hk?}2A?fBBk2PmVyX}&U=b7OMI$sqrayC}!a)obBd&c0|D>;;=>vE&OWZko&T zSq>LeKBwB|xw%9_OiP3TSOkyryvxZ9p{78PK|)OkugrmvB&dyQW@O$n_-1Oo_NDyx z=ttefYIkUQ*Wn}fu+xGN@bHL_c*^a#j`+^P?!2$FTJdW)9Xj%E8vnq?90%Ie zn1cd*9oge?*yEkm0FM$~t$EE;DWMUd5sLv(bGgA*8@Hi@vg=|0giRnyJTj+P>E$;s zBIoiFuKaVg$~lN}KMZlk)U^siXHs@$LvBfT@|n!gNCU9Be4ileiJmQ2n7ghZaThb;n%b z?G^%V14}t}v{?`k#wG8SLBQmnppp?ZYZ7z?;2sMSt#nC3Logzy=cx2-;XL?&h>Hm{ z0!=Iksmb1zh&2E8U2_hz*d>$r#M06yK#uguW`Rq=;4Nl=n%N)2@V%(k8OYX~j_Ju1`w5n;e>e>YGCgO|R+(m~dVM{G&NEQ&dsCN4DJ=(pgP#oe7Pk z&O>G>7p2fEWjL7xD~i@v#`ULWc{JJbru_N1>+9`4W?!I;2o?u?3OwOc;HhewR{#l{ zw~A(u4$l~?Hl)b2TlQn|1n)#0^l?rF?5VQE($!~2U&I=+jb{VBbPn*Lb7r)hhf%x& zb)?`k1@^(H)s#pI?IR0&1+cjig{Ct<+>}Ev#+&z$9nUbnD!oEQ9-y-}73IEa6;K*C z3JftWT3Z^d1EB+-S9PiS9J+;BEjEc$*u4OdW;5x4>kxZ>{^G*sn?90h!*8jVac_aoBMKShP-;i0A0ZUi#>{gbi+J>gC2EQK zLy8}?uBOS!at*knP`3smGK}e4@H7^3Z}yW+LmoTMZ*7r*wan11w;sHq$pyw-C6gZP zF&;%FSV!`e2;vjrrk+7?!|brdmMTZ>v)pyvH{o{ZwrR~Cu_2S@=U$j!=y#LtMZ>@5^|Fxb~b zD54xktmqm7?8gjHi*Joq5kNW;dJwDVq}adnByu=8RYlu0`-GN@MYEA`&T7r(K$oA1 zW`tkDT+GIwgkR^MNcghWSXhiioz7@Pj4L6<`>?tKO=1xxN@3&dzwSQ2aLZSSt%R8S zfJz#4pD%qS1bD&1izQOBWH6gim>SF3ugJ8R5p@cM{DJK8`!##e?@_L^dn`?)vUkJI z5tAE1IP71)b$co|xw-B?_3tNE5X%3!{3~8sPHz3gAAW2d?Ntae{~Goxjn0HXYD=}Yg<@T*J_W1R7TbytT-$=SY8S0k z1-mH4*0#3RYM)x$rNNN$u+gd*TX?Ekzor7%eAi1cWE+a|n%oG`kYdOWbqmNsr;$BOi zPb4E@4VWS$ack4uoQyv1sU;Z+I#wljk-u%S_)PJ)jU{oU5}D#`K(ESJp3o%OP328z zI%VF{N4GrFX{+x*=E5_lS0OOss!JSF*1KEQBZM<=Z_2ZRPbSxj&ynn>{J+D8O19zK z-0O?LpS$wq-Xvkwc~YvEJbNm3BXgXgI)nabclF#g9mVmd?ZKi* zZMFXHe8gJAN-1KmY4TV%I^Fs6F4*iZ&i2hIqxP0{5$GeT3-!_DJ7}M*hXg_az87=N zn49JA6RxIS?kY#^(dbB%Ja;RGsQ<4uS4|hKCaE~Rf2eu7L+UwTHt?Bc+lF)TYF6m!ZaY?%C?}` zsweP#k9@8{F3(W>c*BqPXHe#wh>95Zru*?$XAnOP*taBZf+a`>$m9V;;81x|y?&ft zFXk`SY;fS616x;e2b63(l{eK(<$Zm!?T`YesHdd>4td6l+74^x^s!pllo{z0!Kz*! zjHcp{eqpHXwB@q=1`dqwLRbg&2{%%>lPOZqkpD-tw7v=gEYK8vp zoE&UU+7JdWaYjsO7?P*MK6Eq;z6RxyFvOXiIti9t9CWa!xII{$om~{P^Cy`jSe$a~ zE30~5aq;}>NW3png}ZrGI7*s&&MOP$TM#P`hz;qPq)<7 zwXjHYO-*xZe~Bxm_m?hMaf@c^(|Jv=;Du-GFL7mRf5{Z+FWrq4?nDaUpx6g*$nkVa z;h6k~)X}plRv_(r9F9n6tm%Tb&OJhx)!^L<}=Wrz~jTduKu{?)Mr6B&K@}%*i@+7*v zNpTL2pvfqORt;W5PV$rEMdeMje4#2gc)u*SyJRLZ=NihbeW=`R2^?$ybDV*rtf)ld zC`F1yYf9cgIDWw=5;)iZrbUTkMoF2(QH~S|riprxuJ~Em{=blIlTr_sRh5ZgB(~yS zW(%j*qY{u0OMdoGRgc8DcSI^PF^!`RFjh{aAiI#OperMJVsWh28q0(AqG4%tXpMO< zLSw-all%@chiRF%gEn?G(}?$UssbqdFcm0D#H@a@M*h{+~I$E^bg7% z{-1WzxrXzBlg>5Ru&*0|1Y@$-BGhItkO4sZYt(#8kz5R^z%XyqKCS#Wp2*WVP zCuzNU^kO#n$3gNZG#Gy$Z6*D~%CeFpAdW9`7QFEdv=_f|ERXnw= zkfL;!H?vRo)%6NrqCarLlWfM`f}Yuio!SVrCO?X`c(U@dc!vCL%VOKJc4h5_Qu!J! z(`$IgF-0=Vw5T`ATkE21OLRwccT_}aMfEZG6Nz5qw)Ww))fR`)9A3w62Ss}{IqbFY zMZ|Yo*@$(!br+1jcJ0EpI@=YKXOwp1P-AJ)j@ry~Ff`)plfV|{&NW8Dt8vGIDH4nG@+--$)%V{FmsTi(5x z^)2b`U9zOFZ%JKANnL#j77}PWd|qSku~u+e?_o%-oZStrBJbid&?$4xm}E-GlQwq}GH6LuvW3p@Ib(DPNk|T+_^wqJ^2o*{fRnH?aDRk-6DF zi~o?dR+O9*Ep!xA&n_9gr0DEmOU_~Tkjq&f4Y<~Lvo1c*WYW(M6#C8=wyKiMj5QXY z+qQO<>-)@{2)x#BkJJ4a=hcHU z++%$ZTVYNdN;LPG*1}BBX<{oi$4Wc5L8S_lJ#00#oj$47J#u>n^!_xw%;9e<{?rCB z^d<9nK>#Kv*Pz7g$YA__cK+Z(8K;BBH=Pg6!q^^*b=(VJMib5QCZ>Jbomv-g+I8} z7PXZ%*43SN-g)b~FOJh$!E^gBUbSc)dyw&c)s+>6ay+f&2qTKKxjqf?)LbUNW^?W{ z??d@ys6j-sOFJ<8&kvoBJ;O0r@K8*XbiN6P=`fk$d0Jc*JmW3RFOZL)k-sP5*`4y4 z>nBIR0X`!2gBviRH!)Weq>H zYga{GtgW6tpKx)QP9=FbG%511lQI#()>2W6 zANmD)??5gW}9%0p=z9Ig?L7+i7(&I)NcgA4rAX~h{-P`&wNo;d1llDB&nHlxZ0+ipHyp!J`H&S~ z88I9@#uoDqiq}g$PIkyRdm*3Y8H^IV$gt&D1G#R^g!3es-2qd`jrzMyx+Q>f_7v$t z>iiqX@@ZZz3|q*!7h~~dIxa^l9;IIe|Ifho9jaCU^%UA1HyDp^X2Q>{pM4|#kBk|W zwl{=sFDIrHbrIvTtWV+02-&;~Bl zF==~-XZjuSCQ!Urb%FgV{wSx=w}QstT)_|i(OncQuXkph`x218)WSg*M&+E-Rr zt?Z~Mp0Vte!e+?R(P(A1qrUX#=gcT!7oT-WM}B_CC1`Qwzmbb#MVH*QP{fG-xTOM2?Z7F?S^UsW(C{#0dYv;<~q0efy)*lrI6L&3b+t7cul!|9Iyx;jVP(Ag36R`?GK9xTH! zC0~RWKo&WS`LR)3{}{|OkH#oeNPamhFK=qDj$s5=uh0rtXxM;h&UP=W^Txb=@N>{q zy0T1&vfR2=LFRRP{JE=?zbwp+aKa%^aU|X7CV|Qs z0f}%PPu(G8F#A@~jLw##*6xzLs?gQ>&5J4u7c}ObE-Vk1M4SyxA%{OZ!|EvwzzI~wGR>5UQ?PcdB_JB0 z*4RYH(h2P_uNLfwT&AeM5I7L&k!cGRawqPdv{f~?WPGBqA+u<1#`eMua}m_+zEu-n z+taf4%RN00tl0V1P+bou(S%Q^!|*sVTkAVC$IR+z!7&3xk+#j1E9xKx#tPOJ@PfIK z71rhz+MGI5o^Z`tRci5Nu5#^_qOx(=1s#IE!PdW&2ia=!@|N@wm14D=$3uyurf2pL z6_^pLZ0;`13b*}F_=jpL3kE$GIs^Z`dnoXT7-WNIVCP+@T_1DIh=MfX1xh=cycA7j zVBLUFzo#Z5*Z`4MhAptBJz96H?o^$q%W80zSXY#1tSGFPwz73@=3eP2agF1p$|d8M)z8oeRH|rK`Y%E=9mg!9j!{W#AVv;kBm-%Lm|@(}x*<7OQ<{<8 z6O!*?Nl#!t;SAUvrbXb=Jobar2tVCgrr&IHQ@2Q8@i04}!Gkj= z%38v(uEH8tX~}&>Z3X?Uvlb(`MIL;>B?91)5VHvRt5)b)Kdl~%9 z0S}uDvL*EzE*3xhOtQF=w-^%Q45n5&2>onYlC1ptI0~Q+k)cD*9J!C?`_wxAQ z;I?gpgX6yl7X_W{yRg|S3fI-}@A4|P^3a119y<7~Z^h5eXmj9$5!un!8zfNPo6o(aQxdxlpQ2rF7z-Ghk`;guMaMGFW_0<=hFFO_!W zz!S9hy3_f^zM8yDzbmJCN&Pnmy2cAlQ_ zmlQ>vU-Z}1*Jnm%&#HABCkU^>nYh}9+JHP07w+ipPMnE5Cd-$B^1X(BDh6$2Wi5-8 zX6BnjNonyi&0Ui3D>i3=p{{~k9%GB2b|0l3xTK9n6vGHdqr6WUswU(}|GdpJ$Ig6ZrZI(M2S%oEPLXDv;v!(kP+HEB^ zT?wmg>2=hk{Dmt^Ecp%plXO%^@gay`36=!5O^(E2$U58YUC?sD@{Wd@lHm<4eVLKm z*}3@@VVggdY6p$_CbhCv#rbDw{)hXBr}r90DpxC?+Wqho&@GZjK2gxxRyxl~?7vdVT-q^^v;n z&o~N#m31XEqBS`A~oVLzoFM!EW(*^A%E?2+RzOZA? zT#qxWpfVRNU52g+=E?S?_9ovOnUI?29fZXnar-E^so0UZJCkQt6s_3d+U>&Dp0+Z> zp0~0#>obgOCl1K&{znC)l4QjlJ1BToBwO$Mc3q4 zR_1+twQJ)R=J;TKOUwKZ;(yz+5oj>i$T$PQV+E#SoR3*Xaa_4OhEZ>>-GmS<8h8Lnw1rBs%qaBHNC`@R=cdN{7mr$sLsDYo%7+Jy^WTv zFJP}hH!r8)iQG~^9@~$Gj)nBl@?cbpx%=Fw-0!+|_wwA`=!Iy=o~Px)-L}UK*E!Po zy$wE=WG6JpN?|cd)x?}gbV|!lHzy4y>O>Dh>9HA-aV7odK*tm(v>b zkEhx%njaN++##a#FKR#aM_Pw6nuf4n{&)78lrhI*Gbsd2%yZ16dzQb8HIG)ujzXN| z57r&2<9&6ktd7+!KU(`PJi0_n>q=wr9j=!yFO(kJ1DRRf`Sl27Qn@P2QWp|%`Dr75 z0qF~FAk;DGN*EZEQ6ep>PpaA|qJkU-|1F8IdQUPFVmfwSF{3Z8mB9- zv9zGt>#ff%ZOC_3S1m8f(`_zWrf=p5-892&ziY-a&nR^1l~fh0mGg{yfO(Lo#uK>5-o5}V9?=QjoXJvX4`7HSLh)U1mM<(1(vu32xTg|uPXSIdD>$WN zqdgzkyHDG*{^)q_lRGe`e=hTGF!DZb)FFO+qA-e$ZdHd1@avlr4muoJh6fX6cyJ;V z@FmJ1bvd#O5^h>d`A`MGxTyeE3W1b;r^y}2QMRM_+VnColwn4Bk=v-B)EDqyVlVaU zfHR8|V3A~x0!QffK%cV6p#4s{?vZfcRB-tcjs+U)3$prHRRfR{oRqO89O^QaAIk`4 zlDz?^LK2+vuT6L#QgEjYKg$1#*@BsHr_CG^lw=5wcG~a=FjSGfO!vP4v88ru&T^Ny1ZoCA>I+PNjWiSEe7}OwTadr4+RD z6HaAUa8&lZ7-FF@#6<(7&@16^9-hW^>1kXQ9QjM0A=~{))t*NFj>h^t8-J*?q0ExT50dmaafpT`7@trvFTCpx$CJ8y2d8?XRN@zc&GI zu2%4bARS)JOt#JKsby-ID^V;(5~{Q`Tu8KMN*Xv@nyQD9X5REPlczw1Z}II3KCa(5 z**y6r#mAc`LWM~_{^K;bCnuu`xadTrGyxa?R~p={@h1T1A&ap16BF5C38=>KB<)9} z;=U*TgCy(^CUU32(%wKS>}~Nkldx}2WUC3s$hRU5_TKpGN!ZsXa;L#wE@6))>wo*C zEde`en<%VGE$cld$&bum&F{+LnA+zY+aSe8g5iSMuQ)5i9yk@#`r#gRa@+ z-($AMm;@z@GdTv*VGX+G%+}lhNM6<1%c>F?@*Nw_CKg9*4eG(FSuyEWdI z?EgN{pae8%khnoA?t9`FC1EcD4W_~#NQ1pCesL1^V$fhJ?3dGE?~R|EggqBDmVJFuh9v9_6QP2C2YcT~!y57*(V&$7rf7STXj{sPN!nJj;uLI>wgDR~lCVkI zPKQmUZ9sAdXj{pLini0?r)YbUXj>)$=_Qj8ZKtP6(zZ8DQm(?0LaXWUskEI$kPa{D zRJF|%ZKF*26*38Eds@Xe5l*zN>VG@p?UDRJ^TBS=c51$pX|VUjzmSCe!gN?; zy#abv>kUcUwEohfm2$n2IOm|&B~x%j*AlLF}9G|l_za7h`}S6l!<;ckSzbi!iv z4DdwLQl`~P6@2l(hfm6(cX2^0$nzf~Wk`;U%w9 z&Nw;Z@SVL#?B=S`{o5N~d%gr-LPoi`r#LtvYWeVGdQE~;YluXC-Vm*6)DnpDQ)`(ixI}*5GwMGHPRVU4`9Wq= zG9=}v8(diGl>D=6%2!azvv2d_^>kt116XaEbQwol(C@copAGlrJMd(}2=G zQhth`Pr)V1myxE|R6K*=)c8!~=W8N)*ZABP7|OynQ4!B3!4`5}8XhCY-(c%lLCI|y(bbexbH zKbhhTeRTfdhtuGdx-Si0@;22z;D_nuk(#?{4~WnXDE+BKgs+} zjid^ho_|tjg7O&jlZ3aO0Y0fS0lYy!Q{{PkVi9RhB!)zJB>kxNH0bA};3t=%zy4~_ z&sSwX-XiH|b@Kg_@q<(E5|M;EB_xHwE zq`;q&?-l)!be@2pdVimk+Ku<%Q|H27$dIq5=qDRay&mDrTTc>)BnGriI;=rE3E0Me z2W!v`U=`gck!-48)AKgy2Ji;mOioCNEYVNt@CMx^^H<{7N9S+QO%h&-V`=aSnQDq| zQp+PHt7+v)fj8*pqu?hmML!YWDb-2qnxg0B@kb|`+KL*{>KLz+i_+kd@)wVPaiXOo z0T;hE4K5*n(K@bWVpg*ROvqnpunGB#V7n$}PlNq&8f-%TBG~bXSxu?=ekTn!A%79< z=84(UU?(LkG2KffkH?JIv|qR3cwF zo72i4b7w=9oXiz3PR|oELTa8;5}e8t_V7GeFa0wKd9k@tR;t>NpH!X(9OxEssd-B1 zM4mQK-dmy>vKE~@vdFfQ=kMX^u>>1CseUXJEY2P)*r~I}oQG&5id!O70?GR}P`)^a zlz{Dszc4wWbRWN*$Wq%@MB6u|!R^9KYrst=Z6vTKYm@y?=Wau=yX=WoaWe~NMKlXs z-`f2Yh}^$CBa|cH89lVhX^D(wY52`bXIOB;6XrbRW~r4nYw3v4iIb-*DGU@W%Zidm zgo`yt$6*PpMY2tN z0Owu&q2ip}vi3$^<1g@A^ZZ!_MFr)3C?wN{aJKCxz8|*3SuqE~X}L2syX$_-{b(k6 zx(yK{k!J(q-~`~mmd<$q+U!h>WZcK($8 zHjWa&Y)5{Mul|X&y@Ib;@2jdnDSPRmlzW(1lTjTx1E#ZRq2tBjNMT_lTznK?MMZcx zhq*H&PG=<3#kyFytUf!tzAVJ~*;xezSvk>Yj&WV!4|^>ZZ`fbbT;%l@HJ41uN;Kw` zEO0m|#}dgJQnq?~qR0?_Qe-PR?$z4r20)T#dGf0h`Jh(f=#oy9j5L++(GTZq2t5gS z*n7*dukxjH|59IqeXhbVGG=@#R=1P~Y5c1)1D3{rvdr&JG*Sx50%#24)P_7$XzU|u z9r3%>7-aFgCp>D)kKo$V;C99LC*byzol#<6vJ7zWMTN01_fC-Ct_0kj$WLyaP=57k zaJ!)4lw+U8?@QV@!EBG>LjM(K+-U4?jfEniC>+!--{(KzKZ*laM-dzK6wbnv)nf)l zWLPdVIGxasTIm?9P(fAUvDCWU5?0K?wo=#O_{xftyi>eEv4#_;D-j`fYXdGg1HSqs z1}T%S*9@;=Ne;nU`v=#q9b|5UHNXqoEi5bkJ6unnzA2S6prcTS7{>1e{~bn1hE@=B z!x@0^S`bt*!=kxpB)|6BGpzQRr(Zkq{A*;sf>@ZAv_Z|fH_h4pIE`!sT+5BN)$unT zsNB1KYIIlhVssO(rNDLH6fTS`?$zy?EW-kCr3NnVtIxc4QsIJK3hbY!F%Wj&wR1Mb z-wzbH{6Qcqh}H6M?yY>_;dEqN8wMZViSZtQ&1_37yDS*VIaLT==s1Nw&;n(V{J2Z{)9PP=^$uqNL>Z%f6W+2uf}ZQLaByG+fyUi zK*DODNx+`OUL9?b8LAD+Hvl`_m!z$e(t#X$Cuyhk=cJuh&6(}A($b2bohj`{*m$MY zM^Ba!^(hR?GA8*#`d-;hs860+k^M5}R<>kQhGb3P4@#CHyOJYPMv(hOQ!)b6yjj>R zVkT!|-ZyLvNk&jMhEx7Yn3FcQn8}@hoh+ezC7)2R9r4d4#{ccacWBFs_(Xmh+%Bx3 z3_h_ZY2OIC?@gh5xZ`HRm0`)W>(^==hGB5WirMmMc%e0hSL%d`<6^88!>gulel$0y zFyMC<1m*C$FS@)O6K9q`&kEWHj&9)ihB3B)LxX=pi9;HnDICX7BrMQyfFNNKERUqI zZ)~5l>HfO50^kVxT?GL-s$NaUkvgU-W0_^e1qX2W)Dh6^j`CohDd6z#M180#Fm^jm z-qcn@hXNb1xiO_1#l3r3|*Ep^Z42&XY5;gUXRgnzp3EzMR?KLk!T-Bu9JkPH{9N^zR%nhuLKuUaDjHd-xV$xn*3F-dC| zo#{LrRo$~JPUvT7ir9591qZ_05f_g7NKVFV$| zF}9=zRrZg9rEw@>r(|^;@}~_RW=i^}o197c%5kV*JK}p2<7@v!SZxQitm zynaWDjql_t!2L|_Lp9>gf_mvic8fVDoRwx` zNh0&uxWzB7oP_p07oaa$2&PW$i)UhCup~Mf{dMOhsElg4-#2#8(GXR-=W`ZtN zzBFEmdJ|=(6iSYroapUJWKDgYDffA=1pPEnA3}z^M$rVva=S=v9}`?>8r&}QwXuGC zG{rtV{!iorUqHYQF;wPvae~H%Co0u;59LP`lM1&BS}udv-=DPg1|L@IK|0^w$YwqU zc64;Yh4>34bkf+XosBDkgVCGf7#@pbbn75j0CWa95tNM}rE>&$0+4Po5VI0qUGWxD z_^3Z{tKGcff1TO^u?lmOwMIy6GAlguq$5ys4T+ zt0C%Dd#ic1KL#(N(t~WTe~teI|F8VIf4MCNgW@_zAAA`JM=hMkK3D)pTi$|bfhZ_B znsW?3HkY5$-bIB=ikoWfjjPISB`XW9IMQehtukD`NfTs{=xgLT*n506&OjVrjYw2* zEme7P^%^)DudKx3eK>T%&T{Hs(l;DMdV$A=sWbdoMyW&mm{N=-vHP5!?sKvWW1qKr z92T=X==BEOW;0yL?`|*1VXqrvFuVA(H{JBv_MP)qukto`_Ewg5HRa_uFD#qU+ur0| zwR+x-@t4wNtK&fc+DE-cADAc1eiYGMjPA9 za&wA9eizuUwXiQ`E(fjc$2uu#FRPU)?LS5^jZ3xj0t=Ufbt~ZSPlJCl{=wvzror!; zh)lu9UrB?%HGW$X-q=Ygo5-$H=Cf*D7=JG<%{}q^($lm|v3EB`SdhB zX?P~xX=(0_Ka-xOBOT9$G7atTgB_v0Zjb*tJ}hEx-4iv_)BHFsjnrpPPg9zX=R0X>q+WY^n*4M; zlQNBAUm*JhwsX_d#3mY7PODEmEsfN3Pfyd9mIiYnwOc~hs`!`vVV+%>BZs1tE9hMA zlukyCCCDDdA)ivmkbI)@NzBnxFpbr+i0E@ToW+;&lf6CW%8`y`BJvwyk59=dnBpIk z*C8B3Jr%3RjW1Y|lT%#cG?#>Oi`l<_XOkKX&85Xck!Ci3~R%n4tOE3gI%uJj; z$ED0np+TU3wS-zig=H3;kDUp~7V>cd4>mJ{xJUF5v&9@_kLNWnEH7W!l$X~;*XF$V zcN`v%1D|i$%qDXtBEXr z?De?)_^~o%3m_eWK;WCbmzqEDxjhcM$76SRwwWk@vngP+>*r?XJED;aTZYe39*H{g z*Oce7Kndb6m|RxfnQytxlJC^5ETCx^q4QB1k!ka9-fr(*h z#$bkShAm*Jf6%YbvzeGpXY*|=!nh4SsrUj*DYKL?OChrqFk3#eLwv4w_0+?F|% z$<6K-_n;f@L0epdE@5-D;$Wh+)yn7HQNO>Q57l2;e`CFxIJLYU~@7&&NkadcNY}x~J2_UyjZ9u=_l0(8DaAnI4Wf@f1;Q-fsI*J1?-azu4Jzc6N@P zyBA!cs`C!eWry1MfVtD0vuQ&-HXpVQsn%wo-b&AgzwzL|TQ z8Ea;*H~*!XA8dZA`Nd{&bMrmT{JLhgu6eAPpVQ1bnwhqTpeQ##0{bHR1(HRZxwV;z zW(*Q777XWhA1-{l@OYv4D%7{d)7gVtx`~;T+-BtOIa_x}@6u7>=vgIGeJ<5(As;Z^yj#y(+W%o5r zpKaooHn9tv*jY`iN#=noQDjqgQDxB_czi#K^WH_PDp*COwffQcjzh&|-MAh-lvjl7 zq;@DPm#(oxz6f1+#9Ww2EY+dvvT9+k&ZCz47K)K)EoPqLQXY-OB7KpyksXnJ5pxL9 zF(Pcv(a5O?e<;G#Tfri}NI_&lM1MWPz7lyV!mp38(Fj|Y4EuFom-zIlS!0Ubf%+xR*z~72YAQ zKthMtBk~1b@H4@7iM@iK7VOW0EfI(W_Jm;j1%_AzLBT`_yK4cvCtMru4X+7P@QMe+ zmN`elFNEI-i*J$VO?oHX;kxpo>{ttkLCxdj_vB z3I`1OydA#XzJ0z^KArg%`1tF-zxeo9d~Ahposa9jP9Goe-RC>(dpg$Y(=EP`ugoVL zK8?dC=z>%HUC!_43?A4QaCVThd!QkcKe4rZ3t~3$2jMpq9+2CfA8lB(dd=1~Teptl z@1oTW7b!ocbl>(o9@LBEZ_-Ub0+>9gH3Eh_pHc#OkB3T?*Xp$NGA{)!6Ht=X5=%oR z(8xu0+w-d%Dz`QuR3mv)#Vg=wtZanKKl!S1D}Kj43XL^-B^6!$5ysI<=6$u{)rQKG z_!@og`368H%SQE>{y+&)0`F8QsSS)OOJ}b1gmm~n)hK{pgI5hyTzsveG<4&A9;HGd z;p&+F5S*FHOt+{Uy@zKrSp>XQSB6XC|3$bnS|FioKmZ;%;b`htq z@oRE(bK?)PrucLCJeVuL?##)_!Mo=8kMa3duKK!^&4{0fPtZ5NGAHNs#@t*c-{m8N zm*_QH^523$z7?7deb&3|B<^yx3hno??D8noLFF+Ig$Bf3c9eW6XVFUvI8GWQ=!j0m z-0)*(iNXJqnZ8I(bSP6^PaVQ9x%3PrQ|6z_{s`GHe0Bm%xBVgr8dKz$vTT!w79OA=N9Mb_{W5WIk15*MNfRKhI@UA zE8`_I2MSwEfn{2K(r2FPmxSj$dYTD;#pI|?X@JZSI1N80flvs+rxGr$_4nU@KQo*I zsjw&#sPg-AbNzu(c97+}0|B=;7<}{n_y6`#upl=YbY=(K4rh(eQ7ga1}ILq`5D_Oa2vIITZX&KHr6$|*GeBLe79L?ohx z3yNsMt}!d@>)S8hOw@^R2+j8}XS(R&UxEJs!=X2ghxZ6r<*OO_TC|*)%cOO2VdXt0 zi^|<76QYCx1351vEHA#;x1T-N$DWhrqV$Bz0v}-cUKV40OhnmQwgo%oHr@q!o9{L; zQ;+2?LFI)L7}>1eqogOK$iS2_dk@VdD~pVcavAMw(dyy+-V(F$wU(psKx5l(+GW~n z5@>Qv13laX8`?H3-DIw-Rkl7VDH@+LEkr?8=4im)f;&^v{^C;R&P;-6&KP{&L!%i>tg4$p26_jK9YTu0!q%IP!h()I$X ztBxPQlqtNPJ+2WcV)|0O99UJAl!LhzuHib2z$9HurVc0WH21si6l` z+PyF_et4IT^&7ask4*4Ve(ciBZ9gky>^V(vz zKAS#8K@Mk~`IwoTiENy6Bluy#jd+pRs81fw<3fFR)&9umw{8xs2j+bzULwV!g!=$?k{=%W(xlH~NZrG4N5nnqqk=t=1+Rj>z3^>4D*&qWEbIC;LZI9XNb}B!6nR zLL$0%jdqi~TID}0Rw(mVU9v?xpz%8G7&?)4>4d}7!#ItqsfIJ!t%Nv4L5XZPVpOW# zUL=Z>&4w(l1D;ViS6Q&P?lE=gn6bcQ^_|A7CFd>VEXO^@JlHG!Vfy+YjCdXi-f9BP z`kDpr7XFp&UNA1TDFg&B{0DQmt!*#v`2-NNE+Tz;hI^YsVUB|$S z^sWOKt6Dg)$I@eW^?2PoZF_<}87V{uW`r^*UUd4z>aCK_5jkGn8dO+BGoKH>|7o@4C1XUy3&OQ47#y^T~Z`oC{eG)ebgr?ygt`qANJMpa^3z$Y#4x zye@4odbZ1?dtH0nJq|0)yl8e%Y)at}@Elug#9nCFQ}lS6E)ajf;By!vsx)H$2VuS` zh1Ea;puQkp1It#FVO=b?8=HS!2*t|mKAQBp;1rqJe3~o~Caf+-A}E?}JKM#09m?o+ z?y>iH^d6fT-6wf?+smrm;EQN=r7Rla%z#JGx9rkJCYwvn?v3bMl4ZclUqlC^ZBiH% z+Q=Bos(fv+Vn^O9 zUh=4-0$BnIT_U@Sx(PDRK585)K$167{}7$cjuqOw;EbI{n!^e1VZwN}*mmkYeZ=+K zFvtzQPZOBr_=J;?5@nz}h@TV?G7Rg_8~lproc^L3+t(#|7V+V-Hc*1St4;>IcY;|F ztvW%dwwI=>gT*IxZWo!9A1H(`!W!u3eFu!P$UZeZQRde-R7tJhJ} z$)d`#5`|KKp&{v;9%Y|lBsUYk#2j-S$({*bdHRby$LO;pzjSEpV+*&KcYp_Nw@@*K zrRxAn=iIA3NQ@JLUe`YTfX>@cN+$^qd+lhvEtVZ{npfl>1Vc^^vRH2;TK&s# z=7l+rx^*@6tK_YXs#KE2U|MIRlDGDqeuHmH%;&OCEm|(x4G~rly}E~6dQ9YOQ_k4v z6l`fXqc2LNw2z4zMAEk}b)F%*Cz+rumg(rSTe`SOIPGAO=AE>Tk@6IH5VczaGEE9- zjTs<4Ihc`~lFdE{)2f5!{{*j@p0Dn*@3D~tXx>BXBM@_HzQoIjVg%>~BL`dp85@GO zoDR^onz0sefQMEymm}u!cRRYQ7P?xx>L8zOLE9hIkLhNeYT>Z#CKA@Azzr$0(ctlw zC*H2~l5c2m2^zEXPjLvaDA1=QP7tV+WoSG}-eA+_#7cHq_tMC*?b7#xx=4UQ7%1!A zmYsVsaC>&6*Y76wAWh2K(6f-5h-)X9195G|8i0rvkzfq8kVKmqb)z{Sc!*vw1k5|w zZg89~U31uW!X2C$x$gy%p517UyOs5N8?954coa*(WYwq`!b#$~JO@%IQM0jLf!r*) zkAdX~auhD3YIPLm$Duhv0(*3XjqYLBW6_9cOscoi202ZN^pB{NFky*6d=(#}QJVjy zjBe99VlzHz{vyUr*AWZj;I2_(u)Ek^Sv~B@?6F+W_fP{Wgm54(t0f(ULSbdJA#jzT z4GlJ~1bYmL6uL{nr+-oQQ8B9RxXE^>joZ2oSTUKA0?&3m7JJlZ`t` z+LGE)wk7c|*_QDp>N7Ov)Y=cRZVsD-pcxyP)RGwq79T`WG!xUPz%J(GurdFBBaYoJ?Pl#Z?M|$*?$Peo z9su(>q&ub=`KIFdU%99J%F31|{{Jy?gE#*R_ji?* z;XmaTjsDNx+!c+A`DJBg+wh^k)N6U#bL#KnnEa8zx5-4?$}UT}pL(xpEB~+1!4ujM z?R(m@+K;stw3oD3v|nn!(te};UVBS>NBgVxckN%=B(yTn-!Tu%U?BwV&Syoej8(E) z2J1F92VzbKTg1*n%)b?is;HN!cj=n=eAKfk1ttMY*Z|Hf~UMnNQ? z)Q|d(U!@2+<@b_!Je&TT-_z6o{~bO9 zf_@RqOwaJ~fgFqh@Xj1)mz9^(6j+ve zRg)aO{V;rL`o!-amA|;|gK+8}1g0t3DnnZpYcbP)F86h5ZQ=-4qdZ{Q<=yM$-Y$C` z6g}MK$jsPj7fPD#apAD)POP*@7{iVL`I}E_+Tl+hOFw!A84c5gA-x)kcgT99Sa?W% zvs?)zWLaZHkd&XX9>~CcL^#6(jUOTdnlnwj$C_dD_c%T7ol>5}a;f12RQqz})NuOg zMr3ggqG2u}f_~DGW%z4%AZHPC~7g$A+mjtf^l!rV%k3A-ir69jC;}%CGH(K|NM^e-kEam zO(}yfr3`+FS7;2I5}LM$*`Rlzdw3j2Oi6XmH7k3_xEI=N_Ly<6Yf<)Bkx!B2QQMz&lzI<#Tqc(kFe zzCPN~KRhx#w61?sbjkSonrL*%(7J))v4Qo`ZNuvaMx)~!2cj!4-ZnhGExK@IcwGIw zZXjA;Q)j$Bdt`W|ePq-6l*cGNN6#G?9UB@Mj@H%8N`;j_e)u=araC2`{^9j0W$Pau zh>i|y7#bTN7)9B}NBh?gZ0;YubSyeDm;y#s=+Y4!LQ#jpL^Fd&BU>pI+T!n-Aa zS&wB-RNmA30sKCO@AY`I4fpGDKZ^Tta8xACX(47dmCHj2m@58&Cbn zJ<&_lpX2D?*)VUc#j=wA)c_0iq)J2BC`AqWU<4+pwZubcUk87apF+Hv1Rs)b)R)PN zmmE;AX#l@5L#t$kF2fEk;lxQYH#mwHT6{k^XC_YX2BFUn!-_Er)|NToT6wU!jA{j1 zAuKP85zVI*_Lt?bh?oH@%qm2gtwAA(02^SD*@URmE!s?UU@Iyy2Pe+vY4fpmj%f?f z1sz(a)&+uEq;-QwF2-tl34(7f#hSWLTc$0?%K97-%(+-!pNIHQ7hsirp|)DP2y5-N zT0axo_qDHTPh(Aeo%WRWGwm7e4eh(w6?quz>j~{JR^JD)*8aKnS?#x2Wj&-l!E~&_ zKMC&o9as~*36=flu|EF~?d#gT%%pvWQFMcwwg1Gr>vLGK-++@yC$+z5U)J_(f79O6 z-q*gOeN+1()@t9va9D?+G3&8v8_<5B{RnHf=d|awpJ;zTcfW)!nV({nzX3;czM!4Z zUe=Cd7`>&vt=*_y0j(yc4(i_{-pg`dz@LBjoGmlbTXHAT8lF`R)t>X!x~Xzeyk5OS%3wxN({sBGz)9R z9G1)Suwsm|0_`8#e?f0m#EMx7E5!=3oK>(HSVvZ|YF2~QWF4z#4caSMRW`wBumx+& zS*(@K#tL&To5$v3of*Sn>vqx8?6g;;lXvmUk>tIs9uY_=3@&_1?|EoUp( zIcz06m#t#wvGdsl>|^Xgwi;{M57}qxm`#8H+d!22^O8HgoHOzd!!XED@*mdlB z_DS|Bwv&BY`!>6Q-N-(}ZepKhpJSiLrpRvg1-6IX%)ZEOVYjl|*zN2~><)G(yNmq? z`!e)e``F!x0dWtzm)*y{%I;@hV_#?c*#qnw?3?Uc2>yJ4J;V-bx3fdq9om=Jg!T?Q z%pTV6gE_}t(CO^bzNp=zJ*FLHk7!S_M-hAParOlJHv103)E!|**^}5=_#XQ{dm0fH zpJhK_KV&~*KW5Ld=h;u#3)qYNDSMH<#9l_ct`qDP_A~Z#MDzJ2dlj*9PO@LYf5GeQ z*X%d&81q|1Li;_UXa0fx5wWQL#NK9qX79iv=`ZX**`oL`HRraSm2_;vhx{z?8Rz7wa7Z{Rob&+wc0XZh#&=lL$an}31tLB!xM z@>}?={5F0&Y|QWAck;XVfABB!y?h^{pL~Vi!|&zy@vp+%@N4|*I9K@q{|5gi{}z7` zMiUS5gZvPm;D`Cc{1N^re~drQpWxr--$8W3Bm5|Tl0U`2$G^{?=FjkF`49LH`H%RI z`E&ev{uBNJd`$k7zsO(WFZ1L41b>D9jQp<+x*Y`9oRtrh5sl2D}Rswjla+T&i}#xi~p1Vi+{jR^EjUr8f<1b zVr=QcB+SAhtO8zfghM!mOSpwcc!f{+MTW=}0TC1-5r&aymdF-4B3I1W z#iB%%iZW3yD#Q#?DXK)Zs1dcIPSlGA(I}ckvuF`B#VpY(W{Wvuu9zq0i#8Dx3q-r< z5S^k+EEJ1Gx9Aaz#aUvBI9n_gy`oPn6U)U4agJCi&K0Y~dE$I=f%q7#R#%IQ#2T?y z^oxtdItHjmf8u4*) zt=KMhh);;?#P#Bn;!|R$__Vk|+$cUHZW5mrpA(-KyToqs1+homEWRji5x0ul#O>ls z;tp}AxJ&$p_%h6B_ldj3SHwNyUU8rJs<>Z#O?+MK7Y~SUh;NE-i3hRg_K-NJ?G=Z_ zgg7i77LSNW#be@e@r3xc_>TB4RzXL_liHo)De*n=eetw-Mm#HiAbu!*Bz`QO6VHpE zh!+rZ?5E;I@sfC192Y0VE8=J3=i(RQm*Q3Nnm8$bB~FRg#jnM0#2ezb;&*{B{8_vs-W7il|0(_|-V=Wl?~A{Se~AAQ{}lfcABfW;E+%yix_Yh)UDr+6 zZ@~tXZqx0$LwD*f-K~3cukO?RdWN2<2lSvG(!+X0&(gE?96c8Xg!y_@FVGA1BE48I z(M$C*yzAseLx@7H|QJnA^j5lQhk%YSs%vfpe_1VeN-RQ$MtRcW%}j%75bI> zRr=NXHTuW(YxV8=4*e7Qb^7)CC-qP1JM~ZNH|RI&pV4p9KdXOE|Gd6S->rW^-=p7* zO^93cTlL%Y+x0K$cj$NOcj^D3e;M0H`}Di@uju#a_v-iQU)Ar|zovg(->*NQe?$MK z{w?fu9?&1s59){X3H`ACu>OetsQ#G#xc-FxZT&m?cl9IK=Xz3qO8=hzef??u8U0!P z2l@~7AL&2VpVOb$f1aedOHVJDcw08clWOlF*~v6^fqyUAg4np`Hg$z$@Gd?vps!<1S|ta@#w&1 z1Ll5tu`C$bFfu%Fsij|C9Ube2M%QiIJh*A#3dg#sdwa+Fk@5a@l&O7P^48qBt{)i9 z>(!+b==;aEh!ffp+&DwerR;T@0{dsi|O`#|#6(q)upKwZsUD&qlpaV(lDk7L8s zy?s$K1N(;Lt#c7pVOWjHGCMbK_mAou@n!BAAKJ8jz&s=`mL8)f zLq<({R859d3-%ag9#U6(PqGN+p_)x2>o)P8#eC=z$KokWj!UNQooA&K&3S3cgYVJ} zqXPrOo3K_LT355Ke{8^+`o_GZf8Dn60rMt#aV|+o>D-j^U|ymcag)60OHe$06TZw# zRr+C-erZY)=Wxn{d8tZ2EHB>S{w*V8Wtv(Q00`VYDAy;&OFarLbQvFSb?d zhoC1J8yd4+p13oguK=%<7w1(2qa$P6BqJJi4vuUaoq8C$Y#{OA7#q4Gaqk)fQyNY_ z4Uh^c@#GvH8crsXc@GT_5|bNsfOjSD$1fjA+`Gm%V(28EWC^AoP=dq*l^}7iN|1b# zB}hEU5+ojM{ewe8E%gnvT5SVk<6sKo1M96Q$oR&g(e*ZzLf(wo@JeQ~(J4!#?#CR1 zz;E0;Wu=V=%3^S6aC{?WA#cVUGNHP+Q!}btf<(c`H`*yLc{gUKchrRA8y!e*+>WV+ zNIa>oP*7t|nb>%cU18i)_Gocc5P35uktc3}Q{6gbzQ(<*g}OI&4s06lCsJytZ)lO% zhWcjX+A0Ru4B@lMMnqDBJ{}{4>INm3H+ETZd26G38+X90;814;CrhAiWdRf*ilG1v z9OyZPgKi`a+$3<|*1#d}Bo2a;I0(+bLAM4D0#rEYPO^_0X#X53gUyXeHs#Ti1gaU^ zI5IkJ>x0g5c+~V;lK`aYsAY;H3i?q=VzOcHEB94^HE) zOk$&l0hy1ylP_J1whe6>14r6KKbYGgFbs^FyN1^zwYh6EUEE0!nZn+6#kx%h7(H_N zuuQyZU^DTC!Ep&EpCp`f*)}5ikzs+Sf1TB6JU1CvNdR^Avm`;_ zI@5SR%eb~0SH+*|XSEy89mciOxON%Wh3eXB;BPhXw;Fg`4ZN)e-c|!|tAV%Gz}srz zZ8h+=8hBd`ysZY_Rs(PALQ^k#aM(0L->M7?j5;qca4#@$FEDT~FmNw0a4#@$FEDT~ zFmNw0a4#@$FEDT~=rXO8IJZsVY&YuLZs2Y=aJL({+YQ|92JUtPce{bR-N4;$;BGf? zw;Qpt6ukLjK(cW6r;u^n&@}B>P$1{k}vn>-apUx-$!{o z)u*cKymfl1eyh9cj1lpTh;KxEW1v-M#xDlb1ZyF>5z&o^ZbWn=q8kz2i0DQ{HzB$S z(M^bMLUa?No6vg`dT&DSO^9zY*oBCkh0%#vY12ByNVBYC6KHDRi}pEeJH2|FdZXc4 zYv4-{>Z~;yp0!59v({*M)*21ZTBG4vYcxD-jfQ7OL&LM9q2bxl(D3YNXn1xsG(0;R z8lD{u`2NUn1;iH+UqE~T@!7+N*9eF&AijY11+*`qeF5!j(7p!kYtX(1?Q77!2K{3X zJ6@wf`x^95gZ^pIKMne)L3|D3YY<<9_*%r*BEA;!wTQ1pd@bT@(LXKXY7tk9xLU;3 zBCZy3wTP=lT!Od+aS7rQ#3hJJ5SJh>LB9#&6T~NoPY|CVK0$nf_yq9{np%`y$0Vl> zPsjv%YWH)}~nv{JQ7D^{x%$bnLQtZ7U4 z@Q=-kt5r?FMb-SI&x))4rg0buWmIRe>ThIG5OFVhy%L_M98%zUjn=#sC`elxX{)-F zNO^(MmQLEzOItzGmchKGlhAbRd=kEsRA$B!h-6ogtO=4eL9(WitZAecYs^-7jnqz! zWKSctQzKc{NR~B{WvygcD_Pb`mbKEc&`KCu2}3JkXeA7-grSu%h=f5T3?g9=34=%& z)yIWM7(~J#5(belbW*EyQVpF{LnqbHNj3CRtMpP^^io^&Qd{(rWxZrsFIm=0mi3b5 zAjxu&8q`ou>cKG1>RgL@MbK5H)9FB84ITFOEt_`5I|naGy5apGl&G5?+rnaungK- z=&MdgU+J*h7+)n29qSf}o^_KD6rPpqSvN`ateYf3tQ#aqZAlR821yX>21yX>21$^~ zd}yl=2GUhxKn$e01ZgfonoE%867%7d>anhvAk8I6a|zO1f;5*P%_Rob6%%~DNJ6md zK&nfS>Jp^71gS1Ts!NdS5~R8WsV+gPOOWakq`CyDE(yV75Q6xj>`_FJ?h>TC1nDk8 zx=WDm5~RBX=`KOKOOWmoq`L&^ETC1nDk8x=WDm5~RBX z=`KOKOOWmoq`L&^ETC1nDk8x=WDm5~RBX=`KOKOOWmo zq`L&^ETC1nDk8x=W0BjT;#iAVx+7h>=kNf`peK;U!3T z2@+m{gqI-UB}jM)5?+FYmmuLKNO%bnUV?;|AmJrQcnK0-Vq#s0PS6Ij?gE~@jD7;! zr1vSXPopXu-d-kHWm2|bm692oof4}GNzF)#RfZ;H$ErHV!YgHZb8F$oGiGEZ!#g)+ zG!!X}P#l>ATgtBRrd-uMHX|bzUeOL66dx<^kt6S!Bkz|C??scvcj5Bh$%^o#bX7$1 z;GwaK$k-g~C}v90J1JSw5&rkiN>;^E+(9DlU=ddpPhYDfAnGU)RV;)_RDhZ+qNY$( z7|8=FYi4Lid0LJMK-|0OBm4;MFv2}!GBOy=|d9+$J$Zn zVa8K>mIJy=6&quAEZwjby=CR%mYEkhpr@<^y`zc~D&{@ydWkr+$c}ot?+ zhOOu%D;KxSCR{8PR*c?K#Rr1biNl-?td(t89_dXGR#?-5989}OvePC!cOGNkl50V#b>KuY^a zNNFD_nAk7~Qp9J&AkYz?4TC^Od;#$U#AC07p&aqpun2U-W5Xc9#D+nTqJL}{1UmZ1 zhC!gCe{2{8I^wZm5a{S18wP=n{;^>Y=;$9C1_>rM41yH>W5XcO(LXi}0v-Kh!ywS{ z__E;;=;$vS4uOvTvf&Wu=r0=%fsV(Q4Tl618xBE={@Geg&dGf#^pdwqJ+#8T}VbjJH6F z_H}4qhxT=7Ux)T}=#LI@bm)%`@pR~q4smsO{&a}1M|?f{$9R%pVmt{_#AiGSbi~&q zz8>-Qh_6R{J>u&TUyu0gm84)|uOuPGz zpquf~-yrmty^<76?3E;>h|f41=!nla8|dgS<7}WKK6^C@I{M2v8|dgS<7}WKKI3eH ziE%ba@pv=N20ET^#@Rqe{~2ck9sOsV4RrLMaW>G=f5zEBNB&IT#^ z&o~?C=s)9Xpd&8hYM>)7<7%KIF5_yTBQE1=pd&8hYJ!PzHAoScaW&8pmvJ=E5tnf^ z&=Hq$G|&;3aWv2omvJ=E5tnf^!NfQkq=?Hn8t8a_87BiB&oAR-pyT;voD6itVO$J! z#9>@aFflF$DdI3L20Hr3xESb&%eWZmh|9Pb=!na>80dIiF)ju=URR8Z2`0w9AjRv5 zaWBvjhjA{@5yynb(}XxCJf0@RF`=I(qdk3&1_jZtC~Vtcu^nQu9cr=N(PF!k#kSF6 z+f==6u&{5iuy3%iZ?Ld$u&{5iuy3%iZ?Lc*VqrhT!hVQ_{SXWLAr|&SEbNC^*blL= zA8N6GM~iI}-4?kBa9MiHjl79oGeAvf-)l0lV{L@gAp!^qmN^Hf+!g zF^5oSv50yk7EuSp9117yW8TnE7%|7ZGcBQ(%~)D91d;5R(Y5A=5wjg?My#$iH-nh% zXrvsemf14A!e;IS()y}FFkvLcIyE~h36>zJsI-nxp(&VV2TI&9yTQ&RFO0bF5B8&ridGvnJROG=_x6) zS*fwvX)w1Nazi_Zt7ZN@x_45`x|wro1DJar3^U35!nAlX-wrG~ zz$|t(%ug3!=6M**CTBJ50L>9BHiUWW8kmvZ17?}WVI2j`g7<(K?k!;sdkD-(e-CDR zE5&AlMSIwCf*J9?FuT1i%wq2f^VOqaCU_&6DkR#dmUZYD9;uc^_vjS{ODMv7^-#;E zMTU1*!;EjSwgb$#cZS*YjbUbd8<-8>5$3)3hMDb&h-?Kj@4aAFeJhwZ-w9^He*iPd znIG0LBflQZw)cnm^hTH+-yi0cizPPj=M8i4gJ33o1k8?4##~#NtKS^v-FJpr^f55^ zoLRAhS^YjRTR#Bi<9C7C^#fr>dTMN9W}JK)m2;?EOywFXOQ`&U$|F>sqVf`zH>s== zCl1MCD)XqENaZvtXHhvfD~lJDMO3Z=sZnmGayOObRGy&nB9+&vyhr6zQL1EA z+EMA2l`|+ymk}EtR2EcA>H-m623Ni?b|L1F1};GL=ekT27WqoP(34 z%A;~3mD8x4Mde&7i{J(m?>r~CL;jjAIbG)>u9$IwyX()V9NdF4=xP4El+(30VhbF^ zUvv78r5qelv1MZK#X;XAO7R~D2%;1<2%-6JOKY$o{(_+!^tF~-;`&Ds;m^yOtp2rE z3B-<}KKwgUTw%$aPp1kb20@T}+ueRdM89Lj~2K~rEI(mZ&wtbu3aPFWeO zMmhy6p|0Us-HB-_rrR(r!E`gG8!=sv=?hGMVJX)Q(|MTQW~rR8t4gk8dVLM1gk4Yd z^HHCUDdPJeu1^`u_c?_rwA<&A>;TAnRNh7z06Ev-iN*O`0x1XCoJ)sQH#1~2-&ig5 zZ{&g11#m}9f|WdSpLt+^I5*lCHl3m`Pvw#kdm17+7`iEzCa8Rjs!gZr#D=wCxZ(VwYrh0+uMvaU4*qd95<1 zX-@l`8$0)NsjR)tHP6l6?OGkTI-}}r^yuJe=XthnD*PbB5U*2UF&ucv3~v>W%ehVEvh_ zK3uW1KCE)1^#P66hZS$MKCFAA^|>5YAFeuz&yB?Tqp<#HtUm_pkHz|VSbrSW-;DLQ zVEq!TzZL6m!}{B?eks=9f%SJ|{XJM8*4K&t!TL7V{(V?~Kh`h9`Ul`y&;posYv9P; z{`YeOfvdzL>&{K3sVDa_O})56ntEgTOjZs@j+Vm_qvfzpkk*I0lh%iIf~v8Pv^k(I7SJ854DJ_S)ik3r*X?<8p%F4%Lc^;OJ!}4udz8%X;v3v)X@5A!_SYC$Z z2Y_Qaz?JU}BfOT}r`SfCLR(lm7SrvR?gxJ14x=)0Y^Q_Kt4Y=q#;*flEi3bk^+VoF z2T!ODp3rhG5A|`Vm!iG{^)l4oY#F;wy*ZkKEtZbMbO)yY%6WNv5C2v7@Y^RHds6=2 zdD6Y@Rp0iiVt@b7_Ns61;QwoP@LR6>ma8%j`-_(ctG?}3-}b6+-vF?Y+}k$* zZ{Gm?XWjt3?N#6Qs&9MMx4kMG;lJ%w|1-U+Ts{xKhRNl2@U`vV_;y)SUHBHy$>B?z zJdb{HmcjdFxjY}fW&Kkz2;nVsE7*TL#Gh>ZCn9``F)kNEY{W$nJ#z_son9(iCR;9B zAzLY1C0i|9Bl}#oR<=&IUbaEDQMO68S++&CRklsGT~;dFA=@e21z+zjLu|*ZvhU!x z5N^S*A>5_$Gao=S&c_go^O@{th$Zj<_G6SEdX!mJGuFx?^gr58lL z^x@R-ZLcxc6e3-=fGCaCh-u`P8F*RnOlvG(gZOqyFvWQo)Eh-9O72? zg@~2!LtM%v_znoa-UG+a_8($*U4s1KkpJ5lUY8+14f1~*%j+BXvizgWuBPwD@a3C> zIcXr}H(@Vvu7mjFFT)|ir5$_|7T>>%Gc`KF_cJ+sS)irjcW?M&FbDn|AYNvU%n|qe zy*+OoMEnwFMQ`{4>KADz-)$88U-~Q zW;Bd}sH}5k3m|T2f7pB6pNbDV0wSpHk$nMCUiU%V*D{zxa1efDqZ}f|9)aksUqKAl zV-UHuf<|mTNu#x%p;21T!|!iggm|%+AhPJUFo)tg#FM=ZabhcJ^wl5XtFagb_POkZ z>=%f=3MY(Ha#oxTd`EVKIIJ!Zf3*(8UabppSL;K})rOoe*Mw^ZQC9u9RuErRfXJ$W z5LMLx5mnnkG}RFJ-3}u}Q0)rQQ+q(<)IJb3H3}l8MnkOB!4MHOg&Qg!RfvigEt5gi zx&k-{q8_J&nS2nZt`PMs*5>o;*0Qo~QP8E} z8T<&hyg1+UHJ|VKQqFOLJ#TBJ@~fqgd#Pl6td*Ug6*!i!2lt92_&$6~iyZG|KI6S% z(xdp-3qG}HK@i(inEEJ2LJk)H_=Xn7ly0(VZMLlaBx&o)maZcLSA|}F65eP{alUIl zpRel6=PQGY6*M}jTE#m`jpJ0%j0q=cvlLNED_40`gy78AvI51%)fxgyj7m?76;$0+?<;27xq3%r$3h&V1PI|BnGlzhmY$kEI5{D!rMhccoWIbT z4-$8?cNH+Qb{wq#PfkpZgCI*;{#oX#*-(>4+0IOWXk^LR>6s$~1RYPrx(e4;)esR0 znZqIEc$PXmJw039vD%nABqtk!sU&BQ4jVwn(pvh5y+?8GNr-S>K5cU&0rUgH;r2J_EM&4}uil!}$qO{qGo?Rqc7b z=(*>?@lST#%ietAVEbV0vj+#f?ay^NnxN4SwU0U))$4DKy!S78I48hwUGW+|yJO4m zr*&65Hd@yqx6g680`AV``J4%kNGR_B2e-Z}$GwJM%9GLSyS|gCDHU?7GTvP*Z6fLp zyq%Q|+>|O6L~rHmi}|%6OsCs1-{tCUTT(KY>`q_sVX*zti(4+P<{OB`zDiHteZ1SY zBjda}RxHfvA5h-?(MR)~?>_9~%(ph%;y9&0-;!@()_JbL2QQBFxU7sCZUf#R8gHN! zCz1OXw=8Z^(A<1AWv14!e^z2vCfpGIaha)ngjiLr4CA};U99W}7IfhXeof=7J>@W6 zTyJiIoOAaREoMQmd-0b1gA3I1T7ymlt~L1a(1^V3^{YoM_p8i(?{wRPKOcP7Bqmh< zep{DV?^TM|WJuD!ON~}EjP5dNR#cA@>sB2nN6Lsk_!~>Px%i^on=CtNf->$@aq`J{RKdE{@h1Dpc}o;r5?Pk{(p2+&7Yom|v@A;}|Ox!x?RpEY<-(fu~ zC;QDY;^W@zWg5~820BbnSXHd8dz8j;VbEuCkbk)zld+0f4D+eH^D-}UUe^!*<$ z#B?dB+;`>m%?E?Me@aN&`tGpe0VDR@U)c3-#`t!9J>zWBFFmR_)qb2jvQeb-#gYkU z%W~RvANS>mL&3T0ycFBjDFH+Lwj7?4SH8z*^MQ-TX6bA7{hm#3df{TLr=NT5XppJv zxyqw`!n{u|w@B;1?A4TO_TP@XHKWdVKOAp;?t1NIuB|T4+!Ry0U9pYIru2iA2|-HZ ze4ph52WB4*S(!Pg-k`$`(qp_r_sRPttl8-6IpmjI#pgZ7jX(5aUGy(YJFGZX*Zoz= zR}ThcIaZC>yWr`_d0%X?9=xoM>tR3m()wW_O5nM8A_Rc|qBSpTFLoJnQ3$ z*_EHw+a%`{%O{la6ZTqkDW}UfpPqd-%w^ct*yHV%zPhqz$k`kGgc+<)nJ|f;kU!q7 zrhS$UUXk#ZoYj1|qFKMGRPhSv9W76>xew5Ee_V1bc=j)~k1VyGK66B|*2?XJSw5c6 zY*w|itNZih@h)k}H|KirugUDV%%G|YZ*F=0In7rHPe+wUUU+&-=%-j#abnQrImWE* z`;A8%Z$FnW-{3nkdB)Dt9w$zQ9n<>W@t(4F(MKU^?nl+PrY`HyG1rx zmzFi@_QHmX>{9bf8sD9m}0!KiW|BpY)?RSgQPlV{djv|0Kop;yuOg$j;TJb2{y;M23c4RgEl1 z;&p@5IUJuh=*7Y4~lzJ9&X?K9Bt2=`)StY}2U14G&(v>Q``K@lUcD(_1*~ z4OO04-Cp^$YW$KDSK{t_30)H=E5H_JP&6oA?*4xnDaWZOGHwogy;$!b3%V{ruY5WOsYCug~WF zlTU>;>zA@U@bIEd9>R0`kE=FJ(5a@{%sbh7QaX+w;8i zzq&si=CUB0cYozNXLs6Ct7VQ3h`23`b@894s zHT5=pZLve5%*lqgf=)mVy@J+EB7oO4iWQXR*LrPxj)Y7yV8|c zwVkACIQr<9c5521nDwpcOcP%>#o&X^=hL0~j~-RA)}>!EZZ$3oIePX&r=G#PvWK5r<{H)V$mHeQ=dZV#IC)%-)i3+q!fI8d zm0xYQqxP_$?mX<%p;7a$*XnnlyoOX*ExS@X`tJq0ctv131pWNs(WKt<2CP#=Y?$pE z*TB8#Z@WrVajn1mDXE@^DzGr33dWDY(91PtJ)D*OgP-;%kN(Yp`tRys#NO1v8#F}F z5~9(H!$$~cD5-pkMQ7SMRB(cW0bP`ht5uj7Mm5cxVJ&5N^IqZ}cCM~({Mc0T&}4{& zCt#_f#?n9R?UpHHZeP57dg-#qd56jOnHM*{EIfH{MP;q}GV4z+yFXnY(ID{Q9Ij~j z%vtkoOxILSezQwgy|%CCu-ng+Ht6=$)%GDz+-{durbK1B^q+b1n||7B5*a+_i+j^%>qgy=`t@SFlx8N|n6sA;#4LL@<>r*U7dP^+1%wXjW7>0s zA2zzAV!C$t{cGFjZ#Y!n@y3)9xkB5>@H(mAep8Y0nfJm;KLtHgb?)A5bN}US6C15; z{+ZqIIfD=E`FM%fk5*&G&+g}yqgGqZiMAj1py~Zb1M<%-u)qE34r}+2%0cJOo}T{c z+UEzzg=sHm7{k)ir;pjh%}D%7_+evxb8lAwM=GB_ELd+vDT|DE6?=;&Z;a~{Z{GFR z<9Us^Qv;@9K}_xJ=dFm~_GQHys1*LHG6zw%z7B_Qm}(uZ*Qvuh#AIeEIZq zE|DLf{iKuYfnmwZ5Ajyx>tE7uJk~ks>#a>}bq;rxZLVMLH0#jf z^i4OMI={HmcwqeM58`B3KHt%sBz)Oi)%8{MD9=joGE?b-7GFtpWHNijgPNQigDI_t8ZrO9rvHTk{A;u`|070`vXZ~@Mp^o9vdZ|@m*(gPOw(M8w7Y&%GZ_NMA|9@2a8Hd z-rGX67iz&sr21uP9bg>h_p7!_0p8E_eSYe=a^B|)4#w6=C@da##9>jLy_T0Ej7XI* zo~hS>cMtQOeysa1t?oFzAN6ST9$RCprVo0S&xfVA&#o-o=C0QoTqdd-U!4|Rd!gx6 zm(~gSn?H?>8FAxSy?e*Il%0OpLq9d@U9Rd*GehGiuiCu~$Q^iaO?u;JPfmAm?)h=Y zGk4mL?(*;}?MD|j`CW2y?SJN;=Id{oUMa|HuKD|o;VmxCANcD1Cu=4aEbwpK?e(5I z)1Uav@wu8-<+AZ|gLZf8ygWVdhn@8@W3LaXceBmc{X4vFXSL_JbC2^kgBQ%0+UK#{ z(f{Y7s`nShckI(s@w8~KN&Wp*2hI4>rW=lT^)0NJaw>JjnaN8Ie>ta5UT9!$cn`P=_8swywY;m zu}A*B_pWrm?$Q3@tKNft?lf*#R#C$9#I~dDWseu1`oQ{5NYSP*lPA_&99Fu)G~&Qn z+aX7S?yRo(YVnZSQ4Mc9^^Y~Wys`5WBeS6ga diff --git a/stdlib/doc/tools/coqrst/notations/__init__.py b/stdlib/doc/tools/coqrst/notations/__init__.py deleted file mode 100644 index e69de29bb2d1..000000000000 diff --git a/stdlib/doc/tools/coqrst/notations/fontsupport.py b/stdlib/doc/tools/coqrst/notations/fontsupport.py deleted file mode 100755 index 1ffd816ba7cb..000000000000 --- a/stdlib/doc/tools/coqrst/notations/fontsupport.py +++ /dev/null @@ -1,83 +0,0 @@ -#!/usr/bin/env python2 -# -*- coding: utf-8 -*- -########################################################################## -## # The Coq Proof Assistant / The Coq Development Team ## -## v # Copyright INRIA, CNRS and contributors ## -## = 191: - fnt.removeGlyph(g) - return fnt - -def center_glyphs(src_font_path, dst_font_path, dst_name): - fnt = trim_font(fontforge.open(src_font_path)) - - size = max(g.width for g in fnt.glyphs()) - fnt.ascent, fnt.descent = size, 0 - for glyph in fnt.glyphs(): - scale_single_glyph(glyph, size, size) - - fnt.sfnt_names = [] - fnt.fontname = fnt.familyname = fnt.fullname = dst_name - fnt.generate(dst_font_path) - -if __name__ == '__main__': - from os.path import dirname, join, abspath - curdir = dirname(abspath(__file__)) - ubuntumono_path = join(curdir, "UbuntuMono-B.ttf") - ubuntumono_mod_path = join(curdir, "CoqNotations.ttf") - center_glyphs(ubuntumono_path, ubuntumono_mod_path, "CoqNotations") diff --git a/stdlib/doc/tools/coqrst/notations/html.py b/stdlib/doc/tools/coqrst/notations/html.py deleted file mode 100644 index 7219fc2e37f4..000000000000 --- a/stdlib/doc/tools/coqrst/notations/html.py +++ /dev/null @@ -1,86 +0,0 @@ -########################################################################## -## # The Coq Proof Assistant / The Coq Development Team ## -## v # Copyright INRIA, CNRS and contributors ## -## str: - """Configure a coqtop instance (but don't start it yet). - - :param coqtop_bin: The path to coqtop; uses $COQBIN by default, falling back to "coqtop" - :param color: When True, tell coqtop to produce ANSI color codes (see - the ansicolors module) - :param args: Additional arguments to coqtop. - """ - self.coqtop_bin = coqtop_bin or os.path.join(os.getenv('COQBIN', ""), "coqtop") - if not pexpect.utils.which(self.coqtop_bin): - raise ValueError("coqtop binary not found: '{}'".format(self.coqtop_bin)) - self.args = (args or []) + ["-q"] + ["-color", "on"] * color - self.coqtop = None - self.debugfile = None - - def __enter__(self): - if self.coqtop: - raise ValueError("This module isn't re-entrant") - self.coqtop = pexpect.spawn(self.coqtop_bin, args=self.args, echo=False, encoding="utf-8") - # Disable delays (http://pexpect.readthedocs.io/en/stable/commonissues.html?highlight=delaybeforesend) - self.coqtop.delaybeforesend = 0 - if os.getenv ("COQ_DEBUG_REFMAN"): - self.debugfile = tempfile.NamedTemporaryFile(mode="w+", prefix="coqdomain", suffix=".v", delete=False, dir="/tmp/") - self.next_prompt() - return self - - def __exit__(self, type, value, traceback): - if self.debugfile: - self.debugfile.close() - self.debugfile = None - self.coqtop.kill(9) - - def next_prompt(self): - """Wait for the next coqtop prompt, and return the output preceding it.""" - self.coqtop.expect(CoqTop.COQTOP_PROMPT, timeout = 10) - return self.coqtop.before - - def sendone(self, sentence): - """Send a single sentence to coqtop. - - :sentence: One Coq sentence (otherwise, Coqtop will produce multiple - prompts and we'll get confused) - """ - # Suppress newlines, but not spaces: they are significant in notations - sentence = re.sub(r"[\r\n]+", " ", sentence).strip() - try: - if self.debugfile: - self.debugfile.write(sentence+"\n") - self.coqtop.sendline(sentence) - output = self.next_prompt() - except Exception as err: - raise CoqTopError(err, sentence, self.coqtop.before) - return output - - def send_initial_options(self): - """Options to send when starting the toplevel and after a Reset Initial.""" - self.sendone('Set Coqtop Exit On Error.') - self.sendone('Set Warnings "+default".') - -def sendmany(*sentences): - """A small demo: send each sentence in sentences and print the output""" - with CoqTop() as coqtop: - for sentence in sentences: - print("=====================================") - print(sentence) - print("-------------------------------------") - response = coqtop.sendone(sentence) - print(response) - -def main(): - """Run a simple performance test and demo `sendmany`""" - with CoqTop() as coqtop: - for _ in range(200): - print(repr(coqtop.sendone("Check nat."))) - sendmany("Goal False -> True.", "Proof.", "intros H.", - "Check H.", "Chchc.", "apply I.", "Qed.") - -if __name__ == '__main__': - main() diff --git a/stdlib/dune-project b/stdlib/dune-project deleted file mode 100644 index e4c4f3b7531a..000000000000 --- a/stdlib/dune-project +++ /dev/null @@ -1,63 +0,0 @@ -(lang dune 3.8) -(name rocq-stdlib) - -; We use directory targets in documentation -(using directory-targets 0.1) - -(using coq 0.8) - -(formatting - (enabled_for ocaml)) - -(generate_opam_files true) - -(license LGPL-2.1-only) -(maintainers "The Rocq standard library development team") -(authors "The Rocq development team, INRIA, CNRS, and contributors") -; This generates bug-reports and dev-repo -(source (github coq/coq)) -(homepage https://coq.inria.fr/) -(documentation "https://coq.github.io/doc/") -(version dev) - -(package - (name rocq-stdlib) - (depends - rocq-runtime - (rocq-core (= :version))) - (synopsis "The Rocq Proof Assistant -- Standard Library") - (description "Rocq 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. - -This package includes the Rocq Standard Library, that is to say, the -set of modules usually bound to the Stdlib.* namespace.")) - -(package - (name coq-stdlib) - (allow_empty) - (depends - coq-core - (rocq-stdlib (= :version))) - (synopsis "Compatibility metapackage for Coq Stdlib library after the Rocq renaming")) - -(package - (name rocq-stdlib-doc) - (license "OPUBL-1.0") - (depends - (conf-python-3 :build) - (rocq (and :build (= :version)))) - (synopsis "The Rocq Proof Assistant Standard Library --- Reference Manual") - (description "Rocq 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. - -This package provides the Reference Manual for the Standard Library.")) diff --git a/stdlib/rocq-stdlib.opam b/stdlib/rocq-stdlib.opam deleted file mode 100644 index 51cee166496b..000000000000 --- a/stdlib/rocq-stdlib.opam +++ /dev/null @@ -1,46 +0,0 @@ -# This file is generated by dune, edit dune-project instead -opam-version: "2.0" -version: "dev" -synopsis: "The Rocq Proof Assistant -- Standard Library" -description: """ -Rocq 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. - -This package includes the Rocq Standard Library, that is to say, the -set of modules usually bound to the Stdlib.* namespace.""" -maintainer: ["The Rocq standard library development team"] -authors: ["The Rocq development team, INRIA, CNRS, and contributors"] -license: "LGPL-2.1-only" -homepage: "https://coq.inria.fr/" -doc: "https://coq.github.io/doc/" -bug-reports: "https://github.com/coq/coq/issues" -depends: [ - "dune" {>= "3.8"} - "rocq-runtime" - "rocq-core" {= version} - "odoc" {with-doc} -] -dev-repo: "git+https://github.com/coq/coq.git" -build: [ - ["dune" "subst"] {dev} - [ - "dev/with-rocq-wrap.sh" - "dune" - "build" - "-p" - name - "-j" - jobs - "@install" - "@runtest" {with-test} - "@doc" {with-doc} - ] -] diff --git a/stdlib/rocq-stdlib.opam.template b/stdlib/rocq-stdlib.opam.template deleted file mode 100644 index f486c12f3fdf..000000000000 --- a/stdlib/rocq-stdlib.opam.template +++ /dev/null @@ -1,15 +0,0 @@ -build: [ - ["dune" "subst"] {dev} - [ - "dev/with-rocq-wrap.sh" - "dune" - "build" - "-p" - name - "-j" - jobs - "@install" - "@runtest" {with-test} - "@doc" {with-doc} - ] -] diff --git a/stdlib/test-suite/.csdp.cache.test-suite b/stdlib/test-suite/.csdp.cache.test-suite deleted file mode 100644 index 2503d027b878759bae77bf775b3b43be89da8643..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 137304 zcmeHw2e?(mx%S>TDE3HIP$`N67Nl7b_SxrfC^kd{8v-H{3)KQ*Ninv>a*hhdo8ROZ zH7cgr6H5|PjETwB#3ZK2L{o06CO6&kzu(L^ZLL{t?|sB93@o?q$edho%Hu8vBj z($OWhs#NZ%;IOk(9^?P5>bmGl*Xb_zIu3Cex8oo9Ble-2)Nky`adeWNRH+>Q^t1oX z75W$|G6&@sC_h7mCaqbz_`HQHR<1bj>=jEFuUWWi&B}|GuIb>{Z67j#xJiWjvj)ik(%PZtmL9g?3dtMPK{R zLDW)ey4c6ITwM9^5N`P^XgSDKuA)rM(Q?&uy1LPp*FY=%D2bupa@lQe(_7GVZX*D2 z{ym;rslXUwFcJeh0ZpXo>-TPZi<>?fO&^MKBFbDe-IF0D9B!8=$)FbFtkdU}%Jla? z^Lc*eYCP*ulv`15Nrtm39~NzT;v1L@XiLimv9;|-**Ic!RWW+yvU85$icCZWc0-wt z(jIM`l6gklQdcpWBp&~*xZsUT`B}^GjBzMeqP#b~Q8}KhnN1yu9wr)V;oQkKZQjRP z|H7|dgx4N`atX@19IsatMH7rnx((B>ci-zMh26LP=7;#blkmR5C^J!JgHc&!Rk*H}-PkF1kis`q9n$s1BThYpEBJm?Y#PdAC=chTU=Zv|MQo$mo>0NkTLo)) z!FH4G;~LIK%_g8+fkGnf=|0kW+G9{v>%*@W_*h*+6L*m)SDh}v~9bMog!9-u6H<1vOd>Wu` zAU+K}cl-|Aj#;Sx-Y93GERDeDFdX7Z{*^IZLMRubB2S9#Jr@H=E!gFpZ}1zg$CHV% zPoX@Xj1+vM+TW)^p~k_bVZW?OxHvj1YSY%PZ6DxN5*}LV36#%dSCXl#K@r<3r*;Pq zlztIVY$cWVfm))rS(QBa!MDE4mAnp>Yo!XJJd#>T?kLGT)o(Rdk?NXN$K8+FOGgi+ zp9sjuQ69^xqf+_>xn*J0eVqfvbFV-6E=KWq)NEgr6)4M5Lr*_xS(QW=y%DHv6DB^R z>JuMv%N|Px-N`Q^TLRy=^a#p>$xtYV4IoI>17_9mTE+wfZ-LjoLG-b*Zb;9e$pMGY zpUD+G2^Ayn=Q5N_qe$pjgfyU{JH(m~lzC%K*#R>uwo5>%Qn_fs2(4>w#(PNLd==%( z$$*e?ZP42tT#R>XLmUZ>qaPN0?cGNyXnK7cF$?-nK->g6C`u9ngs|}b$dgKk@r4f2 zn>B)#M7A$1jUBK;(g~@!x|MzmNQV%lcOV*IVdnQqyNwGlW;i2uRu7->QtBB zs zrs9cimK#Uxq{>&$hkv%mTmYILb0PJ9gUyBYq986#jxZ)JGNHPuvrVQlIB_VQtYKD! z1|DkT%OD2n4UI@ zr!nXPK{06?N(Io#7G-^^aui95jOUtrPM9isC|h|OIncXYGpbcUmq9@$Z< z1AevaX-G?t{Q(%jp?mC)%<7TfMv1ekD@1)^UR-nI47%*me)?o3GreAf%zOayG94v0 zZWVRd8y4HJh3OR5!mwiKF*H4frns;;#FU&xEFk$*sT}>kLwJaGtG=N6CeZvgl#N;D z!Fi%@@#_ofdx-DQ+e@JJL@Bjc35TXW@wIDJVbj3l6+76N1CG>ja(WIMiDPGvXknx9 z79`~(kdjMLF79SY@dNgqb;`U)P7GIkSru}>loV}iJufC&TgtL<9`#U7jSv9lA>V zGVWMq^*vYf9NJ<5dk^v92KCHBF?0gSnmY@nAn~0zM9$W%bhOe;O+R2i)(zN)i^|FD zT4D7;`SWnAo=5pcmTOg~qg>cZ~#K3SqMi^sw5*a zVwWqmY>dL*l|9i$b699C0Z;hEuPQW2B3ZF2?NqF#lP z$4)bGx${``BaT9u1rII0 zz(S`Y8ZQT)R#1kdCv8k{_lQGH;^6TK2Uy|Lcf#O4>_6=Qrr!saZ$P;zD;9Ac)x&%3 z+i*f8uQx+P?pZTFM&Cx2Mi$Yz+CR1xZ+NsLe?oz9?0k9*bQURhnzC>c^~<7HadH#4(cGqYXmdA-=o z2$&g~43BLf#FgD_W;#+w4tstVhY92i1!(#x2JTPxH$${(gy<4|5g`A)jv)$%G% zJD_>k)*!O>j2Fw8wVO~4VxUUhndO@mmAX^Mv-jwucMYN)NwEH`bOy@eAST9p)+mHP zA#*8#t5jAEouPNNT8)Pug0d0i<{X$5e3eec$jx!8fX3f^Zp@G0H-S569V&1HN*BuQ zIVxhBldsLXB6h#6aUEPAXIlj^VD7seCgw(6505Bxh`*ST!OhjGPh%Q$uhwU-z^=?Gnc~u7L=l}4k zd%F?!Kt<9~-~ObT->wC9EtK|!0j}?N%C&kYFtS8-%75Cc8Y=(Ge)sg&wP1n@sxjkO zP1Ol#g-T_cKbCtpoQdkqz6m!;p#)1*y?^qP4QFC%MJy9TmT2A`GxSD(+4kQ6YJDPg zDpmnHfsKytyhd-;S(J$dU)4}1?s@N2y&ER&+lAeLOQ)kO2>L`$MHLFhCz8BWej+wQ zlaN&^Q#QRz>szd^DNRPX8|9-pjB~L!Swu4TzZ$#q@=oSt3+l2rO0d1s#L`ArR1>p5 zAtgR(Vg(VN|49i^+LN$4_qE;m!Bg>20`g>(lcGSnW54wL4w!Bu(_(vL+vR3DmCDXf zto{i<_H%gLB9woi{52iJVlUAKrK4;0(KL$}xm{}9xkvMUm8G}asljSj+|{Ld(%j1x z>l?btrKiig9>h16`y7GePBExcyaNv?Z}*q-s7JA*d2e*nC zF&E|cD8Gw>a+Sfy-P6dw0JBEg~H#D62zz;)in}0C!n-L zh*I6@-UZUmoqPm3aaWsd3YjF545|}!--~yc&aQ5I?S-sCPe2tPL`VM!g{qpeyMOa5 zZaWTJx5#W1ZRt$rQ0qNtMC!s;(T_TYua47KMPJ#!s@LR2v5UDjN~ue+*Cug@(vwQ? zaT;@@VM9e#w5X>tD=>Z}Mr{&@i=*vnsa8+4tk`Kbs zYU$453LDv$Gd8lNmj^nFPHSbbIa^_Sw$1I?R@<|!ZqL%ecqz{l zlvL7*iR72e&|9}t_lu#pM+{cC;E-0cNwRc`1C2Bfmx9=8i7@-r$21WrUp^XzvU97V zMDWchiy69w%(-t=O@}II>9A7iHSUA@(<4{o@f6cxC3o6>(IjN`z0|73%<$`gwcCG< z#es4)#ZicXU{O#56aWJ-EIj)6&+>b)5lU$u%5PA9nXYRRVaWGZi-Y#<%-Dq9*~^^B z9IUu>`r7lj1+**qJ0X0#q6~`i#fqHXeznuAw0D#zA~H`WQ0R$|_-IA}MG}1lri6jy z*s@OAcmF1NN~s^_rqUtyIXD*knWt1L<)^PamvsuJ1C{<d z9k~Z>$4FP64EwZAVn?;a$)0Ny1HGGw6T{V74SQ27o!gJ}h&hM3Bx0DDIQ3CV81K0QEW~@OoC{nl+<)g7?xaI-XQ~KHa zCIEe2hU~EKS>$a{Wxtc>@g4xBU!w*W15D&<%TtmCj^5fmh_}kGtciV%r#MO~(vg-=yX<-t@AD~BQ4}Z9EZQ-#jz9}- zLnRw@7)~E$P!Qk->~MhYkjqz{uFFrPjk3K}-4^;Zkl2nI&rQH}(TBbfg7`_Y4+-B+ z(a*U$SYB;Y;zL|J=N;wem}@ixgC_@!_eR}h|&VS?M z{AMI>OQ!-@{3*R1eY1hqK^QMqAHKmkRS&_Re8CZ~w6ovdlUVDSl5~Uo){y()5ZOp5p-()M|Bo=-FiVCvl6Z<) zec1pQX5kwV(jt&9v|TI?boXW27q8ScKSL_89h06g%M8bbb>4 zQjZ-bO@yGVme{KzrpiO41upo@l8cx$G}7|`r1hI9Ur&};e4a6ZLCtA`cGK}mLD@AY z>ICG!rfJ%#1f}Q|zmD&>Qcw2-a|Y7Yw$j-f$(rv;XNOkJ89E$;n?{ocZ4vZozG)}Q zo|hVRCjIspb%I~gDJa#2n>xj;73ZHf$6>}C0R2mpSEJ03onlp=Yg096j6y@dLO-&N z-IFz%(v<51I=z zRz4%O$+B7TMw`|uxTS4Eb8Qa+ZMSMkN9)%23=&S)px5k`M zXkp+(U*UEdv=k+92=nYdCxF)Bv8Q<4IzGUyc@eZuPe7~EF`a}DIlyh96P?UQczmC4 zn6vhxDa<@%m?#`7--vQu%~%p2y*AkhP+kgo&sCYkod?^nS9xMr=?PVx!X$n;Sq3=>?K*Ba)FV_RMVGB$3?t!>3)& z8f+RkhA#@1zlZW-4vvKptIZmCfbFLN8x09Z61084!>xR!vYKBXXnUTal19X5r*7eptiTtmsqh9fa?oELBz|y<}uL%5rtV*a&4^ z>Ww~+KJK#3lfR&;(E&<9iqzWL~<|!*_ z*R4qlG#x_?PSXS3Zblu#!IhA)rFn$n!>ovDo8zF4DjCyOQ3Db>zP27!TOp5X&4<4B zHbYe)c|k-7fTj7NS`v2<_*Ys)0^q6vTHGflWr8~+m004?fUkOH1l;oy!A(eBFt}>Y z2E5Z&^)S`tS#HzG7 z&{fbbq_itK0d-1xS51#)^Y}~QMj+Z;fjH*emw3)tc@bbnRv^1n+Ve<5-QlF+I!gx?^?(V!ZHXd*bDhoh|~$GcgB<6QO6^%S*PFzmuXM%e{V)@69{)huy0XrPra~D9J5G! z?%k_P0)bxuT%#B2_uNBaQ9;jrMvT*}ODv~bBb=@(3#x9IF}&C3l?5&R6`Xz-_P1NXAiv>ApVQNVqYK*j^ilf1n>D) z1pxWb*fvbP=XqU}VEPq~Gk_!3i#e>D^5H+tW!8-Yj$Ocz=9WI3DuP}!LpYiU%Mgqj zPQWYS$sF7E-hd=SK_E|v|G=qI5Jpj=lF$}z)^ev9S1z*w$s1~Y*K1K~)7djTu! z2pMDSac^u~EcKhhhNT;0p(MjnI^Zg;5Ub!GR`iy?h4SC^aW4)GH5?cP6=Gn}a?4hT z)ef0sMB*xC#ObVG|5lsq79fkSS(K48DW`u~&ue$c)K~)LkZR29*0>wX;V8+iF{a1z_Jl}}BTcr=697y-}YQXc*2qY==Lj^a>r*dj_;ChJfUomz(HAT#{u5Rmoy&m%AGrR{EGfFyp&&h~)O(jl*?6_cJ`GC<}G=v*Lm z;!D0+UJw~ThGzQJ3*?liKYTL_Foq+f^ZZ$;vqw|anJ0NJV4i@v7b0>L4@6Rt3`BGp zNM`uXAtYDT={q0xKjUv=Bqsq$tWYmwU(E6on;S{hISPC>0un6Npcqn%g~u+Kdg#ZY zrCeU%@!osKi2-kaO$5yKsfH$=Xy|qSSM(@l1LI?DcZ@feCEs2<1L1KXrpv%GBR&pc zxjKSn(fD{$ziS$sYpBiWxL7JOsWU`0NI$Lg)%_AsBZ|r1g{)jd$nMmO<(TRlN3xI? zSgoLW$JOt~0NG`q#2he~`A<%P|u7Hf%+T_gjh zx|9?WZ>e+2SfQFx}PH zm+3Q$l!o=CKLgoN_*}%j%!TZsufD1S#!*lQAA%~N)XvA!)q&<@0R>u1_Q7Fh2)~Sg zF@#@{fH7D4;oOf-dPW(b(*FRzi-FxyDA)`jX@lCN)!^118&m_0W+Gqwglg=qLzYB<6&X5=?NxqM%RY-r|CNChF#xtj{ZQ!n*iXwX#6siGgASO zHKeAPrshjg<8}prLM8y2nX7|4{Mm+{`E?)*jigHt+kxzKzowDAOnmLkF(3Z&YwVU3 zNW&Pq8&rG(IF;Th?&G__@B<87*|S_@aLJXD{2bF=U|47v6O1Ass-n|aN2kISU!uF$ z%iHr8acJkt5+(+hJ5g>(=TH`0<~nNK@TsOTyxQFXVW+1;p>4f*jsETZEC&vc%Wb)X_Q2Ih-FUq zj3G8X0kP09ZoP<&?|E8T3OMi#QzVNP!M%*IxbmEGS_n{D{@~AEXjE3DU>lDb(gYYmkBOJ%1Gjz z?=IKIaTWml6u`qS@8uuX2cRY%@XI!iIq{3fne2XbmvLnLFf&i$XJ<_F%shL7XXcqH z)I2j!&HCNrGyT{nE7SCuz~GlQeMPB2xhMEKU^o+{J(a0wj@NpH zqLgovLtHL0!_fgHKx>h;Tb16$s5akz>YraZo=rdjzf4z|`<1h6)Nb1B$^hY<-z`C# zX}tD}ry})BbXJ64=6b3jyz;Lw(FBq^^VpSxOdvD6zN*&psNSHN)xg1#6&-5oA-+(FDtXsGFh^dXzr8W!*t2Zy%L9#oxZkzbK5r1NG6_~4S6c^JhS@SSo zG=ZexG+?mWLB*TOHwGF{+h5!EB|2{PM?`a7!SwYDFC+4hfPOG@ysvj1bs7h zck*EgOc8XNU&IE^k4Rq8-JQ-jWnEJpEFzK7b_gTM!E{;LJO?Xdw-8!`}|NLokoOK}r99l-JZe0!cD8NQ)g|=iAd%B%9>(^GapAm{2+V_A@R1idne}v0Nz5 zcL3-LHqysH6EC5C@^BrD?gOA{$Ec5?+?g7TOG8Nj10f%_q+rw|CJti6Or0gIG8gIBf^RE9c!$CAFgSAVXe}xmvs1ojNO72&(Y*cM4&)^Uh^Fy16Kze`*jl!p(0 zPRC-+npjxNoS7PFnKu@z4a=kda1F=$MYitMP4P9PBpvBO#Xf&EL}J>Pm1mKaB>MH> zY$#!ucbl_{$@msY*e&__M>bD(BoQ&sHYvdmSPzLz;Jn;PI?`2n5mO;-e0*!yxBjUm zvS@asKx6z$M_iyMxXi|10(G+;Sp&XC^g^F0!db1;# zy{4UzqS+CzF}|EQ;eL*J9yz&{8q)`03{8uvms`hw`grZ}9tofAUU<7-NBQdJ@_0SW z{lRxf+KNQ2c|BhGbdXW#&QLN13El_{onXJ$jx4mO{if6j8%C((bN^k|@mf(w*u%r; zpo53j)pWP@$$V!I1ft8ZdH6b%j(okxr>Efp1e`4&MD-vetgN=&*#k#^Ac zB;0a0M?LavqY56TF;N8vzv}qnV{g=1guTGf4}zT^MWJuTPg=8d@p%hZtXy&4*(;VV zUbAr3nw1wVUDIJ_KPF)#tFF*77$*(WP*W|IP8Pw(QiALvqaNQa!!#C4{s^7jFoxHy zD(Kc7`NQVtrF@uDCzS@^3&phaBY{`Zywrqi7S)>H^crKRW2AxmJm6%iEB-HBqmpl) zmP5oM(`%+h04w?}g;o6zsWpY30+`$Ud~+w2I5Wuk<^np16`9ypFJk9xdu!9Z5MOa+ zZfqJQagq5)^?D(P551@>>JKR%8lM_s)D-J#LeB z^ovf$@|vpX5@>3cqmO(R$rW+W&(V61->i;)ZF$9czxtPsLz^-U(8DXUI|y$lhT!=k zx+hd%ls68oEvq>0xu?IP#^_5wL{wDA7ecL56(Ldz9rLt5@3c`F%*YRf>M7kO4s3Dv zAw1v*Kl?Vf_}^&pyAcB}L0Oa<2bxYYZBvTb@2bqqGk#42OGU!TC`5sn06XK!F;){h zpXLa&A3M`WRO4yXGyZ;fakr^(e@hG_&A}n;8^ID^B|v8f%*0TI+!!Lc_2P-loFE9#3V2#TMRuQw; zy)$RGJ$B8tJVB^GMDYfQ;k77NrHUd0Xc6_(Rar=8j!hDhn1+z!`Q4P0AsG$O?%tdB zWURIYR)o`fl(nf?88Db;7ODbM3J8#VN=w-a`Zl}?YS zu;bF8leyCL{NBC?-mjs{@5kFlnMNCJ9?`?*ycm=WhItAQW1DbL^4%_U6BD$5O8~kB z5$LeUoyT@CgDH!n5dhLPaAIG)yG6XSV8Kjw%Fmom1 zfh2%6E+5gl!vjfj*A{%CvsSPQm<1m!WdeYa^-2xsW^j8;^leAodGO|mjXeGspv1oU z_@jlBp5hvUkeg9&Y&7Gti?vG6zx{s$RXX@$EtEy7i7LIe#LWIn=Qh{J2yBXkZW7J+ zF$yj>JYw|kY6Y@@LQ7$AAXi90Hqpc{$ONfDKZuNWq{ zM&?p=M&P5WE|dn6dvu{rSrJujnZirH+>7@pE&Uq4?OOP?(^1;;__n#hiZruO^X2BG zPV_Bu-_r(dcpp_-iIhnMWys~fid(i?i8f&%;4gxTVI3y~%EBuJ*-3INY{ z3r$!xV`e&i#1C+dV~8>HB3^vb-chwN=KOz5)q~eXr!Nr?(1w5`XDI}lP>nB>36&RzHwQVS5#=wNu=@;2I-l15?FyvKbNqDVzdZV_Z1sv5Z zylkZbDiReDxrhs8DqKylqe*a;uRno3wNjII`DB(B`mTuW4lI(0cSl}NO@R_0;+^}+ zJ@pjcKfrys1g^tulw(re2kvqFp%!td{Li)oaSJ3e$_^Vcs(K^8O99aS~& zS3g_IvcT8|^_c;5x%2Mmw18Y22)AAF2felRB9N&5@4piqM(=1p+?-IY=mZ;J!chz+DXWRpLGEx%S)@27z;{o?Ox-K;%@aD<~0)6i;0 zb;VFLFh8SS+%rr@2=}}h4y7V;d?{{VpQ~&A!axeLF5$9gr00azTjk}x!JEOaD4hZA z839T+9NMuL-`)JrU3i@oP^-*;FT_$1HsNy@bFMx`e{7{$>NRS>MZWbUE*-t)5eiG} zv8|PR$l5Il&=JWKPs6Tq)V^!GD)c=_-fzNs0sO&xdxAfBuTH=%@V3qzHuTmPIp{6A zuHWOAQI-Vz~&GE!B?mtOZb9jO*b`Dj>JaghOy zXA=BL>K>S?Qv$tJ$aBhwR6`#MD-x-y$+0aP+&TTntUu)~w%|08_$Dy&dX)F4vXVIz z0n3P-Id7;+SXpq8xR=_K?^74Da`~Y!U3!{$w9b3L6F2YnT^;#R-Ha)TG?3Y%HVQZ1 zPQ~3Q{K$X&w8`IaE}&6;aOEBW$=wmkn-$pxBv%gP(yqz1ep|diyL|;nKh&xbh~x|y zbFG?`bf@|5&hukDUldRyb0QAzBksUkluUb16*oRfO%hg4(QG&QJaTTNzReQ!f%GaFwO+e7wpha;r!#2yl z@Hk2OTT}IgJb~L$P(eSk9f_qBUd#gP7u2LW~t#d8Eob!OHiR zqai~<%n`fXt!;SzIlTcjrt}-PTIwLiC7*m-9P>qk4k5jr50swFur&4B@DPrdo-7FP>zb0%|GF-`!RVm_1hOEjl^Y8yWTa|tYQaTZ!r*_PqZ-No=^y4T9ME!jMVBYctBwKz0#=sf=CP^rUYK#BYnL0e0q#k(fY-v zj`AM@iMcG&UHU(PzAc~K1aQ6$ZS=>}N{ zHX(}HZ^Ws!MlsyXx`m#e6A(&Qu|&pIL`x==(v40gW5{%`ijZ+#3K>I=&e(tSu62Yk z3}pf^S_+l6@})ZZ6U=m{KC^~(OTm;p7oAnX&#h4`?L8PGDONHM}1!#^`cQs7|7yAJ@6c#kWh@;6q64y zHItAs`K5Z$v-WIhLc(3Zs3Y4GPf;viI!rs8O^RX|#>jk8Y%h`}zDWk zsPG~^vJ`oziQ4SeS?OD>4C%U+H)$xnhUQ+1rk;p0C$+g;MXMLM`>DMy#bygJZ$IR-ez|rs%fRcv;WA(_A7yST4i*5@X=smfwS$_M02 zAm9)XnuZV%2)xCB>=Po)e-DVo=kCNnl=G)F6cC;O7$E4Z5n4y?B~y&6lfVeG=Z?n{ z#O!f*K+cSEfPmMT1Vq)OG-MoTKgY}i`1S-3yPEGad&90P=e@@JP?U;tCJYrd(x?(C zONvVp!UjSmzaiy7g%n5;7nfOkvXu~C$Km_V^xJ|1#+j@El!jDB+TpH)%ne5CdLQ(LblJ+qRtt(WsD zA`hAzX?JI$E`_SO>N0y9Z`6$YrFnUrB zwESqR;x{@VATDt1IC~U8{^M{SR zw$|pSbiUJ-iWQOGkLQuR=DQ0?fP$it+VU&%p!Nv&k1fdk!B@Ag=H7o5dhDfDB2wBXy&A9A=Q)+E{iq>kqdcQRp}S#_w&)`Q&5gb?RTz{qAGR2#M!QJh^oR! zok!3QlsLrNn7`L$vdRf0W*2Pvb~|ra#f*OiEx!P*uAm&5+H%`u(=A>@WJ?Qad-EJ` zw_AHQMEGLgHHi~``C%WgwdpB@x4oWY0jQ@m%qE8ZS-G!cggf=}efL4z>dg;mTVMK= zGA$}Xr)PS{;il7BQ%6l}b3*<@#Qj6tztWWBFuUpbH>C0=O;}&BPUrB@-~XARD>X)7 zf@!JJ^w#y`FrEbwxw8WH3`1Y5DMEEm@%D^=ip+kM4IBxBP36 zm!*&uY_d`wkS;G;6)>;aJVY88kC;s-7HDAp)LS@Q9{a-!A5aY}qkW~T&^XGwpPSl1 zuBf#J)&O>A*GiXy6@`fOET2}kN5Eh#@GP4;-!|3eC8w$kjq=4>DQpyH3W}d7>(+`=Nrfg&TqHJ53=yP7JbbhSNb{sUa3bLoz1Tj*2S>+GJ}vf} zv~VP=3W2uMw zazV|!iL#(u!HHyC=-rlR^@B6~1E1K36$+)})&ZCqDAT$F9Els%Uc?njZOq9HPLiqF zrQh4EQ{*TH@uD3CT+fWtyq-`L&>F(_kUAgnNaI$vw$|sCo21rHef_k?YK>%#YWqGO zYPqfVfV4zcV>tP>M*WWIHoNWmCTorSjwx4IHHeyQ9d-kN>wb|e0FR{mZTr*4dp%Sl zLz(ne`xGc~qf0TAQ=1EN=6BCHh&9H~p)n|-m7U77Ei|?9dOGHq5;B7ticDl6JPnz! z|8eoVr+%6n{x%v;A>4A5b86NVL203e*FAs6qeN=M>lc(EU;5i+49i=94<9cY_D>pwzsthfHoqJu%`>b;s6S@n4(?Dg7D9TnXlCN*1j&aI!(nGuLicV-bIQC_{cq{>eHxJ>T& zZ{8TcL=&#ghCUgJvU{pdNh1t(w7MSCwmt{sn&}ubq`T%lpB7t@&Z;;|J1xI3+0${% zbOzZ^e~8^L{5RX#f1-_7pnYeeEKY4Bzrt1}kKU}Yg^?L${!{!G;@g<`nh9?%WhWQ% z8by18rxk@~8=mlicVEMRJO@DD2{3ZZvU5$H+qc|@Mk#31YYeOHt=xSs7q{2b=Tn}) zg1?$n`a7EVUg~d@(^LE0cDAW9`T`*>4wDt3*Inj*?<|jbxd^KDuSrex-6+}P+ico^ zz{5-=;~uvsxX0BA7))==%ax1PUBW&7H^A{8K(P?zv{X141dEClfuO4y@9_L+q>4bJ z(U|%5pG{yi^5=pX4g8_5Whg8*L=k_$tWj%PJk~^(wD>GT_B5glX=;H#`*h#WjME?9 zybDY~`+H%QZLc#^ncy`uBKygLkz@%Aex#@VRb=WT4IYk>MPxpXr$=yK*%t}w8-{9qy z->SLqsM)G--A*-{+z7N28WsE|kf1k^Kd6KT|5xhNzFB=3I&eW%NvOr3Jv7XY+B;l2l7ACbhX_uSjQ|ILDC$q+p zX#`lMX5kDFd96Ui|$_s}jJZTNBrsS}h(YVIwmIEuM&|8Y@DNTJN$ z?>jo`pbcNT03vy957i80aoyacUEDkyml}1%Qy#S8i*Mt^$j8s(n1Xf^y9F3h>8u&Y z3_@Bxq4ov!TC<<8CnjWu$8x5QQ7q9{t39ZF9e+le$F(rxajBgvvHykR6fC=C(NYEs zbID6L1FV}+Zmb!wbmAGjR4e_)jPdarpNW^8+mnn}!16Cn!z*t2r-NWVUK1X_?r?=y zDStklTa7=|r#bS8(XRK~=vb!!>n5i)aa4>F@kQ(NC%>u(7AJucNFA0xkMd;Al#s2l zl~#>O&peHkCYXMxEv-)#-vrASI99{|MxcE&f7{y=(nV=-x!FPf8a1}(jC}1Qb<@b% zTm4we*TDeuZUFf-%IE3>(`joSH229s)AtnXK{Hjp>PNFz?|+3_) z62t*hqCi&ytHO;I3uTO&KutAuk(8A`8oK@)uj%hXmS0woGqB^DO=nly~O8$5%%a4$weS%##oxHo{Hh&`Bds3?V z5KWJ@sr`v(aF}5?N8;HS_5_blnzS$Pf1{39O<2N{smsR#VI@U1AfbO*{38>uSeqMyZOKP$P}P*$$6A3N;$ zsoU;m=^qTpC~hFwZmJJ5D}ZPmi87tAh~=5)zC}oX5V2<;($39MKO-u! zC~t}Or9s+qK=}#njL!nZp9Z`?Mfp*E5C=(_W|C47Zj#5-AcT+XvzvC3Mg!s7f$qmq z?yC>sFo~_)`3sIy*^nCo4AjX2KEgl&X%~T1IH6d=vnrZN4_4 z+*2QbL5f=Ze7#w4nn^wQ<&GC~<9GSvN9X}Wz?XBrs@JK?RYa>C$1jyh6ym-0^S6eLAIn3u$5JiB-)QIYsuC?Fxe}Z@59RD` z;+3sj02V(rRSztYkFhga?CghO@q@bYFKpbJGf+POEVK~-hV#k?rNY9E!ykGfXP|JD zwk@&Kzxa_uEi0Os8%QpV*YA<7QTzt_`6o5QRc;$7M=s11))qHKx&Oz%cq#j3{m|eW z(O6p6d{t_Ly*h>D!#2V+P7Kmhq#_{g9m}5(bO(j+rr$cysXb~Lc=tS3b4Q_DkQOMM z8WWj#z(4l$Z_Q+=MgXc00wx-h`EV*!s2c%f5wrA&w8bKoupSSa2NA9cK6^Lqc5XP5 z`1B%3r3S7(QXrZ9u8#iNiy@h}b?v-4f8=#*Wy;f0((?-_Po*Mf8^svvWM#a&6&R-f z25{p!`R6juVew^Ht1OQP zSfuPei}GkHSTzyNpeRO=_$Uf8!wlvsA52&^k!U~GV&|x`f>~EWF zD159i$3QIsYNGtgO$VgQl5Qya5BiFBS@KJ4ZH7Ynht{4Nmn8wbaSgY!xm^}ken2iV zN}Iaedg03BwHfJVe}xcJCf7G3_};F?7dLGYG)(fGy$|KI&fmY;{>ql&jdEG{_$$_)$~c{@F9I~H0umi;?{h1T@2DJO`v7|4ytHWII6s1dbB zLZV+@YIWoN;eC(eugI0&1V*%mmzJ$AO~uHo6RE3+i{>;!NtZl9(ii{<@xFatLqIw{ zKS)FzN{0DapObF8<7&?O&;}y!10d(1EZaPwSTv}|1IaK4MRyZj2X%PFv3$pzG*o7L z)Cr?<%8tkXi&4o>74C4`rosh)I_8HW4sJH`R33lnwmboyE<3&7!8z%XE=^^yJJ( zC9?sP3ZQppLG+-l{iy`!-+iGT5^LZ*wPX=gaMeGi=!j+kxE9q5*HIrCw1h=-CPed7 z5KAolDF2`vM6*C7G^?q!cnE*>h@B)m1_yZMDTF;tB1F64a$zU{1?x?w^_ zShQ;fGcc!eGl+JB$U6KVzZ=Wipg*($CBQ#`a!q5k0oa{1-beP8$&Z@?+Y})=l;Z0Z z7(B?G*5JtmF+($Qhkf2)tn!bI78PuQDu342SDSLPmqeRf0ICAxEIRb|ZF1Yuf8Cp* zqNPDMgHlvF8cQo_iH(C6@&Dv`N7QjS=D7tX_c~;hOIpw$<_*dt4=oK!o#+!@8sq~u z_=d@PHgp5$Lpse@w1^<)J280>3rr!c4YAZgCaJq+6{7C55~=r;|5_o?wq4_{L;WFePJRSRTkLr z+*)BdFyot+<~TW=6HgD8=RUE%$-y$Anu^}$_qUULm_zTJs}nN=A<&%=<{MBx&};9KRb@6eyTp-uQpp9E5v23Y=HeQ1S6GfDr|GF{nWV|Sz$vVu9g zF`M@lUdpozx%-#8Vf3Gu>OeXFG%%JktDQQ!^Z=eAoHE8ZB!^F9VO$?L*m^(ez(AmV zFy17ZA-FY81KaV36`j|a2Cg<}Yb1@H4#CpltYIaweSsRZ0P2x`6!oNB8${J*(~oOv z=ogsl=@WI!3H{ET*uS|Mg@Su)MA=p#Os+elaL)W+e^$BIrLRL~v0-Q#3kb`*rrHU8DsPtk$&I0qxQ@4-x=a*9=AilrB;^j~30D=+$_3shVuq`hnDvl{u z`2h`!ynt1_vD}mU3%M-SM?N*IJt0081e@rOob^6*sGB*dAFyEW8)L|1f~gDieqij` zZN9fYB^O|UO#@Q_Ta*K^%ibQS^8l1N*#P<3h;nnP40)aAx(i-f6zPAHE>5R>k+AD8s;e={a~t=QEmrFfAbc3Aqz+-vFHGJDv--_0J+x(FXjn1 za%MU0miRczW8Edg3Q0fvSxcOifuvlO7vQSWD*!r%lq zre0g4Y*imegTfv`)`Y7Bl|?p?r3++EGAJr%`V^vQDzZ_Ew)wjy+FeVEZDTU%UtidU z)6h$S{TG0HAC%tpVeder5Rh!H8T>$s)OkZl({{6dXb||@Z@a&qMmrJU*S{@rvPzM< zfG8eu7vy;dOztjuhOW^s0%HKqFGAk^iG{uU)oJQE?%l_?Ol+Mo`m0Rj#$YLtu}Xn~ zp%dmxW5z{YEWPb`kkpwr;Hv8P@C46n^DPXaIRg2T{&t@E6A2Ep{5 z1_`qB6GbyGx)6Z@K=&5`Fy$<7^>*En?k@shu1O7ci39fD!df8XCcD)e5e+{4y zL)oJ~;DZ_=&9Y_To}pa>B<^O7AbmDoc%)XD(_)8o?CFlG+JsqwkK>9MWxwUHY|7WP zdTvY(J=xSnIwM)yc3Z(+jHS#S!(K%Ym+}IOA$oF|>TRDM23T zYaqk=CE!7CaZX$)?=XDW_jHigth_@ekXu|R5(4t9AMK`Ny6%pa2{4s*!0f)HXjy3i zU)VE%ls3{A_KcV=khM;Y>7ssZE@8i9@0Ye=VLu(h{v@0;ETt;{yFRn#ctH%6mS!gr zVZ!DAtc*@0oQYFkI!g0-0Z^wej=X{L&-zf;7;Dz1hROd~3CTu)KD_gKt&PcbehS`O zndn|K=*69edO_d(DL41ie|DdnVqcGIz3YfIO2?Fb3EtWE5;LfyCeXtx zkk74Qg0(-cI`#3t|BCTy%s{j>=rLXxJH$K-53B};3DW_~7>Eu4mO8E)O@N1X`)S|$ z`Nn=FMFM7<=@@WxC6cPDMXlKv`16Sr@#G?C^=40kIUopp6EpQIDba6YhJ4JWb5GIc zp@GhNGVzp?>8Gh`@r2TW%;c!Z1XrN$Y1`8mP`;U}?mb^x^|Ign zwwVqgBf+`xD2b?6umj;^z*%>G;LXL{41{c9S6zRs$|OC!J}&^z5E9@6n0W1`e$_z&QHBV(IJIJXi)Y*y&hiBvJ!duC5o$_3vuadC&$X zrNdaJsRYj}%r_d)R4fZcHT(^1Cn;?{lFdnJb-ehnd#_;~u@H8TQYqMKr2NKawtHE9 zu_ftThgmW-+9g&-n3YnjJ`F;<#n`Z8ViSK6ha9%b(GHS_6}N z#gy`YR3Om^EwIPU`|F_NG$>!1mH01|zi&q6`yUkrHv;qCi*|oV8NAY~!2BZM-HK94 z#hle7NA-F0dRDtaMZ`u;4@^%}1ssxDX`WY}wB7*^Ejp2n{T^sL&1Am~Wn*gF(}LXO zWU{9eP4j7Hwn<_!j0~!J4ehq9M*_SH!2*Os;L}PWc4|gx(ORHH6F)!t7*N_ zzR8Pt6MiRO`oMz>-i*ZqF1fFnfd$xhTm-GeeIj^|csnb)MSU_p{4K{Fk34ET1KjQN z9U};*B|w|a$HW!BshdzAuwBr4`egy2;LlbR)4T-JLuepxoUO9np?P zaAV-gxtj!Ty%HVxn>=zI}=D}k+e3GZS2kLpuBlR0#<9|I^JKv2N{3`Bz2hvo8 z<+vOq6ZCFkiyEji=E&T|N&1yI`@VCq3Q(Z&WS@=UTY4axXn~$W?{L^%#e80d( zY;mVhouMBQq^X;7L_=L{${|f>^eYhFS088md-CnmH~oe+=6<|D*4;cpxuaL`4eIDx z*+2Rgr>gpttft$&`o*U946#K_b4UG3JWVge;~+JcJa+YuxYPa)e(r=0`xVM7$vjmF zPHM6Xm#hOl5{agsF5H}5*l{1FFiAWyLuYH7&!jUgZo-pJR8($2XFy>d@Qt~l_D74Z zyW_V^hszAY(jL8URZ0Y(-+lSbog~{%bDb%1W76+@~AqnLg3AQqZ!d{ZAGORyX%J z)Zi<4kh*AUEg@0WkwUuS-}{W>Uim$QRG>$mNBKq`A?@iSqYWilxbLL?LzgMc>+d5g zg|lK($P?1-0>f#p6p~oBZ4v{;Fe`>QRox`^6JzYDH5dM4pyEL3Vo2r`6nu4|^vSqn z5^3{ZZ@0f+n*i>X~9MExMJ;oRg6dU|NR7REzNJFwTIWETo;93imo({nqiW4 z8epv)&_7}TVJQY_M0tcp42x)pO6A0Dc3;i!ej4vw1eCWSHIR;UH`K&}T2-K03}dDS zpn}sf)uOFUXC(sa#cPF74U?a6rjPr;;*`H01yzfw*4s=Wa*GMbog;{8B;_cQa!FYG z?n7X^XY`Yh>7yqd5_=Mzg`0#wop=WSL;daGZl>?4C0<9>J5=W@Ya!Shlzx(Ql*FaB zQn-~~c$GaPk8g0oAK9(qR_Ba%-dRTYyE<`hsn7Al;Hdqpw)=v-%hbdY!>G4Mq z%{p_;RwXoQhYI^JDJ}A`>R&8@v*klcB;-3zidF#$Nvbek*CNJ;^oQG_Dh%h$xmzHR zvH=#io1HZ0r|vJhSdPS9>Pf0vbn_jmb+V>$>}17M9i9oi)c!!XR6bHxmY%JmKsx7E z=5=|feJnmiI(NtFgC*NMFocYZ5cQH+9nFHqFZuL6KAM@w~ z2G6!b_lVdf+G9PW`9DM&YvI|AZ8cs}XKW;8x>R(nYUG5pR=ZSm&WUMK(eb7wbca%O zj^?XMMaNTcjG}8-Z#};6pdA#0O9#NB4MaH-WpZ56L6kbRY5;f1GHbKgf6r}><%e8` zA5TTO2j#A0F)&eH!Xq_E8-yUG+`94Rt_@usU8T2LI!CMVje100`Q_+?^Xk2ww7bpS}P2|Jqm{f(>iG)$_+-O?#0(pB(EJ-k9cYf%q>TRwbN Xr tmp_test.v && coqc tmp_test.v > /dev/null 2>&1 && rm -f tmp_test.* && echo "false") || (rm -f tmp_test.* && echo "true")) - -VERBOSE?= -SHOW := $(if $(VERBOSE),@true,@echo) -HIDE := $(if $(VERBOSE),,@) -REDIR := $(if $(VERBOSE),,> /dev/null 2>&1) - -# per test timing support (copied from CoqMakefile.in) -TIMED?= -TIMEFMT?="$(1) (real: %e, user: %U, sys: %S, mem: %M ko)" - -ifneq (,$(TIMED)) -ifeq (0,$(shell command time -f "" true >/dev/null 2>/dev/null; echo $$?)) -STDTIME?=command time --quiet -f $(TIMEFMT) -o $(2) -else -ifeq (0,$(shell gtime --quiet -f "" true >/dev/null 2>/dev/null; echo $$?)) -STDTIME?=gtime -f $(TIMEFMT) -o $(2) -else -STDTIME?=command time -endif -endif -else -STDTIME?=command time -f $(TIMEFMT) -o $(2) -endif - -# args: 1=name of target, 2=command to time, -# 3=file to write time data to (optional, default $(1).time) -WITH_TIMER=$(if $(TIMED), $(call STDTIME,$(1),$(if $(3),$(3),$(1).time)) $(2), $(2)) - -REPORT_TIMER=$(if $(TIMED),$(foreach f,$(1),cat $(f).time 2>/dev/null || true;),:) - -# read out an emacs config and look for coq-prog-args; if such exists, return it -get_coq_prog_args_helper = sed -n s'/^.*$(1):[[:space:]]*(\([^)]*\)).*/\1/p' $(2) -get_coq_prog_args = $(strip $(shell $(call get_coq_prog_args_helper,coq-prog-args,$(1)))) -get_coqchk_prog_args = $(strip $(shell $(call get_coq_prog_args_helper,coqchk-prog-args,$(1))) $(filter "-impredicative-set",$(call get_coq_prog_args,$(1)))) -SINGLE_QUOTE=" -#" # double up on the quotes, in a comment, to appease the emacs syntax highlighter -# wrap the arguments in parens, but only if they exist -get_coq_prog_args_in_parens = $(subst $(SINGLE_QUOTE),,$(if $(call get_coq_prog_args,$(1)), ($(call get_coq_prog_args,$(1))))) -get_coqchk_prog_args_in_parens = $(subst $(SINGLE_QUOTE),,$(if $(call get_coqchk_prog_args,$(1)), ($(call get_coqchk_prog_args,$(1))))) - -bogomips:= -ifneq (,$(wildcard /proc/cpuinfo)) - sedbogo := -e "s/bogomips.*: \([0-9]*\).*/\1/p" # i386, ppc - sedbogo += -e "s/Cpu0Bogo.*: \([0-9]*\).*/\1/p" # sparc - sedbogo += -e "s/BogoMIPS.*: \([0-9]*\).*/\1/p" # alpha - bogomips := $(shell sed -n $(sedbogo) /proc/cpuinfo | head -1) -endif - -ifeq (,$(bogomips)) - $(warning cannot run complexity tests (no bogomips found)) -endif - -# keep these synced with test-suite/save-logs.sh -log_success = "==========> SUCCESS <==========" -log_segfault = "==========> FAILURE <==========" -log_anomaly = "==========> FAILURE <==========" -log_failure = "==========> FAILURE <==========" -log_intro = "==========> TESTING $(1) <==========" - -FAIL = >&2 echo 'FAILED $@' -FAIL_CHK = >&2 echo 'FAILED $(patsubst %.v.log,%.chk.log,$@)' - -####################################################################### -# Testing subsystems -####################################################################### - -# These targets can be skipped by doing `make TARGET= test-suite` -COMPLEXITY := $(if $(bogomips),complexity) -VSUBSYSTEMS := prerequisite success bugs output \ - micromega $(COMPLEXITY) modules stm - -# All subsystems -SUBSYSTEMS := $(VSUBSYSTEMS) - -# EJGA: This seems dangerous as first target... -.csdp.cache: .csdp.cache.test-suite - cp $< $@ - chmod u+w $@ - -PREREQUISITELOG = $(addsuffix .log,$(wildcard prerequisite/*.v)) .csdp.cache - -####################################################################### -# Phony targets -####################################################################### - -.DELETE_ON_ERROR: -.PHONY: all run clean $(SUBSYSTEMS) - -ifeq ($(COQLIB_NOT_FOUND),true) -all: - @echo "" - @echo "Coq's standard library has not been installed; please run: " - @echo " - make" - @echo " - make install" - @echo "" - @false -else -ifeq ($(TIMED),) -all: run - $(MAKE) report -else -all: - $(MAKE) run | tee time-of-build.log - python ../../tools/make-one-time-file.py --real time-of-build.log - $(MAKE) report -endif -endif - -# do nothing -.PHONY: noop -noop: ; - -run: $(SUBSYSTEMS) - -clean: - rm -f trace .csdp.cache .nia.cache .lia.cache - rm -f misc/universes/all_stdlib.v - $(SHOW) 'RM <**/*.stamp> <**/*.vo> <**/*.log> <**/*.glob> <**/*.time>' - $(HIDE)find . \( \ - -name '*.stamp' -o -name '*.vo' -o -name '*.vos' -o -name '*.vok' -o -name '*.log' -o -name '*.glob' -o -name '*.time' \ - \) -exec rm -f {} + - $(SHOW) 'RM <**/*.cmx> <**/*.cmi> <**/*.o> <**/*.test>' - $(HIDE)find unit-tests \( \ - -name '*.cmx' -o -name '*.cmi' -o -name '*.o' -o -name '*.test' \ - \) -exec rm -f {} + -distclean: clean - $(SHOW) 'RM <**/*.aux>' - $(HIDE)find . -name '*.aux' -exec rm -f {} + - -####################################################################### -# Per-subsystem targets -####################################################################### - -define vdeps -$(1): $(patsubst %.v,%.v.log,$(wildcard $(1)/*.v)) -endef -$(foreach S,$(VSUBSYSTEMS),$(eval $(call vdeps,$(S)))) - -####################################################################### -# Summary -####################################################################### - -# using "-L 999" because some versions of tail do not accept more than ~1k arguments -summary_dir = echo $(1); find $(2) -name '*.log' -print0 | xargs -0 -L 999 tail -q -n1 | sort - -.PHONY: summary summary.log - -summary: - @{ \ - $(call summary_dir, "Preparing tests", prerequisite); \ - $(call summary_dir, "Success tests", success); \ - $(call summary_dir, "Bugs tests", bugs); \ - $(call summary_dir, "Output tests", output); \ - $(call summary_dir, "Miscellaneous tests", misc); \ - $(call summary_dir, "Complexity tests", complexity); \ - $(call summary_dir, "Micromega tests", micromega); \ - $(call summary_dir, "Module tests", modules); \ - $(call summary_dir, "STM tests", stm); \ - $(call summary_dir, "Ltac2 tests", ltac2); \ - nb_success=`grep -e $(log_success) -r . -l --include="*.log" --exclude-dir=logs | wc -l`; \ - nb_failure=`grep -e $(log_failure) -r . -l --include="*.log" --exclude-dir=logs | wc -l`; \ - nb_tests=`expr $$nb_success + $$nb_failure`; \ - percentage=`expr 100 \* $$nb_success / $$nb_tests`; \ - echo; \ - echo "$$nb_success tests passed over $$nb_tests, i.e. $$percentage %"; \ - } - -summary.log: - $(SHOW) BUILDING SUMMARY FILE - $(HIDE)$(MAKE) --quiet summary > "$@" - -report: summary.log - $(HIDE)bash report.sh - -####################################################################### -# Other generic tests -####################################################################### - -prerequisite/requires_deprecated_library.v.log: prerequisite/deprecated_library.v.log - -$(addsuffix .log,$(wildcard prerequisite/*.v)): %.v.log: %.v - @echo "TEST $< $(call get_coq_prog_args_in_parens,"$<")" - $(HIDE){ \ - echo $(call log_intro,$<); \ - $(call WITH_TIMER,$@,$(coqc) "$<" $(call get_coq_prog_args,"$<") 2>&1); R=$$?; times; \ - if [ $$R != 0 ]; then \ - echo $(log_failure); \ - echo " $<...could not be prepared" ; \ - $(FAIL); \ - else \ - echo $(log_success); \ - echo " $<...correctly prepared" ; \ - fi; \ - } > "$@" - $(HIDE)$(call REPORT_TIMER,$@) - -modules/PO.v.log: modules/Nat.v.log - -$(addsuffix .log,$(wildcard bugs/*.v success/*.v stm/*.v micromega/*.v modules/*.v)): %.v.log: %.v $(PREREQUISITELOG) - @echo "TEST $< $(call get_coq_prog_args_in_parens,"$<")" - $(HIDE){ \ - opts="$(if $(findstring modules/,$<),-R modules Mods)"; \ - echo $(call log_intro,$<); \ - $(call WITH_TIMER,$@,$(coqc) "$<" $(call get_coq_prog_args,"$<") $$opts 2>&1); R=$$?; times; \ - if [ $$R = 0 ]; then \ - echo $(log_success); \ - echo " $<...Ok"; \ - else \ - echo $(log_failure); \ - echo " $<...Error! (should be accepted)"; \ - $(FAIL); \ - fi; \ - } > "$@" - $(HIDE)$(call REPORT_TIMER,$@) - @if ! grep -q -F "Error!" $@; then echo "CHECK $< $(call get_coqchk_prog_args_in_parens,"$<")"; fi - $(HIDE)if ! grep -q -F "Error!" $@; then { \ - $(call WITH_TIMER,$(patsubst %.v.log,%.chk.log,$@),\ - $(coqchk) $(call get_coqchk_prog_args,"$<") \ - $(if $(findstring modules/,$<), \ - -R modules Mods -norec Mods.$(shell basename $< .v), \ - -Q $(shell dirname $<) "" -norec $(shell basename $< .v)) 2>&1); R=$$?; \ - if [ $$R != 0 ]; then \ - echo $(log_failure); \ - echo " $<...could not be checked (Error!)" ; \ - $(FAIL_CHK); \ - fi; \ - } > "$(shell dirname $<)/$(shell basename $< .v).chk.log"; fi - $(HIDE)$(call REPORT_TIMER,$(patsubst %.v.log,%.chk.log,$@)) - -$(addsuffix .log,$(wildcard output/*.v)): %.v.log: %.v %.out $(PREREQUISITELOG) - @echo "TEST $< $(call get_coq_prog_args_in_parens,"$<")" - $(HIDE){ \ - echo $(call log_intro,$<); \ - output=$*.out.real; \ - export LC_CTYPE=C; \ - export LANG=C; \ - { $(call WITH_TIMER,$@,$(coqc_interactive) "$<" $(call get_coq_prog_args,"$<") 2>&1); \ - R=$$?; \ - if ! [ $$R = 0 ]; then printf '\ncoqc exited with code %s\n' "$$R"; fi; \ - } | grep -a -v "Welcome to Rocq" \ - | grep -a -v "\[Loading ML file" \ - | grep -a -v "Skipping rcfile loading" \ - | grep -a -v "^" \ - > $$output; \ - diff -a -u --strip-trailing-cr $*.out $$output 2>&1; R=$$?; times; \ - if [ $$R = 0 ]; then \ - echo $(log_success); \ - echo " $<...Ok"; \ - rm $$output; \ - else \ - echo $(log_failure); \ - echo " $<...Error! (unexpected output)"; \ - $(FAIL); \ - fi; \ - } > "$@" - $(HIDE)$(call REPORT_TIMER,$@) - -.PHONY: approve-output -approve-output: output output-coqtop output-coqchk - $(HIDE)for f in $(addsuffix /*.out.real,$^); do if [ -f "$$f" ]; then \ - mv "$$f" "$${f%.real}"; \ - echo "Updated $${f%.real}!"; \ - fi; done - -# Complexity test. Expects a line "(* Expected time < XXX.YYs *)" in -# the .v file with exactly two digits after the dot. The reference for -# time is a 6120 bogomips cpu. -ifneq (,$(bogomips)) -$(addsuffix .log,$(wildcard complexity/*.v)): %.v.log: %.v $(PREREQUISITELOG) - @echo "TEST $< $(call get_coq_prog_args_in_parens,"$<")" - $(HIDE){ \ - echo $(call log_intro,$<); \ - true "extract effective user time"; \ - res=`$(call WITH_TIMER,$@,$(coqc_interactive) "$<" $(call get_coq_prog_args,"$<") 2>&1) | sed -n -e "s/Finished .*transaction in .*(\([0-9]*\.[0-9]*\)u.*)/\1/p" | head -1 | sed "s/\r//g"`; \ - R=$$?; times; \ - if [ $$R != 0 ]; then \ - echo $(log_failure); \ - echo " $<...Error! (should be accepted)" ; \ - $(FAIL); \ - elif [ "$$res" = "" ]; then \ - echo $(log_failure); \ - echo " $<...Error! (couldn't find a time measure)"; \ - $(FAIL); \ - else \ - true "express effective time in centiseconds"; \ - resorig="$$res"; \ - res=`echo "$$res"00 | sed -n -e "s/\([0-9]*\)\.\([0-9][0-9]\).*/\1\2/p"`; \ - if [ "$$res" = "" ]; then \ - echo $(log_failure); \ - echo " $<...Error! (invalid time measure: $$resorig)"; \ - else \ - true "find expected time * 100"; \ - exp=`sed -n -e "s/(\*.*Expected time < \([0-9]\).\([0-9][0-9]\)s.*\*)/\1\2/p" "$<"`; \ - true "compute corrected effective time, rounded up"; \ - rescorrected=`expr \( $$res \* $(bogomips) + 6120 - 1 \) / 6120`; \ - ok=`expr \( $$res \* $(bogomips) \) "<" \( $$exp \* 6120 \)`; \ - if [ "$$ok" = 1 ]; then \ - echo $(log_success); \ - echo " $<...Ok"; \ - else \ - echo $(log_failure); \ - echo " $<...Error! (should run faster ($$rescorrected >= $$exp))"; \ - $(FAIL); \ - fi; \ - fi; \ - fi; \ - } > "$@" - $(HIDE)$(call REPORT_TIMER,$@) -endif diff --git a/stdlib/test-suite/README.md b/stdlib/test-suite/README.md deleted file mode 100644 index e33f8449b928..000000000000 --- a/stdlib/test-suite/README.md +++ /dev/null @@ -1,97 +0,0 @@ -# Coq Test Suite - -The test suite can be run from the Coq root directory by `make test-suite`. -However, for incremental test suite builds, we recommend running `make` -from the test-suite directory (or with `make -C test-suite`). -This Makefile is compatible with both Dune -and legacy hybrid builds. - -You can also run `make aaa/bbb/ccc.v.log` to build the log for one test, -or `make ddd` where `ddd` is on of the sub-directories of `test-suite` -to just build the logs for that directory. -In these cases, a summary is not printed, but can be generated by `make summary`. - -`make -B` can be used to rerun tests ( -B meaning always remake). - -From the `test-suite` directory, `make report` (included in `make -all`) prints a summary of which tests failed using the produced log -files (this still works when only some tests are built as described -above). Setting the `PRINT_LOGS` variable will make it print the logs -of the failing tests. - -For instance, running the following in the `test-suite` directory: - -```bash -$ echo Fail. > success/fail.v # make some failing test - -$ make -TEST prerequisite/make_local.v -... -TEST success/fail.v -... -BUILDING SUMMARY FILE -FAILURES - success/fail.v...Error! (should be accepted) -Makefile:189: recipe for target 'all failed -make: *** [report] Error 1 - -$ make report PRINT_LOGS=1 -BUILDING SUMMARY FILE -logs/success/fail.v.log -==========> TESTING success/fail.v <========== -Welcome to Rocq (version information) -Skipping rcfile loading. -File "/path/to/success/fail.v", line 1, characters 4-5: -Error: -Syntax error: [vernac:Vernac.vernac_control] expected after 'Fail' (in [vernac:Vernac.vernac_control]). - -0m0.000000s 0m0.000000s -0m0.040000s 0m0.000000s -==========> FAILURE <========== - success/fail.v...Error! (should be accepted) - -FAILURES - success/fail.v...Error! (should be accepted) -Makefile:189: recipe for target 'report' failed -make: *** [report] Error 1 - -$ echo 'Comments "foo".' > success/fail.v - -$ make -TEST success/fail.v -BUILDING SUMMARY FILE -NO FAILURES -``` - -See [`test-suite/Makefile`](Makefile) for more information. - -## Adding a test - -Regression tests for closed bugs should be added to -[`bugs`](bugs), as `bug_1234.v` where `1234` is the bug number. -Files in this directory are tested for successful compilation. -When you fix a bug, you should usually add a regression test here as well. - -The error "(bug seems to be opened, please check)" when running -`make test-suite` means that a test in [`bugs`](bugs) failed to -compile. - -There are also output tests in [`output`](output) which consist of a `.v` file -and a `.out` file with the expected output. Output tests in this directory are -run with coqc in -test-mode. Output tests in [`output-coqtop`](output-coqtop) -work the same way, but are run with coqtop. - -There are unit tests of OCaml code in [`unit-tests`](unit-tests). These tests -are contained in `.ml` files, and rely on the `OUnit` unit-test framework, as -described at . Use `make unit-tests` in the -[`unit-tests`](unit-tests) directory to run them. - -## Fixing output tests - -When an output test `output/foo.v` fails, the output is stored in -`output/foo.out.real`. Move that file to the reference file -`output/foo.out` to update the test, approving the new output. Target -`approve-output` will do this for all failing output tests -automatically. - -Don't forget to check the updated `.out` files into git! diff --git a/stdlib/test-suite/_CoqProject b/stdlib/test-suite/_CoqProject deleted file mode 100644 index dc121311d075..000000000000 --- a/stdlib/test-suite/_CoqProject +++ /dev/null @@ -1 +0,0 @@ --Q prerequisite TestSuite diff --git a/stdlib/test-suite/bugs/bug_10025.v b/stdlib/test-suite/bugs/bug_10025.v deleted file mode 100644 index ae149c9565bb..000000000000 --- a/stdlib/test-suite/bugs/bug_10025.v +++ /dev/null @@ -1,39 +0,0 @@ -From Stdlib Require Import Program. - -Axiom I : Type. - -Inductive S : Type := NT : I -> S. - -Axiom F : S -> Type. - -Axiom G : forall (s : S), F s -> Type. - -Section S. - -Variable init : I. -Variable my_s : F (NT init). - -Inductive foo : forall (s: S) (hole_sem: F s), Type := -| Foo : foo (NT init) my_s. - -Goal forall - (n : I) (s : F (NT n)) (ptz : foo (NT n) s) (pt : G (NT n) s) (x : unit), -match - match x with tt => tt end -with -| tt => - match - match ptz in foo x s return (forall _ : G x s, unit) with - | Foo => fun _ : G (NT init) my_s => tt - end pt - with - | tt => False - end -end. -Proof. -dependent destruction ptz. -(* Check well-typedness of goal *) -match goal with [ |- ?P ] => let t := type of P in idtac end. -Abort. - -End S. diff --git a/stdlib/test-suite/bugs/bug_10407.v b/stdlib/test-suite/bugs/bug_10407.v deleted file mode 100644 index bf500cd1f64f..000000000000 --- a/stdlib/test-suite/bugs/bug_10407.v +++ /dev/null @@ -1,55 +0,0 @@ -Require Coq.Program.Tactics. - -Module Example1. - -Inductive A : Type := -| C : forall (B := unit) (x : B) , A. - -Program Definition f (v : A) : unit := - match v with - | C x => _ - end. - -End Example1. - -Module Example2. - -(* A bit more complex *) - -Inductive A : Type := -| C : forall (B : Type) (C := unit) (x : B * C) (y:=0) , A. - -Program Definition f (v : A) : unit := - match v with - | C B (x1,x2) => _ - end. - -End Example2. - -Module Example3. - -(* With local parameters and indices *) - -Inductive A (n:=0) : let p:=1 in Type := -| C : forall (B : Type) (C := unit) (x : B * C) (y:=0) , A. - -Program Definition f (v : A) : unit := - match v with - | C B (x1,x2) => _ - end. - -End Example3. - -Require Import JMeq. - -Module Example4. - -Inductive A (n:=0) : forall n, let p:=n in bool -> Type := -| C : forall (B : Type) (C := unit) (x : B * C) (y:=0) , A y true. - -Program Definition f n b (v : A n b) : unit := - match v with - | C B (x1,x2) => _ - end. - -End Example4. diff --git a/stdlib/test-suite/bugs/bug_10533.v b/stdlib/test-suite/bugs/bug_10533.v deleted file mode 100644 index 74f23ecd9824..000000000000 --- a/stdlib/test-suite/bugs/bug_10533.v +++ /dev/null @@ -1,8 +0,0 @@ - -From Stdlib Require Import Eqdep Setoid. -Goal forall (t : unit) (pf : tt = t), - if (match pf with eq_refl => false end) then True else False. -Proof. - intros. - try setoid_rewrite <-Eqdep.Eq_rect_eq.eq_rect_eq. -Abort. diff --git a/stdlib/test-suite/bugs/bug_11030.v b/stdlib/test-suite/bugs/bug_11030.v deleted file mode 100644 index 26807d3f53ba..000000000000 --- a/stdlib/test-suite/bugs/bug_11030.v +++ /dev/null @@ -1,29 +0,0 @@ -Inductive I : let z := 0 in Set := C : I. -Check match C with C => true end. -(* Was failing due to prepare_predicate_from_arsign_tycon not robust to let-in *) - -From Stdlib Require Import Arith Program. - -Module Bug11586. - -Inductive vector (A : Type) : nat -> Type := - | nil : vector A O - | cons : forall {n : nat}, A -> vector A n -> vector A (S n). - -Arguments vector A n. -Arguments nil {A}. -Arguments cons {A n} x xs. - -(** Program was failing due to a List.rev issue *) - -Program Fixpoint nth'' {A : Type} {m : nat} - (xs : vector A m) (n : {i : nat | i < m}) : A := - match xs, n with - | nil, i => ! - | cons y ys, O => y - | cons y ys, (S q) => nth'' ys (exist _ q _) - end. -Next Obligation. Admitted. -Next Obligation. Admitted. - -End Bug11586. diff --git a/stdlib/test-suite/bugs/bug_11321.v b/stdlib/test-suite/bugs/bug_11321.v deleted file mode 100644 index 172340ca4d01..000000000000 --- a/stdlib/test-suite/bugs/bug_11321.v +++ /dev/null @@ -1,10 +0,0 @@ -From Stdlib Require Import Cyclic63. - -Goal False. -Proof. -assert (4294967296 *c 2147483648 = WW 2 0)%uint63 as H. - vm_cast_no_check (@eq_refl (zn2z int) (WW 2 0)%uint63). -generalize (f_equal (zn2z_to_Z wB to_Z) H). -now rewrite mulc_WW_spec. -Fail Qed. -Abort. diff --git a/stdlib/test-suite/bugs/bug_11890.v b/stdlib/test-suite/bugs/bug_11890.v deleted file mode 100644 index 22e380aade36..000000000000 --- a/stdlib/test-suite/bugs/bug_11890.v +++ /dev/null @@ -1,10 +0,0 @@ -From Stdlib Require Import Orders ZArith 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/stdlib/test-suite/bugs/bug_12257.v b/stdlib/test-suite/bugs/bug_12257.v deleted file mode 100644 index 15fc24aa9c71..000000000000 --- a/stdlib/test-suite/bugs/bug_12257.v +++ /dev/null @@ -1,3 +0,0 @@ -(* Test that ExtrHaskellString transitively requires ExtrHaskellBasic *) -From Stdlib Require ExtrHaskellString. -Import Stdlib.extraction.ExtrHaskellBasic. diff --git a/stdlib/test-suite/bugs/bug_1243.v b/stdlib/test-suite/bugs/bug_1243.v deleted file mode 100644 index c886f7f0d0da..000000000000 --- a/stdlib/test-suite/bugs/bug_1243.v +++ /dev/null @@ -1,9 +0,0 @@ -From Stdlib Require Import ZArith. -From Stdlib Require Import Arith. -Open Scope Z_scope. - -Theorem r_ex : (forall x y:nat, x + y = x + y)%nat. -Admitted. - -Theorem r_ex' : forall x y:nat, (x + y = x + y)%nat. -Admitted. diff --git a/stdlib/test-suite/bugs/bug_12860.v b/stdlib/test-suite/bugs/bug_12860.v deleted file mode 100644 index e8be4fc2424c..000000000000 --- a/stdlib/test-suite/bugs/bug_12860.v +++ /dev/null @@ -1,10 +0,0 @@ -From Stdlib Require Import NsatzTactic. -From Stdlib Require Import ZArith QArith. - -Goal forall x y : Z, (x + y = y + x)%Z. - intros; nsatz. -Qed. - -Goal forall x y : Q, Qeq (x + y) (y + x). - intros; nsatz. -Qed. diff --git a/stdlib/test-suite/bugs/bug_12889.v b/stdlib/test-suite/bugs/bug_12889.v deleted file mode 100644 index 819fb4ded0a6..000000000000 --- a/stdlib/test-suite/bugs/bug_12889.v +++ /dev/null @@ -1,28 +0,0 @@ -From Stdlib Require Import Relations. -From Stdlib Require Import Setoid. -From Stdlib Require Import Ring_theory. -From Stdlib Require Import Ring_base. - -Section S1. -Variable R : Type. -Variable Rone Rzero : R. -Variable Rplus Rmult Rminus : R -> R -> R. -Variable Rneg : R -> R. - -Lemma my_ring_theory1 : @ring_theory R Rzero Rone Rplus Rmult Rminus Rneg (@eq -R). -Admitted. -Add Ring my_ring : my_ring_theory1. -End S1. - -Section S2. -Variable R : Type. -Variable Rone Rzero : R. -Variable Rplus Rmult Rminus : R -> R -> R. -Variable Rneg : R -> R. - -Lemma my_ring_theory2 : @ring_theory R Rzero Rone Rplus Rmult Rminus Rneg (@eq -R). -Admitted. -Add Ring my_ring : my_ring_theory2. -End S2. diff --git a/stdlib/test-suite/bugs/bug_12907.v b/stdlib/test-suite/bugs/bug_12907.v deleted file mode 100644 index 5338dbeb2b9e..000000000000 --- a/stdlib/test-suite/bugs/bug_12907.v +++ /dev/null @@ -1,7 +0,0 @@ -From Stdlib Require Export Lia. -Set Mangle Names. -Lemma test (n : nat) : n <= 10 -> n <= 20. -Proof. lia. Qed. - -Lemma test2 : 0 < 1. -Proof. lia. Qed. diff --git a/stdlib/test-suite/bugs/bug_13307.v b/stdlib/test-suite/bugs/bug_13307.v deleted file mode 100644 index c08bfcbcd2e6..000000000000 --- a/stdlib/test-suite/bugs/bug_13307.v +++ /dev/null @@ -1,15 +0,0 @@ -Module numbers. - From Stdlib Require Export EqdepFacts PArith NArith ZArith. -End numbers. - -Import numbers. -Open Scope Z_scope. -(* Make sure Z_scope is open. *) -Local Lemma Z_scope_test : (0%Z) + (0%Z) = 0%Z. -Proof. reflexivity. Qed. - -Import numbers. - -(* Make sure Z_scope is still open. *) -Local Lemma Z_scope_test2 : (0%Z) + (0%Z) = 0%Z. -Proof. reflexivity. Qed. diff --git a/stdlib/test-suite/bugs/bug_1362.v b/stdlib/test-suite/bugs/bug_1362.v deleted file mode 100644 index 8475f1a35349..000000000000 --- a/stdlib/test-suite/bugs/bug_1362.v +++ /dev/null @@ -1,17 +0,0 @@ -(** Omega is now aware of the bodies of context variables - (of type Z or nat). *) - -From Stdlib Require Import ZArith Lia. -Open Scope Z. - -Goal let x := 3 in x = 3. -intros. -lia. -Qed. - -Open Scope nat. - -Goal let x := 2 in x = 2. -intros. -lia. -Qed. diff --git a/stdlib/test-suite/bugs/bug_13698.v b/stdlib/test-suite/bugs/bug_13698.v deleted file mode 100644 index bcb36237393e..000000000000 --- a/stdlib/test-suite/bugs/bug_13698.v +++ /dev/null @@ -1,5 +0,0 @@ -From Stdlib Require Import SetoidList. - -Lemma Problem : forall (A : Type) (eqA : A -> A -> Prop) (x : A) (l : list A), NoDupA eqA (x::l) -> True. - Info 1 destruct 1. -Abort. diff --git a/stdlib/test-suite/bugs/bug_13979.v b/stdlib/test-suite/bugs/bug_13979.v deleted file mode 100644 index d92297844748..000000000000 --- a/stdlib/test-suite/bugs/bug_13979.v +++ /dev/null @@ -1,22 +0,0 @@ -From Stdlib Require Import Lia Lists.List Program.Wf. - -Import ListNotations Nat. - -Set Universe Polymorphism. - -(* Check that merge_by calls merge_by_func with the identity instance *) - -Program Fixpoint merge_by {A : Type} (f : A -> nat) (l0 l1 : list A) - {measure (length l0 + length l1)} : list A := - match l0, l1 with - | [], _ => l1 - | _, [] => l0 - | n0 :: k0, n1 :: k1 => if f n0 <=? f n1 then - n0 :: merge_by f k0 l1 else - n1 :: merge_by f l0 k1 - end. -Next Obligation. - intros. - subst;cbn. - lia. -Qed. diff --git a/stdlib/test-suite/bugs/bug_1414.v b/stdlib/test-suite/bugs/bug_1414.v deleted file mode 100644 index 701c52d1b0f0..000000000000 --- a/stdlib/test-suite/bugs/bug_1414.v +++ /dev/null @@ -1,42 +0,0 @@ -From Stdlib Require Import ZArith. -From Stdlib.Program Require Import Wf Utils. - -Parameter data:Set. - -Inductive t : Set := - | Leaf : t - | Node : t -> data -> t -> Z -> t. - -Parameter avl : t -> Prop. -Parameter bst : t -> Prop. -Parameter In : data -> t -> Prop. -Parameter cardinal : t -> nat. -Definition card2 (s:t*t) := let (s1,s2) := s in cardinal s1 + cardinal s2. - -Parameter split : data -> t -> t*(bool*t). -Parameter join : t -> data -> t -> t. -Parameter add : data -> t -> t. - -Program Fixpoint union - (s u:t) - (hb1: bst s)(ha1: avl s)(hb2: bst u)(hb2: avl u) - { measure (cardinal s + cardinal u) } : - {s' : t | bst s' /\ avl s' /\ forall x, In x s' <-> In x s \/ In x u} := - match s, u with - | Leaf,t2 => t2 - | t1,Leaf => t1 - | Node l1 v1 r1 h1, Node l2 v2 r2 h2 => - if (Z_ge_lt_dec h1 h2) then - if (Z.eq_dec h2 1) - then add v2 s - else - let (l2', r2') := split v1 u in - join (union l1 l2' _ _ _ _) v1 (union r1 (snd r2') _ _ _ _) - else - if (Z.eq_dec h1 1) - then add v1 s - else - let (l1', r1') := split v2 u in - join (union l1' l2 _ _ _ _) v2 (union (snd r1') r2 _ _ _ _) - end. -Reset union. diff --git a/stdlib/test-suite/bugs/bug_14374.v b/stdlib/test-suite/bugs/bug_14374.v deleted file mode 100644 index 7c2abd66e7b2..000000000000 --- a/stdlib/test-suite/bugs/bug_14374.v +++ /dev/null @@ -1,73 +0,0 @@ -From Stdlib Require Import Arith. -Import Logic.EqNotations. - -Definition le n m := forall p, p <= n -> p <= m. -Infix "<=" := le : nat_scope. - -Definition le_refl n : n <= n := - fun _ x => (***** This "id" blocked unification *****) id x. - -Definition le_trans {n m p} (Hnm : n <= m) (Hmp : m <= p) : n <= p := - fun q (Hqn : Peano.le q n) => Hmp _ (Hnm _ Hqn). -Infix "ā†•" := le_trans (at level 45). - -Theorem le_S_up {n m} (Hnm : n <= m) : n <= S m. - intros p Hpn. - apply (Peano.le_S p m). - apply Hnm. - auto. -Defined. -Notation "ā†‘ h" := (le_S_up h) (at level 40). - -Theorem le_S_down {n m} (Hnm : S n <= m) : n <= m. - unfold le. - intros p Hpn. - apply Hnm. - apply Peano.le_S. - auto. -Defined. -Notation "ā†“ p" := (le_S_down p) (at level 40). - -Notation "x .+1" := (S x) (at level 1, left associativity, format "x .+1"). -Notation "x .+2" := (S (S x)) (at level 1, left associativity, format "x .+2"). - -Set Printing Projections. - -Record PartialBox {n p : nat} := { - box (Hp : p <= n) : Type ; - box' (Hp : p.+1 <= n) : Type ; - box'' (Hp : p.+2 <= n) : Type ; - subbox {q} {Hp : p.+1 <= q.+1} (Hq : q.+1 <= n) : - box (ā†“ (Hp ā†• Hq)) -> box' (Hp ā†• Hq); - subbox' {q} {Hp : p.+2 <= q.+2} (Hq : q.+2 <= n) : - box' (ā†“ (Hp ā†• Hq)) -> box'' (Hp ā†• Hq); - cohbox {q r} {Hpr : p.+2 <= r.+2} {Hr : r.+2 <= q.+1} {Hq : q.+1 <= n} - (d : box (ā†“ ā†“ (Hpr ā†• (Hr ā†• Hq)))) : - subbox' (Hr ā†• Hq) (subbox (Hp:=ā†“le_refl _) (Hpr ā†• (Hr ā†• Hq)) d) = - (subbox' (Hr ā†• Hq) (subbox (Hp:=ā†“le_refl _) (Hpr ā†• (Hr ā†• Hq)) d)); -}. - -Record PartialCube (n p : nat) (Box : forall {p}, PartialBox) := { - cube {Hp : p <= n} : - (Box.(box) (le_refl n) -> Type) -> Box.(box) Hp -> Type ; - cube' {Hp : p.+1 <= n} : - Box.(box') Hp -> Type ; - cube'' {Hp : p.+2 <= n} : - Box.(box'') Hp -> Type ; - subcube {q} {Hp : p.+1 <= q.+1} - (Hq : q.+1 <= n) - {E : Box.(box) (le_refl n) -> Type} - {d : Box.(box) (ā†“ (Hp ā†• Hq))} (b : cube E d) : - cube' (Box.(subbox) Hq d) ; - subcube' {q} {Hp : p.+2 <= q.+2} - (Hq : q.+2 <= n) - {d : Box.(box') (ā†“ (Hp ā†• Hq))} (b : cube' d) : - cube'' (Box.(subbox') Hq d) ; - cohcube {q r} {Hp : p.+2 <= r.+2} - {Hr : r.+2 <= q.+1} {Hq : q.+1 <= n} - (E : Box.(box) (le_refl n) -> Type) - (d : Box.(box) (ā†“ ā†“ (Hp ā†• (Hr ā†• Hq)))) (b : cube E d) : - (***** This used to fail if "id" was present in the proof of le_refl *****) - rew (Box.(cohbox) d) in - (subcube' _ (subcube _ b)) = (subcube' _ (subcube _ b)) -}. diff --git a/stdlib/test-suite/bugs/bug_1448.v b/stdlib/test-suite/bugs/bug_1448.v deleted file mode 100644 index 11e16585bd38..000000000000 --- a/stdlib/test-suite/bugs/bug_1448.v +++ /dev/null @@ -1,28 +0,0 @@ -From Stdlib Require Import Relations. -From Stdlib Require Import Setoid. -From Stdlib Require Import Ring_theory. -From Stdlib Require Import Ring_base. - - -Parameter R : Type. -Parameter Rone Rzero : R. -Parameter Rplus Rmult Rminus : R -> R -> R. -Parameter Rneg : R -> R. - -Lemma my_ring_theory : @ring_theory R Rzero Rone Rplus Rmult Rminus Rneg (@eq -R). -Admitted. - -Parameter Req : R -> R -> Prop. - -Axiom Req_refl : reflexive _ Req. -Axiom Req_sym : symmetric _ Req. -Axiom Req_trans : transitive _ Req. - -Add Relation R Req - reflexivity proved by Req_refl - symmetry proved by Req_sym - transitivity proved by Req_trans - as Req_rel. - -Add Ring my_ring : my_ring_theory (abstract). diff --git a/stdlib/test-suite/bugs/bug_14731.v b/stdlib/test-suite/bugs/bug_14731.v deleted file mode 100644 index 8071abefa4c8..000000000000 --- a/stdlib/test-suite/bugs/bug_14731.v +++ /dev/null @@ -1,99 +0,0 @@ -(* Check that hints are correctly applied up to Ī·-expansion. *) - -Module Unary. - -Class Test {A : Type} (R : A -> Prop) : Prop := {}. - -Axiom A : Type. - -Definition foo {R : A -> Prop} {HR : @Test A (fun x => R x)} : @Test A R := _. -Definition bar {R : A -> Prop} {HR : @Test A R} : @Test A (fun x => R x) := _. - -Axiom Rā‚€ : A -> Prop. - -Definition fooā‚€ {HR : @Test A (fun x => Rā‚€ x)} : @Test A Rā‚€ := _. -Definition barā‚€ {HR : @Test A Rā‚€} : @Test A (fun x => Rā‚€ x) := _. - -Inductive Rā‚ : A -> Prop :=. - -Definition fooā‚ {HR : @Test A (fun x => Rā‚ x)} : @Test A Rā‚ := _. -Definition barā‚ {HR : @Test A Rā‚} : @Test A (fun x => Rā‚ x) := _. - -End Unary. - -(* For good measure, check that Ī·-expansion works with functions of arity 2 *) - -Module Binary. - -Class Test {A B : Type} (R : A -> B -> Prop) : Prop := {}. - -Axiom A B : Type. - -Definition foo {R : A -> B -> Prop} {HR : @Test A B (fun x y => R x y)} : @Test A B R := _. -Definition bar {R : A -> B -> Prop} {HR : @Test A B R} : @Test A B (fun x y => R x y) := _. - -Axiom Rā‚€ : A -> B -> Prop. - -Definition fooā‚€ {HR : @Test A B (fun x y => Rā‚€ x y)} : @Test A B Rā‚€ := _. -Definition barā‚€ {HR : @Test A B Rā‚€} : @Test A B (fun x y => Rā‚€ x y) := _. - -Inductive Rā‚ : A -> B -> Prop :=. - -Definition fooā‚ {HR : @Test A B (fun x y => Rā‚ x y)} : @Test A B Rā‚ := _. -Definition barā‚ {HR : @Test A B Rā‚} : @Test A B (fun x y => Rā‚ x y) := _. - -End Binary. - -(* Check that Ī·-expansion correctly handles holes in patterns *) - -Module RelCapture. - -Inductive paths {A : Type} (a : A) : A -> Type :=. - -Class Contr (A : Type) : Type := {}. - -#[export] -Declare Instance myInst {X : Type} (x : X) : Contr {y : X & @paths X x y}. - -Definition foo {X : Type} (x : X) : Contr {y' : X & @paths X x y'} := _. - -End RelCapture. - -Module Collapse. - -Class Test {A : Type} (R : A -> Prop) : Prop := {}. - -Axiom t : Type -> Type. -Axiom map2 : forall [elt : Type], (elt -> Prop) -> t elt -> Prop. - -Definition lift_relation {A} (R : A -> Prop) (defaultA : A) (m1 : t A) : Prop := - map2 (fun x1 => R defaultA) m1. - -Definition Q : Prop -> Prop := fun H => H. - -#[local] -Declare Instance lift0 : forall (A : Type) (default : A) (R : A -> Prop), - Test (fun x : A => Q (R x)) -> - Test (fun x : t A => Q (lift_relation R default x)). - -Definition foo {A R} {HR : @Test A R} {default} : Test (@lift_relation A R default) := _. - -End Collapse. - -From Stdlib Require List. - -Module FMap. - -Import List. Import ListNotations. - -Monomorphic Universe i o. -Class FMap (M : Type@{i} -> Type@{o}) := - fmap : forall {A:Type@{i}} {B:Type@{o}}, (A -> B) -> M A -> M B. -Global Arguments fmap {_ _ _ _} _ !_ / : assert. -#[local] -Monomorphic Instance fmap_list@{a b} : FMap (fun T => list T) := - fun (A : Type@{a}) (B : Type@{b}) f => @map A B f. -Fail Fail Monomorphic Constraint i < list.u0. -Fail Fail Example instance_found := fmap (id) [1;2;3]. - -End FMap. diff --git a/stdlib/test-suite/bugs/bug_15043.v b/stdlib/test-suite/bugs/bug_15043.v deleted file mode 100644 index e68cb597f202..000000000000 --- a/stdlib/test-suite/bugs/bug_15043.v +++ /dev/null @@ -1,61 +0,0 @@ -(* Trailing let-ins were dropped in specialize. *) - -Module ShortExample. - -Lemma test (H : forall x, let y := 1 in x=y) : True. -specialize H with (x:=0). -let t := type of H in let _ := type of t in idtac. -Abort. - -End ShortExample. - -Module OriginalReport. - -Axiom proof_admitted : False. -Tactic Notation "admit" := abstract case proof_admitted. -From Stdlib Require Psatz. -From Stdlib Require Utf8. - -Import Arith. -Import Psatz. -Import Stdlib.Unicode.Utf8. - -Fixpoint log3_iter down_counter log_up_counter up_counter dist_next := - match down_counter with - | O => log_up_counter - | S down_counter' => match dist_next with - | O => log3_iter down_counter' (S log_up_counter) (S up_counter) (2 * up_counter + 1) - | S dist_next' => log3_iter down_counter' log_up_counter (S up_counter) dist_next' - end - end. - -Definition log3_nat (n: nat) : nat := log3_iter (Nat.pred n) 0 1 1. - -Lemma log3_iter_spec : āˆ€ down_counter log_up_counter up_counter dist_next, - 3^(S log_up_counter) = dist_next + up_counter + 1 ā†’ - dist_next < 2*3^log_up_counter ā†’ - let s := log3_iter down_counter log_up_counter up_counter dist_next in - 3^s <= down_counter + up_counter < 3^(S s). -admit. -Defined. - -Lemma log3_nat_mono : āˆ€ n m, n <= m -> log3_nat n <= log3_nat m. -Proof. - intros n m LT. - destruct n. - replace (log3_nat 0) with 0. - lia. - compute. - lia. - rewrite -> (Nat.pow_le_mono_r_iff 3); try lia. - unfold log3_nat. - - pose proof log3_iter_spec as Spec1. - specialize Spec1 with (down_counter := Nat.pred (S n)). - specialize Spec1 with (up_counter := 1). - specialize Spec1 with (log_up_counter := 0). - specialize Spec1 with (dist_next := 1). - destruct Spec1. -Abort. - -End OriginalReport. diff --git a/stdlib/test-suite/bugs/bug_15568.v b/stdlib/test-suite/bugs/bug_15568.v deleted file mode 100644 index 19527525c8b2..000000000000 --- a/stdlib/test-suite/bugs/bug_15568.v +++ /dev/null @@ -1,18 +0,0 @@ -From Stdlib Require Import BinInt. -From Stdlib Require Import RelationClasses. - -Axiom mod_mod : forall a b : Z, Z.modulo (Z.modulo b a) a = Z.modulo b a. - -#[global] Hint Rewrite Z.add_0_r mod_mod : bu. - -Definition modEq (d:Z) := fun (a b :Z)=> Z.modulo a d = Z.modulo b d. - -#[global] Instance modEqR (d:Z): Reflexive (modEq d). Admitted. -#[global] Instance modEqT (d:Z): Transitive (modEq d). Admitted. - -Lemma foo d a e : (a mod d)%Z = e -> Z.modulo (Z.modulo a d + 0) d = e. -Proof. - intro H. - rewrite_strat try (bottomup (hints bu)). (* Should not fail. *) - exact H. -Qed. diff --git a/stdlib/test-suite/bugs/bug_1584.v b/stdlib/test-suite/bugs/bug_1584.v deleted file mode 100644 index b47caa01552f..000000000000 --- a/stdlib/test-suite/bugs/bug_1584.v +++ /dev/null @@ -1,5 +0,0 @@ -From Stdlib Require Export Reals. - -Parameter toto : nat -> nat -> nat. - -Notation " e # f " := (toto e f) (at level 30, f at level 0). diff --git a/stdlib/test-suite/bugs/bug_16043.v b/stdlib/test-suite/bugs/bug_16043.v deleted file mode 100644 index 18e4243e889e..000000000000 --- a/stdlib/test-suite/bugs/bug_16043.v +++ /dev/null @@ -1,52 +0,0 @@ -From Stdlib Require Program.Tactics. - -Module Reduced. - Axiom t : Type -> Type. - Axiom map2 : forall {elt : Type}, t elt. - - Program Definition map2' elt : t elt - := let f' := match true with - | true => @None elt - | _ => None - end - in - map2. -(* Error: Unbound reference: In environment -elt : Type -The reference 2 is free. - *) - About map2'. -End Reduced. - -From Stdlib Require FMapInterface. -Import Orders. -Import Stdlib.FSets.FMapInterface. - -Definition option_value {A} (v1 : option A) (v2 : A) : A := match v1 with Some v => v | None => v2 end. - -Module ProdWSfun_gen (E1 : DecidableTypeOrig) (E2 : DecidableTypeOrig) (M1 : WSfun E1) (M2 : WSfun E2). - - Definition t elt := M1.t { m : M2.t elt | ~M2.Empty m }. - Program Definition map2 elt elt' elt'' (f : option elt -> option elt' -> option elt'') : t elt -> t elt' -> t elt'' - := let f' := match f None None with - | None => f - | _ => fun x y => match x, y with - | None, None => None - | _, _ => f x y - end - end in - M1.map2 (fun m1 m2 - => if match m1, m2 with None, None => true | _, _ => false end - then None - else - let m1' := option_value (option_map (@proj1_sig _ _) m1) (M2.empty _) in - let m2' := option_value (option_map (@proj1_sig _ _) m2) (M2.empty _) in - let m' := M2.map2 f' m1' m2' in - if M2.is_empty m' - then None - else Some (exist _ m' _)). - (* uncaught Not_found *) - Next Obligation. Admitted. - About map2. - -End ProdWSfun_gen. diff --git a/stdlib/test-suite/bugs/bug_1614.v b/stdlib/test-suite/bugs/bug_1614.v deleted file mode 100644 index 60c3afaf1d68..000000000000 --- a/stdlib/test-suite/bugs/bug_1614.v +++ /dev/null @@ -1,21 +0,0 @@ -From Stdlib Require Import Ring. -From Stdlib Require Import ArithRing. - -Fixpoint eq_nat_bool (x y : nat) {struct x} : bool := -match x, y with -| 0, 0 => true -| S x', S y' => eq_nat_bool x' y' -| _, _ => false -end. - -Theorem eq_nat_bool_implies_eq : forall x y, eq_nat_bool x y = true -> x = y. -Proof. -induction x; destruct y; simpl; intro H; try (reflexivity || inversion H). -apply IHx in H; rewrite H; reflexivity. -Qed. - -Add Ring MyNatSRing : natSRth (decidable eq_nat_bool_implies_eq). - -Goal 0 = 0. - ring. -Qed. diff --git a/stdlib/test-suite/bugs/bug_1618.v b/stdlib/test-suite/bugs/bug_1618.v deleted file mode 100644 index cd53c5d02bb2..000000000000 --- a/stdlib/test-suite/bugs/bug_1618.v +++ /dev/null @@ -1,23 +0,0 @@ -Inductive A: Set := -| A1: nat -> A. - -Definition A_size (a: A) : nat := - match a with - | A1 n => 0 - end. - -From Stdlib Require Import Recdef. - -Function n3 (P: A -> Prop) (f: forall n, P (A1 n)) (a: A) {struct a} : P a := - match a return (P a) with - | A1 n => f n - end. - - -Function n1 (P: A -> Prop) (f: forall n, P (A1 n)) (a: A) {measure A_size a} : -P -a := - match a return (P a) with - | A1 n => f n - end. -Proof. Defined. diff --git a/stdlib/test-suite/bugs/bug_16181.v b/stdlib/test-suite/bugs/bug_16181.v deleted file mode 100644 index a8c2680ab65f..000000000000 --- a/stdlib/test-suite/bugs/bug_16181.v +++ /dev/null @@ -1,38 +0,0 @@ -From Stdlib Require Import Equality. - -Inductive star {genv state : Type} - (step : genv -> state -> state -> Prop) - (ge : genv) : state -> state -> Prop := - | star_refl : forall s : state, star step ge s s -. - -Parameter genv expr env mem : Type. - -Inductive state : Type := - | State : expr -> env -> mem -> state. -Parameter step : genv -> state -> state -> Prop. - -Section Test. - -Variable ge : genv. -Axiom admit:False. - -Set Printing Universes. Set Printing All. -Lemma compat_eval_steps - a b e a' b' - (H:star step ge (State a e b) (State a' e b')) - : True. -Proof. - intro_block H. - - generalize_eqs_vars H. - destruct admit. -Qed. -(* Error: Illegal application: -The term "@eq_refl" of type "forall (A : Type@{eq.u0}) (x : A), @eq A x x" -cannot be applied to the terms - "Type@{foo.11}" : "Type@{foo.11+1}" - "genv" : "Type@{genv.u0}" -The 1st term has type "Type@{foo.11+1}" which should be coercible to "Type@{eq.u0}". - *) -End Test. diff --git a/stdlib/test-suite/bugs/bug_16728.v b/stdlib/test-suite/bugs/bug_16728.v deleted file mode 100644 index db0ad7b39ecd..000000000000 --- a/stdlib/test-suite/bugs/bug_16728.v +++ /dev/null @@ -1,8 +0,0 @@ -From Stdlib Require Import Ring. -Lemma Rlt_n_Sn : exists P:Prop, True -> P. -Proof. -eexists. -intro. -apply f_equal. -try ring_simplify. -Abort. diff --git a/stdlib/test-suite/bugs/bug_16738.v b/stdlib/test-suite/bugs/bug_16738.v deleted file mode 100644 index 36fefb7dff46..000000000000 --- a/stdlib/test-suite/bugs/bug_16738.v +++ /dev/null @@ -1,11 +0,0 @@ -From Stdlib Require Vector. - -Inductive container : Type := - | container_v : Vector.t container 2 -> container - | container_0 : container. - -Fixpoint test (c : container) : unit := - match c with - | container_0 => tt - | container_v v => test (Vector.nth v (Fin.FS Fin.F1)) - end. diff --git a/stdlib/test-suite/bugs/bug_16803.v b/stdlib/test-suite/bugs/bug_16803.v deleted file mode 100644 index 2151d1ac9104..000000000000 --- a/stdlib/test-suite/bugs/bug_16803.v +++ /dev/null @@ -1,102 +0,0 @@ -From Stdlib Require Import Lia. -From Stdlib Require Import ZArith. -Import ZifyClasses. - -Module Test1. - - Record Z2@{u} : Type@{u} := MkZ2 { unZ2 : Z }. - - Global Instance Inj_Z2_Z : InjTyp Z2 Z := - { inj := unZ2 - ; pred := fun _ => True - ; cstr := fun _ => I - }. - Add Zify InjTyp Inj_Z2_Z. - - Lemma eq_Z2_inj : - forall (n m : Z2), - n = m <-> unZ2 n = unZ2 m. - Proof. - Admitted. - - Global Instance Op_eq : BinRel (@eq Z2) := - { TR := @eq Z - ; TRInj := eq_Z2_inj - }. - Add Zify BinRel Op_eq. - - Theorem lia_refl_ex : forall (a b : Z2), a = a. - Proof. - lia. - Defined. - - Fail Constraint mkrel.u0 < unZ2.u. - -End Test1. - -Module Test2. - (* we need a separate copy of Z2 to test a different case because - otherwise the constraint is set in one of the tests *) - - Record Z2@{u} : Type@{u} := MkZ2 { unZ2 : Z }. - - Global Instance Inj_Z2_Z : InjTyp Z2 Z := - { inj := unZ2 - ; pred := fun _ => True - ; cstr := fun _ => I - }. - Add Zify InjTyp Inj_Z2_Z. - - Lemma eq_Z2_inj : - forall (n m : Z2), - n = m <-> unZ2 n = unZ2 m. - Proof. - Admitted. - - Global Instance Op_eq : BinRel (@eq Z2) := - { TR := @eq Z - ; TRInj := eq_Z2_inj - }. - Add Zify BinRel Op_eq. - - Theorem lia_refl_ex : forall (a b : Z2), a = b -> True. - Proof. - zify. - exact I. - Defined. - - Fail Constraint mkrel.u0 < unZ2.u. - -End Test2. - -Module Test3. - - Record Z2@{u} : Type@{u} := MkZ2 { unZ2 : Z }. - - Global Instance Inj_Z2_Z : InjTyp Z2 Z := - { inj := unZ2 - ; pred := fun _ => True - ; cstr := fun _ => I - }. - Add Zify InjTyp Inj_Z2_Z. - - Lemma eq_Z2_inj : - forall (n m : Z2), - n = m <-> unZ2 n = unZ2 m. - Proof. - Admitted. - - Global Instance Op_eq : BinRel (@eq Z2) := - { TR := @eq Z - ; TRInj := eq_Z2_inj - }. - Add Zify BinRel Op_eq. - - Constraint mkrel.u0 < unZ2.u. - - Theorem lia_refl_ex : forall (a b : Z2), a = a. - Proof. - Fail lia. - Abort. - -End Test3. diff --git a/stdlib/test-suite/bugs/bug_16906.v b/stdlib/test-suite/bugs/bug_16906.v deleted file mode 100644 index 9a941cc1b1db..000000000000 --- a/stdlib/test-suite/bugs/bug_16906.v +++ /dev/null @@ -1,8 +0,0 @@ -From Stdlib Require Import Program. -From Stdlib Require Import List. -Import ListNotations. -Open Scope list_scope. -Program Fixpoint foo - (_local_inst := tt) (decls : list unit) {struct decls} : list unit - := match decls with | [] => [] | _ => [] end. -(* Was raising a Not_found *) diff --git a/stdlib/test-suite/bugs/bug_16960.v b/stdlib/test-suite/bugs/bug_16960.v deleted file mode 100644 index 65dbaeddee39..000000000000 --- a/stdlib/test-suite/bugs/bug_16960.v +++ /dev/null @@ -1,44 +0,0 @@ -From Stdlib Require Import BinInt. - -Class decoder (n : Z) W := - { decode : W -> Z }. -Coercion decode : decoder >-> Funclass. - -Axiom W : Type. - -Definition tuple_decoder {n} {decode : decoder n W} (k : nat) : decoder (Z.of_nat k * n) W. -Admitted. - - -Lemma tuple_decoder_1 {n:Z} {decode : decoder n W} - (P : forall n, decoder n W -> Type) - : P (Z.of_nat 1 * n)%Z (tuple_decoder 1). -Admitted. - - -Axiom Q : forall (n : Z) (Wdecoder : decoder n W), Type. - -Lemma is_Q {n decode } - : Q (1 * n) (@tuple_decoder n decode 1). -Proof. - Fail apply tuple_decoder_1. - refine (tuple_decoder_1 _). -(* master: no goals remain -this PR: Error: Found no subterm matching "(Z.of_nat 1 * n)%Z" in the current goal. *) -Qed. - -(* -If not using `unsafe_occur_meta_or_existential`, -matching the `tuple_decoder` argument of P/Q instantiated -the `n` argument of `tuple_decoder_1`, -but then when matching `(Z.of_nat 1 * n)%Z` -the unsafe occur check would not realize that `n` is instantiated -so would continue unification with delta on. - -If using the `unsafe_occur_meta_or_existential`, -if we `apply (@tuple_decoder_1 n).` -(so there is no evar to be mistaken about) -we get the same `Found no subterm matching "(Z.of_nat 1 * n)%Z"` error. -I don't know if we should consider that the error is legitimate -given that the goal contains `1 * n` (no `Z.of_nat`). -*) diff --git a/stdlib/test-suite/bugs/bug_1738.v b/stdlib/test-suite/bugs/bug_1738.v deleted file mode 100644 index e79ec478edd4..000000000000 --- a/stdlib/test-suite/bugs/bug_1738.v +++ /dev/null @@ -1,30 +0,0 @@ -From Stdlib Require Import FSets. - -Module SomeSetoids (Import M:FSetInterface.S). - -Lemma Equal_refl : forall s, s[=]s. -Proof. red; split; auto. Qed. - -Add Relation t Equal - reflexivity proved by Equal_refl - symmetry proved by eq_sym - transitivity proved by eq_trans - as EqualSetoid. - -Add Morphism Empty with signature Equal ==> iff as Empty_m. -Proof. -unfold Equal, Empty; firstorder. -Qed. - -End SomeSetoids. - -Module Test (Import M:FSetInterface.S). - Module A:=SomeSetoids M. - Module B:=SomeSetoids M. (* lots of warning *) - - Lemma Test : forall s s', s[=]s' -> Empty s -> Empty s'. - intros. - rewrite H in H0. - assumption. -Qed. -End Test. diff --git a/stdlib/test-suite/bugs/bug_17423.v b/stdlib/test-suite/bugs/bug_17423.v deleted file mode 100644 index b2a35d5eb266..000000000000 --- a/stdlib/test-suite/bugs/bug_17423.v +++ /dev/null @@ -1,11 +0,0 @@ -From Stdlib Require Import Reals Lra. - -Open Scope R_scope. - -Set Mangle Names. - -Lemma div2mult05_0 : forall r, r / 2 = r * 0.5. -Proof. - intros r. - lra. -Qed. diff --git a/stdlib/test-suite/bugs/bug_17466_3.v b/stdlib/test-suite/bugs/bug_17466_3.v deleted file mode 100644 index 97d7a8cee03b..000000000000 --- a/stdlib/test-suite/bugs/bug_17466_3.v +++ /dev/null @@ -1,309 +0,0 @@ -From Stdlib Require String. -From Stdlib Require ZArith. - -Axiom proof_admitted : False. -Tactic Notation "admit" := abstract case proof_admitted. - -Class Monad(M: Type -> Type) := mkMonad { - Bind: forall {A B}, M A -> (A -> M B) -> M B; - Return: forall {A}, A -> M A; - - left_identity: forall {A B} (a: A) (f: A -> M B), - Bind (Return a) f = f a; - right_identity: forall {A} (m: M A), - Bind m Return = m; - associativity: forall {A B C} (m: M A) (f: A -> M B) (g: B -> M C), - Bind (Bind m f) g = Bind m (fun x => Bind (f x) g) -}. - -Definition StateAbortFail(S A: Type) := S -> (option (option A) * S). - -#[global] Instance StateAbortFail_Monad(S: Type): Monad (StateAbortFail S). -Admitted. -Local Set Universe Polymorphism. - Inductive list {A : Type} : Type := nil | cons (_:A) (_:list). - Arguments list : clear implicits. - - Section WithElement. - Context {A} (x : A). - Fixpoint repeat (x : A) (n : nat) {struct n} : list A := - match n with - | 0 => nil - | S k => cons x (repeat x k) - end. - End WithElement. - -Fixpoint hlist@{i j k} (argts : list@{j} Type@{i}) : Type@{k} := - match argts with - | nil => unit - | cons T argts' => T * hlist argts' - end. - -Definition tuple A n := hlist (repeat A n). - Notation byte := (Corelib.Init.Byte.byte: Type). -Import BinInt. -Local Open Scope Z_scope. - -Module Export word. - Class word {width : Z} := { - rep : Type; - - unsigned : rep -> Z; - signed : rep -> Z; - of_Z : Z -> rep; - - add : rep -> rep -> rep; - sub : rep -> rep -> rep; - opp : rep -> rep; - - or : rep -> rep -> rep; - and : rep -> rep -> rep; - xor : rep -> rep -> rep; - not : rep -> rep; - ndn : rep -> rep -> rep; - - mul : rep -> rep -> rep; - mulhss : rep -> rep -> rep; - mulhsu : rep -> rep -> rep; - mulhuu : rep -> rep -> rep; - - divu : rep -> rep -> rep; - divs : rep -> rep -> rep; - modu : rep -> rep -> rep; - mods : rep -> rep -> rep; - - slu : rep -> rep -> rep; - sru : rep -> rep -> rep; - srs : rep -> rep -> rep; - - eqb : rep -> rep -> bool; - ltu : rep -> rep -> bool; - lts : rep -> rep -> bool; - - gtu x y := ltu y x; - gts x y := lts y x; - - swrap z := (z + 2^(width-1)) mod 2^width - 2^(width-1); - - sextend: Z -> rep -> rep; - }. - Arguments word : clear implicits. - Global Hint Mode word + : typeclass_instances. - Local Hint Mode word - : typeclass_instances. - - Class ok {width} {word : word width}: Prop := { - wrap z := z mod 2^width; - - width_pos: 0 < width; - - unsigned_of_Z : forall z, unsigned (of_Z z) = wrap z; - signed_of_Z : forall z, signed (of_Z z) = swrap z; - of_Z_unsigned : forall x, of_Z (unsigned x) = x; - - unsigned_add : forall x y, unsigned (add x y) = wrap (Z.add (unsigned x) (unsigned y)); - unsigned_sub : forall x y, unsigned (sub x y) = wrap (Z.sub (unsigned x) (unsigned y)); - unsigned_opp : forall x, unsigned (opp x) = wrap (Z.opp (unsigned x)); - - unsigned_or : forall x y, unsigned (or x y) = wrap (Z.lor (unsigned x) (unsigned y)); - unsigned_and : forall x y, unsigned (and x y) = wrap (Z.land (unsigned x) (unsigned y)); - unsigned_xor : forall x y, unsigned (xor x y) = wrap (Z.lxor (unsigned x) (unsigned y)); - unsigned_not : forall x, unsigned (not x) = wrap (Z.lnot (unsigned x)); - unsigned_ndn : forall x y, unsigned (ndn x y) = wrap (Z.ldiff (unsigned x) (unsigned y)); - - unsigned_mul : forall x y, unsigned (mul x y) = wrap (Z.mul (unsigned x) (unsigned y)); - signed_mulhss : forall x y, signed (mulhss x y) = swrap (Z.mul (signed x) (signed y) / 2^width); - signed_mulhsu : forall x y, signed (mulhsu x y) = swrap (Z.mul (signed x) (unsigned y) / 2^width); - unsigned_mulhuu : forall x y, unsigned (mulhuu x y) = wrap (Z.mul (unsigned x) (unsigned y) / 2^width); - - unsigned_divu : forall x y, unsigned y <> 0 -> unsigned (divu x y) = wrap (Z.div (unsigned x) (unsigned y)); - signed_divs : forall x y, signed y <> 0 -> signed x <> -2^(width-1) \/ signed y <> -1 -> signed (divs x y) = swrap (Z.quot (signed x) (signed y)); - unsigned_modu : forall x y, unsigned y <> 0 -> unsigned (modu x y) = wrap (Z.modulo (unsigned x) (unsigned y)); - signed_mods : forall x y, signed y <> 0 -> signed (mods x y) = swrap (Z.rem (signed x) (signed y)); - - unsigned_slu : forall x y, Z.lt (unsigned y) width -> unsigned (slu x y) = wrap (Z.shiftl (unsigned x) (unsigned y)); - unsigned_sru : forall x y, Z.lt (unsigned y) width -> unsigned (sru x y) = wrap (Z.shiftr (unsigned x) (unsigned y)); - signed_srs : forall x y, Z.lt (unsigned y) width -> signed (srs x y) = swrap (Z.shiftr (signed x) (unsigned y)); - - unsigned_eqb : forall x y, eqb x y = Z.eqb (unsigned x) (unsigned y); - unsigned_ltu : forall x y, ltu x y = Z.ltb (unsigned x) (unsigned y); - signed_lts : forall x y, lts x y = Z.ltb (signed x) (signed y); - }. - Arguments ok {_} _. -End word. -Global Coercion word.rep : word >-> Sortclass. - -Class Bitwidth(width: Z): Prop := { - width_cases: width = 32%Z \/ width = 64%Z -}. - -Definition w8 := tuple byte 1. -Definition w16 := tuple byte 2. -Definition w32 := tuple byte 4. -Definition w64 := tuple byte 8. - -Class MachineWidth(t: Type) := { - - add: t -> t -> t; - sub: t -> t -> t; - mul: t -> t -> t; - div: t -> t -> t; - rem: t -> t -> t; - - negate: t -> t; - - reg_eqb: t -> t -> bool; - signed_less_than: t -> t -> bool; - ltu: t -> t -> bool; - - xor: t -> t -> t; - or: t -> t -> t; - and: t -> t -> t; - - XLEN: Z; - - regToInt8: t -> w8; - regToInt16: t -> w16; - regToInt32: t -> w32; - regToInt64: t -> w64; - - uInt8ToReg: w8 -> t; - uInt16ToReg: w16 -> t; - uInt32ToReg: w32 -> t; - uInt64ToReg: w64 -> t; - - int8ToReg: w8 -> t; - int16ToReg: w16 -> t; - int32ToReg: w32 -> t; - int64ToReg: w64 -> t; - - s32: t -> t; - u32: t -> t; - - regToZ_signed: t -> Z; - regToZ_unsigned: t -> Z; - - sll: t -> Z -> t; - srl: t -> Z -> t; - sra: t -> Z -> t; - - divu: t -> t -> t; - remu: t -> t -> t; - - maxSigned: t; - maxUnsigned: t; - minSigned: t; - - regToShamt5: t -> Z; - regToShamt: t -> Z; - - highBits: Z -> t; - - ZToReg: Z -> t; -}. - -#[global] Instance MachineWidth_XLEN{width}{_: Bitwidth width}{word: word width}: MachineWidth word. -Admitted. - -Notation Register := BinInt.Z (only parsing). - -Inductive InstructionSet : Type := - | RV32I : InstructionSet - | RV32IM : InstructionSet - | RV32IA : InstructionSet - | RV32IMA : InstructionSet - | RV32IF : InstructionSet - | RV32IMF : InstructionSet - | RV32IAF : InstructionSet - | RV32IMAF : InstructionSet - | RV64I : InstructionSet - | RV64IM : InstructionSet - | RV64IA : InstructionSet - | RV64IMA : InstructionSet - | RV64IF : InstructionSet - | RV64IMF : InstructionSet - | RV64IAF : InstructionSet - | RV64IMAF : InstructionSet. - -Module Export map. - Class map {key value} := mk { - rep : Type; - - get: rep -> key -> option value; - - empty : rep; - put : rep -> key -> value -> rep; - remove : rep -> key -> rep; - fold{R: Type}: (R -> key -> value -> R) -> R -> rep -> R; - }. - Arguments map : clear implicits. - - Global Coercion map.rep : map >-> Sortclass. -Import Stdlib.Strings.String. - -Section Machine. - - Context {width: Z} {word: word width} {word_ok: word.ok word}. - Context {Registers: map.map Register word}. - Context {Mem: map.map word byte}. - - Definition LogItem{_: Bitwidth width}: Type := (Mem * string * list word) * (Mem * list word). -Definition XAddrs: Type. -admit. -Defined. - - Section WithBitwidth. - Context {BW: Bitwidth width}. - - Record RiscvMachine := mkRiscvMachine { - getRegs: Registers; - getPc: word; - getNextPc: word; - getMem: Mem; - getXAddrs: XAddrs; - getLog: list LogItem; - }. - - End WithBitwidth. -End Machine. -Module Export Run. - -Section Riscv. - - Context {mword: Type}. - Context {MW: MachineWidth mword}. - - Context {M: Type -> Type}. - Context {MM: Monad M}. -Definition run1(iset: InstructionSet): - M unit. -Admitted. - -End Riscv. - -Module Export Naive. - -Definition word width: word.word width. -Admitted. -Notation word64 := (word 64%Z). - -End Naive. -#[global] Instance word: word.word 64. -Admitted. -#[global] Instance Words64Naive: Bitwidth 64. -Admitted. -#[global] Instance Mem: map.map word64 Byte.byte. -Admitted. -#[global] Instance Zkeyed_map(V: Type): map.map Z V. -Admitted. -Fixpoint run(fuel: nat)(s: RiscvMachine): bool * RiscvMachine. -exact (match fuel with - | O => (true, s) - | S fuel' => match Run.run1 RV64IM s with - | (Some _, s') => run fuel' s' - | (None, s') => (false, s') - end - end). -Defined. - -End Run. -End map. diff --git a/stdlib/test-suite/bugs/bug_17584.v b/stdlib/test-suite/bugs/bug_17584.v deleted file mode 100644 index 548f717f2ffe..000000000000 --- a/stdlib/test-suite/bugs/bug_17584.v +++ /dev/null @@ -1,6 +0,0 @@ -From Stdlib Require Import RIneq. - -Goal forall x y, (/(x * y) = 0)%R -> True. -Proof. intros x y H. -field_simplify in H. -Abort. diff --git a/stdlib/test-suite/bugs/bug_1779.v b/stdlib/test-suite/bugs/bug_1779.v deleted file mode 100644 index e7c85a449174..000000000000 --- a/stdlib/test-suite/bugs/bug_1779.v +++ /dev/null @@ -1,25 +0,0 @@ -From Stdlib Require Import PeanoNat. - -Lemma double_div2: forall n, Nat.div2 (Nat.double n) = n. -exact (fun n => let _subcase := - let _cofact := fun _ : 0 = 0 => refl_equal 0 in - _cofact (let _fact := refl_equal 0 in _fact) in - let _subcase0 := - fun (m : nat) (Hrec : Nat.div2 (Nat.double m) = m) => - let _fact := f_equal Nat.div2 (Nat.double_S m) in - let _eq := trans_eq _fact (refl_equal (S (Nat.div2 (Nat.double m)))) in - let _eq0 := - trans_eq _eq - (trans_eq - (f_equal (fun f : nat -> nat => f (Nat.div2 (Nat.double m))) - (refl_equal S)) (f_equal S Hrec)) in - _eq0 in - (fix _fix (__ : nat) : Nat.div2 (Nat.double __) = __ := - match __ as n return (Nat.div2 (Nat.double n) = n) with - | 0 => _subcase - | S __0 => - (fun _hrec : Nat.div2 (Nat.double __0) = __0 => _subcase0 __0 _hrec) - (_fix __0) - end) n). -Guarded. -Defined. diff --git a/stdlib/test-suite/bugs/bug_1784.v b/stdlib/test-suite/bugs/bug_1784.v deleted file mode 100644 index 9b12d0f45ea9..000000000000 --- a/stdlib/test-suite/bugs/bug_1784.v +++ /dev/null @@ -1,99 +0,0 @@ -From Stdlib Require Import List. -From Stdlib Require Import ZArith. -From Stdlib Require String. Open Scope string_scope. -Ltac Case s := let c := fresh "case" in set (c := s). - -Set Implicit Arguments. -Unset Strict Implicit. - -Inductive sv : Set := -| I : Z -> sv -| S : list sv -> sv. - -Section sv_induction. - -Variables - (VP: sv -> Prop) - (LP: list sv -> Prop) - - (VPint: forall n, VP (I n)) - (VPset: forall vs, LP vs -> VP (S vs)) - (lpcons: forall v vs, VP v -> LP vs -> LP (v::vs)) - (lpnil: LP nil). - -Fixpoint setl_value_indp (x:sv) {struct x}: VP x := - match x as x return VP x with - | I n => VPint n - | S vs => - VPset - ((fix values_indp (vs:list sv) {struct vs}: (LP vs) := - match vs as vs return LP vs with - | nil => lpnil - | v::vs => lpcons (setl_value_indp v) (values_indp vs) - end) vs) - end. -End sv_induction. - -Inductive slt : sv -> sv -> Prop := -| IC : forall z, slt (I z) (I z) -| IS : forall vs vs', slist_in vs vs' -> slt (S vs) (S vs') - -with sin : sv -> list sv -> Prop := -| Ihd : forall s s' sv', slt s s' -> sin s (s'::sv') -| Itl : forall s s' sv', sin s sv' -> sin s (s'::sv') - -with slist_in : list sv -> list sv -> Prop := -| Inil : forall sv', - slist_in nil sv' -| Icons : forall s sv sv', - sin s sv' -> - slist_in sv sv' -> - slist_in (s::sv) sv'. - -#[export] Hint Constructors sin slt slist_in. - -From Stdlib Require Import Program. - -Program Fixpoint lt_dec (x y:sv) { struct x } : {slt x y}+{~slt x y} := - match x with - | I x => - match y with - | I y => if (Z.eq_dec x y) then in_left else in_right - | S ys => in_right - end - | S xs => - match y with - | I y => in_right - | S ys => - let fix list_in (xs ys:list sv) {struct xs} : - {slist_in xs ys} + {~slist_in xs ys} := - match xs with - | nil => in_left - | x::xs => - let fix elem_in (ys:list sv) : {sin x ys}+{~sin x ys} := - match ys with - | nil => in_right - | y::ys => if lt_dec x y then in_left else if elem_in - ys then in_left else in_right - end - in - if elem_in ys then - if list_in xs ys then in_left else in_right - else in_right - end - in if list_in xs ys then in_left else in_right - end - end. - -Next Obligation. intro H0. apply n; inversion H0; subst; trivial. Defined. -Next Obligation. intro H; inversion H. Defined. -Next Obligation. intro H; inversion H. Defined. -Next Obligation. intro H; inversion H; subst. Defined. -Next Obligation. - intro H1; contradict n. inversion H1; subst. assumption. - contradict n0; assumption. Defined. -Next Obligation. intro H1; contradict n. inversion H1; subst. assumption. Defined. -Next Obligation. - intro H1; contradict n. inversion H1; subst. assumption. Defined. -Next Obligation. - intro H0; contradict n. inversion H0; subst; auto. Defined. diff --git a/stdlib/test-suite/bugs/bug_17936.v b/stdlib/test-suite/bugs/bug_17936.v deleted file mode 100644 index 603884e7480d..000000000000 --- a/stdlib/test-suite/bugs/bug_17936.v +++ /dev/null @@ -1,51 +0,0 @@ -From Stdlib Require Import Lia ZArith Zify PreOmega. -Open Scope Z_scope. - -Goal forall m n, n * m = 1 -> n = 1 \/ n = -1. - pose proof Z.mul_eq_1; intros. - Z.to_euclidean_division_equations. - Fail assumption. (* was previously succeeding *) - let T := type of Z.mul_eq_1 in - lazymatch goal with - | [ H : T |- _ ] => idtac - | _ => fail 0 "Z.to_euclidean_division_equations should not mangle dependent quantifiers" - end. -Abort. -(* swapped n m order *) -Goal forall n m, n * m = 1 -> n = 1 \/ n = -1. - pose proof Z.mul_eq_1; intros. - Z.to_euclidean_division_equations. - Fail assumption. (* correctly does not succeed *) - let T := type of Z.mul_eq_1 in - lazymatch goal with - | [ H : T |- _ ] => idtac - | _ => fail 0 "Z.to_euclidean_division_equations should not mangle dependent quantifiers" - end. -Abort. - -(* Test that the commit message suggestion in fact works to restore behavior *) -Ltac saturate := - let unique_pose_proof lem := - let ty := type of lem in - lazymatch goal with - | [ H : ty |- _ ] => fail - | _ => pose proof lem - end in - repeat match goal with - | [ H : forall x : ?T, _, H' : ?T |- _ ] => unique_pose_proof (H H') - | [ H : forall a (x : ?T), _, H' : ?T |- _ ] => unique_pose_proof (fun a => H a H') - end. -Ltac Zify.zify_internal_to_euclidean_division_equations ::= Z.to_euclidean_division_equations; saturate. -Ltac Zify.zify_post_hook ::= Z.to_euclidean_division_equations; saturate. -Goal forall m n, n * m = 1 -> n = 1 \/ n = -1. - pose proof Z.mul_eq_1; intros. - zify. - assumption. -Qed. - -(* swapped n m order *) -Goal forall n m, n * m = 1 -> n = 1 \/ n = -1. - pose proof Z.mul_eq_1; intros. - zify. - assumption. -Qed. diff --git a/stdlib/test-suite/bugs/bug_17960.v b/stdlib/test-suite/bugs/bug_17960.v deleted file mode 100644 index 765c8161b9c2..000000000000 --- a/stdlib/test-suite/bugs/bug_17960.v +++ /dev/null @@ -1,67 +0,0 @@ -From Stdlib Require Import ZArith. -From Stdlib Require Import Lia. - -Open Scope Z_scope. - -Parameter Znth : Z -> list Z -> Z. -Parameter Zlength : list Z -> Z. -Parameter max_unsigned : Z. - -Goal forall j r N M row_ptr, - Zlength row_ptr = N + 1 -> - 0 <= r -> - r <= Znth 0 row_ptr -> - Znth (N + 1 - 1) row_ptr <= max_unsigned -> - 0 <= j < N -> - 0 <= M -> - 0 <= N + 1 -> - 0 <= j + 1 < N + 1 -> - 0 <= j + 1 < N + 1 -> - j + 1 <= j + 1 + 0 -> - Znth (j + 1) row_ptr <= Znth (j + 1) row_ptr -> - 0 <= j + 1 < N + 1 -> - 0 <= j < N + 1 -> - j + 0 < j + 1 -> - 0 <= j + 1 < N + 1 -> - 0 <= N < N + 1 -> - j + 1 <= N + 0 -> Znth (j + 1) row_ptr <= M -> 0 <= j + 1 < N + 1 -> - 0 <= 0 < N + 1 -> - 0 + 0 < j + 1 -> - 0 <= j + 1 < N + 1 -> - 0 <= N + 1 - 1 < N + 1 -> - j + 1 <= N + 1 - 1 + 0 -> - Znth (j + 1) row_ptr <= Znth (N + 1 - 1) row_ptr -> - 0 <= j < N + 1 -> - 0 <= j < N + 1 -> - j <= j + 0 -> - Znth j row_ptr <= Znth j row_ptr -> - 0 <= j < N + 1 -> - 0 <= N < N + 1 -> - j <= N + 0 -> - Znth j row_ptr <= M -> - 0 <= j < N + 1 -> - 0 <= 0 < N + 1 -> - j <= 0 + 0 -> - Znth j row_ptr <= Znth 0 row_ptr -> 0 <= j < N + 1 -> 0 <= N + 1 - 1 < N + 1 -> - j <= N + 1 - 1 + 0 -> - Znth j row_ptr <= Znth (N + 1 - 1) row_ptr -> - 0 <= j < N + 1 -> - 0 <= j + 1 < N + 1 -> - j <= j + 1 + 0 -> - Znth j row_ptr <= Znth (j + 1) row_ptr -> - 0 <= N < N + 1 -> - 0 <= N < N + 1 -> - N <= N + 0 -> - M <= M -> - 0 <= N < N + 1 -> - 0 <= 0 < N + 1 -> - 0 + 0 < N -> - 0 <= N < N + 1 -> - 0 <= N + 1 - 1 < N + 1 -> - N <= N + 1 - 1 + 0 -> - M <= Znth (N + 1 - 1) row_ptr -> - 0 <= N < N + 1 -> 0 <= j + 1 < N + 1 -> j + 1 + 0 < N -> - False. -Proof. - Timeout 1 Fail lia. (* lia crashes. *) -Abort. diff --git a/stdlib/test-suite/bugs/bug_17983.v b/stdlib/test-suite/bugs/bug_17983.v deleted file mode 100644 index 2c94aaffa734..000000000000 --- a/stdlib/test-suite/bugs/bug_17983.v +++ /dev/null @@ -1,11 +0,0 @@ -From Stdlib Require Import Zify ZifyUint63 ZifySint63 Sint63 Uint63 ZArith Lia. - -Lemma boom : False. -Proof. - assert (sint_bad : forall y z : int, Sint63Axioms.to_Z (y / z) = Uint63Axioms.to_Z (y / z)). - { zify. Fail reflexivity. - (*} - specialize (sint_bad (-1)%sint63 1%uint63). - vm_compute in sint_bad. (* sint_bad : (-1)%Z = 9223372036854775807%Z *) - congruence. *) -Abort. diff --git a/stdlib/test-suite/bugs/bug_18151.v b/stdlib/test-suite/bugs/bug_18151.v deleted file mode 100644 index 1a92ddc2e0c8..000000000000 --- a/stdlib/test-suite/bugs/bug_18151.v +++ /dev/null @@ -1,43 +0,0 @@ -From Stdlib Require Import BinInt. -From Stdlib Require Import Zify ZifyClasses. -Import Z. -Open Scope Z_scope. - -#[global] Instance sat_mod_le : ZifyClasses.Saturate BinIntDef.Z.modulo := - {| - ZifyClasses.PArg1 := fun a => 0 <= a; - ZifyClasses.PArg2 := fun b => 0 < b; - ZifyClasses.PRes := fun a b ab => ab <= a; - ZifyClasses.SatOk := mod_le - |}. -Add Zify Saturate sat_mod_le. - -Lemma shiftr_lbound a n: - 0 <= a -> True -> 0 <= (Z.shiftr a n). -Proof. now intros; apply Z.shiftr_nonneg. Qed. - -#[global] Instance sat_shiftr_lbound : ZifyClasses.Saturate BinIntDef.Z.shiftr := - {| - ZifyClasses.PArg1 := fun a => 0 <= a; - ZifyClasses.PArg2 := fun b => True; - ZifyClasses.PRes := fun a b ab => 0 <= ab; - ZifyClasses.SatOk := shiftr_lbound - |}. -Add Zify Saturate sat_shiftr_lbound. - -Axiom TODO: forall {P}, P. - -Goal forall x4 x5 t0 : N, - 0 <= of_N x4 <= 18446744073709551615 -> - land - (shiftr (of_N x4) (of_N t0) mod 2 ^ of_N (Npos 64)) - (shiftl 1 (of_N x5) - 1) = - land (shiftr (of_N x4) (of_N t0)) - (shiftl 1 (of_N x5) - 1). -Proof. - intros. - zify. - apply TODO. -Qed. -(* Qed used to fail with the following error before #18152. -Error: No such section variable or assumption: __sat6. *) diff --git a/stdlib/test-suite/bugs/bug_18260_1.v b/stdlib/test-suite/bugs/bug_18260_1.v deleted file mode 100644 index 4a7d7300c460..000000000000 --- a/stdlib/test-suite/bugs/bug_18260_1.v +++ /dev/null @@ -1,108 +0,0 @@ -From Stdlib.Init Require Byte. -From Stdlib.Strings Require Byte. -From Stdlib Require ZArith. - -Axiom proof_admitted : False. -Tactic Notation "admit" := abstract case proof_admitted. - -Import Byte. - -Module Export word. - Class word {width : BinInt.Z} := { - rep : Type; - }. - Arguments word : clear implicits. - -End word. -Notation word := word.word. -Global Coercion word.rep : word >-> Sortclass. - - - -Module map. - Class map {key value:Type} := mk { - rep : Type; - }. - Arguments map : clear implicits. - Global Coercion rep : map >-> Sortclass. - -End map. -Local Notation map := map.map. -Global Coercion map.rep : map >-> Sortclass. - -Definition SuchThat(R: Type)(P: R -> Prop) := R. -Existing Class SuchThat. - -Notation "'annotate!' x T" := (match x return T with b => b end) - (at level 10, x at level 0, T at level 0, only parsing). - -Notation "'infer!' P" := - (match _ as ResType return ResType with - | ResType => - match P with - | Fun => annotate! (annotate! _ (SuchThat ResType Fun)) ResType - end - end) - (at level 0, P at level 100, only parsing). - -Global Hint Extern 1 (SuchThat ?RRef ?FRef) => - let R := eval cbv delta [RRef] in RRef in - let r := open_constr:(_ : R) in - let G := eval cbv beta delta [RRef FRef] in (FRef r) in - let t := open_constr:(ltac:(cbv beta; typeclasses eauto) : G) in - match r with - | ?y => exact y - end - : typeclass_instances. - -Class Multiplication{A B R: Type}(a: A)(b: B)(r: R) := {}. -Notation "a * b" := (infer! Multiplication a b) (only parsing) : oo_scope. - - -Import map. - -Section Sep. - Context {map : Type}. - Definition sep (p q : map -> Prop) (m:map) : Prop. Admitted. - -End Sep. - -Import ZArith. - -Section Scalars. - Context {width : Z} {word : word width}. - - Context {mem : map.map word byte}. - Definition scalar : word -> word -> mem -> Prop. Admitted. - -End Scalars. - -#[export] Instance MulSepClause{K V: Type}{M: map.map K V}(a b: @map.rep K V M -> Prop) - : Multiplication a b (sep a b) | 10 := {}. - - -Class PointsTo{width: Z}{word: word.word width}{mem: map.map word Byte.byte}{V: Type} - (addr: word)(val: V)(pred: mem -> Prop) := {}. -Global Hint Mode PointsTo + + + + + + - : typeclass_instances. - -Class PointsToPredicate{width}{word: word.word width}{mem: Type} - (V: Type)(pred: word -> V -> mem -> Prop) := {}. - -#[export] Instance PointsToPredicate_to_PointsTo - {width}{word: word.word width}{mem: map.map word Byte.byte}{V: Type} - (pred: word -> V -> mem -> Prop){p: PointsToPredicate V pred} - (a: word)(v: V): PointsTo a v (pred a v) := {}. - -#[export] Instance PointsToScalarPredicate - {width}{word: word.word width}{mem: map.map word Byte.byte}: - PointsToPredicate word scalar := {}. - -Section TestNotations. - Context {width: Z} {word: word.word width} {mem: map.map word Byte.byte}. - Local Open Scope oo_scope. - Set Printing All. - Typeclasses eauto := debug. - Goal forall (a1 a2 ofs sz v1 v2: word) (R: mem -> Prop) (m: mem), - (infer! Multiplication R (infer! PointsTo a1 v1)) m. - Abort. -End TestNotations. diff --git a/stdlib/test-suite/bugs/bug_1844.v b/stdlib/test-suite/bugs/bug_1844.v deleted file mode 100644 index 1363d9528d6f..000000000000 --- a/stdlib/test-suite/bugs/bug_1844.v +++ /dev/null @@ -1,217 +0,0 @@ -From Stdlib Require Import ZArith. - -Definition zeq := Z.eq_dec. - -Definition update (A: Set) (x: Z) (v: A) (s: Z -> A) : Z -> A := - fun y => if zeq x y then v else s y. - -Arguments update [A]. - -Definition ident := Z. -Parameter operator: Set. -Parameter value: Set. -Parameter is_true: value -> Prop. -Definition label := Z. - -Inductive expr : Set := - | Evar: ident -> expr - | Econst: value -> expr - | Eop: operator -> expr -> expr -> expr. - -Inductive stmt : Set := - | Sskip: stmt - | Sassign: ident -> expr -> stmt - | Scall: ident -> ident -> expr -> stmt (* x := f(e) *) - | Sreturn: expr -> stmt - | Sseq: stmt -> stmt -> stmt - | Sifthenelse: expr -> stmt -> stmt -> stmt - | Sloop: stmt -> stmt - | Sblock: stmt -> stmt - | Sexit: nat -> stmt - | Slabel: label -> stmt -> stmt - | Sgoto: label -> stmt. - -Record function : Set := mkfunction { - fn_param: ident; - fn_body: stmt -}. - -Parameter program: ident -> option function. - -Parameter main_function: ident. - -Definition store := ident -> value. - -Parameter empty_store : store. - -Parameter eval_op: operator -> value -> value -> option value. - -Fixpoint eval_expr (st: store) (e: expr) {struct e} : option value := - match e with - | Evar v => Some (st v) - | Econst v => Some v - | Eop op e1 e2 => - match eval_expr st e1, eval_expr st e2 with - | Some v1, Some v2 => eval_op op v1 v2 - | _, _ => None - end - end. - -Inductive outcome: Set := - | Onormal: outcome - | Oexit: nat -> outcome - | Ogoto: label -> outcome - | Oreturn: value -> outcome. - -Definition outcome_block (out: outcome) : outcome := - match out with - | Onormal => Onormal - | Oexit O => Onormal - | Oexit (S m) => Oexit m - | Ogoto lbl => Ogoto lbl - | Oreturn v => Oreturn v - end. - -Fixpoint label_defined (lbl: label) (s: stmt) {struct s}: Prop := - match s with - | Sskip => False - | Sassign id e => False - | Scall id fn e => False - | Sreturn e => False - | Sseq s1 s2 => label_defined lbl s1 \/ label_defined lbl s2 - | Sifthenelse e s1 s2 => label_defined lbl s1 \/ label_defined lbl s2 - | Sloop s1 => label_defined lbl s1 - | Sblock s1 => label_defined lbl s1 - | Sexit n => False - | Slabel lbl1 s1 => lbl1 = lbl \/ label_defined lbl s1 - | Sgoto lbl => False - end. - -Inductive exec : stmt -> store -> outcome -> store -> Prop := - | exec_skip: forall st, - exec Sskip st Onormal st - | exec_assign: forall id e st v, - eval_expr st e = Some v -> - exec (Sassign id e) st Onormal (update id v st) - | exec_call: forall id fn e st v1 f v2 st', - eval_expr st e = Some v1 -> - program fn = Some f -> - exec_function f (update f.(fn_param) v1 empty_store) v2 st' -> - exec (Scall id fn e) st Onormal (update id v2 st) - | exec_return: forall e st v, - eval_expr st e = Some v -> - exec (Sreturn e) st (Oreturn v) st - | exec_seq_2: forall s1 s2 st st1 out' st', - exec s1 st Onormal st1 -> exec s2 st1 out' st' -> - exec (Sseq s1 s2) st out' st' - | exec_seq_1: forall s1 s2 st out st', - exec s1 st out st' -> out <> Onormal -> - exec (Sseq s1 s2) st out st' - | exec_ifthenelse_true: forall e s1 s2 st out st' v, - eval_expr st e = Some v -> is_true v -> exec s1 st out st' -> - exec (Sifthenelse e s1 s2) st out st' - | exec_ifthenelse_false: forall e s1 s2 st out st' v, - eval_expr st e = Some v -> ~is_true v -> exec s2 st out st' -> - exec (Sifthenelse e s1 s2) st out st' - | exec_loop_loop: forall s st st1 out' st', - exec s st Onormal st1 -> - exec (Sloop s) st1 out' st' -> - exec (Sloop s) st out' st' - | exec_loop_stop: forall s st st' out, - exec s st out st' -> out <> Onormal -> - exec (Sloop s) st out st' - | exec_block: forall s st out st', - exec s st out st' -> - exec (Sblock s) st (outcome_block out) st' - | exec_exit: forall n st, - exec (Sexit n) st (Oexit n) st - | exec_label: forall s lbl st st' out, - exec s st out st' -> - exec (Slabel lbl s) st out st' - | exec_goto: forall st lbl, - exec (Sgoto lbl) st (Ogoto lbl) st - -(** [execg lbl stmt st out st'] starts executing at label [lbl] within [s], - in initial store [st]. The result of the execution is the outcome - [out] with final store [st']. *) - -with execg: label -> stmt -> store -> outcome -> store -> Prop := - | execg_left_seq_2: forall lbl s1 s2 st st1 out' st', - execg lbl s1 st Onormal st1 -> exec s2 st1 out' st' -> - execg lbl (Sseq s1 s2) st out' st' - | execg_left_seq_1: forall lbl s1 s2 st out st', - execg lbl s1 st out st' -> out <> Onormal -> - execg lbl (Sseq s1 s2) st out st' - | execg_right_seq: forall lbl s1 s2 st out st', - ~(label_defined lbl s1) -> - execg lbl s2 st out st' -> - execg lbl (Sseq s1 s2) st out st' - | execg_ifthenelse_left: forall lbl e s1 s2 st out st', - execg lbl s1 st out st' -> - execg lbl (Sifthenelse e s1 s2) st out st' - | execg_ifthenelse_right: forall lbl e s1 s2 st out st', - ~(label_defined lbl s1) -> - execg lbl s2 st out st' -> - execg lbl (Sifthenelse e s1 s2) st out st' - | execg_loop_loop: forall lbl s st st1 out' st', - execg lbl s st Onormal st1 -> - exec (Sloop s) st1 out' st' -> - execg lbl (Sloop s) st out' st' - | execg_loop_stop: forall lbl s st st' out, - execg lbl s st out st' -> out <> Onormal -> - execg lbl (Sloop s) st out st' - | execg_block: forall lbl s st out st', - execg lbl s st out st' -> - execg lbl (Sblock s) st (outcome_block out) st' - | execg_label_found: forall lbl s st st' out, - exec s st out st' -> - execg lbl (Slabel lbl s) st out st' - | execg_label_notfound: forall lbl s lbl' st st' out, - lbl' <> lbl -> - execg lbl s st out st' -> - execg lbl (Slabel lbl' s) st out st' - -(** [exec_finish out st st'] takes the outcome [out] and the store [st] - at the end of the evaluation of the program. If [out] is a [goto], - execute again the program starting at the corresponding label. - Iterate this way until [out] is [Onormal]. *) - -with exec_finish: function -> outcome -> store -> value -> store -> Prop := - | exec_finish_normal: forall f st v, - exec_finish f (Oreturn v) st v st - | exec_finish_goto: forall f lbl st out v st1 st', - execg lbl f.(fn_body) st out st1 -> - exec_finish f out st1 v st' -> - exec_finish f (Ogoto lbl) st v st' - -(** Execution of a function *) - -with exec_function: function -> store -> value -> store -> Prop := - | exec_function_intro: forall f st out st1 v st', - exec f.(fn_body) st out st1 -> - exec_finish f out st1 v st' -> - exec_function f st v st'. - -Scheme exec_ind4:= Minimality for exec Sort Prop - with execg_ind4:= Minimality for execg Sort Prop - with exec_finish_ind4 := Minimality for exec_finish Sort Prop - with exec_function_ind4 := Minimality for exec_function Sort Prop. - -Scheme exec_dind4:= Induction for exec Sort Prop - with execg_dind4:= Minimality for execg Sort Prop - with exec_finish_dind4 := Induction for exec_finish Sort Prop - with exec_function_dind4 := Induction for exec_function Sort Prop. - -Combined Scheme exec_inductiond from exec_dind4, execg_dind4, exec_finish_dind4, - exec_function_dind4. - -Scheme exec_dind4' := Induction for exec Sort Prop - with execg_dind4' := Induction for execg Sort Prop - with exec_finish_dind4' := Induction for exec_finish Sort Prop - with exec_function_dind4' := Induction for exec_function Sort Prop. - -Combined Scheme exec_induction from exec_ind4, execg_ind4, exec_finish_ind4, - exec_function_ind4. - -Combined Scheme exec_inductiond' from exec_dind4', execg_dind4', exec_finish_dind4', - exec_function_dind4'. diff --git a/stdlib/test-suite/bugs/bug_1859.v b/stdlib/test-suite/bugs/bug_1859.v deleted file mode 100644 index b9d0ddb0c5f4..000000000000 --- a/stdlib/test-suite/bugs/bug_1859.v +++ /dev/null @@ -1,20 +0,0 @@ -From Stdlib Require Import Ring. -From Stdlib Require Import ArithRing. - -Ltac ring_simplify_neq := - match goal with - | [ H: ?X <> ?Y |- _ ] => progress ring_simplify X Y in H - end. - -Lemma toto : forall x y, x*1 <> y*1 -> y*1 <> x*1 -> x<>y. -Proof. - intros. - ring_simplify_neq. - ring_simplify_neq. - (* make sure ring_simplify has simplified both hypotheses *) - match goal with - | [ H: context[_*1] |- _ ] => fail 1 - | _ => idtac - end. - auto. -Qed. diff --git a/stdlib/test-suite/bugs/bug_18680.v b/stdlib/test-suite/bugs/bug_18680.v deleted file mode 100644 index 23caac2b272c..000000000000 --- a/stdlib/test-suite/bugs/bug_18680.v +++ /dev/null @@ -1,63 +0,0 @@ -Set Universe Polymorphism. - -From Stdlib Require Import PeanoNat. -From Stdlib Require Import JMeq. - -Inductive narray {X : Type} : nat -> Type := - | Elt : X -> narray 0 - | Cons {c : nat} (x : X) (n : narray c) : narray (c + 1). - -Lemma eqb_eq : forall x, Nat.eqb x x = true. -Proof. - intros. - induction x. - - reflexivity. - - simpl. apply IHx. -Qed. - -Lemma sub_still_le : forall x y, - Nat.eqb x y = false -> x <= y -> x + 1 <= y. -Proof. - intros x y NatEq xLey. - induction xLey. - - rewrite eqb_eq in NatEq. discriminate NatEq. - - replace (x + 1) with (S x). - * apply le_n_S. apply xLey. - * rewrite Nat.add_comm. simpl. reflexivity. -Qed. - -(* Returns the nth element of the array; this version works. *) -Program Fixpoint get - {X : Type} {sz : nat} - (get_n : nat) (cpt : nat) (l : narray sz) : X := - match l with - | Elt x => x - | Cons x tl => - match Nat.eqb get_n cpt with - | true => x - | false => - get get_n (cpt + 1) tl - end - end. - -(* Same than get, but carries additional proofs. *) -Succeed Program Fixpoint get' - {X : Type} {sz : nat} - (get_n : nat) - (Inv : get_n < sz) - (cpt : nat) - (P : cpt <= get_n) - (l : narray sz) : X := - match l with - | Elt x => x - | Cons x tl => - match Nat.eqb get_n cpt with - | true => x - | false => - let CondFalse: Nat.eqb get_n cpt = false := _ in - let P' : cpt + 1 <= get_n := - sub_still_le cpt get_n CondFalse P - in - get' get_n Inv (cpt + 1) P' tl - end - end. diff --git a/stdlib/test-suite/bugs/bug_18850.v b/stdlib/test-suite/bugs/bug_18850.v deleted file mode 100644 index 4c654b90f394..000000000000 --- a/stdlib/test-suite/bugs/bug_18850.v +++ /dev/null @@ -1,15 +0,0 @@ -From Stdlib Require Import - Fin - SetoidClass. (* comment out for different error message *) - -Notation fin := t. - -Succeed Program Definition next_fin {n}: fin (S n) -> fin (S n) := - fix loop (f : fin (S n)) : fin (S n) := - match f with - | F1 => F1 - | FS f' => match f' with - | F1 => F1 - | FS _ => FS (loop f') - end - end. diff --git a/stdlib/test-suite/bugs/bug_18920.v b/stdlib/test-suite/bugs/bug_18920.v deleted file mode 100644 index 96724b5bc474..000000000000 --- a/stdlib/test-suite/bugs/bug_18920.v +++ /dev/null @@ -1,8 +0,0 @@ -(* Check that obligations resulting from evars in the binders are - correctly substituted for wf/measure fixpoints *) -From Stdlib Require Import Program. -Program Fixpoint f (A : nat * _) (n:nat) {measure n} : nat := - match n with 0 => 0 | S n => f A n end. -Next Obligation. exact nat. Defined. -Next Obligation. Admitted. -(* used to return an Anomaly "in econstr: grounding a non evar-free term" *) diff --git a/stdlib/test-suite/bugs/bug_1912.v b/stdlib/test-suite/bugs/bug_1912.v deleted file mode 100644 index 434df18f5b61..000000000000 --- a/stdlib/test-suite/bugs/bug_1912.v +++ /dev/null @@ -1,6 +0,0 @@ -From Stdlib Require Import Lia ZArith. - -Goal forall x, Z.succ (Z.pred x) = x. -intros x. -lia. -Qed. diff --git a/stdlib/test-suite/bugs/bug_1935.v b/stdlib/test-suite/bugs/bug_1935.v deleted file mode 100644 index e43ac99e4c79..000000000000 --- a/stdlib/test-suite/bugs/bug_1935.v +++ /dev/null @@ -1,21 +0,0 @@ -Definition f (n:nat) := n = n. - -Lemma f_refl : forall n , f n. -intros. reflexivity. -Qed. - -Definition f' (x:nat) (n:nat) := n = n. - -Lemma f_refl' : forall n , f' n n. -Proof. - intros. reflexivity. -Qed. - -From Stdlib Require Import ZArith. - -Definition f'' (a:bool) := if a then eq (A:= Z) else Z.lt. - -Lemma f_refl'' : forall n , f'' true n n. -Proof. - intro. reflexivity. -Qed. diff --git a/stdlib/test-suite/bugs/bug_1956.v b/stdlib/test-suite/bugs/bug_1956.v deleted file mode 100644 index 1484aa6efc72..000000000000 --- a/stdlib/test-suite/bugs/bug_1956.v +++ /dev/null @@ -1,15 +0,0 @@ -From Stdlib Require Import Program. - -Inductive exp_raw : nat -> Set := -| exp_raw_bvar : forall n i, i < n -> exp_raw n -| exp_raw_fvar : forall n, nat -> exp_raw n -| exp_raw_abs : forall n, exp_raw (S n) -> exp_raw n -| exp_raw_app : forall n, exp_raw n -> exp_raw n -> exp_raw n. - -(* The following definition is not accepted. *) - -Program Definition is_abs (n : nat) (e : exp_raw n) : bool := - match e with - | exp_raw_abs _ _ => true - | _ => false - end. diff --git a/stdlib/test-suite/bugs/bug_1962.v b/stdlib/test-suite/bugs/bug_1962.v deleted file mode 100644 index 7eca60d97d81..000000000000 --- a/stdlib/test-suite/bugs/bug_1962.v +++ /dev/null @@ -1,55 +0,0 @@ -(* Bug 1962.v - -Bonjour, - -J'ai un exemple de lemme que j'arrivais Ć  prouver avec fsetdec avec la 8.2beta3 -avec la beta4 et la version svn 11447 branche 8.2 ƧƠ diverge. - -Voici l'exemple en question, l'exmple test2 marche bien dans les deux version, -test en revanche pose probleme: - -*) - -From Stdlib Require Export FSets. - -(** This module takes a decidable type and -build finite sets of this type, tactics and defs *) - -Module BuildFSets (DecPoints: UsualDecidableType). - -Module Export FiniteSetsOfPoints := FSetWeakList.Make DecPoints. -Module Export FiniteSetsOfPointsProperties := - WProperties FiniteSetsOfPoints. -Module Export Dec := WDecide FiniteSetsOfPoints. -Module Export FM := Dec.F. - -Definition set_of_points := t. -Definition Point := DecPoints.t. - -Definition couple(x y :Point) : set_of_points := -add x (add y empty). - -Definition triple(x y t :Point): set_of_points := -add x (add y (add t empty)). - -Lemma test : forall P A B C A' B' C', -Equal -(union (singleton P) (union (triple A B C) (triple A' B' C'))) -(union (triple P B B') (union (couple P A) (triple C A' C'))). -Proof. -intros. -unfold triple, couple. -Time fsetdec. (* works in 8.2 beta 3, not in beta 4 and final 8.2 *) - (* appears to works again in 8.3 and trunk, take 4-6 seconds *) -Qed. - -Lemma test2 : forall A B C, -Equal - (union (singleton C) (couple A B)) (triple A B C). -Proof. -intros. -unfold triple, couple. -Time fsetdec. -Qed. - -End BuildFSets. diff --git a/stdlib/test-suite/bugs/bug_1963.v b/stdlib/test-suite/bugs/bug_1963.v deleted file mode 100644 index 256784b57f53..000000000000 --- a/stdlib/test-suite/bugs/bug_1963.v +++ /dev/null @@ -1,20 +0,0 @@ -(* Check that "dependent inversion" behaves correctly w.r.t to universes *) - -From Stdlib Require Import Eqdep. - -Set Implicit Arguments. - -Inductive illist(A:Type) : nat -> Type := - illistn : illist A 0 -| illistc : forall n:nat, A -> illist A n -> illist A (S n). - -Inductive isig (A:Type)(P:A -> Type) : Type := - iexists : forall x : A, P x -> isig P. - -Lemma inv : forall (A:Type)(n n':nat)(ts':illist A n'), n' = S n -> - isig (fun t => isig (fun ts => - eq_dep nat (fun n => illist A n) n' ts' (S n) (illistc t ts))). -Proof. -intros. -dependent inversion ts'. -Abort. diff --git a/stdlib/test-suite/bugs/bug_2016.v b/stdlib/test-suite/bugs/bug_2016.v deleted file mode 100644 index 30b8cc23b9c9..000000000000 --- a/stdlib/test-suite/bugs/bug_2016.v +++ /dev/null @@ -1,65 +0,0 @@ -(* Coq 8.2beta4 *) -From Stdlib Require Import Classical_Prop. - -Unset Structural Injection. - -Record coreSemantics : Type := CoreSemantics { - core: Type; - corestep: core -> core -> Prop; - corestep_fun: forall q q1 q2, corestep q q1 -> corestep q q2 -> q1 = q2 -}. - -Definition state : Type := {sem: coreSemantics & sem.(core)}. - -Inductive step: state -> state -> Prop := - | step_core: forall sem st st' - (Hcs: sem.(corestep) st st'), - step (existT _ sem st) (existT _ sem st'). - -Lemma step_fun: forall st1 st2 st2', step st1 st2 -> step st1 st2' -> st2 = st2'. -Proof. -intros. -inversion H; clear H; subst. inversion H0; clear H0; subst; auto. -generalize (inj_pairT2 _ _ _ _ _ H2); clear H2; intro; subst. -rewrite (corestep_fun _ _ _ _ Hcs Hcs0); auto. -Qed. - -Record oe_core := oe_Core { - in_core: Type; - in_corestep: in_core -> in_core -> Prop; - in_corestep_fun: forall q q1 q2, in_corestep q q1 -> in_corestep q q2 -> q1 = q2; - in_q: in_core -}. - -Definition oe2coreSem (oec : oe_core) : coreSemantics := - CoreSemantics oec.(in_core) oec.(in_corestep) oec.(in_corestep_fun). - -Definition oe_corestep (q q': oe_core) := - step (existT _ (oe2coreSem q) q.(in_q)) (existT _ (oe2coreSem q') q'.(in_q)). - -Lemma inj_pairT1: forall (U: Type) (P: U -> Type) (p1 p2: U) x y, - existT P p1 x = existT P p2 y -> p1=p2. -Proof. intros; injection H; auto. -Qed. - -Definition f := CoreSemantics oe_core. - -Lemma oe_corestep_fun: forall q q1 q2, - oe_corestep q q1 -> oe_corestep q q2 -> q1 = q2. -Proof. -unfold oe_corestep; intros. -assert (HH:= step_fun _ _ _ H H0); clear H H0. -destruct q1; destruct q2; unfold oe2coreSem; simpl in *. -generalize (inj_pairT1 _ _ _ _ _ _ HH); clear HH; intros. -injection H. -revert in_q1 in_corestep1 in_corestep_fun1 - H. -pattern in_core1. -apply eq_ind_r with (x := in_core0). -admit. -apply sym_eq. -(** good to here **) -Show Universes. -Print Universes. -Fail apply H0. -Abort. diff --git a/stdlib/test-suite/bugs/bug_2083.v b/stdlib/test-suite/bugs/bug_2083.v deleted file mode 100644 index e625ef28eccc..000000000000 --- a/stdlib/test-suite/bugs/bug_2083.v +++ /dev/null @@ -1,27 +0,0 @@ -From Stdlib Require Import Program Arith. - -Program Fixpoint check_n (n : nat) (P : { i | i < n } -> bool) (p : nat) - (H : forall (i : { i | i < n }), i < p -> P i = true) - {measure (n - p)} : - Exc (forall (p : { i | i < n}), P p = true) := - match le_lt_dec n p with - | left _ => value _ - | right cmp => - if dec (P p) then - check_n n P (S p) _ - else - error - end. - -From Stdlib Require Import Lia. - -Solve Obligations with program_simpl ; auto with *; lia. - -Next Obligation. - apply H. simpl. lia. -Defined. - -Next Obligation. - case (le_lt_dec p i) ; intros. assert(i = p) by lia. subst. - revert e. clear_subset_proofs. auto. - apply H. simpl. assumption. Defined. diff --git a/stdlib/test-suite/bugs/bug_2136.v b/stdlib/test-suite/bugs/bug_2136.v deleted file mode 100644 index 2e97fea9779a..000000000000 --- a/stdlib/test-suite/bugs/bug_2136.v +++ /dev/null @@ -1,61 +0,0 @@ -(* Bug #2136 - -The fsetdec tactic seems to get confused by hypotheses like - HeqH1 : H1 = MkEquality s0 s1 b -If I clear them then it is able to solve my goal; otherwise it is not. -I would expect it to be able to solve the goal even without this hypothesis -being cleared. A small, self-contained example is below. - -I have coq r12238. - - -Thanks -Ian -*) - - -From Stdlib Require Import FSets. -From Stdlib Require Import Arith. -From Stdlib Require Import FSetWeakList. - -Module DecidableNat. -Definition t := nat. -Definition eq := @eq nat. -Definition eq_refl := @refl_equal nat. -Definition eq_sym := @sym_eq nat. -Definition eq_trans := @trans_eq nat. -Definition eq_dec := eq_nat_dec. -End DecidableNat. - -Module NatSet := Make(DecidableNat). - -Module Export Dec := WDecide (NatSet). -Import FSetDecideAuxiliary. - -Parameter MkEquality : forall ( s0 s1 : NatSet.t ) - ( x : nat ), - NatSet.Equal s1 (NatSet.add x s0). - -Lemma ThisLemmaWorks : forall ( s0 s1 : NatSet.t ) - ( a b : nat ), - NatSet.In a s0 - -> NatSet.In a s1. -Proof. -intros. -remember (MkEquality s0 s1 b) as H1. -clear HeqH1. -fsetdec. -Qed. - -Lemma ThisLemmaWasFailing : forall ( s0 s1 : NatSet.t ) - ( a b : nat ), - NatSet.In a s0 - -> NatSet.In a s1. -Proof. -intros. -remember (MkEquality s0 s1 b) as H1. -fsetdec. -(* -Error: Tactic failure: because the goal is beyond the scope of this tactic. -*) -Qed. diff --git a/stdlib/test-suite/bugs/bug_2137.v b/stdlib/test-suite/bugs/bug_2137.v deleted file mode 100644 index 4e5f103ba67d..000000000000 --- a/stdlib/test-suite/bugs/bug_2137.v +++ /dev/null @@ -1,52 +0,0 @@ -(* Bug #2137 - -The fsetdec tactic is sensitive to which way round the arguments to <> are. -In the small, self-contained example below, it is able to solve the goal -if it knows that "b <> a", but not if it knows that "a <> b". I would expect -it to be able to solve the goal in either case. - -I have coq r12238. - - -Thanks -Ian - -*) - -From Stdlib Require Import Arith FSets FSetWeakList. - -Module DecidableNat. -Definition t := nat. -Definition eq := @eq nat. -Definition eq_refl := @refl_equal nat. -Definition eq_sym := @sym_eq nat. -Definition eq_trans := @trans_eq nat. -Definition eq_dec := eq_nat_dec. -End DecidableNat. - -Module NatSet := Make(DecidableNat). - -Module Export NameSetDec := WDecide (NatSet). - -Lemma ThisLemmaWorks : forall ( s0 : NatSet.t ) - ( a b : nat ), - b <> a - -> ~(NatSet.In a s0) - -> ~(NatSet.In a (NatSet.add b s0)). -Proof. -intros. -fsetdec. -Qed. - -Lemma ThisLemmaWasFailing : forall ( s0 : NatSet.t ) - ( a b : nat ), - a <> b - -> ~(NatSet.In a s0) - -> ~(NatSet.In a (NatSet.add b s0)). -Proof. -intros. -fsetdec. -(* -Error: Tactic failure: because the goal is beyond the scope of this tactic. -*) -Qed. diff --git a/stdlib/test-suite/bugs/bug_2141.v b/stdlib/test-suite/bugs/bug_2141.v deleted file mode 100644 index 4786cdd00144..000000000000 --- a/stdlib/test-suite/bugs/bug_2141.v +++ /dev/null @@ -1,16 +0,0 @@ -From Stdlib Require Extraction. -From Stdlib Require Import FSetList. -From Stdlib Require Import OrderedTypeEx. - -Module NatSet := FSetList.Make (Nat_as_OT). -Recursive Extraction NatSet.fold. - -Module FSetHide (X : FSetInterface.S). - Include X. -End FSetHide. - -Module NatSet' := FSetHide NatSet. -Recursive Extraction NatSet'.fold. -Extraction TestCompile NatSet'.fold. - -(* Extraction "test2141.ml" NatSet'.fold. *) diff --git a/stdlib/test-suite/bugs/bug_2145.v b/stdlib/test-suite/bugs/bug_2145.v deleted file mode 100644 index 5196b5260fe7..000000000000 --- a/stdlib/test-suite/bugs/bug_2145.v +++ /dev/null @@ -1,19 +0,0 @@ -(* Test robustness of Groebner tactic in presence of disequalities *) - -From Stdlib Require Export Reals. -From Stdlib Require Export Nsatz. - -Open Scope R_scope. - -Lemma essai : - forall yb xb m1 m2 xa ya, - xa <> xb -> - yb - 2 * m2 * xb = ya - m2 * xa -> - yb - m1 * xb = ya - m1 * xa -> - yb - ya = (2 * xb - xa) * m2 -> - yb - ya = (xb - xa) * m1. -Proof. -intros. -(* clear H. groebner used not to work when H was not cleared *) -nsatz. -Qed. diff --git a/stdlib/test-suite/bugs/bug_2281.v b/stdlib/test-suite/bugs/bug_2281.v deleted file mode 100644 index c7b86a623879..000000000000 --- a/stdlib/test-suite/bugs/bug_2281.v +++ /dev/null @@ -1,50 +0,0 @@ -(** Bug #2281 - -In the code below, coq is confused by an equality unless it is first 'subst'ed -away, yet http://coq.inria.fr/stdlib/Coq.FSets.FSetDecide.html says - - fsetdec will first perform any necessary zeta and beta reductions and will -invoke subst to eliminate any Coq equalities between finite sets or their -elements. - -I have coq r12851. - -*) - -From Stdlib Require Import Arith. -From Stdlib Require Import FSets. -From Stdlib Require Import FSetWeakList. - -Module DecidableNat. -Definition t := nat. -Definition eq := @eq nat. -Definition eq_refl := @refl_equal nat. -Definition eq_sym := @sym_eq nat. -Definition eq_trans := @trans_eq nat. -Definition eq_dec := eq_nat_dec. -End DecidableNat. - -Module NatSet := Make(DecidableNat). - -Module Export NameSetDec := WDecide (NatSet). - -Lemma ThisLemmaWorks : forall ( s1 s2 : NatSet.t ) - ( H : s1 = s2 ), - NatSet.Equal s1 s2. -Proof. -intros. -subst. -fsetdec. -Qed. - -Import FSetDecideAuxiliary. - -Lemma ThisLemmaWasFailing : forall ( s1 s2 : NatSet.t ) - ( H : s1 = s2 ), - NatSet.Equal s1 s2. -Proof. -intros. -fsetdec. -(* Error: Tactic failure: because the goal is beyond the scope of this tactic. -*) -Qed. diff --git a/stdlib/test-suite/bugs/bug_2347.v b/stdlib/test-suite/bugs/bug_2347.v deleted file mode 100644 index 6144025823fb..000000000000 --- a/stdlib/test-suite/bugs/bug_2347.v +++ /dev/null @@ -1,10 +0,0 @@ -From Stdlib Require Import EquivDec List. -Generalizable All Variables. - -Program Definition list_eqdec `(eqa : EqDec A eq) : EqDec (list A) eq := - (fun (x y : list A) => _). -Admit Obligations of list_eqdec. - -Program Definition list_eqdec' `(eqa : EqDec A eq) : EqDec (list A) eq := - (fun _ : nat => (fun (x y : list A) => _)) 0. -Admit Obligations of list_eqdec'. diff --git a/stdlib/test-suite/bugs/bug_2388.v b/stdlib/test-suite/bugs/bug_2388.v deleted file mode 100644 index dde7b990f471..000000000000 --- a/stdlib/test-suite/bugs/bug_2388.v +++ /dev/null @@ -1,9 +0,0 @@ -(* Error message was not printed in the correct environment *) - -Fail Parameters (A:Prop) (a:A A). - -(* This is a variant (reported as part of bug #2347) *) - -From Stdlib Require Import EquivDec. -Fail Program Instance bool_eq_eqdec : EqDec bool eq := - {equiv_dec x y := (fix aux (x y : bool) {struct x}:= aux _ y) x y}. diff --git a/stdlib/test-suite/bugs/bug_2393.v b/stdlib/test-suite/bugs/bug_2393.v deleted file mode 100644 index 580ae115b86e..000000000000 --- a/stdlib/test-suite/bugs/bug_2393.v +++ /dev/null @@ -1,14 +0,0 @@ -From Stdlib Require Import Program. -From Stdlib Require Import Wf_nat. - -Inductive T := MkT. - -Definition sizeOf (t : T) : nat - := match t with - | MkT => 1 - end. -Parameter vect : nat -> Type. -Program Fixpoint idType (t : T) (n := sizeOf t) (b : vect n) {measure n} : T - := match t with - | MkT => MkT - end. diff --git a/stdlib/test-suite/bugs/bug_2456.v b/stdlib/test-suite/bugs/bug_2456.v deleted file mode 100644 index 05f6e4c1f09b..000000000000 --- a/stdlib/test-suite/bugs/bug_2456.v +++ /dev/null @@ -1,58 +0,0 @@ - -From Stdlib Require Import Equality. - -Parameter Patch : nat -> nat -> Set. - -Inductive Catch (from to : nat) : Type - := MkCatch : forall (p : Patch from to), - Catch from to. -Arguments MkCatch [from to]. - -Inductive CatchCommute5 - : forall {from mid1 mid2 to : nat}, - Catch from mid1 - -> Catch mid1 to - -> Catch from mid2 - -> Catch mid2 to - -> Prop - := MkCatchCommute5 : - forall {from mid1 mid2 to : nat} - (p : Patch from mid1) - (q : Patch mid1 to) - (q' : Patch from mid2) - (p' : Patch mid2 to), - CatchCommute5 (MkCatch p) (MkCatch q) (MkCatch q') (MkCatch p'). - -Inductive CatchCommute {from mid1 mid2 to : nat} - (p : Catch from mid1) - (q : Catch mid1 to) - (q' : Catch from mid2) - (p' : Catch mid2 to) - : Prop - := isCatchCommute5 : forall (catchCommuteDetails : CatchCommute5 p q q' p'), - CatchCommute p q q' p'. -Notation "<< p , q >> <~> << q' , p' >>" - := (CatchCommute p q q' p') - (at level 60, no associativity). - -Lemma CatchCommuteUnique2 : - forall {from mid mid' to : nat} - {p : Catch from mid} {q : Catch mid to} - {q' : Catch from mid'} {p' : Catch mid' to} - {q'' : Catch from mid'} {p'' : Catch mid' to} - (commute1 : <> <~> <>) - (commute2 : <> <~> <>), - (p' = p'') /\ (q' = q''). -Proof with auto. -intros. -set (X := commute2). -Fail dependent destruction commute1; -dependent destruction catchCommuteDetails; -dependent destruction commute2; -dependent destruction catchCommuteDetails generalizing X. -revert X. -dependent destruction commute1; -dependent destruction catchCommuteDetails; -dependent destruction commute2; -dependent destruction catchCommuteDetails. -Abort. diff --git a/stdlib/test-suite/bugs/bug_2464.v b/stdlib/test-suite/bugs/bug_2464.v deleted file mode 100644 index 7fc7db0a0d21..000000000000 --- a/stdlib/test-suite/bugs/bug_2464.v +++ /dev/null @@ -1,39 +0,0 @@ -From Stdlib Require Import FSetWeakList. -From Stdlib Require Import FSetDecide. - -Parameter Name : Set. -Axiom eq_Name_dec : forall (n : Name) (o : Name), {n = o} + {n <> o}. - -Module DecidableName. -Definition t := Name. -Definition eq := @eq Name. -Definition eq_refl := @refl_equal Name. -Definition eq_sym := @sym_eq Name. -Definition eq_trans := @trans_eq Name. -Definition eq_dec := eq_Name_dec. -End DecidableName. - -Module NameSetMod := Make(DecidableName). - -Module NameSetDec := WDecide (NameSetMod). - -Class PartPatchUniverse (pu_type1 pu_type2 : Type) - : Type := mkPartPatchUniverse { -}. -Class PatchUniverse {pu_type : Type} - (ppu : PartPatchUniverse pu_type pu_type) - : Type := mkPatchUniverse { - pu_nameOf : pu_type -> Name -}. - -Lemma foo : forall (pu_type : Type) - (ppu : PartPatchUniverse pu_type pu_type) - (patchUniverse : PatchUniverse ppu) - (ns ns1 ns2 : NameSetMod.t) - (containsOK : NameSetMod.Equal ns1 ns2) - (p : pu_type) - (HX1 : NameSetMod.Equal ns1 (NameSetMod.add (pu_nameOf p) ns)), - NameSetMod.Equal ns2 (NameSetMod.add (pu_nameOf p) ns). -Proof. -NameSetDec.fsetdec. -Qed. diff --git a/stdlib/test-suite/bugs/bug_2467.v b/stdlib/test-suite/bugs/bug_2467.v deleted file mode 100644 index 47e32d418b4b..000000000000 --- a/stdlib/test-suite/bugs/bug_2467.v +++ /dev/null @@ -1,49 +0,0 @@ -(* -In the code below, I would expect the - NameSetDec.fsetdec. -to solve the Lemma, but I need to do it in steps instead. - -This is a regression relative to FSet, - -I have v8.3 (13702). -*) - -From Stdlib Require Import MSets. - -Parameter Name : Set. -Parameter Name_compare : Name -> Name -> comparison. -Parameter Name_compare_sym : forall {x y : Name}, - Name_compare y x = CompOpp (Name_compare x y). -Parameter Name_compare_trans : forall {c : comparison} - {x y z : Name}, - Name_compare x y = c - -> Name_compare y z = c - -> Name_compare x z = c. -Parameter Name_eq_leibniz : forall {s s' : Name}, - Name_compare s s' = Eq - -> s = s'. - -Module NameOrderedTypeAlt. -Definition t := Name. -Definition compare := Name_compare. -Definition compare_sym := @Name_compare_sym. -Definition compare_trans := @Name_compare_trans. -End NameOrderedTypeAlt. - -Module NameOrderedType := OT_from_Alt(NameOrderedTypeAlt). - -Module NameOrderedTypeWithLeibniz. -Include NameOrderedType. -Definition eq_leibniz := @Name_eq_leibniz. -End NameOrderedTypeWithLeibniz. - -Module NameSetMod := MSetList.MakeWithLeibniz(NameOrderedTypeWithLeibniz). -Module NameSetDec := WDecide (NameSetMod). - -Lemma foo : forall (xs ys : NameSetMod.t) - (n : Name) - (H1 : NameSetMod.Equal xs (NameSetMod.add n ys)), - NameSetMod.In n xs. -Proof. -NameSetDec.fsetdec. -Qed. diff --git a/stdlib/test-suite/bugs/bug_2473.v b/stdlib/test-suite/bugs/bug_2473.v deleted file mode 100644 index 16bcd9767057..000000000000 --- a/stdlib/test-suite/bugs/bug_2473.v +++ /dev/null @@ -1,40 +0,0 @@ -Require Import TestSuite.admit. - -From Stdlib Require Import Relations Program Setoid Morphisms. - -Section S1. - Variable R: nat -> relation bool. - Instance HR1: forall n, Transitive (R n). Admitted. - Instance HR2: forall n, Symmetric (R n). Admitted. - Hypothesis H: forall n a, R n (andb a a) a. - Goal forall n a b, R n b a. - intros. - (* rewrite <- H. *) (* Anomaly: Evar ?.. was not declared. Please report. *) - (* idem with setoid_rewrite *) -(* assert (HR2' := HR2 n). *) - rewrite <- H. (* ok *) - admit. - Qed. -End S1. - -Section S2. - Variable R: nat -> relation bool. - Instance HR: forall n, Equivalence (R n). Admitted. - Hypothesis H: forall n a, R n (andb a a) a. - Goal forall n a b, R n a b. - intros. rewrite <- H. admit. - Qed. -End S2. - -(* the parametrised relation is required to get the problem *) -Section S3. - Variable R: relation bool. - Instance HR1': Transitive R. Admitted. - Instance HR2': Symmetric R. Admitted. - Hypothesis H: forall a, R (andb a a) a. - Goal forall a b, R b a. - intros. - rewrite <- H. (* ok *) - admit. - Qed. -End S3. diff --git a/stdlib/test-suite/bugs/bug_2586.v b/stdlib/test-suite/bugs/bug_2586.v deleted file mode 100644 index 31940e446bc2..000000000000 --- a/stdlib/test-suite/bugs/bug_2586.v +++ /dev/null @@ -1,6 +0,0 @@ -From Stdlib Require Import Setoid SetoidClass Program. - -Goal forall `(Setoid nat) x y, x == y -> S x == S y. - intros. - Fail clsubst H0. - Abort. diff --git a/stdlib/test-suite/bugs/bug_2590.v b/stdlib/test-suite/bugs/bug_2590.v deleted file mode 100644 index 5916afa8b941..000000000000 --- a/stdlib/test-suite/bugs/bug_2590.v +++ /dev/null @@ -1,19 +0,0 @@ -Require Import TestSuite.admit. -From Stdlib Require Import Relation_Definitions RelationClasses Setoid SetoidClass. - -Section Bug. - - Context {A : Type} (R : relation A). - Hypothesis pre : PreOrder R. - Context `{SA : Setoid A}. - - Goal True. - set (SA' := SA). - assert ( forall SA0 : Setoid A, - @PartialOrder A (@equiv A SA0) (@setoid_equiv A SA0) R pre ). - rename SA into SA0. - intro SA. - admit. - admit. -Qed. -End Bug. diff --git a/stdlib/test-suite/bugs/bug_2613.v b/stdlib/test-suite/bugs/bug_2613.v deleted file mode 100644 index c46cf6363990..000000000000 --- a/stdlib/test-suite/bugs/bug_2613.v +++ /dev/null @@ -1,17 +0,0 @@ -Require Import TestSuite.admit. -(* Check that eq_sym is still pointing to Logic.eq_sym after use of Function *) - -From Stdlib Require Import ZArith. -From Stdlib Require Recdef. - -Axiom nat_eq_dec: forall x y : nat, {x=y}+{x<>y}. - -Locate eq_sym. (* Constant Stdlib.Init.Logic.eq_sym *) - -Function loop (n: nat) {measure (fun x => x) n} : bool := - if nat_eq_dec n 0 then false else loop (pred n). -Proof. - admit. -Defined. - -Check eq_sym eq_refl : 0=0. diff --git a/stdlib/test-suite/bugs/bug_2668.v b/stdlib/test-suite/bugs/bug_2668.v deleted file mode 100644 index 4e70da0a3294..000000000000 --- a/stdlib/test-suite/bugs/bug_2668.v +++ /dev/null @@ -1,6 +0,0 @@ -From Stdlib Require Import MSetPositive. -From Stdlib Require Import MSetProperties. - -Module Pos := MSetPositive.PositiveSet. -Module PPPP := MSetProperties.WPropertiesOn(Pos). -Print Module PPPP. diff --git a/stdlib/test-suite/bugs/bug_2729.v b/stdlib/test-suite/bugs/bug_2729.v deleted file mode 100644 index 15951e9c54d9..000000000000 --- a/stdlib/test-suite/bugs/bug_2729.v +++ /dev/null @@ -1,116 +0,0 @@ -(* This bug report actually revealed two bugs in the reconstruction of - a term with "match" in the vm *) - -(* A simplified form of the first problem *) - -(* Reconstruction of terms normalized with vm when a constructor has *) -(* let-ins arguments *) - -Record A : Type := C { a := 0 : nat; b : a=a }. -Goal forall d:A, match d with C a b => b end = match d with C a b => b end. -intro. -vm_compute. -(* Now check that it is well-typed *) -match goal with |- ?c = _ => first [let x := type of c in idtac | fail 2] end. -Abort. - -(* A simplified form of the second problem *) - -Parameter P : nat -> Type. - -Inductive box A := Box : A -> box A. - -Axiom com : {m : nat & box (P m) }. - -Lemma L : - (let (w, s) as com' return (com' = com -> Prop) := com in - let (s0) as s0 - return (existT (fun m : nat => box (P m)) w s0 = com -> Prop) := s in - fun _ : existT (fun m : nat => box (P m)) w (Box (P w) s0) = com => - True) eq_refl. -Proof. -vm_compute. -(* Now check that it is well-typed (the "P w" used to be turned into "P s") *) -match goal with |- ?c => first [let x := type of c in idtac | fail 2] end. -Abort. - -(* Then the original report *) - -From Stdlib Require Import Equality. - -Parameter NameSet : Set. -Parameter SignedName : Set. -Parameter SignedName_compare : forall (x y : SignedName), comparison. -Parameter pu_type : NameSet -> NameSet -> Type. -Parameter pu_nameOf : forall {from to : NameSet}, pu_type from to -> SignedName. -Parameter commute : forall {from mid1 mid2 to : NameSet}, - pu_type from mid1 -> pu_type mid1 to - -> pu_type from mid2 -> pu_type mid2 to -> Prop. - -Program Definition castPatchFrom {from from' to : NameSet} - (HeqFrom : from = from') - (p : pu_type from to) - : pu_type from' to - := p. - -Class PatchUniverse : Type := mkPatchUniverse { - - commutable : forall {from mid1 to : NameSet}, - pu_type from mid1 -> pu_type mid1 to -> Prop - := fun {from mid1 to : NameSet} - (p : pu_type from mid1) (q : pu_type mid1 to) => - exists mid2 : NameSet, - exists q' : pu_type from mid2, - exists p' : pu_type mid2 to, - commute p q q' p'; - - commutable_dec : forall {from mid to : NameSet} - (p : pu_type from mid) - (q : pu_type mid to), - {mid2 : NameSet & - { q' : pu_type from mid2 & - { p' : pu_type mid2 to & - commute p q q' p' }}} - + {~(commutable p q)} -}. - -Inductive SequenceBase (pu : PatchUniverse) - : NameSet -> NameSet -> Type - := Nil : forall {cxt : NameSet}, - SequenceBase pu cxt cxt - | Cons : forall {from mid to : NameSet} - (p : pu_type from mid) - (qs : SequenceBase pu mid to), - SequenceBase pu from to. -Arguments Nil {pu cxt}. -Arguments Cons [pu from mid to]. - -Program Fixpoint insertBase {pu : PatchUniverse} - {from mid to : NameSet} - (p : pu_type from mid) - (qs : SequenceBase pu mid to) - : SequenceBase pu from to - := match qs with - | Nil => Cons p Nil - | Cons q qs' => - match SignedName_compare (pu_nameOf p) (pu_nameOf q) with - | Lt => Cons p qs - | _ => match commutable_dec p (castPatchFrom _ q) with - | inleft (existT _ _ (existT _ q' (existT _ p' _))) => Cons q' -(insertBase p' qs') - | inright _ => Cons p qs - end - end - end. - -Lemma insertBaseConsLt {pu : PatchUniverse} - {o op opq opqr : NameSet} - (p : pu_type o op) - (q : pu_type op opq) - (rs : SequenceBase pu opq opqr) - (p_Lt_q : SignedName_compare (pu_nameOf p) (pu_nameOf q) -= Lt) - : insertBase p (Cons q rs) = Cons p (Cons q rs). -Proof. -vm_compute. -Abort. diff --git a/stdlib/test-suite/bugs/bug_2734.v b/stdlib/test-suite/bugs/bug_2734.v deleted file mode 100644 index 17ddc8a3c94d..000000000000 --- a/stdlib/test-suite/bugs/bug_2734.v +++ /dev/null @@ -1,15 +0,0 @@ -From Stdlib Require Import Arith List. -From Stdlib Require Import OrderedTypeEx. - -Module Adr. - Include Nat_as_OT. - Definition nat2t (i: nat) : t := i. -End Adr. - -Inductive expr := Const: Adr.t -> expr. - -Inductive control := Go: expr -> control. - -Definition program := (Adr.t * (control))%type. - -Fail Definition myprog : program := (Adr.nat2t 0, Go (Adr.nat2t 0) ). diff --git a/stdlib/test-suite/bugs/bug_2814.v b/stdlib/test-suite/bugs/bug_2814.v deleted file mode 100644 index 73e84351494c..000000000000 --- a/stdlib/test-suite/bugs/bug_2814.v +++ /dev/null @@ -1,6 +0,0 @@ -From Stdlib Require Import Program. - -Goal forall (x : Type) (f g : Type -> Type) (H : f x ~= g x), False. - intros. - Fail induction H. -Abort. diff --git a/stdlib/test-suite/bugs/bug_2830.v b/stdlib/test-suite/bugs/bug_2830.v deleted file mode 100644 index f13c33d5a09c..000000000000 --- a/stdlib/test-suite/bugs/bug_2830.v +++ /dev/null @@ -1,230 +0,0 @@ -(* Bug report #2830 (evar defined twice) covers different bugs *) - -(* 1- This was submitted by qb.h.agws *) - -Module A. - -Set Implicit Arguments. - -Inductive Bit := O | I. - -Inductive BitString: nat -> Set := -| bit: Bit -> BitString 0 -| bitStr: forall n: nat, Bit -> BitString n -> BitString (S n). - -Definition BitOr (a b: Bit) := - match a, b with - | O, O => O - | _, _ => I - end. - -(* Should fail with an error; used to failed in 8.4 and trunk with - anomaly Evd.define: cannot define an evar twice *) - -Fail Fixpoint StringOr (n m: nat) (a: BitString n) (b: BitString m) := - match a with - | bit a' => - match b with - | bit b' => bit (BitOr a' b') - | bitStr b' bT => bitStr b' (StringOr (bit a') bT) - end - | bitStr a' aT => - match b with - | bit b' => bitStr a' (StringOr aT (bit b')) - | bitStr b' bT => bitStr (BitOr a' b') (StringOr aT bT) - end - end. - -End A. - -(* 2- This was submitted by Andrew Appel *) - -Module B. - -From Stdlib Require Import Program Relations. - -Record ageable_facts (A:Type) (level: A -> nat) (age1:A -> option A) := -{ af_unage : forall x x' y', level x' = level y' -> age1 x = Some x' -> exists y, age1 y = Some y' -; af_level1 : forall x, age1 x = None <-> level x = 0 -; af_level2 : forall x y, age1 x = Some y -> level x = S (level y) -}. - -Arguments af_unage {A level age1}. -Arguments af_level1 {A level age1}. -Arguments af_level2 {A level age1}. - -Class ageable (A:Type) := mkAgeable -{ level : A -> nat -; age1 : A -> option A -; age_facts : ageable_facts A level age1 -}. -Definition age {A} `{ageable A} (x y:A) := age1 x = Some y. -Definition necR {A} `{ageable A} : relation A := clos_refl_trans A age. -Delimit Scope pred with pred. -Local Open Scope pred. - -Definition hereditary {A} (R:A->A->Prop) (p:A->Prop) := - forall a a':A, R a a' -> p a -> p a'. - -Definition pred (A:Type) {AG:ageable A} := - { p:A -> Prop | hereditary age p }. - -Bind Scope pred with pred. - -Definition app_pred {A} `{ageable A} (p:pred A) : A -> Prop := proj1_sig p. -Definition pred_hereditary `{ageable} (p:pred A) := proj2_sig p. -Coercion app_pred : pred >-> Funclass. -Global Opaque pred. - -Definition derives {A} `{ageable A} (P Q:pred A) := forall a:A, P a -> Q a. -Arguments derives : default implicits. - -Program Definition andp {A} `{ageable A} (P Q:pred A) : pred A := - fun a:A => P a /\ Q a. -Next Obligation. - intros; intro; intuition; apply pred_hereditary with a; auto. -Qed. - -Program Definition imp {A} `{ageable A} (P Q:pred A) : pred A := - fun a:A => forall a':A, necR a a' -> P a' -> Q a'. -Next Obligation. - intros; intro; intuition. - apply H1; auto. - apply rt_trans with a'; auto. - apply rt_step; auto. -Qed. - -Program Definition allp {A} `{ageable A} {B: Type} (f: B -> pred A) : pred A - := fun a => forall b, f b a. -Next Obligation. - intros; intro; intuition. - apply pred_hereditary with a; auto. - apply H1. -Qed. - -Notation "P '<-->' Q" := (andp (imp P Q) (imp Q P)) (at level 57, no associativity) : pred. -Notation "P '|--' Q" := (derives P Q) (at level 80, no associativity). -Notation "'All' x ':' T ',' P " := (allp (fun x:T => P%pred)) (at level 65, x at level 99) : pred. - -Lemma forall_pred_ext {A} `{agA : ageable A}: forall B P Q, - (All x : B, (P x <--> Q x)) |-- (All x : B, P x) <--> (All x: B, Q x). -Abort. - -End B. - -(* 3. *) - -(* This was submitted by Anthony Cowley *) - -From Stdlib Require Import Morphisms. -From Stdlib Require Import Setoid. - -Module C. - -Reserved Notation "a ~> b" (at level 70, right associativity). -Reserved Notation "a ā‰ˆ b" (at level 54). -Reserved Notation "a āˆ˜ b" (at level 50, left associativity). -Generalizable All Variables. - -Class Category (Object:Type) (Hom:Object -> Object -> Type) := { - hom := Hom where "a ~> b" := (hom a b) : category_scope - ; ob := Object - ; id : forall a, hom a a - ; comp : forall c b a, hom b c -> hom a b -> hom a c - where "g āˆ˜ f" := (comp _ _ _ g f) : category_scope - ; eqv : forall a b, hom a b -> hom a b -> Prop - where "f ā‰ˆ g" := (eqv _ _ f g) : category_scope - ; eqv_equivalence : forall a b, Equivalence (eqv a b) - ; comp_respects : forall a b c, - Proper (eqv b c ==> eqv a b ==> eqv a c) (comp c b a) - ; left_identity : forall `(f:a ~> b), id b āˆ˜ f ā‰ˆ f - ; right_identity : forall `(f:a ~> b), f āˆ˜ id a ā‰ˆ f - ; associativity : forall `(f:a~>b) `(g:b~>c) `(h:c~>d), - h āˆ˜ (g āˆ˜ f) ā‰ˆ (h āˆ˜ g) āˆ˜ f -}. -Notation "a ~> b" := (@hom _ _ _ a b) : category_scope. -Notation "g āˆ˜ f" := (@comp _ _ _ _ _ _ g f) : category_scope. -Notation "a ā‰ˆ b" := (@eqv _ _ _ _ _ a b) : category_scope. -Notation "a ~{ C }~> b" := (@hom _ _ C a b) (at level 100) : category_scope. -Coercion ob : Category >-> Sortclass. - -Open Scope category_scope. - -Add Parametric Relation `(C:Category Ob Hom) (a b : Ob) : (hom a b) (eqv a b) - reflexivity proved by (@Equivalence_Reflexive _ _ (eqv_equivalence a b)) - symmetry proved by (@Equivalence_Symmetric _ _ (eqv_equivalence a b)) - transitivity proved by (@Equivalence_Transitive _ _ (eqv_equivalence a b)) - as parametric_relation_eqv. - -Add Parametric Morphism `(C:Category Ob Hom) (c b a : Ob) : (comp c b a) - with signature (eqv _ _ ==> eqv _ _ ==> eqv _ _) as parametric_morphism_comp. - intros x y Heq x' y'. apply comp_respects. exact Heq. - Defined. - -Class Functor `(C:Category) `(D:Category) (im : C -> D) := { - functor_im := im - ; fmap : forall {a b}, `(a ~> b) -> im a ~> im b - ; fmap_respects : forall a b (f f' : a ~> b), f ā‰ˆ f' -> fmap f ā‰ˆ fmap f' - ; fmap_preserves_id : forall a, fmap (id a) ā‰ˆ id (im a) - ; fmap_preserves_comp : forall `(f:a~>b) `(g:b~>c), - fmap g āˆ˜ fmap f ā‰ˆ fmap (g āˆ˜ f) -}. -Coercion functor_im : Functor >-> Funclass. -Arguments fmap [Object Hom C Object0 Hom0 D im] _ [a b]. - -Add Parametric Morphism `(C:Category) `(D:Category) - (Im:C->D) (F:Functor C D Im) (a b:C) : (@fmap _ _ C _ _ D Im F a b) - with signature (@eqv C _ C a b ==> @eqv D _ D (Im a) (Im b)) - as parametric_morphism_fmap. -intros. apply fmap_respects. assumption. Qed. - -(* HERE IS THE PROBLEMATIC INSTANCE. If we change this to a regular Definition, - then the problem goes away. *) -#[export] Instance functor_comp `{C:Category} `{D:Category} `{E:Category} - {Gim} (G:Functor D E Gim) {Fim} (F:Functor C D Fim) - : Functor C E (Basics.compose Gim Fim). -intros. apply Build_Functor with (fmap := fun a b f => fmap G (fmap F f)). -abstract (intros; rewrite H; reflexivity). -abstract (intros; repeat (rewrite fmap_preserves_id); reflexivity). -abstract (intros; repeat (rewrite fmap_preserves_comp); reflexivity). -Defined. - -Definition skel {A:Type} : relation A := @eq A. -#[export] Instance skel_equiv A : Equivalence (@skel A). -Admitted. - -Import FunctionalExtensionality. - -#[export] Instance set_cat : Category Type (fun A B => A -> B). -refine {| - id := fun A => fun x => x - ; comp c b a f g := fun x => f (g x) - ; eqv := fun A B => @skel (A -> B) -|}. -intros. compute. symmetry. apply eta_expansion. -intros. compute. symmetry. apply eta_expansion. -intros. compute. reflexivity. -Defined. - -(* The [list] type constructor is a Functor. *) - -From Stdlib Require Import List. - -Definition setList (A:set_cat) := list A. -#[export] Instance list_functor : Functor set_cat set_cat setList. -apply Build_Functor with (fmap := @map). -intros. rewrite H. reflexivity. -intros; simpl; apply functional_extensionality. - induction x; [auto|simpl]. rewrite IHx. reflexivity. -intros; simpl; apply functional_extensionality. - induction x; [auto|simpl]. rewrite IHx. reflexivity. -Defined. - -Local Notation "[ a , .. , b ]" := (a :: .. (b :: nil) ..) : list_scope. -Definition setFmap {Fim} {F:Functor set_cat set_cat Fim} `(f:A~>B) (xs:Fim A) := fmap F f xs. - -(* We want to infer the [Functor] instance based on the value's - structure, but the [functor_comp] instance throws things awry. *) -Eval cbv in setFmap (fun x => x * 3) [67,8]. - -End C. diff --git a/stdlib/test-suite/bugs/bug_2883.v b/stdlib/test-suite/bugs/bug_2883.v deleted file mode 100644 index c2c07925ea7e..000000000000 --- a/stdlib/test-suite/bugs/bug_2883.v +++ /dev/null @@ -1,37 +0,0 @@ -Require Import TestSuite.admit. -From Stdlib Require Import List. -From Stdlib Require Import Equality. - -Inductive star {genv state : Type} - (step : genv -> state -> state -> Prop) - (ge : genv) : state -> state -> Prop := - | star_refl : forall s : state, star step ge s s - | star_step : - forall (s1 : state) (s2 : state) - (s3 : state), - step ge s1 s2 -> - star step ge s2 s3 -> - star step ge s1 s3. - -Parameter genv expr env mem : Type. -Definition genv' := genv. -Inductive state : Type := - | State : expr -> env -> mem -> state. -Parameter step : genv' -> state -> state -> Prop. - -Section Test. - -Variable ge : genv'. - -Lemma compat_eval_steps: - forall a b e a' b', - star step ge (State a e b) (State a' e b') -> - True. -Proof. - intros. dependent induction H. - trivial. - eapply IHstar; eauto. - replace s2 with (State a' e b') by admit. eauto. -Qed. (* Oups *) - -End Test. diff --git a/stdlib/test-suite/bugs/bug_2900.v b/stdlib/test-suite/bugs/bug_2900.v deleted file mode 100644 index 3c57d5d9aef5..000000000000 --- a/stdlib/test-suite/bugs/bug_2900.v +++ /dev/null @@ -1,29 +0,0 @@ -(* Was raising stack overflow in 8.4 and assertion failed in future 8.5 *) -Set Implicit Arguments. - -From Stdlib Require Import List. -From Stdlib Require Import Equality. - -(** Reflexive-transitive closure ( R* ) *) - -Inductive rtclosure (A : Type) (R : A-> A->Prop) : A->A->Prop := - | rtclosure_refl : forall x, - rtclosure R x x - | rtclosure_step : forall y x z, - R x y -> rtclosure R y z -> rtclosure R x z. - (* bug goes away if rtclosure_step is commented out *) - -(** The closure of the trivial binary relation [eq] *) - -Definition tr (A:Type) := rtclosure (@eq A). - -(** The bug *) - -Lemma bug : forall A B (l t:list A) (r s:list B), - length l = length r -> - tr (combine l r) (combine t s) -> tr l t. -Proof. - intros * E Hp. - (* bug goes away if [revert E] is called explicitly *) - dependent induction Hp. -Abort. diff --git a/stdlib/test-suite/bugs/bug_3036.v b/stdlib/test-suite/bugs/bug_3036.v deleted file mode 100644 index 3db56dac4ecf..000000000000 --- a/stdlib/test-suite/bugs/bug_3036.v +++ /dev/null @@ -1,171 +0,0 @@ -(* Checking use of retyping in w_unify0 in the presence of unification -problems of the form \x:Meta.Meta = \x:ind.match x with ... end *) - -From Stdlib Require Import List. -From Stdlib Require Import QArith. -From Stdlib Require Import Qcanon. - -Set Implicit Arguments. - -Inductive dynamic : Type := - | Dyn : forall T, T -> dynamic. - -Definition perm := Qc. - -Locate Qle_bool. - -Definition compatibleb (p1 p2 : perm) : bool := -let p1pos := Qle_bool 0 p1 in - let p2pos := Qle_bool 0 p2 in - negb ( - (p1pos && p2pos) - || ((p1pos || p2pos) && (negb (Qle_bool 0 ((p1 + p2)%Qc)))))%Qc. - -Definition compatible (p1 p2 : perm) := compatibleb p1 p2 = true. - -Definition perm_plus (p1 p2 : perm) : option perm := - if compatibleb p1 p2 then Some (p1 + p2) else None. - -Infix "+p" := perm_plus (at level 60, no associativity). - -Axiom axiom_ptr : Set. - -Definition ptr := axiom_ptr. - -Axiom axiom_ptr_eq_dec : forall (a b : ptr), {a = b} + {a <> b}. - -Definition ptr_eq_dec := axiom_ptr_eq_dec. - -Definition hval := (dynamic * perm)%type. - -Definition heap := ptr -> option hval. - -Bind Scope heap_scope with heap. -Delimit Scope heap_scope with heap. -Local Open Scope heap_scope. - -Definition read (h : heap) (p : ptr) : option hval := h p. - -Notation "a # b" := (read a b) (at level 55, no associativity) : heap_scope. - -Definition val (v:hval) := fst v. -Definition frac (v:hval) := snd v. - -Definition hval_plus (v1 v2 : hval) : option hval := - match (frac v1) +p (frac v2) with - | None => None - | Some v1v2 => Some (val v1, v1v2) - end. - -Definition hvalo_plus (v1 v2 : option hval) := - match v1 with - | None => v2 - | Some v1' => - match v2 with - | None => v1 - | Some v2' => (hval_plus v1' v2') - end - end. - -Notation "v1 +o v2" := (hvalo_plus v1 v2) (at level 60, no associativity) : heap_scope. - -Definition join (h1 h2 : heap) : heap := - (fun p => (h1 p) +o (h2 p)). - -Infix "*" := join (at level 40, left associativity) : heap_scope. - -Definition hprop := heap -> Prop. - -Bind Scope hprop_scope with hprop. -Delimit Scope hprop_scope with hprop. - -Definition hprop_cell (p : ptr) T (v : T) (pi:Qc): hprop := fun h => - h#p = Some (Dyn v, pi) /\ forall p', p' <> p -> h#p' = None. - -Notation "p ---> v" := (hprop_cell p v (0%Qc)) (at level 38, no associativity) : hprop_scope. - -Definition empty : heap := fun _ => None. - -Definition hprop_empty : hprop := eq empty. -Notation "'emp'" := hprop_empty : hprop_scope. - -Definition hprop_inj (P : Prop) : hprop := fun h => h = empty /\ P. -Notation "[ P ]" := (hprop_inj P) (at level 0, P at level 200) : hprop_scope. - -Definition hprop_imp (p1 p2 : hprop) : Prop := forall h, p1 h -> p2 h. -Infix "==>" := hprop_imp (right associativity, at level 55). - -Definition hprop_ex T (p : T -> hprop) : hprop := fun h => exists v, p v h. -Notation "'Exists' v :@ T , p" := (hprop_ex (fun v : T => p%hprop)) - (at level 90, T at next level) : hprop_scope. - -Local Open Scope hprop_scope. -Definition disjoint (h1 h2 : heap) : Prop := - forall p, - match h1#p with - | None => True - | Some v1 => match h2#p with - | None => True - | Some v2 => val v1 = val v2 - /\ compatible (frac v1) (frac v2) - end - end. - -Infix "<#>" := disjoint (at level 40, no associativity) : heap_scope. - -Definition split (h h1 h2 : heap) : Prop := h1 <#> h2 /\ h = h1 * h2. - -Notation "h ~> h1 * h2" := (split h h1 h2) (at level 40, h1 at next level, no associativity). - -Definition hprop_sep (p1 p2 : hprop) : hprop := fun h => - exists h1, exists h2, h ~> h1 * h2 - /\ p1 h1 - /\ p2 h2. -Infix "*" := hprop_sep (at level 40, left associativity) : hprop_scope. - -Section Stack. - Variable T : Set. - - Record node : Set := Node { - data : T; - next : option ptr - }. - - Fixpoint listRep (ls : list T) (hd : option ptr) {struct ls} : hprop := - match ls with - | nil => [hd = None] - | h :: t => - match hd with - | None => [False] - | Some hd' => Exists p :@ option ptr, hd' ---> Node h p * listRep t p - end - end%hprop. - - Definition stack := ptr. - - Definition rep q ls := (Exists po :@ option ptr, q ---> po * listRep ls po)%hprop. - - Definition isExistential T (x : T) := True. - - Theorem himp_ex_conc_trivial : forall T p p1 p2, - p ==> p1 * p2 - -> T - -> p ==> hprop_ex (fun _ : T => p1) * p2. - Admitted. - - Goal forall (s : ptr) (x : T) (nd : ptr) (v : unit) (x0 : list T) (v0 : option ptr) - (H0 : isExistential v0), - nd ---> {| data := x; next := v0 |} * (s ---> Some nd * listRep x0 v0) ==> - (Exists po :@ option ptr, - s ---> po * - match po with - | Some hd' => - Exists p :@ option ptr, - hd' ---> {| data := x; next := p |} * listRep x0 p - | None => [False] - end) * emp. - Proof. - intros. - try apply himp_ex_conc_trivial. - Abort. -End Stack. diff --git a/stdlib/test-suite/bugs/bug_3037.v b/stdlib/test-suite/bugs/bug_3037.v deleted file mode 100644 index 89ca66542154..000000000000 --- a/stdlib/test-suite/bugs/bug_3037.v +++ /dev/null @@ -1,12 +0,0 @@ -(* Anomaly before 4a8950ec7a0d9f2b216e67e69b446c064590a8e9 *) - -From Stdlib Require Import Arith_base Recdef. - -Function f_R (a: nat) {wf (fun x y: nat => False) a}:Prop:= - match a:nat with - | 0 => True - | (S y') => f_R y' - end. -(* Anomaly: File "plugins/funind/recdef.ml", line 916, characters 13-19: Assertion failed. -Please report. *) -Abort. diff --git a/stdlib/test-suite/bugs/bug_3164.v b/stdlib/test-suite/bugs/bug_3164.v deleted file mode 100644 index b5f69068b77d..000000000000 --- a/stdlib/test-suite/bugs/bug_3164.v +++ /dev/null @@ -1,49 +0,0 @@ -(* Before 31a69c4d0fd7b8325187e8da697a9c283594047d, [case] would stack overflow *) -From Stdlib Require Import Arith. - -Section Acc_generator. - Variable A : Type. - Variable R : A -> A -> Prop. - - (* *Lazily* add 2^n - 1 Acc_intro on top of wf. - Needed for fast reductions using Function and Program Fixpoint - and probably using Fix and Fix_F_2 - *) - Fixpoint Acc_intro_generator n (wf : well_founded R) := - match n with - | O => wf - | S n => fun x => Acc_intro x (fun y _ => Acc_intro_generator n (Acc_intro_generator n wf) y) - end. - - -End Acc_generator. - -Definition pred_F : (forall x : nat, - (forall y : nat, y < x -> (fun _ : nat => nat) y) -> - (fun _ : nat => nat) x). -Proof. - intros x. - simpl. - case x. - exact (fun _ => 0). - intros n h. - apply (h n). - constructor. -Defined. - -Definition my_pred := Fix lt_wf (fun _ => nat) pred_F. - - -Lemma my_pred_is_pred : forall x, match my_pred x with | 0 => True | S n => False end. -Proof. - intros x. - case x. -Abort. - -Definition my_pred_bad := Fix (Acc_intro_generator _ _ 100 lt_wf) (fun _ => nat) pred_F. - -Lemma my_pred_is_pred : forall x, match my_pred_bad x with | 0 => True | S n => False end. -Proof. - intros x. - Timeout 2 case x. -Admitted. diff --git a/stdlib/test-suite/bugs/bug_3258.v b/stdlib/test-suite/bugs/bug_3258.v deleted file mode 100644 index 483db62c4ff3..000000000000 --- a/stdlib/test-suite/bugs/bug_3258.v +++ /dev/null @@ -1,37 +0,0 @@ -Require Import TestSuite.admit. -From Stdlib Require Import Morphisms RelationClasses Program Setoid. - -Global Set Implicit Arguments. - -#[export] Hint Extern 0 => apply reflexivity : typeclass_instances. - -Inductive Comp : Type -> Type := -| Pick : forall A, (A -> Prop) -> Comp A. - -Axiom computes_to : forall A, Comp A -> A -> Prop. - -Axiom refine : forall {A} (old : Comp A) (new : Comp A), Prop. - -Global Instance refine_PreOrder A : PreOrder (@refine A). -Admitted. -Add Parametric Morphism A -: (@Pick A) - with signature - (pointwise_relation _ (flip impl)) - ==> (@refine A) - as refine_flip_impl_Pick. - admit. -Defined. -Definition remove_forall_eq' A x B (P : A -> B -> Prop) : pointwise_relation _ impl (P x) (fun z => forall y : A, y = x -> P y z). - admit. -Defined. -Goal forall A B (x : A) (P : _ -> _ -> Prop), - refine (Pick (fun n : B => forall y, y = x -> P y n)) - (Pick (fun n : B => P x n)). -Proof. - intros. - setoid_rewrite (@remove_forall_eq' _ _ _ _). - Undo. - (* This failed with NotConvertible at some time *) - setoid_rewrite (@remove_forall_eq' _ _ _). -Abort. diff --git a/stdlib/test-suite/bugs/bug_3344.v b/stdlib/test-suite/bugs/bug_3344.v deleted file mode 100644 index e67c12b4e738..000000000000 --- a/stdlib/test-suite/bugs/bug_3344.v +++ /dev/null @@ -1,59 +0,0 @@ -Require Import TestSuite.admit. -(* File reduced by coq-bug-finder from original input, then from 716 lines to 197 lines, then from 206 lines to 162 lines, then from 163 lines to 73 lines *) -From Stdlib Require Import Ensembles. -From Stdlib Require Import String. -Global Set Implicit Arguments. -Global Set Asymmetric Patterns. -Ltac clearbodies := repeat match goal with | [ H := _ |- _ ] => clearbody H end. - -Inductive Comp : Type -> Type := -| Return : forall A, A -> Comp A -| Bind : forall A B, Comp A -> (A -> Comp B) -> Comp B. -Inductive computes_to : forall A, Comp A -> A -> Prop := -| ReturnComputes : forall A v, @computes_to A (Return v) v -| BindComputes : forall A B comp_a f comp_a_value comp_b_value, - @computes_to A comp_a comp_a_value - -> @computes_to B (f comp_a_value) comp_b_value - -> @computes_to B (Bind comp_a f) comp_b_value. - -Inductive is_computational : forall A, Comp A -> Prop := -| Return_is_computational : forall A (x : A), is_computational (Return x) -| Bind_is_computational : forall A B (cA : Comp A) (f : A -> Comp B), - is_computational cA - -> (forall a, - @computes_to _ cA a -> is_computational (f a)) - -> is_computational (Bind cA f). -Theorem is_computational_inv A (c : Comp A) -: is_computational c - -> match c with - | Return _ _ => True - | Bind _ _ x f => is_computational x - /\ forall v, computes_to x v - -> is_computational (f v) - end. - admit. -Defined. -Fixpoint is_computational_unique_val A (c : Comp A) {struct c} -: is_computational c -> { a | unique (computes_to c) a }. -Proof. - refine match c as c return is_computational c -> { a | unique (computes_to c) a } with - | Return T x => fun _ => exist (unique (computes_to (Return x))) - x - _ - | Bind _ _ x f - => fun H - => let H' := is_computational_inv H in - let xv := @is_computational_unique_val _ _ (proj1 H') in - let fxv := @is_computational_unique_val _ _ (proj2 H' _ (proj1 (proj2_sig xv))) in - exist (unique (computes_to _)) - (proj1_sig fxv) - _ - end; - clearbodies; - clear is_computational_unique_val; - clear; - first [ abstract admit - | abstract admit ]. -(* [Fail] does not catch the anomaly *) -Defined. -(* Anomaly: Uncaught exception Not_found(_). Please report. *) diff --git a/stdlib/test-suite/bugs/bug_3350.v b/stdlib/test-suite/bugs/bug_3350.v deleted file mode 100644 index 7ec3a9f2721e..000000000000 --- a/stdlib/test-suite/bugs/bug_3350.v +++ /dev/null @@ -1,121 +0,0 @@ -Require Import TestSuite.admit. -From Stdlib Require Fin. -From Stdlib Require Vector. - -Local Generalizable All Variables. -Set Implicit Arguments. - -Arguments Fin.F1 : clear implicits. - -Lemma fin_0_absurd : notT (Fin.t 0). -Proof. hnf. apply Fin.case0. Qed. - -Axiom admit : forall {A}, A. - -Fixpoint lower {n:nat} (p:Fin.t (S n)) {struct p} : - forall (i:Fin.t (S n)), option (Fin.t n) - := match p in Fin.t (S n1) - return Fin.t (S n1) -> option (Fin.t n1) - with - | @Fin.F1 n1 => - fun (i:Fin.t (S n1)) => - match i in Fin.t (S n2) return option (Fin.t n2) with - | @Fin.F1 n2 => None - | @Fin.FS n2 i2 => Some i2 - end - | @Fin.FS n1 p1 => - fun (i:Fin.t (S n1)) => - match i in Fin.t (S n2) return Fin.t n2 -> option (Fin.t n2) with - | @Fin.F1 n2 => - match n2 as n3 return Fin.t n3 -> option (Fin.t n3) with - | 0 => fun p2 => False_rect _ (fin_0_absurd p2) - | S n3 => fun p2 => Some (Fin.F1 n3) - end - | @Fin.FS n2 i2 => - match n2 as n3 return Fin.t n3 -> Fin.t n3 -> option (Fin.t n3) with - | 0 => fun i3 p3 => False_rect _ (fin_0_absurd p3) - | S n3 => fun (i3 p3:Fin.t (S n3)) => - option_map (@Fin.FS _) admit - end i2 - end p1 - end. - -Lemma lower_ind (P: forall n (p i:Fin.t (S n)), option (Fin.t n) -> Prop) - (c11 : forall n, P n (Fin.F1 n) (Fin.F1 n) None) - (c1S : forall n (i:Fin.t n), P n (Fin.F1 n) (Fin.FS i) (Some i)) - (cS1 : forall n (p:Fin.t (S n)), - P (S n) (Fin.FS p) (Fin.F1 (S n)) (Some (Fin.F1 n))) - (cSSS : forall n (p i:Fin.t (S n)) (i':Fin.t n) - (Elow:lower p i = Some i'), - P n p i (Some i') -> - P (S n) (Fin.FS p) (Fin.FS i) (Some (Fin.FS i'))) - (cSSN : forall n (p i:Fin.t (S n)) - (Elow:lower p i = None), - P n p i None -> - P (S n) (Fin.FS p) (Fin.FS i) None) : - forall n (p i:Fin.t (S n)), P n p i (lower p i). -Proof. - fix lower_ind 2. intros n p. - refine (match p as p1 in Fin.t (S n1) - return forall (i1:Fin.t (S n1)), P n1 p1 i1 (lower p1 i1) - with - | @Fin.F1 n1 => _ - | @Fin.FS n1 p1 => _ - end); clear n p. - { revert n1. refine (@Fin.caseS _ _ _); cbn; intros. - apply c11. apply c1S. } - { intros i1. revert p1. - pattern n1, i1; refine (@Fin.caseS _ _ _ _ _); - clear n1 i1; - (intros [|n] i; [refine (False_rect _ (fin_0_absurd i)) | cbn ]). - { apply cS1. } - { intros p. pose proof (admit : P n p i (lower p i)) as H. - destruct (lower p i) eqn:E. - { admit; assumption. } - { cbn. apply admit; assumption. } } } -Qed. - -Section squeeze. - Context {A:Type} (x:A). - Notation vec := (Vector.t A). - - Fixpoint squeeze {n} (v:vec n) (i:Fin.t (S n)) {struct i} : vec (S n) := - match i in Fin.t (S _n) return vec _n -> vec (S _n) - with - | @Fin.F1 n' => fun v' => Vector.cons _ x _ v' - | @Fin.FS n' i' => - fun v' => - match n' as _n return vec _n -> Fin.t _n -> vec (S _n) - with - | 0 => fun u i' => False_rect _ (fin_0_absurd i') - | S m => - fun (u:vec (S m)) => - match u in Vector.t _ (S _m) - return Fin.t (S _m) -> vec (S (S _m)) - with - | Vector.nil _ => tt - | Vector.cons _ h _ u' => - fun j' => Vector.cons _ h _ admit (* (squeeze u' j') *) - end - end v' i' - end v. -End squeeze. - -From Stdlib Require Import Program. -Lemma squeeze_nth (A:Type) (x:A) (n:nat) (v:Vector.t A n) p i : - Vector.nth (squeeze x v p) i = match lower p i with - | Some j => Vector.nth v j - | None => x - end. -Proof. - (* alternatively: [functional induction (lower p i) using lower_ind] *) - revert v. pattern n, p, i, (lower p i). - refine (@lower_ind _ _ _ _ _ _ n p i); - intros; cbn; auto. - - (*** Fails here with "Conversion test raised an anomaly" ***) - revert v. - admit. - admit. - admit. -Qed. diff --git a/stdlib/test-suite/bugs/bug_3652.v b/stdlib/test-suite/bugs/bug_3652.v deleted file mode 100644 index e9ac72ff538a..000000000000 --- a/stdlib/test-suite/bugs/bug_3652.v +++ /dev/null @@ -1,101 +0,0 @@ -From Stdlib Require Setoid. -From Stdlib Require ZArith. -Import ZArith. -From Stdlib Require Import Lia. - -Inductive Erasable(A : Set) : Prop := - erasable: A -> Erasable A. - -Arguments erasable [A] _. - -#[export] Hint Constructors Erasable. - -Scheme Erasable_elim := Induction for Erasable Sort Prop. - -Notation "## T" := (Erasable T) (at level 1, format "## T") : Erasable_scope. -Notation "# x" := (erasable x) (at level 1, format "# x") : Erasable_scope. -Open Scope Erasable_scope. - -Axiom Erasable_inj : forall {A : Set}{a b : A}, #a=#b -> a=b. - -Lemma Erasable_rw : forall (A: Set)(a b : A), (#a=#b) <-> (a=b). -Proof. - intros A a b. - split. - - apply Erasable_inj. - - congruence. -Qed. - -Open Scope Z_scope. -Opaque Z.mul. - -Infix "^" := Zpower_nat : Z_scope. - -Notation "f ; v <- x" := (let (v) := x in f) - (at level 199, left associativity) : Erasable_scope. -Notation "f ; < v" := (f ; v <- v) - (at level 199, left associativity) : Erasable_scope. -Notation "f |# v <- x" := (#f ; v <- x) - (at level 199, left associativity) : Erasable_scope. -Notation "f |# < v" := (#f ; < v) - (at level 199, left associativity) : Erasable_scope. - -Ltac name_evars id := - repeat match goal with |- context[?V] => - is_evar V; let H := fresh id in set (H:=V) in * end. - -Lemma Twoto0 : 2^0 = 1. -Proof. compute. reflexivity. Qed. - -Ltac ring_simplify' := rewrite ?Twoto0; ring_simplify. - -Definition mp2a1s(x : Z)(n : nat) := x * 2^n + (2^n-1). - -#[export] Hint Unfold mp2a1s. - -Definition zotval(n1s : nat)(is2 : bool)(next_value : Z) : Z := - 2 * mp2a1s next_value n1s + if is2 then 2 else 0. - -Inductive zot'(eis2 : ##bool)(value : ##Z) : Set := -| Zot'(is2 : bool) - (iseq : eis2=#is2) - {next_is2 : ##bool} - (ok : is2=true -> next_is2=#false) - {next_value : ##Z} - (n1s : nat) - (veq : value = (zotval n1s is2 next_value |# Type := -| Return : forall A, A -> Comp A -| Bind : forall A B, Comp A -> (A -> Comp B) -> Comp B -| Pick : forall A, Ensemble A -> Comp A. -Notation ret := Return. -Notation "x <- y ; z" := (Bind y%comp (fun x => z%comp)) - (at level 81, right associativity, - format "'[v' x <- y ; '/' z ']'") : comp_scope. -Axiom refine : forall {A} (old : Comp A) (new : Comp A), Prop. -Open Scope comp. -Axiom elements : forall {A} (ls : list A), Ensemble A. -Axiom to_list : forall {A} (S : Ensemble A), Comp (list A). -Axiom finite_set_handle_cardinal : refine (ret 0) (ret 0). -Definition sumUniqueSpec (ls : list nat) : Comp nat. - exact (ls' <- to_list (elements ls); - List.fold_right (fun a b' => Bind b' ((fun a b => ret (a + b)) a)) (ret 0) ls'). -Defined. -Axiom admit : forall {T}, T. -Definition sumUniqueImpl (ls : list nat) -: { c : _ | refine (sumUniqueSpec ls) (ret c) }%type. -Proof. - eexists. - match goal with - | [ |- refine ?a ?b ] => let a' := eval hnf in a in change (refine a' b) - end. - try setoid_rewrite (@finite_set_handle_cardinal). -Abort. diff --git a/stdlib/test-suite/bugs/bug_3938.v b/stdlib/test-suite/bugs/bug_3938.v deleted file mode 100644 index 867bd3ede6ef..000000000000 --- a/stdlib/test-suite/bugs/bug_3938.v +++ /dev/null @@ -1,9 +0,0 @@ -Require Import TestSuite.admit. -From Stdlib Require Import PeanoNat. -#[export] Hint Extern 1 => admit : typeclass_instances. -From Stdlib Require Import Setoid. -Goal forall a b (f : nat -> Set) (R : nat -> nat -> Prop), - Equivalence R -> R a b -> f a = f b. - intros a b f H. - intros. Fail rewrite H1. -Abort. diff --git a/stdlib/test-suite/bugs/bug_3978.v b/stdlib/test-suite/bugs/bug_3978.v deleted file mode 100644 index bc961ae42e36..000000000000 --- a/stdlib/test-suite/bugs/bug_3978.v +++ /dev/null @@ -1,27 +0,0 @@ -From Stdlib Require Import OrderedType. -From Stdlib Require Import OrderedTypeEx. - -Module Type M. Parameter X : Type. - -Declare Module Export XOrd : OrderedType - with Definition t := X - with Definition eq := @Logic.eq X. -End M. - -Module M' : M. - Definition X := nat. - - Module XOrd := Nat_as_OT. -End M'. - -Module Type MyOt. - Parameter t : Type. - Parameter eq : t -> t -> Prop. -End MyOt. - -Module Type M2. Parameter X : Type. - -Declare Module Export XOrd : MyOt - with Definition t := X - with Definition eq := @Logic.eq X. -End M2. diff --git a/stdlib/test-suite/bugs/bug_4035.v b/stdlib/test-suite/bugs/bug_4035.v deleted file mode 100644 index 273f11786293..000000000000 --- a/stdlib/test-suite/bugs/bug_4035.v +++ /dev/null @@ -1,14 +0,0 @@ -(* Supporting tactic notations within Ltac in the presence of an - "ident" entry which does not expect a fresh ident *) -(* Of course, this is a matter of convention of what "ident" is - supposed to denote, but in practice, it seems more convenient to - have less constraints on ident at interpretation time, as - otherwise more ad hoc entries would be necessary (as e.g. a special - "quantified_hypothesis" entry for dependent destruction). *) -From Stdlib Require Import Program. -Goal nat -> Type. - intro x. - lazymatch goal with - | [ x : nat |- _ ] => dependent destruction x - end. -Abort. diff --git a/stdlib/test-suite/bugs/bug_4057.v b/stdlib/test-suite/bugs/bug_4057.v deleted file mode 100644 index ea055bf251a9..000000000000 --- a/stdlib/test-suite/bugs/bug_4057.v +++ /dev/null @@ -1,211 +0,0 @@ -From Stdlib Require String. - -Set Implicit Arguments. - -Axiom falso : False. -Ltac admit := destruct falso. - -Reserved Notation "[ x ]". - -Record string_like (CharType : Type) := - { - String :> Type; - Singleton : CharType -> String where "[ x ]" := (Singleton x); - Empty : String; - Concat : String -> String -> String where "x ++ y" := (Concat x y); - bool_eq : String -> String -> bool; - bool_eq_correct : forall x y : String, bool_eq x y = true <-> x = y; - Length : String -> nat - }. - -Delimit Scope string_like_scope with string_like. -Bind Scope string_like_scope with String. -Arguments Length {_%_type_scope _} _%_string_like. -Infix "++" := (@Concat _ _) : string_like_scope. - -Definition str_le {CharType} {String : string_like CharType} (s1 s2 : String) - := Length s1 < Length s2 \/ s1 = s2. -Infix "Ć¢ā€°Ā¤s" := str_le (at level 70, right associativity). - -Module Export ContextFreeGrammar. - Import Stdlib.Strings.String. - Import Stdlib.Lists.List. - - Section cfg. - Variable CharType : Type. - - Section definitions. - - Inductive item := - | NonTerminal (name : string). - - Definition production := list item. - Definition productions := list production. - - Record grammar := - { - Start_symbol :> string; - Lookup :> string -> productions - }. - End definitions. - - Section parse. - Variable String : string_like CharType. - Variable G : grammar. - - Inductive parse_of : String -> productions -> Type := - | ParseHead : forall str pat pats, parse_of_production str pat - -> parse_of str (pat::pats) - | ParseTail : forall str pat pats, parse_of str pats - -> parse_of str (pat::pats) - with parse_of_production : String -> production -> Type := - | ParseProductionCons : forall str pat strs pats, - parse_of_item str pat - -> parse_of_production strs pats - -> parse_of_production (str ++ strs) (pat::pats) - with parse_of_item : String -> item -> Type := - | ParseNonTerminal : forall name str, parse_of str (Lookup G name) - -> parse_of_item str (NonTerminal -name). - End parse. - End cfg. - -End ContextFreeGrammar. -Module Export ContextFreeGrammarProperties. - - Section cfg. - Context CharType (String : string_like CharType) (G : grammar) - (P : String.string -> Type). - - Fixpoint Forall_parse_of {str pats} (p : parse_of String G str pats) - := match p with - | @ParseHead _ _ _ str pat pats p' - => Forall_parse_of_production p' - | @ParseTail _ _ _ _ _ _ p' - => Forall_parse_of p' - end - with Forall_parse_of_production {str pat} (p : parse_of_production String G -str pat) - := let Forall_parse_of_item {str it} (p : parse_of_item String G str -it) - := match p return Type with - | @ParseNonTerminal _ _ _ name str p' - => (P name * Forall_parse_of p')%type - end in - match p return Type with - | @ParseProductionCons _ _ _ str pat strs pats p' p'' - => (Forall_parse_of_item p' * Forall_parse_of_production -p'')%type - end. - - Definition Forall_parse_of_item {str it} (p : parse_of_item String G str it) - := match p return Type with - | @ParseNonTerminal _ _ _ name str p' - => (P name * Forall_parse_of p')%type - end. - End cfg. - -End ContextFreeGrammarProperties. - -Module Export DependentlyTyped. - Import Stdlib.Strings.String. - - Section recursive_descent_parser. - - Class parser_computational_predataT := - { nonterminal_names_listT : Type; - initial_nonterminal_names_data : nonterminal_names_listT; - is_valid_nonterminal_name : nonterminal_names_listT -> string -> bool; - remove_nonterminal_name : nonterminal_names_listT -> string -> -nonterminal_names_listT }. - - End recursive_descent_parser. - -End DependentlyTyped. -Import Stdlib.Strings.String. -Import Stdlib.Lists.List. - -Section cfg. - Context CharType (String : string_like CharType) (G : grammar). - Context (names_listT : Type) - (initial_names_data : names_listT) - (is_valid_name : names_listT -> string -> bool) - (remove_name : names_listT -> string -> names_listT). - - Inductive minimal_parse_of - : forall (str0 : String) (valid : names_listT) - (str : String), - productions -> Type := - | MinParseHead : forall str0 valid str pat pats, - @minimal_parse_of_production str0 valid str pat - -> @minimal_parse_of str0 valid str (pat::pats) - | MinParseTail : forall str0 valid str pat pats, - @minimal_parse_of str0 valid str pats - -> @minimal_parse_of str0 valid str (pat::pats) - with minimal_parse_of_production - : forall (str0 : String) (valid : names_listT) - (str : String), - production -> Type := - | MinParseProductionNil : forall str0 valid, - @minimal_parse_of_production str0 valid (Empty _) -nil - | MinParseProductionCons : forall str0 valid str strs pat pats, - str ++ strs Ć¢ā€°Ā¤s str0 - -> @minimal_parse_of_item str0 valid str pat - -> @minimal_parse_of_production str0 valid strs -pats - -> @minimal_parse_of_production str0 valid (str -++ strs) (pat::pats) - with minimal_parse_of_item - : forall (str0 : String) (valid : names_listT) - (str : String), - item -> Type := - | MinParseNonTerminal - : forall str0 valid str name, - @minimal_parse_of_name str0 valid str name - -> @minimal_parse_of_item str0 valid str (NonTerminal name) - with minimal_parse_of_name - : forall (str0 : String) (valid : names_listT) - (str : String), - string -> Type := - | MinParseNonTerminalStrLt - : forall str0 valid name str, - @minimal_parse_of str initial_names_data str (Lookup G name) - -> @minimal_parse_of_name str0 valid str name - | MinParseNonTerminalStrEq - : forall str valid name, - @minimal_parse_of str (remove_name valid name) str (Lookup G name) - -> @minimal_parse_of_name str valid str name. - Definition parse_of_item_name__of__minimal_parse_of_name - : forall {str0 valid str name} (p : @minimal_parse_of_name str0 valid str -name), - parse_of_item String G str (NonTerminal name). - Proof. - admit. - Defined. - -End cfg. - -Section recursive_descent_parser. - Context (CharType : Type) - (String : string_like CharType) - (G : grammar). - Context {premethods : parser_computational_predataT}. - Let P : string -> Prop. - Proof. - admit. - Defined. - - Let mp_parse_nonterminal_name str0 valid str nonterminal_name - := { p' : minimal_parse_of_name String G initial_nonterminal_names_data -remove_nonterminal_name str0 valid str nonterminal_name & Forall_parse_of_item -P (parse_of_item_name__of__minimal_parse_of_name p') }. - - Goal False. - Proof. - clear -mp_parse_nonterminal_name. - subst P. - simpl in *. - admit. - Qed. -End recursive_descent_parser. diff --git a/stdlib/test-suite/bugs/bug_4132.v b/stdlib/test-suite/bugs/bug_4132.v deleted file mode 100644 index e027dfeda8cc..000000000000 --- a/stdlib/test-suite/bugs/bug_4132.v +++ /dev/null @@ -1,31 +0,0 @@ - -From Stdlib Require Import ZArith Lia. -Open Scope Z_scope. - -(** bug 4132: omega was using "simpl" either on whole equations, or on - delimited but wrong spots. This was leading to unexpected reductions - when one atom (here [b]) is an evaluable reference instead of a variable. *) - -Lemma foo - (x y x' zxy zxy' z : Z) - (b := 5) - (Ry : - b <= y < b) - (Bx : x' <= b) - (H : - zxy' <= zxy) - (H' : zxy' <= x') : - b <= zxy. -Proof. -lia. (* was: Uncaught exception Invalid_argument("index out of bounds"). *) -Qed. - -Lemma foo2 x y (b := 5) (H1 : x <= y) (H2 : y <= b) : x <= b. -lia. (* Pierre L: according to a comment of bug report #4132, - this might have triggered "index out of bounds" in the past, - but I never managed to reproduce that in any version, - even before my fix. *) -Qed. - -Lemma foo3 x y (b := 0) (H1 : x <= y) (H2 : y <= b) : x <= b. -lia. (* Pierre L: according to a comment of bug report #4132, - this might have triggered "Failure(occurrence 2)" in the past, - but I never managed to reproduce that. *) -Qed. diff --git a/stdlib/test-suite/bugs/bug_4151.v b/stdlib/test-suite/bugs/bug_4151.v deleted file mode 100644 index 66469111440d..000000000000 --- a/stdlib/test-suite/bugs/bug_4151.v +++ /dev/null @@ -1,405 +0,0 @@ -Lemma foo (H : forall A, A) : forall A, A. - Show Universes. - eexact H. -Qed. - -(* File reduced by coq-bug-finder from original input, then from 6390 lines to 397 lines *) -(* coqc version 8.5beta1 (March 2015) compiled on Mar 17 2015 12:34:25 with OCaml 4.01.0 - coqtop version cagnode15:/afs/csail.mit.edu/u/j/jgross/coq-8.5,v8.5 (1b3759e78f227eb85a128c58b8ce8c11509dd8c3) *) -Axiom proof_admitted : False. -Tactic Notation "admit" := case proof_admitted. -From Stdlib Require Import SetoidList. -Import ListNotations. - -Global Set Implicit Arguments. -Global Set Asymmetric Patterns. - -Fixpoint combine_sig_helper {T} {P : T -> Prop} (ls : list T) : (forall x, In x ls -> P x) -> list (sig P). - admit. -Defined. - -Lemma Forall_forall1_transparent_helper_1 {A P} {x : A} {xs : list A} {l : list A} - (H : Forall P l) (H' : x::xs = l) -: P x. - admit. -Defined. -Lemma Forall_forall1_transparent_helper_2 {A P} {x : A} {xs : list A} {l : list A} - (H : Forall P l) (H' : x::xs = l) -: Forall P xs. - admit. -Defined. - -Fixpoint Forall_forall1_transparent {A} (P : A -> Prop) (l : list A) {struct l} -: Forall P l -> forall x, In x l -> P x - := match l as l return Forall P l -> forall x, In x l -> P x with - | nil => fun _ _ f => match f : False with end - | x::xs => fun H x' H' => - match H' with - | or_introl H'' => eq_rect x - P - (Forall_forall1_transparent_helper_1 H eq_refl) - _ - H'' - | or_intror H'' => @Forall_forall1_transparent A P xs (Forall_forall1_transparent_helper_2 H eq_refl) _ H'' - end - end. - -Definition combine_sig {T P ls} (H : List.Forall P ls) : list (@sig T P) - := combine_sig_helper ls (@Forall_forall1_transparent T P ls H). -Fixpoint Forall_tails {T} (P : list T -> Type) (ls : list T) : Type - := match ls with - | nil => P nil - | x::xs => (P (x::xs) * Forall_tails P xs)%type - end. - -Record string_like (CharType : Type) := - { - String :> Type; - Singleton : CharType -> String where "[ x ]" := (Singleton x); - Empty : String; - Concat : String -> String -> String where "x ++ y" := (Concat x y); - bool_eq : String -> String -> bool; - bool_eq_correct : forall x y : String, bool_eq x y = true <-> x = y; - Length : String -> nat; - Associativity : forall x y z, (x ++ y) ++ z = x ++ (y ++ z); - LeftId : forall x, Empty ++ x = x; - RightId : forall x, x ++ Empty = x; - Singleton_Length : forall x, Length (Singleton x) = 1; - Length_correct : forall s1 s2, Length s1 + Length s2 = Length (s1 ++ s2); - Length_Empty : Length Empty = 0; - Empty_Length : forall s1, Length s1 = 0 -> s1 = Empty; - Not_Singleton_Empty : forall x, Singleton x <> Empty; - SplitAt : nat -> String -> String * String; - SplitAt_correct : forall n s, fst (SplitAt n s) ++ snd (SplitAt n s) = s; - SplitAt_concat_correct : forall s1 s2, SplitAt (Length s1) (s1 ++ s2) = (s1, s2); - SplitAtLength_correct : forall n s, Length (fst (SplitAt n s)) = min (Length s) n - }. - -Delimit Scope string_like_scope with string_like. -Bind Scope string_like_scope with String. -Arguments Length {_%_type_scope _} _%_string_like. -Notation "[[ x ]]" := (@Singleton _ _ x) : string_like_scope. -Infix "++" := (@Concat _ _) : string_like_scope. -Infix "=s" := (@bool_eq _ _) (at level 70, right associativity) : string_like_scope. - -Definition str_le {CharType} {String : string_like CharType} (s1 s2 : String) - := Length s1 < Length s2 \/ s1 = s2. -Infix "ā‰¤s" := str_le (at level 70, right associativity). - -Record StringWithSplitState {CharType} (String : string_like CharType) (split_stateT : String -> Type) := - { string_val :> String; - state_val : split_stateT string_val }. - -Module Export ContextFreeGrammar. -From Stdlib Require Import String. - - Section cfg. - Variable CharType : Type. - - Section definitions. - - Inductive item := - | Terminal (_ : CharType) - | NonTerminal (_ : string). - - Definition production := list item. - Definition productions := list production. - - Record grammar := - { - Start_symbol :> string; - Lookup :> string -> productions; - Start_productions :> productions := Lookup Start_symbol; - Valid_nonterminals : list string; - Valid_productions : list productions := map Lookup Valid_nonterminals - }. - End definitions. - - End cfg. - -End ContextFreeGrammar. -Module Export BaseTypes. - Import Stdlib.Strings.String. - - Local Open Scope string_like_scope. - - Inductive any_grammar CharType := - | include_item (_ : item CharType) - | include_production (_ : production CharType) - | include_productions (_ : productions CharType) - | include_nonterminal (_ : string). - Global Coercion include_item : item >-> any_grammar. - Global Coercion include_production : production >-> any_grammar. - - Section recursive_descent_parser. - Context {CharType : Type} - {String : string_like CharType} - {G : grammar CharType}. - - Class parser_computational_predataT := - { nonterminals_listT : Type; - initial_nonterminals_data : nonterminals_listT; - is_valid_nonterminal : nonterminals_listT -> string -> bool; - remove_nonterminal : nonterminals_listT -> string -> nonterminals_listT; - nonterminals_listT_R : nonterminals_listT -> nonterminals_listT -> Prop; - remove_nonterminal_dec : forall ls nonterminal, - is_valid_nonterminal ls nonterminal = true - -> nonterminals_listT_R (remove_nonterminal ls nonterminal) ls; - ntl_wf : well_founded nonterminals_listT_R }. - - Class parser_computational_types_dataT := - { predata :: parser_computational_predataT; - split_stateT : String -> nonterminals_listT -> any_grammar CharType -> String -> Type }. - - Class parser_computational_dataT' `{parser_computational_types_dataT} := - { split_string_for_production - : forall (str0 : String) (valid : nonterminals_listT) (it : item CharType) (its : production CharType) (str : StringWithSplitState String (split_stateT str0 valid (it::its : production CharType))), - list (StringWithSplitState String (split_stateT str0 valid it) - * StringWithSplitState String (split_stateT str0 valid its)); - split_string_for_production_correct - : forall str0 valid it its str, - let P f := List.Forall f (@split_string_for_production str0 valid it its str) in - P (fun s1s2 => (fst s1s2 ++ snd s1s2 =s str) = true) }. - End recursive_descent_parser. - -End BaseTypes. -Import Stdlib.Strings.String. - -Section cfg. - Context CharType (String : string_like CharType) (G : grammar CharType). - Context (names_listT : Type) - (initial_names_data : names_listT) - (is_valid_name : names_listT -> string -> bool) - (remove_name : names_listT -> string -> names_listT) - (names_listT_R : names_listT -> names_listT -> Prop) - (remove_name_dec : forall ls name, - is_valid_name ls name = true - -> names_listT_R (remove_name ls name) ls) - (remove_name_1 - : forall ls ps ps', - is_valid_name (remove_name ls ps) ps' = true - -> is_valid_name ls ps' = true) - (remove_name_2 - : forall ls ps ps', - is_valid_name (remove_name ls ps) ps' = false - <-> is_valid_name ls ps' = false \/ ps = ps') - (ntl_wf : well_founded names_listT_R). - - Inductive minimal_parse_of - : forall (str0 : String) (valid : names_listT) - (str : String), - productions CharType -> Type := - | MinParseHead : forall str0 valid str pat pats, - @minimal_parse_of_production str0 valid str pat - -> @minimal_parse_of str0 valid str (pat::pats) - | MinParseTail : forall str0 valid str pat pats, - @minimal_parse_of str0 valid str pats - -> @minimal_parse_of str0 valid str (pat::pats) - with minimal_parse_of_production - : forall (str0 : String) (valid : names_listT) - (str : String), - production CharType -> Type := - | MinParseProductionNil : forall str0 valid, - @minimal_parse_of_production str0 valid (Empty _) nil - | MinParseProductionCons : forall str0 valid str strs pat pats, - str ++ strs ā‰¤s str0 - -> @minimal_parse_of_item str0 valid str pat - -> @minimal_parse_of_production str0 valid strs pats - -> @minimal_parse_of_production str0 valid (str ++ strs) (pat::pats) - with minimal_parse_of_item - : forall (str0 : String) (valid : names_listT) - (str : String), - item CharType -> Type := - | MinParseTerminal : forall str0 valid x, - @minimal_parse_of_item str0 valid [[ x ]]%string_like (Terminal x) - | MinParseNonTerminal - : forall str0 valid str name, - @minimal_parse_of_name str0 valid str name - -> @minimal_parse_of_item str0 valid str (NonTerminal CharType name) - with minimal_parse_of_name - : forall (str0 : String) (valid : names_listT) - (str : String), - string -> Type := - | MinParseNonTerminalStrLt - : forall str0 valid name str, - Length str < Length str0 - -> is_valid_name initial_names_data name = true - -> @minimal_parse_of str initial_names_data str (Lookup G name) - -> @minimal_parse_of_name str0 valid str name - | MinParseNonTerminalStrEq - : forall str valid name, - is_valid_name initial_names_data name = true - -> is_valid_name valid name = true - -> @minimal_parse_of str (remove_name valid name) str (Lookup G name) - -> @minimal_parse_of_name str valid str name. -End cfg. - -Local Coercion is_true : bool >-> Sortclass. - -Local Open Scope string_like_scope. - -Section general. - Context {CharType} {String : string_like CharType} {G : grammar CharType}. - - Class boolean_parser_dataT := - { predata :: parser_computational_predataT; - split_stateT : String -> Type; - data' :: _ := {| BaseTypes.predata := predata ; BaseTypes.split_stateT := fun _ _ _ => split_stateT |}; - split_string_for_production - : forall it its, - StringWithSplitState String split_stateT - -> list (StringWithSplitState String split_stateT * StringWithSplitState String split_stateT); - split_string_for_production_correct - : forall it its (str : StringWithSplitState String split_stateT), - let P f := List.Forall f (split_string_for_production it its str) in - P (fun s1s2 => - (fst s1s2 ++ snd s1s2 =s str) = true); - premethods :: parser_computational_dataT' - := @Build_parser_computational_dataT' - _ String data' - (fun _ _ => split_string_for_production) - (fun _ _ => split_string_for_production_correct) }. - - Definition split_list_completeT `{data : boolean_parser_dataT} - {str0 valid} - (str : StringWithSplitState String split_stateT) (pf : str ā‰¤s str0) - (split_list : list (StringWithSplitState String split_stateT * StringWithSplitState String split_stateT)) - (it : item CharType) (its : production CharType) - := ({ s1s2 : String * String - & (fst s1s2 ++ snd s1s2 =s str) - * (minimal_parse_of_item _ G initial_nonterminals_data is_valid_nonterminal remove_nonterminal str0 valid (fst s1s2) it) - * (minimal_parse_of_production _ G initial_nonterminals_data is_valid_nonterminal remove_nonterminal str0 valid (snd s1s2) its) }%type) - -> ({ s1s2 : StringWithSplitState String split_stateT * StringWithSplitState String split_stateT - & (In s1s2 split_list) - * (minimal_parse_of_item _ G initial_nonterminals_data is_valid_nonterminal remove_nonterminal str0 valid (fst s1s2) it) - * (minimal_parse_of_production _ G initial_nonterminals_data is_valid_nonterminal remove_nonterminal str0 valid (snd s1s2) its) }%type). -End general. - -Section recursive_descent_parser. - Context {CharType} - {String : string_like CharType} - {G : grammar CharType}. - Context `{data : @boolean_parser_dataT _ String}. - - Section bool. - Section parts. - Definition parse_item - (str_matches_nonterminal : string -> bool) - (str : StringWithSplitState String split_stateT) - (it : item CharType) - : bool - := match it with - | Terminal ch => [[ ch ]] =s str - | NonTerminal nt => str_matches_nonterminal nt - end. - - Section production. - Context {str0} - (parse_nonterminal - : forall (str : StringWithSplitState String split_stateT), - str ā‰¤s str0 - -> string - -> bool). - - Fixpoint parse_production - (str : StringWithSplitState String split_stateT) - (pf : str ā‰¤s str0) - (prod : production CharType) - : bool. - Proof. - refine - match prod with - | nil => - - str =s Empty _ - | it::its - => let parse_production' := fun str pf => parse_production str pf its in - fold_right - orb - false - (let mapF f := map f (combine_sig (split_string_for_production_correct it its str)) in - mapF (fun s1s2p => - (parse_item - (parse_nonterminal (fst (proj1_sig s1s2p)) _) - (fst (proj1_sig s1s2p)) - it) - && parse_production' (snd (proj1_sig s1s2p)) _)%bool) - end; - revert pf; clear; intros; admit. - Defined. - End production. - - End parts. - End bool. -End recursive_descent_parser. - -Section sound. - Context CharType (String : string_like CharType) (G : grammar CharType). - Context `{data : @boolean_parser_dataT CharType String}. - - Section production. - Context (str0 : String) - (parse_nonterminal : forall (str : StringWithSplitState String split_stateT), - str ā‰¤s str0 - -> string - -> bool). - - Definition parse_nonterminal_completeT P - := forall valid (str : StringWithSplitState String split_stateT) pf nonterminal (H_sub : P str0 valid nonterminal), - minimal_parse_of_name _ G initial_nonterminals_data is_valid_nonterminal remove_nonterminal str0 valid str nonterminal - -> @parse_nonterminal str pf nonterminal = true. - - Lemma parse_production_complete - valid Pv - (parse_nonterminal_complete : parse_nonterminal_completeT Pv) - (Hinit : forall str (pf : str ā‰¤s str0) nonterminal, - minimal_parse_of_name String G initial_nonterminals_data is_valid_nonterminal remove_nonterminal str0 valid str nonterminal - -> Pv str0 valid nonterminal) - (str : StringWithSplitState String split_stateT) (pf : str ā‰¤s str0) - (prod : production CharType) - (split_string_for_production_complete' - : forall str0 valid str pf, - Forall_tails - (fun prod' => - match prod' return Type with - | nil => True - | it::its => split_list_completeT (G := G) (valid := valid) (str0 := str0) str pf (split_string_for_production it its str) it its - end) - prod) - : minimal_parse_of_production _ G initial_nonterminals_data is_valid_nonterminal remove_nonterminal str0 valid str prod - -> parse_production parse_nonterminal str pf prod = true. - admit. - Defined. - End production. - Context (str0 : String) - (parse_nonterminal : forall (str : StringWithSplitState String split_stateT), - str ā‰¤s str0 - -> string - -> bool). - - Goal forall (a : production CharType), - (forall (str1 : String) (valid : nonterminals_listT) - (str : StringWithSplitState String split_stateT) - (pf : str ā‰¤s str1), - Forall_tails - (fun prod' : list (item CharType) => - match prod' with - | [] => True - | it :: its => - split_list_completeT (G := G) (valid := valid) str pf - (split_string_for_production it its str) it its - end) a) -> - forall (str : String) (pf : str ā‰¤s str0) (st : split_stateT str), - parse_production parse_nonterminal - {| string_val := str; state_val := st |} pf a = true. - Proof. - intros a X **. - eapply parse_production_complete. - Focus 3. - exact X. - Undo. - assumption. - Undo. - eassumption. (* no applicable tactic *) - Abort. -End sound. diff --git a/stdlib/test-suite/bugs/bug_4187.v b/stdlib/test-suite/bugs/bug_4187.v deleted file mode 100644 index 58e782f4af16..000000000000 --- a/stdlib/test-suite/bugs/bug_4187.v +++ /dev/null @@ -1,715 +0,0 @@ -(* Lifted from https://coq.inria.fr/bugs/show_bug.cgi?id=4187 *) -(* File reduced by coq-bug-finder from original input, then from 715 lines to 696 lines *) -(* coqc version 8.4pl5 (December 2014) compiled on Dec 28 2014 03:23:16 with OCaml 4.01.0 - coqtop version 8.4pl5 (December 2014) *) -Set Asymmetric Patterns. -Axiom proof_admitted : False. -Tactic Notation "admit" := case proof_admitted. -From Stdlib Require Import List. -From Stdlib Require Import Setoid. -From Stdlib Require Import BinNat. -From Stdlib Require Import Sumbool. -Global Set Implicit Arguments. -Global Generalizable All Variables. -Coercion is_true : bool >-> Sortclass. -Coercion bool_of_sumbool {A B} (x : {A} + {B}) : bool := if x then true else false. -Fixpoint ForallT {T} (P : T -> Type) (ls : list T) : Type - := match ls return Type with - | nil => True - | x::xs => (P x * ForallT P xs)%type - end. -Fixpoint Forall_tails {T} (P : list T -> Type) (ls : list T) : Type - := match ls with - | nil => P nil - | x::xs => (P (x::xs) * Forall_tails P xs)%type - end. - -Module Export ADTSynthesis_DOT_Common_DOT_Wf. -Module Export ADTSynthesis. -Module Export Common. -Module Export Wf. - -Section wf. - Section wf_prod. - Context A B (RA : relation A) (RB : relation B). -Definition prod_relation : relation (A * B). -exact (fun ab a'b' => - RA (fst ab) (fst a'b') \/ (fst a'b' = fst ab /\ RB (snd ab) (snd a'b'))). -Defined. - - Fixpoint well_founded_prod_relation_helper - a b - (wf_A : Acc RA a) (wf_B : well_founded RB) {struct wf_A} - : Acc prod_relation (a, b) - := match wf_A with - | Acc_intro fa => (fix wf_B_rec b' (wf_B' : Acc RB b') : Acc prod_relation (a, b') - := Acc_intro - _ - (fun ab => - match ab as ab return prod_relation ab (a, b') -> Acc prod_relation ab with - | (a'', b'') => - fun pf => - match pf with - | or_introl pf' - => @well_founded_prod_relation_helper - _ _ - (fa _ pf') - wf_B - | or_intror (conj pfa pfb) - => match wf_B' with - | Acc_intro fb - => eq_rect - _ - (fun a'' => Acc prod_relation (a'', b'')) - (wf_B_rec _ (fb _ pfb)) - _ - pfa - end - end - end) - ) b (wf_B b) - end. - - Definition well_founded_prod_relation : well_founded RA -> well_founded RB -> well_founded prod_relation. - Proof. - intros wf_A wf_B [a b]; hnf in *. - apply well_founded_prod_relation_helper; auto. - Defined. - End wf_prod. - - Section wf_projT1. - Context A (B : A -> Type) (R : relation A). -Definition projT1_relation : relation (sigT B). -exact (fun ab a'b' => - R (projT1 ab) (projT1 a'b')). -Defined. - - Definition well_founded_projT1_relation : well_founded R -> well_founded projT1_relation. - Proof. - intros wf [a b]; hnf in *. - induction (wf a) as [a H IH]. - constructor. - intros y r. - specialize (IH _ r (projT2 y)). - destruct y. - exact IH. - Defined. - End wf_projT1. -End wf. - -Section Fix3. - Context A (B : A -> Type) (C : forall a, B a -> Type) (D : forall a b, C a b -> Type) - (R : A -> A -> Prop) (Rwf : well_founded R) - (P : forall a b c, D a b c -> Type) - (F : forall x : A, (forall y : A, R y x -> forall b c d, P y b c d) -> forall b c d, P x b c d). -Definition Fix3 a b c d : @P a b c d. -exact (@Fix { a : A & { b : B a & { c : C b & D c } } } - (fun x y => R (projT1 x) (projT1 y)) - (well_founded_projT1_relation Rwf) - (fun abcd => P (projT2 (projT2 (projT2 abcd)))) - (fun x f => @F (projT1 x) (fun y r b c d => f (existT _ y (existT _ b (existT _ c d))) r) _ _ _) - (existT _ a (existT _ b (existT _ c d)))). -Defined. -End Fix3. - -End Wf. - -End Common. - -End ADTSynthesis. - -End ADTSynthesis_DOT_Common_DOT_Wf. - -Module Export ADTSynthesis_DOT_Parsers_DOT_StringLike_DOT_Core. -Module Export ADTSynthesis. -Module Export Parsers. -Module Export StringLike. -Module Export Core. -Import Stdlib.Setoids.Setoid. -Import Stdlib.Classes.Morphisms. - - - -Module Export StringLike. - Class StringLike {Char : Type} := - { - String :: Type; - is_char : String -> Char -> bool; - length : String -> nat; - take : nat -> String -> String; - drop : nat -> String -> String; - bool_eq : String -> String -> bool; - beq : relation String := fun x y => bool_eq x y - }. - - Arguments StringLike : clear implicits. - Infix "=s" := (@beq _ _) (at level 70, no associativity) : type_scope. - Notation "s ~= [ ch ]" := (is_char s ch) (at level 70, no associativity) : string_like_scope. - Local Open Scope string_like_scope. - - Definition str_le `{StringLike Char} (s1 s2 : String) - := length s1 < length s2 \/ s1 =s s2. - Infix "ā‰¤s" := str_le (at level 70, right associativity). - - Class StringLikeProperties (Char : Type) `{StringLike Char} := - { - singleton_unique : forall s ch ch', s ~= [ ch ] -> s ~= [ ch' ] -> ch = ch'; - length_singleton : forall s ch, s ~= [ ch ] -> length s = 1; - bool_eq_char : forall s s' ch, s ~= [ ch ] -> s' ~= [ ch ] -> s =s s'; - is_char_Proper :: Proper (beq ==> eq ==> eq) is_char; - length_Proper :: Proper (beq ==> eq) length; - take_Proper :: Proper (eq ==> beq ==> beq) take; - drop_Proper :: Proper (eq ==> beq ==> beq) drop; - bool_eq_Equivalence :: Equivalence beq; - bool_eq_empty : forall str str', length str = 0 -> length str' = 0 -> str =s str'; - take_short_length : forall str n, n <= length str -> length (take n str) = n; - take_long : forall str n, length str <= n -> take n str =s str; - take_take : forall str n m, take n (take m str) =s take (min n m) str; - drop_length : forall str n, length (drop n str) = length str - n; - drop_0 : forall str, drop 0 str =s str; - drop_drop : forall str n m, drop n (drop m str) =s drop (n + m) str; - drop_take : forall str n m, drop n (take m str) =s take (m - n) (drop n str); - take_drop : forall str n m, take n (drop m str) =s drop m (take (n + m) str) - }. - - Arguments StringLikeProperties Char {_}. -End StringLike. - -End Core. - -End StringLike. - -End Parsers. - -End ADTSynthesis. - -End ADTSynthesis_DOT_Parsers_DOT_StringLike_DOT_Core. - -Module Export ADTSynthesis. -Module Export Parsers. -Module Export ContextFreeGrammar. -From Stdlib Require Import String. -From Stdlib Require Import List. -Export ADTSynthesis.Parsers.StringLike.Core. -Import ADTSynthesis.Common. - -Local Open Scope string_like_scope. - -Section cfg. - Context {Char : Type}. - - Section definitions. - - Inductive item := - | Terminal (_ : Char) - | NonTerminal (_ : string). - - Definition production := list item. - Definition productions := list production. - - Record grammar := - { - Start_symbol :> string; - Lookup :> string -> productions; - Start_productions :> productions := Lookup Start_symbol; - Valid_nonterminals : list string; - Valid_productions : list productions := map Lookup Valid_nonterminals - }. - End definitions. - - Section parse. - Context {HSL : StringLike Char}. - Variable G : grammar. - - Inductive parse_of (str : String) : productions -> Type := - | ParseHead : forall pat pats, parse_of_production str pat - -> parse_of str (pat::pats) - | ParseTail : forall pat pats, parse_of str pats - -> parse_of str (pat::pats) - with parse_of_production (str : String) : production -> Type := - | ParseProductionNil : length str = 0 -> parse_of_production str nil - | ParseProductionCons : forall n pat pats, - parse_of_item (take n str) pat - -> parse_of_production (drop n str) pats - -> parse_of_production str (pat::pats) - with parse_of_item (str : String) : item -> Type := - | ParseTerminal : forall ch, str ~= [ ch ] -> parse_of_item str (Terminal ch) - | ParseNonTerminal : forall nt, parse_of str (Lookup G nt) - -> parse_of_item str (NonTerminal nt). - End parse. -End cfg. - -Arguments item _ : clear implicits. -Arguments production _ : clear implicits. -Arguments productions _ : clear implicits. -Arguments grammar _ : clear implicits. - -End ContextFreeGrammar. -End Parsers. -End ADTSynthesis. - -Module Export BaseTypes. - -Section recursive_descent_parser. - - Class parser_computational_predataT := - { nonterminals_listT : Type; - initial_nonterminals_data : nonterminals_listT; - is_valid_nonterminal : nonterminals_listT -> String.string -> bool; - remove_nonterminal : nonterminals_listT -> String.string -> nonterminals_listT; - nonterminals_listT_R : nonterminals_listT -> nonterminals_listT -> Prop; - remove_nonterminal_dec : forall ls nonterminal, - is_valid_nonterminal ls nonterminal - -> nonterminals_listT_R (remove_nonterminal ls nonterminal) ls; - ntl_wf : well_founded nonterminals_listT_R }. - - Class parser_removal_dataT' `{predata : parser_computational_predataT} := - { remove_nonterminal_1 - : forall ls ps ps', - is_valid_nonterminal (remove_nonterminal ls ps) ps' - -> is_valid_nonterminal ls ps'; - remove_nonterminal_2 - : forall ls ps ps', - is_valid_nonterminal (remove_nonterminal ls ps) ps' = false - <-> is_valid_nonterminal ls ps' = false \/ ps = ps' }. -End recursive_descent_parser. - -End BaseTypes. -Import Stdlib.Lists.List. -Import ADTSynthesis.Parsers.ContextFreeGrammar. - -Local Open Scope string_like_scope. - -Section cfg. - Context {Char} {HSL : StringLike Char} {G : grammar Char}. - Context {predata : @parser_computational_predataT} - {rdata' : @parser_removal_dataT' predata}. - - Inductive minimal_parse_of - : forall (str0 : String) (valid : nonterminals_listT) - (str : String), - productions Char -> Type := - | MinParseHead : forall str0 valid str pat pats, - @minimal_parse_of_production str0 valid str pat - -> @minimal_parse_of str0 valid str (pat::pats) - | MinParseTail : forall str0 valid str pat pats, - @minimal_parse_of str0 valid str pats - -> @minimal_parse_of str0 valid str (pat::pats) - with minimal_parse_of_production - : forall (str0 : String) (valid : nonterminals_listT) - (str : String), - production Char -> Type := - | MinParseProductionNil : forall str0 valid str, - length str = 0 - -> @minimal_parse_of_production str0 valid str nil - | MinParseProductionCons : forall str0 valid str n pat pats, - str ā‰¤s str0 - -> @minimal_parse_of_item str0 valid (take n str) pat - -> @minimal_parse_of_production str0 valid (drop n str) pats - -> @minimal_parse_of_production str0 valid str (pat::pats) - with minimal_parse_of_item - : forall (str0 : String) (valid : nonterminals_listT) - (str : String), - item Char -> Type := - | MinParseTerminal : forall str0 valid str ch, - str ~= [ ch ] - -> @minimal_parse_of_item str0 valid str (Terminal ch) - | MinParseNonTerminal - : forall str0 valid str (nt : String.string), - @minimal_parse_of_nonterminal str0 valid str nt - -> @minimal_parse_of_item str0 valid str (NonTerminal nt) - with minimal_parse_of_nonterminal - : forall (str0 : String) (valid : nonterminals_listT) - (str : String), - String.string -> Type := - | MinParseNonTerminalStrLt - : forall str0 valid (nt : String.string) str, - length str < length str0 - -> is_valid_nonterminal initial_nonterminals_data nt - -> @minimal_parse_of str initial_nonterminals_data str (Lookup G nt) - -> @minimal_parse_of_nonterminal str0 valid str nt - | MinParseNonTerminalStrEq - : forall str0 str valid nonterminal, - str =s str0 - -> is_valid_nonterminal initial_nonterminals_data nonterminal - -> is_valid_nonterminal valid nonterminal - -> @minimal_parse_of str0 (remove_nonterminal valid nonterminal) str (Lookup G nonterminal) - -> @minimal_parse_of_nonterminal str0 valid str nonterminal. -End cfg. -Import ADTSynthesis.Common. - -Section general. - Context {Char} {HSL : StringLike Char} {G : grammar Char}. - - Class boolean_parser_dataT := - { predata :: parser_computational_predataT; - split_string_for_production - : item Char -> production Char -> String -> list nat }. - - Global Coercion predata : boolean_parser_dataT >-> parser_computational_predataT. - - Definition split_list_completeT `{data : @parser_computational_predataT} - {str0 valid} - (it : item Char) (its : production Char) - (str : String) - (pf : str ā‰¤s str0) - (split_list : list nat) - - := ({ n : nat - & (minimal_parse_of_item (G := G) (predata := data) str0 valid (take n str) it) - * (minimal_parse_of_production (G := G) str0 valid (drop n str) its) }%type) - -> ({ n : nat - & (In n split_list) - * (minimal_parse_of_item (G := G) str0 valid (take n str) it) - * (minimal_parse_of_production (G := G) str0 valid (drop n str) its) }%type). - - Class boolean_parser_completeness_dataT' `{data : boolean_parser_dataT} := - { split_string_for_production_complete - : forall str0 valid str (pf : str ā‰¤s str0) nt, - is_valid_nonterminal initial_nonterminals_data nt - -> ForallT - (Forall_tails - (fun prod - => match prod return Type with - | nil => True - | it::its - => @split_list_completeT data str0 valid it its str pf (split_string_for_production it its str) - end)) - (Lookup G nt) }. -End general. - -Module Export BooleanRecognizer. -Import PeanoNat. -Import Compare_dec. -Import Wf_nat. - -Section recursive_descent_parser. - Context {Char} {HSL : StringLike Char} {HSLP : StringLikeProperties Char} {G : grammar Char}. - Context {data : @boolean_parser_dataT Char _}. - - Section bool. - Section parts. -Definition parse_item - (str_matches_nonterminal : String.string -> bool) - (str : String) - (it : item Char) - : bool. -Admitted. - - Section production. - Context {str0} - (parse_nonterminal - : forall (str : String), - str ā‰¤s str0 - -> String.string - -> bool). - - Fixpoint parse_production - (str : String) - (pf : str ā‰¤s str0) - (prod : production Char) - : bool. - Proof. - refine - match prod with - | nil => - - Nat.eq_dec (length str) 0 - | it::its - => let parse_production' := fun str pf => parse_production str pf its in - fold_right - orb - false - (map (fun n => - (parse_item - (parse_nonterminal (str := take n str) _) - (take n str) - it) - && parse_production' (drop n str) _)%bool - (split_string_for_production it its str)) - end; - revert pf; clear -HSLP; intros; admit. - Defined. - End production. - - Section productions. - Context {str0} - (parse_nonterminal - : forall (str : String) - (pf : str ā‰¤s str0), - String.string -> bool). -Definition parse_productions - (str : String) - (pf : str ā‰¤s str0) - (prods : productions Char) - : bool. -exact (fold_right orb - false - (map (parse_production parse_nonterminal pf) - prods)). -Defined. - End productions. - - Section nonterminals. - Section step. - Context {str0 valid} - (parse_nonterminal - : forall (p : String * nonterminals_listT), - prod_relation (ltof _ length) nonterminals_listT_R p (str0, valid) - -> forall str : String, - str ā‰¤s fst p -> String.string -> bool). - - Definition parse_nonterminal_step - (str : String) - (pf : str ā‰¤s str0) - (nt : String.string) - : bool. - Proof. - refine - (if lt_dec (length str) (length str0) - then - parse_productions - (@parse_nonterminal - (str : String, initial_nonterminals_data) - (or_introl _)) - (or_intror (reflexivity _)) - (Lookup G nt) - else - if Sumbool.sumbool_of_bool (is_valid_nonterminal valid nt) - then - parse_productions - (@parse_nonterminal - (str0 : String, remove_nonterminal valid nt) - (or_intror (conj eq_refl (remove_nonterminal_dec _ nt _)))) - (str := str) - _ - (Lookup G nt) - else - false); - assumption. - Defined. - End step. - - Section wf. -Definition parse_nonterminal_or_abort - : forall (p : String * nonterminals_listT) - (str : String), - str ā‰¤s fst p - -> String.string - -> bool. -exact (Fix3 - _ _ _ - (well_founded_prod_relation - (well_founded_ltof _ length) - ntl_wf) - _ - (fun sl => @parse_nonterminal_step (fst sl) (snd sl))). -Defined. -Definition parse_nonterminal - (str : String) - (nt : String.string) - : bool. -exact (@parse_nonterminal_or_abort - (str : String, initial_nonterminals_data) str - (or_intror (reflexivity _)) nt). -Defined. - End wf. - End nonterminals. - End parts. - End bool. -End recursive_descent_parser. - -Section cfg. - Context {Char} {HSL : StringLike Char} {HSLP : @StringLikeProperties Char HSL} (G : grammar Char). - - Section definitions. - Context (P : String -> String.string -> Type). - - Definition Forall_parse_of_item' - (Forall_parse_of : forall {str pats} (p : parse_of G str pats), Type) - {str it} (p : parse_of_item G str it) - := match p return Type with - | ParseTerminal ch pf => unit - | ParseNonTerminal nt p' - => (P str nt * Forall_parse_of p')%type - end. - - Fixpoint Forall_parse_of {str pats} (p : parse_of G str pats) - := match p with - | ParseHead pat pats p' - => Forall_parse_of_production p' - | ParseTail _ _ p' - => Forall_parse_of p' - end - with Forall_parse_of_production {str pat} (p : parse_of_production G str pat) - := match p return Type with - | ParseProductionNil pf => unit - | ParseProductionCons pat strs pats p' p'' - => (Forall_parse_of_item' (@Forall_parse_of) p' * Forall_parse_of_production p'')%type - end. - - Definition Forall_parse_of_item {str it} (p : parse_of_item G str it) - := @Forall_parse_of_item' (@Forall_parse_of) str it p. - End definitions. - - End cfg. - -Section recursive_descent_parser_list. - Context {Char} {HSL : StringLike Char} {HLSP : StringLikeProperties Char} {G : grammar Char}. -Definition rdp_list_nonterminals_listT : Type. -exact (list String.string). -Defined. -Definition rdp_list_is_valid_nonterminal : rdp_list_nonterminals_listT -> String.string -> bool. -admit. -Defined. -Definition rdp_list_remove_nonterminal : rdp_list_nonterminals_listT -> String.string -> rdp_list_nonterminals_listT. -admit. -Defined. -Definition rdp_list_nonterminals_listT_R : rdp_list_nonterminals_listT -> rdp_list_nonterminals_listT -> Prop. -exact (ltof _ (@List.length _)). -Defined. - Lemma rdp_list_remove_nonterminal_dec : forall ls prods, - @rdp_list_is_valid_nonterminal ls prods = true - -> @rdp_list_nonterminals_listT_R (@rdp_list_remove_nonterminal ls prods) ls. -admit. -Defined. - Lemma rdp_list_ntl_wf : well_founded rdp_list_nonterminals_listT_R. - Proof. - unfold rdp_list_nonterminals_listT_R. - intro. - apply well_founded_ltof. - Defined. - - Global Instance rdp_list_predata : parser_computational_predataT - := { nonterminals_listT := rdp_list_nonterminals_listT; - initial_nonterminals_data := Valid_nonterminals G; - is_valid_nonterminal := rdp_list_is_valid_nonterminal; - remove_nonterminal := rdp_list_remove_nonterminal; - nonterminals_listT_R := rdp_list_nonterminals_listT_R; - remove_nonterminal_dec := rdp_list_remove_nonterminal_dec; - ntl_wf := rdp_list_ntl_wf }. -End recursive_descent_parser_list. - -Section sound. - Section general. - Context {Char} {HSL : StringLike Char} {HSLP : StringLikeProperties Char} (G : grammar Char). - Context {data : @boolean_parser_dataT Char _} - {cdata : @boolean_parser_completeness_dataT' Char _ G data} - {rdata : @parser_removal_dataT' predata}. - - Section parts. - - Section nonterminals. - Section wf. - - Lemma parse_nonterminal_sound - (str : String) (nonterminal : String.string) - : parse_nonterminal (G := G) str nonterminal - = true - -> parse_of_item G str (NonTerminal nonterminal). -admit. -Defined. - End wf. - End nonterminals. - End parts. - End general. -End sound. - -Import Stdlib.Strings.String. -Import ADTSynthesis.Parsers.ContextFreeGrammar. - -Fixpoint list_to_productions {T} (default : T) (ls : list (string * T)) : string -> T - := match ls with - | nil => fun _ => default - | (str, t)::ls' => fun s => if string_dec str s - then t - else list_to_productions default ls' s - end. - -Fixpoint list_to_grammar {T} (default : productions T) (ls : list (string * productions T)) : grammar T - := {| Start_symbol := hd ""%string (map (@fst _ _) ls); - Lookup := list_to_productions default ls; - Valid_nonterminals := map (@fst _ _) ls |}. - -Section interface. - Context {Char} (G : grammar Char). -Definition production_is_reachable (p : production Char) : Prop. -admit. -Defined. -Definition split_list_is_complete `{HSL : StringLike Char} (str : String) (it : item Char) (its : production Char) - (splits : list nat) - : Prop. -exact (forall n, - n <= length str - -> parse_of_item G (take n str) it - -> parse_of_production G (drop n str) its - -> production_is_reachable (it::its) - -> List.In n splits). -Defined. - - Record Splitter := - { - string_type :> StringLike Char; - splits_for : String -> item Char -> production Char -> list nat; - - string_type_properties :> StringLikeProperties Char; - splits_for_complete : forall str it its, - split_list_is_complete str it its (splits_for str it its) - - }. - Global Existing Instance string_type_properties. - - Record Parser (HSL : StringLike Char) := - { - has_parse : @String Char HSL -> bool; - - has_parse_sound : forall str, - has_parse str = true - -> parse_of_item G str (NonTerminal (Start_symbol G)); - - has_parse_complete : forall str (p : parse_of_item G str (NonTerminal (Start_symbol G))), - Forall_parse_of_item - (fun _ nt => List.In nt (Valid_nonterminals G)) - p - -> has_parse str = true - }. -End interface. - -Module Export ParserImplementation. - -Section implementation. - Context {Char} {G : grammar Char}. - Context (splitter : Splitter G). - - Local Instance parser_data : @boolean_parser_dataT Char _ := - { predata := rdp_list_predata (G := G); - split_string_for_production it its str - := splits_for splitter str it its }. - - Program Definition parser : Parser G splitter - := {| has_parse str := parse_nonterminal (G := G) (data := parser_data) str (Start_symbol G); - has_parse_sound str Hparse := parse_nonterminal_sound G _ _ Hparse; - has_parse_complete str p Hp := _ |}. - Next Obligation. -admit. -Defined. -End implementation. - -End ParserImplementation. - -Section implementation. - Context {Char} {ls : list (String.string * productions Char)}. - Local Notation G := (list_to_grammar (nil::nil) ls) (only parsing). - Context (splitter : Splitter G). - - Local Instance parser_data : @boolean_parser_dataT Char _ := parser_data splitter. - - Goal forall str : @String Char splitter, - let G' := - @BooleanRecognizer.parse_nonterminal Char splitter splitter G parser_data str G = true in - G'. - intros str G'. - Timeout 1 assert (pf' : G' -> Prop) by abstract admit. - Abort. -End implementation. -End BooleanRecognizer. diff --git a/stdlib/test-suite/bugs/bug_4232.v b/stdlib/test-suite/bugs/bug_4232.v deleted file mode 100644 index 22958245e3fa..000000000000 --- a/stdlib/test-suite/bugs/bug_4232.v +++ /dev/null @@ -1,20 +0,0 @@ -From Stdlib Require Import Setoid Morphisms Vector. - -Class Equiv A := equiv : A -> A -> Prop. -Class Setoid A `{Equiv A} := setoid_equiv :: Equivalence (equiv). - -Global Declare Instance vec_equiv {A} `{Equiv A} {n}: Equiv (Vector.t A n). -Global Declare Instance vec_setoid A `{Setoid A} n : Setoid (Vector.t A n). - -Global Declare Instance tl_proper1 {A} `{Equiv A} n: - Proper ((equiv) ==> (equiv)) - (@tl A n). - -Lemma test: - forall {A} `{Setoid A} n (xa ya: Vector.t A (S n)), - (equiv xa ya) -> equiv (tl xa) (tl ya). -Proof. - intros A R HA n xa ya Heq. - setoid_rewrite Heq. - reflexivity. -Qed. diff --git a/stdlib/test-suite/bugs/bug_4280.v b/stdlib/test-suite/bugs/bug_4280.v deleted file mode 100644 index 817b3b0fa09e..000000000000 --- a/stdlib/test-suite/bugs/bug_4280.v +++ /dev/null @@ -1,24 +0,0 @@ -From Stdlib Require Import ZArith Lia. -From Stdlib Require Import Eqdep_dec. -Local Open Scope Z_scope. - -Definition t := { n: Z | n > 1 }. - -Program Definition two : t := 2. -Next Obligation. lia. Qed. - -Program Definition t_eq (x y: t) : {x=y} + {x<>y} := - if Z.eq_dec (proj1_sig x) (proj1_sig y) then left _ else right _. -Next Obligation. - destruct x as [x Px], y as [y Py]. simpl in e; subst y. - f_equal. apply UIP_dec. decide equality. -Qed. -Next Obligation. - congruence. -Qed. - -Definition t_list_eq: forall (x y: list t), {x=y} + {x<>y}. -Proof. decide equality. apply t_eq. Defined. - -Goal match t_list_eq (two::nil) (two::nil) with left _ => True | right _ => False end. -Proof. exact I. Qed. diff --git a/stdlib/test-suite/bugs/bug_4306.v b/stdlib/test-suite/bugs/bug_4306.v deleted file mode 100644 index c686a467b64f..000000000000 --- a/stdlib/test-suite/bugs/bug_4306.v +++ /dev/null @@ -1,32 +0,0 @@ -From Stdlib Require Import List. -From Stdlib Require Import Arith. -From Stdlib Require Import Recdef. -From Stdlib Require Import Lia. - -Function foo (xys : (list nat * list nat)) {measure (fun xys => length (fst xys) + length (snd xys))} : list nat := - match xys with - | (nil, _) => snd xys - | (_, nil) => fst xys - | (x :: xs', y :: ys') => match Nat.compare x y with - | Lt => x :: foo (xs', y :: ys') - | Eq => x :: foo (xs', ys') - | Gt => y :: foo (x :: xs', ys') - end - end. -Proof. - all: simpl; lia. -Qed. - -Function bar (xys : (list nat * list nat)) {measure (fun xys => length (fst xys) + length (snd xys))} : list nat := - let (xs, ys) := xys in - match (xs, ys) with - | (nil, _) => ys - | (_, nil) => xs - | (x :: xs', y :: ys') => match Nat.compare x y with - | Lt => x :: foo (xs', ys) - | Eq => x :: foo (xs', ys') - | Gt => y :: foo (xs, ys') - end - end. -Proof. -Defined. diff --git a/stdlib/test-suite/bugs/bug_4397.v b/stdlib/test-suite/bugs/bug_4397.v deleted file mode 100644 index 0d56bf08c774..000000000000 --- a/stdlib/test-suite/bugs/bug_4397.v +++ /dev/null @@ -1,4 +0,0 @@ -From Stdlib Require Import Equality. -Theorem foo (u : unit) (H : u = u) : True. -dependent destruction H. -Abort. diff --git a/stdlib/test-suite/bugs/bug_4433.v b/stdlib/test-suite/bugs/bug_4433.v deleted file mode 100644 index f5f176412edc..000000000000 --- a/stdlib/test-suite/bugs/bug_4433.v +++ /dev/null @@ -1,30 +0,0 @@ -From Stdlib Require Import Arith. -From Stdlib.Init Require Import Wf. -Axiom proof_admitted : False. -Goal exists x y z : nat, Fix - Wf_nat.lt_wf - (fun _ => nat -> nat) - (fun x' f => match x' as x'0 - return match x'0 with - | 0 => True - | S x'' => x'' < x' - end - -> nat -> nat - with - | 0 => fun _ _ => 0 - | S x'' => f x'' - end - (match x' with - | 0 => I - | S x'' => (Nat.lt_succ_diag_r _) - end)) - z - y - = 0. -Proof. - do 3 (eexists; [ shelve.. | ]). - match goal with |- ?G => let G' := (eval lazy in G) in change G with G' end. - case proof_admitted. - Unshelve. - all:constructor. -Defined. diff --git a/stdlib/test-suite/bugs/bug_4456.v b/stdlib/test-suite/bugs/bug_4456.v deleted file mode 100644 index 1560a3c94677..000000000000 --- a/stdlib/test-suite/bugs/bug_4456.v +++ /dev/null @@ -1,652 +0,0 @@ - -(* File reduced by coq-bug-finder from original input, then from 2475 lines to 729 lines, then from 746 lines to 658 lines, then from 675 lines to 658 lines *) -(* coqc version 8.5beta3 (November 2015) compiled on Nov 11 2015 18:23:0 with OCaml 4.01.0 - coqtop version 8.5beta3 (November 2015) *) -(* Variable P : forall n m : nat, n = m -> Prop. *) -(* Axiom Prefl : forall n : nat, P n n eq_refl. *) -Axiom proof_admitted : False. - -Tactic Notation "admit" := case proof_admitted. - -From Stdlib Require Program. -From Stdlib Require String. -From Stdlib Require Lia. -Module Export Fiat_DOT_Common. -Module Export Fiat. -Module Common. -Import Stdlib.Lists.List. -Export Program. - -Global Set Implicit Arguments. - -Global Coercion is_true : bool >-> Sortclass. -Coercion bool_of_sum {A B} (b : sum A B) : bool := if b then true else false. - -Fixpoint ForallT {T} (P : T -> Type) (ls : list T) : Type - := match ls return Type with - | nil => True - | x::xs => (P x * ForallT P xs)%type - end. -Fixpoint Forall_tails {T} (P : list T -> Type) (ls : list T) : Type - := match ls with - | nil => P nil - | x::xs => (P (x::xs) * Forall_tails P xs)%type - end. - -End Common. - -End Fiat. - -End Fiat_DOT_Common. -Module Export Fiat_DOT_Parsers_DOT_StringLike_DOT_Core. -Module Export Fiat. -Module Export Parsers. -Module Export StringLike. -Module Export Core. -Import Stdlib.Relations.Relation_Definitions. -Import Stdlib.Classes.Morphisms. - -Local Coercion is_true : bool >-> Sortclass. - -Module Export StringLike. - Class StringLike {Char : Type} := - { - String :: Type; - is_char : String -> Char -> bool; - length : String -> nat; - take : nat -> String -> String; - drop : nat -> String -> String; - get : nat -> String -> option Char; - unsafe_get : nat -> String -> Char; - bool_eq : String -> String -> bool; - beq : relation String := fun x y => bool_eq x y - }. - - Arguments StringLike : clear implicits. - Infix "=s" := (@beq _ _) (at level 70, no associativity) : type_scope. - Notation "s ~= [ ch ]" := (is_char s ch) (at level 70, no associativity) : string_like_scope. - Local Open Scope string_like_scope. - - Class StringLikeProperties (Char : Type) `{StringLike Char} := - { - singleton_unique : forall s ch ch', s ~= [ ch ] -> s ~= [ ch' ] -> ch = ch'; - singleton_exists : forall s, length s = 1 -> exists ch, s ~= [ ch ]; - get_0 : forall s ch, take 1 s ~= [ ch ] <-> get 0 s = Some ch; - get_S : forall n s, get (S n) s = get n (drop 1 s); - unsafe_get_correct : forall n s ch, get n s = Some ch -> unsafe_get n s = ch; - length_singleton : forall s ch, s ~= [ ch ] -> length s = 1; - bool_eq_char : forall s s' ch, s ~= [ ch ] -> s' ~= [ ch ] -> s =s s'; - is_char_Proper :: Proper (beq ==> eq ==> eq) is_char; - length_Proper :: Proper (beq ==> eq) length; - take_Proper :: Proper (eq ==> beq ==> beq) take; - drop_Proper :: Proper (eq ==> beq ==> beq) drop; - bool_eq_Equivalence :: Equivalence beq; - bool_eq_empty : forall str str', length str = 0 -> length str' = 0 -> str =s str'; - take_short_length : forall str n, n <= length str -> length (take n str) = n; - take_long : forall str n, length str <= n -> take n str =s str; - take_take : forall str n m, take n (take m str) =s take (min n m) str; - drop_length : forall str n, length (drop n str) = length str - n; - drop_0 : forall str, drop 0 str =s str; - drop_drop : forall str n m, drop n (drop m str) =s drop (n + m) str; - drop_take : forall str n m, drop n (take m str) =s take (m - n) (drop n str); - take_drop : forall str n m, take n (drop m str) =s drop m (take (n + m) str); - bool_eq_from_get : forall str str', (forall n, get n str = get n str') -> str =s str' - }. -Global Arguments StringLikeProperties _ {_}. -End StringLike. - -End Core. - -End StringLike. - -End Parsers. - -End Fiat. - -End Fiat_DOT_Parsers_DOT_StringLike_DOT_Core. - -Module Export Fiat_DOT_Parsers_DOT_ContextFreeGrammar_DOT_Core. -Module Export Fiat. -Module Export Parsers. -Module Export ContextFreeGrammar. -Module Export Core. -Import Stdlib.Strings.String. -Import Stdlib.Lists.List. -Export Fiat.Parsers.StringLike.Core. - -Section cfg. - Context {Char : Type}. - - Section definitions. - - Inductive item := - | Terminal (_ : Char) - | NonTerminal (_ : string). - - Definition production := list item. - Definition productions := list production. - - Record grammar := - { - Start_symbol :> string; - Lookup :> string -> productions; - Start_productions :> productions := Lookup Start_symbol; - Valid_nonterminals : list string; - Valid_productions : list productions := map Lookup Valid_nonterminals - }. - End definitions. - - End cfg. - -Arguments item _ : clear implicits. -Arguments production _ : clear implicits. -Arguments productions _ : clear implicits. -Arguments grammar _ : clear implicits. - -End Core. - -End ContextFreeGrammar. - -End Parsers. - -End Fiat. - -End Fiat_DOT_Parsers_DOT_ContextFreeGrammar_DOT_Core. - -Module Export Fiat_DOT_Parsers_DOT_BaseTypes. -Module Export Fiat. -Module Export Parsers. -Module Export BaseTypes. -Import Wf_nat. - -Local Coercion is_true : bool >-> Sortclass. - -Section recursive_descent_parser. - Context {Char} {HSL : StringLike Char} {G : grammar Char}. - - Class parser_computational_predataT := - { nonterminals_listT : Type; - nonterminal_carrierT : Type; - of_nonterminal : String.string -> nonterminal_carrierT; - to_nonterminal : nonterminal_carrierT -> String.string; - initial_nonterminals_data : nonterminals_listT; - nonterminals_length : nonterminals_listT -> nat; - is_valid_nonterminal : nonterminals_listT -> nonterminal_carrierT -> bool; - remove_nonterminal : nonterminals_listT -> nonterminal_carrierT -> nonterminals_listT }. - - Class parser_removal_dataT' `{predata : parser_computational_predataT} := - { nonterminals_listT_R : nonterminals_listT -> nonterminals_listT -> Prop - := ltof _ nonterminals_length; - nonterminals_length_zero : forall ls, - nonterminals_length ls = 0 - -> forall nt, is_valid_nonterminal ls nt = false; - remove_nonterminal_dec : forall ls nonterminal, - is_valid_nonterminal ls nonterminal - -> nonterminals_listT_R (remove_nonterminal ls nonterminal) ls; - remove_nonterminal_noninc : forall ls nonterminal, - ~nonterminals_listT_R ls (remove_nonterminal ls nonterminal); - initial_nonterminals_correct : forall nonterminal, - is_valid_nonterminal initial_nonterminals_data (of_nonterminal nonterminal) <-> List.In nonterminal (Valid_nonterminals G); - initial_nonterminals_correct' : forall nonterminal, - is_valid_nonterminal initial_nonterminals_data nonterminal <-> List.In (to_nonterminal nonterminal) (Valid_nonterminals G); - to_of_nonterminal : forall nonterminal, - List.In nonterminal (Valid_nonterminals G) - -> to_nonterminal (of_nonterminal nonterminal) = nonterminal; - of_to_nonterminal : forall nonterminal, - is_valid_nonterminal initial_nonterminals_data nonterminal - -> of_nonterminal (to_nonterminal nonterminal) = nonterminal; - ntl_wf : well_founded nonterminals_listT_R - := well_founded_ltof _ _; - remove_nonterminal_1 - : forall ls ps ps', - is_valid_nonterminal (remove_nonterminal ls ps) ps' - -> is_valid_nonterminal ls ps'; - remove_nonterminal_2 - : forall ls ps ps', - is_valid_nonterminal (remove_nonterminal ls ps) ps' = false - <-> is_valid_nonterminal ls ps' = false \/ ps = ps' }. - - Class split_dataT := - { split_string_for_production - : item Char -> production Char -> String -> list nat }. - - Class boolean_parser_dataT := - { predata :: parser_computational_predataT; - split_data :: split_dataT }. -End recursive_descent_parser. - -End BaseTypes. - -End Parsers. - -End Fiat. - -End Fiat_DOT_Parsers_DOT_BaseTypes. - -Module Export Fiat_DOT_Common_DOT_List_DOT_Operations. -Module Export Fiat. -Module Export Common. -Module Export List. -Module Export Operations. - -Import Stdlib.Lists.List. - -Module Export List. - Section InT. - Context {A : Type} (a : A). - - Fixpoint InT (ls : list A) : Set - := match ls return Set with - | nil => False - | b :: m => (b = a) + InT m - end%type. - End InT. - - End List. - -End Operations. - -End List. - -End Common. - -End Fiat. - -End Fiat_DOT_Common_DOT_List_DOT_Operations. - -Module Export Fiat_DOT_Parsers_DOT_StringLike_DOT_Properties. -Module Export Fiat. -Module Export Parsers. -Module Export StringLike. -Module Export Properties. - -Section String. - Context {Char} {HSL : StringLike Char} {HSLP : StringLikeProperties Char}. - - Lemma take_length {str n} - : length (take n str) = min n (length str). -admit. -Defined. - - End String. - -End Properties. - -End StringLike. - -End Parsers. - -End Fiat. - -End Fiat_DOT_Parsers_DOT_StringLike_DOT_Properties. - -Module Export Fiat_DOT_Parsers_DOT_ContextFreeGrammar_DOT_Properties. -Module Export Fiat. -Module Export Parsers. -Module Export ContextFreeGrammar. -Module Export Properties. - -Local Open Scope list_scope. -Definition production_is_reachableT {Char} (G : grammar Char) (p : production Char) - := { nt : _ - & { prefix : _ - & List.In nt (Valid_nonterminals G) - * List.InT - (prefix ++ p) - (Lookup G nt) } }%type. - -End Properties. - -End ContextFreeGrammar. - -End Parsers. - -End Fiat. - -End Fiat_DOT_Parsers_DOT_ContextFreeGrammar_DOT_Properties. - -Module Export Fiat_DOT_Parsers_DOT_MinimalParse. -Module Export Fiat. -Module Export Parsers. -Module Export MinimalParse. -Import Stdlib.Lists.List. -Import Fiat.Parsers.ContextFreeGrammar.Core. - -Local Coercion is_true : bool >-> Sortclass. -Local Open Scope string_like_scope. - -Section cfg. - Context {Char} {HSL : StringLike Char} {G : grammar Char}. - Context {predata : @parser_computational_predataT} - {rdata' : @parser_removal_dataT' _ G predata}. - - Inductive minimal_parse_of - : forall (len0 : nat) (valid : nonterminals_listT) - (str : String), - productions Char -> Type := - | MinParseHead : forall len0 valid str pat pats, - @minimal_parse_of_production len0 valid str pat - -> @minimal_parse_of len0 valid str (pat::pats) - | MinParseTail : forall len0 valid str pat pats, - @minimal_parse_of len0 valid str pats - -> @minimal_parse_of len0 valid str (pat::pats) - with minimal_parse_of_production - : forall (len0 : nat) (valid : nonterminals_listT) - (str : String), - production Char -> Type := - | MinParseProductionNil : forall len0 valid str, - length str = 0 - -> @minimal_parse_of_production len0 valid str nil - | MinParseProductionCons : forall len0 valid str n pat pats, - length str <= len0 - -> @minimal_parse_of_item len0 valid (take n str) pat - -> @minimal_parse_of_production len0 valid (drop n str) pats - -> @minimal_parse_of_production len0 valid str (pat::pats) - with minimal_parse_of_item - : forall (len0 : nat) (valid : nonterminals_listT) - (str : String), - item Char -> Type := - | MinParseTerminal : forall len0 valid str ch, - str ~= [ ch ] - -> @minimal_parse_of_item len0 valid str (Terminal ch) - | MinParseNonTerminal - : forall len0 valid str (nt : String.string), - @minimal_parse_of_nonterminal len0 valid str nt - -> @minimal_parse_of_item len0 valid str (NonTerminal nt) - with minimal_parse_of_nonterminal - : forall (len0 : nat) (valid : nonterminals_listT) - (str : String), - String.string -> Type := - | MinParseNonTerminalStrLt - : forall len0 valid (nt : String.string) str, - length str < len0 - -> is_valid_nonterminal initial_nonterminals_data (of_nonterminal nt) - -> @minimal_parse_of (length str) initial_nonterminals_data str (Lookup G nt) - -> @minimal_parse_of_nonterminal len0 valid str nt - | MinParseNonTerminalStrEq - : forall len0 str valid nonterminal, - length str = len0 - -> is_valid_nonterminal initial_nonterminals_data (of_nonterminal nonterminal) - -> is_valid_nonterminal valid (of_nonterminal nonterminal) - -> @minimal_parse_of len0 (remove_nonterminal valid (of_nonterminal nonterminal)) str (Lookup G nonterminal) - -> @minimal_parse_of_nonterminal len0 valid str nonterminal. - -End cfg. - -End MinimalParse. - -End Parsers. - -End Fiat. - -End Fiat_DOT_Parsers_DOT_MinimalParse. - -Module Export Fiat_DOT_Parsers_DOT_CorrectnessBaseTypes. -Module Export Fiat. -Module Export Parsers. -Module Export CorrectnessBaseTypes. -Import Stdlib.Lists.List. -Import Fiat.Parsers.ContextFreeGrammar.Core. -Import Fiat_DOT_Common.Fiat.Common. -Section general. - Context {Char} {HSL : StringLike Char} {G : grammar Char}. - - Definition split_list_completeT_for {data : @parser_computational_predataT} - {len0 valid} - (it : item Char) (its : production Char) - (str : String) - (pf : length str <= len0) - (split_list : list nat) - - := ({ n : nat - & (minimal_parse_of_item (G := G) (predata := data) len0 valid (take n str) it) - * (minimal_parse_of_production (G := G) len0 valid (drop n str) its) }%type) - -> ({ n : nat - & (In (min (length str) n) (map (min (length str)) split_list)) - * (minimal_parse_of_item (G := G) len0 valid (take n str) it) - * (minimal_parse_of_production (G := G) len0 valid (drop n str) its) }%type). - - Definition split_list_completeT {data : @parser_computational_predataT} - (splits : item Char -> production Char -> String -> list nat) - := forall len0 valid str (pf : length str <= len0) nt, - is_valid_nonterminal initial_nonterminals_data (of_nonterminal nt) - -> ForallT - (Forall_tails - (fun prod - => match prod return Type with - | nil => True - | it::its - => @split_list_completeT_for data len0 valid it its str pf (splits it its str) - end)) - (Lookup G nt). - - Class boolean_parser_completeness_dataT' {data : boolean_parser_dataT} := - { split_string_for_production_complete - : split_list_completeT split_string_for_production }. -End general. - -End CorrectnessBaseTypes. - -End Parsers. - -End Fiat. - -End Fiat_DOT_Parsers_DOT_CorrectnessBaseTypes. - -Module Export Fiat. -Module Export Parsers. -Module Export ContextFreeGrammar. -Module Export Valid. -Export Fiat.Parsers.StringLike.Core. - -Section cfg. - Context {Char : Type} {HSL : StringLike Char} (G : grammar Char) - {predata : parser_computational_predataT}. - - Definition item_valid (it : item Char) - := match it with - | Terminal _ => True - | NonTerminal nt' => is_true (is_valid_nonterminal initial_nonterminals_data (of_nonterminal nt')) - end. - - Definition production_valid pat - := List.Forall item_valid pat. - - Definition productions_valid pats - := List.Forall production_valid pats. - - Definition grammar_valid - := forall nt, - List.In nt (Valid_nonterminals G) - -> productions_valid (Lookup G nt). -End cfg. - -End Valid. -End ContextFreeGrammar. -End Parsers. -End Fiat. - -Section app. - Context {Char : Type} {HSL : StringLike Char} (G : grammar Char) - {predata : parser_computational_predataT}. - - Lemma hd_production_valid - (it : item Char) - (its : production Char) - (H : production_valid (it :: its)) - : item_valid it. -admit. -Defined. - - Lemma production_valid_cons - (it : item Char) - (its : production Char) - (H : production_valid (it :: its)) - : production_valid its. -admit. -Defined. - - End app. - -Import Stdlib.Lists.List. -Import Arith. -Import Lia. -Import Fiat_DOT_Common.Fiat.Common. -Import Fiat.Parsers.ContextFreeGrammar.Valid. -Local Open Scope string_like_scope. - -Section recursive_descent_parser. - Context {Char} {HSL : StringLike Char} {HSLP : StringLikeProperties Char} (G : grammar Char). - Context {data : @boolean_parser_dataT Char _} - {cdata : @boolean_parser_completeness_dataT' Char _ G data} - {rdata : @parser_removal_dataT' _ G _} - {gvalid : grammar_valid G}. - - Local Notation dec T := (T + (T -> False))%type (only parsing). - - Local Notation iffT x y := ((x -> y) * (y -> x))%type (only parsing). - - Lemma dec_prod {A B} (HA : dec A) (HB : dec B) : dec (A * B). -admit. -Defined. - - Lemma dec_In {A} {P : A -> Type} (HA : forall a, dec (P a)) ls - : dec { a : _ & (In a ls * P a) }. -admit. -Defined. - - Section item. - Context {len0 valid} - (str : String) - (str_matches_nonterminal' - : nonterminal_carrierT -> bool) - (str_matches_nonterminal - : forall nt : nonterminal_carrierT, - dec (minimal_parse_of_nonterminal (G := G) len0 valid str (to_nonterminal nt))). - - Section valid. - Context (Hmatches - : forall nt, - is_valid_nonterminal initial_nonterminals_data nt - -> str_matches_nonterminal nt = str_matches_nonterminal' nt :> bool) - (it : item Char) - (Hvalid : item_valid it). - - Definition parse_item' - : dec (minimal_parse_of_item (G := G) len0 valid str it). - Proof. - clear Hvalid. - refine (match it return dec (minimal_parse_of_item len0 valid str it) with - | Terminal ch => if Sumbool.sumbool_of_bool (str ~= [ ch ]) - then inl (MinParseTerminal _ _ _ _ _) - else inr (fun _ => !) - | NonTerminal nt => if str_matches_nonterminal (of_nonterminal nt) - then inl (MinParseNonTerminal _) - else inr (fun _ => !) - end); - clear str_matches_nonterminal Hmatches; - admit. - Defined. - End valid. - - End item. - Context {len0 valid} - (parse_nonterminal - : forall (str : String) (len : nat) (Hlen : length str = len) (pf : len <= len0) (nt : nonterminal_carrierT), - dec (minimal_parse_of_nonterminal (G := G) len0 valid str (to_nonterminal nt))). - - Lemma dec_in_helper {ls it its str} - : iffT {n0 : nat & - (In (min (length str) n0) (map (min (length str)) ls) * - minimal_parse_of_item (G := G) len0 valid (take n0 str) it * - minimal_parse_of_production (G := G) len0 valid (drop n0 str) its)%type} - {n0 : nat & - (In n0 ls * - (minimal_parse_of_item (G := G) len0 valid (take n0 str) it * - minimal_parse_of_production (G := G) len0 valid (drop n0 str) its))%type}. -admit. -Defined. - - Lemma parse_production'_helper {str it its} (pf : length str <= len0) - : dec {n0 : nat & - (minimal_parse_of_item (G := G) len0 valid (take n0 str) it * - minimal_parse_of_production (G := G) len0 valid (drop n0 str) its)%type} - -> dec (minimal_parse_of_production (G := G) len0 valid str (it :: its)). -admit. -Defined. - Local Ltac t_parse_production_for := repeat - match goal with - | [ H : (Nat.eqb _ _) = true |- _ ] => apply ->Nat.eqb_eq in H - | _ => progress subst - | _ => solve [ constructor; assumption ] - | [ H : minimal_parse_of_production _ _ _ nil |- _ ] => (inversion H; clear H) - | [ H : minimal_parse_of_production _ _ _ (_::_) |- _ ] => (inversion H; clear H) - | [ H : ?x = 0, H' : context[?x] |- _ ] => rewrite H in H' - | _ => progress simpl in * - | _ => discriminate - | [ H : forall x, (_ * _)%type -> _ |- _ ] => specialize (fun x y z => H x (y, z)) - | _ => solve [ eauto with nocore ] - | _ => solve [ apply Nat.min_case_strong; lia ] - | _ => lia - | [ H : production_valid (_::_) |- _ ] - => let H' := fresh in - pose proof H as H'; - apply production_valid_cons in H; - apply hd_production_valid in H' - end. - - Definition parse_production'_for - (splits : item Char -> production Char -> String -> list nat) - (Hsplits : forall str it its (Hreachable : production_is_reachableT G (it::its)) pf', split_list_completeT_for (len0 := len0) (G := G) (valid := valid) it its str pf' (splits it its str)) - (str : String) - (len : nat) - (Hlen : length str = len) - (pf : len <= len0) - (prod : production Char) - (Hreachable : production_is_reachableT G prod) - : dec (minimal_parse_of_production (G := G) len0 valid str prod). - Proof. - revert prod Hreachable str len Hlen pf. - refine - ((fun pf_helper => - list_rect - (fun prod => - forall (Hreachable : production_is_reachableT G prod) - (str : String) - (len : nat) - (Hlen : length str = len) - (pf : len <= len0), - dec (minimal_parse_of_production (G := G) len0 valid str prod)) - ( - fun Hreachable str len Hlen pf - => match Utils.dec (Nat.eqb len 0) with - | left H => inl _ - | right H => inr (fun p => _) - end) - (fun it its parse_production' Hreachable str len Hlen pf - => parse_production'_helper - _ - (let parse_item := (fun n pf => parse_item' (parse_nonterminal (take n str) (len := min n len) (eq_trans take_length (f_equal (min _) Hlen)) pf) it) in - let parse_item := (fun n => parse_item n (Nat.min_case_strong n len (fun k => k <= len0) (fun Hlen => (Nat.le_trans _ _ _ Hlen pf)) (fun Hlen => pf))) in - let parse_production := (fun n => parse_production' (pf_helper it its Hreachable) (drop n str) (len - n) (eq_trans (drop_length _ _) (f_equal (fun x => x - _) Hlen)) (Nat.le_trans _ _ _ (Nat.le_sub_l _ _) pf)) in - match dec_In - (fun n => dec_prod (parse_item n) (parse_production n)) - (splits it its str) - with - | inl p => inl (existT _ (projT1 p) (snd (projT2 p))) - | inr p - => let pf' := (Nat.le_trans _ _ _ (Nat.eq_le_incl _ _ Hlen) pf) in - let H := (_ : split_list_completeT_for (G := G) (len0 := len0) (valid := valid) it its str pf' (splits it its str)) in - inr (fun p' => p (fst dec_in_helper (H p'))) - end) - )) _); - [ clear parse_nonterminal Hsplits splits rdata cdata - | clear parse_nonterminal Hsplits splits rdata cdata - | .. - | admit ]. - abstract t_parse_production_for. - abstract t_parse_production_for. - abstract t_parse_production_for. - abstract t_parse_production_for. - Defined. -End recursive_descent_parser. diff --git a/stdlib/test-suite/bugs/bug_4684.v b/stdlib/test-suite/bugs/bug_4684.v deleted file mode 100644 index 575bc01acfab..000000000000 --- a/stdlib/test-suite/bugs/bug_4684.v +++ /dev/null @@ -1,32 +0,0 @@ -(*Suppose a user wants to declare a new list-like notation with support for singletons in both 8.4 and 8.5. If they use*) -From Stdlib Require Import List. -From Stdlib Require Import Vector. -Import ListNotations. -Import VectorNotations. -Set Implicit Arguments. -Inductive mylist T := mynil | mycons (_ : T) (_ : mylist T). -Arguments mynil {_}, _. - -Delimit Scope mylist_scope with mylist. -Bind Scope mylist_scope with mylist. -Delimit Scope vector_scope with vector. - -Notation " [ ] " := mynil (format "[ ]") : mylist_scope. -Notation " [ x ] " := (mycons x mynil) : mylist_scope. -Notation " [ x ; y ; .. ; z ] " := (mycons x (mycons y .. (mycons z mynil) ..)) : mylist_scope. - -Check [ ]%mylist : mylist _. -Check [ ]%list : list _. -Check []%vector : Vector.t _ _. -Check [ _ ]%mylist : mylist _. -Check [ _ ]%list : list _. -Check [ _ ]%vector : Vector.t _ _. -Check [ _ ; _ ]%list : list _. -Check [ _ ; _ ]%vector : Vector.t _ _. -Check [ _ ; _ ]%mylist : mylist _. -Check [ _ ; _ ; _ ]%list : list _. -Check [ _ ; _ ; _ ]%vector : Vector.t _ _. -Check [ _ ; _ ; _ ]%mylist : mylist _. -Check [ _ ; _ ; _ ; _ ]%list : list _. -Check [ _ ; _ ; _ ; _ ]%vector : Vector.t _ _. -Check [ _ ; _ ; _ ; _ ]%mylist : mylist _. diff --git a/stdlib/test-suite/bugs/bug_4717.v b/stdlib/test-suite/bugs/bug_4717.v deleted file mode 100644 index ce5ab5c646d9..000000000000 --- a/stdlib/test-suite/bugs/bug_4717.v +++ /dev/null @@ -1,33 +0,0 @@ -(* Omega being smarter on recognizing nat and Z *) - -From Stdlib Require Import Lia ZArith. - -Definition nat' := nat. - -Theorem le_not_eq_lt : forall (n m:nat), - n <= m -> - n <> m :> nat' -> - n < m. -Proof. - intros. - lia. -Qed. - -Goal forall (x n : nat'), x = x + n - n. -Proof. - intros. - lia. -Qed. - -Open Scope Z_scope. - -Definition Z' := Z. - -Theorem Zle_not_eq_lt : forall n m, - n <= m -> - n <> m :> Z' -> - n < m. -Proof. - intros. - lia. -Qed. diff --git a/stdlib/test-suite/bugs/bug_4725.v b/stdlib/test-suite/bugs/bug_4725.v deleted file mode 100644 index 85b958531ec2..000000000000 --- a/stdlib/test-suite/bugs/bug_4725.v +++ /dev/null @@ -1,39 +0,0 @@ -From Stdlib Require Import EquivDec Equivalence List Program. -From Stdlib Require Import Relation_Definitions. -Import ListNotations. -Generalizable All Variables. - -Fixpoint removeV `{eqDecV : @EqDec V eqV equivV}`(x : V) (l : list V) : list V -:= - match l with - | nil => nil - | y::tl => if (equiv_dec x y) then removeV x tl else y::(removeV x tl) - end. - -Lemma remove_le {V:Type}{eqV:relation V}{equivV:@Equivalence V eqV}{eqDecV : -@EqDec V eqV equivV} (xs : list V) (x : V) : - length (removeV x xs) < length (x :: xs). - Proof. Admitted. - -(* Function version *) -Set Printing Universes. - -From Stdlib Require Import Recdef. - -Function nubV {V:Type}{eqV:relation V}{equivV:@Equivalence V eqV}{eqDecV : -@EqDec V eqV equivV} (l : list V) { measure length l} := - match l with - | nil => nil - | x::xs => x :: @nubV V eqV equivV eqDecV (removeV x xs) - end. -Proof. intros. apply remove_le. Qed. - -(* Program version *) - -Program Fixpoint nubV' `{eqDecV : @EqDec V eqV equivV} (l : list V) - { measure (@length V l) lt } := - match l with - | nil => nil - | x::xs => x :: @nubV' V eqV equivV eqDecV (removeV x xs) _ - end. -Next Obligation. apply remove_le. Defined. diff --git a/stdlib/test-suite/bugs/bug_4763.v b/stdlib/test-suite/bugs/bug_4763.v deleted file mode 100644 index 716893102006..000000000000 --- a/stdlib/test-suite/bugs/bug_4763.v +++ /dev/null @@ -1,13 +0,0 @@ -From Stdlib Require Import Arith Morphisms RelationClasses. -Coercion is_true : bool >-> Sortclass. -Global Instance: Transitive leb. -Admitted. - -Goal forall x y z, leb x y -> leb y z -> True. - intros ??? H H'. - lazymatch goal with - | [ H : is_true (?R ?x ?y), H' : is_true (?R ?y ?z) |- _ ] - => pose proof (transitivity H H' : is_true (R x z)) - end. - exact I. -Qed. diff --git a/stdlib/test-suite/bugs/bug_4785.v b/stdlib/test-suite/bugs/bug_4785.v deleted file mode 100644 index 586090722e99..000000000000 --- a/stdlib/test-suite/bugs/bug_4785.v +++ /dev/null @@ -1,34 +0,0 @@ -From Stdlib Require List Vector. - -Module A. -Import Stdlib.Lists.List Stdlib.Vectors.Vector. -Import ListNotations. -Check [ ]%list : list _. -Import VectorNotations ListNotations. -Delimit Scope vector_scope with vector. -Check [ ]%vector : Vector.t _ _. -Check []%vector : Vector.t _ _. -Check [ ]%list : list _. -Check []%list : list _. - -Goal True. - idtac; []. (* Check that vector notations don't break the [ | .. | ] syntax of Ltac *) -Abort. - -Inductive mylist A := mynil | mycons (x : A) (xs : mylist A). -Delimit Scope mylist_scope with mylist. -Bind Scope mylist_scope with mylist. -Arguments mynil {_}, _. -Arguments mycons {_} _ _. -Notation " [ ] " := mynil (format "[ ]") : mylist_scope. -Notation " [ x ] " := (mycons x nil) : mylist_scope. -Notation " [ x ; y ; .. ; z ] " := (mycons x (mycons y .. (mycons z nil) ..)) : mylist_scope. - -Locate Module VectorNotations. -Import VectorDef.VectorNotations. - -Check []%vector : Vector.t _ _. -Check []%mylist : mylist _. -Check [ ]%mylist : mylist _. -Check [ ]%list : list _. -End A. diff --git a/stdlib/test-suite/bugs/bug_4852.v b/stdlib/test-suite/bugs/bug_4852.v deleted file mode 100644 index 5665f69b42b9..000000000000 --- a/stdlib/test-suite/bugs/bug_4852.v +++ /dev/null @@ -1,53 +0,0 @@ -(** BZ 4852 : unsatisfactory Extraction Implicit for a fixpoint defined via wf *) - -From Stdlib Require Import List. -Import ListNotations. -From Stdlib Require Import Lia. - -Definition wfi_lt := well_founded_induction_type Wf_nat.lt_wf. - -Tactic Notation "wfinduction" constr(term) "on" ne_hyp_list(Hs) "as" ident(H) := - let R := fresh in - let E := fresh in - remember term as R eqn:E; - revert E; revert Hs; - induction R as [R H] using wfi_lt; - intros; subst R. - -#[export] Hint Rewrite @app_comm_cons @app_assoc @app_length : app_rws. - -Ltac solve_nat := autorewrite with app_rws in *; cbn in *; lia. - -Notation "| x |" := (length x) (at level 11, no associativity, format "'|' x '|'"). - -Definition split_acc (ls : list nat) : forall acc1 acc2, - (|acc1| = |acc2| \/ |acc1| = S (|acc2|)) -> - { lss : list nat * list nat | - let '(ls1, ls2) := lss in |ls1++ls2| = |ls++acc1++acc2| /\ (|ls1| = |ls2| \/ |ls1| = S (|ls2|))}. -Proof. - induction ls as [|a ls IHls]. all:intros acc1 acc2 H. - { exists (acc1, acc2). cbn. intuition reflexivity. } - destruct (IHls (a::acc2) acc1) as [[ls1 ls2] (H1 & H2)]. 1:solve_nat. - exists (ls1, ls2). cbn. intuition solve_nat. -Defined. - -Definition join(ls : list nat) : { rls : list nat | |rls| = |ls| }. -Proof. - wfinduction (|ls|) on ls as IH. - case (split_acc ls [] []). 1:solve_nat. - intros (ls1 & ls2) (H1 & H2). - destruct ls2 as [|a ls2]. - - exists ls1. solve_nat. - - unshelve eelim (IH _ _ ls1 eq_refl). 1:solve_nat. intros rls1 H3. - unshelve eelim (IH _ _ ls2 eq_refl). 1:solve_nat. intros rls2 H4. - exists (a :: rls1 ++ rls2). solve_nat. -Defined. - -From Stdlib Require Import ExtrOcamlNatInt. -Extract Inlined Constant length => "List.length". -Extract Inlined Constant app => "List.append". - -Extraction Inline wfi_lt. -Extraction Implicit wfi_lt [1 3]. -Recursive Extraction join. (* was: Error: An implicit occurs after extraction *) -Extraction TestCompile join. diff --git a/stdlib/test-suite/bugs/bug_4858.v b/stdlib/test-suite/bugs/bug_4858.v deleted file mode 100644 index 164589f3f76c..000000000000 --- a/stdlib/test-suite/bugs/bug_4858.v +++ /dev/null @@ -1,7 +0,0 @@ -From Stdlib Require Import Nsatz. -Goal True. -try nsatz_compute - (PEc 0%Z :: PEc (-1)%Z - :: PEpow (PEsub (PEX Z 2) (PEX Z 3)) 1 - :: PEsub (PEX Z 1) (PEX Z 1) :: nil). -Abort. diff --git a/stdlib/test-suite/bugs/bug_4863.v b/stdlib/test-suite/bugs/bug_4863.v deleted file mode 100644 index 0c55bf1087cb..000000000000 --- a/stdlib/test-suite/bugs/bug_4863.v +++ /dev/null @@ -1,33 +0,0 @@ -From Stdlib Require Import DecidableClass. - -Inductive Foo : Set := -| foo1 | foo2. - -Lemma Decidable_sumbool : forall P, {P}+{~P} -> Decidable P. -Proof. - intros P H. - refine (Build_Decidable _ (if H then true else false) _). - intuition congruence. -Qed. - -#[export] Hint Extern 100 (Decidable (?A = ?B)) => abstract (abstract (abstract (apply Decidable_sumbool; decide equality))) : typeclass_instances. - -Goal forall (a b : Foo), {a=b}+{a<>b}. -intros. -abstract (abstract (decide equality)). (*abstract works here*) -Qed. - -Check ltac:(abstract (exact I)) : True. - -Goal forall (a b : Foo), Decidable (a=b) * Decidable (a=b). -intros. -split. typeclasses eauto. -typeclasses eauto. Qed. - -Goal forall (a b : Foo), Decidable (a=b) * Decidable (a=b). -intros. -split. -refine _. -refine _. -Defined. -(*fails*) diff --git a/stdlib/test-suite/bugs/bug_4880.v b/stdlib/test-suite/bugs/bug_4880.v deleted file mode 100644 index 44c8ed1c49b6..000000000000 --- a/stdlib/test-suite/bugs/bug_4880.v +++ /dev/null @@ -1,11 +0,0 @@ -From Stdlib Require Import Reals Nsatz. -Local Open Scope R. - -Goal forall x y : R, - x*x = y * y -> - x*x = -y * -y -> - x*(x*x) = 0 -> (* The associativity does not actually matter, *) - (x*x)*x = 0. (* just otherwise [assumption] would solve the goal. *) -Proof. - nsatz. -Qed. diff --git a/stdlib/test-suite/bugs/bug_5019.v b/stdlib/test-suite/bugs/bug_5019.v deleted file mode 100644 index ae224a2bd24f..000000000000 --- a/stdlib/test-suite/bugs/bug_5019.v +++ /dev/null @@ -1,5 +0,0 @@ -From Stdlib Require Import ZArith. -Goal forall (T0 : Z -> Type) (k : nat) d (P : T0 (Z.of_nat (S k)) -> Prop), P d. - clear; intros. - Timeout 1 zify. (* used to loop forever; should take < 0.01 s *) -Admitted. diff --git a/stdlib/test-suite/bugs/bug_5066.v b/stdlib/test-suite/bugs/bug_5066.v deleted file mode 100644 index 408cc4e428ab..000000000000 --- a/stdlib/test-suite/bugs/bug_5066.v +++ /dev/null @@ -1,7 +0,0 @@ -From Stdlib Require Import Vector. - -Fail Program Fixpoint vector_rev {A : Type} {n1 n2 : nat} (v1 : Vector.t A n1) (v2 : Vector.t A n2) : Vector.t A (n1+n2) := - match v1 with - | nil _ => v2 - | cons _ e n' sv => vector_rev sv (cons A e n2 v2) - end. diff --git a/stdlib/test-suite/bugs/bug_5096.v b/stdlib/test-suite/bugs/bug_5096.v deleted file mode 100644 index b4744253c230..000000000000 --- a/stdlib/test-suite/bugs/bug_5096.v +++ /dev/null @@ -1,220 +0,0 @@ -(* coq-prog-args: ("-top" "bug_5096") *) -From Stdlib Require Import FMapPositive BinPos List. - -Set Asymmetric Patterns. - -Notation eta x := (fst x, snd x). - -Inductive expr {var : Type} : Type := -| Const : expr -| LetIn : expr -> (var -> expr) -> expr. - -Definition Expr := forall var, @expr var. - -Fixpoint count_binders (e : @expr unit) : nat := -match e with -| LetIn _ eC => 1 + @count_binders (eC tt) -| _ => 0 -end. - -Definition CountBinders (e : Expr) : nat := count_binders (e _). - -Class Context (Name : Type) (var : Type) := - { ContextT : Type; - extendb : ContextT -> Name -> var -> ContextT; - empty : ContextT }. -Coercion ContextT : Context >-> Sortclass. -Arguments ContextT {_ _ _}, {_ _} _. -Arguments extendb {_ _ _} _ _ _. -Arguments empty {_ _ _}. - -Module Export Named. -Inductive expr Name : Type := -| Const : expr Name -| LetIn : Name -> expr Name -> expr Name -> expr Name. -End Named. - -Global Arguments Const {_}. -Global Arguments LetIn {_} _ _ _. - -Definition split_onames {Name : Type} (ls : list (option Name)) - : option (Name) * list (option Name) - := match ls with - | cons n ls' - => (n, ls') - | nil => (None, nil) - end. - -Section internal. - Context (InName OutName : Type) - {InContext : Context InName (OutName)} - {ReverseContext : Context OutName (InName)} - (InName_beq : InName -> InName -> bool). - - Fixpoint register_reassign (ctxi : InContext) (ctxr : ReverseContext) - (e : expr InName) (new_names : list (option OutName)) - : option (expr OutName) - := match e in Named.expr _ return option (expr _) with - | Const => Some Const - | LetIn n ex eC - => let '(n', new_names') := eta (split_onames new_names) in - match n', @register_reassign ctxi ctxr ex nil with - | Some n', Some x - => let ctxi := @extendb _ _ _ ctxi n n' in - let ctxr := @extendb _ _ _ ctxr n' n in - option_map (LetIn n' x) (@register_reassign ctxi ctxr eC new_names') - | None, Some x - => let ctxi := ctxi in - @register_reassign ctxi ctxr eC new_names' - | _, None => None - end - end. - -End internal. - -Global Instance pos_context (var : Type) : Context positive var - := { ContextT := PositiveMap.t var; - extendb ctx key v := PositiveMap.add key v ctx; - empty := PositiveMap.empty _ }. - -Global Arguments register_reassign {_ _ _ _} ctxi ctxr e _. - -Section language5. - Context (Name : Type). - - Local Notation expr := (@bug_5096.expr Name). - Local Notation nexpr := (@Named.expr Name). - - Fixpoint ocompile (e : expr) (ls : list (option Name)) {struct e} - : option (nexpr) - := match e in @bug_5096.expr _ return option (nexpr) with - | bug_5096.Const => Some Named.Const - | bug_5096.LetIn ex eC - => match @ocompile ex nil, split_onames ls with - | Some x, (Some n, ls')%core - => option_map (fun C => Named.LetIn n x C) (@ocompile (eC n) ls') - | _, _ => None - end - end. - - Definition compile (e : expr) (ls : list Name) := @ocompile e (List.map (@Some _) ls). -End language5. - -Global Arguments compile {_} e ls. - -Fixpoint merge_liveness (ls1 ls2 : list unit) := - match ls1, ls2 with - | cons x xs, cons y ys => cons tt (@merge_liveness xs ys) - | nil, ls | ls, nil => ls - end. - -Section internal1. - Context (Name : Type) - (OutName : Type) - {Context : Context Name (list unit)}. - - Definition compute_livenessf_step - (compute_livenessf : forall (ctx : Context) (e : expr Name) (prefix : list unit), list unit) - (ctx : Context) - (e : expr Name) (prefix : list unit) - : list unit - := match e with - | Const => prefix - | LetIn n ex eC - => let lx := @compute_livenessf ctx ex prefix in - let lx := merge_liveness lx (prefix ++ repeat tt 1) in - let ctx := @extendb _ _ _ ctx n (lx) in - @compute_livenessf ctx eC (prefix ++ repeat tt 1) - end. - - Fixpoint compute_liveness ctx e prefix - := @compute_livenessf_step (@compute_liveness) ctx e prefix. - - Fixpoint insert_dead_names_gen def (ls : list unit) (lsn : list OutName) - : list (option OutName) - := match ls with - | nil => nil - | cons live xs - => match lsn with - | cons n lsn' => Some n :: @insert_dead_names_gen def xs lsn' - | nil => def :: @insert_dead_names_gen def xs nil - end - end. - Definition insert_dead_names def (e : expr Name) - := insert_dead_names_gen def (compute_liveness empty e nil). -End internal1. - -Global Arguments insert_dead_names {_ _ _} def e lsn. - -Definition Let_In {A P} (x : A) (f : forall a : A, P a) : P x := let y := x in f y. - -Section language7. - Context {Context : Context unit (positive)}. - - Local Notation nexpr := (@Named.expr unit). - - Definition CompileAndEliminateDeadCode (e : Expr) (ls : list unit) - : option (nexpr) - := let e := compile (Name:=positive) (e _) (List.map Pos.of_nat (seq 1 (CountBinders e))) in - match e with - | Some e => Let_In (insert_dead_names None e ls) (* help vm_compute by factoring this out *) - (fun names => register_reassign empty empty e names) - | None => None - end. -End language7. - -Global Arguments CompileAndEliminateDeadCode {_} e ls. - -Definition ContextOn {Name1 Name2} f {var} (Ctx : Context Name1 var) : Context Name2 var - := {| ContextT := Ctx; - extendb ctx n v := extendb ctx (f n) v; - empty := empty |}. - -Definition Register := Datatypes.unit. - -Global Instance RegisterContext {var : Type} : Context Register var - := ContextOn (fun _ => 1%positive) (pos_context var). - -Definition syntax := Named.expr Register. - -Definition AssembleSyntax e ls (res := CompileAndEliminateDeadCode e ls) - := match res return match res with None => _ | _ => _ end with - | Some v => v - | None => I - end. - -Definition dummy_registers (n : nat) : list Register - := List.map (fun _ => tt) (seq 0 n). -Definition DefaultRegisters (e : Expr) : list Register - := dummy_registers (CountBinders e). - -Definition DefaultAssembleSyntax e := @AssembleSyntax e (DefaultRegisters e). - -Notation "'slet' x := A 'in' b" := (bug_5096.LetIn A (fun x => b)) (at level 200, b at level 200). -Notation "#[ var ]#" := (@bug_5096.Const var). - -Definition compiled_syntax : Expr := fun (var : Type) => -( - slet x1 := #[ var ]# in - slet x1 := #[ var ]# in - slet x1 := #[ var ]# in - slet x1 := #[ var ]# in - slet x1 := #[ var ]# in - slet x1 := #[ var ]# in - slet x1 := #[ var ]# in - slet x1 := #[ var ]# in - slet x1 := #[ var ]# in - slet x1 := #[ var ]# in - slet x1 := #[ var ]# in - slet x1 := #[ var ]# in - slet x1 := #[ var ]# in - slet x1 := #[ var ]# in - slet x1 := #[ var ]# in - slet x1 := #[ var ]# in - slet x1 := #[ var ]# in - @bug_5096.Const var). - -Definition v := - Eval cbv [compiled_syntax] in (DefaultAssembleSyntax (compiled_syntax)). - -Timeout 2 Eval vm_compute in v. diff --git a/stdlib/test-suite/bugs/bug_5123.v b/stdlib/test-suite/bugs/bug_5123.v deleted file mode 100644 index e74f89555757..000000000000 --- a/stdlib/test-suite/bugs/bug_5123.v +++ /dev/null @@ -1,33 +0,0 @@ -(* IN 8.5pl2 and 8.6 (4da2131), the following shows different typeclass resolution behaviors following an unshelve tactical vs. an Unshelve command: *) - -(*Pose an open constr to prevent immediate typeclass resolution in holes:*) -Tactic Notation "opose" open_constr(x) "as" ident(H) := pose x as H. - -Inductive vect A : nat -> Type := -| vnil : vect A 0 -| vcons : forall (h:A) (n:nat), vect A n -> vect A (S n). - -Class Eqdec A := eqdec : forall a b : A, {a=b}+{a<>b}. - -From Stdlib Require Bool. - -#[export] Instance Bool_eqdec : Eqdec bool := Bool.bool_dec. - -#[warning="context-outside-section"] Context `{vect_sigT_eqdec : forall A : Type, Eqdec A -> Eqdec {a : nat & vect A a}}. - -Typeclasses eauto := debug. - -Goal True. - unshelve opose (@vect_sigT_eqdec _ _ _ _) as H. - all:cycle 2. - eapply existT. (*BUG: Why does this do typeclass resolution in the evar?*) - Focus 5. -Abort. - -Goal True. - opose (@vect_sigT_eqdec _ _ _ _) as H. - Unshelve. - all:cycle 3. - eapply existT. (*This does no typeclass resolution, which is correct.*) - Focus 5. -Abort. diff --git a/stdlib/test-suite/bugs/bug_5161.v b/stdlib/test-suite/bugs/bug_5161.v deleted file mode 100644 index 9e62be6f8ab4..000000000000 --- a/stdlib/test-suite/bugs/bug_5161.v +++ /dev/null @@ -1,27 +0,0 @@ -(* Check that the presence of binders with type annotation do not - prevent the recursive binder part to be found *) - -From Stdlib Require Import Utf8. - -Delimit Scope C_scope with C. -Global Open Scope C_scope. - -Delimit Scope uPred_scope with I. - -Definition FORALL {T : Type} (f : T ā†’ Prop) : Prop := āˆ€ x, f x. - -Notation "āˆ€ x .. y , P" := - (FORALL (Ī» x, .. (FORALL (Ī» y, P)) ..)%I) - (at level 10, x binder, y binder, P at level 200) : uPred_scope. -Infix "āˆ§" := and : uPred_scope. - -(* The next command fails with - In recursive notation with binders, Ī¦ is expected to come without type. - I would expect this notation to work fine, since the āˆ€ does support - type annotation. -*) -Notation "'{{{' P } } } e {{{ x .. y ; pat , Q } } }" := - (āˆ€ Ī¦ : _ ā†’ _, - (āˆ€ x, .. (āˆ€ y, Q āˆ§ Ī¦ pat) .. ))%I - (at level 20, x closed binder, y closed binder, - format "{{{ P } } } e {{{ x .. y ; pat , Q } } }") : uPred_scope. diff --git a/stdlib/test-suite/bugs/bug_5208.v b/stdlib/test-suite/bugs/bug_5208.v deleted file mode 100644 index 0a109859a639..000000000000 --- a/stdlib/test-suite/bugs/bug_5208.v +++ /dev/null @@ -1,222 +0,0 @@ -From Stdlib Require Import Program. - -From Stdlib Require Import String. -From Stdlib Require Import Ascii. -From Stdlib Require Import BinNums. - -Set Implicit Arguments. -Set Strict Implicit. -Set Universe Polymorphism. -Set Printing Universes. - -Local Open Scope positive. - -Definition field : Type := positive. - -Section poly. - Universe U. - - Inductive fields : Type := - | pm_Leaf : fields - | pm_Branch : fields -> option Type@{U} -> fields -> fields. - - Definition fields_left (f : fields) : fields := - match f with - | pm_Leaf => pm_Leaf - | pm_Branch l _ _ => l - end. - - Definition fields_right (f : fields) : fields := - match f with - | pm_Leaf => pm_Leaf - | pm_Branch _ _ r => r - end. - - Definition fields_here (f : fields) : option Type@{U} := - match f with - | pm_Leaf => None - | pm_Branch _ s _ => s - end. - - Fixpoint fields_get (p : field) (m : fields) {struct p} : option Type@{U} := - match p with - | xH => match m with - | pm_Leaf => None - | pm_Branch _ x _ => x - end - | xO p' => fields_get p' match m with - | pm_Leaf => pm_Leaf - | pm_Branch L _ _ => L - end - | xI p' => fields_get p' match m with - | pm_Leaf => pm_Leaf - | pm_Branch _ _ R => R - end - end. - - Definition fields_leaf : fields := pm_Leaf. - - Inductive member (val : Type@{U}) : fields -> Type := - | pmm_H : forall L R, member val (pm_Branch L (Some val) R) - | pmm_L : forall (V : option Type@{U}) L R, member val L -> member val (pm_Branch L V R) - | pmm_R : forall (V : option Type@{U}) L R, member val R -> member val (pm_Branch L V R). - Arguments pmm_H {_ _ _}. - Arguments pmm_L {_ _ _ _} _. - Arguments pmm_R {_ _ _ _} _. - - Fixpoint get_member (val : Type@{U}) p {struct p} - : forall m, fields_get p m = @Some Type@{U} val -> member val m := - match p as p return forall m, fields_get p m = @Some Type@{U} val -> member@{U} val m with - | xH => fun m => - match m as m return fields_get xH m = @Some Type@{U} val -> member@{U} val m with - | pm_Leaf => fun pf : None = @Some Type@{U} _ => - match pf in _ = Z return match Z with - | Some _ => _ - | None => unit - end - with - | eq_refl => tt - end - | pm_Branch _ None _ => fun pf : None = @Some Type@{U} _ => - match pf in _ = Z return match Z with - | Some _ => _ - | None => unit - end - with - | eq_refl => tt - end - | pm_Branch _ (Some x) _ => fun pf : @Some Type@{U} x = @Some Type@{U} val => - match eq_sym pf in _ = Z return member@{U} val (pm_Branch _ Z _) with - | eq_refl => pmm_H - end - end - | xO p' => fun m => - match m as m return fields_get (xO p') m = @Some Type@{U} val -> member@{U} val m with - | pm_Leaf => fun pf : fields_get p' pm_Leaf = @Some Type@{U} val => - @get_member _ p' pm_Leaf pf - | pm_Branch l _ _ => fun pf : fields_get p' l = @Some Type@{U} val => - @pmm_L _ _ _ _ (@get_member _ p' l pf) - end - | xI p' => fun m => - match m as m return fields_get (xI p') m = @Some Type@{U} val -> member@{U} val m with - | pm_Leaf => fun pf : fields_get p' pm_Leaf = @Some Type@{U} val => - @get_member _ p' pm_Leaf pf - | pm_Branch l _ r => fun pf : fields_get p' r = @Some Type@{U} val => - @pmm_R _ _ _ _ (@get_member _ p' r pf) - end - end. - - Inductive record : fields -> Type := - | pr_Leaf : record pm_Leaf - | pr_Branch : forall L R (V : option Type@{U}), - record L -> - match V return Type@{U} with - | None => unit - | Some t => t - end -> - record R -> - record (pm_Branch L V R). - - - Definition record_left {L} {V : option Type@{U}} {R} - (r : record (pm_Branch L V R)) : record L := - match r in record z - return match z with - | pm_Branch L _ _ => record L - | _ => unit - end - with - | pr_Branch _ l _ _ => l - | pr_Leaf => tt - end. -Set Printing All. - Definition record_at {L} {V : option Type@{U}} {R} (r : record (pm_Branch L V R)) - : match V return Type@{U} with - | None => unit - | Some t => t - end := - match r in record z - return match z (* return ?X *) with - | pm_Branch _ V _ => match V return Type@{U} with - | None => unit - | Some t => t - end - | _ => unit - end - with - | pr_Branch _ _ v _ => v - | pr_Leaf => tt - end. - - Definition record_here {L : fields} (v : Type@{U}) {R : fields} - (r : record (pm_Branch L (@Some Type@{U} v) R)) : v := - match r in record z - return match z return Type@{U} with - | pm_Branch _ (Some v) _ => v - | _ => unit - end - with - | pr_Branch _ _ v _ => v - | pr_Leaf => tt - end. - - Definition record_right {L V R} (r : record (pm_Branch L V R)) : record R := - match r in record z return match z with - | pm_Branch _ _ R => record R - | _ => unit - end - with - | pr_Branch _ _ _ r => r - | pr_Leaf => tt - end. - - Fixpoint record_get {val : Type@{U}} {pm : fields} (m : member val pm) : record pm -> val := - match m in member _ pm return record pm -> val with - | pmm_H => fun r => record_here r - | pmm_L m' => fun r => record_get m' (record_left r) - | pmm_R m' => fun r => record_get m' (record_right r) - end. - - Fixpoint record_set {val : Type@{U}} {pm : fields} (m : member val pm) (x : val) {struct m} - : record pm -> record pm := - match m in member _ pm return record pm -> record pm with - | pmm_H => fun r => - pr_Branch (Some _) - (record_left r) - x - (record_right r) - | pmm_L m' => fun r => - pr_Branch _ - (record_set m' x (record_left r)) - (record_at r) - (record_right r) - | pmm_R m' => fun r => - pr_Branch _ (record_left r) - (record_at r) - (record_set m' x (record_right r)) - end. -End poly. -Axiom cheat : forall {A}, A. -Lemma record_get_record_set_different: - forall (T: Type) (vars: fields) - (pmr pmw: member T vars) - (diff: pmr <> pmw) - (r: record vars) (val: T), - record_get pmr (record_set pmw val r) = record_get pmr r. -Proof. - intros. - revert pmr diff r val. - induction pmw; simpl; intros. - - dependent destruction pmr. - + congruence. - + auto. - + auto. - - dependent destruction pmr. - + auto. - + simpl. apply IHpmw. congruence. - + auto. - - dependent destruction pmr. - + auto. - + auto. - + simpl. apply IHpmw. congruence. -Qed. diff --git a/stdlib/test-suite/bugs/bug_5315.v b/stdlib/test-suite/bugs/bug_5315.v deleted file mode 100644 index 7309a8edb08d..000000000000 --- a/stdlib/test-suite/bugs/bug_5315.v +++ /dev/null @@ -1,10 +0,0 @@ -From Stdlib Require Import Recdef. - -Function dumb_works (a:nat) {struct a} := - match (fun x => x) a with O => O | S n' => dumb_works n' end. - -Function dumb_nope (a:nat) {struct a} := - match (id (fun x => x)) a with O => O | S n' => dumb_nope n' end. - -(* This check is just present to ensure Function worked well *) -Check R_dumb_nope_complete. diff --git a/stdlib/test-suite/bugs/bug_5359.v b/stdlib/test-suite/bugs/bug_5359.v deleted file mode 100644 index eb8205940f88..000000000000 --- a/stdlib/test-suite/bugs/bug_5359.v +++ /dev/null @@ -1,221 +0,0 @@ -From Stdlib Require Import Nsatz. -From Stdlib Require Import BinNat. - -Goal False. - - (* the first (succeeding) goal was reached by clearing one hypothesis in the second goal which overflows 6GB of stack space *) - let sugar := constr:( 0%Z ) in - let nparams := constr:( (-1)%Z ) in - let reified_goal := constr:( - (Ring_polynom.PEsub (Ring_polynom.PEc 1%Z) - (Ring_polynom.PEmul - (Ring_polynom.PEmul - (Ring_polynom.PEmul - (Ring_polynom.PEmul (Ring_polynom.PEX Z 4) (Ring_polynom.PEX Z 2)) - (Ring_polynom.PEX Z 5)) (Ring_polynom.PEX Z 3)) - (Ring_polynom.PEX Z 6))) ) in - let power := constr:( N.one ) in - let reified_givens := constr:( - (Ring_polynom.PEmul - (Ring_polynom.PEadd (Ring_polynom.PEc 1%Z) - (Ring_polynom.PEmul - (Ring_polynom.PEmul - (Ring_polynom.PEmul - (Ring_polynom.PEmul (Ring_polynom.PEX Z 4) (Ring_polynom.PEX Z 2)) - (Ring_polynom.PEX Z 5)) (Ring_polynom.PEX Z 3)) - (Ring_polynom.PEX Z 6))) - (Ring_polynom.PEsub (Ring_polynom.PEc 1%Z) - (Ring_polynom.PEmul - (Ring_polynom.PEmul - (Ring_polynom.PEmul - (Ring_polynom.PEmul (Ring_polynom.PEX Z 4) (Ring_polynom.PEX Z 2)) - (Ring_polynom.PEX Z 5)) (Ring_polynom.PEX Z 3)) - (Ring_polynom.PEX Z 6))) - :: Ring_polynom.PEsub - (Ring_polynom.PEmul - (Ring_polynom.PEadd (Ring_polynom.PEc 1%Z) - (Ring_polynom.PEmul - (Ring_polynom.PEmul - (Ring_polynom.PEmul - (Ring_polynom.PEmul (Ring_polynom.PEX Z 4) - (Ring_polynom.PEX Z 2)) (Ring_polynom.PEX Z 5)) - (Ring_polynom.PEX Z 3)) (Ring_polynom.PEX Z 6))) - (Ring_polynom.PEX Z 10)) (Ring_polynom.PEc 1%Z) - :: Ring_polynom.PEsub - (Ring_polynom.PEmul - (Ring_polynom.PEsub (Ring_polynom.PEc 1%Z) - (Ring_polynom.PEmul - (Ring_polynom.PEmul - (Ring_polynom.PEmul - (Ring_polynom.PEmul (Ring_polynom.PEX Z 4) - (Ring_polynom.PEX Z 2)) (Ring_polynom.PEX Z 5)) - (Ring_polynom.PEX Z 3)) (Ring_polynom.PEX Z 6))) - (Ring_polynom.PEX Z 9)) (Ring_polynom.PEc 1%Z) - :: Ring_polynom.PEsub - (Ring_polynom.PEadd - (Ring_polynom.PEmul (Ring_polynom.PEX Z 1) - (Ring_polynom.PEmul (Ring_polynom.PEX Z 7) - (Ring_polynom.PEX Z 7))) - (Ring_polynom.PEmul (Ring_polynom.PEX Z 8) (Ring_polynom.PEX Z 8))) - (Ring_polynom.PEadd (Ring_polynom.PEc 1%Z) - (Ring_polynom.PEmul - (Ring_polynom.PEmul (Ring_polynom.PEX Z 4) - (Ring_polynom.PEmul (Ring_polynom.PEX Z 7) - (Ring_polynom.PEX Z 7))) - (Ring_polynom.PEmul (Ring_polynom.PEX Z 8) - (Ring_polynom.PEX Z 8)))) - :: Ring_polynom.PEsub - (Ring_polynom.PEadd - (Ring_polynom.PEmul (Ring_polynom.PEX Z 1) - (Ring_polynom.PEmul (Ring_polynom.PEX Z 5) - (Ring_polynom.PEX Z 5))) - (Ring_polynom.PEmul (Ring_polynom.PEX Z 6) - (Ring_polynom.PEX Z 6))) - (Ring_polynom.PEadd (Ring_polynom.PEc 1%Z) - (Ring_polynom.PEmul - (Ring_polynom.PEmul (Ring_polynom.PEX Z 4) - (Ring_polynom.PEmul (Ring_polynom.PEX Z 5) - (Ring_polynom.PEX Z 5))) - (Ring_polynom.PEmul (Ring_polynom.PEX Z 6) - (Ring_polynom.PEX Z 6)))) - :: Ring_polynom.PEsub - (Ring_polynom.PEadd - (Ring_polynom.PEmul (Ring_polynom.PEX Z 1) - (Ring_polynom.PEmul (Ring_polynom.PEX Z 2) - (Ring_polynom.PEX Z 2))) - (Ring_polynom.PEmul (Ring_polynom.PEX Z 3) - (Ring_polynom.PEX Z 3))) - (Ring_polynom.PEadd (Ring_polynom.PEc 1%Z) - (Ring_polynom.PEmul - (Ring_polynom.PEmul (Ring_polynom.PEX Z 4) - (Ring_polynom.PEmul (Ring_polynom.PEX Z 2) - (Ring_polynom.PEX Z 2))) - (Ring_polynom.PEmul (Ring_polynom.PEX Z 3) - (Ring_polynom.PEX Z 3)))) :: nil)%list ) in - NsatzTactic.nsatz_compute - (@cons _ (@Ring_polynom.PEc _ sugar) (@cons _ (@Ring_polynom.PEc _ nparams) (@cons _ (@Ring_polynom.PEpow _ reified_goal power) reified_givens))). - - let sugar := constr:( 0%Z ) in - let nparams := constr:( (-1)%Z ) in - let reified_goal := constr:( - (Ring_polynom.PEsub (Ring_polynom.PEc 1%Z) - (Ring_polynom.PEmul - (Ring_polynom.PEmul - (Ring_polynom.PEmul - (Ring_polynom.PEmul (Ring_polynom.PEX Z 4) (Ring_polynom.PEX Z 2)) - (Ring_polynom.PEX Z 5)) (Ring_polynom.PEX Z 3)) - (Ring_polynom.PEX Z 6))) ) in - let power := constr:( N.one ) in - let reified_givens := constr:( - (Ring_polynom.PEmul - (Ring_polynom.PEadd (Ring_polynom.PEc 1%Z) - (Ring_polynom.PEmul - (Ring_polynom.PEmul - (Ring_polynom.PEmul - (Ring_polynom.PEmul (Ring_polynom.PEX Z 4) (Ring_polynom.PEX Z 2)) - (Ring_polynom.PEX Z 5)) (Ring_polynom.PEX Z 3)) - (Ring_polynom.PEX Z 6))) - (Ring_polynom.PEsub (Ring_polynom.PEc 1%Z) - (Ring_polynom.PEmul - (Ring_polynom.PEmul - (Ring_polynom.PEmul - (Ring_polynom.PEmul (Ring_polynom.PEX Z 4) (Ring_polynom.PEX Z 2)) - (Ring_polynom.PEX Z 5)) (Ring_polynom.PEX Z 3)) - (Ring_polynom.PEX Z 6))) - :: Ring_polynom.PEadd - (Ring_polynom.PEmul - (Ring_polynom.PEadd (Ring_polynom.PEc 1%Z) - (Ring_polynom.PEmul - (Ring_polynom.PEmul - (Ring_polynom.PEmul - (Ring_polynom.PEmul (Ring_polynom.PEX Z 4) - (Ring_polynom.PEX Z 2)) (Ring_polynom.PEX Z 5)) - (Ring_polynom.PEX Z 3)) (Ring_polynom.PEX Z 6))) - (Ring_polynom.PEsub (Ring_polynom.PEc 1%Z) - (Ring_polynom.PEmul - (Ring_polynom.PEmul - (Ring_polynom.PEmul - (Ring_polynom.PEmul (Ring_polynom.PEX Z 4) - (Ring_polynom.PEX Z 2)) (Ring_polynom.PEX Z 5)) - (Ring_polynom.PEX Z 3)) (Ring_polynom.PEX Z 6)))) - (Ring_polynom.PEmul - (Ring_polynom.PEmul - (Ring_polynom.PEmul - (Ring_polynom.PEmul (Ring_polynom.PEX Z 4) - (Ring_polynom.PEadd - (Ring_polynom.PEmul (Ring_polynom.PEX Z 2) - (Ring_polynom.PEX Z 6)) - (Ring_polynom.PEmul (Ring_polynom.PEX Z 3) - (Ring_polynom.PEX Z 5)))) (Ring_polynom.PEX Z 7)) - (Ring_polynom.PEsub - (Ring_polynom.PEmul (Ring_polynom.PEX Z 3) (Ring_polynom.PEX Z 6)) - (Ring_polynom.PEmul - (Ring_polynom.PEmul (Ring_polynom.PEX Z 1) - (Ring_polynom.PEX Z 2)) (Ring_polynom.PEX Z 5)))) - (Ring_polynom.PEX Z 8)) - :: Ring_polynom.PEsub - (Ring_polynom.PEmul - (Ring_polynom.PEadd (Ring_polynom.PEc 1%Z) - (Ring_polynom.PEmul - (Ring_polynom.PEmul - (Ring_polynom.PEmul - (Ring_polynom.PEmul (Ring_polynom.PEX Z 4) - (Ring_polynom.PEX Z 2)) (Ring_polynom.PEX Z 5)) - (Ring_polynom.PEX Z 3)) (Ring_polynom.PEX Z 6))) - (Ring_polynom.PEX Z 10)) (Ring_polynom.PEc 1%Z) - :: Ring_polynom.PEsub - (Ring_polynom.PEmul - (Ring_polynom.PEsub (Ring_polynom.PEc 1%Z) - (Ring_polynom.PEmul - (Ring_polynom.PEmul - (Ring_polynom.PEmul - (Ring_polynom.PEmul (Ring_polynom.PEX Z 4) - (Ring_polynom.PEX Z 2)) - (Ring_polynom.PEX Z 5)) (Ring_polynom.PEX Z 3)) - (Ring_polynom.PEX Z 6))) (Ring_polynom.PEX Z 9)) - (Ring_polynom.PEc 1%Z) - :: Ring_polynom.PEsub - (Ring_polynom.PEadd - (Ring_polynom.PEmul (Ring_polynom.PEX Z 1) - (Ring_polynom.PEmul (Ring_polynom.PEX Z 7) - (Ring_polynom.PEX Z 7))) - (Ring_polynom.PEmul (Ring_polynom.PEX Z 8) - (Ring_polynom.PEX Z 8))) - (Ring_polynom.PEadd (Ring_polynom.PEc 1%Z) - (Ring_polynom.PEmul - (Ring_polynom.PEmul (Ring_polynom.PEX Z 4) - (Ring_polynom.PEmul (Ring_polynom.PEX Z 7) - (Ring_polynom.PEX Z 7))) - (Ring_polynom.PEmul (Ring_polynom.PEX Z 8) - (Ring_polynom.PEX Z 8)))) - :: Ring_polynom.PEsub - (Ring_polynom.PEadd - (Ring_polynom.PEmul (Ring_polynom.PEX Z 1) - (Ring_polynom.PEmul (Ring_polynom.PEX Z 5) - (Ring_polynom.PEX Z 5))) - (Ring_polynom.PEmul (Ring_polynom.PEX Z 6) - (Ring_polynom.PEX Z 6))) - (Ring_polynom.PEadd (Ring_polynom.PEc 1%Z) - (Ring_polynom.PEmul - (Ring_polynom.PEmul (Ring_polynom.PEX Z 4) - (Ring_polynom.PEmul (Ring_polynom.PEX Z 5) - (Ring_polynom.PEX Z 5))) - (Ring_polynom.PEmul (Ring_polynom.PEX Z 6) - (Ring_polynom.PEX Z 6)))) - :: Ring_polynom.PEsub - (Ring_polynom.PEadd - (Ring_polynom.PEmul (Ring_polynom.PEX Z 1) - (Ring_polynom.PEmul (Ring_polynom.PEX Z 2) - (Ring_polynom.PEX Z 2))) - (Ring_polynom.PEmul (Ring_polynom.PEX Z 3) - (Ring_polynom.PEX Z 3))) - (Ring_polynom.PEadd (Ring_polynom.PEc 1%Z) - (Ring_polynom.PEmul - (Ring_polynom.PEmul (Ring_polynom.PEX Z 4) - (Ring_polynom.PEmul (Ring_polynom.PEX Z 2) - (Ring_polynom.PEX Z 2))) - (Ring_polynom.PEmul (Ring_polynom.PEX Z 3) - (Ring_polynom.PEX Z 3)))) :: nil)%list ) in - NsatzTactic.nsatz_compute - (@cons _ (@Ring_polynom.PEc _ sugar) (@cons _ (@Ring_polynom.PEc _ nparams) (@cons _ (@Ring_polynom.PEpow _ reified_goal power) reified_givens))). -Abort. diff --git a/stdlib/test-suite/bugs/bug_5445.v b/stdlib/test-suite/bugs/bug_5445.v deleted file mode 100644 index d3c82fc5c104..000000000000 --- a/stdlib/test-suite/bugs/bug_5445.v +++ /dev/null @@ -1,11 +0,0 @@ -From Stdlib Require Import NsatzTactic. -(** Ensure that loading the nsatz tactic doesn't load the reals *) -Fail Module M := Stdlib.Reals.Rdefinitions. -(** Ensure that loading the nsatz tactic doesn't load classic *) -Fail Check Stdlib.Logic.Classical_Prop.classic. -(** Ensure that this test-case hasn't messed up about the location of the reals / how to check for them *) -From Stdlib Require Rdefinitions. -Module M := Stdlib.Reals.Rdefinitions. -(** Ensure that this test-case hasn't messed up about the location of classic / how to check for it *) -From Stdlib Require Classical_Prop. -Check Stdlib.Logic.Classical_Prop.classic. diff --git a/stdlib/test-suite/bugs/bug_5493.v b/stdlib/test-suite/bugs/bug_5493.v deleted file mode 100644 index d0627fb9090c..000000000000 --- a/stdlib/test-suite/bugs/bug_5493.v +++ /dev/null @@ -1,9 +0,0 @@ -From Stdlib Require Import FSetAVL. -Declare Module NatKey : OrderedType.OrderedType - with Definition t := nat - with Definition eq := @ eq nat. -#[local] Remove Hints NatKey.eq_trans NatKey.eq_refl. -Module Import NatMap := FSetAVL.Make NatKey. -Goal forall x y, NatMap.E.eq x y. - Timeout 1 intros; debug eauto. -Admitted. diff --git a/stdlib/test-suite/bugs/bug_5521.v b/stdlib/test-suite/bugs/bug_5521.v deleted file mode 100644 index b8c7bc6cd905..000000000000 --- a/stdlib/test-suite/bugs/bug_5521.v +++ /dev/null @@ -1,68 +0,0 @@ -From Stdlib Require Export Utf8. -From Stdlib Require Export Program. -From Stdlib Require Export CEquivalence. -From Stdlib Require Export CMorphisms. -From Stdlib Require Setoid. - -(* Notation "f ā‰ƒ g" := (equiv f g) (at level 79, only parsing). *) - -Reserved Infix "~>" (at level 90, right associativity). - -Class Category := { - ob : Type; - - uhom := Type : Type; - hom : ob -> ob -> uhom where "a ~> b" := (hom a b); - - id {A} : A ~> A; - compose {A B C} (f: B ~> C) (g : A ~> B) : A ~> C - where "f āˆ˜ g" := (compose f g); - - id_left {X Y} (f : X ~> Y) : id āˆ˜ f = f; - - comp_assoc {X Y Z W} (f : Z ~> W) (g : Y ~> Z) (h : X ~> Y) : - f āˆ˜ (g āˆ˜ h) = (f āˆ˜ g) āˆ˜ h -}. - -Class Isomorphism `{C : Category} (X Y : @ob C) : Type := { - to :: hom X Y; - from : hom Y X - - (* If these two lines are commented out, the rewrite works at the bottom. *) - ; iso_to_from : compose to from = id - ; iso_from_to : compose from to = id -}. - -#[export] Program Instance isomorphism_equivalence `{C : Category} : - Equivalence Isomorphism. -Next Obligation. - repeat intro. - unshelve econstructor; try exact id; - rewrite id_left; reflexivity. -Defined. -Next Obligation. - repeat intro; destruct X. - unshelve econstructor; auto. -Defined. -Next Obligation. - repeat intro; destruct X, X0. - unshelve econstructor; - first [ exact (compose to1 to0) - | exact (compose from0 from1) - | rewrite <- !comp_assoc; - rewrite (comp_assoc to0); - rewrite iso_to_from0; - rewrite id_left; assumption - | rewrite <- !comp_assoc; - rewrite (comp_assoc from1); - rewrite iso_from_to1; - rewrite id_left; assumption ]. -Defined. - -Goal forall `{C : Category} {X Y Z : @ob C} - (f : Isomorphism Y Z) - (g : Isomorphism X Y), - Isomorphism X Z. - intros. - rewrite g. -Abort. diff --git a/stdlib/test-suite/bugs/bug_5618.v b/stdlib/test-suite/bugs/bug_5618.v deleted file mode 100644 index e8c9b884d2a0..000000000000 --- a/stdlib/test-suite/bugs/bug_5618.v +++ /dev/null @@ -1,9 +0,0 @@ -From Stdlib Require Import FunInd. - -Function test {T} (v : T) (x : nat) : nat := - match x with - | 0 => 0 - | S x' => test v x' - end. - -Check R_test_complete. diff --git a/stdlib/test-suite/bugs/bug_5692.v b/stdlib/test-suite/bugs/bug_5692.v deleted file mode 100644 index aa4ed404519a..000000000000 --- a/stdlib/test-suite/bugs/bug_5692.v +++ /dev/null @@ -1,88 +0,0 @@ -Set Primitive Projections. -From Stdlib Require Import ZArith ssreflect. - -Module Test1. - -Structure semigroup := SemiGroup { - sg_car :> Type; - sg_op : sg_car -> sg_car -> sg_car; -}. - -Structure monoid := Monoid { - monoid_car :> Type; - monoid_op : monoid_car -> monoid_car -> monoid_car; - monoid_unit : monoid_car; -}. - -Coercion monoid_sg (X : monoid) : semigroup := - SemiGroup (monoid_car X) (monoid_op X). -Canonical Structure monoid_sg. - -Parameter X : monoid. -Parameter x y : X. - -Check (sg_op _ x y). - -End Test1. - -Module Test2. - -Structure semigroup := SemiGroup { - sg_car :> Type; - sg_op : sg_car -> sg_car -> sg_car; -}. - -Structure monoid := Monoid { - monoid_car :> Type; - monoid_op : monoid_car -> monoid_car -> monoid_car; - monoid_unit : monoid_car; - monoid_left_id x : monoid_op monoid_unit x = x; -}. - -Coercion monoid_sg (X : monoid) : semigroup := - SemiGroup (monoid_car X) (monoid_op X). -Canonical Structure monoid_sg. - -Canonical Structure nat_sg := SemiGroup nat plus. -Canonical Structure nat_monoid := Monoid nat plus 0 plus_O_n. - -Lemma foo (x : nat) : 0 + x = x. -Proof. -apply monoid_left_id. -Qed. - -End Test2. - -Module Test3. - -Structure semigroup := SemiGroup { - sg_car :> Type; - sg_op : sg_car -> sg_car -> sg_car; -}. - -Structure group := Something { - group_car :> Type; - group_op : group_car -> group_car -> group_car; - group_neg : group_car -> group_car; - group_neg_op' x y : group_neg (group_op x y) = group_op (group_neg x) (group_neg y) -}. - -Coercion group_sg (X : group) : semigroup := - SemiGroup (group_car X) (group_op X). -Canonical Structure group_sg. - -Axiom group_neg_op : forall (X : group) (x y : X), - group_neg X (sg_op (group_sg X) x y) = sg_op (group_sg X) (group_neg X x) (group_neg X y). - -Canonical Structure Z_sg := SemiGroup Z Z.add . -Canonical Structure Z_group := Something Z Z.add Z.opp Z.opp_add_distr. - -Lemma foo (x y : Z) : - sg_op Z_sg (group_neg Z_group x) (group_neg Z_group y) = - group_neg Z_group (sg_op Z_sg x y). -Proof. - rewrite -group_neg_op. - reflexivity. -Qed. - -End Test3. diff --git a/stdlib/test-suite/bugs/bug_5713.v b/stdlib/test-suite/bugs/bug_5713.v deleted file mode 100644 index f48e82d28e42..000000000000 --- a/stdlib/test-suite/bugs/bug_5713.v +++ /dev/null @@ -1,15 +0,0 @@ -(* Checking that classical_right/classical_left work in an empty context *) - -From Stdlib Require Import Classical. - -Parameter A:Prop. - -Goal A \/ ~A. -classical_right. -assumption. -Qed. - -Goal ~A \/ A. -classical_left. -assumption. -Qed. diff --git a/stdlib/test-suite/bugs/bug_5744.v b/stdlib/test-suite/bugs/bug_5744.v deleted file mode 100644 index 64ee974bd0f6..000000000000 --- a/stdlib/test-suite/bugs/bug_5744.v +++ /dev/null @@ -1,7 +0,0 @@ -From Stdlib Require FunInd. -Set Universe Polymorphism. -Inductive ARG := phy | inf. -Function Phy (x:ARG): ARG := match x with inf => inf | _ => phy end -with Inf (x:ARG): ARG := match x with phy => phy | _ => inf end. -(* Used to be: Anomaly: Universe Top.998 undefined. Please report at -http://coq.inria.fr/bugs/.*) diff --git a/stdlib/test-suite/bugs/bug_5777.v b/stdlib/test-suite/bugs/bug_5777.v deleted file mode 100644 index 1908ae5e745d..000000000000 --- a/stdlib/test-suite/bugs/bug_5777.v +++ /dev/null @@ -1,29 +0,0 @@ -From Stdlib.Program Require Import Tactics Utils. -From Stdlib Require Import JMeq Lia. - -#[local] -Open Scope program_scope. - -Inductive vector (A: Type) : nat -> Type := -| vcons {n:nat} : A -> vector A n -> vector A (S n) -| vnil : vector A 0. - -Arguments vcons [A n] _ _. -Arguments vnil {A}. - -#[program] -Fixpoint drop - {A: Type} - {n: nat} - (v: vector A n) - (b: nat | b <= n) - {struct v} - : vector A (n - b) := - match b, v with - | 0, v => v - | S b', vcons _ r => drop r b' - | _, _ => ! - end. -Next Obligation. lia. Qed. -Next Obligation. lia. Qed. -Next Obligation. Admitted. (* Can we do better? *) diff --git a/stdlib/test-suite/bugs/bug_6191.v b/stdlib/test-suite/bugs/bug_6191.v deleted file mode 100644 index ed267c5fd87e..000000000000 --- a/stdlib/test-suite/bugs/bug_6191.v +++ /dev/null @@ -1,16 +0,0 @@ -(* Check a 8.7.1 regression in ring_simplify *) - -From Stdlib Require Import ArithRing BinNat. -Goal forall f x, (2+x+f (N.to_nat 2)+3=4). -intros. -ring_simplify (2+x+f (N.to_nat 2)+3). -match goal with |- x + f (N.to_nat 2) + 5 = 4 => idtac end. -Abort. - -From Stdlib Require Import ZArithRing BinInt. -Open Scope Z_scope. -Goal forall x, (2+x+3=4). -intros. -ring_simplify (2+x+3). -match goal with |- x+5 = 4 => idtac end. -Abort. diff --git a/stdlib/test-suite/bugs/bug_6378.v b/stdlib/test-suite/bugs/bug_6378.v deleted file mode 100644 index 1b4c8d4065cb..000000000000 --- a/stdlib/test-suite/bugs/bug_6378.v +++ /dev/null @@ -1,27 +0,0 @@ -From Stdlib Require Import ZArith. -Ltac profile_constr tac := - let dummy := match goal with _ => reset ltac profile; start ltac profiling end in - let ret := match goal with _ => tac () end in - let dummy := match goal with _ => stop ltac profiling; show ltac profile end in - pose 1. - -Ltac slow _ := eval vm_compute in (Z.div_eucl, Z.div_eucl, Z.div_eucl, Z.div_eucl, Z.div_eucl). - -Ltac manipulate_ltac_prof := - start ltac profiling; - reset ltac profile; - try ((idtac + reset ltac profile + idtac); fail); - try ((idtac + start ltac profiling + idtac); fail); - try ((idtac + stop ltac profiling + idtac); fail). - -Goal True. - start ltac profiling. - reset ltac profile. - manipulate_ltac_prof. - reset ltac profile. - stop ltac profiling. - Set Warnings Append "+profile-invalid-stack-no-self". - time profile_constr slow. - show ltac profile cutoff 0. - show ltac profile "slow". -Abort. diff --git a/stdlib/test-suite/bugs/bug_6529.v b/stdlib/test-suite/bugs/bug_6529.v deleted file mode 100644 index aa8c966ede86..000000000000 --- a/stdlib/test-suite/bugs/bug_6529.v +++ /dev/null @@ -1,16 +0,0 @@ -From Stdlib Require Import Vector Program. - -Program Definition append_nil_def := - forall A n (ls: t A n), append ls (nil A) = ls. (* Works *) - -Lemma append_nil : append_nil_def. (* Works *) -Proof. -Admitted. - -Program Lemma append_nil' : - forall A n (ls: t A n), append ls (nil A) = ls. -Abort. - -Fail Program Lemma append_nil'' : - forall A B n (ls: t A n), append ls (nil A) = ls. -(* Error: Anomaly "Evar ?X25 was not declared." Please report at http://coq.inria.fr/bugs/. *) diff --git a/stdlib/test-suite/bugs/bug_7017.v b/stdlib/test-suite/bugs/bug_7017.v deleted file mode 100644 index 92e5115855fe..000000000000 --- a/stdlib/test-suite/bugs/bug_7017.v +++ /dev/null @@ -1,32 +0,0 @@ -From Stdlib Require Import Extraction BinPos. -From Stdlib Require Import ExtrOcamlNatInt. - -From Stdlib Require Import Extraction BinPos. - -Definition test (a:Decimal.int) n m (H:m>0) := - let (q,r,_,_) := Euclid.eucl_dev m H n in - (Decimal.norm a, Nat.compare n (q*m+r)). - -Extraction TestCompile test. - -(* Test combination of Decimal.int with ExtrOcamlInt63 *) - -From Stdlib Require Import ExtrOCamlInt63. - -Definition f n p := (CompOpp n, Decimal.norm p). - -Extraction TestCompile f. - -(* Test combination of Decimal.int with ExtrOcamlIntConv *) - -From Stdlib Require Import ExtrOcamlIntConv. - -Definition g n p := (n_of_int n, Decimal.norm p). - -Extraction TestCompile g. - -(* Test combination of Decimal.int with ExtrOcamlZInt *) - -From Stdlib Require Import ExtrOcamlZInt ZArith. - -Extraction TestCompile Z.add. diff --git a/stdlib/test-suite/bugs/bug_8119.v b/stdlib/test-suite/bugs/bug_8119.v deleted file mode 100644 index 2cd46ad32585..000000000000 --- a/stdlib/test-suite/bugs/bug_8119.v +++ /dev/null @@ -1,46 +0,0 @@ -From Stdlib Require Import String. - -Section T. - Eval vm_compute in let x := tt in _. -(* Error: Anomaly "Uncaught exception Constr.DestKO." Please report at http://coq.inria.fr/bugs/. *) - Eval vm_compute in let _ := Set in _. -(* Error: Anomaly "Uncaught exception Constr.DestKO." Please report at http://coq.inria.fr/bugs/. *) - Eval vm_compute in let _ := Prop in _. -(* Error: Anomaly "Uncaught exception Constr.DestKO." Please report at http://coq.inria.fr/bugs/. *) -End T. - -Section U0. - Let n : unit := tt. - Eval vm_compute in _. -(* Error: Anomaly "Uncaught exception Constr.DestKO." Please report at http://coq.inria.fr/bugs/. *) - Goal exists tt : unit, tt = tt. eexists. vm_compute. Abort. -(* Error: Anomaly "Uncaught exception Constr.DestKO." Please report at http://coq.inria.fr/bugs/. *) -End U0. - -Section S0. - Let LF : string := String (Stdlib.Strings.Ascii.Ascii false true false true false false false false) "". - Eval vm_compute in _. -(* Error: Anomaly "Uncaught exception Constr.DestKO." Please report at http://coq.inria.fr/bugs/. *) - Goal exists tt : unit, tt = tt. eexists. vm_compute. Abort. -(* Error: Anomaly "Uncaught exception Constr.DestKO." Please report at http://coq.inria.fr/bugs/. *) -End S0. - -Class T := { }. -Section S1. - Context {p : T}. - Let LF : string := String (Stdlib.Strings.Ascii.Ascii false true false true false false false false) "". - Eval vm_compute in _. -(* Error: Anomaly "Uncaught exception Not_found." Please report at http://coq.inria.fr/bugs/. *) - Goal exists tt : unit, tt = tt. eexists. vm_compute. Abort. -(* Error: Anomaly "Uncaught exception Not_found." Please report at http://coq.inria.fr/bugs/. *) -End S1. - -Class M := { m : Type }. -Section S2. - Context {p : M}. - Let LF : string := String (Stdlib.Strings.Ascii.Ascii false true false true false false false false) "". - Eval vm_compute in _. -(* Error: Anomaly "File "pretyping/vnorm.ml", line 60, characters 9-15: Assertion failed." *) - Goal exists tt : unit, tt = tt. eexists. vm_compute. Abort. -(* Error: Anomaly "File "pretyping/vnorm.ml", line 60, characters 9-15: Assertion failed." *) -End S2. diff --git a/stdlib/test-suite/bugs/bug_8121.v b/stdlib/test-suite/bugs/bug_8121.v deleted file mode 100644 index 6c7bab42dedf..000000000000 --- a/stdlib/test-suite/bugs/bug_8121.v +++ /dev/null @@ -1,46 +0,0 @@ -From Stdlib Require Import String. - -Section T. - Eval native_compute in let x := tt in _. -(* Error: Anomaly "Uncaught exception Constr.DestKO." Please report at http://coq.inria.fr/bugs/. *) - Eval native_compute in let _ := Set in _. -(* Error: Anomaly "Uncaught exception Constr.DestKO." Please report at http://coq.inria.fr/bugs/. *) - Eval native_compute in let _ := Prop in _. -(* Error: Anomaly "Uncaught exception Constr.DestKO." Please report at http://coq.inria.fr/bugs/. *) -End T. - -Section U0. - Let n : unit := tt. - Eval native_compute in _. -(* Error: Anomaly "Uncaught exception Constr.DestKO." Please report at http://coq.inria.fr/bugs/. *) - Goal exists tt : unit, tt = tt. eexists. native_compute. Abort. -(* Error: Anomaly "Uncaught exception Constr.DestKO." Please report at http://coq.inria.fr/bugs/. *) -End U0. - -Section S0. - Let LF : string := String (Stdlib.Strings.Ascii.Ascii false true false true false false false false) "". - Eval native_compute in _. -(* Error: Anomaly "Uncaught exception Constr.DestKO." Please report at http://coq.inria.fr/bugs/. *) - Goal exists tt : unit, tt = tt. eexists. native_compute. Abort. -(* Error: Anomaly "Uncaught exception Constr.DestKO." Please report at http://coq.inria.fr/bugs/. *) -End S0. - -Class T := { }. -Section S1. - Context {p : T}. - Let LF : string := String (Stdlib.Strings.Ascii.Ascii false true false true false false false false) "". - Eval native_compute in _. -(* Error: Anomaly "Uncaught exception Not_found." Please report at http://coq.inria.fr/bugs/. *) - Goal exists tt : unit, tt = tt. eexists. native_compute. Abort. -(* Error: Anomaly "Uncaught exception Not_found." Please report at http://coq.inria.fr/bugs/. *) -End S1. - -Class M := { m : Type }. -Section S2. - Context {p : M}. - Let LF : string := String (Stdlib.Strings.Ascii.Ascii false true false true false false false false) "". - Eval native_compute in _. -(* Error: Anomaly "File "pretyping/vnorm.ml", line 60, characters 9-15: Assertion failed." *) - Goal exists tt : unit, tt = tt. eexists. native_compute. Abort. -(* Error: Anomaly "File "pretyping/vnorm.ml", line 60, characters 9-15: Assertion failed." *) -End S2. diff --git a/stdlib/test-suite/bugs/bug_8459.v b/stdlib/test-suite/bugs/bug_8459.v deleted file mode 100644 index 862abc96365c..000000000000 --- a/stdlib/test-suite/bugs/bug_8459.v +++ /dev/null @@ -1,24 +0,0 @@ -From Stdlib Require Import Vector. - -Axiom exfalso : False. - -Fixpoint all_then_someV (n:nat) (l:Vector.t bool n) {struct l}: -(Vector.fold_left orb false l) = false -> -(forall p, (Vector.nth l p ) = false). -Proof. -intros. -destruct l. -inversion p. -revert h l H. -set (P := fun n p => forall (h : bool) (l : t bool n), -fold_left orb false (cons bool h n l) = false -> @eq bool (@nth bool (S n) (cons bool h n l) p) false). -revert n p. -fix loop 1. -unshelve eapply (@Fin.rectS P). -+ elim exfalso. -+ unfold P. - intros. - eapply all_then_someV. - exact H0. -Fail Defined. -Abort. diff --git a/stdlib/test-suite/bugs/bug_9201.v b/stdlib/test-suite/bugs/bug_9201.v deleted file mode 100644 index b8d85a6c4919..000000000000 --- a/stdlib/test-suite/bugs/bug_9201.v +++ /dev/null @@ -1,22 +0,0 @@ -From Stdlib Require Import Ring. - -Set Universe Polymorphism. -Inductive word : Type -> Type :=. -Axiom wzero : forall sz, word sz. -Axiom wone : forall sz, word sz. -Axiom wplus : forall sz, word sz -> word sz -> word sz. -Axiom wmult : forall sz, word sz -> word sz -> word sz. -Axiom wminus : forall sz, word sz -> word sz -> word sz. -Axiom wneg : forall sz, word sz -> word sz. -Axiom wring : forall sz, ring_theory (wzero sz) (wone sz) (@wplus sz) (@wmult sz) (@wminus sz) (@wneg sz) (@eq _). -Local Unset Universe Polymorphism. -Section foo. - Context (sz : Type). - Add Ring word_sz_ring : (wring sz). (* success *) -End foo. -Local Set Universe Polymorphism. -Section foo'. - Context (sz : Type). - Fail Add Ring word_sz_ring' : (wring sz). - (* Error: Cannot add a universe monomorphic declaration when section polymorphic universes are present. *) -End foo'. diff --git a/stdlib/test-suite/bugs/bug_9268.v b/stdlib/test-suite/bugs/bug_9268.v deleted file mode 100644 index 587502b7923f..000000000000 --- a/stdlib/test-suite/bugs/bug_9268.v +++ /dev/null @@ -1,46 +0,0 @@ -From Stdlib Require Import ZArith. -From Stdlib Require Import Lia. - -Local Open Scope Z_scope. - -Definition Register := Z%type. - -Definition Opcode := Z%type. - -Inductive InstructionI : Type - := Lb : Register -> Register -> Z -> InstructionI - | InvalidI : InstructionI. - -Inductive Instruction : Type - := IInstruction : InstructionI -> Instruction. - -Definition funct3_LB : Z := 0. - -Definition opcode_LOAD : Opcode := 3. - -Set Universe Polymorphism. - -Definition MachineInt := Z. - -Definition funct3_JALR := 0. - -Axiom InstructionMapper: Type -> Type. - -Definition apply_InstructionMapper(mapper: InstructionMapper Z)(inst: Instruction): Z := - match inst with - | IInstruction InvalidI => 2 - | IInstruction (Lb rd rs1 oimm12) => 3 - end. - -Axiom Encoder: InstructionMapper MachineInt. - -Definition encode: Instruction -> MachineInt := apply_InstructionMapper Encoder. - -Lemma foo: forall (ins: InstructionI), - 0 <= encode (IInstruction ins) -> - 0 <= encode (IInstruction ins) . -Proof. - Set Printing Universes. - intros. - lia. -Qed. diff --git a/stdlib/test-suite/bugs/bug_9512.v b/stdlib/test-suite/bugs/bug_9512.v deleted file mode 100644 index 621d7f782c92..000000000000 --- a/stdlib/test-suite/bugs/bug_9512.v +++ /dev/null @@ -1,31 +0,0 @@ -From Stdlib Require Import BinInt Lia. - -Set Primitive Projections. -Record params := { width : Z }. -Definition p : params := Build_params 64. - -Definition width' := width. -Set Printing All. - -Lemma foo : width p = 0%Z -> width p = 0%Z. - intros. - - assert_succeeds (enough True; [lia|]). - -(* H : @eq Z (width p) Z0 *) -(* ============================ *) -(* @eq Z (width p) Z0 *) - - change (width' p = 0%Z) in H;cbv [width'] in H. - (* check that we correctly got the compat constant in H *) - Fail match goal with H : ?l = _ |- ?l' = _ => constr_eq l l' end. - -(* H : @eq Z (width p) Z0 *) -(* ============================ *) -(* @eq Z (width p) Z0 *) - - assert_succeeds (enough True; [lia|]). - - lia. - (* Tactic failure: Cannot find witness. *) -Qed. diff --git a/stdlib/test-suite/bugs/bug_9580.v b/stdlib/test-suite/bugs/bug_9580.v deleted file mode 100644 index ddea9a89e976..000000000000 --- a/stdlib/test-suite/bugs/bug_9580.v +++ /dev/null @@ -1,13 +0,0 @@ -From Stdlib Require Import List. -From Stdlib Require Import Decidable PeanoNat. - -Theorem count_occ_cons: forall l1 l2 (p1 p2:nat) n, count_occ Nat.eq_dec l1 p1 + n = - count_occ Nat.eq_dec l2 p1 -> - count_occ Nat.eq_dec (p2 :: l1) p1 + n = count_occ Nat.eq_dec (p2 :: l2) p1. -Proof. - intros. destruct (Nat.eq_dec p2 p1). - - eapply eq_trans. - + eapply eq_ind_r with (A:=nat) (x:= _) (P:= (fun x => x + n = _)). - eapply eq_refl. eapply count_occ_cons_eq. apply e. - + eapply eq_trans. (* <-- Error used to be: Anomaly "Uncaught exception Not_found." *) -Abort. diff --git a/stdlib/test-suite/bugs/bug_9652.v b/stdlib/test-suite/bugs/bug_9652.v deleted file mode 100644 index 212d02670ee9..000000000000 --- a/stdlib/test-suite/bugs/bug_9652.v +++ /dev/null @@ -1,19 +0,0 @@ -Set Universe Polymorphism. -From Stdlib Require Import BinInt. -Class word_interface (width : Z) : Type := Build_word - { rep : Type; - unsigned : rep -> Z; - of_Z : Z -> rep; - sub : rep -> rep -> rep }. -Coercion rep : word_interface >-> Sortclass. -Axiom word : word_interface 64. Local Existing Instance word. -Goal - forall (x : list word) (x1 x2 : word), - (unsigned (sub x2 x1) / 2 ^ 4 * 2 ^ 3 < - unsigned (of_Z 8) * Z.of_nat (Datatypes.length x))%Z. -Proof. - intros. - assert (unsigned (sub x2 x1) = unsigned (sub x2 x1)) by exact eq_refl. - Fail progress rewrite H. - Fail rewrite H. -Abort. diff --git a/stdlib/test-suite/bugs/bug_9741.v b/stdlib/test-suite/bugs/bug_9741.v deleted file mode 100644 index c3e2faef9d0d..000000000000 --- a/stdlib/test-suite/bugs/bug_9741.v +++ /dev/null @@ -1,21 +0,0 @@ -(* This was failing at parsing *) - -Notation "'a'" := tt (only printing). -Goal True. let a := constr:(1+1) in idtac a. Abort. - -(* Idem *) - -From Stdlib Require Import String. -From Stdlib Require Import ZArith. -Open Scope string_scope. - -Axiom Ox: string -> Z. - -Axiom isMMIOAddr: Z -> Prop. - -Notation "'Ox' a" := (Ox a) (only printing, at level 10, format "'Ox' a"). - -Goal False. - set (f := isMMIOAddr). - set (x := f (Ox "0018")). -Abort. diff --git a/stdlib/test-suite/bugs/bug_9851.v b/stdlib/test-suite/bugs/bug_9851.v deleted file mode 100644 index c612f8093bfb..000000000000 --- a/stdlib/test-suite/bugs/bug_9851.v +++ /dev/null @@ -1,18 +0,0 @@ -From Stdlib Require Import Ring_base. -Record word : Type := Build_word - { rep : Type; - zero : rep; one: rep; - add : rep -> rep -> rep; - sub : rep -> rep -> rep; - opp : rep -> rep; - mul : rep -> rep -> rep; - }. -Axiom rth - : forall (word : word ), - @ring_theory (@rep word) - (@zero word) - (@one word) (@add word) - (@mul word) (@sub word) - (@opp word) (@eq (@rep word)). - -Fail Add Ring wring: (@rth _). diff --git a/stdlib/test-suite/complexity/ConstructiveCauchyRealsPerformance.v b/stdlib/test-suite/complexity/ConstructiveCauchyRealsPerformance.v deleted file mode 100644 index 0d5fe7c27a7c..000000000000 --- a/stdlib/test-suite/complexity/ConstructiveCauchyRealsPerformance.v +++ /dev/null @@ -1,249 +0,0 @@ -(* Here we give some functions that compute non-rational reals, - to measure the computation speed. *) -(* Expected time < 5.00s *) - -From Stdlib Require Import QArith Qabs Qpower. -From Stdlib Require Import ConstructiveCauchyRealsMult. -From Stdlib Require Import Lqa. -From Stdlib Require Import Lia. - -Local Open Scope CReal_scope. - -(* We would need a shift instruction on positives to do this properly *) - -Definition CReal_sqrt_Q_seq (q : Q) (n : Z) : Q - := let (k,j) := q in - match k with - | Z0 => 0 - | Z.pos i => match n with - | Z0 - | Z.pos _ => Z.pos (Pos.sqrt (i*j)) # (j) - | Z.neg n' => Z.pos (Pos.sqrt (i*j*2^(2*n'))) # (j*2^n') - end - | Z.neg i => 0 (* unused *) - end. - -Local Lemma Pos_pow_twice_r a b : (a^(2*b) = a^b * a^b)%positive. -Proof. - apply Pos2Z.inj. - rewrite Pos2Z.inj_mul. - do 2 rewrite Pos2Z.inj_pow. - rewrite Pos2Z.inj_mul. - apply Z.pow_twice_r. -Qed. - -(* Approximation of the square root from below, - improves the convergence modulus. *) -Lemma CReal_sqrt_Q_le_below : forall (q : Q) (n : Z), - (0<=q)%Q -> (CReal_sqrt_Q_seq q n * CReal_sqrt_Q_seq q n <= q)%Q. -Proof. - intros q n Hqpos. destruct q as [k j]. unfold CReal_sqrt_Q_seq. - destruct k as [|i|i]. - - apply Z.le_refl. - - destruct n as [|n|n]. - + pose proof (Pos.sqrt_spec (i * j)) as H. simpl in H. - destruct H as [H _]. - unfold Qle, Qmult, Qnum, Qden. - rewrite <- Pos2Z.inj_mul, <- Pos2Z.inj_mul, <- Pos2Z.inj_mul. - apply Pos2Z.pos_le_pos. rewrite (Pos.mul_assoc i j j). - apply Pos.mul_le_mono_r; exact H. - + pose proof (Pos.sqrt_spec (i * j)) as H. simpl in H. - destruct H as [H _]. - unfold Qle, Qmult, Qnum, Qden. - rewrite <- Pos2Z.inj_mul, <- Pos2Z.inj_mul, <- Pos2Z.inj_mul. - apply Pos2Z.pos_le_pos. rewrite (Pos.mul_assoc i j j). - apply Pos.mul_le_mono_r; exact H. - + pose proof (Pos.sqrt_spec (i * j * 2^(2*n))) as H. simpl in H. - destruct H as [H _]. - unfold Qle, Qmult, Qnum, Qden. - rewrite <- Pos2Z.inj_mul, <- Pos2Z.inj_mul, <- Pos2Z.inj_mul. - apply Pos2Z.pos_le_pos. rewrite (Pos.mul_comm j (2^n)) at 2. - do 3 rewrite Pos.mul_assoc. - apply Pos.mul_le_mono_r. - simpl. - rewrite Pos_pow_twice_r in H at 3. - rewrite Pos.mul_assoc in H. - exact H. - - exact Hqpos. -Qed. - -Lemma CReal_sqrt_Q_lt_above : forall (q : Q) (n : Z), - (0 <= q)%Q -> (q < ((CReal_sqrt_Q_seq q n + 2^n) * (CReal_sqrt_Q_seq q n + 2^n)))%Q. -Proof. - intros. destruct q as [k j]. unfold CReal_sqrt_Q_seq. - destruct k as [|i|i]. - - ring_simplify. - setoid_rewrite <- Qpower_mult. - setoid_rewrite Qreduce_zero. - pose proof Qpower_0_lt 2 (n*2)%Z ltac:(lra). - lra. - - destruct n as [|n|n]. - + pose proof (Pos.sqrt_spec (i * j)). simpl in H0. - destruct H0 as [_ H0]. - change (2^0)%Q with 1%Q. - unfold Qlt, Qplus, Qmult, Qnum, Qden. - rewrite Pos.mul_1_r, Z.mul_1_r, Z.mul_1_l. - repeat rewrite <- Pos2Z.inj_add, <- Pos2Z.inj_mul. - apply Pos2Z.pos_lt_pos. - rewrite Pos.mul_assoc. - apply Pos.mul_lt_mono_r. - apply (Pos.lt_le_trans _ _ _ H0). - apply Pos.mul_le_mono; lia. - + pose proof (Pos.sqrt_spec (i * j)). simpl in H0. - destruct H0 as [_ H0]. - rewrite Qpower_decomp_pos. - unfold Qlt, Qplus, Qmult, Qnum, Qden. - rewrite PosExtra.Pos_pow_1_r. - rewrite Pos.mul_1_r, Z.mul_1_r. - rewrite <- Pos2Z.inj_pow; do 2 rewrite <- Pos2Z.inj_mul; rewrite <- Pos2Z.inj_add. - apply Pos2Z.pos_lt_pos. - rewrite Pos.mul_assoc. - apply Pos.mul_lt_mono_r. - apply (Pos.lt_le_trans _ _ _ H0). - apply Pos.mul_le_mono; - pose proof Pos.le_1_l (2 ^ n * j)%positive; lia. - + pose proof (Pos.sqrt_spec (i * j * 2 ^ (2 * n))). simpl in H0. - destruct H0 as [_ H0]. - rewrite <- Pos2Z.opp_pos, Qpower_opp. - rewrite Qpower_decomp_pos. - rewrite <- Pos2Z.inj_pow, PosExtra.Pos_pow_1_r, Qinv_pos. - unfold Qlt, Qplus, Qmult, Qnum, Qden. - repeat rewrite Pos2Z.inj_mul. - ring_simplify. - replace (Z.pos i * Z.pos j ^ 2 * Z.pos (2 ^ n) ^ 4)%Z - with ((Z.pos i * Z.pos j * Z.pos (2 ^ n) ^ 2) * (Z.pos j * Z.pos (2 ^ n) ^ 2))%Z by ring. - replace ( - Z.pos j ^ 3 * Z.pos (2 ^ n) ^ 2 + - 2 * Z.pos j ^ 2 * Z.pos (2 ^ n) ^ 2 * Z.pos (Pos.sqrt (i * j * 2 ^ (2 * n))) + - Z.pos j * Z.pos (2 ^ n) ^ 2 * Z.pos (Pos.sqrt (i * j * 2 ^ (2 * n))) ^ 2)%Z - with ( - (Z.pos j + Z.pos (Pos.sqrt (i * j * 2 ^ (2 * n))))^2 * - (Z.pos j * Z.pos (2 ^ n) ^ 2))%Z by ring. - repeat rewrite Pos2Z.inj_pow. - rewrite <- Z.pow_mul_r by lia. - repeat rewrite <- Pos2Z.inj_mul. - repeat rewrite <- Pos2Z.inj_pow. - repeat rewrite <- Pos2Z.inj_mul. - repeat rewrite <- Pos2Z.inj_add. - apply Pos2Z.pos_lt_pos. - rewrite (Pos.mul_comm n 2); change (2*n)%positive with (n~0)%positive. - apply Pos.mul_lt_mono_r. - apply (Pos.lt_le_trans _ _ _ H0). - apply Pos.mul_le_mono; - pose proof Pos.le_1_l (2 ^ n * j)%positive; lia. - - exfalso; unfold Qle, Z.le in H; simpl in H; exact (H eq_refl). -Qed. - -Lemma CReal_sqrt_Q_pos : forall (q : Q) (n : Z), - (0 <= (CReal_sqrt_Q_seq q n))%Q. -Proof. - intros. unfold CReal_sqrt_Q_seq. destruct q, Qnum. - - apply Qle_refl. - - destruct n as [|n|n]; discriminate. - - apply Qle_refl. -Qed. - -Lemma Qsqrt_lt : forall q r :Q, - (0 <= r -> q*q < r*r -> q < r)%Q. -Proof. - intros. destruct (Q_dec q r). destruct s. exact q0. - - exfalso. apply (Qlt_not_le _ _ H0). apply (Qle_trans _ (q * r)). - apply Qmult_le_compat_r. apply Qlt_le_weak, q0. exact H. - rewrite Qmult_comm. - apply Qmult_le_compat_r. apply Qlt_le_weak, q0. - apply (Qle_trans _ r _ H). apply Qlt_le_weak, q0. - - exfalso. rewrite q0 in H0. exact (Qlt_irrefl _ H0). -Qed. - -Lemma CReal_sqrt_Q_cauchy : - forall q:Q, QCauchySeq (CReal_sqrt_Q_seq q). -Proof. - intro q. destruct q as [k j]. destruct k. - - intros n a b H H0. - change (Qabs _) with 0%Q. - apply Qpower_0_lt; reflexivity. - - assert (forall n a b, (b<=n)%Z -> - (CReal_sqrt_Q_seq (Z.pos p # j) a - CReal_sqrt_Q_seq (Z.pos p # j) b - < 2^n)%Q). - { intros. - pose proof Qpower_0_lt 2 n eq_refl as Hpow. - rewrite <- (Qplus_lt_r _ _ (CReal_sqrt_Q_seq (Z.pos p # j) b)). - ring_simplify. apply Qsqrt_lt. - { apply (Qle_trans _ (0+2^n)). lra. - apply Qplus_le_l. apply CReal_sqrt_Q_pos. } - apply (Qle_lt_trans _ (Z.pos p # j)). - { apply CReal_sqrt_Q_le_below. discriminate. } - apply (Qlt_le_trans _ ((CReal_sqrt_Q_seq (Z.pos p # j) b + (2^b)) * - (CReal_sqrt_Q_seq (Z.pos p # j) b + (2^b)))). - { apply CReal_sqrt_Q_lt_above. discriminate. } - apply (Qle_trans _ ((CReal_sqrt_Q_seq (Z.pos p # j) b + (2^n)) * - (CReal_sqrt_Q_seq (Z.pos p # j) b + (2^b)))). - { apply Qmult_le_r. - - apply (Qlt_le_trans _ (0+(2^b))). - + rewrite Qplus_0_l. apply Qpower_0_lt. reflexivity. - + apply Qplus_le_l. apply CReal_sqrt_Q_pos. - - apply Qplus_le_r. apply Qpower_le_compat_l. - exact H. discriminate. } - apply Qmult_le_compat_nonneg. - - split. - + pose proof CReal_sqrt_Q_pos (Z.pos p # j) b. - lra. - + apply Qle_refl. - - split. - + pose proof CReal_sqrt_Q_pos (Z.pos p # j) b. - pose proof Qpower_0_lt 2 b eq_refl as Hpowb. - lra. - + apply Qplus_le_r. - apply Qpower_le_compat_l. - exact H. discriminate. - } - intros n a b H0 H1. apply Qabs_case. - intros. apply H, H1. - intros. - setoid_replace (- (CReal_sqrt_Q_seq (Z.pos p # j) a - CReal_sqrt_Q_seq (Z.pos p # j) b))%Q - with (CReal_sqrt_Q_seq (Z.pos p # j) b - CReal_sqrt_Q_seq (Z.pos p # j) a)%Q. - 2: ring. apply H, H0. - - intros n a b H H0. - change (Qabs _) with 0%Q. - apply Qpower_0_lt; reflexivity. -Qed. - -Definition CReal_sqrt_Q_scale (q : Q) : Z - := ((QExtra.Qbound_lt_ZExp2 q + 1)/2)%Z. - -Lemma CReal_sqrt_Q_bound : forall (q : Q), - QBound (CReal_sqrt_Q_seq q) (CReal_sqrt_Q_scale q). -Proof. - intros q k. - unfold CReal_sqrt_Q_scale. - rewrite Qabs_pos. - 2: apply CReal_sqrt_Q_pos. - apply Qsqrt_lt. - 1: apply Qpower_pos; discriminate. - destruct (Qlt_le_dec q 0) as [Hq|Hq]. - - destruct q as [[|n|n] d]. - + discriminate Hq. - + discriminate Hq. - + reflexivity. - - apply (Qle_lt_trans _ _ _ (CReal_sqrt_Q_le_below _ _ Hq)). - rewrite <- Qpower_plus. - 2: discriminate. - rewrite Z.add_diag, Z.mul_comm. - pose proof Zdiv.Zmod_eq (QExtra.Qbound_lt_ZExp2 q + 1) 2 eq_refl as Hmod. - assert (forall a b c : Z, c=b-a -> a=b-c)%Z as H by (intros a b c H'; rewrite H'; ring). - apply H in Hmod; rewrite Hmod; clear H Hmod. - apply (Qlt_le_trans _ _ _ (QExtra.Qbound_lt_ZExp2_spec q)). - apply Qpower_le_compat_l. 2: discriminate. - pose proof Z.mod_pos_bound (QExtra.Qbound_lt_ZExp2 q + 1)%Z 2%Z eq_refl. - lia. -Qed. - -Definition CReal_sqrt_Q (q : Q) : CReal := -{| - seq := CReal_sqrt_Q_seq q; - scale := CReal_sqrt_Q_scale q; - cauchy := CReal_sqrt_Q_cauchy q; - bound := CReal_sqrt_Q_bound q -|}. - -Time Eval vm_compute in (seq (CReal_sqrt_Q 2) (-1000)%Z). diff --git a/stdlib/test-suite/complexity/bug_13227_1.v b/stdlib/test-suite/complexity/bug_13227_1.v deleted file mode 100644 index 22540e03a89f..000000000000 --- a/stdlib/test-suite/complexity/bug_13227_1.v +++ /dev/null @@ -1,28 +0,0 @@ -From Stdlib Require Import Lia ZArith. -Open Scope Z_scope. - -Unset Lia Cache. - -(* Expected time < 1.00s *) -Goal forall Y r0 r q q0 r1 q1 : Z, - 3 = 4294967296 * q1 + r1 -> - Y - r1 = 4294967296 * q0 + r0 -> - r1 < 4294967296 -> - 0 <= r1 -> - r0 < 4294967296 -> - 0 <= r0 -> - r < 4 -> - 0 <= r -> - 0 < 4 -> - r0 = 4 * q + r -> - Y < 4294967296 -> - 0 <= Y -> - r = 0 -> - r0 < 268517376 -> - 268513280 <= r0 -> - 268587008 <= Y -> - False. -Proof. - intros. - Time lia. -Qed. diff --git a/stdlib/test-suite/complexity/bug_13227_2.v b/stdlib/test-suite/complexity/bug_13227_2.v deleted file mode 100644 index 22540e03a89f..000000000000 --- a/stdlib/test-suite/complexity/bug_13227_2.v +++ /dev/null @@ -1,28 +0,0 @@ -From Stdlib Require Import Lia ZArith. -Open Scope Z_scope. - -Unset Lia Cache. - -(* Expected time < 1.00s *) -Goal forall Y r0 r q q0 r1 q1 : Z, - 3 = 4294967296 * q1 + r1 -> - Y - r1 = 4294967296 * q0 + r0 -> - r1 < 4294967296 -> - 0 <= r1 -> - r0 < 4294967296 -> - 0 <= r0 -> - r < 4 -> - 0 <= r -> - 0 < 4 -> - r0 = 4 * q + r -> - Y < 4294967296 -> - 0 <= Y -> - r = 0 -> - r0 < 268517376 -> - 268513280 <= r0 -> - 268587008 <= Y -> - False. -Proof. - intros. - Time lia. -Qed. diff --git a/stdlib/test-suite/complexity/bug_13227_3.v b/stdlib/test-suite/complexity/bug_13227_3.v deleted file mode 100644 index 0bc55eb9bf71..000000000000 --- a/stdlib/test-suite/complexity/bug_13227_3.v +++ /dev/null @@ -1,46 +0,0 @@ -From Stdlib Require Import Lia ZArith. -Open Scope Z_scope. - -Unset Lia Cache. - -(* Expected time < 1.00s *) -Goal forall (two64 right left : Z) (length_xs v : nat) (x2 x1 : Z) - (length_x : nat) (r3 r2 q r r1 q0 r0 q1 q2 q3 : Z), - two64 = 2 ^ 64 -> - r3 = 8 * Z.of_nat length_xs -> - r2 = 8 * Z.of_nat length_x -> - 0 <= 8 * Z.of_nat length_x -> - 8 * Z.of_nat length_x < two64 -> - r1 = 2 ^ 4 * q + r -> - 0 < 2 ^ 4 -> - 0 <= r -> - r < 2 ^ 4 -> - x1 + q * 2 ^ 3 - x1 = two64 * q0 + r0 -> - 0 < two64 -> - 0 <= r0 -> - r0 < two64 -> - 8 * Z.of_nat length_x = two64 * q1 + r1 -> - 0 <= r1 -> - r1 < two64 -> - x2 - x1 = two64 * q2 + r2 -> - 0 <= r2 -> - r2 < two64 -> - right - left = two64 * q3 + r3 -> - 0 <= r3 -> - r3 < two64 -> - Z.of_nat length_x = Z.of_nat v -> - 0 <= Z.of_nat length_x -> - 0 <= Z.of_nat length_xs -> - 0 <= Z.of_nat v -> - (r2 = 0 -> False) -> - (2 ^ 4 = 0 -> False) -> - (2 ^ 4 < 0 -> False) -> - (two64 = 0 -> False) -> - (two64 < 0 -> False) -> - (r0 < 8 * Z.of_nat length_x -> False) -> - False. -Proof. - intros. - subst. - Time lia. -Qed. diff --git a/stdlib/test-suite/complexity/bug_13227_4.v b/stdlib/test-suite/complexity/bug_13227_4.v deleted file mode 100644 index 7015fce5bda0..000000000000 --- a/stdlib/test-suite/complexity/bug_13227_4.v +++ /dev/null @@ -1,45 +0,0 @@ -From Stdlib Require Import Lia ZArith. -Open Scope Z_scope. - -Unset Lia Cache. - -(* Expected time < 1.00s *) -Goal forall (two64 right left : Z) (length_xs v : nat) (x2 x1 : Z) - (length_x : nat) (r3 r2 q r r1 q0 r0 q1 q2 q3 : Z), - two64 = 2 ^ 64 -> - r3 = 8 * Z.of_nat length_xs -> - r2 = 8 * Z.of_nat length_x -> - 0 <= 8 * Z.of_nat length_x -> - 8 * Z.of_nat length_x < two64 -> - r1 = 2 ^ 4 * q + r -> - 0 < 2 ^ 4 -> - 0 <= r -> - r < 2 ^ 4 -> - x1 + q * 2 ^ 3 - x1 = two64 * q0 + r0 -> - 0 < two64 -> - 0 <= r0 -> - r0 < two64 -> - 8 * Z.of_nat length_x = two64 * q1 + r1 -> - 0 <= r1 -> - r1 < two64 -> - x2 - x1 = two64 * q2 + r2 -> - 0 <= r2 -> - r2 < two64 -> - right - left = two64 * q3 + r3 -> - 0 <= r3 -> - r3 < two64 -> - Z.of_nat length_x = Z.of_nat v -> - 0 <= Z.of_nat length_x -> - 0 <= Z.of_nat length_xs -> - 0 <= Z.of_nat v -> - (r2 = 0 -> False) -> - (2 ^ 4 = 0 -> False) -> - (2 ^ 4 < 0 -> False) -> - (two64 = 0 -> False) -> - (two64 < 0 -> False) -> - (r0 < 8 * Z.of_nat length_x -> False) -> - False. -Proof. - intros. - Time lia. -Qed. diff --git a/stdlib/test-suite/complexity/bug_13227_5.v b/stdlib/test-suite/complexity/bug_13227_5.v deleted file mode 100644 index 4075434bef1e..000000000000 --- a/stdlib/test-suite/complexity/bug_13227_5.v +++ /dev/null @@ -1,79 +0,0 @@ -From Stdlib Require Import Lia ZArith. -Open Scope Z_scope. - -Unset Lia Cache. - -Axiom word: Type. - -(* Expected time < 1.00s *) -Goal forall (right left : Z) (length_xs : nat) (r14 : Z) (v : nat) (x : list word) - (x2 x1 r8 q2 q r q0 r0 r3 r10 r13 q1 r1 r9 r2 r4 q3 q4 - r5 q5 r6 q6 r7 q7 q8 q9 q10 r11 q11 r12 q12 q13 q14 z83 z84 : Z), - z84 = 0 -> - Z.of_nat (Datatypes.length x) - (z83 + 1) <= 0 -> - z84 = Z.of_nat (Datatypes.length x) - (z83 + 1) -> - z83 = 0 -> - q0 <= 0 -> - 0 <= Z.of_nat v -> - 0 <= Z.of_nat length_xs -> - 0 <= Z.of_nat (Datatypes.length x) -> - Z.of_nat (Datatypes.length x) = Z.of_nat v -> - r14 < 2 ^ 64 -> - 0 <= r14 -> - right - left = 2 ^ 64 * q14 + r14 -> - r13 < 2 ^ 64 -> - 0 <= r13 -> - r10 - x1 = 2 ^ 64 * q13 + r13 -> - r12 < 2 ^ 64 -> - 0 <= r12 -> - q = 2 ^ 64 * q12 + r12 -> - r11 < 2 ^ 64 -> - 0 <= r11 -> - r12 * 2 ^ 3 = 2 ^ 64 * q11 + r11 -> - r10 < 2 ^ 64 -> - 0 <= r10 -> - x1 + r11 = 2 ^ 64 * q10 + r10 -> - r9 < 2 ^ 64 -> - 0 <= r9 -> - r10 + r3 = 2 ^ 64 * q9 + r9 -> - r8 < 2 ^ 64 -> - 0 <= r8 -> - x2 - x1 = 2 ^ 64 * q8 + r8 -> - r7 < 2 ^ 64 -> - 0 <= r7 -> - Z.shiftr r8 4 = 2 ^ 64 * q7 + r7 -> - r6 < 2 ^ 64 -> - 0 <= r6 -> - Z.shiftl r7 3 = 2 ^ 64 * q6 + r6 -> - r5 < 2 ^ 64 -> - 0 <= r5 -> - x1 + r6 = 2 ^ 64 * q5 + r5 -> - r4 < 2 ^ 64 -> - 0 <= r4 -> - r5 - x1 = 2 ^ 64 * q4 + r4 -> - r3 < 2 ^ 64 -> - 0 <= r3 -> - 8 = 2 ^ 64 * q3 + r3 -> - r2 < r3 -> - 0 <= r2 -> - r4 = r3 * q2 + r2 -> - r1 < 2 ^ 64 -> - 0 <= r1 -> - 0 < 2 ^ 64 -> - x2 - r9 = 2 ^ 64 * q1 + r1 -> - r0 < r3 -> - 0 <= r0 -> - 0 < r3 -> - r13 = r3 * q0 + r0 -> - r < 2 ^ 4 -> - 0 <= r -> - 0 < 2 ^ 4 -> - r8 = 2 ^ 4 * q + r -> - r8 = 8 * Z.of_nat (Datatypes.length x) -> - r14 = 8 * Z.of_nat length_xs -> - (r1 = 8 * z84 -> False) -> - False. -Proof. - intros. - Time lia. -Qed. diff --git a/stdlib/test-suite/complexity/bug_13227_6.v b/stdlib/test-suite/complexity/bug_13227_6.v deleted file mode 100644 index 1759021dd7c8..000000000000 --- a/stdlib/test-suite/complexity/bug_13227_6.v +++ /dev/null @@ -1,16 +0,0 @@ -From Stdlib Require Import Lia ZArith. -Open Scope Z_scope. - -Unset Lia Cache. - -(* Expected time < 1.00s *) -Goal forall (x2 x3 x : Z) - (H : 0 <= 1073741824 * x + x2 - 67146752) - (H0 : 0 <= -8192 + x2) - (H1 : 0 <= 34816 + - x2) - (H2 : 0 <= -1073741824 * x - x2 + 1073741823), - False. -Proof. - intros. - Time lia. -Qed. diff --git a/stdlib/test-suite/complexity/pretyping.v b/stdlib/test-suite/complexity/pretyping.v deleted file mode 100644 index 61a0041a53f4..000000000000 --- a/stdlib/test-suite/complexity/pretyping.v +++ /dev/null @@ -1,2659 +0,0 @@ -(* Test parsing/interpretation/pretyping on a large example *) -(* Expected time < 2.00s *) - -From Stdlib Require Import Reals. -From Stdlib Require Import Ring_tac. - -Open Scope R_scope. - -Timeout 5 Time Goal forall x1 x2 x3 y1 y2 y3 e1 e2 e3 e4 e5 e6 e7: R, -(e6 + e7 - 2 * y2 * y3 - x2 * e3 - x3 * e3 - e3 * x1) * -((e6 + e7 - 2 * y2 * y3 - x2 * e3 - x3 * e3 - e3 * x1) * 1) * -((- (y1 - y2) * (e5 + e6 - 2 * y1 * y2 - x1 * e1 - x2 * e1 - e1 * x1) - - e2 * y1 - e2 * y3) * - ((- (y1 - y2) * (e5 + e6 - 2 * y1 * y2 - x1 * e1 - x2 * e1 - e1 * x1) - - e2 * y1 - e2 * y3) * 1)) * e3 - -(e5 + e6 - 2 * y1 * y2 - x1 * e1 - x2 * e1 - e1 * x3) * -((e5 + e6 - 2 * y1 * y2 - x1 * e1 - x2 * e1 - e1 * x3) * 1) * -((e6 + e7 - 2 * y2 * y3 - x2 * e3 - x3 * e3 - e3 * x1) * - ((e6 + e7 - 2 * y2 * y3 - x2 * e3 - x3 * e3 - e3 * x1) * 1)) * -(e5 + e6 - 2 * y1 * y2 - x1 * e1 - x2 * e1) * e3 - -(e5 + e6 - 2 * y1 * y2 - x1 * e1 - x2 * e1 - e1 * x3) * -((e5 + e6 - 2 * y1 * y2 - x1 * e1 - x2 * e1 - e1 * x3) * 1) * -((e6 + e7 - 2 * y2 * y3 - x2 * e3 - x3 * e3 - e3 * x1) * - ((e6 + e7 - 2 * y2 * y3 - x2 * e3 - x3 * e3 - e3 * x1) * 1)) * x3 * e1 * e3 - -(- (y2 - y3) * (e6 + e7 - 2 * y2 * y3 - x2 * e3 - x3 * e3 - e3 * x2) - - e4 * y2 - e4 * y1) * -((- (y2 - y3) * (e6 + e7 - 2 * y2 * y3 - x2 * e3 - x3 * e3 - e3 * x2) - - e4 * y2 - e4 * y1) * 1) * -((e5 + e6 - 2 * y1 * y2 - x1 * e1 - x2 * e1 - e1 * x3) * - ((e5 + e6 - 2 * y1 * y2 - x1 * e1 - x2 * e1 - e1 * x3) * 1)) * e1 + -(e5 + e6 - 2 * y1 * y2 - x1 * e1 - x2 * e1 - e1 * x3) * -((e5 + e6 - 2 * y1 * y2 - x1 * e1 - x2 * e1 - e1 * x3) * 1) * -((e6 + e7 - 2 * y2 * y3 - x2 * e3 - x3 * e3 - e3 * x1) * - ((e6 + e7 - 2 * y2 * y3 - x2 * e3 - x3 * e3 - e3 * x1) * 1)) * -(e6 + e7 - 2 * y2 * y3 - x2 * e3 - x3 * e3) * e1 + -(e5 + e6 - 2 * y1 * y2 - x1 * e1 - x2 * e1 - e1 * x3) * -((e5 + e6 - 2 * y1 * y2 - x1 * e1 - x2 * e1 - e1 * x3) * 1) * -((e6 + e7 - 2 * y2 * y3 - x2 * e3 - x3 * e3 - e3 * x1) * - ((e6 + e7 - 2 * y2 * y3 - x2 * e3 - x3 * e3 - e3 * x1) * 1)) * x1 * e1 * e3 = -3 * e1 * e6 ^ 4 * e7 + e1 * e6 ^ 2 * e7 ^ 3 + e3 * e6 ^ 4 * y1 ^ 2 + -3 * e1 * e6 ^ 3 * e7 ^ 2 - 2 * e6 ^ 4 * x2 * e1 ^ 2 + 2 * e1 * e6 ^ 4 * e5 - -2 * e3 * e6 ^ 4 * e7 - 2 * e6 ^ 4 * x1 * e1 ^ 2 + e1 ^ 3 * x3 ^ 2 * e6 ^ 3 - -2 * e6 ^ 4 * e1 ^ 2 * x3 + x2 ^ 4 * e3 ^ 3 * y1 ^ 2 * e1 ^ 2 + -x2 ^ 4 * e3 ^ 3 * y2 ^ 2 * e1 ^ 2 + x2 ^ 2 * e3 ^ 3 * y1 ^ 2 * e5 ^ 2 + -x2 ^ 2 * e3 ^ 3 * y1 ^ 2 * e6 ^ 2 + 4 * x2 ^ 2 * e3 ^ 3 * y1 ^ 4 * y2 ^ 2 + -x3 ^ 2 * e3 ^ 3 * y1 ^ 2 * e5 ^ 2 + x3 ^ 2 * e3 ^ 3 * y1 ^ 2 * e6 ^ 2 + -4 * x3 ^ 2 * e3 ^ 3 * y1 ^ 4 * y2 ^ 2 + 4 * e3 ^ 3 * x1 ^ 4 * y1 ^ 2 * e1 ^ 2 + -4 * e3 ^ 3 * x1 ^ 4 * y2 ^ 2 * e1 ^ 2 + e3 ^ 3 * x1 ^ 2 * y1 ^ 2 * e5 ^ 2 + -e3 ^ 3 * x1 ^ 2 * y1 ^ 2 * e6 ^ 2 + 4 * e3 ^ 3 * x1 ^ 2 * y1 ^ 4 * y2 ^ 2 + -x2 ^ 2 * e3 ^ 3 * y2 ^ 2 * e5 ^ 2 + x2 ^ 2 * e3 ^ 3 * y2 ^ 2 * e6 ^ 2 + -4 * x2 ^ 2 * e3 ^ 3 * y1 ^ 2 * y2 ^ 4 + x2 ^ 2 * e3 ^ 3 * e2 ^ 2 * y1 ^ 2 + -x2 ^ 2 * e3 ^ 3 * e2 ^ 2 * y3 ^ 2 + x3 ^ 2 * e3 ^ 3 * y2 ^ 2 * e5 ^ 2 + -x3 ^ 2 * e3 ^ 3 * y2 ^ 2 * e6 ^ 2 + 4 * x3 ^ 2 * e3 ^ 3 * y1 ^ 2 * y2 ^ 4 + -x3 ^ 2 * e3 ^ 3 * e2 ^ 2 * y1 ^ 2 + x3 ^ 2 * e3 ^ 3 * e2 ^ 2 * y3 ^ 2 + -e3 ^ 3 * x1 ^ 2 * y2 ^ 2 * e5 ^ 2 + e3 ^ 3 * x1 ^ 2 * y2 ^ 2 * e6 ^ 2 + -4 * e3 ^ 3 * x1 ^ 2 * y1 ^ 2 * y2 ^ 4 + e3 ^ 3 * x1 ^ 2 * e2 ^ 2 * y1 ^ 2 + -e3 ^ 3 * x1 ^ 2 * e2 ^ 2 * y3 ^ 2 - 2 * e6 ^ 3 * x2 * e3 ^ 2 * y1 ^ 2 - -2 * e6 ^ 3 * x3 * e3 ^ 2 * y1 ^ 2 - 2 * e6 ^ 3 * e3 ^ 2 * x1 * y1 ^ 2 - -2 * e6 ^ 3 * x2 * e3 ^ 2 * y2 ^ 2 - 2 * e6 ^ 3 * x3 * e3 ^ 2 * y2 ^ 2 - -2 * e6 ^ 3 * e3 ^ 2 * x1 * y2 ^ 2 + 2 * e3 * e6 ^ 3 * y1 ^ 2 * e5 - -4 * e3 * e6 ^ 3 * y1 ^ 3 * y2 + 4 * e3 * e6 ^ 4 * y1 * y2 - -4 * e3 * e6 ^ 3 * y1 ^ 2 * y2 ^ 2 + 2 * e3 * e6 ^ 3 * y1 ^ 2 * e2 + -2 * e3 * e6 ^ 3 * y2 ^ 2 * e5 - 4 * e3 * e6 ^ 3 * y2 ^ 3 * y1 + -e3 * e6 ^ 2 * y1 ^ 2 * e5 ^ 2 + 4 * e3 * e6 ^ 2 * y1 ^ 4 * y2 ^ 2 + -2 * e3 * e6 ^ 3 * e7 * y1 ^ 2 + e3 * e7 ^ 2 * y1 ^ 2 * e5 ^ 2 + -e3 * e7 ^ 2 * y1 ^ 2 * e6 ^ 2 + 4 * e3 * e7 ^ 2 * y1 ^ 4 * y2 ^ 2 + -16 * e3 * y2 ^ 4 * y3 ^ 2 * y1 ^ 4 + e3 * e6 ^ 2 * y2 ^ 2 * e5 ^ 2 + -4 * e3 * e6 ^ 2 * y1 ^ 2 * y2 ^ 4 + e3 * e6 ^ 2 * e2 ^ 2 * y1 ^ 2 + -e3 * e6 ^ 2 * e2 ^ 2 * y3 ^ 2 + 2 * e3 * e6 ^ 3 * e7 * y2 ^ 2 + -e3 * e7 ^ 2 * y2 ^ 2 * e5 ^ 2 + e3 * e7 ^ 2 * y2 ^ 2 * e6 ^ 2 + -x1 ^ 2 * e1 ^ 3 * e6 ^ 3 + x2 ^ 2 * e1 ^ 3 * e6 ^ 3 + e1 * e5 ^ 2 * e7 ^ 3 + -e3 * e6 ^ 4 * y2 ^ 2 - 24 * y2 * y3 * x2 * e3 ^ 2 * y1 ^ 2 * e5 * x1 * e1 - -8 * y2 * y3 * x2 ^ 2 * e3 ^ 2 * y1 ^ 2 * e5 * e1 + -32 * y2 ^ 2 * y3 * x2 * e3 ^ 2 * y1 * e5 * e6 + -8 * y2 * y3 ^ 2 * x2 * e3 ^ 2 * y1 * e5 * e2 - -24 * y2 * y3 * x2 * e3 ^ 2 * y1 ^ 2 * e6 * x1 * e1 - -8 * y2 * y3 * x2 ^ 2 * e3 ^ 2 * y1 ^ 2 * e6 * e1 + -16 * y2 ^ 2 * y3 * x2 ^ 2 * e3 ^ 2 * y1 ^ 3 * e1 + -8 * y2 * y3 ^ 2 * x2 * e3 ^ 2 * y1 * e6 * e2 + -48 * y2 ^ 2 * y3 * x2 * e3 ^ 2 * y1 ^ 3 * x1 * e1 - -16 * y2 ^ 3 * y3 * x2 * e3 ^ 2 * y1 ^ 2 * x1 * e1 + -24 * y2 ^ 3 * y3 * x2 ^ 2 * e3 ^ 2 * y1 ^ 2 * e1 - -16 * y2 ^ 2 * y3 ^ 2 * x2 * e3 ^ 2 * y1 ^ 2 * e2 + -8 * y2 * y3 * x2 * e3 ^ 2 * y1 ^ 2 * e5 * e6 - -16 * y2 ^ 2 * y3 * x2 * e3 ^ 2 * y1 ^ 3 * e5 + -16 * y2 ^ 2 * y3 * x2 * e3 ^ 2 * y1 * e5 ^ 2 - -16 * y2 ^ 3 * y3 * x2 * e3 ^ 2 * y1 ^ 2 * e5 + -8 * y2 * y3 * x2 * e3 ^ 2 * y1 ^ 2 * e5 * e2 - -16 * y2 ^ 2 * y3 * x2 * e3 ^ 2 * y1 ^ 3 * e6 + -16 * y2 ^ 2 * y3 * x2 * e3 ^ 2 * y1 * e6 ^ 2 - -16 * y2 ^ 3 * y3 * x2 * e3 ^ 2 * y1 ^ 2 * e6 + -16 * y2 * y3 * x2 * e3 ^ 2 * y1 ^ 2 * e6 * e2 - -16 * y2 ^ 2 * y3 * x2 * e3 ^ 2 * y1 ^ 3 * e2 + -32 * y2 * y3 * x2 * e3 ^ 2 * y1 ^ 2 * x1 ^ 2 * e1 ^ 2 + -4 * y2 * y3 * x2 ^ 3 * e3 ^ 2 * y1 ^ 2 * e1 ^ 2 + -8 * y2 ^ 3 * y3 * x2 * e3 ^ 2 * e5 * e6 - -16 * y2 ^ 4 * y3 * x2 * e3 ^ 2 * e5 * y1 - -16 * y2 ^ 4 * y3 * x2 * e3 ^ 2 * e6 * y1 + -16 * y2 ^ 3 * y3 * x2 * e3 ^ 2 * y1 ^ 2 * e2 + -32 * y2 ^ 3 * y3 * x2 * e3 ^ 2 * x1 ^ 2 * e1 ^ 2 + -4 * y2 ^ 3 * y3 * x2 ^ 3 * e3 ^ 2 * e1 ^ 2 + -8 * y2 * y3 ^ 2 * x2 * e3 ^ 2 * e2 ^ 2 * y1 + -4 * y2 * y3 * x2 * e3 ^ 2 * y1 ^ 2 * e5 ^ 2 + -4 * y2 * y3 * x2 * e3 ^ 2 * y1 ^ 2 * e6 ^ 2 + -16 * y2 ^ 3 * y3 * x2 * e3 ^ 2 * y1 ^ 4 - -16 * y2 * y3 * x3 * e3 ^ 2 * y1 ^ 2 * e5 * x1 * e1 - -8 * y2 * y3 * x3 * e3 ^ 2 * y1 ^ 2 * e5 * x2 * e1 + -32 * y2 ^ 2 * y3 * x3 * e3 ^ 2 * y1 * e5 * e6 + -8 * y2 * y3 ^ 2 * x3 * e3 ^ 2 * y1 * e5 * e2 - -16 * y2 * y3 * x3 * e3 ^ 2 * y1 ^ 2 * e6 * x1 * e1 - -8 * y2 * y3 * x3 * e3 ^ 2 * y1 ^ 2 * e6 * x2 * e1 + -8 * y2 * y3 ^ 2 * x3 * e3 ^ 2 * y1 * e6 * e2 + -32 * y2 ^ 2 * y3 * x3 * e3 ^ 2 * y1 ^ 3 * x1 * e1 + -16 * y2 ^ 2 * y3 * x3 * e3 ^ 2 * y1 ^ 3 * x2 * e1 - -16 * y2 ^ 3 * y3 * x3 * e3 ^ 2 * y1 ^ 2 * x1 * e1 + -16 * y2 ^ 3 * y3 * x3 * e3 ^ 2 * y1 ^ 2 * x2 * e1 - -16 * y2 ^ 2 * y3 ^ 2 * x3 * e3 ^ 2 * y1 ^ 2 * e2 + -8 * y2 * y3 * x3 * e3 ^ 2 * y1 ^ 2 * e5 * e6 - -16 * y2 ^ 2 * y3 * x3 * e3 ^ 2 * y1 ^ 3 * e5 + -16 * y2 ^ 2 * y3 * x3 * e3 ^ 2 * y1 * e5 ^ 2 - -16 * y2 ^ 3 * y3 * x3 * e3 ^ 2 * y1 ^ 2 * e5 + -8 * y2 * y3 * x3 * e3 ^ 2 * y1 ^ 2 * e5 * e2 - -16 * y2 ^ 2 * y3 * x3 * e3 ^ 2 * y1 ^ 3 * e6 + -16 * y2 ^ 2 * y3 * x3 * e3 ^ 2 * y1 * e6 ^ 2 - -16 * y2 ^ 3 * y3 * x3 * e3 ^ 2 * y1 ^ 2 * e6 + -16 * y2 * y3 * x3 * e3 ^ 2 * y1 ^ 2 * e6 * e2 - -16 * y2 ^ 2 * y3 * x3 * e3 ^ 2 * y1 ^ 3 * e2 + -16 * y2 * y3 * x3 * e3 ^ 2 * y1 ^ 2 * x1 ^ 2 * e1 ^ 2 + -4 * y2 * y3 * x3 * e3 ^ 2 * y1 ^ 2 * x2 ^ 2 * e1 ^ 2 + -8 * y2 ^ 3 * y3 * x3 * e3 ^ 2 * e5 * e6 - -16 * y2 ^ 4 * y3 * x3 * e3 ^ 2 * e5 * y1 - -16 * y2 ^ 4 * y3 * x3 * e3 ^ 2 * e6 * y1 + -16 * y2 ^ 3 * y3 * x3 * e3 ^ 2 * y1 ^ 2 * e2 + -16 * y2 ^ 3 * y3 * x3 * e3 ^ 2 * x1 ^ 2 * e1 ^ 2 + -4 * y2 ^ 3 * y3 * x3 * e3 ^ 2 * x2 ^ 2 * e1 ^ 2 + -8 * y2 * y3 ^ 2 * x3 * e3 ^ 2 * e2 ^ 2 * y1 + -4 * y2 * y3 * x3 * e3 ^ 2 * y1 ^ 2 * e5 ^ 2 + -4 * y2 * y3 * x3 * e3 ^ 2 * y1 ^ 2 * e6 ^ 2 + -16 * y2 ^ 3 * y3 * x3 * e3 ^ 2 * y1 ^ 4 - -16 * y2 * y3 * e3 ^ 2 * x1 ^ 2 * y1 ^ 2 * e5 * e1 + -32 * y2 ^ 2 * y3 * e3 ^ 2 * x1 * y1 * e5 * e6 + -8 * y2 * y3 ^ 2 * e3 ^ 2 * x1 * y1 * e5 * e2 - -16 * y2 * y3 * e3 ^ 2 * x1 ^ 2 * y1 ^ 2 * e6 * e1 + -8 * y2 * y3 ^ 2 * e3 ^ 2 * x1 * y1 * e6 * e2 + -32 * y2 ^ 2 * y3 * e3 ^ 2 * x1 ^ 2 * y1 ^ 3 * e1 - -8 * y2 ^ 3 * y3 * e3 ^ 2 * x1 ^ 2 * y1 ^ 2 * e1 - -16 * y2 ^ 2 * y3 ^ 2 * e3 ^ 2 * x1 * y1 ^ 2 * e2 + -8 * y2 * y3 * e3 ^ 2 * x1 * y1 ^ 2 * e5 * e6 - -16 * y2 ^ 2 * y3 * e3 ^ 2 * x1 * y1 ^ 3 * e5 + -16 * y2 ^ 2 * y3 * e3 ^ 2 * x1 * y1 * e5 ^ 2 - -16 * y2 ^ 3 * y3 * e3 ^ 2 * x1 * y1 ^ 2 * e5 + -8 * y2 * y3 * e3 ^ 2 * x1 * y1 ^ 2 * e5 * e2 - -16 * y2 ^ 2 * y3 * e3 ^ 2 * x1 * y1 ^ 3 * e6 + -16 * y2 ^ 2 * y3 * e3 ^ 2 * x1 * y1 * e6 ^ 2 - -16 * y2 ^ 3 * y3 * e3 ^ 2 * x1 * y1 ^ 2 * e6 + -16 * y2 * y3 * e3 ^ 2 * x1 * y1 ^ 2 * e6 * e2 - -16 * y2 ^ 2 * y3 * e3 ^ 2 * x1 * y1 ^ 3 * e2 + -16 * y2 * y3 * e3 ^ 2 * x1 ^ 3 * y1 ^ 2 * e1 ^ 2 + -20 * y2 * y3 * e3 ^ 2 * x1 * y1 ^ 2 * x2 ^ 2 * e1 ^ 2 + -8 * y2 ^ 3 * y3 * e3 ^ 2 * x1 * e5 * e6 - -16 * y2 ^ 4 * y3 * e3 ^ 2 * x1 * e5 * y1 - -16 * y2 ^ 4 * y3 * e3 ^ 2 * x1 * e6 * y1 + -16 * y2 ^ 3 * y3 * e3 ^ 2 * x1 * y1 ^ 2 * e2 + -16 * y2 ^ 3 * y3 * e3 ^ 2 * x1 ^ 3 * e1 ^ 2 + -20 * y2 ^ 3 * y3 * e3 ^ 2 * x1 * x2 ^ 2 * e1 ^ 2 + -8 * y2 * y3 ^ 2 * e3 ^ 2 * x1 * e2 ^ 2 * y1 + -4 * y2 * y3 * e3 ^ 2 * x1 * y1 ^ 2 * e5 ^ 2 + -4 * y2 * y3 * e3 ^ 2 * x1 * y1 ^ 2 * e6 ^ 2 + -16 * y2 ^ 3 * y3 * e3 ^ 2 * x1 * y1 ^ 4 - -8 * x2 ^ 2 * e3 ^ 3 * y1 ^ 2 * e5 * x1 * e1 - -2 * x2 ^ 3 * e3 ^ 3 * y1 ^ 2 * e5 * e1 + -8 * x2 ^ 2 * e3 ^ 3 * y1 * e5 * y2 * e6 + -2 * x2 ^ 2 * e3 ^ 3 * y1 * e5 * e2 * y3 - -8 * x2 ^ 2 * e3 ^ 3 * y1 ^ 2 * e6 * x1 * e1 - -2 * x2 ^ 3 * e3 ^ 3 * y1 ^ 2 * e6 * e1 + -2 * x2 ^ 2 * e3 ^ 3 * y1 * e6 * e2 * y3 + -16 * x2 ^ 2 * e3 ^ 3 * y1 ^ 3 * y2 * x1 * e1 + -4 * x2 ^ 3 * e3 ^ 3 * y1 ^ 3 * y2 * e1 - -4 * x2 ^ 2 * e3 ^ 3 * y1 ^ 2 * y2 * e2 * y3 + -2 * x2 ^ 2 * e3 ^ 3 * y1 ^ 2 * e5 * e6 - -4 * x2 ^ 2 * e3 ^ 3 * y1 ^ 3 * e5 * y2 + -4 * x2 ^ 2 * e3 ^ 3 * y1 * e5 ^ 2 * y2 - -4 * x2 ^ 2 * e3 ^ 3 * y1 ^ 2 * e5 * y2 ^ 2 + -2 * x2 ^ 2 * e3 ^ 3 * y1 ^ 2 * e5 * e2 - -4 * x2 ^ 2 * e3 ^ 3 * y1 ^ 3 * e6 * y2 + -4 * x2 ^ 2 * e3 ^ 3 * y1 * e6 ^ 2 * y2 - -4 * x2 ^ 2 * e3 ^ 3 * y1 ^ 2 * e6 * y2 ^ 2 + -2 * x2 ^ 2 * e3 ^ 3 * y1 ^ 2 * e6 * e2 - -4 * x2 ^ 2 * e3 ^ 3 * y1 ^ 3 * y2 * e2 + -13 * x2 ^ 2 * e3 ^ 3 * y1 ^ 2 * x1 ^ 2 * e1 ^ 2 + -2 * x2 ^ 2 * e3 ^ 3 * y2 ^ 2 * e5 * e6 - -4 * x2 ^ 2 * e3 ^ 3 * y2 ^ 3 * e5 * y1 - -4 * x2 ^ 2 * e3 ^ 3 * y2 ^ 3 * e6 * y1 + -4 * x2 ^ 2 * e3 ^ 3 * y1 ^ 2 * y2 ^ 2 * e2 + -13 * x2 ^ 2 * e3 ^ 3 * y2 ^ 2 * x1 ^ 2 * e1 ^ 2 + -2 * x2 ^ 2 * e3 ^ 3 * e2 ^ 2 * y1 * y3 - -4 * x3 ^ 2 * e3 ^ 3 * y1 ^ 2 * e5 * x1 * e1 - -2 * x3 ^ 2 * e3 ^ 3 * y1 ^ 2 * e5 * x2 * e1 + -8 * x3 ^ 2 * e3 ^ 3 * y1 * e5 * y2 * e6 + -2 * x3 ^ 2 * e3 ^ 3 * y1 * e5 * e2 * y3 - -4 * x3 ^ 2 * e3 ^ 3 * y1 ^ 2 * e6 * x1 * e1 - -2 * x3 ^ 2 * e3 ^ 3 * y1 ^ 2 * e6 * x2 * e1 + -2 * x3 ^ 2 * e3 ^ 3 * y1 * e6 * e2 * y3 + -8 * x3 ^ 2 * e3 ^ 3 * y1 ^ 3 * y2 * x1 * e1 + -4 * x3 ^ 2 * e3 ^ 3 * y1 ^ 3 * y2 * x2 * e1 - -4 * x3 ^ 2 * e3 ^ 3 * y1 ^ 2 * y2 * e2 * y3 + -2 * x3 ^ 2 * e3 ^ 3 * y1 ^ 2 * e5 * e6 - -4 * x3 ^ 2 * e3 ^ 3 * y1 ^ 3 * e5 * y2 + -4 * x3 ^ 2 * e3 ^ 3 * y1 * e5 ^ 2 * y2 - -4 * x3 ^ 2 * e3 ^ 3 * y1 ^ 2 * e5 * y2 ^ 2 + -2 * x3 ^ 2 * e3 ^ 3 * y1 ^ 2 * e5 * e2 - -4 * x3 ^ 2 * e3 ^ 3 * y1 ^ 3 * e6 * y2 + -4 * x3 ^ 2 * e3 ^ 3 * y1 * e6 ^ 2 * y2 - -4 * x3 ^ 2 * e3 ^ 3 * y1 ^ 2 * e6 * y2 ^ 2 + -2 * x3 ^ 2 * e3 ^ 3 * y1 ^ 2 * e6 * e2 - -4 * x3 ^ 2 * e3 ^ 3 * y1 ^ 3 * y2 * e2 + -4 * x3 ^ 2 * e3 ^ 3 * y1 ^ 2 * x1 ^ 2 * e1 ^ 2 + -x3 ^ 2 * e3 ^ 3 * y1 ^ 2 * x2 ^ 2 * e1 ^ 2 + -2 * x3 ^ 2 * e3 ^ 3 * y2 ^ 2 * e5 * e6 - -4 * x3 ^ 2 * e3 ^ 3 * y2 ^ 3 * e5 * y1 - -4 * x3 ^ 2 * e3 ^ 3 * y2 ^ 3 * e6 * y1 + -4 * x3 ^ 2 * e3 ^ 3 * y1 ^ 2 * y2 ^ 2 * e2 + -4 * x3 ^ 2 * e3 ^ 3 * y2 ^ 2 * x1 ^ 2 * e1 ^ 2 + -x3 ^ 2 * e3 ^ 3 * y2 ^ 2 * x2 ^ 2 * e1 ^ 2 + -2 * x3 ^ 2 * e3 ^ 3 * e2 ^ 2 * y1 * y3 - -4 * e3 ^ 3 * x1 ^ 3 * y1 ^ 2 * e5 * e1 - -10 * e3 ^ 3 * x1 ^ 2 * y1 ^ 2 * e5 * x2 * e1 + -8 * e3 ^ 3 * x1 ^ 2 * y1 * e5 * y2 * e6 + -2 * e3 ^ 3 * x1 ^ 2 * y1 * e5 * e2 * y3 - -4 * e3 ^ 3 * x1 ^ 3 * y1 ^ 2 * e6 * e1 - -10 * e3 ^ 3 * x1 ^ 2 * y1 ^ 2 * e6 * x2 * e1 + -2 * e3 ^ 3 * x1 ^ 2 * y1 * e6 * e2 * y3 + -8 * e3 ^ 3 * x1 ^ 3 * y1 ^ 3 * y2 * e1 + -20 * e3 ^ 3 * x1 ^ 2 * y1 ^ 3 * y2 * x2 * e1 - -4 * e3 ^ 3 * x1 ^ 2 * y1 ^ 2 * y2 * e2 * y3 + -2 * e3 ^ 3 * x1 ^ 2 * y1 ^ 2 * e5 * e6 - -4 * e3 ^ 3 * x1 ^ 2 * y1 ^ 3 * e5 * y2 + -4 * e3 ^ 3 * x1 ^ 2 * y1 * e5 ^ 2 * y2 - -4 * e3 ^ 3 * x1 ^ 2 * y1 ^ 2 * e5 * y2 ^ 2 + -2 * e3 ^ 3 * x1 ^ 2 * y1 ^ 2 * e5 * e2 - -4 * e3 ^ 3 * x1 ^ 2 * y1 ^ 3 * e6 * y2 + -4 * e3 ^ 3 * x1 ^ 2 * y1 * e6 ^ 2 * y2 - -4 * e3 ^ 3 * x1 ^ 2 * y1 ^ 2 * e6 * y2 ^ 2 + -2 * e3 ^ 3 * x1 ^ 2 * y1 ^ 2 * e6 * e2 - -4 * e3 ^ 3 * x1 ^ 2 * y1 ^ 3 * y2 * e2 + -2 * e3 ^ 3 * x1 ^ 2 * y2 ^ 2 * e5 * e6 - -4 * e3 ^ 3 * x1 ^ 2 * y2 ^ 3 * e5 * y1 - -4 * e3 ^ 3 * x1 ^ 2 * y2 ^ 3 * e6 * y1 + -4 * e3 ^ 3 * x1 ^ 2 * y1 ^ 2 * y2 ^ 2 * e2 + -2 * e3 ^ 3 * x1 ^ 2 * e2 ^ 2 * y1 * y3 + -4 * y2 ^ 3 * y3 * x2 * e3 ^ 2 * e5 ^ 2 + -4 * y2 ^ 3 * y3 * x2 * e3 ^ 2 * e6 ^ 2 + -16 * y2 ^ 5 * y3 * x2 * e3 ^ 2 * y1 ^ 2 + -4 * y2 * y3 * x2 * e3 ^ 2 * e2 ^ 2 * y1 ^ 2 + -4 * y2 * y3 ^ 3 * x2 * e3 ^ 2 * e2 ^ 2 - -32 * y2 ^ 2 * y3 * x2 * e3 ^ 2 * y1 * e5 * x1 * e1 - -40 * y2 ^ 2 * y3 * x2 ^ 2 * e3 ^ 2 * y1 * e5 * e1 - -32 * y2 ^ 2 * y3 * x2 * e3 ^ 2 * y1 * e6 * x1 * e1 - -40 * y2 ^ 2 * y3 * x2 ^ 2 * e3 ^ 2 * y1 * e6 * e1 - -24 * y2 * y3 * x2 * e3 ^ 2 * y1 ^ 2 * x1 * e1 * e2 + -24 * y2 ^ 2 * y3 * x2 ^ 3 * e3 ^ 2 * y1 * e1 ^ 2 - -8 * y2 * y3 * x2 ^ 2 * e3 ^ 2 * y1 ^ 2 * e1 * e2 - -24 * y2 ^ 3 * y3 * x2 * e3 ^ 2 * e5 * x1 * e1 - -8 * y2 ^ 3 * y3 * x2 ^ 2 * e3 ^ 2 * e5 * e1 - -8 * y2 ^ 2 * y3 * x2 * e3 ^ 2 * e5 * e2 * y1 - -8 * y2 ^ 2 * y3 ^ 2 * x2 * e3 ^ 2 * e5 * e2 - -24 * y2 ^ 3 * y3 * x2 * e3 ^ 2 * e6 * x1 * e1 - -8 * y2 ^ 3 * y3 * x2 ^ 2 * e3 ^ 2 * e6 * e1 - -16 * y2 ^ 2 * y3 * x2 * e3 ^ 2 * e6 * e2 * y1 - -8 * y2 ^ 2 * y3 ^ 2 * x2 * e3 ^ 2 * e6 * e2 + -48 * y2 ^ 4 * y3 * x2 * e3 ^ 2 * y1 * x1 * e1 + -16 * y2 ^ 4 * y3 * x2 ^ 2 * e3 ^ 2 * y1 * e1 + -16 * y2 ^ 3 * y3 ^ 2 * x2 * e3 ^ 2 * y1 * e2 + -24 * y2 ^ 2 * y3 * x2 ^ 2 * e3 ^ 2 * y1 * x1 * e1 ^ 2 - -24 * y2 * y3 ^ 2 * x2 * e3 ^ 2 * y1 * x1 * e1 * e2 - -8 * y2 * y3 ^ 2 * x2 ^ 2 * e3 ^ 2 * y1 * e1 * e2 + -24 * y2 ^ 2 * y3 * x2 * e3 ^ 2 * x1 * e1 * e2 * y1 + -24 * y2 ^ 2 * y3 ^ 2 * x2 * e3 ^ 2 * x1 * e1 * e2 + -8 * y2 ^ 2 * y3 * x2 ^ 2 * e3 ^ 2 * e1 * e2 * y1 + -8 * y2 ^ 2 * y3 ^ 2 * x2 ^ 2 * e3 ^ 2 * e1 * e2 + -4 * y2 ^ 3 * y3 * x3 * e3 ^ 2 * e5 ^ 2 + -4 * y2 ^ 3 * y3 * x3 * e3 ^ 2 * e6 ^ 2 + -16 * y2 ^ 5 * y3 * x3 * e3 ^ 2 * y1 ^ 2 + -4 * y2 * y3 * x3 * e3 ^ 2 * e2 ^ 2 * y1 ^ 2 + -4 * y2 * y3 ^ 3 * x3 * e3 ^ 2 * e2 ^ 2 - -16 * y2 ^ 2 * y3 * x3 * e3 ^ 2 * y1 * e5 * x1 * e1 - -32 * y2 ^ 2 * y3 * x3 * e3 ^ 2 * y1 * e5 * x2 * e1 - -16 * y2 ^ 2 * y3 * x3 * e3 ^ 2 * y1 * e6 * x1 * e1 - -32 * y2 ^ 2 * y3 * x3 * e3 ^ 2 * y1 * e6 * x2 * e1 + -16 * y2 * y3 * x3 * e3 ^ 2 * y1 ^ 2 * x1 * e1 ^ 2 * x2 - -16 * y2 * y3 * x3 * e3 ^ 2 * y1 ^ 2 * x1 * e1 * e2 + -24 * y2 ^ 2 * y3 * x3 * e3 ^ 2 * y1 * x2 ^ 2 * e1 ^ 2 - -8 * y2 * y3 * x3 * e3 ^ 2 * y1 ^ 2 * x2 * e1 * e2 - -16 * y2 ^ 3 * y3 * x3 * e3 ^ 2 * e5 * x1 * e1 - -8 * y2 ^ 3 * y3 * x3 * e3 ^ 2 * e5 * x2 * e1 - -8 * y2 ^ 2 * y3 * x3 * e3 ^ 2 * e5 * e2 * y1 - -8 * y2 ^ 2 * y3 ^ 2 * x3 * e3 ^ 2 * e5 * e2 - -16 * y2 ^ 3 * y3 * x3 * e3 ^ 2 * e6 * x1 * e1 - -8 * y2 ^ 3 * y3 * x3 * e3 ^ 2 * e6 * x2 * e1 - -16 * y2 ^ 2 * y3 * x3 * e3 ^ 2 * e6 * e2 * y1 - -8 * y2 ^ 2 * y3 ^ 2 * x3 * e3 ^ 2 * e6 * e2 + -32 * y2 ^ 4 * y3 * x3 * e3 ^ 2 * y1 * x1 * e1 + -16 * y2 ^ 4 * y3 * x3 * e3 ^ 2 * y1 * x2 * e1 + -16 * y2 ^ 3 * y3 ^ 2 * x3 * e3 ^ 2 * y1 * e2 + -16 * y2 ^ 3 * y3 * x3 * e3 ^ 2 * x1 * e1 ^ 2 * x2 - -16 * y2 * y3 ^ 2 * x3 * e3 ^ 2 * y1 * x1 * e1 * e2 - -8 * y2 * y3 ^ 2 * x3 * e3 ^ 2 * y1 * x2 * e1 * e2 + -16 * y2 ^ 2 * y3 * x3 * e3 ^ 2 * x1 * e1 * e2 * y1 + -16 * y2 ^ 2 * y3 ^ 2 * x3 * e3 ^ 2 * x1 * e1 * e2 + -8 * y2 ^ 2 * y3 * x3 * e3 ^ 2 * x2 * e1 * e2 * y1 + -8 * y2 ^ 2 * y3 ^ 2 * x3 * e3 ^ 2 * x2 * e1 * e2 + -4 * y2 ^ 3 * y3 * e3 ^ 2 * x1 * e5 ^ 2 + -4 * y2 ^ 3 * y3 * e3 ^ 2 * x1 * e6 ^ 2 + -16 * y2 ^ 5 * y3 * e3 ^ 2 * x1 * y1 ^ 2 + -4 * y2 * y3 * e3 ^ 2 * x1 * e2 ^ 2 * y1 ^ 2 + -4 * y2 * y3 ^ 3 * e3 ^ 2 * x1 * e2 ^ 2 - -24 * y2 ^ 2 * y3 * e3 ^ 2 * x1 ^ 2 * y1 * e5 * e1 - -24 * y2 ^ 2 * y3 * e3 ^ 2 * x1 ^ 2 * y1 * e6 * e1 - -16 * y2 * y3 * e3 ^ 2 * x1 ^ 2 * y1 ^ 2 * e1 * e2 - -16 * y2 ^ 3 * y3 * e3 ^ 2 * x1 ^ 2 * e5 * e1 - -8 * y2 ^ 2 * y3 * e3 ^ 2 * x1 * e5 * e2 * y1 - -8 * y2 ^ 2 * y3 ^ 2 * e3 ^ 2 * x1 * e5 * e2 - -16 * y2 ^ 3 * y3 * e3 ^ 2 * x1 ^ 2 * e6 * e1 - -16 * y2 ^ 2 * y3 * e3 ^ 2 * x1 * e6 * e2 * y1 - -8 * y2 ^ 2 * y3 ^ 2 * e3 ^ 2 * x1 * e6 * e2 + -32 * y2 ^ 4 * y3 * e3 ^ 2 * x1 ^ 2 * y1 * e1 + -16 * y2 ^ 3 * y3 ^ 2 * e3 ^ 2 * x1 * y1 * e2 - -16 * y2 * y3 ^ 2 * e3 ^ 2 * x1 ^ 2 * y1 * e1 * e2 + -16 * y2 ^ 2 * y3 * e3 ^ 2 * x1 ^ 2 * e1 * e2 * y1 + -16 * y2 ^ 2 * y3 ^ 2 * e3 ^ 2 * x1 ^ 2 * e1 * e2 - -16 * x2 ^ 2 * e3 ^ 3 * y1 * e5 * y2 * x1 * e1 - -4 * x2 ^ 3 * e3 ^ 3 * y1 * e5 * y2 * e1 - -16 * x2 ^ 2 * e3 ^ 3 * y1 * e6 * y2 * x1 * e1 - -4 * x2 ^ 3 * e3 ^ 3 * y1 * e6 * y2 * e1 + -6 * x2 ^ 3 * e3 ^ 3 * y1 ^ 2 * x1 * e1 ^ 2 + -10 * x2 ^ 2 * e3 ^ 3 * y1 * x1 ^ 2 * e1 ^ 2 * y2 - -8 * x2 ^ 2 * e3 ^ 3 * y1 ^ 2 * x1 * e1 * e2 - -2 * x2 ^ 3 * e3 ^ 3 * y1 ^ 2 * e1 * e2 - -8 * x2 ^ 2 * e3 ^ 3 * y2 ^ 2 * e5 * x1 * e1 - -2 * x2 ^ 3 * e3 ^ 3 * y2 ^ 2 * e5 * e1 - -2 * x2 ^ 2 * e3 ^ 3 * y2 * e5 * e2 * y1 - -2 * x2 ^ 2 * e3 ^ 3 * y2 * e5 * e2 * y3 - -8 * x2 ^ 2 * e3 ^ 3 * y2 ^ 2 * e6 * x1 * e1 - -2 * x2 ^ 3 * e3 ^ 3 * y2 ^ 2 * e6 * e1 - -2 * x2 ^ 2 * e3 ^ 3 * y2 * e6 * e2 * y1 - -2 * x2 ^ 2 * e3 ^ 3 * y2 * e6 * e2 * y3 + -16 * x2 ^ 2 * e3 ^ 3 * y1 * y2 ^ 3 * x1 * e1 + -4 * x2 ^ 3 * e3 ^ 3 * y1 * y2 ^ 3 * e1 + -4 * x2 ^ 2 * e3 ^ 3 * y1 * y2 ^ 2 * e2 * y3 + -6 * x2 ^ 3 * e3 ^ 3 * y2 ^ 2 * x1 * e1 ^ 2 + -4 * x2 ^ 3 * e3 ^ 3 * y1 * x1 * e1 ^ 2 * y2 - -8 * x2 ^ 2 * e3 ^ 3 * y1 * x1 * e1 * e2 * y3 - -2 * x2 ^ 3 * e3 ^ 3 * y1 * e1 * e2 * y3 + -8 * x2 ^ 2 * e3 ^ 3 * y2 * x1 * e1 * e2 * y1 + -8 * x2 ^ 2 * e3 ^ 3 * y2 * x1 * e1 * e2 * y3 + -2 * x2 ^ 3 * e3 ^ 3 * y2 * e1 * e2 * y1 + -2 * x2 ^ 3 * e3 ^ 3 * y2 * e1 * e2 * y3 - -8 * x3 ^ 2 * e3 ^ 3 * y1 * e5 * y2 * x1 * e1 - -4 * x3 ^ 2 * e3 ^ 3 * y1 * e5 * y2 * x2 * e1 - -8 * x3 ^ 2 * e3 ^ 3 * y1 * e6 * y2 * x1 * e1 - -4 * x3 ^ 2 * e3 ^ 3 * y1 * e6 * y2 * x2 * e1 + -4 * x3 ^ 2 * e3 ^ 3 * y1 ^ 2 * x1 * e1 ^ 2 * x2 + -4 * x3 ^ 2 * e3 ^ 3 * y1 * x1 ^ 2 * e1 ^ 2 * y2 - -4 * x3 ^ 2 * e3 ^ 3 * y1 ^ 2 * x1 * e1 * e2 - -14 * x3 ^ 2 * e3 ^ 3 * y1 * x2 ^ 2 * e1 ^ 2 * y2 - -2 * x3 ^ 2 * e3 ^ 3 * y1 ^ 2 * x2 * e1 * e2 - -4 * x3 ^ 2 * e3 ^ 3 * y2 ^ 2 * e5 * x1 * e1 - -2 * x3 ^ 2 * e3 ^ 3 * y2 ^ 2 * e5 * x2 * e1 - -2 * x3 ^ 2 * e3 ^ 3 * y2 * e5 * e2 * y1 - -2 * x3 ^ 2 * e3 ^ 3 * y2 * e5 * e2 * y3 - -4 * x3 ^ 2 * e3 ^ 3 * y2 ^ 2 * e6 * x1 * e1 - -2 * x3 ^ 2 * e3 ^ 3 * y2 ^ 2 * e6 * x2 * e1 - -2 * x3 ^ 2 * e3 ^ 3 * y2 * e6 * e2 * y1 - -2 * x3 ^ 2 * e3 ^ 3 * y2 * e6 * e2 * y3 + -8 * x3 ^ 2 * e3 ^ 3 * y1 * y2 ^ 3 * x1 * e1 + -4 * x3 ^ 2 * e3 ^ 3 * y1 * y2 ^ 3 * x2 * e1 + -4 * x3 ^ 2 * e3 ^ 3 * y1 * y2 ^ 2 * e2 * y3 + -4 * x3 ^ 2 * e3 ^ 3 * y2 ^ 2 * x1 * e1 ^ 2 * x2 - -8 * x3 ^ 2 * e3 ^ 3 * y1 * x1 * e1 ^ 2 * y2 * x2 - -4 * x3 ^ 2 * e3 ^ 3 * y1 * x1 * e1 * e2 * y3 - -2 * x3 ^ 2 * e3 ^ 3 * y1 * x2 * e1 * e2 * y3 + -4 * x3 ^ 2 * e3 ^ 3 * y2 * x1 * e1 * e2 * y1 + -4 * x3 ^ 2 * e3 ^ 3 * y2 * x1 * e1 * e2 * y3 + -2 * x3 ^ 2 * e3 ^ 3 * y2 * x2 * e1 * e2 * y1 + -2 * x3 ^ 2 * e3 ^ 3 * y2 * x2 * e1 * e2 * y3 - -8 * e3 ^ 3 * x1 ^ 3 * y1 * e5 * y2 * e1 - -20 * e3 ^ 3 * x1 ^ 2 * y1 * e5 * y2 * x2 * e1 - -8 * e3 ^ 3 * x1 ^ 3 * y1 * e6 * y2 * e1 - -20 * e3 ^ 3 * x1 ^ 2 * y1 * e6 * y2 * x2 * e1 + -12 * e3 ^ 3 * x1 ^ 3 * y1 ^ 2 * e1 ^ 2 * x2 + -2 * e3 ^ 3 * x1 ^ 4 * y1 * e1 ^ 2 * y2 - -4 * e3 ^ 3 * x1 ^ 3 * y1 ^ 2 * e1 * e2 - -10 * e3 ^ 3 * x1 ^ 2 * y1 ^ 2 * x2 * e1 * e2 - -4 * e3 ^ 3 * x1 ^ 3 * y2 ^ 2 * e5 * e1 - -10 * e3 ^ 3 * x1 ^ 2 * y2 ^ 2 * e5 * x2 * e1 - -2 * e3 ^ 3 * x1 ^ 2 * y2 * e5 * e2 * y1 - -2 * e3 ^ 3 * x1 ^ 2 * y2 * e5 * e2 * y3 - -4 * e3 ^ 3 * x1 ^ 3 * y2 ^ 2 * e6 * e1 - -10 * e3 ^ 3 * x1 ^ 2 * y2 ^ 2 * e6 * x2 * e1 - -2 * e3 ^ 3 * x1 ^ 2 * y2 * e6 * e2 * y1 - -2 * e3 ^ 3 * x1 ^ 2 * y2 * e6 * e2 * y3 + -8 * e3 ^ 3 * x1 ^ 3 * y1 * y2 ^ 3 * e1 + -20 * e3 ^ 3 * x1 ^ 2 * y1 * y2 ^ 3 * x2 * e1 + -4 * e3 ^ 3 * x1 ^ 2 * y1 * y2 ^ 2 * e2 * y3 + -12 * e3 ^ 3 * x1 ^ 3 * y2 ^ 2 * e1 ^ 2 * x2 + -8 * e3 ^ 3 * x1 ^ 3 * y1 * e1 ^ 2 * y2 * x2 - -4 * e3 ^ 3 * x1 ^ 3 * y1 * e1 * e2 * y3 - -10 * e3 ^ 3 * x1 ^ 2 * y1 * x2 * e1 * e2 * y3 + -4 * e3 ^ 3 * x1 ^ 3 * y2 * e1 * e2 * y1 + -4 * e3 ^ 3 * x1 ^ 3 * y2 * e1 * e2 * y3 + -10 * e3 ^ 3 * x1 ^ 2 * y2 * x2 * e1 * e2 * y1 + -10 * e3 ^ 3 * x1 ^ 2 * y2 * x2 * e1 * e2 * y3 + -2 * x2 * e3 ^ 3 * x3 * y2 ^ 2 * e5 ^ 2 - -12 * x2 * e3 ^ 3 * x3 * y1 ^ 2 * e5 * x1 * e1 - -4 * x2 ^ 2 * e3 ^ 3 * x3 * y1 ^ 2 * e5 * e1 + -16 * x2 * e3 ^ 3 * x3 * y1 * e5 * y2 * e6 + -4 * x2 * e3 ^ 3 * x3 * y1 * e5 * e2 * y3 - -12 * x2 * e3 ^ 3 * x3 * y1 ^ 2 * e6 * x1 * e1 - -4 * x2 ^ 2 * e3 ^ 3 * x3 * y1 ^ 2 * e6 * e1 + -4 * x2 * e3 ^ 3 * x3 * y1 * e6 * e2 * y3 + -24 * x2 * e3 ^ 3 * x3 * y1 ^ 3 * y2 * x1 * e1 + -8 * x2 ^ 2 * e3 ^ 3 * x3 * y1 ^ 3 * y2 * e1 - -8 * x2 * e3 ^ 3 * x3 * y1 ^ 2 * y2 * e2 * y3 + -4 * x2 * e3 ^ 3 * x3 * y1 ^ 2 * e5 * e6 - -8 * x2 * e3 ^ 3 * x3 * y1 ^ 3 * e5 * y2 + -8 * x2 * e3 ^ 3 * x3 * y1 * e5 ^ 2 * y2 - -8 * x2 * e3 ^ 3 * x3 * y1 ^ 2 * e5 * y2 ^ 2 + -4 * x2 * e3 ^ 3 * x3 * y1 ^ 2 * e5 * e2 - -8 * x2 * e3 ^ 3 * x3 * y1 ^ 3 * e6 * y2 + -8 * x2 * e3 ^ 3 * x3 * y1 * e6 ^ 2 * y2 - -8 * x2 * e3 ^ 3 * x3 * y1 ^ 2 * e6 * y2 ^ 2 + -4 * x2 * e3 ^ 3 * x3 * y1 ^ 2 * e6 * e2 - -8 * x2 * e3 ^ 3 * x3 * y1 ^ 3 * y2 * e2 + -16 * x2 * e3 ^ 3 * x3 * y1 ^ 2 * x1 ^ 2 * e1 ^ 2 + -2 * x2 ^ 3 * e3 ^ 3 * x3 * y1 ^ 2 * e1 ^ 2 + -4 * x2 * e3 ^ 3 * x3 * y2 ^ 2 * e5 * e6 - -8 * x2 * e3 ^ 3 * x3 * y2 ^ 3 * e5 * y1 - -8 * x2 * e3 ^ 3 * x3 * y2 ^ 3 * e6 * y1 + -8 * x2 * e3 ^ 3 * x3 * y1 ^ 2 * y2 ^ 2 * e2 + -16 * x2 * e3 ^ 3 * x3 * y2 ^ 2 * x1 ^ 2 * e1 ^ 2 + -2 * x2 ^ 3 * e3 ^ 3 * x3 * y2 ^ 2 * e1 ^ 2 + -4 * x2 * e3 ^ 3 * x3 * e2 ^ 2 * y1 * y3 + -2 * x2 * e3 ^ 3 * x3 * y1 ^ 2 * e5 ^ 2 + -2 * x2 * e3 ^ 3 * x3 * y1 ^ 2 * e6 ^ 2 + -8 * x2 * e3 ^ 3 * x3 * y1 ^ 4 * y2 ^ 2 + -16 * x2 * e3 ^ 3 * x1 * y1 * e5 * y2 * e6 + -4 * x2 * e3 ^ 3 * x1 * y1 * e5 * e2 * y3 + -4 * x2 * e3 ^ 3 * x1 * y1 * e6 * e2 * y3 - -8 * x2 * e3 ^ 3 * x1 * y1 ^ 2 * y2 * e2 * y3 + -4 * x2 * e3 ^ 3 * x1 * y1 ^ 2 * e5 * e6 - -8 * x2 * e3 ^ 3 * x1 * y1 ^ 3 * e5 * y2 + -8 * x2 * e3 ^ 3 * x1 * y1 * e5 ^ 2 * y2 - -8 * x2 * e3 ^ 3 * x1 * y1 ^ 2 * e5 * y2 ^ 2 + -4 * x2 * e3 ^ 3 * x1 * y1 ^ 2 * e5 * e2 - -8 * x2 * e3 ^ 3 * x1 * y1 ^ 3 * e6 * y2 + -8 * x2 * e3 ^ 3 * x1 * y1 * e6 ^ 2 * y2 - -8 * x2 * e3 ^ 3 * x1 * y1 ^ 2 * e6 * y2 ^ 2 + -4 * x2 * e3 ^ 3 * x1 * y1 ^ 2 * e6 * e2 - -8 * x2 * e3 ^ 3 * x1 * y1 ^ 3 * y2 * e2 + -4 * x2 * e3 ^ 3 * x1 * y2 ^ 2 * e5 * e6 - -8 * x2 * e3 ^ 3 * x1 * y2 ^ 3 * e5 * y1 - -8 * x2 * e3 ^ 3 * x1 * y2 ^ 3 * e6 * y1 + -8 * x2 * e3 ^ 3 * x1 * y1 ^ 2 * y2 ^ 2 * e2 + -4 * x2 * e3 ^ 3 * x1 * e2 ^ 2 * y1 * y3 + -2 * x2 * e3 ^ 3 * x1 * y1 ^ 2 * e5 ^ 2 + -2 * x2 * e3 ^ 3 * x1 * y1 ^ 2 * e6 ^ 2 + -8 * x2 * e3 ^ 3 * x1 * y1 ^ 4 * y2 ^ 2 - -8 * x3 * e3 ^ 3 * x1 ^ 2 * y1 ^ 2 * e5 * e1 + -16 * x3 * e3 ^ 3 * x1 * y1 * e5 * y2 * e6 + -4 * x3 * e3 ^ 3 * x1 * y1 * e5 * e2 * y3 - -8 * x3 * e3 ^ 3 * x1 ^ 2 * y1 ^ 2 * e6 * e1 + -4 * x3 * e3 ^ 3 * x1 * y1 * e6 * e2 * y3 + -16 * x3 * e3 ^ 3 * x1 ^ 2 * y1 ^ 3 * y2 * e1 - -8 * x3 * e3 ^ 3 * x1 * y1 ^ 2 * y2 * e2 * y3 + -4 * x3 * e3 ^ 3 * x1 * y1 ^ 2 * e5 * e6 - -8 * x3 * e3 ^ 3 * x1 * y1 ^ 3 * e5 * y2 + -8 * x3 * e3 ^ 3 * x1 * y1 * e5 ^ 2 * y2 - -8 * x3 * e3 ^ 3 * x1 * y1 ^ 2 * e5 * y2 ^ 2 + -4 * x3 * e3 ^ 3 * x1 * y1 ^ 2 * e5 * e2 - -8 * x3 * e3 ^ 3 * x1 * y1 ^ 3 * e6 * y2 + -8 * x3 * e3 ^ 3 * x1 * y1 * e6 ^ 2 * y2 - -8 * x3 * e3 ^ 3 * x1 * y1 ^ 2 * e6 * y2 ^ 2 + -4 * x3 * e3 ^ 3 * x1 * y1 ^ 2 * e6 * e2 - -8 * x3 * e3 ^ 3 * x1 * y1 ^ 3 * y2 * e2 + -8 * x3 * e3 ^ 3 * x1 ^ 3 * y1 ^ 2 * e1 ^ 2 + -10 * x3 * e3 ^ 3 * x1 * y1 ^ 2 * x2 ^ 2 * e1 ^ 2 + -4 * x3 * e3 ^ 3 * x1 * y2 ^ 2 * e5 * e6 - -8 * x3 * e3 ^ 3 * x1 * y2 ^ 3 * e5 * y1 - -8 * x3 * e3 ^ 3 * x1 * y2 ^ 3 * e6 * y1 + -8 * x3 * e3 ^ 3 * x1 * y1 ^ 2 * y2 ^ 2 * e2 + -8 * x3 * e3 ^ 3 * x1 ^ 3 * y2 ^ 2 * e1 ^ 2 + -10 * x3 * e3 ^ 3 * x1 * y2 ^ 2 * x2 ^ 2 * e1 ^ 2 + -4 * x3 * e3 ^ 3 * x1 * e2 ^ 2 * y1 * y3 + -2 * x3 * e3 ^ 3 * x1 * y1 ^ 2 * e5 ^ 2 + -2 * x3 * e3 ^ 3 * x1 * y1 ^ 2 * e6 ^ 2 + -8 * x3 * e3 ^ 3 * x1 * y1 ^ 4 * y2 ^ 2 + -12 * e6 * x2 * e3 ^ 2 * y1 ^ 2 * e5 * x1 * e1 + -4 * e6 * x2 ^ 2 * e3 ^ 2 * y1 ^ 2 * e5 * e1 - -16 * e6 ^ 2 * x2 * e3 ^ 2 * y1 * e5 * y2 - -4 * e6 * x2 * e3 ^ 2 * y1 * e5 * e2 * y3 + -12 * e6 ^ 2 * x2 * e3 ^ 2 * y1 ^ 2 * x1 * e1 + -4 * e6 ^ 2 * x2 ^ 2 * e3 ^ 2 * y1 ^ 2 * e1 - -4 * e6 ^ 2 * x2 * e3 ^ 2 * y1 * e2 * y3 - -24 * e6 * x2 * e3 ^ 2 * y1 ^ 3 * y2 * x1 * e1 - -8 * e6 * x2 ^ 2 * e3 ^ 2 * y1 ^ 3 * y2 * e1 + -8 * e6 * x2 * e3 ^ 2 * y1 ^ 2 * y2 ^ 2 * x1 * e1 + -4 * e6 * x2 ^ 2 * e3 ^ 2 * y1 ^ 2 * y2 ^ 2 * e1 - -4 * e6 ^ 2 * x2 * e3 ^ 2 * y1 ^ 2 * e5 + -8 * e6 * x2 * e3 ^ 2 * y1 ^ 3 * e5 * y2 - -8 * e6 * x2 * e3 ^ 2 * y1 * e5 ^ 2 * y2 + -8 * e6 * x2 * e3 ^ 2 * y1 ^ 2 * e5 * y2 ^ 2 - -4 * e6 * x2 * e3 ^ 2 * y1 ^ 2 * e5 * e2 + -8 * e6 ^ 2 * x2 * e3 ^ 2 * y1 ^ 3 * y2 - 8 * e6 ^ 3 * x2 * e3 ^ 2 * y1 * y2 + -8 * e6 ^ 2 * x2 * e3 ^ 2 * y1 ^ 2 * y2 ^ 2 - -4 * e6 ^ 2 * x2 * e3 ^ 2 * y1 ^ 2 * e2 + -8 * e6 * x2 * e3 ^ 2 * y1 ^ 3 * y2 * e2 - -16 * e6 * x2 * e3 ^ 2 * y1 ^ 2 * x1 ^ 2 * e1 ^ 2 - -2 * e6 * x2 ^ 3 * e3 ^ 2 * y1 ^ 2 * e1 ^ 2 - -4 * e6 ^ 2 * x2 * e3 ^ 2 * y2 ^ 2 * e5 + -8 * e6 * x2 * e3 ^ 2 * y2 ^ 3 * e5 * y1 + -8 * e6 ^ 2 * x2 * e3 ^ 2 * y2 ^ 3 * y1 - -8 * e6 * x2 * e3 ^ 2 * y1 ^ 2 * y2 ^ 2 * e2 - -16 * e6 * x2 * e3 ^ 2 * y2 ^ 2 * x1 ^ 2 * e1 ^ 2 + -6 * e6 * x2 ^ 3 * e3 ^ 2 * y2 ^ 2 * e1 ^ 2 - -4 * e6 * x2 * e3 ^ 2 * e2 ^ 2 * y1 * y3 - -2 * e6 * x2 * e3 ^ 2 * y1 ^ 2 * e5 ^ 2 - -8 * e6 * x2 * e3 ^ 2 * y1 ^ 4 * y2 ^ 2 + -8 * e6 * x3 * e3 ^ 2 * y1 ^ 2 * e5 * x1 * e1 + -4 * e6 * x3 * e3 ^ 2 * y1 ^ 2 * e5 * x2 * e1 - -16 * e6 ^ 2 * x3 * e3 ^ 2 * y1 * e5 * y2 - -4 * e6 * x3 * e3 ^ 2 * y1 * e5 * e2 * y3 + -8 * e6 ^ 2 * x3 * e3 ^ 2 * y1 ^ 2 * x1 * e1 + -4 * e6 ^ 2 * x3 * e3 ^ 2 * y1 ^ 2 * x2 * e1 - -4 * e6 ^ 2 * x3 * e3 ^ 2 * y1 * e2 * y3 - -16 * e6 * x3 * e3 ^ 2 * y1 ^ 3 * y2 * x1 * e1 - -8 * e6 * x3 * e3 ^ 2 * y1 ^ 3 * y2 * x2 * e1 + -8 * e6 * x3 * e3 ^ 2 * y1 ^ 2 * y2 ^ 2 * x1 * e1 + -8 * e6 * x3 * e3 ^ 2 * y1 ^ 2 * y2 ^ 2 * x2 * e1 - -4 * e6 ^ 2 * x3 * e3 ^ 2 * y1 ^ 2 * e5 + -8 * e6 * x3 * e3 ^ 2 * y1 ^ 3 * e5 * y2 - -8 * e6 * x3 * e3 ^ 2 * y1 * e5 ^ 2 * y2 + -8 * e6 * x3 * e3 ^ 2 * y1 ^ 2 * e5 * y2 ^ 2 - -4 * e6 * x3 * e3 ^ 2 * y1 ^ 2 * e5 * e2 + -8 * e6 ^ 2 * x3 * e3 ^ 2 * y1 ^ 3 * y2 - 8 * e6 ^ 3 * x3 * e3 ^ 2 * y1 * y2 + -8 * e6 ^ 2 * x3 * e3 ^ 2 * y1 ^ 2 * y2 ^ 2 - -4 * e6 ^ 2 * x3 * e3 ^ 2 * y1 ^ 2 * e2 + -8 * e6 * x3 * e3 ^ 2 * y1 ^ 3 * y2 * e2 - -8 * e6 * x3 * e3 ^ 2 * y1 ^ 2 * x1 ^ 2 * e1 ^ 2 - -2 * e6 * x3 * e3 ^ 2 * y1 ^ 2 * x2 ^ 2 * e1 ^ 2 - -4 * e6 ^ 2 * x3 * e3 ^ 2 * y2 ^ 2 * e5 + -8 * e6 * x3 * e3 ^ 2 * y2 ^ 3 * e5 * y1 + -8 * e6 ^ 2 * x3 * e3 ^ 2 * y2 ^ 3 * y1 - -8 * e6 * x3 * e3 ^ 2 * y1 ^ 2 * y2 ^ 2 * e2 - -8 * e6 * x3 * e3 ^ 2 * y2 ^ 2 * x1 ^ 2 * e1 ^ 2 + -14 * e6 * x3 * e3 ^ 2 * y2 ^ 2 * x2 ^ 2 * e1 ^ 2 - -4 * e6 * x3 * e3 ^ 2 * e2 ^ 2 * y1 * y3 - -2 * e6 * x3 * e3 ^ 2 * y1 ^ 2 * e5 ^ 2 - -8 * e6 * x3 * e3 ^ 2 * y1 ^ 4 * y2 ^ 2 + -8 * e6 * e3 ^ 2 * x1 ^ 2 * y1 ^ 2 * e5 * e1 - -16 * e6 ^ 2 * e3 ^ 2 * x1 * y1 * e5 * y2 - -4 * e6 * e3 ^ 2 * x1 * y1 * e5 * e2 * y3 + -8 * e6 ^ 2 * e3 ^ 2 * x1 ^ 2 * y1 ^ 2 * e1 - -4 * e6 ^ 2 * e3 ^ 2 * x1 * y1 * e2 * y3 - -16 * e6 * e3 ^ 2 * x1 ^ 2 * y1 ^ 3 * y2 * e1 + -4 * e6 * e3 ^ 2 * x1 ^ 2 * y1 ^ 2 * y2 ^ 2 * e1 - -4 * e6 ^ 2 * e3 ^ 2 * x1 * y1 ^ 2 * e5 + -8 * e6 * e3 ^ 2 * x1 * y1 ^ 3 * e5 * y2 - -8 * e6 * e3 ^ 2 * x1 * y1 * e5 ^ 2 * y2 + -8 * e6 * e3 ^ 2 * x1 * y1 ^ 2 * e5 * y2 ^ 2 - -4 * e6 * e3 ^ 2 * x1 * y1 ^ 2 * e5 * e2 + -8 * e6 ^ 2 * e3 ^ 2 * x1 * y1 ^ 3 * y2 - 8 * e6 ^ 3 * e3 ^ 2 * x1 * y1 * y2 + -8 * e6 ^ 2 * e3 ^ 2 * x1 * y1 ^ 2 * y2 ^ 2 - -4 * e6 ^ 2 * e3 ^ 2 * x1 * y1 ^ 2 * e2 + -8 * e6 * e3 ^ 2 * x1 * y1 ^ 3 * y2 * e2 - -8 * e6 * e3 ^ 2 * x1 ^ 3 * y1 ^ 2 * e1 ^ 2 - -10 * e6 * e3 ^ 2 * x1 * y1 ^ 2 * x2 ^ 2 * e1 ^ 2 - -4 * e6 ^ 2 * e3 ^ 2 * x1 * y2 ^ 2 * e5 + -8 * e6 * e3 ^ 2 * x1 * y2 ^ 3 * e5 * y1 + -8 * e6 ^ 2 * e3 ^ 2 * x1 * y2 ^ 3 * y1 - -8 * e6 * e3 ^ 2 * x1 * y1 ^ 2 * y2 ^ 2 * e2 - -8 * e6 * e3 ^ 2 * x1 ^ 3 * y2 ^ 2 * e1 ^ 2 - -2 * e6 * e3 ^ 2 * x1 * y2 ^ 2 * x2 ^ 2 * e1 ^ 2 - -4 * e6 * e3 ^ 2 * x1 * e2 ^ 2 * y1 * y3 - -2 * e6 * e3 ^ 2 * x1 * y1 ^ 2 * e5 ^ 2 - -8 * e6 * e3 ^ 2 * x1 * y1 ^ 4 * y2 ^ 2 + -12 * e7 * x2 * e3 ^ 2 * y1 ^ 2 * e5 * x1 * e1 + -4 * e7 * x2 ^ 2 * e3 ^ 2 * y1 ^ 2 * e5 * e1 - -16 * e7 * x2 * e3 ^ 2 * y1 * e5 * y2 * e6 - -4 * e7 * x2 * e3 ^ 2 * y1 * e5 * e2 * y3 + -12 * e7 * x2 * e3 ^ 2 * y1 ^ 2 * e6 * x1 * e1 + -4 * e7 * x2 ^ 2 * e3 ^ 2 * y1 ^ 2 * e6 * e1 - -4 * e7 * x2 * e3 ^ 2 * y1 * e6 * e2 * y3 - -24 * e7 * x2 * e3 ^ 2 * y1 ^ 3 * y2 * x1 * e1 - -8 * e7 * x2 ^ 2 * e3 ^ 2 * y1 ^ 3 * y2 * e1 + -8 * e7 * x2 * e3 ^ 2 * y1 ^ 2 * y2 ^ 2 * x1 * e1 + -4 * e7 * x2 ^ 2 * e3 ^ 2 * y1 ^ 2 * y2 ^ 2 * e1 + -8 * e7 * x2 * e3 ^ 2 * y1 ^ 2 * y2 * e2 * y3 - -4 * e7 * x2 * e3 ^ 2 * y1 ^ 2 * e5 * e6 + -8 * e7 * x2 * e3 ^ 2 * y1 ^ 3 * e5 * y2 - -8 * e7 * x2 * e3 ^ 2 * y1 * e5 ^ 2 * y2 + -8 * e7 * x2 * e3 ^ 2 * y1 ^ 2 * e5 * y2 ^ 2 - -4 * e7 * x2 * e3 ^ 2 * y1 ^ 2 * e5 * e2 + -8 * e7 * x2 * e3 ^ 2 * y1 ^ 3 * e6 * y2 - -8 * e7 * x2 * e3 ^ 2 * y1 * e6 ^ 2 * y2 + -8 * e7 * x2 * e3 ^ 2 * y1 ^ 2 * e6 * y2 ^ 2 - -4 * e7 * x2 * e3 ^ 2 * y1 ^ 2 * e6 * e2 + -8 * e7 * x2 * e3 ^ 2 * y1 ^ 3 * y2 * e2 - -16 * e7 * x2 * e3 ^ 2 * y1 ^ 2 * x1 ^ 2 * e1 ^ 2 - -2 * e7 * x2 ^ 3 * e3 ^ 2 * y1 ^ 2 * e1 ^ 2 - -4 * e7 * x2 * e3 ^ 2 * y2 ^ 2 * e5 * e6 + -8 * e7 * x2 * e3 ^ 2 * y2 ^ 3 * e5 * y1 + -8 * e7 * x2 * e3 ^ 2 * y2 ^ 3 * e6 * y1 - -8 * e7 * x2 * e3 ^ 2 * y1 ^ 2 * y2 ^ 2 * e2 - -16 * e7 * x2 * e3 ^ 2 * y2 ^ 2 * x1 ^ 2 * e1 ^ 2 - -2 * e7 * x2 ^ 3 * e3 ^ 2 * y2 ^ 2 * e1 ^ 2 - -4 * e7 * x2 * e3 ^ 2 * e2 ^ 2 * y1 * y3 - -2 * e7 * x2 * e3 ^ 2 * y1 ^ 2 * e5 ^ 2 - -2 * e7 * x2 * e3 ^ 2 * y1 ^ 2 * e6 ^ 2 - -8 * e7 * x2 * e3 ^ 2 * y1 ^ 4 * y2 ^ 2 + -8 * e7 * x3 * e3 ^ 2 * y1 ^ 2 * e5 * x1 * e1 + -4 * e7 * x3 * e3 ^ 2 * y1 ^ 2 * e5 * x2 * e1 - -16 * e7 * x3 * e3 ^ 2 * y1 * e5 * y2 * e6 - -4 * e7 * x3 * e3 ^ 2 * y1 * e5 * e2 * y3 + -8 * e7 * x3 * e3 ^ 2 * y1 ^ 2 * e6 * x1 * e1 + -4 * e7 * x3 * e3 ^ 2 * y1 ^ 2 * e6 * x2 * e1 - -4 * e7 * x3 * e3 ^ 2 * y1 * e6 * e2 * y3 - -16 * e7 * x3 * e3 ^ 2 * y1 ^ 3 * y2 * x1 * e1 - -8 * e7 * x3 * e3 ^ 2 * y1 ^ 3 * y2 * x2 * e1 + -8 * e7 * x3 * e3 ^ 2 * y1 ^ 2 * y2 ^ 2 * x1 * e1 + -8 * e7 * x3 * e3 ^ 2 * y1 ^ 2 * y2 ^ 2 * x2 * e1 + -8 * e7 * x3 * e3 ^ 2 * y1 ^ 2 * y2 * e2 * y3 - -4 * e7 * x3 * e3 ^ 2 * y1 ^ 2 * e5 * e6 + -8 * e7 * x3 * e3 ^ 2 * y1 ^ 3 * e5 * y2 - -8 * e7 * x3 * e3 ^ 2 * y1 * e5 ^ 2 * y2 + -8 * e7 * x3 * e3 ^ 2 * y1 ^ 2 * e5 * y2 ^ 2 - -4 * e7 * x3 * e3 ^ 2 * y1 ^ 2 * e5 * e2 + -8 * e7 * x3 * e3 ^ 2 * y1 ^ 3 * e6 * y2 - -8 * e7 * x3 * e3 ^ 2 * y1 * e6 ^ 2 * y2 + -8 * e7 * x3 * e3 ^ 2 * y1 ^ 2 * e6 * y2 ^ 2 - -4 * e7 * x3 * e3 ^ 2 * y1 ^ 2 * e6 * e2 + -8 * e7 * x3 * e3 ^ 2 * y1 ^ 3 * y2 * e2 - -8 * e7 * x3 * e3 ^ 2 * y1 ^ 2 * x1 ^ 2 * e1 ^ 2 - -2 * e7 * x3 * e3 ^ 2 * y1 ^ 2 * x2 ^ 2 * e1 ^ 2 - -4 * e7 * x3 * e3 ^ 2 * y2 ^ 2 * e5 * e6 + -8 * e7 * x3 * e3 ^ 2 * y2 ^ 3 * e5 * y1 + -8 * e7 * x3 * e3 ^ 2 * y2 ^ 3 * e6 * y1 - -8 * e7 * x3 * e3 ^ 2 * y1 ^ 2 * y2 ^ 2 * e2 - -8 * e7 * x3 * e3 ^ 2 * y2 ^ 2 * x1 ^ 2 * e1 ^ 2 - -2 * e7 * x3 * e3 ^ 2 * y2 ^ 2 * x2 ^ 2 * e1 ^ 2 - -4 * e7 * x3 * e3 ^ 2 * e2 ^ 2 * y1 * y3 - -2 * e7 * x3 * e3 ^ 2 * y1 ^ 2 * e5 ^ 2 - -2 * e7 * x3 * e3 ^ 2 * y1 ^ 2 * e6 ^ 2 - -8 * e7 * x3 * e3 ^ 2 * y1 ^ 4 * y2 ^ 2 + -8 * e7 * e3 ^ 2 * x1 ^ 2 * y1 ^ 2 * e5 * e1 - -16 * e7 * e3 ^ 2 * x1 * y1 * e5 * y2 * e6 - -4 * e7 * e3 ^ 2 * x1 * y1 * e5 * e2 * y3 + -8 * e7 * e3 ^ 2 * x1 ^ 2 * y1 ^ 2 * e6 * e1 - -4 * e7 * e3 ^ 2 * x1 * y1 * e6 * e2 * y3 - -16 * e7 * e3 ^ 2 * x1 ^ 2 * y1 ^ 3 * y2 * e1 + -4 * e7 * e3 ^ 2 * x1 ^ 2 * y1 ^ 2 * y2 ^ 2 * e1 + -8 * e7 * e3 ^ 2 * x1 * y1 ^ 2 * y2 * e2 * y3 - -4 * e7 * e3 ^ 2 * x1 * y1 ^ 2 * e5 * e6 + -8 * e7 * e3 ^ 2 * x1 * y1 ^ 3 * e5 * y2 - -8 * e7 * e3 ^ 2 * x1 * y1 * e5 ^ 2 * y2 + -8 * e7 * e3 ^ 2 * x1 * y1 ^ 2 * e5 * y2 ^ 2 - -4 * e7 * e3 ^ 2 * x1 * y1 ^ 2 * e5 * e2 + -8 * e7 * e3 ^ 2 * x1 * y1 ^ 3 * e6 * y2 - -8 * e7 * e3 ^ 2 * x1 * y1 * e6 ^ 2 * y2 + -8 * e7 * e3 ^ 2 * x1 * y1 ^ 2 * e6 * y2 ^ 2 - -4 * e7 * e3 ^ 2 * x1 * y1 ^ 2 * e6 * e2 + -8 * e7 * e3 ^ 2 * x1 * y1 ^ 3 * y2 * e2 - -8 * e7 * e3 ^ 2 * x1 ^ 3 * y1 ^ 2 * e1 ^ 2 - -10 * e7 * e3 ^ 2 * x1 * y1 ^ 2 * x2 ^ 2 * e1 ^ 2 - -4 * e7 * e3 ^ 2 * x1 * y2 ^ 2 * e5 * e6 + -8 * e7 * e3 ^ 2 * x1 * y2 ^ 3 * e5 * y1 + -8 * e7 * e3 ^ 2 * x1 * y2 ^ 3 * e6 * y1 - -8 * e7 * e3 ^ 2 * x1 * y1 ^ 2 * y2 ^ 2 * e2 - -8 * e7 * e3 ^ 2 * x1 ^ 3 * y2 ^ 2 * e1 ^ 2 - -10 * e7 * e3 ^ 2 * x1 * y2 ^ 2 * x2 ^ 2 * e1 ^ 2 - -4 * e7 * e3 ^ 2 * x1 * e2 ^ 2 * y1 * y3 - -2 * e7 * e3 ^ 2 * x1 * y1 ^ 2 * e5 ^ 2 - -2 * e7 * e3 ^ 2 * x1 * y1 ^ 2 * e6 ^ 2 - -8 * e7 * e3 ^ 2 * x1 * y1 ^ 4 * y2 ^ 2 + -2 * x2 * e3 ^ 3 * x3 * y2 ^ 2 * e6 ^ 2 + -8 * x2 * e3 ^ 3 * x3 * y1 ^ 2 * y2 ^ 4 + -2 * x2 * e3 ^ 3 * x3 * e2 ^ 2 * y1 ^ 2 + -2 * x2 * e3 ^ 3 * x3 * e2 ^ 2 * y3 ^ 2 - -24 * x2 * e3 ^ 3 * x3 * y1 * e5 * y2 * x1 * e1 - -8 * x2 ^ 2 * e3 ^ 3 * x3 * y1 * e5 * y2 * e1 - -24 * x2 * e3 ^ 3 * x3 * y1 * e6 * y2 * x1 * e1 - -8 * x2 ^ 2 * e3 ^ 3 * x3 * y1 * e6 * y2 * e1 + -16 * x2 * e3 ^ 3 * x3 * y1 * x1 ^ 2 * e1 ^ 2 * y2 - -12 * x2 * e3 ^ 3 * x3 * y1 ^ 2 * x1 * e1 * e2 - -4 * x2 ^ 3 * e3 ^ 3 * x3 * y1 * e1 ^ 2 * y2 - -4 * x2 ^ 2 * e3 ^ 3 * x3 * y1 ^ 2 * e1 * e2 - -12 * x2 * e3 ^ 3 * x3 * y2 ^ 2 * e5 * x1 * e1 - -4 * x2 ^ 2 * e3 ^ 3 * x3 * y2 ^ 2 * e5 * e1 - -4 * x2 * e3 ^ 3 * x3 * y2 * e5 * e2 * y1 - -4 * x2 * e3 ^ 3 * x3 * y2 * e5 * e2 * y3 - -12 * x2 * e3 ^ 3 * x3 * y2 ^ 2 * e6 * x1 * e1 - -4 * x2 ^ 2 * e3 ^ 3 * x3 * y2 ^ 2 * e6 * e1 - -4 * x2 * e3 ^ 3 * x3 * y2 * e6 * e2 * y1 - -4 * x2 * e3 ^ 3 * x3 * y2 * e6 * e2 * y3 + -24 * x2 * e3 ^ 3 * x3 * y1 * y2 ^ 3 * x1 * e1 + -8 * x2 ^ 2 * e3 ^ 3 * x3 * y1 * y2 ^ 3 * e1 + -8 * x2 * e3 ^ 3 * x3 * y1 * y2 ^ 2 * e2 * y3 + -4 * x2 ^ 2 * e3 ^ 3 * x3 * y1 * x1 * e1 ^ 2 * y2 - -12 * x2 * e3 ^ 3 * x3 * y1 * x1 * e1 * e2 * y3 - -4 * x2 ^ 2 * e3 ^ 3 * x3 * y1 * e1 * e2 * y3 + -12 * x2 * e3 ^ 3 * x3 * y2 * x1 * e1 * e2 * y1 + -12 * x2 * e3 ^ 3 * x3 * y2 * x1 * e1 * e2 * y3 + -4 * x2 ^ 2 * e3 ^ 3 * x3 * y2 * e1 * e2 * y1 + -4 * x2 ^ 2 * e3 ^ 3 * x3 * y2 * e1 * e2 * y3 + -2 * x2 * e3 ^ 3 * x1 * y2 ^ 2 * e5 ^ 2 + -2 * x2 * e3 ^ 3 * x1 * y2 ^ 2 * e6 ^ 2 + -8 * x2 * e3 ^ 3 * x1 * y1 ^ 2 * y2 ^ 4 + -2 * x2 * e3 ^ 3 * x1 * e2 ^ 2 * y1 ^ 2 + -2 * x2 * e3 ^ 3 * x1 * e2 ^ 2 * y3 ^ 2 - -4 * x2 * e3 ^ 3 * x1 * y2 * e5 * e2 * y1 - -4 * x2 * e3 ^ 3 * x1 * y2 * e5 * e2 * y3 - -4 * x2 * e3 ^ 3 * x1 * y2 * e6 * e2 * y1 - -4 * x2 * e3 ^ 3 * x1 * y2 * e6 * e2 * y3 + -8 * x2 * e3 ^ 3 * x1 * y1 * y2 ^ 2 * e2 * y3 + -2 * x3 * e3 ^ 3 * x1 * y2 ^ 2 * e5 ^ 2 + -2 * x3 * e3 ^ 3 * x1 * y2 ^ 2 * e6 ^ 2 + -8 * x3 * e3 ^ 3 * x1 * y1 ^ 2 * y2 ^ 4 + -2 * x3 * e3 ^ 3 * x1 * e2 ^ 2 * y1 ^ 2 + -2 * x3 * e3 ^ 3 * x1 * e2 ^ 2 * y3 ^ 2 - -16 * x3 * e3 ^ 3 * x1 ^ 2 * y1 * e5 * y2 * e1 - -16 * x3 * e3 ^ 3 * x1 ^ 2 * y1 * e6 * y2 * e1 + -8 * x3 * e3 ^ 3 * x1 ^ 3 * y1 * e1 ^ 2 * y2 - -8 * x3 * e3 ^ 3 * x1 ^ 2 * y1 ^ 2 * e1 * e2 - -8 * x3 * e3 ^ 3 * x1 ^ 2 * y2 ^ 2 * e5 * e1 - -4 * x3 * e3 ^ 3 * x1 * y2 * e5 * e2 * y1 - -4 * x3 * e3 ^ 3 * x1 * y2 * e5 * e2 * y3 - -8 * x3 * e3 ^ 3 * x1 ^ 2 * y2 ^ 2 * e6 * e1 - -4 * x3 * e3 ^ 3 * x1 * y2 * e6 * e2 * y1 - -4 * x3 * e3 ^ 3 * x1 * y2 * e6 * e2 * y3 + -16 * x3 * e3 ^ 3 * x1 ^ 2 * y1 * y2 ^ 3 * e1 + -8 * x3 * e3 ^ 3 * x1 * y1 * y2 ^ 2 * e2 * y3 - -8 * x3 * e3 ^ 3 * x1 ^ 2 * y1 * e1 * e2 * y3 + -8 * x3 * e3 ^ 3 * x1 ^ 2 * y2 * e1 * e2 * y1 + -8 * x3 * e3 ^ 3 * x1 ^ 2 * y2 * e1 * e2 * y3 - -2 * e6 * x2 * e3 ^ 2 * y2 ^ 2 * e5 ^ 2 - -8 * e6 * x2 * e3 ^ 2 * y1 ^ 2 * y2 ^ 4 - -2 * e6 * x2 * e3 ^ 2 * e2 ^ 2 * y1 ^ 2 - -2 * e6 * x2 * e3 ^ 2 * e2 ^ 2 * y3 ^ 2 + -16 * e6 * x2 * e3 ^ 2 * y1 * e5 * y2 * x1 * e1 + -4 * e6 * x2 ^ 2 * e3 ^ 2 * y1 * e5 * y2 * e1 + -16 * e6 ^ 2 * x2 * e3 ^ 2 * y1 * y2 * x1 * e1 + -4 * e6 ^ 2 * x2 ^ 2 * e3 ^ 2 * y1 * y2 * e1 + -12 * e6 * x2 * e3 ^ 2 * y1 ^ 2 * x1 * e1 * e2 + -4 * e6 * x2 ^ 3 * e3 ^ 2 * y1 * e1 ^ 2 * y2 + -4 * e6 * x2 ^ 2 * e3 ^ 2 * y1 ^ 2 * e1 * e2 + -12 * e6 * x2 * e3 ^ 2 * y2 ^ 2 * e5 * x1 * e1 - -4 * e6 * x2 ^ 2 * e3 ^ 2 * y2 ^ 2 * e5 * e1 + -4 * e6 * x2 * e3 ^ 2 * y2 * e5 * e2 * y1 + -4 * e6 * x2 * e3 ^ 2 * y2 * e5 * e2 * y3 + -12 * e6 ^ 2 * x2 * e3 ^ 2 * y2 ^ 2 * x1 * e1 + -4 * e6 ^ 2 * x2 * e3 ^ 2 * y2 * e2 * y1 + -4 * e6 ^ 2 * x2 * e3 ^ 2 * y2 * e2 * y3 - -24 * e6 * x2 * e3 ^ 2 * y1 * y2 ^ 3 * x1 * e1 + -8 * e6 * x2 ^ 2 * e3 ^ 2 * y1 * y2 ^ 3 * e1 + -4 * e6 * x2 ^ 2 * e3 ^ 2 * y1 * x1 * e1 ^ 2 * y2 + -12 * e6 * x2 * e3 ^ 2 * y1 * x1 * e1 * e2 * y3 + -4 * e6 * x2 ^ 2 * e3 ^ 2 * y1 * e1 * e2 * y3 - -12 * e6 * x2 * e3 ^ 2 * y2 * x1 * e1 * e2 * y1 - -12 * e6 * x2 * e3 ^ 2 * y2 * x1 * e1 * e2 * y3 - -4 * e6 * x2 ^ 2 * e3 ^ 2 * y2 * e1 * e2 * y1 - -4 * e6 * x2 ^ 2 * e3 ^ 2 * y2 * e1 * e2 * y3 - -2 * e6 * x3 * e3 ^ 2 * y2 ^ 2 * e5 ^ 2 - -8 * e6 * x3 * e3 ^ 2 * y1 ^ 2 * y2 ^ 4 - -2 * e6 * x3 * e3 ^ 2 * e2 ^ 2 * y1 ^ 2 - -2 * e6 * x3 * e3 ^ 2 * e2 ^ 2 * y3 ^ 2 + -8 * e6 * x3 * e3 ^ 2 * y1 * e5 * y2 * x1 * e1 + -8 * e6 ^ 2 * x3 * e3 ^ 2 * y1 * y2 * x1 * e1 - -8 * e6 * x3 * e3 ^ 2 * y1 ^ 2 * x1 * e1 ^ 2 * x2 + -8 * e6 * x3 * e3 ^ 2 * y1 ^ 2 * x1 * e1 * e2 + -20 * e6 * x3 * e3 ^ 2 * y1 * x2 ^ 2 * e1 ^ 2 * y2 + -4 * e6 * x3 * e3 ^ 2 * y1 ^ 2 * x2 * e1 * e2 + -8 * e6 * x3 * e3 ^ 2 * y2 ^ 2 * e5 * x1 * e1 - -4 * e6 * x3 * e3 ^ 2 * y2 ^ 2 * e5 * x2 * e1 + -4 * e6 * x3 * e3 ^ 2 * y2 * e5 * e2 * y1 + -4 * e6 * x3 * e3 ^ 2 * y2 * e5 * e2 * y3 + -8 * e6 ^ 2 * x3 * e3 ^ 2 * y2 ^ 2 * x1 * e1 + -4 * e6 ^ 2 * x3 * e3 ^ 2 * y2 * e2 * y1 + -4 * e6 ^ 2 * x3 * e3 ^ 2 * y2 * e2 * y3 - -16 * e6 * x3 * e3 ^ 2 * y1 * y2 ^ 3 * x1 * e1 + -8 * e6 * x3 * e3 ^ 2 * y1 * y2 ^ 3 * x2 * e1 + -16 * e6 * x3 * e3 ^ 2 * y1 * x1 * e1 ^ 2 * y2 * x2 + -8 * e6 * x3 * e3 ^ 2 * y1 * x1 * e1 * e2 * y3 + -4 * e6 * x3 * e3 ^ 2 * y1 * x2 * e1 * e2 * y3 - -8 * e6 * x3 * e3 ^ 2 * y2 * x1 * e1 * e2 * y1 - -8 * e6 * x3 * e3 ^ 2 * y2 * x1 * e1 * e2 * y3 - -4 * e6 * x3 * e3 ^ 2 * y2 * x2 * e1 * e2 * y1 - -4 * e6 * x3 * e3 ^ 2 * y2 * x2 * e1 * e2 * y3 - -2 * e6 * e3 ^ 2 * x1 * y2 ^ 2 * e5 ^ 2 - -8 * e6 * e3 ^ 2 * x1 * y1 ^ 2 * y2 ^ 4 - -2 * e6 * e3 ^ 2 * x1 * e2 ^ 2 * y1 ^ 2 - -2 * e6 * e3 ^ 2 * x1 * e2 ^ 2 * y3 ^ 2 + -12 * e6 * e3 ^ 2 * x1 ^ 2 * y1 * e5 * y2 * e1 + -12 * e6 ^ 2 * e3 ^ 2 * x1 ^ 2 * y1 * y2 * e1 + -8 * e6 * e3 ^ 2 * x1 ^ 2 * y1 ^ 2 * e1 * e2 + -8 * e6 * e3 ^ 2 * x1 ^ 2 * y2 ^ 2 * e5 * e1 + -4 * e6 * e3 ^ 2 * x1 * y2 * e5 * e2 * y1 + -4 * e6 * e3 ^ 2 * x1 * y2 * e5 * e2 * y3 + -8 * e6 ^ 2 * e3 ^ 2 * x1 ^ 2 * y2 ^ 2 * e1 + -4 * e6 ^ 2 * e3 ^ 2 * x1 * y2 * e2 * y1 + -4 * e6 ^ 2 * e3 ^ 2 * x1 * y2 * e2 * y3 - -16 * e6 * e3 ^ 2 * x1 ^ 2 * y1 * y2 ^ 3 * e1 + -8 * e6 * e3 ^ 2 * x1 ^ 2 * y1 * e1 * e2 * y3 - -8 * e6 * e3 ^ 2 * x1 ^ 2 * y2 * e1 * e2 * y1 - -8 * e6 * e3 ^ 2 * x1 ^ 2 * y2 * e1 * e2 * y3 - -2 * e7 * x2 * e3 ^ 2 * y2 ^ 2 * e5 ^ 2 - -2 * e7 * x2 * e3 ^ 2 * y2 ^ 2 * e6 ^ 2 - -8 * e7 * x2 * e3 ^ 2 * y1 ^ 2 * y2 ^ 4 - -2 * e7 * x2 * e3 ^ 2 * e2 ^ 2 * y1 ^ 2 - -2 * e7 * x2 * e3 ^ 2 * e2 ^ 2 * y3 ^ 2 + -16 * e7 * x2 * e3 ^ 2 * y1 * e5 * y2 * x1 * e1 + -4 * e7 * x2 ^ 2 * e3 ^ 2 * y1 * e5 * y2 * e1 + -16 * e7 * x2 * e3 ^ 2 * y1 * e6 * y2 * x1 * e1 + -4 * e7 * x2 ^ 2 * e3 ^ 2 * y1 * e6 * y2 * e1 + -12 * e7 * x2 * e3 ^ 2 * y1 ^ 2 * x1 * e1 * e2 + -4 * e7 * x2 ^ 3 * e3 ^ 2 * y1 * e1 ^ 2 * y2 + -4 * e7 * x2 ^ 2 * e3 ^ 2 * y1 ^ 2 * e1 * e2 + -12 * e7 * x2 * e3 ^ 2 * y2 ^ 2 * e5 * x1 * e1 + -4 * e7 * x2 ^ 2 * e3 ^ 2 * y2 ^ 2 * e5 * e1 + -4 * e7 * x2 * e3 ^ 2 * y2 * e5 * e2 * y1 + -4 * e7 * x2 * e3 ^ 2 * y2 * e5 * e2 * y3 + -12 * e7 * x2 * e3 ^ 2 * y2 ^ 2 * e6 * x1 * e1 + -4 * e7 * x2 ^ 2 * e3 ^ 2 * y2 ^ 2 * e6 * e1 + -4 * e7 * x2 * e3 ^ 2 * y2 * e6 * e2 * y1 + -4 * e7 * x2 * e3 ^ 2 * y2 * e6 * e2 * y3 - -24 * e7 * x2 * e3 ^ 2 * y1 * y2 ^ 3 * x1 * e1 - -8 * e7 * x2 ^ 2 * e3 ^ 2 * y1 * y2 ^ 3 * e1 - -8 * e7 * x2 * e3 ^ 2 * y1 * y2 ^ 2 * e2 * y3 + -4 * e7 * x2 ^ 2 * e3 ^ 2 * y1 * x1 * e1 ^ 2 * y2 + -12 * e7 * x2 * e3 ^ 2 * y1 * x1 * e1 * e2 * y3 + -4 * e7 * x2 ^ 2 * e3 ^ 2 * y1 * e1 * e2 * y3 - -12 * e7 * x2 * e3 ^ 2 * y2 * x1 * e1 * e2 * y1 - -12 * e7 * x2 * e3 ^ 2 * y2 * x1 * e1 * e2 * y3 - -4 * e7 * x2 ^ 2 * e3 ^ 2 * y2 * e1 * e2 * y1 - -4 * e7 * x2 ^ 2 * e3 ^ 2 * y2 * e1 * e2 * y3 - -2 * e7 * x3 * e3 ^ 2 * y2 ^ 2 * e5 ^ 2 - -2 * e7 * x3 * e3 ^ 2 * y2 ^ 2 * e6 ^ 2 - -8 * e7 * x3 * e3 ^ 2 * y1 ^ 2 * y2 ^ 4 - -2 * e7 * x3 * e3 ^ 2 * e2 ^ 2 * y1 ^ 2 - -2 * e7 * x3 * e3 ^ 2 * e2 ^ 2 * y3 ^ 2 + -8 * e7 * x3 * e3 ^ 2 * y1 * e5 * y2 * x1 * e1 + -8 * e7 * x3 * e3 ^ 2 * y1 * e6 * y2 * x1 * e1 - -8 * e7 * x3 * e3 ^ 2 * y1 ^ 2 * x1 * e1 ^ 2 * x2 + -8 * e7 * x3 * e3 ^ 2 * y1 ^ 2 * x1 * e1 * e2 + -20 * e7 * x3 * e3 ^ 2 * y1 * x2 ^ 2 * e1 ^ 2 * y2 + -4 * e7 * x3 * e3 ^ 2 * y1 ^ 2 * x2 * e1 * e2 + -8 * e7 * x3 * e3 ^ 2 * y2 ^ 2 * e5 * x1 * e1 + -4 * e7 * x3 * e3 ^ 2 * y2 ^ 2 * e5 * x2 * e1 + -4 * e7 * x3 * e3 ^ 2 * y2 * e5 * e2 * y1 + -4 * e7 * x3 * e3 ^ 2 * y2 * e5 * e2 * y3 + -8 * e7 * x3 * e3 ^ 2 * y2 ^ 2 * e6 * x1 * e1 + -4 * e7 * x3 * e3 ^ 2 * y2 ^ 2 * e6 * x2 * e1 + -4 * e7 * x3 * e3 ^ 2 * y2 * e6 * e2 * y1 + -4 * e7 * x3 * e3 ^ 2 * y2 * e6 * e2 * y3 - -16 * e7 * x3 * e3 ^ 2 * y1 * y2 ^ 3 * x1 * e1 - -8 * e7 * x3 * e3 ^ 2 * y1 * y2 ^ 3 * x2 * e1 - -8 * e7 * x3 * e3 ^ 2 * y1 * y2 ^ 2 * e2 * y3 - -8 * e7 * x3 * e3 ^ 2 * y2 ^ 2 * x1 * e1 ^ 2 * x2 + -16 * e7 * x3 * e3 ^ 2 * y1 * x1 * e1 ^ 2 * y2 * x2 + -8 * e7 * x3 * e3 ^ 2 * y1 * x1 * e1 * e2 * y3 + -4 * e7 * x3 * e3 ^ 2 * y1 * x2 * e1 * e2 * y3 - -8 * e7 * x3 * e3 ^ 2 * y2 * x1 * e1 * e2 * y1 - -8 * e7 * x3 * e3 ^ 2 * y2 * x1 * e1 * e2 * y3 - -4 * e7 * x3 * e3 ^ 2 * y2 * x2 * e1 * e2 * y1 - -4 * e7 * x3 * e3 ^ 2 * y2 * x2 * e1 * e2 * y3 - -2 * e7 * e3 ^ 2 * x1 * y2 ^ 2 * e5 ^ 2 - -2 * e7 * e3 ^ 2 * x1 * y2 ^ 2 * e6 ^ 2 - -8 * e7 * e3 ^ 2 * x1 * y1 ^ 2 * y2 ^ 4 - -2 * e7 * e3 ^ 2 * x1 * e2 ^ 2 * y1 ^ 2 - -2 * e7 * e3 ^ 2 * x1 * e2 ^ 2 * y3 ^ 2 + -12 * e7 * e3 ^ 2 * x1 ^ 2 * y1 * e5 * y2 * e1 + -12 * e7 * e3 ^ 2 * x1 ^ 2 * y1 * e6 * y2 * e1 + -8 * e7 * e3 ^ 2 * x1 ^ 2 * y1 ^ 2 * e1 * e2 + -8 * e7 * e3 ^ 2 * x1 ^ 2 * y2 ^ 2 * e5 * e1 + -4 * e7 * e3 ^ 2 * x1 * y2 * e5 * e2 * y1 + -4 * e7 * e3 ^ 2 * x1 * y2 * e5 * e2 * y3 + -8 * e7 * e3 ^ 2 * x1 ^ 2 * y2 ^ 2 * e6 * e1 + -4 * e7 * e3 ^ 2 * x1 * y2 * e6 * e2 * y1 + -4 * e7 * e3 ^ 2 * x1 * y2 * e6 * e2 * y3 - -16 * e7 * e3 ^ 2 * x1 ^ 2 * y1 * y2 ^ 3 * e1 - -8 * e7 * e3 ^ 2 * x1 * y1 * y2 ^ 2 * e2 * y3 + -8 * e7 * e3 ^ 2 * x1 ^ 2 * y1 * e1 * e2 * y3 - -8 * e7 * e3 ^ 2 * x1 ^ 2 * y2 * e1 * e2 * y1 - -8 * e7 * e3 ^ 2 * x1 ^ 2 * y2 * e1 * e2 * y3 + 8 * e3 * e6 ^ 3 * y1 * e5 * y2 - -4 * e3 * e6 ^ 3 * y1 ^ 2 * x1 * e1 - 2 * e3 * e6 ^ 3 * y1 ^ 2 * x2 * e1 + -2 * e3 * e6 ^ 3 * y1 * e2 * y3 - 4 * e3 * e6 ^ 2 * y1 ^ 3 * e5 * y2 + -x1 ^ 2 * e1 ^ 3 * e7 ^ 3 + 4 * e3 * e6 ^ 2 * y1 * e5 ^ 2 * y2 - -4 * e3 * e6 ^ 2 * y1 ^ 2 * e5 * y2 ^ 2 + 2 * e3 * e6 ^ 2 * y1 ^ 2 * e5 * e2 - -4 * e3 * e6 ^ 2 * y1 ^ 3 * y2 * e2 + -4 * e3 * e6 ^ 2 * y1 ^ 2 * x1 ^ 2 * e1 ^ 2 + -e3 * e6 ^ 2 * y1 ^ 2 * x2 ^ 2 * e1 ^ 2 - 4 * e3 * e6 ^ 2 * y2 ^ 3 * e5 * y1 + -4 * e3 * e6 ^ 2 * y1 ^ 2 * y2 ^ 2 * e2 + -4 * e3 * e6 ^ 2 * y2 ^ 2 * x1 ^ 2 * e1 ^ 2 - -7 * e3 * e6 ^ 2 * y2 ^ 2 * x2 ^ 2 * e1 ^ 2 + -2 * e3 * e6 ^ 2 * e2 ^ 2 * y1 * y3 + 4 * e3 * e6 ^ 2 * e7 * y1 ^ 2 * e5 - -8 * e3 * e6 ^ 2 * e7 * y1 ^ 3 * y2 + 8 * e3 * e6 ^ 3 * e7 * y1 * y2 - -8 * e3 * e6 ^ 2 * e7 * y1 ^ 2 * y2 ^ 2 + 4 * e3 * e6 ^ 2 * e7 * y1 ^ 2 * e2 + -4 * e3 * e6 ^ 2 * e7 * y2 ^ 2 * e5 - 8 * e3 * e6 ^ 2 * e7 * y2 ^ 3 * y1 + -2 * e3 * e6 * e7 * y1 ^ 2 * e5 ^ 2 + 8 * e3 * e6 * e7 * y1 ^ 4 * y2 ^ 2 + -2 * e3 * e7 ^ 2 * y1 ^ 2 * e5 * e6 - 4 * e3 * e7 ^ 2 * y1 ^ 3 * e5 * y2 + -4 * e3 * e7 ^ 2 * y1 * e5 ^ 2 * y2 - 4 * e3 * e6 ^ 2 * y1 ^ 2 * e5 * x1 * e1 - -2 * e3 * e6 ^ 2 * y1 ^ 2 * e5 * x2 * e1 + 2 * e3 * e6 ^ 2 * y1 * e5 * e2 * y3 + -8 * e3 * e6 ^ 2 * y1 ^ 3 * y2 * x1 * e1 + -4 * e3 * e6 ^ 2 * y1 ^ 3 * y2 * x2 * e1 - -8 * e3 * e6 ^ 2 * y1 ^ 2 * y2 ^ 2 * x1 * e1 - -8 * e3 * e6 ^ 2 * y1 ^ 2 * y2 ^ 2 * x2 * e1 - -12 * e3 * e6 ^ 2 * y1 ^ 2 * y2 * e2 * y3 + e1 * e5 ^ 2 * e6 ^ 3 - -8 * e3 * e6 * e7 * y1 ^ 2 * e5 * x1 * e1 - -4 * e3 * e6 * e7 * y1 ^ 2 * e5 * x2 * e1 + -16 * e3 * e6 ^ 2 * e7 * y1 * e5 * y2 + 4 * e3 * e6 * e7 * y1 * e5 * e2 * y3 - -8 * e3 * e6 ^ 2 * e7 * y1 ^ 2 * x1 * e1 - -4 * e3 * e6 ^ 2 * e7 * y1 ^ 2 * x2 * e1 + 4 * e3 * e6 ^ 2 * e7 * y1 * e2 * y3 + -16 * e3 * e6 * e7 * y1 ^ 3 * y2 * x1 * e1 + -8 * e3 * e6 * e7 * y1 ^ 3 * y2 * x2 * e1 - -16 * e3 * e6 * e7 * y1 ^ 2 * y2 ^ 2 * x1 * e1 - -16 * e3 * e6 * e7 * y1 ^ 2 * y2 ^ 2 * x2 * e1 - -16 * e3 * e6 * e7 * y1 ^ 2 * y2 * e2 * y3 - -8 * e3 * e6 * e7 * y1 ^ 3 * e5 * y2 + 8 * e3 * e6 * e7 * y1 * e5 ^ 2 * y2 - -8 * e3 * e6 * e7 * y1 ^ 2 * e5 * y2 ^ 2 + 4 * e3 * e6 * e7 * y1 ^ 2 * e5 * e2 - -8 * e3 * e6 * e7 * y1 ^ 3 * y2 * e2 + -8 * e3 * e6 * e7 * y1 ^ 2 * x1 ^ 2 * e1 ^ 2 + -2 * e3 * e6 * e7 * y1 ^ 2 * x2 ^ 2 * e1 ^ 2 - -8 * e3 * e6 * e7 * y2 ^ 3 * e5 * y1 + 8 * e3 * e6 * e7 * y1 ^ 2 * y2 ^ 2 * e2 + -8 * e3 * e6 * e7 * y2 ^ 2 * x1 ^ 2 * e1 ^ 2 - -6 * e3 * e6 * e7 * y2 ^ 2 * x2 ^ 2 * e1 ^ 2 + -4 * e3 * e6 * e7 * e2 ^ 2 * y1 * y3 - 4 * e3 * e7 ^ 2 * y1 ^ 2 * e5 * x1 * e1 - -2 * e3 * e7 ^ 2 * y1 ^ 2 * e5 * x2 * e1 + 8 * e3 * e7 ^ 2 * y1 * e5 * y2 * e6 + -2 * e3 * e7 ^ 2 * y1 * e5 * e2 * y3 - 4 * e3 * e7 ^ 2 * y1 ^ 2 * e6 * x1 * e1 - -2 * e3 * e7 ^ 2 * y1 ^ 2 * e6 * x2 * e1 + 2 * e3 * e7 ^ 2 * y1 * e6 * e2 * y3 + -8 * e3 * e7 ^ 2 * y1 ^ 3 * y2 * x1 * e1 + -4 * e3 * e7 ^ 2 * y1 ^ 3 * y2 * x2 * e1 - -8 * e3 * e7 ^ 2 * y1 ^ 2 * y2 ^ 2 * x1 * e1 - -8 * e3 * e7 ^ 2 * y1 ^ 2 * y2 ^ 2 * x2 * e1 - -4 * e3 * e7 ^ 2 * y1 ^ 2 * y2 * e2 * y3 - -4 * e3 * e7 ^ 2 * y1 ^ 2 * e5 * y2 ^ 2 + 2 * e3 * e7 ^ 2 * y1 ^ 2 * e5 * e2 - -4 * e3 * e7 ^ 2 * y1 ^ 3 * e6 * y2 + 4 * e3 * e7 ^ 2 * y1 * e6 ^ 2 * y2 - -4 * e3 * e7 ^ 2 * y1 ^ 2 * e6 * y2 ^ 2 + 2 * e3 * e7 ^ 2 * y1 ^ 2 * e6 * e2 - -4 * e3 * e7 ^ 2 * y1 ^ 3 * y2 * e2 + -4 * e3 * e7 ^ 2 * y1 ^ 2 * x1 ^ 2 * e1 ^ 2 + -e3 * e7 ^ 2 * y1 ^ 2 * x2 ^ 2 * e1 ^ 2 + 2 * e3 * e7 ^ 2 * y2 ^ 2 * e5 * e6 - -4 * e3 * e7 ^ 2 * y2 ^ 3 * e5 * y1 - 4 * e3 * e7 ^ 2 * y2 ^ 3 * e6 * y1 + -4 * e3 * e7 ^ 2 * y1 ^ 2 * y2 ^ 2 * e2 + -4 * e3 * e7 ^ 2 * y2 ^ 2 * x1 ^ 2 * e1 ^ 2 + -e3 * e7 ^ 2 * y2 ^ 2 * x2 ^ 2 * e1 ^ 2 + 2 * e3 * e7 ^ 2 * e2 ^ 2 * y1 * y3 - -16 * e3 * y2 ^ 3 * y3 ^ 3 * y1 ^ 2 * e2 - -16 * e3 * y2 ^ 3 * y3 ^ 2 * y1 ^ 3 * e5 + -16 * e3 * y2 ^ 3 * y3 ^ 2 * y1 * e5 ^ 2 - -16 * e3 * y2 ^ 4 * y3 ^ 2 * y1 ^ 2 * e5 - -16 * e3 * y2 ^ 3 * y3 ^ 2 * y1 ^ 3 * e6 + -16 * e3 * y2 ^ 3 * y3 ^ 2 * y1 * e6 ^ 2 - -16 * e3 * y2 ^ 4 * y3 ^ 2 * y1 ^ 2 * e6 - -16 * e3 * y2 ^ 3 * y3 ^ 2 * y1 ^ 3 * e2 + 8 * e3 * y2 ^ 4 * y3 ^ 2 * e5 * e6 - -16 * e3 * y2 ^ 5 * y3 ^ 2 * e5 * y1 - 16 * e3 * y2 ^ 5 * y3 ^ 2 * e6 * y1 + -16 * e3 * y2 ^ 4 * y3 ^ 2 * y1 ^ 2 * e2 + -16 * e3 * y2 ^ 4 * y3 ^ 2 * x1 ^ 2 * e1 ^ 2 + -4 * e3 * y2 ^ 4 * y3 ^ 2 * x2 ^ 2 * e1 ^ 2 + -8 * e3 * y2 ^ 2 * y3 ^ 3 * e2 ^ 2 * y1 + -4 * e3 * y2 ^ 2 * y3 ^ 2 * y1 ^ 2 * e5 ^ 2 + -4 * e3 * y2 ^ 2 * y3 ^ 2 * y1 ^ 2 * e6 ^ 2 - -4 * e3 * e6 ^ 3 * y2 ^ 2 * x1 * e1 + 2 * e3 * e6 ^ 3 * y2 ^ 2 * x2 * e1 - -2 * e3 * e6 ^ 3 * y2 * e2 * y1 - 2 * e3 * e6 ^ 3 * y2 * e2 * y3 + -2 * e3 * e6 * e7 * y2 ^ 2 * e5 ^ 2 + 8 * e3 * e6 * e7 * y1 ^ 2 * y2 ^ 4 + -2 * e3 * e6 * e7 * e2 ^ 2 * y1 ^ 2 + 2 * e3 * e6 * e7 * e2 ^ 2 * y3 ^ 2 + -4 * e3 * y2 ^ 2 * y3 ^ 2 * e2 ^ 2 * y1 ^ 2 - -8 * e3 * y2 ^ 3 * y3 ^ 3 * e5 * e2 - 8 * e3 * y2 ^ 3 * y3 ^ 3 * e6 * e2 + -16 * e3 * y2 ^ 4 * y3 ^ 3 * y1 * e2 + 16 * e3 * e6 ^ 2 * y2 ^ 2 * y3 * y1 ^ 3 - -16 * e3 * e6 ^ 3 * y2 ^ 2 * y3 * y1 + 16 * e3 * e6 ^ 2 * y2 ^ 3 * y3 * y1 ^ 2 - -8 * e3 * e6 ^ 2 * y2 ^ 3 * y3 * e5 - -16 * e3 * y2 ^ 2 * y3 ^ 2 * y1 ^ 2 * e5 * x1 * e1 - -8 * e3 * y2 ^ 2 * y3 ^ 2 * y1 ^ 2 * e5 * x2 * e1 + -32 * e3 * y2 ^ 3 * y3 ^ 2 * y1 * e5 * e6 + -8 * e3 * y2 ^ 2 * y3 ^ 3 * y1 * e5 * e2 - -16 * e3 * y2 ^ 2 * y3 ^ 2 * y1 ^ 2 * e6 * x1 * e1 + -8 * e3 * y2 ^ 2 * y3 ^ 2 * y1 ^ 2 * e6 * x2 * e1 + -8 * e3 * y2 ^ 2 * y3 ^ 3 * y1 * e6 * e2 + -32 * e3 * y2 ^ 3 * y3 ^ 2 * y1 ^ 3 * x1 * e1 + -16 * e3 * y2 ^ 3 * y3 ^ 2 * y1 ^ 3 * x2 * e1 - -32 * e3 * y2 ^ 4 * y3 ^ 2 * y1 ^ 2 * x1 * e1 + -32 * e3 * y2 ^ 4 * y3 ^ 2 * y1 ^ 2 * x2 * e1 + -8 * e3 * y2 ^ 2 * y3 ^ 2 * y1 ^ 2 * e5 * e6 + -8 * e3 * y2 ^ 2 * y3 ^ 2 * y1 ^ 2 * e5 * e2 + x2 ^ 2 * e1 ^ 3 * e7 ^ 3 + -24 * e3 * y2 ^ 2 * y3 ^ 2 * y1 ^ 2 * e6 * e2 + -16 * e3 * y2 ^ 2 * y3 ^ 2 * y1 ^ 2 * x1 ^ 2 * e1 ^ 2 + -4 * e3 * y2 ^ 2 * y3 ^ 2 * y1 ^ 2 * x2 ^ 2 * e1 ^ 2 + -4 * e3 * e7 ^ 2 * y1 ^ 2 * y2 ^ 4 + e3 * e7 ^ 2 * e2 ^ 2 * y1 ^ 2 + -e3 * e7 ^ 2 * e2 ^ 2 * y3 ^ 2 + 4 * e3 * y2 ^ 4 * y3 ^ 2 * e5 ^ 2 + -4 * e3 * y2 ^ 4 * y3 ^ 2 * e6 ^ 2 + 16 * e3 * y2 ^ 6 * y3 ^ 2 * y1 ^ 2 + -4 * e3 * y2 ^ 2 * y3 ^ 4 * e2 ^ 2 - 4 * e3 * e6 ^ 3 * y2 ^ 3 * y3 + -4 * e3 * e6 ^ 2 * y1 * e5 * y2 * x2 * e1 + -4 * e3 * e6 ^ 3 * y1 * y2 * x2 * e1 + -4 * e3 * e6 ^ 2 * y1 ^ 2 * x1 * e1 ^ 2 * x2 - -6 * e3 * e6 ^ 2 * y1 * x1 ^ 2 * e1 ^ 2 * y2 - -4 * e3 * e6 ^ 2 * y1 ^ 2 * x1 * e1 * e2 - -8 * e3 * e6 ^ 2 * y1 * x2 ^ 2 * e1 ^ 2 * y2 - -2 * e3 * e6 ^ 2 * y1 ^ 2 * x2 * e1 * e2 - -4 * e3 * e6 ^ 2 * y2 ^ 2 * e5 * x1 * e1 + -6 * e3 * e6 ^ 2 * y2 ^ 2 * e5 * x2 * e1 - 2 * e3 * e6 ^ 2 * y2 * e5 * e2 * y1 - -2 * e3 * e6 ^ 2 * y2 * e5 * e2 * y3 + 8 * e3 * e6 ^ 2 * y1 * y2 ^ 3 * x1 * e1 - -12 * e3 * e6 ^ 2 * y1 * y2 ^ 3 * x2 * e1 + -12 * e3 * e6 ^ 2 * y1 * y2 ^ 2 * e2 * y3 - -4 * e3 * e6 ^ 2 * y2 ^ 2 * x1 * e1 ^ 2 * x2 - -12 * e3 * e6 ^ 2 * y1 * x1 * e1 ^ 2 * y2 * x2 - -4 * e3 * e6 ^ 2 * y1 * x1 * e1 * e2 * y3 - -2 * e3 * e6 ^ 2 * y1 * x2 * e1 * e2 * y3 + -4 * e3 * e6 ^ 2 * y2 * x1 * e1 * e2 * y1 + -4 * e3 * e6 ^ 2 * y2 * x1 * e1 * e2 * y3 + -2 * e3 * e6 ^ 2 * y2 * x2 * e1 * e2 * y1 + -2 * e3 * e6 ^ 2 * y2 * x2 * e1 * e2 * y3 + -8 * e3 * e6 * e7 * y1 * e5 * y2 * x2 * e1 + -8 * e3 * e6 ^ 2 * e7 * y1 * y2 * x2 * e1 + -8 * e3 * e6 * e7 * y1 ^ 2 * x1 * e1 ^ 2 * x2 - -12 * e3 * e6 * e7 * y1 * x1 ^ 2 * e1 ^ 2 * y2 - -8 * e3 * e6 * e7 * y1 ^ 2 * x1 * e1 * e2 - -16 * e3 * e6 * e7 * y1 * x2 ^ 2 * e1 ^ 2 * y2 - -4 * e3 * e6 * e7 * y1 ^ 2 * x2 * e1 * e2 - -8 * e3 * e6 * e7 * y2 ^ 2 * e5 * x1 * e1 + -4 * e3 * e6 * e7 * y2 ^ 2 * e5 * x2 * e1 - -4 * e3 * e6 * e7 * y2 * e5 * e2 * y1 - 4 * e3 * e6 * e7 * y2 * e5 * e2 * y3 - -8 * e3 * e6 ^ 2 * e7 * y2 ^ 2 * x1 * e1 - 4 * e3 * e6 ^ 2 * e7 * y2 * e2 * y1 - -4 * e3 * e6 ^ 2 * e7 * y2 * e2 * y3 + -16 * e3 * e6 * e7 * y1 * y2 ^ 3 * x1 * e1 - -8 * e3 * e6 * e7 * y1 * y2 ^ 3 * x2 * e1 + -16 * e3 * e6 * e7 * y1 * y2 ^ 2 * e2 * y3 - -24 * e3 * e6 * e7 * y1 * x1 * e1 ^ 2 * y2 * x2 - -8 * e3 * e6 * e7 * y1 * x1 * e1 * e2 * y3 - -4 * e3 * e6 * e7 * y1 * x2 * e1 * e2 * y3 + -8 * e3 * e6 * e7 * y2 * x1 * e1 * e2 * y1 + -8 * e3 * e6 * e7 * y2 * x1 * e1 * e2 * y3 + -4 * e3 * e6 * e7 * y2 * x2 * e1 * e2 * y1 + -4 * e3 * e6 * e7 * y2 * x2 * e1 * e2 * y3 + -4 * e3 * e7 ^ 2 * y1 * e5 * y2 * x2 * e1 + -4 * e3 * e7 ^ 2 * y1 * e6 * y2 * x2 * e1 + -4 * e3 * e7 ^ 2 * y1 ^ 2 * x1 * e1 ^ 2 * x2 - -6 * e3 * e7 ^ 2 * y1 * x1 ^ 2 * e1 ^ 2 * y2 - -4 * e3 * e7 ^ 2 * y1 ^ 2 * x1 * e1 * e2 - -8 * e3 * e7 ^ 2 * y1 * x2 ^ 2 * e1 ^ 2 * y2 - -2 * e3 * e7 ^ 2 * y1 ^ 2 * x2 * e1 * e2 - -4 * e3 * e7 ^ 2 * y2 ^ 2 * e5 * x1 * e1 - -2 * e3 * e7 ^ 2 * y2 ^ 2 * e5 * x2 * e1 - 2 * e3 * e7 ^ 2 * y2 * e5 * e2 * y1 - -2 * e3 * e7 ^ 2 * y2 * e5 * e2 * y3 - 4 * e3 * e7 ^ 2 * y2 ^ 2 * e6 * x1 * e1 - -2 * e3 * e7 ^ 2 * y2 ^ 2 * e6 * x2 * e1 - 2 * e3 * e7 ^ 2 * y2 * e6 * e2 * y1 - -2 * e3 * e7 ^ 2 * y2 * e6 * e2 * y3 + 8 * e3 * e7 ^ 2 * y1 * y2 ^ 3 * x1 * e1 + -4 * e3 * e7 ^ 2 * y1 * y2 ^ 3 * x2 * e1 + -4 * e3 * e7 ^ 2 * y1 * y2 ^ 2 * e2 * y3 + -4 * e3 * e7 ^ 2 * y2 ^ 2 * x1 * e1 ^ 2 * x2 - -12 * e3 * e7 ^ 2 * y1 * x1 * e1 ^ 2 * y2 * x2 - -4 * e3 * e7 ^ 2 * y1 * x1 * e1 * e2 * y3 - -2 * e3 * e7 ^ 2 * y1 * x2 * e1 * e2 * y3 + -4 * e3 * e7 ^ 2 * y2 * x1 * e1 * e2 * y1 + -4 * e3 * e7 ^ 2 * y2 * x1 * e1 * e2 * y3 + -2 * e3 * e7 ^ 2 * y2 * x2 * e1 * e2 * y1 + -2 * e3 * e7 ^ 2 * y2 * x2 * e1 * e2 * y3 - -48 * e3 * y2 ^ 3 * y3 ^ 2 * y1 * e5 * x2 * e1 - -48 * e3 * y2 ^ 3 * y3 ^ 2 * y1 * e6 * x2 * e1 + -16 * e3 * y2 ^ 2 * y3 ^ 2 * y1 ^ 2 * x1 * e1 ^ 2 * x2 - -24 * e3 * y2 ^ 3 * y3 ^ 2 * y1 * x1 ^ 2 * e1 ^ 2 - -16 * e3 * y2 ^ 2 * y3 ^ 2 * y1 ^ 2 * x1 * e1 * e2 + -32 * e3 * y2 ^ 3 * y3 ^ 2 * y1 * x2 ^ 2 * e1 ^ 2 - -8 * e3 * y2 ^ 2 * y3 ^ 2 * y1 ^ 2 * x2 * e1 * e2 - -16 * e3 * y2 ^ 4 * y3 ^ 2 * e5 * x1 * e1 - -8 * e3 * y2 ^ 4 * y3 ^ 2 * e5 * x2 * e1 - -8 * e3 * y2 ^ 3 * y3 ^ 2 * e5 * e2 * y1 - -16 * e3 * y2 ^ 4 * y3 ^ 2 * e6 * x1 * e1 - -8 * e3 * y2 ^ 4 * y3 ^ 2 * e6 * x2 * e1 - -24 * e3 * y2 ^ 3 * y3 ^ 2 * e6 * e2 * y1 + -32 * e3 * y2 ^ 5 * y3 ^ 2 * y1 * x1 * e1 + -16 * e3 * y2 ^ 5 * y3 ^ 2 * y1 * x2 * e1 + -16 * e3 * y2 ^ 4 * y3 ^ 2 * x1 * e1 ^ 2 * x2 + -16 * e3 * y2 ^ 3 * y3 ^ 2 * y1 * x1 * e1 ^ 2 * x2 - -16 * e3 * y2 ^ 2 * y3 ^ 3 * y1 * x1 * e1 * e2 - -8 * e3 * y2 ^ 2 * y3 ^ 3 * y1 * x2 * e1 * e2 + -16 * e3 * y2 ^ 3 * y3 ^ 2 * x1 * e1 * e2 * y1 + -16 * e3 * y2 ^ 3 * y3 ^ 3 * x1 * e1 * e2 + -8 * e3 * y2 ^ 3 * y3 ^ 2 * x2 * e1 * e2 * y1 + -8 * e3 * y2 ^ 3 * y3 ^ 3 * x2 * e1 * e2 - e3 * e6 ^ 3 * e7 ^ 2 + -16 * e3 * e6 * y2 * y3 * y1 ^ 2 * e5 * x1 * e1 + -8 * e3 * e6 * y2 * y3 * y1 ^ 2 * e5 * x2 * e1 - -32 * e3 * e6 ^ 2 * y2 ^ 2 * y3 * y1 * e5 - -8 * e3 * e6 * y2 * y3 ^ 2 * y1 * e5 * e2 + -16 * e3 * e6 ^ 2 * y2 * y3 * y1 ^ 2 * x1 * e1 + -8 * e3 * e6 ^ 2 * y2 * y3 * y1 ^ 2 * x2 * e1 - -8 * e3 * e6 ^ 2 * y2 * y3 ^ 2 * y1 * e2 - -32 * e3 * e6 * y2 ^ 2 * y3 * y1 ^ 3 * x1 * e1 - -16 * e3 * e6 * y2 ^ 2 * y3 * y1 ^ 3 * x2 * e1 + -32 * e3 * e6 * y2 ^ 3 * y3 * y1 ^ 2 * x1 * e1 - -8 * e3 * e6 ^ 2 * y2 * y3 * y1 ^ 2 * e5 + -16 * e3 * e6 * y2 ^ 2 * y3 * y1 ^ 3 * e5 - -16 * e3 * e6 * y2 ^ 2 * y3 * y1 * e5 ^ 2 + -16 * e3 * e6 * y2 ^ 3 * y3 * y1 ^ 2 * e5 - -8 * e3 * e6 * y2 * y3 * y1 ^ 2 * e5 * e2 + -16 * e3 * e6 * y2 ^ 2 * y3 * y1 ^ 3 * e2 - -16 * e3 * e6 * y2 * y3 * y1 ^ 2 * x1 ^ 2 * e1 ^ 2 - -4 * e3 * e6 * y2 * y3 * y1 ^ 2 * x2 ^ 2 * e1 ^ 2 + -16 * e3 * e6 * y2 ^ 4 * y3 * e5 * y1 + 16 * e3 * e6 ^ 2 * y2 ^ 4 * y3 * y1 - -4 * e3 * e6 ^ 3 * y2 * y3 * y1 ^ 2 - 16 * e3 * e6 * y2 ^ 3 * y3 * y1 ^ 4 - -16 * e3 * e7 * y2 ^ 3 * y3 * y1 ^ 4 - 4 * e3 * e6 * y2 ^ 3 * y3 * e5 ^ 2 - -16 * e3 * e6 * y2 ^ 5 * y3 * y1 ^ 2 - 4 * e3 * e6 * y2 * y3 ^ 3 * e2 ^ 2 + -8 * e3 * e6 ^ 2 * y2 ^ 2 * y3 ^ 2 * e2 - 4 * e3 * e7 * y2 ^ 3 * y3 * e5 ^ 2 - -4 * e3 * e7 * y2 ^ 3 * y3 * e6 ^ 2 - 16 * e3 * e7 * y2 ^ 5 * y3 * y1 ^ 2 - -4 * e3 * e7 * y2 * y3 ^ 3 * e2 ^ 2 - 16 * e3 * e6 * y2 ^ 3 * y3 * y1 ^ 2 * e2 - -16 * e3 * e6 * y2 ^ 3 * y3 * x1 ^ 2 * e1 ^ 2 + -12 * e3 * e6 * y2 ^ 3 * y3 * x2 ^ 2 * e1 ^ 2 - -8 * e3 * e6 * y2 * y3 ^ 2 * e2 ^ 2 * y1 - -4 * e3 * e6 * y2 * y3 * y1 ^ 2 * e5 ^ 2 + -16 * e3 * e7 * y2 * y3 * y1 ^ 2 * e5 * x1 * e1 + -8 * e3 * e7 * y2 * y3 * y1 ^ 2 * e5 * x2 * e1 - -32 * e3 * e7 * y2 ^ 2 * y3 * y1 * e5 * e6 - -8 * e3 * e7 * y2 * y3 ^ 2 * y1 * e5 * e2 + -16 * e3 * e7 * y2 * y3 * y1 ^ 2 * e6 * x1 * e1 + -8 * e3 * e7 * y2 * y3 * y1 ^ 2 * e6 * x2 * e1 - -8 * e3 * e7 * y2 * y3 ^ 2 * y1 * e6 * e2 - -32 * e3 * e7 * y2 ^ 2 * y3 * y1 ^ 3 * x1 * e1 - -16 * e3 * e7 * y2 ^ 2 * y3 * y1 ^ 3 * x2 * e1 + -32 * e3 * e7 * y2 ^ 3 * y3 * y1 ^ 2 * x1 * e1 + -16 * e3 * e7 * y2 ^ 2 * y3 ^ 2 * y1 ^ 2 * e2 - -8 * e3 * e7 * y2 * y3 * y1 ^ 2 * e5 * e6 + -16 * e3 * e7 * y2 ^ 2 * y3 * y1 ^ 3 * e5 - -16 * e3 * e7 * y2 ^ 2 * y3 * y1 * e5 ^ 2 + -16 * e3 * e7 * y2 ^ 3 * y3 * y1 ^ 2 * e5 - -8 * e3 * e7 * y2 * y3 * y1 ^ 2 * e5 * e2 + -16 * e3 * e7 * y2 ^ 2 * y3 * y1 ^ 3 * e6 - -16 * e3 * e7 * y2 ^ 2 * y3 * y1 * e6 ^ 2 + -16 * e3 * e7 * y2 ^ 3 * y3 * y1 ^ 2 * e6 + -16 * e3 * e7 * y2 ^ 2 * y3 * y1 ^ 3 * e2 - -16 * e3 * e7 * y2 * y3 * y1 ^ 2 * x1 ^ 2 * e1 ^ 2 - -4 * e3 * e7 * y2 * y3 * y1 ^ 2 * x2 ^ 2 * e1 ^ 2 - -8 * e3 * e7 * y2 ^ 3 * y3 * e5 * e6 + 16 * e3 * e7 * y2 ^ 4 * y3 * e5 * y1 + -16 * e3 * e7 * y2 ^ 4 * y3 * e6 * y1 - -16 * e3 * e7 * y2 ^ 3 * y3 * y1 ^ 2 * e2 - -16 * e3 * e7 * y2 ^ 3 * y3 * x1 ^ 2 * e1 ^ 2 - -4 * e3 * e7 * y2 ^ 3 * y3 * x2 ^ 2 * e1 ^ 2 - -8 * e3 * e7 * y2 * y3 ^ 2 * e2 ^ 2 * y1 - -4 * e3 * e7 * y2 * y3 * y1 ^ 2 * e5 ^ 2 - -4 * e3 * e7 * y2 * y3 * y1 ^ 2 * e6 ^ 2 + e1 ^ 3 * x3 ^ 2 * e7 ^ 3 - -4 * e3 * e6 * y2 * y3 * e2 ^ 2 * y1 ^ 2 + -16 * e3 * e6 * y2 ^ 2 * y3 * y1 * e5 * x2 * e1 + -16 * e3 * e6 ^ 2 * y2 ^ 2 * y3 * y1 * x2 * e1 - -16 * e3 * e6 * y2 * y3 * y1 ^ 2 * x1 * e1 ^ 2 * x2 + -24 * e3 * e6 * y2 ^ 2 * y3 * y1 * x1 ^ 2 * e1 ^ 2 + -16 * e3 * e6 * y2 * y3 * y1 ^ 2 * x1 * e1 * e2 + -8 * e3 * e6 * y2 * y3 * y1 ^ 2 * x2 * e1 * e2 + -16 * e3 * e6 * y2 ^ 3 * y3 * e5 * x1 * e1 - -8 * e3 * e6 * y2 ^ 3 * y3 * e5 * x2 * e1 + -8 * e3 * e6 * y2 ^ 2 * y3 * e5 * e2 * y1 + -8 * e3 * e6 * y2 ^ 2 * y3 ^ 2 * e5 * e2 + -16 * e3 * e6 ^ 2 * y2 ^ 3 * y3 * x1 * e1 - -32 * e3 * e6 * y2 ^ 4 * y3 * y1 * x1 * e1 + -16 * e3 * e6 * y2 ^ 4 * y3 * y1 * x2 * e1 + -16 * e3 * e6 * y2 ^ 2 * y3 * y1 * x1 * e1 ^ 2 * x2 + -16 * e3 * e6 * y2 * y3 ^ 2 * y1 * x1 * e1 * e2 + -8 * e3 * e6 * y2 * y3 ^ 2 * y1 * x2 * e1 * e2 - -16 * e3 * e6 * y2 ^ 2 * y3 * x1 * e1 * e2 * y1 - -16 * e3 * e6 * y2 ^ 2 * y3 ^ 2 * x1 * e1 * e2 - -8 * e3 * e6 * y2 ^ 2 * y3 * x2 * e1 * e2 * y1 - -8 * e3 * e6 * y2 ^ 2 * y3 ^ 2 * x2 * e1 * e2 - e1 * y3 ^ 2 * e6 ^ 4 - -4 * e3 * e7 * y2 * y3 * e2 ^ 2 * y1 ^ 2 + -16 * e3 * e7 * y2 ^ 2 * y3 * y1 * e5 * x2 * e1 + -16 * e3 * e7 * y2 ^ 2 * y3 * y1 * e6 * x2 * e1 - -16 * e3 * e7 * y2 * y3 * y1 ^ 2 * x1 * e1 ^ 2 * x2 + -24 * e3 * e7 * y2 ^ 2 * y3 * y1 * x1 ^ 2 * e1 ^ 2 + -16 * e3 * e7 * y2 * y3 * y1 ^ 2 * x1 * e1 * e2 + -8 * e3 * e7 * y2 * y3 * y1 ^ 2 * x2 * e1 * e2 + -16 * e3 * e7 * y2 ^ 3 * y3 * e5 * x1 * e1 + -8 * e3 * e7 * y2 ^ 3 * y3 * e5 * x2 * e1 + -8 * e3 * e7 * y2 ^ 2 * y3 * e5 * e2 * y1 + -8 * e3 * e7 * y2 ^ 2 * y3 ^ 2 * e5 * e2 + -16 * e3 * e7 * y2 ^ 3 * y3 * e6 * x1 * e1 + -8 * e3 * e7 * y2 ^ 3 * y3 * e6 * x2 * e1 + -8 * e3 * e7 * y2 ^ 2 * y3 ^ 2 * e6 * e2 - -32 * e3 * e7 * y2 ^ 4 * y3 * y1 * x1 * e1 - -16 * e3 * e7 * y2 ^ 4 * y3 * y1 * x2 * e1 - -16 * e3 * e7 * y2 ^ 3 * y3 ^ 2 * y1 * e2 - -16 * e3 * e7 * y2 ^ 3 * y3 * x1 * e1 ^ 2 * x2 + -16 * e3 * e7 * y2 ^ 2 * y3 * y1 * x1 * e1 ^ 2 * x2 + -16 * e3 * e7 * y2 * y3 ^ 2 * y1 * x1 * e1 * e2 + -8 * e3 * e7 * y2 * y3 ^ 2 * y1 * x2 * e1 * e2 - -16 * e3 * e7 * y2 ^ 2 * y3 * x1 * e1 * e2 * y1 - -16 * e3 * e7 * y2 ^ 2 * y3 ^ 2 * x1 * e1 * e2 - -8 * e3 * e7 * y2 ^ 2 * y3 * x2 * e1 * e2 * y1 - -8 * e3 * e7 * y2 ^ 2 * y3 ^ 2 * x2 * e1 * e2 - e6 ^ 3 * x3 ^ 2 * e3 ^ 3 - -16 * e1 * y2 ^ 3 * y3 ^ 2 * e4 * y1 ^ 3 - e6 ^ 3 * e3 ^ 3 * x1 ^ 2 + -2 * e6 ^ 4 * x2 * e3 ^ 2 + 2 * e6 ^ 4 * x3 * e3 ^ 2 + -2 * e6 ^ 4 * e3 ^ 2 * x1 - e5 ^ 3 * x2 ^ 2 * e3 ^ 3 - -e5 ^ 3 * x3 ^ 2 * e3 ^ 3 - e5 ^ 3 * e3 ^ 3 * x1 ^ 2 + -2 * x1 ^ 5 * e1 ^ 3 * e3 ^ 3 - 3 * e3 * e6 ^ 4 * e5 - e3 * e5 ^ 3 * e6 ^ 2 - -3 * e3 * e5 ^ 2 * e6 ^ 3 - e3 * e5 ^ 3 * e7 ^ 2 - e6 ^ 3 * x2 ^ 2 * e3 ^ 3 - -2 * e6 ^ 3 * x2 * e3 ^ 3 * x3 - 2 * e6 ^ 3 * x2 * e3 ^ 3 * x1 - -2 * e6 ^ 3 * x3 * e3 ^ 3 * x1 + 2 * e6 ^ 3 * e7 * x2 * e3 ^ 2 + -2 * e6 ^ 3 * e7 * x3 * e3 ^ 2 + 2 * e6 ^ 3 * e7 * e3 ^ 2 * x1 - -2 * e5 ^ 3 * x2 * e3 ^ 3 * x3 - 2 * e5 ^ 3 * x2 * e3 ^ 3 * x1 - -2 * e5 ^ 3 * x3 * e3 ^ 3 * x1 + 2 * e5 ^ 3 * e6 * x2 * e3 ^ 2 + -6 * e5 ^ 2 * e6 ^ 2 * x2 * e3 ^ 2 + 2 * e5 ^ 3 * e6 * x3 * e3 ^ 2 + -6 * e5 ^ 2 * e6 ^ 2 * x3 * e3 ^ 2 + 2 * e5 ^ 3 * e6 * e3 ^ 2 * x1 + -6 * e5 ^ 2 * e6 ^ 2 * e3 ^ 2 * x1 + 2 * e5 ^ 3 * e7 * x2 * e3 ^ 2 + -2 * e5 ^ 3 * e7 * x3 * e3 ^ 2 + 2 * e5 ^ 3 * e7 * e3 ^ 2 * x1 - -3 * e5 ^ 2 * e6 * x2 ^ 2 * e3 ^ 3 - 3 * e5 * e6 ^ 2 * x2 ^ 2 * e3 ^ 3 - -3 * e5 ^ 2 * e6 * x3 ^ 2 * e3 ^ 3 - 3 * e5 * e6 ^ 2 * x3 ^ 2 * e3 ^ 3 - -3 * e5 ^ 2 * e6 * e3 ^ 3 * x1 ^ 2 - 3 * e5 * e6 ^ 2 * e3 ^ 3 * x1 ^ 2 + -6 * e5 * e6 ^ 3 * x2 * e3 ^ 2 + 6 * e5 * e6 ^ 3 * x3 * e3 ^ 2 + -6 * e5 * e6 ^ 3 * e3 ^ 2 * x1 + 8 * x1 ^ 3 * e1 ^ 2 * e6 ^ 2 * e3 ^ 2 - -8 * e1 ^ 2 * x3 ^ 3 * e6 ^ 2 * e3 ^ 2 + 4 * e5 ^ 2 * x1 ^ 3 * e1 * e3 ^ 3 + -2 * e5 ^ 2 * x2 ^ 3 * e1 * e3 ^ 3 - 5 * x1 ^ 4 * e1 ^ 2 * e3 ^ 3 * e5 - -5 * x1 ^ 4 * e1 ^ 2 * e3 ^ 3 * e6 - x2 ^ 4 * e1 ^ 2 * e3 ^ 3 * e5 - -x2 ^ 4 * e1 ^ 2 * e3 ^ 3 * e6 + 3 * e1 ^ 2 * x3 ^ 4 * e3 ^ 3 * e5 + -3 * e1 ^ 2 * x3 ^ 4 * e3 ^ 3 * e6 + 8 * x1 ^ 2 * e1 ^ 3 * x2 ^ 3 * e3 ^ 3 + -2 * x1 * e1 ^ 3 * x2 ^ 4 * e3 ^ 3 + 8 * x1 ^ 4 * e1 ^ 3 * x2 * e3 ^ 3 + -12 * x1 ^ 3 * e1 ^ 3 * x2 ^ 2 * e3 ^ 3 + -4 * x1 ^ 3 * e1 ^ 3 * x3 ^ 2 * e3 ^ 3 + 6 * x1 ^ 4 * e1 ^ 3 * x3 * e3 ^ 3 - -3 * x1 ^ 4 * e1 ^ 3 * e6 * e3 ^ 2 - 3 * x1 ^ 4 * e1 ^ 3 * e7 * e3 ^ 2 - -8 * x2 ^ 3 * e1 ^ 3 * x3 ^ 2 * e3 ^ 3 - 2 * x2 ^ 4 * e1 ^ 3 * e3 ^ 3 * x3 + -x2 ^ 4 * e1 ^ 3 * e6 * e3 ^ 2 + x2 ^ 4 * e1 ^ 3 * e7 * e3 ^ 2 - -12 * e1 ^ 3 * x3 ^ 3 * x2 ^ 2 * e3 ^ 3 - -4 * e1 ^ 3 * x3 ^ 3 * e3 ^ 3 * x1 ^ 2 + 2 * e6 ^ 2 * x2 ^ 3 * e3 ^ 3 * e1 + -4 * e6 ^ 2 * e3 ^ 3 * x1 ^ 3 * e1 - 3 * e6 ^ 3 * x2 ^ 2 * e3 ^ 2 * e1 - -7 * e6 ^ 3 * e3 ^ 2 * x1 ^ 2 * e1 - 6 * e1 ^ 3 * x3 ^ 4 * e3 ^ 3 * x1 - -8 * e1 ^ 3 * x3 ^ 4 * e3 ^ 3 * x2 + e6 ^ 3 * e1 * x3 ^ 2 * e3 ^ 2 - -6 * e3 * e6 ^ 3 * e7 * e5 - 4 * e3 * e6 ^ 3 * y2 ^ 2 * y3 ^ 2 + -4 * e3 * e6 ^ 4 * y2 * y3 - 2 * e3 * e5 ^ 3 * e6 * e7 - -6 * e3 * e5 ^ 2 * e6 ^ 2 * e7 - 4 * e3 * e5 ^ 3 * y2 ^ 2 * y3 ^ 2 - -3 * e3 * e5 ^ 2 * e6 * e7 ^ 2 - 3 * e3 * e5 * e6 ^ 2 * e7 ^ 2 - e3 * e6 ^ 5 + -12 * e6 ^ 2 * x2 * e3 ^ 3 * x3 * x1 * e1 + -4 * e6 ^ 2 * x2 ^ 2 * e3 ^ 3 * x3 * e1 + -10 * e6 ^ 2 * x2 * e3 ^ 3 * x1 ^ 2 * e1 + -8 * e6 ^ 2 * x2 ^ 2 * e3 ^ 3 * x1 * e1 - 4 * e6 ^ 3 * y2 * y3 * x2 * e3 ^ 2 - -4 * e6 ^ 3 * y2 * y3 * x3 * e3 ^ 2 - 4 * e6 ^ 3 * y2 * y3 * e3 ^ 2 * x1 + -8 * x1 * e1 ^ 2 * x2 ^ 2 * e6 ^ 2 * e3 ^ 2 + -16 * x1 ^ 2 * e1 ^ 2 * x2 * e6 ^ 2 * e3 ^ 2 - -4 * e5 ^ 3 * y2 * y3 * x2 * e3 ^ 2 - 4 * e5 ^ 3 * y2 * y3 * x3 * e3 ^ 2 - -4 * e5 ^ 3 * y2 * y3 * e3 ^ 2 * x1 + -8 * x1 ^ 2 * e1 ^ 2 * e6 ^ 2 * x3 * e3 ^ 2 - -8 * x2 ^ 2 * e1 ^ 2 * e6 ^ 2 * x3 * e3 ^ 2 - -16 * e1 ^ 2 * x3 ^ 2 * e6 ^ 2 * x2 * e3 ^ 2 - -6 * e6 ^ 2 * x2 * e3 ^ 3 * x3 * e5 - 6 * e6 ^ 2 * x2 * e3 ^ 3 * x1 * e5 - -6 * e6 ^ 2 * x3 * e3 ^ 3 * x1 * e5 + 6 * e6 ^ 2 * e7 * x2 * e3 ^ 2 * e5 + -6 * e6 ^ 2 * e7 * x3 * e3 ^ 2 * e5 + 6 * e6 ^ 2 * e7 * e3 ^ 2 * x1 * e5 - -8 * x1 * e1 ^ 2 * x2 ^ 3 * e3 ^ 3 * e5 - -8 * x1 * e1 ^ 2 * x2 ^ 3 * e3 ^ 3 * e6 - -16 * x1 ^ 3 * e1 ^ 2 * x2 * e3 ^ 3 * e5 - -16 * x1 ^ 3 * e1 ^ 2 * x2 * e3 ^ 3 * e6 - -18 * x1 ^ 2 * e1 ^ 2 * x2 ^ 2 * e3 ^ 3 * e5 - -18 * x1 ^ 2 * e1 ^ 2 * x2 ^ 2 * e3 ^ 3 * e6 - -6 * e5 ^ 2 * x2 * e3 ^ 3 * x3 * e6 - 6 * e5 ^ 2 * x2 * e3 ^ 3 * x1 * e6 - -6 * e5 ^ 2 * x3 * e3 ^ 3 * x1 * e6 + 6 * e5 ^ 2 * e7 * x2 * e3 ^ 2 * e6 + -6 * e5 ^ 2 * e7 * x3 * e3 ^ 2 * e6 + 6 * e5 ^ 2 * e7 * e3 ^ 2 * x1 * e6 - -6 * x1 ^ 2 * e1 ^ 2 * x3 ^ 2 * e3 ^ 3 * e5 - -6 * x1 ^ 2 * e1 ^ 2 * x3 ^ 2 * e3 ^ 3 * e6 - -12 * x1 ^ 3 * e1 ^ 2 * x3 * e3 ^ 3 * e5 - -12 * x1 ^ 3 * e1 ^ 2 * x3 * e3 ^ 3 * e6 + -8 * x1 ^ 3 * e1 ^ 2 * e6 * e3 ^ 2 * e5 + -8 * x1 ^ 3 * e1 ^ 2 * e7 * e3 ^ 2 * e5 + -8 * x1 ^ 3 * e1 ^ 2 * e7 * e3 ^ 2 * e6 + -6 * x2 ^ 2 * e1 ^ 2 * x3 ^ 2 * e3 ^ 3 * e5 + -6 * x2 ^ 2 * e1 ^ 2 * x3 ^ 2 * e3 ^ 3 * e6 + -8 * e1 ^ 2 * x3 ^ 3 * x2 * e3 ^ 3 * e5 + -8 * e1 ^ 2 * x3 ^ 3 * x2 * e3 ^ 3 * e6 + -4 * e1 ^ 2 * x3 ^ 3 * e3 ^ 3 * x1 * e5 + -4 * e1 ^ 2 * x3 ^ 3 * e3 ^ 3 * x1 * e6 - -12 * e6 ^ 2 * y2 * y3 * x2 * e3 ^ 2 * e5 - -12 * e6 ^ 2 * y2 * y3 * x3 * e3 ^ 2 * e5 - -12 * e6 ^ 2 * y2 * y3 * e3 ^ 2 * x1 * e5 - -32 * x1 * e1 ^ 2 * x2 ^ 2 * y2 * y3 * e3 ^ 2 * e5 - -32 * x1 * e1 ^ 2 * x2 ^ 2 * y2 * y3 * e3 ^ 2 * e6 - -16 * x1 * e1 ^ 2 * x2 * y2 * y3 * x3 * e3 ^ 2 * e5 - -16 * x1 * e1 ^ 2 * x2 * y2 * y3 * x3 * e3 ^ 2 * e6 - -32 * x1 ^ 2 * e1 ^ 2 * x2 * y2 * y3 * e3 ^ 2 * e5 - -32 * x1 ^ 2 * e1 ^ 2 * x2 * y2 * y3 * e3 ^ 2 * e6 - -12 * x1 * e1 ^ 2 * x2 ^ 2 * e3 ^ 3 * x3 * e5 - -12 * x1 * e1 ^ 2 * x2 ^ 2 * e3 ^ 3 * x3 * e6 - -24 * x1 ^ 2 * e1 ^ 2 * x2 * x3 * e3 ^ 3 * e5 - -24 * x1 ^ 2 * e1 ^ 2 * x2 * x3 * e3 ^ 3 * e6 + -8 * x1 * e1 ^ 2 * x2 ^ 2 * e6 * e3 ^ 2 * e5 + -16 * x1 ^ 2 * e1 ^ 2 * x2 * e6 * e3 ^ 2 * e5 + -8 * x1 * e1 ^ 2 * x2 ^ 2 * e7 * e3 ^ 2 * e5 + -8 * x1 * e1 ^ 2 * x2 ^ 2 * e7 * e3 ^ 2 * e6 + -16 * x1 ^ 2 * e1 ^ 2 * x2 * e7 * e3 ^ 2 * e5 + -16 * x1 ^ 2 * e1 ^ 2 * x2 * e7 * e3 ^ 2 * e6 - -12 * e5 ^ 2 * y2 * y3 * x2 * e3 ^ 2 * e6 - -12 * e5 ^ 2 * y2 * y3 * x3 * e3 ^ 2 * e6 - -12 * e5 ^ 2 * y2 * y3 * e3 ^ 2 * x1 * e6 - -16 * x1 ^ 2 * e1 ^ 2 * y2 * y3 * x3 * e3 ^ 2 * e5 - -16 * x1 ^ 2 * e1 ^ 2 * y2 * y3 * x3 * e3 ^ 2 * e6 - -16 * x1 ^ 3 * e1 ^ 2 * y2 * y3 * e3 ^ 2 * e5 - -16 * x1 ^ 3 * e1 ^ 2 * y2 * y3 * e3 ^ 2 * e6 + -8 * x1 ^ 2 * e1 ^ 2 * e6 * x3 * e3 ^ 2 * e5 + -8 * x1 ^ 2 * e1 ^ 2 * e7 * x3 * e3 ^ 2 * e5 + -8 * x1 ^ 2 * e1 ^ 2 * e7 * x3 * e3 ^ 2 * e6 - -16 * x2 ^ 3 * e1 ^ 2 * y2 * y3 * e3 ^ 2 * e5 - -16 * x2 ^ 3 * e1 ^ 2 * y2 * y3 * e3 ^ 2 * e6 - -16 * x2 ^ 2 * e1 ^ 2 * y2 * y3 * x3 * e3 ^ 2 * e5 - -16 * x2 ^ 2 * e1 ^ 2 * y2 * y3 * x3 * e3 ^ 2 * e6 - -8 * x2 ^ 2 * e1 ^ 2 * e6 * x3 * e3 ^ 2 * e5 - -8 * x2 ^ 2 * e1 ^ 2 * e7 * x3 * e3 ^ 2 * e5 - -8 * x2 ^ 2 * e1 ^ 2 * e7 * x3 * e3 ^ 2 * e6 + -12 * e1 ^ 2 * x3 ^ 2 * y2 * y3 * x2 * e3 ^ 2 * e5 + -12 * e1 ^ 2 * x3 ^ 2 * y2 * y3 * x2 * e3 ^ 2 * e6 + -12 * e1 ^ 2 * x3 ^ 3 * y2 * y3 * e3 ^ 2 * e5 + -12 * e1 ^ 2 * x3 ^ 3 * y2 * y3 * e3 ^ 2 * e6 + -12 * e1 ^ 2 * x3 ^ 2 * y2 * y3 * e3 ^ 2 * x1 * e5 + -12 * e1 ^ 2 * x3 ^ 2 * y2 * y3 * e3 ^ 2 * x1 * e6 - -16 * e1 ^ 2 * x3 ^ 2 * e6 * x2 * e3 ^ 2 * e5 - -8 * e1 ^ 2 * x3 ^ 3 * e6 * e3 ^ 2 * e5 - -8 * e1 ^ 2 * x3 ^ 3 * e7 * e3 ^ 2 * e5 - -8 * e1 ^ 2 * x3 ^ 3 * e7 * e3 ^ 2 * e6 + 8 * e5 * x1 ^ 3 * e1 * e3 ^ 3 * e6 + -4 * e5 * x2 ^ 3 * e1 * e3 ^ 3 * e6 - -8 * e1 ^ 2 * x3 ^ 2 * e6 ^ 2 * e3 ^ 2 * x1 + -8 * e6 ^ 2 * x3 * e3 ^ 3 * x1 ^ 2 * e1 - -10 * e6 ^ 2 * e7 * x2 * e3 ^ 2 * x1 * e1 - -3 * e6 ^ 2 * e7 * x2 ^ 2 * e3 ^ 2 * e1 - -6 * e6 ^ 2 * e7 * x3 * e3 ^ 2 * x1 * e1 - -2 * e6 ^ 2 * e7 * x3 * e3 ^ 2 * x2 * e1 - -7 * e6 ^ 2 * e7 * e3 ^ 2 * x1 ^ 2 * e1 + -12 * e5 ^ 2 * x2 * e3 ^ 3 * x3 * x1 * e1 + -4 * e5 ^ 2 * x2 ^ 2 * e3 ^ 3 * x3 * e1 + -10 * e5 ^ 2 * x2 * e3 ^ 3 * x1 ^ 2 * e1 + -8 * e5 ^ 2 * x2 ^ 2 * e3 ^ 3 * x1 * e1 + -8 * e5 ^ 2 * x3 * e3 ^ 3 * x1 ^ 2 * e1 - -10 * e5 ^ 2 * e6 * x2 * e3 ^ 2 * x1 * e1 - -3 * e5 ^ 2 * e6 * x2 ^ 2 * e3 ^ 2 * e1 - -6 * e5 ^ 2 * e6 * x3 * e3 ^ 2 * x1 * e1 - -2 * e5 ^ 2 * e6 * x3 * e3 ^ 2 * x2 * e1 - -7 * e5 ^ 2 * e6 * e3 ^ 2 * x1 ^ 2 * e1 - -10 * e5 ^ 2 * e7 * x2 * e3 ^ 2 * x1 * e1 - -3 * e5 ^ 2 * e7 * x2 ^ 2 * e3 ^ 2 * e1 - -6 * e5 ^ 2 * e7 * x3 * e3 ^ 2 * x1 * e1 - -2 * e5 ^ 2 * e7 * x3 * e3 ^ 2 * x2 * e1 - -7 * e5 ^ 2 * e7 * e3 ^ 2 * x1 ^ 2 * e1 + -16 * e5 * e6 * x2 ^ 2 * e3 ^ 3 * x1 * e1 + -8 * e5 * e6 * x3 ^ 2 * e3 ^ 3 * x1 * e1 + -4 * e5 * e6 * x3 ^ 2 * e3 ^ 3 * x2 * e1 + -20 * e5 * e6 * e3 ^ 3 * x1 ^ 2 * x2 * e1 - -20 * e5 * e6 ^ 2 * x2 * e3 ^ 2 * x1 * e1 - -6 * e5 * e6 ^ 2 * x2 ^ 2 * e3 ^ 2 * e1 - -12 * e5 * e6 ^ 2 * x3 * e3 ^ 2 * x1 * e1 - -4 * e5 * e6 ^ 2 * x3 * e3 ^ 2 * x2 * e1 - -14 * e5 * e6 ^ 2 * e3 ^ 2 * x1 ^ 2 * e1 + -16 * x1 ^ 3 * e1 ^ 3 * x3 * e3 ^ 3 * x2 - -8 * x1 ^ 3 * e1 ^ 3 * e6 * e3 ^ 2 * x2 - -8 * x1 ^ 3 * e1 ^ 3 * e7 * e3 ^ 2 * x2 - -12 * x2 ^ 2 * e1 ^ 3 * x3 ^ 2 * e3 ^ 3 * x1 - -16 * e1 ^ 2 * x3 ^ 3 * x2 * e3 ^ 3 * y1 * y2 - -16 * e1 ^ 3 * x3 ^ 3 * x2 * e3 ^ 3 * x1 - -8 * e1 ^ 2 * x3 ^ 3 * e3 ^ 3 * x1 * y1 * y2 + -20 * e6 ^ 2 * y2 * y3 * x2 * e3 ^ 2 * x1 * e1 + -14 * e6 ^ 2 * y2 * y3 * x2 ^ 2 * e3 ^ 2 * e1 + -12 * e6 ^ 2 * y2 * y3 * x3 * e3 ^ 2 * x1 * e1 + -12 * e6 ^ 2 * y2 * y3 * x3 * e3 ^ 2 * x2 * e1 + -4 * e6 ^ 2 * x3 ^ 2 * e3 ^ 3 * x1 * e1 + -2 * e6 ^ 2 * x3 ^ 2 * e3 ^ 3 * x2 * e1 - 10 * e6 ^ 3 * x2 * e3 ^ 2 * x1 * e1 - -6 * e6 ^ 3 * x3 * e3 ^ 2 * x1 * e1 - 2 * e6 ^ 3 * x3 * e3 ^ 2 * x2 * e1 + -4 * e5 ^ 2 * x3 ^ 2 * e3 ^ 3 * x1 * e1 + -2 * e5 ^ 2 * x3 ^ 2 * e3 ^ 3 * x2 * e1 - -6 * e1 ^ 2 * x3 ^ 4 * e3 ^ 3 * y1 * y2 + -14 * e6 ^ 2 * y2 * y3 * e3 ^ 2 * x1 ^ 2 * e1 + -20 * x1 ^ 2 * e1 ^ 3 * x2 ^ 2 * y2 * y3 * e3 ^ 2 + -16 * x1 * e1 ^ 3 * x2 ^ 3 * y2 * y3 * e3 ^ 2 + -8 * x1 ^ 2 * e1 ^ 3 * x2 * y2 * y3 * x3 * e3 ^ 2 + -8 * x1 * e1 ^ 3 * x2 ^ 2 * y2 * y3 * x3 * e3 ^ 2 + -16 * x1 ^ 3 * e1 ^ 3 * x2 * y2 * y3 * e3 ^ 2 + -12 * x1 ^ 2 * e1 ^ 3 * x2 ^ 2 * e3 ^ 3 * x3 - -6 * x1 ^ 2 * e1 ^ 3 * x2 ^ 2 * e6 * e3 ^ 2 + -12 * x1 * e1 ^ 3 * x2 ^ 2 * e6 * x3 * e3 ^ 2 - -6 * x1 ^ 2 * e1 ^ 3 * x2 ^ 2 * e7 * e3 ^ 2 + -12 * x1 * e1 ^ 3 * x2 ^ 2 * e7 * x3 * e3 ^ 2 + -20 * e5 ^ 2 * y2 * y3 * x2 * e3 ^ 2 * x1 * e1 + -14 * e5 ^ 2 * y2 * y3 * x2 ^ 2 * e3 ^ 2 * e1 + -12 * e5 ^ 2 * y2 * y3 * x3 * e3 ^ 2 * x1 * e1 + -12 * e5 ^ 2 * y2 * y3 * x3 * e3 ^ 2 * x2 * e1 + -14 * e5 ^ 2 * y2 * y3 * e3 ^ 2 * x1 ^ 2 * e1 + -40 * e5 * e6 * y2 * y3 * x2 * e3 ^ 2 * x1 * e1 + -28 * e5 * e6 * y2 * y3 * x2 ^ 2 * e3 ^ 2 * e1 + -24 * e5 * e6 * y2 * y3 * x3 * e3 ^ 2 * x1 * e1 + -24 * e5 * e6 * y2 * y3 * x3 * e3 ^ 2 * x2 * e1 + -28 * e5 * e6 * y2 * y3 * e3 ^ 2 * x1 ^ 2 * e1 + -24 * e5 * e6 * x2 * e3 ^ 3 * x3 * x1 * e1 + -8 * e5 * e6 * x2 ^ 2 * e3 ^ 3 * x3 * e1 + -16 * e5 * e6 * x3 * e3 ^ 3 * x1 ^ 2 * e1 - -20 * e5 * e6 * e7 * x2 * e3 ^ 2 * x1 * e1 - -6 * e5 * e6 * e7 * x2 ^ 2 * e3 ^ 2 * e1 - -12 * e5 * e6 * e7 * x3 * e3 ^ 2 * x1 * e1 - -4 * e5 * e6 * e7 * x3 * e3 ^ 2 * x2 * e1 - -14 * e5 * e6 * e7 * e3 ^ 2 * x1 ^ 2 * e1 + -8 * x1 ^ 3 * e1 ^ 3 * y2 * y3 * x3 * e3 ^ 2 + -6 * x1 ^ 4 * e1 ^ 3 * y2 * y3 * e3 ^ 2 - -4 * x1 ^ 3 * e1 ^ 3 * e6 * x3 * e3 ^ 2 - -4 * x1 ^ 3 * e1 ^ 3 * e7 * x3 * e3 ^ 2 + -6 * x2 ^ 4 * e1 ^ 3 * y2 * y3 * e3 ^ 2 + -8 * x2 ^ 3 * e1 ^ 3 * y2 * y3 * x3 * e3 ^ 2 + -8 * x2 ^ 3 * e1 ^ 3 * e6 * x3 * e3 ^ 2 + -8 * x2 ^ 3 * e1 ^ 3 * e7 * x3 * e3 ^ 2 - -24 * e1 ^ 2 * x3 ^ 2 * y2 ^ 2 * y3 * x2 * e3 ^ 2 * y1 - -28 * e1 ^ 3 * x3 ^ 2 * y2 * y3 * x2 * e3 ^ 2 * x1 - -10 * e1 ^ 3 * x3 ^ 2 * y2 * y3 * x2 ^ 2 * e3 ^ 2 - -24 * e1 ^ 2 * x3 ^ 3 * y2 ^ 2 * y3 * e3 ^ 2 * y1 - -20 * e1 ^ 3 * x3 ^ 3 * y2 * y3 * e3 ^ 2 * x1 - -20 * e1 ^ 3 * x3 ^ 3 * y2 * y3 * e3 ^ 2 * x2 - -24 * e1 ^ 2 * x3 ^ 2 * y2 ^ 2 * y3 * e3 ^ 2 * x1 * y1 - -10 * e1 ^ 3 * x3 ^ 2 * y2 * y3 * e3 ^ 2 * x1 ^ 2 + -32 * e1 ^ 2 * x3 ^ 2 * e6 * x2 * e3 ^ 2 * y1 * y2 + -24 * e1 ^ 3 * x3 ^ 2 * e6 * x2 * e3 ^ 2 * x1 + -18 * e1 ^ 3 * x3 ^ 2 * e6 * x2 ^ 2 * e3 ^ 2 + -16 * e1 ^ 2 * x3 ^ 3 * e6 * e3 ^ 2 * y1 * y2 + -12 * e1 ^ 3 * x3 ^ 3 * e6 * e3 ^ 2 * x1 + -16 * e1 ^ 3 * x3 ^ 3 * e6 * e3 ^ 2 * x2 + -16 * e1 ^ 2 * x3 ^ 3 * e7 * e3 ^ 2 * y1 * y2 + -12 * e1 ^ 3 * x3 ^ 3 * e7 * e3 ^ 2 * x1 + -16 * e1 ^ 3 * x3 ^ 3 * e7 * e3 ^ 2 * x2 - -4 * y1 * y2 * e1 * x3 ^ 2 * e6 ^ 2 * e3 ^ 2 + -e5 ^ 2 * e1 * x3 ^ 2 * e6 * e3 ^ 2 + e5 ^ 2 * e1 * x3 ^ 2 * e7 * e3 ^ 2 + -e6 ^ 2 * e1 * x3 ^ 2 * e7 * e3 ^ 2 + 2 * e6 ^ 2 * e1 * x3 ^ 2 * e3 ^ 2 * e5 - -8 * e1 ^ 2 * x3 ^ 2 * e6 * e3 ^ 2 * x1 * e5 - -16 * e1 ^ 2 * x3 ^ 2 * e7 * x2 * e3 ^ 2 * e5 - -16 * e1 ^ 2 * x3 ^ 2 * e7 * x2 * e3 ^ 2 * e6 - -8 * e1 ^ 2 * x3 ^ 2 * e7 * e3 ^ 2 * x1 * e5 - -8 * e1 ^ 2 * x3 ^ 2 * e7 * e3 ^ 2 * x1 * e6 - -4 * y1 * y2 * e1 * x3 ^ 2 * e6 * e3 ^ 2 * e5 - -4 * y1 * y2 * e1 * x3 ^ 2 * e7 * e3 ^ 2 * e5 - -4 * y1 * y2 * e1 * x3 ^ 2 * e7 * e3 ^ 2 * e6 + -2 * e5 * e1 * x3 ^ 2 * e7 * e3 ^ 2 * e6 + -16 * e1 ^ 2 * x3 ^ 2 * e6 * e3 ^ 2 * x1 * y1 * y2 + -6 * e1 ^ 3 * x3 ^ 2 * e6 * e3 ^ 2 * x1 ^ 2 + -32 * e1 ^ 2 * x3 ^ 2 * e7 * x2 * e3 ^ 2 * y1 * y2 + -24 * e1 ^ 3 * x3 ^ 2 * e7 * x2 * e3 ^ 2 * x1 + -18 * e1 ^ 3 * x3 ^ 2 * e7 * x2 ^ 2 * e3 ^ 2 + -16 * e1 ^ 2 * x3 ^ 2 * e7 * e3 ^ 2 * x1 * y1 * y2 + -6 * e1 ^ 3 * x3 ^ 2 * e7 * e3 ^ 2 * x1 ^ 2 + -4 * y1 ^ 2 * y2 ^ 2 * e1 * x3 ^ 2 * e6 * e3 ^ 2 + -4 * y1 ^ 2 * y2 ^ 2 * e1 * x3 ^ 2 * e7 * e3 ^ 2 + -4 * e3 * e6 ^ 3 * e7 * y2 * y3 + 2 * e3 * x1 * e1 ^ 2 * x2 * e6 ^ 3 + -4 * e3 * e5 ^ 3 * e6 * y2 * y3 + 12 * e3 * e5 ^ 2 * e6 ^ 2 * y2 * y3 + -4 * e3 * e5 ^ 3 * e7 * y2 * y3 - 12 * e3 * e5 ^ 2 * e6 * y2 ^ 2 * y3 ^ 2 - -12 * e3 * e5 * e6 ^ 2 * y2 ^ 2 * y3 ^ 2 + 12 * e3 * e5 * e6 ^ 3 * y2 * y3 - -e3 * x1 ^ 2 * e1 ^ 2 * e6 ^ 3 + 3 * e3 * x2 ^ 2 * e1 ^ 2 * e6 ^ 3 + -7 * e3 * e1 ^ 2 * x3 ^ 2 * e6 ^ 3 + 2 * e3 * e6 ^ 4 * x1 * e1 - -2 * e3 * e6 ^ 4 * e1 * x3 - 2 * e3 * x2 ^ 3 * e1 ^ 3 * e6 ^ 2 - -2 * e3 * x2 ^ 3 * e1 ^ 3 * e7 ^ 2 - 2 * e3 * x1 ^ 2 * e1 ^ 2 * e6 ^ 2 * e7 + -6 * e3 * x2 ^ 2 * e1 ^ 2 * e6 ^ 2 * e7 + -14 * e3 * e1 ^ 2 * x3 ^ 2 * e6 ^ 2 * e7 + 6 * e3 * x1 * e1 ^ 2 * x3 * e6 ^ 3 + -10 * e3 * x2 * e1 ^ 2 * x3 * e6 ^ 3 + 2 * e3 * e5 ^ 2 * x1 * e1 * e6 ^ 2 + -2 * e3 * e5 ^ 2 * x1 * e1 * e7 ^ 2 - 2 * e3 * e5 ^ 2 * e1 * x3 * e6 ^ 2 - -2 * e3 * e5 ^ 2 * e1 * x3 * e7 ^ 2 - e3 * x1 ^ 2 * e1 ^ 2 * e6 ^ 2 * e5 - -e3 * x1 ^ 2 * e1 ^ 2 * e7 ^ 2 * e5 - e3 * x1 ^ 2 * e1 ^ 2 * e7 ^ 2 * e6 + -3 * e3 * x2 ^ 2 * e1 ^ 2 * e6 ^ 2 * e5 + -3 * e3 * x2 ^ 2 * e1 ^ 2 * e7 ^ 2 * e5 + -3 * e3 * x2 ^ 2 * e1 ^ 2 * e7 ^ 2 * e6 + -7 * e3 * e1 ^ 2 * x3 ^ 2 * e6 ^ 2 * e5 + -7 * e3 * e1 ^ 2 * x3 ^ 2 * e7 ^ 2 * e5 + -7 * e3 * e1 ^ 2 * x3 ^ 2 * e7 ^ 2 * e6 + 4 * e3 * e6 ^ 3 * x1 * e1 * e5 - -4 * e3 * e6 ^ 3 * e1 * x3 * e5 - 2 * e3 * x1 ^ 2 * e1 ^ 3 * x2 * e6 ^ 2 - -4 * e3 * x1 * e1 ^ 3 * x2 ^ 2 * e6 ^ 2 - -2 * e3 * x1 ^ 2 * e1 ^ 3 * x2 * e7 ^ 2 - -4 * e3 * x1 * e1 ^ 3 * x2 ^ 2 * e7 ^ 2 + -4 * e3 * x1 * e1 ^ 2 * x2 * e6 ^ 2 * e7 + -8 * e3 * x1 * e1 ^ 2 * x2 * e6 ^ 2 * y2 * y3 + -4 * e3 * x1 ^ 2 * e1 ^ 2 * e6 ^ 2 * y2 * y3 + -4 * e3 * x2 ^ 2 * e1 ^ 2 * e6 ^ 2 * y2 * y3 - -20 * e3 * e1 ^ 2 * x3 ^ 2 * e6 ^ 2 * y2 * y3 + -12 * e3 * e6 ^ 2 * e7 * y2 * y3 * e5 + -2 * e3 * x1 * e1 ^ 2 * x2 * e6 ^ 2 * e5 + -2 * e3 * x1 * e1 ^ 2 * x2 * e7 ^ 2 * e5 + -2 * e3 * x1 * e1 ^ 2 * x2 * e7 ^ 2 * e6 + -12 * e3 * e5 ^ 2 * e7 * y2 * y3 * e6 - -2 * e3 * x1 ^ 2 * e1 ^ 2 * e6 * e7 * e5 - -4 * e3 * x1 ^ 2 * e1 ^ 2 * y2 ^ 2 * y3 ^ 2 * e5 - -4 * e3 * x1 ^ 2 * e1 ^ 2 * y2 ^ 2 * y3 ^ 2 * e6 + -6 * e3 * x2 ^ 2 * e1 ^ 2 * e6 * e7 * e5 - -20 * e3 * x2 ^ 2 * e1 ^ 2 * y2 ^ 2 * y3 ^ 2 * e5 - -20 * e3 * x2 ^ 2 * e1 ^ 2 * y2 ^ 2 * y3 ^ 2 * e6 + -14 * e3 * e1 ^ 2 * x3 ^ 2 * e6 * e7 * e5 + -12 * e3 * e1 ^ 2 * x3 ^ 2 * y2 ^ 2 * y3 ^ 2 * e5 + -12 * e3 * e1 ^ 2 * x3 ^ 2 * y2 ^ 2 * y3 ^ 2 * e6 + -4 * e3 * x1 * e1 ^ 2 * x2 * e6 * e7 * e5 - -24 * e3 * x1 * e1 ^ 2 * x2 * y2 ^ 2 * y3 ^ 2 * e5 - -24 * e3 * x1 * e1 ^ 2 * x2 * y2 ^ 2 * y3 ^ 2 * e6 + -8 * e3 * x1 * e1 ^ 2 * x2 * e6 * y2 * y3 * e5 + -8 * e3 * x1 * e1 ^ 2 * x2 * e7 * y2 * y3 * e5 + -8 * e3 * x1 * e1 ^ 2 * x2 * e7 * y2 * y3 * e6 + -4 * e3 * x1 ^ 2 * e1 ^ 2 * e6 * y2 * y3 * e5 + -4 * e3 * x1 ^ 2 * e1 ^ 2 * e7 * y2 * y3 * e5 + -4 * e3 * x1 ^ 2 * e1 ^ 2 * e7 * y2 * y3 * e6 + -4 * e3 * x2 ^ 2 * e1 ^ 2 * e6 * y2 * y3 * e5 + -4 * e3 * x2 ^ 2 * e1 ^ 2 * e7 * y2 * y3 * e5 + -4 * e3 * x2 ^ 2 * e1 ^ 2 * e7 * y2 * y3 * e6 - -20 * e3 * e1 ^ 2 * x3 ^ 2 * e6 * y2 * y3 * e5 + -6 * e3 * x1 * e1 ^ 2 * x3 * e6 ^ 2 * e5 + -6 * e3 * x1 * e1 ^ 2 * x3 * e7 ^ 2 * e5 + -6 * e3 * x1 * e1 ^ 2 * x3 * e7 ^ 2 * e6 + -10 * e3 * x2 * e1 ^ 2 * x3 * e6 ^ 2 * e5 + -10 * e3 * x2 * e1 ^ 2 * x3 * e7 ^ 2 * e5 + -10 * e3 * x2 * e1 ^ 2 * x3 * e7 ^ 2 * e6 + -4 * e3 * e5 * x1 * e1 * e7 ^ 2 * e6 - 4 * e3 * e5 * e1 * x3 * e7 ^ 2 * e6 - -8 * e3 * e6 ^ 2 * e7 * y2 * y3 * x1 * e1 - -8 * e3 * e6 ^ 2 * e7 * y2 * y3 * x2 * e1 - -8 * e3 * e5 ^ 2 * e6 * y2 * y3 * x1 * e1 - -8 * e3 * e5 ^ 2 * e6 * y2 * y3 * x2 * e1 - -8 * e3 * e5 ^ 2 * e7 * y2 * y3 * x1 * e1 - -8 * e3 * e5 ^ 2 * e7 * y2 * y3 * x2 * e1 + -16 * e3 * e5 * e6 * y2 ^ 2 * y3 ^ 2 * x1 * e1 + -32 * e3 * e5 * e6 * y2 ^ 2 * y3 ^ 2 * x2 * e1 - -16 * e3 * e5 * e6 ^ 2 * y2 * y3 * x1 * e1 - -16 * e3 * e5 * e6 ^ 2 * y2 * y3 * x2 * e1 - -4 * e3 * x1 ^ 2 * e1 ^ 3 * e6 * e7 * x2 + -8 * e3 * x1 ^ 2 * e1 ^ 3 * y2 ^ 2 * y3 ^ 2 * x2 - -4 * e3 * x2 ^ 3 * e1 ^ 3 * e6 * e7 + -8 * e3 * x2 ^ 3 * e1 ^ 3 * y2 ^ 2 * y3 ^ 2 + 4 * e3 * e6 ^ 3 * e7 * x1 * e1 - -8 * e3 * e1 ^ 3 * x3 ^ 2 * e6 ^ 2 * x1 - -10 * e3 * e1 ^ 3 * x3 ^ 2 * e6 ^ 2 * x2 - -8 * e3 * e1 ^ 3 * x3 ^ 2 * e7 ^ 2 * x1 - -10 * e3 * e1 ^ 3 * x3 ^ 2 * e7 ^ 2 * x2 + 2 * e3 * e6 ^ 2 * e7 ^ 2 * x1 * e1 - -4 * e3 * x1 ^ 2 * e1 ^ 3 * x3 * e6 ^ 2 - -4 * e3 * x1 ^ 2 * e1 ^ 3 * x3 * e7 ^ 2 - -8 * e3 * x2 ^ 2 * e1 ^ 3 * x3 * e6 ^ 2 - -8 * e3 * x2 ^ 2 * e1 ^ 3 * x3 * e7 ^ 2 - 4 * e3 * e6 ^ 3 * e1 * x3 * e7 - -2 * e3 * e6 ^ 2 * e1 * x3 * e7 ^ 2 - 8 * e3 * x2 ^ 2 * e1 ^ 3 * e6 * e7 * x1 + -16 * e3 * x2 ^ 2 * e1 ^ 3 * y2 ^ 2 * y3 ^ 2 * x1 - -28 * e3 * e1 ^ 2 * x3 ^ 2 * e6 * e7 * y1 * y2 - -16 * e3 * e1 ^ 3 * x3 ^ 2 * e6 * e7 * x1 - -20 * e3 * e1 ^ 3 * x3 ^ 2 * e6 * e7 * x2 - -24 * e3 * e1 ^ 2 * x3 ^ 2 * y2 ^ 3 * y3 ^ 2 * y1 - -16 * e3 * e1 ^ 3 * x3 ^ 2 * y2 ^ 2 * y3 ^ 2 * x1 - -8 * e3 * e1 ^ 3 * x3 ^ 2 * y2 ^ 2 * y3 ^ 2 * x2 + -8 * e3 * e6 ^ 2 * y2 ^ 2 * y3 ^ 2 * x1 * e1 + -16 * e3 * e6 ^ 2 * y2 ^ 2 * y3 ^ 2 * x2 * e1 - -8 * e3 * e6 ^ 3 * y2 * y3 * x1 * e1 - 8 * e3 * e6 ^ 3 * y2 * y3 * x2 * e1 + -4 * e3 * e5 ^ 2 * e6 * e7 * x1 * e1 + -8 * e3 * e5 ^ 2 * y2 ^ 2 * y3 ^ 2 * x1 * e1 + -16 * e3 * e5 ^ 2 * y2 ^ 2 * y3 ^ 2 * x2 * e1 + -8 * e3 * e5 * e6 ^ 2 * e7 * x1 * e1 - -14 * e3 * e1 ^ 2 * x3 ^ 2 * e6 ^ 2 * y1 * y2 - -14 * e3 * e1 ^ 2 * x3 ^ 2 * e7 ^ 2 * y1 * y2 + -8 * e3 * e6 ^ 3 * e1 * x3 * y1 * y2 - -16 * e3 * e5 * e6 * e7 * y2 * y3 * x1 * e1 - -16 * e3 * e5 * e6 * e7 * y2 * y3 * x2 * e1 + -40 * e3 * e1 ^ 2 * x3 ^ 2 * e6 * y2 ^ 2 * y3 * y1 + -24 * e3 * e1 ^ 3 * x3 ^ 2 * e6 * y2 * y3 * x1 + -24 * e3 * e1 ^ 3 * x3 ^ 2 * e6 * y2 * y3 * x2 - -12 * e3 * x1 * e1 ^ 2 * x3 * e6 ^ 2 * y1 * y2 - -12 * e3 * x1 * e1 ^ 3 * x3 * e6 ^ 2 * x2 - -12 * e3 * x1 * e1 ^ 2 * x3 * e7 ^ 2 * y1 * y2 - -12 * e3 * x1 * e1 ^ 3 * x3 * e7 ^ 2 * x2 - -20 * e3 * x2 * e1 ^ 2 * x3 * e6 ^ 2 * y1 * y2 - -20 * e3 * x2 * e1 ^ 2 * x3 * e7 ^ 2 * y1 * y2 + -8 * e3 * e5 * e1 * x3 * e6 ^ 2 * y1 * y2 + -8 * e3 * e5 * e1 * x3 * e7 ^ 2 * y1 * y2 + -16 * e3 * y1 * y2 * e1 * x3 * e6 ^ 2 * e7 - -16 * e3 * y1 * y2 ^ 2 * e1 * x3 * e6 ^ 2 * y3 + -12 * e3 * x1 * e1 ^ 2 * x3 * e6 ^ 2 * e7 - -16 * e3 * x1 * e1 ^ 2 * x3 * e6 ^ 2 * y2 * y3 + -20 * e3 * x2 * e1 ^ 2 * x3 * e6 ^ 2 * e7 - -16 * e3 * x2 * e1 ^ 2 * x3 * e6 ^ 2 * y2 * y3 - -4 * e3 * e5 ^ 2 * e1 * x3 * e6 * e7 + -4 * e3 * e5 ^ 2 * e1 * x3 * e6 * y2 * y3 + -8 * e3 * e5 * e1 * x3 * e6 ^ 2 * y2 * y3 + -4 * e3 * e5 ^ 2 * e1 * x3 * e7 * y2 * y3 + -4 * e3 * e6 ^ 3 * e1 * x3 * y2 * y3 + -4 * e3 * e6 ^ 2 * e1 * x3 * e7 * y2 * y3 - -8 * e3 * e6 ^ 2 * e1 * x3 * e7 * e5 - -20 * e3 * e1 ^ 2 * x3 ^ 2 * e7 * y2 * y3 * e5 - -20 * e3 * e1 ^ 2 * x3 ^ 2 * e7 * y2 * y3 * e6 + -16 * e3 * y1 * y2 * e1 * x3 * e6 * e7 * e5 + -8 * e3 * y1 * y2 * e1 * x3 * e7 ^ 2 * e6 - -16 * e3 * y1 * y2 ^ 2 * e1 * x3 * e6 * y3 * e5 - -16 * e3 * y1 * y2 ^ 2 * e1 * x3 * e7 * y3 * e5 - -16 * e3 * y1 * y2 ^ 2 * e1 * x3 * e7 * y3 * e6 + -12 * e3 * x1 * e1 ^ 2 * x3 * e6 * e7 * e5 + -8 * e3 * x1 * e1 ^ 2 * x3 * y2 ^ 2 * y3 ^ 2 * e5 + -8 * e3 * x1 * e1 ^ 2 * x3 * y2 ^ 2 * y3 ^ 2 * e6 - -16 * e3 * x1 * e1 ^ 2 * x3 * e6 * y2 * y3 * e5 - -16 * e3 * x1 * e1 ^ 2 * x3 * e7 * y2 * y3 * e5 - -16 * e3 * x1 * e1 ^ 2 * x3 * e7 * y2 * y3 * e6 + -20 * e3 * x2 * e1 ^ 2 * x3 * e6 * e7 * e5 - -8 * e3 * x2 * e1 ^ 2 * x3 * y2 ^ 2 * y3 ^ 2 * e5 - -8 * e3 * x2 * e1 ^ 2 * x3 * y2 ^ 2 * y3 ^ 2 * e6 - -16 * e3 * x2 * e1 ^ 2 * x3 * e6 * y2 * y3 * e5 - -16 * e3 * x2 * e1 ^ 2 * x3 * e7 * y2 * y3 * e5 - -16 * e3 * x2 * e1 ^ 2 * x3 * e7 * y2 * y3 * e6 + -8 * e3 * e5 * e1 * x3 * e7 * y2 * y3 * e6 + -40 * e3 * e1 ^ 2 * x3 ^ 2 * e7 * y2 ^ 2 * y3 * y1 + -24 * e3 * e1 ^ 3 * x3 ^ 2 * e7 * y2 * y3 * x1 + -24 * e3 * e1 ^ 3 * x3 ^ 2 * e7 * y2 * y3 * x2 - -8 * e3 * y1 ^ 2 * y2 ^ 2 * e1 * x3 * e6 ^ 2 - -16 * e3 * y1 ^ 2 * y2 ^ 2 * e1 * x3 * e6 * e7 - -24 * e3 * y1 * y2 * e1 ^ 2 * x3 * e6 * e7 * x1 - -40 * e3 * y1 * y2 * e1 ^ 2 * x3 * e6 * e7 * x2 - -8 * e3 * y1 ^ 2 * y2 ^ 2 * e1 * x3 * e7 ^ 2 - -16 * e3 * y1 * y2 ^ 3 * e1 ^ 2 * x3 * y3 ^ 2 * x1 + -16 * e3 * y1 * y2 ^ 3 * e1 ^ 2 * x3 * y3 ^ 2 * x2 + -16 * e3 * y1 ^ 2 * y2 ^ 3 * e1 * x3 * e6 * y3 + -32 * e3 * y1 * y2 ^ 2 * e1 ^ 2 * x3 * e6 * y3 * x1 + -32 * e3 * y1 * y2 ^ 2 * e1 ^ 2 * x3 * e6 * y3 * x2 + -16 * e3 * y1 ^ 2 * y2 ^ 3 * e1 * x3 * e7 * y3 + -32 * e3 * y1 * y2 ^ 2 * e1 ^ 2 * x3 * e7 * y3 * x1 + -32 * e3 * y1 * y2 ^ 2 * e1 ^ 2 * x3 * e7 * y3 * x2 - -8 * e3 * x1 ^ 2 * e1 ^ 3 * x3 * e6 * e7 - -24 * e3 * x1 * e1 ^ 3 * x3 * e6 * e7 * x2 - -8 * e3 * x1 ^ 2 * e1 ^ 3 * x3 * y2 ^ 2 * y3 ^ 2 + -12 * e3 * x1 ^ 2 * e1 ^ 3 * x3 * e6 * y2 * y3 + -24 * e3 * x1 * e1 ^ 3 * x3 * e6 * y2 * y3 * x2 + -12 * e3 * x1 ^ 2 * e1 ^ 3 * x3 * e7 * y2 * y3 + -24 * e3 * x1 * e1 ^ 3 * x3 * e7 * y2 * y3 * x2 - -16 * e3 * x2 ^ 2 * e1 ^ 3 * x3 * e6 * e7 + -8 * e3 * x2 ^ 2 * e1 ^ 3 * x3 * y2 ^ 2 * y3 ^ 2 + -12 * e3 * x2 ^ 2 * e1 ^ 3 * x3 * e6 * y2 * y3 + -12 * e3 * x2 ^ 2 * e1 ^ 3 * x3 * e7 * y2 * y3 - 2 * x3 ^ 5 * e1 ^ 3 * e3 ^ 3 - -4 * x3 ^ 3 * e1 ^ 3 * e3 * e6 ^ 2 - 4 * x3 ^ 3 * e1 ^ 3 * e3 * e7 ^ 2 + -5 * x3 ^ 4 * e1 ^ 3 * e3 ^ 2 * e6 + 5 * x3 ^ 4 * e1 ^ 3 * e3 ^ 2 * e7 - -8 * x3 ^ 3 * e1 ^ 3 * e3 * e6 * e7 - -8 * x3 ^ 3 * e1 ^ 3 * e3 * y2 ^ 2 * y3 ^ 2 - -8 * x3 ^ 4 * e1 ^ 3 * e3 ^ 2 * y2 * y3 + -12 * x3 ^ 3 * e1 ^ 3 * e3 * e6 * y2 * y3 + -12 * x3 ^ 3 * e1 ^ 3 * e3 * e7 * y2 * y3 - -8 * y2 ^ 3 * y3 * x2 * e3 * x1 ^ 2 * e1 ^ 3 - -e6 ^ 2 * y2 ^ 2 * x1 ^ 2 * e1 ^ 3 - e6 ^ 2 * y2 ^ 2 * x2 ^ 2 * e1 ^ 3 - -e7 ^ 2 * y2 ^ 2 * x1 ^ 2 * e1 ^ 3 - e7 ^ 2 * y2 ^ 2 * x2 ^ 2 * e1 ^ 3 - -4 * y2 ^ 4 * y3 ^ 2 * x1 ^ 2 * e1 ^ 3 - 4 * y2 ^ 4 * y3 ^ 2 * x2 ^ 2 * e1 ^ 3 - -4 * x2 ^ 4 * e3 ^ 2 * y2 ^ 2 * e1 ^ 3 + 2 * e6 ^ 3 * y2 ^ 2 * x1 * e1 ^ 2 + -2 * e6 ^ 3 * y2 ^ 2 * x2 * e1 ^ 2 - y2 ^ 2 * e7 ^ 2 * e1 ^ 3 * x3 ^ 2 - -4 * y2 ^ 4 * y3 ^ 2 * e1 ^ 3 * x3 ^ 2 - y3 ^ 2 * e6 ^ 2 * x1 ^ 2 * e1 ^ 3 - -y3 ^ 2 * e6 ^ 2 * x2 ^ 2 * e1 ^ 3 - y3 ^ 2 * e6 ^ 2 * e1 ^ 3 * x3 ^ 2 - -y3 ^ 2 * e7 ^ 2 * x1 ^ 2 * e1 ^ 3 - y3 ^ 2 * e7 ^ 2 * x2 ^ 2 * e1 ^ 3 - -y3 ^ 2 * e7 ^ 2 * e1 ^ 3 * x3 ^ 2 - 4 * y2 ^ 2 * y3 ^ 4 * x1 ^ 2 * e1 ^ 3 - -4 * y2 ^ 2 * y3 ^ 4 * x2 ^ 2 * e1 ^ 3 - 4 * y2 ^ 2 * y3 ^ 4 * e1 ^ 3 * x3 ^ 2 - -e4 ^ 2 * y2 ^ 2 * x1 ^ 2 * e1 ^ 3 - e4 ^ 2 * y2 ^ 2 * x2 ^ 2 * e1 ^ 3 - -e4 ^ 2 * y2 ^ 2 * e1 ^ 3 * x3 ^ 2 - e4 ^ 2 * y1 ^ 2 * x1 ^ 2 * e1 ^ 3 - -e4 ^ 2 * y1 ^ 2 * x2 ^ 2 * e1 ^ 3 - e4 ^ 2 * y1 ^ 2 * e1 ^ 3 * x3 ^ 2 - -y2 ^ 2 * x3 ^ 4 * e3 ^ 2 * e1 ^ 3 - 4 * y3 ^ 2 * x2 ^ 4 * e3 ^ 2 * e1 ^ 3 - -y3 ^ 2 * x3 ^ 4 * e3 ^ 2 * e1 ^ 3 + 2 * y2 ^ 2 * e6 ^ 3 * e1 ^ 2 * x3 + -2 * y3 ^ 2 * e6 ^ 3 * x1 * e1 ^ 2 + 2 * y3 ^ 2 * e6 ^ 3 * x2 * e1 ^ 2 + -2 * y3 ^ 2 * e6 ^ 3 * e1 ^ 2 * x3 - 2 * e1 * e6 ^ 3 * y2 ^ 2 * e5 + -4 * e1 * e6 ^ 3 * y2 ^ 3 * y1 - e1 * e6 ^ 2 * y2 ^ 2 * e5 ^ 2 - -4 * e1 * e6 ^ 2 * y1 ^ 2 * y2 ^ 4 - 2 * e1 * e6 ^ 3 * e7 * y2 ^ 2 - -e1 * e7 ^ 2 * y2 ^ 2 * e5 ^ 2 - e1 * e7 ^ 2 * y2 ^ 2 * e6 ^ 2 - -4 * e1 * e7 ^ 2 * y1 ^ 2 * y2 ^ 4 - 4 * e1 * y2 ^ 4 * y3 ^ 2 * e5 ^ 2 - -4 * e1 * y2 ^ 4 * y3 ^ 2 * e6 ^ 2 - 16 * e1 * y2 ^ 6 * y3 ^ 2 * y1 ^ 2 + -4 * e1 * e6 ^ 3 * y2 ^ 3 * y3 - 8 * e1 * e4 ^ 2 * y2 ^ 3 * y1 ^ 3 + -4 * e1 * e6 ^ 3 * y2 ^ 2 * y3 ^ 2 - 4 * e1 * e6 ^ 4 * y2 * y3 - -e1 * y3 ^ 2 * e6 ^ 2 * e5 ^ 2 - 2 * e1 * y3 ^ 2 * e6 ^ 3 * e5 - -e1 * y3 ^ 2 * e7 ^ 2 * e6 ^ 2 - e1 * y3 ^ 2 * e7 ^ 2 * e5 ^ 2 - -4 * e1 * y2 ^ 2 * y3 ^ 4 * e6 ^ 2 - 4 * e1 * y2 ^ 2 * y3 ^ 4 * e5 ^ 2 - -8 * y2 ^ 3 * y3 * x2 ^ 3 * e3 * e1 ^ 3 - e1 * e6 ^ 4 * y2 ^ 2 - -4 * y2 ^ 3 * y3 * x3 * e3 * x1 ^ 2 * e1 ^ 3 - -20 * y2 ^ 3 * y3 * x3 * e3 * x2 ^ 2 * e1 ^ 3 - -16 * y2 ^ 3 * y3 * e3 * x1 * x2 ^ 2 * e1 ^ 3 - -2 * e6 * e7 * y2 ^ 2 * x1 ^ 2 * e1 ^ 3 - -2 * e6 * e7 * y2 ^ 2 * x2 ^ 2 * e1 ^ 3 - -4 * x2 ^ 2 * e3 ^ 2 * y2 ^ 2 * x1 ^ 2 * e1 ^ 3 - -x3 ^ 2 * e3 ^ 2 * y2 ^ 2 * x1 ^ 2 * e1 ^ 3 - -13 * x3 ^ 2 * e3 ^ 2 * y2 ^ 2 * x2 ^ 2 * e1 ^ 3 + -16 * y2 ^ 3 * y3 * x2 * e3 * e5 * x1 * e1 ^ 2 + -16 * y2 ^ 3 * y3 * x2 ^ 2 * e3 * e5 * e1 ^ 2 + -2 * e6 ^ 2 * y2 ^ 2 * e5 * x1 * e1 ^ 2 - -32 * y2 ^ 4 * y3 * x2 * e3 * y1 * x1 * e1 ^ 2 - -32 * y2 ^ 4 * y3 * x2 ^ 2 * e3 * y1 * e1 ^ 2 + -8 * y2 ^ 3 * y3 * x3 * e3 * e5 * x1 * e1 ^ 2 + -24 * y2 ^ 3 * y3 * x3 * e3 * e5 * x2 * e1 ^ 2 + -8 * y2 ^ 3 * y3 * x3 * e3 * e6 * x1 * e1 ^ 2 + -24 * y2 ^ 3 * y3 * x3 * e3 * e6 * x2 * e1 ^ 2 - -16 * y2 ^ 4 * y3 * x3 * e3 * y1 * x1 * e1 ^ 2 - -48 * y2 ^ 4 * y3 * x3 * e3 * y1 * x2 * e1 ^ 2 - -24 * y2 ^ 3 * y3 * x3 * e3 * x1 * e1 ^ 3 * x2 + -2 * e6 ^ 2 * y2 ^ 2 * e5 * x2 * e1 ^ 2 - -4 * e6 ^ 2 * y1 * y2 ^ 3 * x1 * e1 ^ 2 - -4 * e6 ^ 2 * y1 * y2 ^ 3 * x2 * e1 ^ 2 - -2 * e6 ^ 2 * y2 ^ 2 * x1 * e1 ^ 3 * x2 + -4 * e6 * e7 * y2 ^ 2 * e5 * x1 * e1 ^ 2 + -4 * e6 * e7 * y2 ^ 2 * e5 * x2 * e1 ^ 2 + -4 * e6 ^ 2 * e7 * y2 ^ 2 * x1 * e1 ^ 2 + -4 * e6 ^ 2 * e7 * y2 ^ 2 * x2 * e1 ^ 2 - -8 * e6 * e7 * y1 * y2 ^ 3 * x1 * e1 ^ 2 - -8 * e6 * e7 * y1 * y2 ^ 3 * x2 * e1 ^ 2 - -4 * e6 * e7 * y2 ^ 2 * x1 * e1 ^ 3 * x2 + -2 * e7 ^ 2 * y2 ^ 2 * e5 * x1 * e1 ^ 2 + -2 * e7 ^ 2 * y2 ^ 2 * e5 * x2 * e1 ^ 2 + -2 * e7 ^ 2 * y2 ^ 2 * e6 * x1 * e1 ^ 2 + -2 * e7 ^ 2 * y2 ^ 2 * e6 * x2 * e1 ^ 2 - y2 ^ 2 * e6 ^ 2 * e1 ^ 3 * x3 ^ 2 - -4 * e7 ^ 2 * y1 * y2 ^ 3 * x1 * e1 ^ 2 - -4 * e7 ^ 2 * y1 * y2 ^ 3 * x2 * e1 ^ 2 - -2 * e7 ^ 2 * y2 ^ 2 * x1 * e1 ^ 3 * x2 + -16 * y2 ^ 3 * y3 ^ 2 * y1 * e6 * x1 * e1 ^ 2 + -16 * y2 ^ 3 * y3 ^ 2 * y1 * e6 * x2 * e1 ^ 2 + -8 * y2 ^ 4 * y3 ^ 2 * e5 * x1 * e1 ^ 2 + -8 * y2 ^ 4 * y3 ^ 2 * e5 * x2 * e1 ^ 2 + -8 * y2 ^ 4 * y3 ^ 2 * e6 * x1 * e1 ^ 2 + -8 * y2 ^ 4 * y3 ^ 2 * e6 * x2 * e1 ^ 2 - -16 * y2 ^ 5 * y3 ^ 2 * y1 * x1 * e1 ^ 2 - -16 * y2 ^ 5 * y3 ^ 2 * y1 * x2 * e1 ^ 2 - -8 * y2 ^ 4 * y3 ^ 2 * x1 * e1 ^ 3 * x2 + -8 * x2 ^ 2 * e3 ^ 2 * y2 ^ 2 * e5 * x1 * e1 ^ 2 + -8 * x2 ^ 3 * e3 ^ 2 * y2 ^ 2 * e5 * e1 ^ 2 - -16 * x2 ^ 2 * e3 ^ 2 * y1 * y2 ^ 3 * x1 * e1 ^ 2 - -16 * x2 ^ 3 * e3 ^ 2 * y1 * y2 ^ 3 * e1 ^ 2 - -8 * x2 ^ 3 * e3 ^ 2 * y2 ^ 2 * x1 * e1 ^ 3 + -2 * x3 ^ 2 * e3 ^ 2 * y2 ^ 2 * e5 * x1 * e1 ^ 2 + -10 * x3 ^ 2 * e3 ^ 2 * y2 ^ 2 * e5 * x2 * e1 ^ 2 + -2 * x3 ^ 2 * e3 ^ 2 * y2 ^ 2 * e6 * x1 * e1 ^ 2 + -10 * x3 ^ 2 * e3 ^ 2 * y2 ^ 2 * e6 * x2 * e1 ^ 2 - -4 * x3 ^ 2 * e3 ^ 2 * y1 * y2 ^ 3 * x1 * e1 ^ 2 - -20 * x3 ^ 2 * e3 ^ 2 * y1 * y2 ^ 3 * x2 * e1 ^ 2 - -10 * x3 ^ 2 * e3 ^ 2 * y2 ^ 2 * x1 * e1 ^ 3 * x2 - -4 * x2 * e3 ^ 2 * x3 * y2 ^ 2 * x1 ^ 2 * e1 ^ 3 - -12 * x2 ^ 3 * e3 ^ 2 * x3 * y2 ^ 2 * e1 ^ 3 - -16 * x3 * e3 ^ 2 * x1 * y2 ^ 2 * x2 ^ 2 * e1 ^ 3 + -4 * e6 * y2 ^ 3 * y3 * x1 ^ 2 * e1 ^ 3 + -4 * e6 * y2 ^ 3 * y3 * x2 ^ 2 * e1 ^ 3 + -4 * e6 * x2 * e3 * y2 ^ 2 * x1 ^ 2 * e1 ^ 3 + -4 * e6 * x2 ^ 3 * e3 * y2 ^ 2 * e1 ^ 3 + -2 * e6 * x3 * e3 * y2 ^ 2 * x1 ^ 2 * e1 ^ 3 + -10 * e6 * x3 * e3 * y2 ^ 2 * x2 ^ 2 * e1 ^ 3 + -8 * e6 * e3 * x1 * y2 ^ 2 * x2 ^ 2 * e1 ^ 3 + -4 * e7 * y2 ^ 3 * y3 * x1 ^ 2 * e1 ^ 3 + -4 * e7 * y2 ^ 3 * y3 * x2 ^ 2 * e1 ^ 3 + -4 * e7 * x2 * e3 * y2 ^ 2 * x1 ^ 2 * e1 ^ 3 + -4 * e7 * x2 ^ 3 * e3 * y2 ^ 2 * e1 ^ 3 + -2 * e7 * x3 * e3 * y2 ^ 2 * x1 ^ 2 * e1 ^ 3 + -10 * e7 * x3 * e3 * y2 ^ 2 * x2 ^ 2 * e1 ^ 3 + -8 * e7 * e3 * x1 * y2 ^ 2 * x2 ^ 2 * e1 ^ 3 + -8 * x2 * e3 ^ 2 * x3 * y2 ^ 2 * e5 * x1 * e1 ^ 2 + -16 * x2 ^ 2 * e3 ^ 2 * x3 * y2 ^ 2 * e5 * e1 ^ 2 - -16 * x2 * e3 ^ 2 * x3 * y1 * y2 ^ 3 * x1 * e1 ^ 2 - -32 * x2 ^ 2 * e3 ^ 2 * x3 * y1 * y2 ^ 3 * e1 ^ 2 - -16 * e6 ^ 2 * y2 ^ 2 * y3 * y1 * x1 * e1 ^ 2 - -16 * e6 ^ 2 * y2 ^ 2 * y3 * y1 * x2 * e1 ^ 2 - -8 * e6 * y2 ^ 3 * y3 * e5 * x1 * e1 ^ 2 - -8 * e6 * y2 ^ 3 * y3 * e5 * x2 * e1 ^ 2 - -8 * e6 ^ 2 * y2 ^ 3 * y3 * x1 * e1 ^ 2 - -8 * e6 ^ 2 * y2 ^ 3 * y3 * x2 * e1 ^ 2 + -16 * e6 * y2 ^ 4 * y3 * y1 * x1 * e1 ^ 2 + -16 * e6 * y2 ^ 4 * y3 * y1 * x2 * e1 ^ 2 + -8 * e6 * y2 ^ 3 * y3 * x1 * e1 ^ 3 * x2 - -8 * e6 * x2 * e3 * y2 ^ 2 * e5 * x1 * e1 ^ 2 - -8 * e6 * x2 ^ 2 * e3 * y2 ^ 2 * e5 * e1 ^ 2 + -16 * e6 * x2 * e3 * y1 * y2 ^ 3 * x1 * e1 ^ 2 + -16 * e6 * x2 ^ 2 * e3 * y1 * y2 ^ 3 * e1 ^ 2 - -4 * e6 * x3 * e3 * y2 ^ 2 * e5 * x1 * e1 ^ 2 - -12 * e6 * x3 * e3 * y2 ^ 2 * e5 * x2 * e1 ^ 2 - -4 * e6 ^ 2 * x3 * e3 * y2 ^ 2 * x1 * e1 ^ 2 - -12 * e6 ^ 2 * x3 * e3 * y2 ^ 2 * x2 * e1 ^ 2 + -8 * e6 * x3 * e3 * y1 * y2 ^ 3 * x1 * e1 ^ 2 + -24 * e6 * x3 * e3 * y1 * y2 ^ 3 * x2 * e1 ^ 2 + -12 * e6 * x3 * e3 * y2 ^ 2 * x1 * e1 ^ 3 * x2 - -32 * e7 * y2 ^ 2 * y3 * y1 * e6 * x1 * e1 ^ 2 - -32 * e7 * y2 ^ 2 * y3 * y1 * e6 * x2 * e1 ^ 2 - -8 * e7 * y2 ^ 3 * y3 * e5 * x1 * e1 ^ 2 - -8 * e7 * y2 ^ 3 * y3 * e5 * x2 * e1 ^ 2 - -8 * e7 * y2 ^ 3 * y3 * e6 * x1 * e1 ^ 2 - -8 * e7 * y2 ^ 3 * y3 * e6 * x2 * e1 ^ 2 + -16 * e7 * y2 ^ 4 * y3 * y1 * x1 * e1 ^ 2 + -16 * e7 * y2 ^ 4 * y3 * y1 * x2 * e1 ^ 2 + -8 * e7 * y2 ^ 3 * y3 * x1 * e1 ^ 3 * x2 - -8 * e7 * x2 * e3 * y2 ^ 2 * e5 * x1 * e1 ^ 2 - -8 * e7 * x2 ^ 2 * e3 * y2 ^ 2 * e5 * e1 ^ 2 + -16 * e7 * x2 * e3 * y1 * y2 ^ 3 * x1 * e1 ^ 2 + -16 * e7 * x2 ^ 2 * e3 * y1 * y2 ^ 3 * e1 ^ 2 - -4 * e7 * x3 * e3 * y2 ^ 2 * e5 * x1 * e1 ^ 2 - -12 * e7 * x3 * e3 * y2 ^ 2 * e5 * x2 * e1 ^ 2 - -4 * e7 * x3 * e3 * y2 ^ 2 * e6 * x1 * e1 ^ 2 - -12 * e7 * x3 * e3 * y2 ^ 2 * e6 * x2 * e1 ^ 2 + -8 * e7 * x3 * e3 * y1 * y2 ^ 3 * x1 * e1 ^ 2 + -24 * e7 * x3 * e3 * y1 * y2 ^ 3 * x2 * e1 ^ 2 + -12 * e7 * x3 * e3 * y2 ^ 2 * x1 * e1 ^ 3 * x2 - -8 * x1 * e1 ^ 3 * x2 * e6 ^ 2 * y2 * y3 - -4 * x1 ^ 2 * e1 ^ 3 * e6 ^ 2 * y2 * y3 - -4 * x2 ^ 2 * e1 ^ 3 * e6 ^ 2 * y2 * y3 - -4 * e1 ^ 3 * x3 ^ 2 * e6 ^ 2 * y2 * y3 + -4 * x1 ^ 2 * e1 ^ 3 * y2 ^ 2 * y3 ^ 2 * e6 + -4 * x2 ^ 2 * e1 ^ 3 * y2 ^ 2 * y3 ^ 2 * e6 + -4 * e1 ^ 3 * x3 ^ 2 * y2 ^ 2 * y3 ^ 2 * e6 + -8 * x1 * e1 ^ 3 * x2 * y2 ^ 2 * y3 ^ 2 * e6 - -16 * x1 * e1 ^ 3 * x2 * e7 * y2 * y3 * e6 - -8 * x1 ^ 2 * e1 ^ 3 * e7 * y2 * y3 * e6 - -8 * x2 ^ 2 * e1 ^ 3 * e7 * y2 * y3 * e6 + -16 * e6 ^ 2 * e7 * y2 * y3 * x1 * e1 ^ 2 + -16 * e6 ^ 2 * e7 * y2 * y3 * x2 * e1 ^ 2 - -8 * e5 * e6 * y2 ^ 2 * y3 ^ 2 * x1 * e1 ^ 2 - -8 * e5 * e6 * y2 ^ 2 * y3 ^ 2 * x2 * e1 ^ 2 + -8 * e5 * e6 ^ 2 * y2 * y3 * x1 * e1 ^ 2 + -8 * e5 * e6 ^ 2 * y2 * y3 * x2 * e1 ^ 2 - -8 * e6 ^ 2 * y2 ^ 2 * y3 ^ 2 * x1 * e1 ^ 2 - -8 * e6 ^ 2 * y2 ^ 2 * y3 ^ 2 * x2 * e1 ^ 2 + -8 * e6 ^ 3 * y2 * y3 * x1 * e1 ^ 2 + 8 * e6 ^ 3 * y2 * y3 * x2 * e1 ^ 2 + -16 * e5 * e6 * e7 * y2 * y3 * x1 * e1 ^ 2 + -16 * e5 * e6 * e7 * y2 * y3 * x2 * e1 ^ 2 - -16 * y1 * y2 ^ 2 * e1 ^ 2 * x3 * e6 ^ 2 * y3 - -8 * x1 * e1 ^ 3 * x3 * e6 ^ 2 * y2 * y3 - -8 * x2 * e1 ^ 3 * x3 * e6 ^ 2 * y2 * y3 + -8 * e5 * e1 ^ 2 * x3 * e6 ^ 2 * y2 * y3 - -8 * e6 ^ 2 * e1 ^ 2 * x3 * y2 ^ 2 * y3 ^ 2 + -8 * e6 ^ 3 * e1 ^ 2 * x3 * y2 * y3 + 16 * e6 ^ 2 * e1 ^ 2 * x3 * e7 * y2 * y3 - -8 * e1 ^ 3 * x3 ^ 2 * e7 * y2 * y3 * e6 + -16 * y1 * y2 ^ 3 * e1 ^ 2 * x3 * y3 ^ 2 * e6 - -32 * y1 * y2 ^ 2 * e1 ^ 2 * x3 * e7 * y3 * e6 + -8 * x1 * e1 ^ 3 * x3 * y2 ^ 2 * y3 ^ 2 * e6 - -16 * x1 * e1 ^ 3 * x3 * e7 * y2 * y3 * e6 + -8 * x2 * e1 ^ 3 * x3 * y2 ^ 2 * y3 ^ 2 * e6 - -16 * x2 * e1 ^ 3 * x3 * e7 * y2 * y3 * e6 - -8 * e5 * e1 ^ 2 * x3 * y2 ^ 2 * y3 ^ 2 * e6 + -16 * e5 * e1 ^ 2 * x3 * e7 * y2 * y3 * e6 - -2 * y3 ^ 2 * e6 ^ 2 * x1 * e1 ^ 3 * x2 - -4 * y3 ^ 2 * e6 ^ 2 * y1 * y2 * x1 * e1 ^ 2 - -4 * y3 ^ 2 * e6 ^ 2 * y1 * y2 * x2 * e1 ^ 2 - -2 * y3 ^ 2 * e7 ^ 2 * x1 * e1 ^ 3 * x2 - -4 * y3 ^ 2 * e7 ^ 2 * y1 * y2 * x1 * e1 ^ 2 - -4 * y3 ^ 2 * e7 ^ 2 * y1 * y2 * x2 * e1 ^ 2 - -8 * y2 ^ 2 * y3 ^ 4 * x1 * e1 ^ 3 * x2 - -16 * y2 ^ 3 * y3 ^ 4 * y1 * x1 * e1 ^ 2 - -16 * y2 ^ 3 * y3 ^ 4 * y1 * x2 * e1 ^ 2 - -2 * e4 ^ 2 * y2 ^ 2 * x1 * e1 ^ 3 * x2 - -4 * e4 ^ 2 * y2 ^ 3 * y1 * x1 * e1 ^ 2 - -4 * e4 ^ 2 * y2 ^ 3 * y1 * x2 * e1 ^ 2 - -2 * e4 ^ 2 * y1 ^ 2 * x1 * e1 ^ 3 * x2 - -4 * e4 ^ 2 * y1 ^ 3 * y2 * x1 * e1 ^ 2 - -4 * e4 ^ 2 * y1 ^ 3 * y2 * x2 * e1 ^ 2 - -2 * y2 ^ 2 * e6 * e7 * e1 ^ 3 * x3 ^ 2 + -4 * y2 ^ 3 * e6 * y3 * e1 ^ 3 * x3 ^ 2 - -4 * y2 ^ 2 * e6 * e4 * x1 * e1 ^ 3 * x2 - -2 * y2 ^ 2 * e6 * e4 * x1 ^ 2 * e1 ^ 3 - -2 * y2 ^ 2 * e6 * e4 * x2 ^ 2 * e1 ^ 3 - -2 * y2 ^ 2 * e6 * e4 * e1 ^ 3 * x3 ^ 2 - -8 * y2 ^ 3 * e6 * e4 * y1 * x1 * e1 ^ 2 - -8 * y2 ^ 3 * e6 * e4 * y1 * x2 * e1 ^ 2 + -4 * y2 ^ 3 * e7 * y3 * e1 ^ 3 * x3 ^ 2 - -8 * y2 * e7 ^ 2 * y3 * x1 * e1 ^ 3 * x2 - -4 * y2 * e7 ^ 2 * y3 * x1 ^ 2 * e1 ^ 3 - -4 * y2 * e7 ^ 2 * y3 * x2 ^ 2 * e1 ^ 3 - -4 * y2 * e7 ^ 2 * y3 * e1 ^ 3 * x3 ^ 2 - -16 * y2 ^ 2 * e7 ^ 2 * y3 * y1 * x1 * e1 ^ 2 - -16 * y2 ^ 2 * e7 ^ 2 * y3 * y1 * x2 * e1 ^ 2 + -8 * y2 ^ 2 * e7 * y3 ^ 2 * x1 * e1 ^ 3 * x2 + -4 * y2 ^ 2 * e7 * y3 ^ 2 * x1 ^ 2 * e1 ^ 3 + -4 * y2 ^ 2 * e7 * y3 ^ 2 * x2 ^ 2 * e1 ^ 3 + -4 * y2 ^ 2 * e7 * y3 ^ 2 * e1 ^ 3 * x3 ^ 2 + -16 * y2 ^ 3 * e7 * y3 ^ 2 * y1 * x1 * e1 ^ 2 + -16 * y2 ^ 3 * e7 * y3 ^ 2 * y1 * x2 * e1 ^ 2 - -4 * y2 ^ 2 * e7 * e4 * x1 * e1 ^ 3 * x2 - -2 * y2 ^ 2 * e7 * e4 * x1 ^ 2 * e1 ^ 3 - -2 * y2 ^ 2 * e7 * e4 * x2 ^ 2 * e1 ^ 3 - -2 * y2 ^ 2 * e7 * e4 * e1 ^ 3 * x3 ^ 2 - -8 * y2 ^ 3 * e7 * e4 * y1 * x1 * e1 ^ 2 - -8 * y2 ^ 3 * e7 * e4 * y1 * x2 * e1 ^ 2 + -8 * y2 ^ 3 * y3 * e4 * x1 * e1 ^ 3 * x2 + -4 * y2 ^ 3 * y3 * e4 * x1 ^ 2 * e1 ^ 3 + -4 * y2 ^ 3 * y3 * e4 * x2 ^ 2 * e1 ^ 3 + -4 * y2 ^ 3 * y3 * e4 * e1 ^ 3 * x3 ^ 2 + -16 * y2 ^ 4 * y3 * e4 * y1 * x1 * e1 ^ 2 + -16 * y2 ^ 4 * y3 * e4 * y1 * x2 * e1 ^ 2 - -4 * y3 ^ 2 * e6 * e7 * x1 * e1 ^ 3 * x2 - -2 * y3 ^ 2 * e6 * e7 * x1 ^ 2 * e1 ^ 3 - -2 * y3 ^ 2 * e6 * e7 * x2 ^ 2 * e1 ^ 3 - -2 * y3 ^ 2 * e6 * e7 * e1 ^ 3 * x3 ^ 2 - -8 * y3 ^ 2 * e6 * e7 * y1 * y2 * x1 * e1 ^ 2 - -8 * y3 ^ 2 * e6 * e7 * y1 * y2 * x2 * e1 ^ 2 + -8 * y3 ^ 3 * e6 * y2 * x1 * e1 ^ 3 * x2 + -4 * y3 ^ 3 * e6 * y2 * x1 ^ 2 * e1 ^ 3 + -4 * y3 ^ 3 * e6 * y2 * x2 ^ 2 * e1 ^ 3 + -4 * y3 ^ 3 * e6 * y2 * e1 ^ 3 * x3 ^ 2 + -16 * y3 ^ 3 * e6 * y2 ^ 2 * y1 * x1 * e1 ^ 2 + -16 * y3 ^ 3 * e6 * y2 ^ 2 * y1 * x2 * e1 ^ 2 + -8 * y3 ^ 3 * e7 * y2 * x1 * e1 ^ 3 * x2 + -4 * y3 ^ 3 * e7 * y2 * x1 ^ 2 * e1 ^ 3 + -4 * y3 ^ 3 * e7 * y2 * x2 ^ 2 * e1 ^ 3 + -4 * y3 ^ 3 * e7 * y2 * e1 ^ 3 * x3 ^ 2 + -16 * y3 ^ 3 * e7 * y2 ^ 2 * y1 * x1 * e1 ^ 2 + -16 * y3 ^ 3 * e7 * y2 ^ 2 * y1 * x2 * e1 ^ 2 - -8 * y2 ^ 2 * y3 ^ 2 * e4 * x1 * e1 ^ 3 * x2 - -4 * y2 ^ 2 * y3 ^ 2 * e4 * x1 ^ 2 * e1 ^ 3 - -4 * y2 ^ 2 * y3 ^ 2 * e4 * x2 ^ 2 * e1 ^ 3 - -4 * y2 ^ 2 * y3 ^ 2 * e4 * e1 ^ 3 * x3 ^ 2 - -16 * y2 ^ 3 * y3 ^ 2 * e4 * y1 * x1 * e1 ^ 2 - -16 * y2 ^ 3 * y3 ^ 2 * e4 * y1 * x2 * e1 ^ 2 - -8 * y3 ^ 2 * x2 ^ 3 * e3 ^ 2 * x1 * e1 ^ 3 - -4 * y3 ^ 2 * x2 ^ 2 * e3 ^ 2 * x1 ^ 2 * e1 ^ 3 - -13 * y3 ^ 2 * x2 ^ 2 * e3 ^ 2 * e1 ^ 3 * x3 ^ 2 - -16 * y3 ^ 2 * x2 ^ 2 * e3 ^ 2 * y1 * y2 * x1 * e1 ^ 2 - -16 * y3 ^ 2 * x2 ^ 3 * e3 ^ 2 * y1 * y2 * e1 ^ 2 - -10 * y3 ^ 2 * x3 ^ 2 * e3 ^ 2 * x1 * e1 ^ 3 * x2 - -y3 ^ 2 * x3 ^ 2 * e3 ^ 2 * x1 ^ 2 * e1 ^ 3 - -4 * y3 ^ 2 * x3 ^ 2 * e3 ^ 2 * y1 * y2 * x1 * e1 ^ 2 - -20 * y3 ^ 2 * x3 ^ 2 * e3 ^ 2 * y1 * y2 * x2 * e1 ^ 2 + -8 * y2 ^ 2 * e6 * x2 * e3 * e1 ^ 3 * x3 ^ 2 + -2 * y2 ^ 2 * e6 * x3 ^ 3 * e3 * e1 ^ 3 - -4 * y2 * e6 * e4 * y1 * x1 * e1 ^ 3 * x2 - -2 * y2 * e6 * e4 * y1 * x1 ^ 2 * e1 ^ 3 - -2 * y2 * e6 * e4 * y1 * x2 ^ 2 * e1 ^ 3 - -2 * y2 * e6 * e4 * y1 * e1 ^ 3 * x3 ^ 2 - -8 * y2 ^ 2 * e6 * e4 * y1 ^ 2 * x1 * e1 ^ 2 - -8 * y2 ^ 2 * e6 * e4 * y1 ^ 2 * x2 * e1 ^ 2 + -8 * y2 ^ 2 * e7 * x2 * e3 * e1 ^ 3 * x3 ^ 2 + -2 * y2 ^ 2 * e7 * x3 ^ 3 * e3 * e1 ^ 3 - -4 * y2 * e7 * e4 * y1 * x1 * e1 ^ 3 * x2 - -2 * y2 * e7 * e4 * y1 * x1 ^ 2 * e1 ^ 3 - -2 * y2 * e7 * e4 * y1 * x2 ^ 2 * e1 ^ 3 - -2 * y2 * e7 * e4 * y1 * e1 ^ 3 * x3 ^ 2 - -8 * y2 ^ 2 * e7 * e4 * y1 ^ 2 * x1 * e1 ^ 2 - -8 * y2 ^ 2 * e7 * e4 * y1 ^ 2 * x2 * e1 ^ 2 - -4 * y2 ^ 3 * e6 ^ 2 * y1 * e1 ^ 2 * x3 - -2 * y2 ^ 2 * e6 ^ 2 * x1 * e1 ^ 3 * x3 - -2 * y2 ^ 2 * e6 ^ 2 * x2 * e1 ^ 3 * x3 + -2 * y2 ^ 2 * e6 ^ 2 * e5 * e1 ^ 2 * x3 - -4 * y2 ^ 3 * e7 ^ 2 * y1 * e1 ^ 2 * x3 - -2 * y2 ^ 2 * e7 ^ 2 * x1 * e1 ^ 3 * x3 - -2 * y2 ^ 2 * e7 ^ 2 * x2 * e1 ^ 3 * x3 + -2 * y2 ^ 2 * e7 ^ 2 * e5 * e1 ^ 2 * x3 + -2 * y2 ^ 2 * e7 ^ 2 * e6 * e1 ^ 2 * x3 - -16 * y2 ^ 5 * y3 ^ 2 * y1 * e1 ^ 2 * x3 - -8 * y2 ^ 4 * y3 ^ 2 * x1 * e1 ^ 3 * x3 - -8 * y2 ^ 4 * y3 ^ 2 * x2 * e1 ^ 3 * x3 + -8 * y2 ^ 4 * y3 ^ 2 * e5 * e1 ^ 2 * x3 + -8 * y2 ^ 4 * y3 ^ 2 * e6 * e1 ^ 2 * x3 - -4 * y3 ^ 2 * e6 ^ 2 * y1 * y2 * e1 ^ 2 * x3 - -2 * y3 ^ 2 * e6 ^ 2 * x1 * e1 ^ 3 * x3 - -2 * y3 ^ 2 * e6 ^ 2 * x2 * e1 ^ 3 * x3 + -2 * y3 ^ 2 * e6 ^ 2 * e5 * x1 * e1 ^ 2 + -2 * y3 ^ 2 * e6 ^ 2 * e5 * x2 * e1 ^ 2 + -2 * y3 ^ 2 * e6 ^ 2 * e5 * e1 ^ 2 * x3 - -4 * y3 ^ 2 * e7 ^ 2 * y1 * y2 * e1 ^ 2 * x3 - -2 * y3 ^ 2 * e7 ^ 2 * x1 * e1 ^ 3 * x3 - -2 * y3 ^ 2 * e7 ^ 2 * x2 * e1 ^ 3 * x3 + -2 * y3 ^ 2 * e7 ^ 2 * e5 * x1 * e1 ^ 2 + -2 * y3 ^ 2 * e7 ^ 2 * e5 * x2 * e1 ^ 2 + -2 * y3 ^ 2 * e7 ^ 2 * e5 * e1 ^ 2 * x3 + -2 * y3 ^ 2 * e7 ^ 2 * e6 * x1 * e1 ^ 2 + -2 * y3 ^ 2 * e7 ^ 2 * e6 * x2 * e1 ^ 2 + -2 * y3 ^ 2 * e7 ^ 2 * e6 * e1 ^ 2 * x3 - -16 * y2 ^ 3 * y3 ^ 4 * y1 * e1 ^ 2 * x3 - -8 * y2 ^ 2 * y3 ^ 4 * x1 * e1 ^ 3 * x3 - -8 * y2 ^ 2 * y3 ^ 4 * x2 * e1 ^ 3 * x3 + -8 * y2 ^ 2 * y3 ^ 4 * e5 * x1 * e1 ^ 2 + -8 * y2 ^ 2 * y3 ^ 4 * e5 * x2 * e1 ^ 2 + -8 * y2 ^ 2 * y3 ^ 4 * e5 * e1 ^ 2 * x3 + -8 * y2 ^ 2 * y3 ^ 4 * e6 * x1 * e1 ^ 2 + -8 * y2 ^ 2 * y3 ^ 4 * e6 * x2 * e1 ^ 2 + -8 * y2 ^ 2 * y3 ^ 4 * e6 * e1 ^ 2 * x3 - -4 * e4 ^ 2 * y2 ^ 3 * y1 * e1 ^ 2 * x3 - -2 * e4 ^ 2 * y2 ^ 2 * x1 * e1 ^ 3 * x3 - -2 * e4 ^ 2 * y2 ^ 2 * x2 * e1 ^ 3 * x3 + -2 * e4 ^ 2 * y2 ^ 2 * e5 * x1 * e1 ^ 2 + -2 * e4 ^ 2 * y2 ^ 2 * e5 * x2 * e1 ^ 2 + -2 * e4 ^ 2 * y2 ^ 2 * e5 * e1 ^ 2 * x3 + -2 * e4 ^ 2 * y2 ^ 2 * e6 * x1 * e1 ^ 2 + -2 * e4 ^ 2 * y2 ^ 2 * e6 * x2 * e1 ^ 2 + -2 * e4 ^ 2 * y2 ^ 2 * e6 * e1 ^ 2 * x3 - -4 * e4 ^ 2 * y1 ^ 3 * y2 * e1 ^ 2 * x3 - -2 * e4 ^ 2 * y1 ^ 2 * x1 * e1 ^ 3 * x3 - -2 * e4 ^ 2 * y1 ^ 2 * x2 * e1 ^ 3 * x3 + -2 * e4 ^ 2 * y1 ^ 2 * e5 * x1 * e1 ^ 2 + -2 * e4 ^ 2 * y1 ^ 2 * e5 * x2 * e1 ^ 2 + -2 * e4 ^ 2 * y1 ^ 2 * e5 * e1 ^ 2 * x3 + -2 * e4 ^ 2 * y1 ^ 2 * e6 * x1 * e1 ^ 2 + -2 * e4 ^ 2 * y1 ^ 2 * e6 * x2 * e1 ^ 2 + -2 * e4 ^ 2 * y1 ^ 2 * e6 * e1 ^ 2 * x3 - -8 * y2 ^ 3 * e6 * e7 * y1 * e1 ^ 2 * x3 - -4 * y2 ^ 2 * e6 * e7 * x1 * e1 ^ 3 * x3 - -4 * y2 ^ 2 * e6 * e7 * x2 * e1 ^ 3 * x3 + -4 * y2 ^ 2 * e6 * e7 * e5 * e1 ^ 2 * x3 + -4 * y2 ^ 2 * e6 ^ 2 * e7 * e1 ^ 2 * x3 + -16 * y2 ^ 4 * e6 * y3 * y1 * e1 ^ 2 * x3 + -8 * y2 ^ 3 * e6 * y3 * x1 * e1 ^ 3 * x3 + -8 * y2 ^ 3 * e6 * y3 * x2 * e1 ^ 3 * x3 - -8 * y2 ^ 3 * e6 * y3 * e5 * e1 ^ 2 * x3 - -8 * y2 ^ 3 * e6 ^ 2 * y3 * e1 ^ 2 * x3 - -8 * y2 ^ 3 * e6 * e4 * y1 * e1 ^ 2 * x3 - -4 * y2 ^ 2 * e6 * e4 * x1 * e1 ^ 3 * x3 - -4 * y2 ^ 2 * e6 * e4 * x2 * e1 ^ 3 * x3 + -4 * y2 ^ 2 * e6 * e4 * e5 * x1 * e1 ^ 2 + -4 * y2 ^ 2 * e6 * e4 * e5 * x2 * e1 ^ 2 + -4 * y2 ^ 2 * e6 * e4 * e5 * e1 ^ 2 * x3 + -4 * y2 ^ 2 * e6 ^ 2 * e4 * x1 * e1 ^ 2 + -4 * y2 ^ 2 * e6 ^ 2 * e4 * x2 * e1 ^ 2 + -4 * y2 ^ 2 * e6 ^ 2 * e4 * e1 ^ 2 * x3 + -16 * y2 ^ 4 * e7 * y3 * y1 * e1 ^ 2 * x3 + -8 * y2 ^ 3 * e7 * y3 * x1 * e1 ^ 3 * x3 + -8 * y2 ^ 3 * e7 * y3 * x2 * e1 ^ 3 * x3 - -8 * y2 ^ 3 * e7 * y3 * e5 * e1 ^ 2 * x3 - -8 * y2 ^ 3 * e7 * y3 * e6 * e1 ^ 2 * x3 - -16 * y2 ^ 2 * e7 ^ 2 * y3 * y1 * e1 ^ 2 * x3 - -8 * y2 * e7 ^ 2 * y3 * x1 * e1 ^ 3 * x3 - -8 * y2 * e7 ^ 2 * y3 * x2 * e1 ^ 3 * x3 + -8 * y2 * e7 ^ 2 * y3 * e5 * x1 * e1 ^ 2 + -8 * y2 * e7 ^ 2 * y3 * e5 * x2 * e1 ^ 2 + -8 * y2 * e7 ^ 2 * y3 * e5 * e1 ^ 2 * x3 + -8 * y2 * e7 ^ 2 * y3 * e6 * x1 * e1 ^ 2 + -8 * y2 * e7 ^ 2 * y3 * e6 * x2 * e1 ^ 2 + -8 * y2 * e7 ^ 2 * y3 * e6 * e1 ^ 2 * x3 + -16 * y2 ^ 3 * e7 * y3 ^ 2 * y1 * e1 ^ 2 * x3 + -8 * y2 ^ 2 * e7 * y3 ^ 2 * x1 * e1 ^ 3 * x3 + -8 * y2 ^ 2 * e7 * y3 ^ 2 * x2 * e1 ^ 3 * x3 - -8 * y2 ^ 2 * e7 * y3 ^ 2 * e5 * x1 * e1 ^ 2 - -8 * y2 ^ 2 * e7 * y3 ^ 2 * e5 * x2 * e1 ^ 2 - -8 * y2 ^ 2 * e7 * y3 ^ 2 * e5 * e1 ^ 2 * x3 - -8 * y2 ^ 2 * e7 * y3 ^ 2 * e6 * x1 * e1 ^ 2 - -8 * y2 ^ 2 * e7 * y3 ^ 2 * e6 * x2 * e1 ^ 2 - -8 * y2 ^ 2 * e7 * y3 ^ 2 * e6 * e1 ^ 2 * x3 - -8 * y2 ^ 3 * e7 * e4 * y1 * e1 ^ 2 * x3 - -4 * y2 ^ 2 * e7 * e4 * x1 * e1 ^ 3 * x3 - -4 * y2 ^ 2 * e7 * e4 * x2 * e1 ^ 3 * x3 + -4 * y2 ^ 2 * e7 * e4 * e5 * x1 * e1 ^ 2 + -4 * y2 ^ 2 * e7 * e4 * e5 * x2 * e1 ^ 2 + -4 * y2 ^ 2 * e7 * e4 * e5 * e1 ^ 2 * x3 + -4 * y2 ^ 2 * e7 * e4 * e6 * x1 * e1 ^ 2 + -4 * y2 ^ 2 * e7 * e4 * e6 * x2 * e1 ^ 2 + -4 * y2 ^ 2 * e7 * e4 * e6 * e1 ^ 2 * x3 + -16 * y2 ^ 4 * y3 * e4 * y1 * e1 ^ 2 * x3 + -8 * y2 ^ 3 * y3 * e4 * x1 * e1 ^ 3 * x3 + -8 * y2 ^ 3 * y3 * e4 * x2 * e1 ^ 3 * x3 - -8 * y2 ^ 3 * y3 * e4 * e5 * x1 * e1 ^ 2 - -8 * y2 ^ 3 * y3 * e4 * e5 * x2 * e1 ^ 2 - -8 * y2 ^ 3 * y3 * e4 * e5 * e1 ^ 2 * x3 - -8 * y2 ^ 3 * y3 * e4 * e6 * x1 * e1 ^ 2 - -8 * y2 ^ 3 * y3 * e4 * e6 * x2 * e1 ^ 2 - -8 * y2 ^ 3 * y3 * e4 * e6 * e1 ^ 2 * x3 - -4 * y2 ^ 3 * x3 ^ 3 * e3 ^ 2 * y1 * e1 ^ 2 - -2 * y2 ^ 2 * x3 ^ 3 * e3 ^ 2 * x1 * e1 ^ 3 - -6 * y2 ^ 2 * x3 ^ 3 * e3 ^ 2 * x2 * e1 ^ 3 + -2 * y2 ^ 2 * x3 ^ 3 * e3 ^ 2 * e5 * e1 ^ 2 + -2 * y2 ^ 2 * x3 ^ 3 * e3 ^ 2 * e6 * e1 ^ 2 - -8 * y3 ^ 2 * e6 * e7 * y1 * y2 * e1 ^ 2 * x3 - -4 * y3 ^ 2 * e6 * e7 * x1 * e1 ^ 3 * x3 - -4 * y3 ^ 2 * e6 * e7 * x2 * e1 ^ 3 * x3 + -4 * y3 ^ 2 * e6 * e7 * e5 * x1 * e1 ^ 2 + -4 * y3 ^ 2 * e6 * e7 * e5 * x2 * e1 ^ 2 + -4 * y3 ^ 2 * e6 * e7 * e5 * e1 ^ 2 * x3 + -4 * y3 ^ 2 * e6 ^ 2 * e7 * x1 * e1 ^ 2 + -4 * y3 ^ 2 * e6 ^ 2 * e7 * x2 * e1 ^ 2 + -4 * y3 ^ 2 * e6 ^ 2 * e7 * e1 ^ 2 * x3 + -16 * y3 ^ 3 * e6 * y2 ^ 2 * y1 * e1 ^ 2 * x3 + -8 * y3 ^ 3 * e6 * y2 * x1 * e1 ^ 3 * x3 + -8 * y3 ^ 3 * e6 * y2 * x2 * e1 ^ 3 * x3 - -8 * y3 ^ 3 * e6 * y2 * e5 * x1 * e1 ^ 2 - -8 * y3 ^ 3 * e6 * y2 * e5 * x2 * e1 ^ 2 - -8 * y3 ^ 3 * e6 * y2 * e5 * e1 ^ 2 * x3 - -8 * y3 ^ 3 * e6 ^ 2 * y2 * x1 * e1 ^ 2 - -8 * y3 ^ 3 * e6 ^ 2 * y2 * x2 * e1 ^ 2 - -8 * y3 ^ 3 * e6 ^ 2 * y2 * e1 ^ 2 * x3 + -16 * y3 ^ 3 * e7 * y2 ^ 2 * y1 * e1 ^ 2 * x3 + -8 * y3 ^ 3 * e7 * y2 * x1 * e1 ^ 3 * x3 + -8 * y3 ^ 3 * e7 * y2 * x2 * e1 ^ 3 * x3 - -8 * y3 ^ 3 * e7 * y2 * e5 * x1 * e1 ^ 2 - -8 * y3 ^ 3 * e7 * y2 * e5 * x2 * e1 ^ 2 - -8 * y3 ^ 3 * e7 * y2 * e5 * e1 ^ 2 * x3 - -8 * y3 ^ 3 * e7 * y2 * e6 * x1 * e1 ^ 2 - -8 * y3 ^ 3 * e7 * y2 * e6 * x2 * e1 ^ 2 - -8 * y3 ^ 3 * e7 * y2 * e6 * e1 ^ 2 * x3 - -16 * y2 ^ 3 * y3 ^ 2 * e4 * y1 * e1 ^ 2 * x3 - -8 * y2 ^ 2 * y3 ^ 2 * e4 * x1 * e1 ^ 3 * x3 - -8 * y2 ^ 2 * y3 ^ 2 * e4 * x2 * e1 ^ 3 * x3 + -8 * y2 ^ 2 * y3 ^ 2 * e4 * e5 * x1 * e1 ^ 2 + -8 * y2 ^ 2 * y3 ^ 2 * e4 * e5 * x2 * e1 ^ 2 + -8 * y2 ^ 2 * y3 ^ 2 * e4 * e5 * e1 ^ 2 * x3 + -8 * y2 ^ 2 * y3 ^ 2 * e4 * e6 * x1 * e1 ^ 2 + -8 * y2 ^ 2 * y3 ^ 2 * e4 * e6 * x2 * e1 ^ 2 + -8 * y2 ^ 2 * y3 ^ 2 * e4 * e6 * e1 ^ 2 * x3 - -32 * y3 ^ 2 * x2 ^ 2 * e3 ^ 2 * y1 * y2 * e1 ^ 2 * x3 - -16 * y3 ^ 2 * x2 ^ 2 * e3 ^ 2 * x1 * e1 ^ 3 * x3 - -12 * y3 ^ 2 * x2 ^ 3 * e3 ^ 2 * e1 ^ 3 * x3 + -8 * y3 ^ 2 * x2 ^ 2 * e3 ^ 2 * e5 * x1 * e1 ^ 2 + -8 * y3 ^ 2 * x2 ^ 3 * e3 ^ 2 * e5 * e1 ^ 2 + -16 * y3 ^ 2 * x2 ^ 2 * e3 ^ 2 * e5 * e1 ^ 2 * x3 + -8 * y3 ^ 2 * x2 ^ 2 * e3 ^ 2 * e6 * x1 * e1 ^ 2 + -8 * y3 ^ 2 * x2 ^ 3 * e3 ^ 2 * e6 * e1 ^ 2 + -16 * y3 ^ 2 * x2 ^ 2 * e3 ^ 2 * e6 * e1 ^ 2 * x3 - -4 * y3 ^ 2 * x3 ^ 3 * e3 ^ 2 * y1 * y2 * e1 ^ 2 - -2 * y3 ^ 2 * x3 ^ 3 * e3 ^ 2 * x1 * e1 ^ 3 - -6 * y3 ^ 2 * x3 ^ 3 * e3 ^ 2 * x2 * e1 ^ 3 + -2 * y3 ^ 2 * x3 ^ 2 * e3 ^ 2 * e5 * x1 * e1 ^ 2 + -10 * y3 ^ 2 * x3 ^ 2 * e3 ^ 2 * e5 * x2 * e1 ^ 2 + -2 * y3 ^ 2 * x3 ^ 3 * e3 ^ 2 * e5 * e1 ^ 2 + -2 * y3 ^ 2 * x3 ^ 2 * e3 ^ 2 * e6 * x1 * e1 ^ 2 + -10 * y3 ^ 2 * x3 ^ 2 * e3 ^ 2 * e6 * x2 * e1 ^ 2 + -2 * y3 ^ 2 * x3 ^ 3 * e3 ^ 2 * e6 * e1 ^ 2 + -8 * y2 ^ 3 * e6 * x3 ^ 2 * e3 * y1 * e1 ^ 2 + -4 * y2 ^ 2 * e6 * x3 ^ 2 * e3 * x1 * e1 ^ 3 - -4 * y2 ^ 2 * e6 * x3 ^ 2 * e3 * e5 * e1 ^ 2 - -4 * y2 ^ 2 * e6 ^ 2 * x3 ^ 2 * e3 * e1 ^ 2 - -8 * y2 ^ 2 * e6 * e4 * y1 ^ 2 * e1 ^ 2 * x3 - -4 * y2 * e6 * e4 * y1 * x1 * e1 ^ 3 * x3 - -4 * y2 * e6 * e4 * y1 * x2 * e1 ^ 3 * x3 + -4 * y2 * e6 * e4 * y1 * e5 * x1 * e1 ^ 2 + -4 * y2 * e6 * e4 * y1 * e5 * x2 * e1 ^ 2 + -4 * y2 * e6 * e4 * y1 * e5 * e1 ^ 2 * x3 + -4 * y2 * e6 ^ 2 * e4 * y1 * x1 * e1 ^ 2 + -4 * y2 * e6 ^ 2 * e4 * y1 * x2 * e1 ^ 2 + -4 * y2 * e6 ^ 2 * e4 * y1 * e1 ^ 2 * x3 + -8 * y2 ^ 3 * e7 * x3 ^ 2 * e3 * y1 * e1 ^ 2 + -4 * y2 ^ 2 * e7 * x3 ^ 2 * e3 * x1 * e1 ^ 3 - -4 * y2 ^ 2 * e7 * x3 ^ 2 * e3 * e5 * e1 ^ 2 - -4 * y2 ^ 2 * e7 * x3 ^ 2 * e3 * e6 * e1 ^ 2 - -8 * y2 ^ 2 * e7 * e4 * y1 ^ 2 * e1 ^ 2 * x3 - -4 * y2 * e7 * e4 * y1 * x1 * e1 ^ 3 * x3 - -4 * y2 * e7 * e4 * y1 * x2 * e1 ^ 3 * x3 + -4 * y2 * e7 * e4 * y1 * e5 * x1 * e1 ^ 2 + -4 * y2 * e7 * e4 * y1 * e5 * x2 * e1 ^ 2 + -4 * y2 * e7 * e4 * y1 * e5 * e1 ^ 2 * x3 + -4 * y2 * e7 * e4 * y1 * e6 * x1 * e1 ^ 2 + -4 * y2 * e7 * e4 * y1 * e6 * x2 * e1 ^ 2 + -4 * y2 * e7 * e4 * y1 * e6 * e1 ^ 2 * x3 - -16 * y2 ^ 3 * y3 * x2 * e3 * e1 ^ 3 * x3 ^ 2 - -4 * y2 ^ 3 * y3 * x3 ^ 3 * e3 * e1 ^ 3 + -8 * y2 ^ 2 * y3 * e4 * y1 * x1 * e1 ^ 3 * x2 + -4 * y2 ^ 2 * y3 * e4 * y1 * x1 ^ 2 * e1 ^ 3 + -4 * y2 ^ 2 * y3 * e4 * y1 * x2 ^ 2 * e1 ^ 3 + -4 * y2 ^ 2 * y3 * e4 * y1 * e1 ^ 3 * x3 ^ 2 + -16 * y2 ^ 3 * y3 * e4 * y1 ^ 2 * x1 * e1 ^ 2 + -16 * y2 ^ 3 * y3 * e4 * y1 ^ 2 * x2 * e1 ^ 2 + -8 * y2 ^ 2 * x2 ^ 2 * e3 * e4 * x1 * e1 ^ 3 + -4 * y2 ^ 2 * x2 * e3 * e4 * x1 ^ 2 * e1 ^ 3 + -4 * y2 ^ 2 * x2 ^ 3 * e3 * e4 * e1 ^ 3 + -8 * y2 ^ 2 * x2 * e3 * e4 * e1 ^ 3 * x3 ^ 2 + -16 * y2 ^ 3 * x2 * e3 * e4 * y1 * x1 * e1 ^ 2 + -16 * y2 ^ 3 * x2 ^ 2 * e3 * e4 * y1 * e1 ^ 2 + -8 * y2 * x2 ^ 2 * e3 * e4 * y1 * x1 * e1 ^ 3 + -4 * y2 * x2 * e3 * e4 * y1 * x1 ^ 2 * e1 ^ 3 + -4 * y2 * x2 ^ 3 * e3 * e4 * y1 * e1 ^ 3 + -8 * y2 * x2 * e3 * e4 * y1 * e1 ^ 3 * x3 ^ 2 + -16 * y2 ^ 2 * x2 * e3 * e4 * y1 ^ 2 * x1 * e1 ^ 2 + -16 * y2 ^ 2 * x2 ^ 2 * e3 * e4 * y1 ^ 2 * e1 ^ 2 + -12 * y2 ^ 2 * x3 * e3 * e4 * x1 * e1 ^ 3 * x2 + -2 * y2 ^ 2 * x3 * e3 * e4 * x1 ^ 2 * e1 ^ 3 + -10 * y2 ^ 2 * x3 * e3 * e4 * x2 ^ 2 * e1 ^ 3 + -2 * y2 ^ 2 * x3 ^ 3 * e3 * e4 * e1 ^ 3 + -8 * y2 ^ 3 * x3 * e3 * e4 * y1 * x1 * e1 ^ 2 + -24 * y2 ^ 3 * x3 * e3 * e4 * y1 * x2 * e1 ^ 2 + -8 * y3 ^ 2 * e6 * x2 ^ 2 * e3 * x1 * e1 ^ 3 + -4 * y3 ^ 2 * e6 * x2 * e3 * x1 ^ 2 * e1 ^ 3 + -4 * y3 ^ 2 * e6 * x2 ^ 3 * e3 * e1 ^ 3 + -8 * y3 ^ 2 * e6 * x2 * e3 * e1 ^ 3 * x3 ^ 2 + -16 * y3 ^ 2 * e6 * x2 * e3 * y1 * y2 * x1 * e1 ^ 2 + -16 * y3 ^ 2 * e6 * x2 ^ 2 * e3 * y1 * y2 * e1 ^ 2 + -12 * y3 ^ 2 * e6 * x3 * e3 * x1 * e1 ^ 3 * x2 + -2 * y3 ^ 2 * e6 * x3 * e3 * x1 ^ 2 * e1 ^ 3 + -10 * y3 ^ 2 * e6 * x3 * e3 * x2 ^ 2 * e1 ^ 3 + -2 * y3 ^ 2 * e6 * x3 ^ 3 * e3 * e1 ^ 3 + -8 * y3 ^ 2 * e6 * x3 * e3 * y1 * y2 * x1 * e1 ^ 2 + -24 * y3 ^ 2 * e6 * x3 * e3 * y1 * y2 * x2 * e1 ^ 2 + -4 * y3 * e6 * e4 * y2 * x1 * e1 ^ 3 * x2 + -2 * y3 * e6 * e4 * y2 * x1 ^ 2 * e1 ^ 3 + -2 * y3 * e6 * e4 * y2 * x2 ^ 2 * e1 ^ 3 + -2 * y3 * e6 * e4 * y2 * e1 ^ 3 * x3 ^ 2 + -4 * y3 * e6 * e4 * y1 * x1 * e1 ^ 3 * x2 + -2 * y3 * e6 * e4 * y1 * x1 ^ 2 * e1 ^ 3 + -2 * y3 * e6 * e4 * y1 * x2 ^ 2 * e1 ^ 3 + -2 * y3 * e6 * e4 * y1 * e1 ^ 3 * x3 ^ 2 + -8 * y3 * e6 * e4 * y1 ^ 2 * y2 * x1 * e1 ^ 2 + -8 * y3 * e6 * e4 * y1 ^ 2 * y2 * x2 * e1 ^ 2 + -8 * y3 ^ 2 * e7 * x2 ^ 2 * e3 * x1 * e1 ^ 3 + -4 * y3 ^ 2 * e7 * x2 * e3 * x1 ^ 2 * e1 ^ 3 + -4 * y3 ^ 2 * e7 * x2 ^ 3 * e3 * e1 ^ 3 + -8 * y3 ^ 2 * e7 * x2 * e3 * e1 ^ 3 * x3 ^ 2 + -16 * y3 ^ 2 * e7 * x2 * e3 * y1 * y2 * x1 * e1 ^ 2 + -16 * y3 ^ 2 * e7 * x2 ^ 2 * e3 * y1 * y2 * e1 ^ 2 + -12 * y3 ^ 2 * e7 * x3 * e3 * x1 * e1 ^ 3 * x2 + -2 * y3 ^ 2 * e7 * x3 * e3 * x1 ^ 2 * e1 ^ 3 + -10 * y3 ^ 2 * e7 * x3 * e3 * x2 ^ 2 * e1 ^ 3 + -2 * y3 ^ 2 * e7 * x3 ^ 3 * e3 * e1 ^ 3 + -8 * y3 ^ 2 * e7 * x3 * e3 * y1 * y2 * x1 * e1 ^ 2 + -24 * y3 ^ 2 * e7 * x3 * e3 * y1 * y2 * x2 * e1 ^ 2 + -4 * y3 * e7 * e4 * y2 * x1 * e1 ^ 3 * x2 + -2 * y3 * e7 * e4 * y2 * x1 ^ 2 * e1 ^ 3 + -2 * y3 * e7 * e4 * y2 * x2 ^ 2 * e1 ^ 3 + -2 * y3 * e7 * e4 * y2 * e1 ^ 3 * x3 ^ 2 + -8 * y3 * e7 * e4 * y2 ^ 2 * y1 * x1 * e1 ^ 2 + -8 * y3 * e7 * e4 * y2 ^ 2 * y1 * x2 * e1 ^ 2 + -4 * y3 * e7 * e4 * y1 * x1 * e1 ^ 3 * x2 + -2 * y3 * e7 * e4 * y1 * x1 ^ 2 * e1 ^ 3 + -2 * y3 * e7 * e4 * y1 * x2 ^ 2 * e1 ^ 3 + -2 * y3 * e7 * e4 * y1 * e1 ^ 3 * x3 ^ 2 + -8 * y3 * e7 * e4 * y1 ^ 2 * y2 * x1 * e1 ^ 2 + -8 * y3 * e7 * e4 * y1 ^ 2 * y2 * x2 * e1 ^ 2 - -16 * y2 * y3 ^ 3 * x2 ^ 2 * e3 * x1 * e1 ^ 3 - -8 * y2 * y3 ^ 3 * x2 * e3 * x1 ^ 2 * e1 ^ 3 - -8 * y2 * y3 ^ 3 * x2 ^ 3 * e3 * e1 ^ 3 - -16 * y2 * y3 ^ 3 * x2 * e3 * e1 ^ 3 * x3 ^ 2 - -32 * y2 ^ 2 * y3 ^ 3 * x2 * e3 * y1 * x1 * e1 ^ 2 - -32 * y2 ^ 2 * y3 ^ 3 * x2 ^ 2 * e3 * y1 * e1 ^ 2 - -24 * y2 * y3 ^ 3 * x3 * e3 * x1 * e1 ^ 3 * x2 - -4 * y2 * y3 ^ 3 * x3 * e3 * x1 ^ 2 * e1 ^ 3 - -20 * y2 * y3 ^ 3 * x3 * e3 * x2 ^ 2 * e1 ^ 3 - -4 * y2 * y3 ^ 3 * x3 ^ 3 * e3 * e1 ^ 3 - -16 * y2 ^ 2 * y3 ^ 3 * x3 * e3 * y1 * x1 * e1 ^ 2 - -48 * y2 ^ 2 * y3 ^ 3 * x3 * e3 * y1 * x2 * e1 ^ 2 - -8 * y2 * y3 ^ 2 * e4 * y1 * x1 * e1 ^ 3 * x2 - -4 * y2 * y3 ^ 2 * e4 * y1 * x1 ^ 2 * e1 ^ 3 - -4 * y2 * y3 ^ 2 * e4 * y1 * x2 ^ 2 * e1 ^ 3 - -4 * y2 * y3 ^ 2 * e4 * y1 * e1 ^ 3 * x3 ^ 2 - -16 * y2 ^ 2 * y3 ^ 2 * e4 * y1 ^ 2 * x1 * e1 ^ 2 - -16 * y2 ^ 2 * y3 ^ 2 * e4 * y1 ^ 2 * x2 * e1 ^ 2 - -4 * y3 ^ 2 * x2 * e3 ^ 2 * x3 * x1 ^ 2 * e1 ^ 3 - -16 * y3 ^ 2 * x2 * e3 ^ 2 * x3 * y1 * y2 * x1 * e1 ^ 2 + -12 * y2 * x3 * e3 * e4 * y1 * x1 * e1 ^ 3 * x2 + -2 * y2 * x3 * e3 * e4 * y1 * x1 ^ 2 * e1 ^ 3 + -10 * y2 * x3 * e3 * e4 * y1 * x2 ^ 2 * e1 ^ 3 + -2 * y2 * x3 ^ 3 * e3 * e4 * y1 * e1 ^ 3 + -8 * y2 ^ 2 * x3 * e3 * e4 * y1 ^ 2 * x1 * e1 ^ 2 + -24 * y2 ^ 2 * x3 * e3 * e4 * y1 ^ 2 * x2 * e1 ^ 2 - -8 * y3 * x2 ^ 2 * e3 * e4 * y2 * x1 * e1 ^ 3 - -4 * y3 * x2 * e3 * e4 * y2 * x1 ^ 2 * e1 ^ 3 - -4 * y3 * x2 ^ 3 * e3 * e4 * y2 * e1 ^ 3 - -8 * y3 * x2 * e3 * e4 * y2 * e1 ^ 3 * x3 ^ 2 - -16 * y3 * x2 * e3 * e4 * y2 ^ 2 * y1 * x1 * e1 ^ 2 - -16 * y3 * x2 ^ 2 * e3 * e4 * y2 ^ 2 * y1 * e1 ^ 2 - -8 * y3 * x2 ^ 2 * e3 * e4 * y1 * x1 * e1 ^ 3 - -4 * y3 * x2 * e3 * e4 * y1 * x1 ^ 2 * e1 ^ 3 - -4 * y3 * x2 ^ 3 * e3 * e4 * y1 * e1 ^ 3 - -8 * y3 * x2 * e3 * e4 * y1 * e1 ^ 3 * x3 ^ 2 - -16 * y3 * x2 * e3 * e4 * y1 ^ 2 * y2 * x1 * e1 ^ 2 - -16 * y3 * x2 ^ 2 * e3 * e4 * y1 ^ 2 * y2 * e1 ^ 2 - -12 * y3 * x3 * e3 * e4 * y2 * x1 * e1 ^ 3 * x2 - -2 * y3 * x3 * e3 * e4 * y2 * x1 ^ 2 * e1 ^ 3 - -10 * y3 * x3 * e3 * e4 * y2 * x2 ^ 2 * e1 ^ 3 - -2 * y3 * x3 ^ 3 * e3 * e4 * y2 * e1 ^ 3 - -8 * y3 * x3 * e3 * e4 * y2 ^ 2 * y1 * x1 * e1 ^ 2 - -24 * y3 * x3 * e3 * e4 * y2 ^ 2 * y1 * x2 * e1 ^ 2 - -12 * y3 * x3 * e3 * e4 * y1 * x1 * e1 ^ 3 * x2 - -2 * y3 * x3 * e3 * e4 * y1 * x1 ^ 2 * e1 ^ 3 - -10 * y3 * x3 * e3 * e4 * y1 * x2 ^ 2 * e1 ^ 3 - -2 * y3 * x3 ^ 3 * e3 * e4 * y1 * e1 ^ 3 - -8 * y3 * x3 * e3 * e4 * y1 ^ 2 * y2 * x1 * e1 ^ 2 - -24 * y3 * x3 * e3 * e4 * y1 ^ 2 * y2 * x2 * e1 ^ 2 - -4 * e4 ^ 2 * y2 * y1 * x1 * e1 ^ 3 * x2 - -2 * e4 ^ 2 * y2 * y1 * x1 ^ 2 * e1 ^ 3 - -2 * e4 ^ 2 * y2 * y1 * x2 ^ 2 * e1 ^ 3 - -2 * e4 ^ 2 * y2 * y1 * e1 ^ 3 * x3 ^ 2 - -8 * e4 ^ 2 * y2 ^ 2 * y1 ^ 2 * x1 * e1 ^ 2 - -8 * e4 ^ 2 * y2 ^ 2 * y1 ^ 2 * x2 * e1 ^ 2 - -16 * y2 ^ 4 * y3 * x3 ^ 2 * e3 * y1 * e1 ^ 2 - -8 * y2 ^ 3 * y3 * x3 ^ 2 * e3 * x1 * e1 ^ 3 + -8 * y2 ^ 3 * y3 * x3 ^ 2 * e3 * e5 * e1 ^ 2 + -8 * y2 ^ 3 * y3 * x3 ^ 2 * e3 * e6 * e1 ^ 2 + -16 * y2 ^ 3 * y3 * e4 * y1 ^ 2 * e1 ^ 2 * x3 + -8 * y2 ^ 2 * y3 * e4 * y1 * x1 * e1 ^ 3 * x3 + -8 * y2 ^ 2 * y3 * e4 * y1 * x2 * e1 ^ 3 * x3 - -8 * y2 ^ 2 * y3 * e4 * y1 * e5 * x1 * e1 ^ 2 - -8 * y2 ^ 2 * y3 * e4 * y1 * e5 * x2 * e1 ^ 2 - -8 * y2 ^ 2 * y3 * e4 * y1 * e5 * e1 ^ 2 * x3 - -8 * y2 ^ 2 * x2 * e3 * e4 * e5 * x1 * e1 ^ 2 - -8 * y2 ^ 2 * x2 ^ 2 * e3 * e4 * e5 * e1 ^ 2 - -12 * y2 ^ 2 * x2 * e3 * e4 * e5 * e1 ^ 2 * x3 - -8 * y2 ^ 2 * x2 * e3 * e4 * e6 * x1 * e1 ^ 2 - -8 * y2 ^ 2 * x2 ^ 2 * e3 * e4 * e6 * e1 ^ 2 - -12 * y2 ^ 2 * x2 * e3 * e4 * e6 * e1 ^ 2 * x3 - -8 * y2 * x2 * e3 * e4 * y1 * e5 * x1 * e1 ^ 2 - -8 * y2 * x2 ^ 2 * e3 * e4 * y1 * e5 * e1 ^ 2 - -12 * y2 * x2 * e3 * e4 * y1 * e5 * e1 ^ 2 * x3 - -8 * y2 * x2 * e3 * e4 * y1 * e6 * x1 * e1 ^ 2 - -8 * y2 * x2 ^ 2 * e3 * e4 * y1 * e6 * e1 ^ 2 - -12 * y2 * x2 * e3 * e4 * y1 * e6 * e1 ^ 2 * x3 + -8 * y2 ^ 3 * x3 ^ 2 * e3 * e4 * y1 * e1 ^ 2 + -4 * y2 ^ 2 * x3 ^ 2 * e3 * e4 * x1 * e1 ^ 3 - -4 * y2 ^ 2 * x3 * e3 * e4 * e5 * x1 * e1 ^ 2 - -4 * y2 ^ 2 * x3 ^ 2 * e3 * e4 * e5 * e1 ^ 2 - -4 * y2 ^ 2 * x3 * e3 * e4 * e6 * x1 * e1 ^ 2 - -4 * y2 ^ 2 * x3 ^ 2 * e3 * e4 * e6 * e1 ^ 2 - -8 * y3 ^ 2 * e6 * x2 * e3 * e5 * x1 * e1 ^ 2 - -8 * y3 ^ 2 * e6 * x2 ^ 2 * e3 * e5 * e1 ^ 2 - -12 * y3 ^ 2 * e6 * x2 * e3 * e5 * e1 ^ 2 * x3 - -8 * y3 ^ 2 * e6 ^ 2 * x2 * e3 * x1 * e1 ^ 2 - -8 * y3 ^ 2 * e6 ^ 2 * x2 ^ 2 * e3 * e1 ^ 2 - -12 * y3 ^ 2 * e6 ^ 2 * x2 * e3 * e1 ^ 2 * x3 + -8 * y3 ^ 2 * e6 * x3 ^ 2 * e3 * y1 * y2 * e1 ^ 2 + -4 * y3 ^ 2 * e6 * x3 ^ 2 * e3 * x1 * e1 ^ 3 - -4 * y3 ^ 2 * e6 * x3 * e3 * e5 * x1 * e1 ^ 2 - -4 * y3 ^ 2 * e6 * x3 ^ 2 * e3 * e5 * e1 ^ 2 - -4 * y3 ^ 2 * e6 ^ 2 * x3 * e3 * x1 * e1 ^ 2 - -4 * y3 ^ 2 * e6 ^ 2 * x3 ^ 2 * e3 * e1 ^ 2 + -4 * y3 * e6 * e4 * y2 * x1 * e1 ^ 3 * x3 + -4 * y3 * e6 * e4 * y2 * x2 * e1 ^ 3 * x3 - -4 * y3 * e6 * e4 * y2 * e5 * x1 * e1 ^ 2 - -4 * y3 * e6 * e4 * y2 * e5 * x2 * e1 ^ 2 - -4 * y3 * e6 * e4 * y2 * e5 * e1 ^ 2 * x3 - -4 * y3 * e6 ^ 2 * e4 * y2 * x1 * e1 ^ 2 - -4 * y3 * e6 ^ 2 * e4 * y2 * x2 * e1 ^ 2 - -4 * y3 * e6 ^ 2 * e4 * y2 * e1 ^ 2 * x3 + -8 * y3 * e6 * e4 * y1 ^ 2 * y2 * e1 ^ 2 * x3 + -4 * y3 * e6 * e4 * y1 * x1 * e1 ^ 3 * x3 + -4 * y3 * e6 * e4 * y1 * x2 * e1 ^ 3 * x3 - -4 * y3 * e6 * e4 * y1 * e5 * x1 * e1 ^ 2 - -4 * y3 * e6 * e4 * y1 * e5 * x2 * e1 ^ 2 - -4 * y3 * e6 * e4 * y1 * e5 * e1 ^ 2 * x3 - -4 * y3 * e6 ^ 2 * e4 * y1 * x1 * e1 ^ 2 - -4 * y3 * e6 ^ 2 * e4 * y1 * x2 * e1 ^ 2 - -4 * y3 * e6 ^ 2 * e4 * y1 * e1 ^ 2 * x3 - -8 * y3 ^ 2 * e7 * x2 * e3 * e5 * x1 * e1 ^ 2 - -8 * y3 ^ 2 * e7 * x2 ^ 2 * e3 * e5 * e1 ^ 2 - -12 * y3 ^ 2 * e7 * x2 * e3 * e5 * e1 ^ 2 * x3 - -8 * y3 ^ 2 * e7 * x2 * e3 * e6 * x1 * e1 ^ 2 - -8 * y3 ^ 2 * e7 * x2 ^ 2 * e3 * e6 * e1 ^ 2 - -12 * y3 ^ 2 * e7 * x2 * e3 * e6 * e1 ^ 2 * x3 + -8 * y3 ^ 2 * e7 * x3 ^ 2 * e3 * y1 * y2 * e1 ^ 2 + -4 * y3 ^ 2 * e7 * x3 ^ 2 * e3 * x1 * e1 ^ 3 - -4 * y3 ^ 2 * e7 * x3 * e3 * e5 * x1 * e1 ^ 2 - -4 * y3 ^ 2 * e7 * x3 ^ 2 * e3 * e5 * e1 ^ 2 - -4 * y3 ^ 2 * e7 * x3 * e3 * e6 * x1 * e1 ^ 2 - -4 * y3 ^ 2 * e7 * x3 ^ 2 * e3 * e6 * e1 ^ 2 + -8 * y3 * e7 * e4 * y2 ^ 2 * y1 * e1 ^ 2 * x3 + -4 * y3 * e7 * e4 * y2 * x1 * e1 ^ 3 * x3 + -4 * y3 * e7 * e4 * y2 * x2 * e1 ^ 3 * x3 - -4 * y3 * e7 * e4 * y2 * e5 * x1 * e1 ^ 2 - -4 * y3 * e7 * e4 * y2 * e5 * x2 * e1 ^ 2 - -4 * y3 * e7 * e4 * y2 * e5 * e1 ^ 2 * x3 - -4 * y3 * e7 * e4 * y2 * e6 * x1 * e1 ^ 2 - -4 * y3 * e7 * e4 * y2 * e6 * x2 * e1 ^ 2 - -4 * y3 * e7 * e4 * y2 * e6 * e1 ^ 2 * x3 + -8 * y3 * e7 * e4 * y1 ^ 2 * y2 * e1 ^ 2 * x3 + -4 * y3 * e7 * e4 * y1 * x1 * e1 ^ 3 * x3 + -4 * y3 * e7 * e4 * y1 * x2 * e1 ^ 3 * x3 - -4 * y3 * e7 * e4 * y1 * e5 * x1 * e1 ^ 2 - -4 * y3 * e7 * e4 * y1 * e5 * x2 * e1 ^ 2 - -4 * y3 * e7 * e4 * y1 * e5 * e1 ^ 2 * x3 - -4 * y3 * e7 * e4 * y1 * e6 * x1 * e1 ^ 2 - -4 * y3 * e7 * e4 * y1 * e6 * x2 * e1 ^ 2 - -4 * y3 * e7 * e4 * y1 * e6 * e1 ^ 2 * x3 + -16 * y2 * y3 ^ 3 * x2 * e3 * e5 * x1 * e1 ^ 2 + -16 * y2 * y3 ^ 3 * x2 ^ 2 * e3 * e5 * e1 ^ 2 + -24 * y2 * y3 ^ 3 * x2 * e3 * e5 * e1 ^ 2 * x3 + -16 * y2 * y3 ^ 3 * x2 * e3 * e6 * x1 * e1 ^ 2 + -16 * y2 * y3 ^ 3 * x2 ^ 2 * e3 * e6 * e1 ^ 2 + -24 * y2 * y3 ^ 3 * x2 * e3 * e6 * e1 ^ 2 * x3 - -16 * y2 ^ 2 * y3 ^ 3 * x3 ^ 2 * e3 * y1 * e1 ^ 2 - -8 * y2 * y3 ^ 3 * x3 ^ 2 * e3 * x1 * e1 ^ 3 + -8 * y2 * y3 ^ 3 * x3 * e3 * e5 * x1 * e1 ^ 2 + -8 * y2 * y3 ^ 3 * x3 ^ 2 * e3 * e5 * e1 ^ 2 + -8 * y2 * y3 ^ 3 * x3 * e3 * e6 * x1 * e1 ^ 2 + -8 * y2 * y3 ^ 3 * x3 ^ 2 * e3 * e6 * e1 ^ 2 - -16 * y2 ^ 2 * y3 ^ 2 * e4 * y1 ^ 2 * e1 ^ 2 * x3 - -8 * y2 * y3 ^ 2 * e4 * y1 * x1 * e1 ^ 3 * x3 - -8 * y2 * y3 ^ 2 * e4 * y1 * x2 * e1 ^ 3 * x3 + -8 * y2 * y3 ^ 2 * e4 * y1 * e5 * x1 * e1 ^ 2 + -8 * y2 * y3 ^ 2 * e4 * y1 * e5 * x2 * e1 ^ 2 + -8 * y2 * y3 ^ 2 * e4 * y1 * e5 * e1 ^ 2 * x3 + -8 * y2 * y3 ^ 2 * e4 * y1 * e6 * x1 * e1 ^ 2 + -8 * y2 * y3 ^ 2 * e4 * y1 * e6 * x2 * e1 ^ 2 + -8 * y2 * y3 ^ 2 * e4 * y1 * e6 * e1 ^ 2 * x3 + -8 * y3 ^ 2 * x2 * e3 ^ 2 * x3 * e5 * x1 * e1 ^ 2 + -8 * y3 ^ 2 * x2 * e3 ^ 2 * x3 * e6 * x1 * e1 ^ 2 + -8 * y2 ^ 2 * x3 ^ 2 * e3 * e4 * y1 ^ 2 * e1 ^ 2 + -4 * y2 * x3 ^ 2 * e3 * e4 * y1 * x1 * e1 ^ 3 - -4 * y2 * x3 * e3 * e4 * y1 * e5 * x1 * e1 ^ 2 - -4 * y2 * x3 ^ 2 * e3 * e4 * y1 * e5 * e1 ^ 2 - -4 * y2 * x3 * e3 * e4 * y1 * e6 * x1 * e1 ^ 2 - -4 * y2 * x3 ^ 2 * e3 * e4 * y1 * e6 * e1 ^ 2 + -8 * y3 * x2 * e3 * e4 * y2 * e5 * x1 * e1 ^ 2 + -8 * y3 * x2 ^ 2 * e3 * e4 * y2 * e5 * e1 ^ 2 + -12 * y3 * x2 * e3 * e4 * y2 * e5 * e1 ^ 2 * x3 + -8 * y3 * x2 * e3 * e4 * y2 * e6 * x1 * e1 ^ 2 + -8 * y3 * x2 ^ 2 * e3 * e4 * y2 * e6 * e1 ^ 2 + -12 * y3 * x2 * e3 * e4 * y2 * e6 * e1 ^ 2 * x3 + -8 * y3 * x2 * e3 * e4 * y1 * e5 * x1 * e1 ^ 2 + -8 * y3 * x2 ^ 2 * e3 * e4 * y1 * e5 * e1 ^ 2 + -12 * y3 * x2 * e3 * e4 * y1 * e5 * e1 ^ 2 * x3 + -8 * y3 * x2 * e3 * e4 * y1 * e6 * x1 * e1 ^ 2 + -8 * y3 * x2 ^ 2 * e3 * e4 * y1 * e6 * e1 ^ 2 + -12 * y3 * x2 * e3 * e4 * y1 * e6 * e1 ^ 2 * x3 - -8 * y3 * x3 ^ 2 * e3 * e4 * y2 ^ 2 * y1 * e1 ^ 2 - -4 * y3 * x3 ^ 2 * e3 * e4 * y2 * x1 * e1 ^ 3 + -4 * y3 * x3 * e3 * e4 * y2 * e5 * x1 * e1 ^ 2 + -4 * y3 * x3 ^ 2 * e3 * e4 * y2 * e5 * e1 ^ 2 + -4 * y3 * x3 * e3 * e4 * y2 * e6 * x1 * e1 ^ 2 + -4 * y3 * x3 ^ 2 * e3 * e4 * y2 * e6 * e1 ^ 2 - -8 * y3 * x3 ^ 2 * e3 * e4 * y1 ^ 2 * y2 * e1 ^ 2 - -4 * y3 * x3 ^ 2 * e3 * e4 * y1 * x1 * e1 ^ 3 + -4 * y3 * x3 * e3 * e4 * y1 * e5 * x1 * e1 ^ 2 + -4 * y3 * x3 ^ 2 * e3 * e4 * y1 * e5 * e1 ^ 2 + -4 * y3 * x3 * e3 * e4 * y1 * e6 * x1 * e1 ^ 2 + -4 * y3 * x3 ^ 2 * e3 * e4 * y1 * e6 * e1 ^ 2 - -8 * e4 ^ 2 * y2 ^ 2 * y1 ^ 2 * e1 ^ 2 * x3 - -4 * e4 ^ 2 * y2 * y1 * x1 * e1 ^ 3 * x3 - -4 * e4 ^ 2 * y2 * y1 * x2 * e1 ^ 3 * x3 + -4 * e4 ^ 2 * y2 * y1 * e5 * x1 * e1 ^ 2 + -4 * e4 ^ 2 * y2 * y1 * e5 * x2 * e1 ^ 2 + -4 * e4 ^ 2 * y2 * y1 * e5 * e1 ^ 2 * x3 + -4 * e4 ^ 2 * y2 * y1 * e6 * x1 * e1 ^ 2 + -4 * e4 ^ 2 * y2 * y1 * e6 * x2 * e1 ^ 2 + -4 * e4 ^ 2 * y2 * y1 * e6 * e1 ^ 2 * x3 + 4 * e1 * e6 ^ 2 * y2 ^ 3 * e5 * y1 - -4 * e1 * e6 ^ 2 * e7 * y2 ^ 2 * e5 + 8 * e1 * e6 ^ 2 * e7 * y2 ^ 3 * y1 + -32 * e1 * y2 ^ 4 * y3 * x2 * e3 * e5 * y1 - -8 * e1 * y2 ^ 3 * y3 * x3 * e3 * e5 * e6 + -16 * e1 * y2 ^ 4 * y3 * x3 * e3 * e5 * y1 + -16 * e1 * y2 ^ 4 * y3 * x3 * e3 * e6 * y1 + -8 * e1 * e6 * e7 * y2 ^ 3 * e5 * y1 - 2 * e1 * e7 ^ 2 * y2 ^ 2 * e5 * e6 + -4 * e1 * e7 ^ 2 * y2 ^ 3 * e5 * y1 + 4 * e1 * e7 ^ 2 * y2 ^ 3 * e6 * y1 - -16 * e1 * y2 ^ 3 * y3 ^ 2 * y1 * e6 ^ 2 + -16 * e1 * y2 ^ 4 * y3 ^ 2 * y1 ^ 2 * e6 - 8 * e1 * y2 ^ 4 * y3 ^ 2 * e5 * e6 + -16 * e1 * y2 ^ 5 * y3 ^ 2 * e5 * y1 + 16 * e1 * y2 ^ 5 * y3 ^ 2 * e6 * y1 - -4 * e1 * y2 ^ 2 * y3 ^ 2 * y1 ^ 2 * e6 ^ 2 - -2 * e1 * e6 * e7 * y2 ^ 2 * e5 ^ 2 - 8 * e1 * e6 * e7 * y1 ^ 2 * y2 ^ 4 - -4 * e1 * x2 ^ 2 * e3 ^ 2 * y2 ^ 2 * e5 ^ 2 - -16 * e1 * x2 ^ 2 * e3 ^ 2 * y1 ^ 2 * y2 ^ 4 - -e1 * x3 ^ 2 * e3 ^ 2 * y2 ^ 2 * e5 ^ 2 - -e1 * x3 ^ 2 * e3 ^ 2 * y2 ^ 2 * e6 ^ 2 - -4 * e1 * x3 ^ 2 * e3 ^ 2 * y1 ^ 2 * y2 ^ 4 + -16 * e1 * e6 ^ 3 * y2 ^ 2 * y3 * y1 - 16 * e1 * e6 ^ 2 * y2 ^ 3 * y3 * y1 ^ 2 + -8 * e1 * e6 ^ 2 * y2 ^ 3 * y3 * e5 - 16 * e1 * y2 ^ 3 * y3 ^ 2 * y1 * e5 * e6 + -16 * e1 * x2 ^ 2 * e3 ^ 2 * y2 ^ 3 * e5 * y1 - -2 * e1 * x3 ^ 2 * e3 ^ 2 * y2 ^ 2 * e5 * e6 + -4 * e1 * x3 ^ 2 * e3 ^ 2 * y2 ^ 3 * e5 * y1 + -4 * e1 * x3 ^ 2 * e3 ^ 2 * y2 ^ 3 * e6 * y1 - -8 * e1 * y2 ^ 3 * y3 * x2 * e3 * e5 ^ 2 - -32 * e1 * y2 ^ 5 * y3 * x2 * e3 * y1 ^ 2 - -4 * e1 * y2 ^ 3 * y3 * x3 * e3 * e5 ^ 2 - -4 * e1 * y2 ^ 3 * y3 * x3 * e3 * e6 ^ 2 - -16 * e1 * y2 ^ 5 * y3 * x3 * e3 * y1 ^ 2 - -4 * e1 * x2 * e3 ^ 2 * x3 * y2 ^ 2 * e5 ^ 2 + -16 * e1 * x2 * e3 ^ 2 * x3 * y2 ^ 3 * e5 * y1 + -16 * e1 * e6 ^ 2 * y2 ^ 2 * y3 * y1 * e5 - -16 * e1 * e6 * y2 ^ 4 * y3 * e5 * y1 - 16 * e1 * e6 ^ 2 * y2 ^ 4 * y3 * y1 + -4 * e1 * e6 * y2 ^ 3 * y3 * e5 ^ 2 + 16 * e1 * e6 * y2 ^ 5 * y3 * y1 ^ 2 + -2 * e1 * e6 ^ 3 * x3 * e3 * y2 ^ 2 + 4 * e1 * e7 * y2 ^ 3 * y3 * e5 ^ 2 + -4 * e1 * e7 * y2 ^ 3 * y3 * e6 ^ 2 + 16 * e1 * e7 * y2 ^ 5 * y3 * y1 ^ 2 - -16 * e1 * e6 * x2 * e3 * y2 ^ 3 * e5 * y1 + -4 * e1 * e6 ^ 2 * x3 * e3 * y2 ^ 2 * e5 - -8 * e1 * e6 * x3 * e3 * y2 ^ 3 * e5 * y1 - -8 * e1 * e6 ^ 2 * x3 * e3 * y2 ^ 3 * y1 + -32 * e1 * e7 * y2 ^ 2 * y3 * y1 * e5 * e6 + -32 * e1 * e7 * y2 ^ 2 * y3 * y1 * e6 ^ 2 - -32 * e1 * e7 * y2 ^ 3 * y3 * y1 ^ 2 * e6 + -8 * e1 * e7 * y2 ^ 3 * y3 * e5 * e6 - 16 * e1 * e7 * y2 ^ 4 * y3 * e5 * y1 - -16 * e1 * e7 * y2 ^ 4 * y3 * e6 * y1 - -16 * e1 * e7 * x2 * e3 * y2 ^ 3 * e5 * y1 + -4 * e1 * e7 * x3 * e3 * y2 ^ 2 * e5 * e6 - -8 * e1 * e7 * x3 * e3 * y2 ^ 3 * e5 * y1 - -8 * e1 * e7 * x3 * e3 * y2 ^ 3 * e6 * y1 - -16 * e1 * x2 * e3 ^ 2 * x3 * y1 ^ 2 * y2 ^ 4 + -4 * e1 * e6 * x2 * e3 * y2 ^ 2 * e5 ^ 2 + -16 * e1 * e6 * x2 * e3 * y1 ^ 2 * y2 ^ 4 + -2 * e1 * e6 * x3 * e3 * y2 ^ 2 * e5 ^ 2 + -8 * e1 * e6 * x3 * e3 * y1 ^ 2 * y2 ^ 4 + -4 * e1 * e7 * x2 * e3 * y2 ^ 2 * e5 ^ 2 + -16 * e1 * e7 * x2 * e3 * y1 ^ 2 * y2 ^ 4 + -2 * e1 * e7 * x3 * e3 * y2 ^ 2 * e5 ^ 2 + -2 * e1 * e7 * x3 * e3 * y2 ^ 2 * e6 ^ 2 + -8 * e1 * e7 * x3 * e3 * y1 ^ 2 * y2 ^ 4 - 8 * e1 * e6 ^ 3 * e7 * y2 * y3 - -4 * e1 * e5 ^ 2 * e6 ^ 2 * y2 * y3 + 4 * e1 * e5 ^ 2 * e6 * y2 ^ 2 * y3 ^ 2 + -8 * e1 * e5 * e6 ^ 2 * y2 ^ 2 * y3 ^ 2 - 8 * e1 * e5 * e6 ^ 3 * y2 * y3 - -16 * e1 * e6 ^ 2 * e7 * y2 * y3 * e5 - 8 * e1 * e5 ^ 2 * e7 * y2 * y3 * e6 - -2 * e1 * y3 ^ 2 * e7 ^ 2 * e5 * e6 - -4 * e1 * y3 ^ 2 * e7 ^ 2 * y1 ^ 2 * y2 ^ 2 - -8 * e1 * y2 ^ 2 * y3 ^ 4 * e5 * e6 - 2 * e1 * e4 ^ 2 * y2 ^ 2 * e5 * e6 - -2 * e1 * e4 ^ 2 * y1 ^ 2 * e5 * e6 - 16 * e1 * y2 ^ 4 * y3 ^ 4 * y1 ^ 2 - -e1 * e4 ^ 2 * y2 ^ 2 * e6 ^ 2 - e1 * e4 ^ 2 * y2 ^ 2 * e5 ^ 2 - -4 * e1 * e4 ^ 2 * y2 ^ 4 * y1 ^ 2 - e1 * e4 ^ 2 * y1 ^ 2 * e6 ^ 2 - -e1 * e4 ^ 2 * y1 ^ 2 * e5 ^ 2 - 4 * e1 * e4 ^ 2 * y1 ^ 4 * y2 ^ 2 - -2 * e1 * y2 ^ 2 * e6 ^ 3 * e4 - 2 * e1 * y3 ^ 2 * e6 ^ 3 * e7 + -4 * e1 * y3 ^ 3 * e6 ^ 3 * y2 - 2 * e1 * y2 ^ 2 * e6 * e4 * e5 ^ 2 - -4 * e1 * y2 ^ 2 * e6 ^ 2 * e4 * e5 - 8 * e1 * y2 ^ 4 * e6 * e4 * y1 ^ 2 - -4 * e1 * y2 * e7 ^ 2 * y3 * e6 ^ 2 - 4 * e1 * y2 * e7 ^ 2 * y3 * e5 ^ 2 - -16 * e1 * y2 ^ 3 * e7 ^ 2 * y3 * y1 ^ 2 + -4 * e1 * y2 ^ 2 * e7 * y3 ^ 2 * e6 ^ 2 + -4 * e1 * y2 ^ 2 * e7 * y3 ^ 2 * e5 ^ 2 + -16 * e1 * y2 ^ 4 * e7 * y3 ^ 2 * y1 ^ 2 - 2 * e1 * y2 ^ 2 * e7 * e4 * e6 ^ 2 - -2 * e1 * y2 ^ 2 * e7 * e4 * e5 ^ 2 - 8 * e1 * y2 ^ 4 * e7 * e4 * y1 ^ 2 + -4 * e1 * y2 ^ 3 * y3 * e4 * e6 ^ 2 + 4 * e1 * y2 ^ 3 * y3 * e4 * e5 ^ 2 + -16 * e1 * y2 ^ 5 * y3 * e4 * y1 ^ 2 - 2 * e1 * y3 ^ 2 * e6 * e7 * e5 ^ 2 - -4 * e1 * y3 ^ 2 * e6 ^ 2 * e7 * e5 + 4 * e1 * y3 ^ 3 * e6 * y2 * e5 ^ 2 + -8 * e1 * y3 ^ 3 * e6 ^ 2 * y2 * e5 + 16 * e1 * y3 ^ 3 * e6 * y2 ^ 3 * y1 ^ 2 + -4 * e1 * y3 ^ 3 * e7 * y2 * e6 ^ 2 + 4 * e1 * y3 ^ 3 * e7 * y2 * e5 ^ 2 + -16 * e1 * y3 ^ 3 * e7 * y2 ^ 3 * y1 ^ 2 - -4 * e1 * y2 ^ 2 * y3 ^ 2 * e4 * e6 ^ 2 - -4 * e1 * y2 ^ 2 * y3 ^ 2 * e4 * e5 ^ 2 - -16 * e1 * y2 ^ 4 * y3 ^ 2 * e4 * y1 ^ 2 - -4 * e1 * y3 ^ 2 * x2 ^ 2 * e3 ^ 2 * e6 ^ 2 - -4 * e1 * y3 ^ 2 * x2 ^ 2 * e3 ^ 2 * e5 ^ 2 - -e1 * y3 ^ 2 * x3 ^ 2 * e3 ^ 2 * e6 ^ 2 - -e1 * y3 ^ 2 * x3 ^ 2 * e3 ^ 2 * e5 ^ 2 - 2 * e1 * y2 * e6 ^ 3 * e4 * y1 - -8 * e1 * y2 ^ 3 * e6 * e4 * y1 ^ 3 - 8 * e1 * y2 ^ 3 * e7 * e4 * y1 ^ 3 + -4 * e1 * y3 ^ 2 * e6 ^ 3 * y1 * y2 + 16 * e1 * y2 ^ 3 * y3 ^ 4 * e5 * y1 + -16 * e1 * y2 ^ 3 * y3 ^ 4 * e6 * y1 + 4 * e1 * e4 ^ 2 * y2 ^ 3 * e5 * y1 - -8 * e1 * y2 * e7 ^ 2 * y3 * e5 * e6 + 8 * e1 * y2 ^ 2 * e7 * y3 ^ 2 * e5 * e6 - -4 * e1 * y2 ^ 2 * e7 * e4 * e5 * e6 + 8 * e1 * y2 ^ 3 * y3 * e4 * e5 * e6 - -8 * e1 * y3 ^ 2 * e6 * e7 * y1 ^ 2 * y2 ^ 2 + -8 * e1 * y3 ^ 3 * e7 * y2 * e5 * e6 - 8 * e1 * y2 ^ 2 * y3 ^ 2 * e4 * e5 * e6 - -8 * e1 * y3 ^ 2 * x2 ^ 2 * e3 ^ 2 * e5 * e6 - -16 * e1 * y3 ^ 2 * x2 ^ 2 * e3 ^ 2 * y1 ^ 2 * y2 ^ 2 - -2 * e1 * y3 ^ 2 * x3 ^ 2 * e3 ^ 2 * e5 * e6 - -4 * e1 * y3 ^ 2 * x3 ^ 2 * e3 ^ 2 * y1 ^ 2 * y2 ^ 2 - -2 * e1 * y2 * e6 * e4 * y1 * e5 ^ 2 - 4 * e1 * y2 * e6 ^ 2 * e4 * y1 * e5 - -2 * e1 * y2 * e7 * e4 * y1 * e6 ^ 2 - 2 * e1 * y2 * e7 * e4 * y1 * e5 ^ 2 - -4 * e1 * y2 * e7 * e4 * y1 * e5 * e6 + -4 * e1 * y3 ^ 2 * e6 ^ 2 * e5 * y1 * y2 + -4 * e1 * y3 ^ 2 * e7 ^ 2 * e5 * y1 * y2 + -4 * e1 * y3 ^ 2 * e7 ^ 2 * e6 * y1 * y2 + 4 * e1 * e4 ^ 2 * y2 ^ 3 * e6 * y1 + -4 * e1 * e4 ^ 2 * y1 ^ 3 * e5 * y2 + 4 * e1 * e4 ^ 2 * y1 ^ 3 * e6 * y2 + -8 * e1 * y2 ^ 3 * e6 ^ 2 * e4 * y1 - 16 * e1 * y3 ^ 3 * e6 ^ 2 * y2 ^ 2 * y1 + -8 * e1 * y2 ^ 2 * e6 ^ 2 * e4 * y1 ^ 2 + 16 * e1 * y2 ^ 4 * y3 * e4 * y1 ^ 3 + -4 * e1 * y3 ^ 2 * e6 ^ 3 * x2 * e3 + 2 * e1 * y3 ^ 2 * e6 ^ 3 * x3 * e3 + -2 * e1 * y3 * e6 ^ 3 * e4 * y2 + 2 * e1 * y3 * e6 ^ 3 * e4 * y1 - -2 * e1 * e4 ^ 2 * y2 * y1 * e6 ^ 2 - 2 * e1 * e4 ^ 2 * y2 * y1 * e5 ^ 2 + -8 * e1 * e4 ^ 2 * y2 ^ 2 * y1 ^ 2 * e5 + -8 * e1 * e4 ^ 2 * y2 ^ 2 * y1 ^ 2 * e6 + 8 * e1 * y2 ^ 3 * e6 * e4 * e5 * y1 + -16 * e1 * y2 ^ 2 * e7 ^ 2 * y3 * e5 * y1 + -16 * e1 * y2 ^ 2 * e7 ^ 2 * y3 * e6 * y1 - -16 * e1 * y2 ^ 3 * e7 * y3 ^ 2 * e5 * y1 - -16 * e1 * y2 ^ 3 * e7 * y3 ^ 2 * e6 * y1 + -8 * e1 * y2 ^ 3 * e7 * e4 * e5 * y1 + 8 * e1 * y2 ^ 3 * e7 * e4 * e6 * y1 - -16 * e1 * y2 ^ 4 * y3 * e4 * e5 * y1 - 16 * e1 * y2 ^ 4 * y3 * e4 * e6 * y1 + -8 * e1 * y3 ^ 2 * e6 * e7 * e5 * y1 * y2 + -8 * e1 * y3 ^ 2 * e6 ^ 2 * e7 * y1 * y2 - -16 * e1 * y3 ^ 3 * e6 * y2 ^ 2 * e5 * y1 - -16 * e1 * y3 ^ 3 * e7 * y2 ^ 2 * e5 * y1 - -16 * e1 * y3 ^ 3 * e7 * y2 ^ 2 * e6 * y1 + -16 * e1 * y2 ^ 3 * y3 ^ 2 * e4 * e5 * y1 + -16 * e1 * y2 ^ 3 * y3 ^ 2 * e4 * e6 * y1 + -16 * e1 * y3 ^ 2 * x2 ^ 2 * e3 ^ 2 * e5 * y1 * y2 + -16 * e1 * y3 ^ 2 * x2 ^ 2 * e3 ^ 2 * e6 * y1 * y2 + -4 * e1 * y3 ^ 2 * x3 ^ 2 * e3 ^ 2 * e5 * y1 * y2 + -4 * e1 * y3 ^ 2 * x3 ^ 2 * e3 ^ 2 * e6 * y1 * y2 + -8 * e1 * y2 ^ 2 * e6 * e4 * y1 ^ 2 * e5 + -8 * e1 * y2 ^ 2 * e7 * e4 * y1 ^ 2 * e5 + -8 * e1 * y2 ^ 2 * e7 * e4 * y1 ^ 2 * e6 - -4 * e1 * y2 ^ 2 * y3 * e4 * y1 * e6 ^ 2 + -4 * e1 * y2 ^ 2 * y3 * e4 * y1 * e5 ^ 2 + -4 * e1 * y2 ^ 2 * x2 * e3 * e4 * e6 ^ 2 + -4 * e1 * y2 ^ 2 * x2 * e3 * e4 * e5 ^ 2 + -8 * e1 * y2 ^ 2 * x2 * e3 * e4 * e5 * e6 + -16 * e1 * y2 ^ 4 * x2 * e3 * e4 * y1 ^ 2 + -4 * e1 * y2 * x2 * e3 * e4 * y1 * e6 ^ 2 + -4 * e1 * y2 * x2 * e3 * e4 * y1 * e5 ^ 2 + -8 * e1 * y2 * x2 * e3 * e4 * y1 * e5 * e6 + -16 * e1 * y2 ^ 3 * x2 * e3 * e4 * y1 ^ 3 + -2 * e1 * y2 ^ 2 * x3 * e3 * e4 * e6 ^ 2 + -2 * e1 * y2 ^ 2 * x3 * e3 * e4 * e5 ^ 2 + -4 * e1 * y2 ^ 2 * x3 * e3 * e4 * e5 * e6 + -8 * e1 * y2 ^ 4 * x3 * e3 * e4 * y1 ^ 2 + -4 * e1 * y3 ^ 2 * e6 * x2 * e3 * e5 ^ 2 + -8 * e1 * y3 ^ 2 * e6 ^ 2 * x2 * e3 * e5 + -2 * e1 * y3 ^ 2 * e6 * x3 * e3 * e5 ^ 2 + -4 * e1 * y3 ^ 2 * e6 ^ 2 * x3 * e3 * e5 + -8 * e1 * y3 ^ 2 * e6 * x3 * e3 * y1 ^ 2 * y2 ^ 2 + -2 * e1 * y3 * e6 * e4 * y2 * e5 ^ 2 + 4 * e1 * y3 * e6 ^ 2 * e4 * y2 * e5 - -8 * e1 * y3 * e6 * e4 * y2 ^ 3 * y1 ^ 2 + 2 * e1 * y3 * e6 * e4 * y1 * e5 ^ 2 + -4 * e1 * y3 * e6 ^ 2 * e4 * y1 * e5 + 8 * e1 * y3 * e6 * e4 * y1 ^ 3 * y2 ^ 2 + -4 * e1 * y3 ^ 2 * e7 * x2 * e3 * e6 ^ 2 + -4 * e1 * y3 ^ 2 * e7 * x2 * e3 * e5 ^ 2 + -8 * e1 * y3 ^ 2 * e7 * x2 * e3 * e5 * e6 + -16 * e1 * y3 ^ 2 * e7 * x2 * e3 * y1 ^ 2 * y2 ^ 2 + -2 * e1 * y3 ^ 2 * e7 * x3 * e3 * e6 ^ 2 + -2 * e1 * y3 ^ 2 * e7 * x3 * e3 * e5 ^ 2 + -4 * e1 * y3 ^ 2 * e7 * x3 * e3 * e5 * e6 + -8 * e1 * y3 ^ 2 * e7 * x3 * e3 * y1 ^ 2 * y2 ^ 2 + -2 * e1 * y3 * e7 * e4 * y2 * e6 ^ 2 + 2 * e1 * y3 * e7 * e4 * y2 * e5 ^ 2 + -4 * e1 * y3 * e7 * e4 * y2 * e5 * e6 + -8 * e1 * y3 * e7 * e4 * y2 ^ 3 * y1 ^ 2 + 2 * e1 * y3 * e7 * e4 * y1 * e6 ^ 2 + -2 * e1 * y3 * e7 * e4 * y1 * e5 ^ 2 + 4 * e1 * y3 * e7 * e4 * y1 * e5 * e6 + -8 * e1 * y3 * e7 * e4 * y1 ^ 3 * y2 ^ 2 - -8 * e1 * y2 * y3 ^ 3 * x2 * e3 * e6 ^ 2 - -8 * e1 * y2 * y3 ^ 3 * x2 * e3 * e5 ^ 2 - -16 * e1 * y2 * y3 ^ 3 * x2 * e3 * e5 * e6 - -32 * e1 * y2 ^ 3 * y3 ^ 3 * x2 * e3 * y1 ^ 2 - -4 * e1 * y2 * y3 ^ 3 * x3 * e3 * e6 ^ 2 - -4 * e1 * y2 * y3 ^ 3 * x3 * e3 * e5 ^ 2 - -8 * e1 * y2 * y3 ^ 3 * x3 * e3 * e5 * e6 - -16 * e1 * y2 ^ 3 * y3 ^ 3 * x3 * e3 * y1 ^ 2 - -4 * e1 * y2 * y3 ^ 2 * e4 * y1 * e6 ^ 2 - -4 * e1 * y2 * y3 ^ 2 * e4 * y1 * e5 ^ 2 - -8 * e1 * y2 * y3 ^ 2 * e4 * y1 * e5 * e6 - -4 * e1 * y3 ^ 2 * x2 * e3 ^ 2 * x3 * e6 ^ 2 - -4 * e1 * y3 ^ 2 * x2 * e3 ^ 2 * x3 * e5 ^ 2 - -8 * e1 * y3 ^ 2 * x2 * e3 ^ 2 * x3 * e5 * e6 - -16 * e1 * y3 ^ 2 * x2 * e3 ^ 2 * x3 * y1 ^ 2 * y2 ^ 2 + -2 * e1 * y2 * x3 * e3 * e4 * y1 * e6 ^ 2 + -2 * e1 * y2 * x3 * e3 * e4 * y1 * e5 ^ 2 + -4 * e1 * y2 * x3 * e3 * e4 * y1 * e5 * e6 + -8 * e1 * y2 ^ 3 * x3 * e3 * e4 * y1 ^ 3 - -4 * e1 * y3 * x2 * e3 * e4 * y2 * e6 ^ 2 - -4 * e1 * y3 * x2 * e3 * e4 * y2 * e5 ^ 2 - -8 * e1 * y3 * x2 * e3 * e4 * y2 * e5 * e6 - -16 * e1 * y3 * x2 * e3 * e4 * y2 ^ 3 * y1 ^ 2 - -4 * e1 * y3 * x2 * e3 * e4 * y1 * e6 ^ 2 - -4 * e1 * y3 * x2 * e3 * e4 * y1 * e5 ^ 2 - -8 * e1 * y3 * x2 * e3 * e4 * y1 * e5 * e6 - -16 * e1 * y3 * x2 * e3 * e4 * y1 ^ 3 * y2 ^ 2 - -2 * e1 * y3 * x3 * e3 * e4 * y2 * e6 ^ 2 - -2 * e1 * y3 * x3 * e3 * e4 * y2 * e5 ^ 2 - -4 * e1 * y3 * x3 * e3 * e4 * y2 * e5 * e6 - -8 * e1 * y3 * x3 * e3 * e4 * y2 ^ 3 * y1 ^ 2 - -2 * e1 * y3 * x3 * e3 * e4 * y1 * e6 ^ 2 - -2 * e1 * y3 * x3 * e3 * e4 * y1 * e5 ^ 2 - -4 * e1 * y3 * x3 * e3 * e4 * y1 * e5 * e6 - -8 * e1 * y3 * x3 * e3 * e4 * y1 ^ 3 * y2 ^ 2 - -4 * e1 * e4 ^ 2 * y2 * y1 * e5 * e6 - -16 * e1 * y2 ^ 3 * y3 * e4 * y1 ^ 2 * e5 - -16 * e1 * y2 ^ 3 * x2 * e3 * e4 * e5 * y1 - -16 * e1 * y2 ^ 3 * x2 * e3 * e4 * e6 * y1 - -16 * e1 * y2 ^ 2 * x2 * e3 * e4 * y1 ^ 2 * e5 - -16 * e1 * y2 ^ 2 * x2 * e3 * e4 * y1 ^ 2 * e6 - -8 * e1 * y2 ^ 3 * x3 * e3 * e4 * e5 * y1 - -8 * e1 * y2 ^ 3 * x3 * e3 * e4 * e6 * y1 - -16 * e1 * y3 ^ 2 * e6 * x2 * e3 * e5 * y1 * y2 - -16 * e1 * y3 ^ 2 * e6 ^ 2 * x2 * e3 * y1 * y2 - -8 * e1 * y3 ^ 2 * e6 * x3 * e3 * e5 * y1 * y2 - -8 * e1 * y3 ^ 2 * e6 ^ 2 * x3 * e3 * y1 * y2 - -8 * e1 * y3 * e6 * e4 * y1 ^ 2 * e5 * y2 - -8 * e1 * y3 * e6 ^ 2 * e4 * y1 ^ 2 * y2 - -16 * e1 * y3 ^ 2 * e7 * x2 * e3 * e5 * y1 * y2 - -16 * e1 * y3 ^ 2 * e7 * x2 * e3 * e6 * y1 * y2 - -8 * e1 * y3 ^ 2 * e7 * x3 * e3 * e5 * y1 * y2 - -8 * e1 * y3 ^ 2 * e7 * x3 * e3 * e6 * y1 * y2 - -8 * e1 * y3 * e7 * e4 * y2 ^ 2 * e5 * y1 - -8 * e1 * y3 * e7 * e4 * y2 ^ 2 * e6 * y1 - -8 * e1 * y3 * e7 * e4 * y1 ^ 2 * e5 * y2 - -8 * e1 * y3 * e7 * e4 * y1 ^ 2 * e6 * y2 + -32 * e1 * y2 ^ 2 * y3 ^ 3 * x2 * e3 * e5 * y1 + -32 * e1 * y2 ^ 2 * y3 ^ 3 * x2 * e3 * e6 * y1 + -16 * e1 * y2 ^ 2 * y3 ^ 3 * x3 * e3 * e5 * y1 + -16 * e1 * y2 ^ 2 * y3 ^ 3 * x3 * e3 * e6 * y1 + -16 * e1 * y2 ^ 2 * y3 ^ 2 * e4 * y1 ^ 2 * e5 + -16 * e1 * y2 ^ 2 * y3 ^ 2 * e4 * y1 ^ 2 * e6 + -16 * e1 * y3 ^ 2 * x2 * e3 ^ 2 * x3 * e5 * y1 * y2 + -16 * e1 * y3 ^ 2 * x2 * e3 ^ 2 * x3 * e6 * y1 * y2 - -8 * e1 * y2 ^ 2 * x3 * e3 * e4 * y1 ^ 2 * e5 - -8 * e1 * y2 ^ 2 * x3 * e3 * e4 * y1 ^ 2 * e6 + -16 * e1 * y3 * x2 * e3 * e4 * y2 ^ 2 * e5 * y1 + -16 * e1 * y3 * x2 * e3 * e4 * y2 ^ 2 * e6 * y1 + -16 * e1 * y3 * x2 * e3 * e4 * y1 ^ 2 * e5 * y2 + -16 * e1 * y3 * x2 * e3 * e4 * y1 ^ 2 * e6 * y2 + -8 * e1 * y3 * x3 * e3 * e4 * y2 ^ 2 * e5 * y1 + -8 * e1 * y3 * x3 * e3 * e4 * y2 ^ 2 * e6 * y1 + -8 * e1 * y3 * x3 * e3 * e4 * y1 ^ 2 * e5 * y2 + -8 * e1 * y3 * x3 * e3 * e4 * y1 ^ 2 * e6 * y2 + -12 * e6 ^ 2 * e7 * y1 * y2 * x1 * e1 ^ 2 + 2 * x1 * e1 ^ 3 * x2 * e6 ^ 3 + -3 * x1 ^ 2 * e1 ^ 3 * e6 ^ 2 * e7 + 3 * x2 ^ 2 * e1 ^ 3 * e6 ^ 2 * e7 + -3 * e1 ^ 3 * x3 ^ 2 * e6 ^ 2 * e7 + 2 * x1 * e1 ^ 3 * x3 * e6 ^ 3 + -2 * x2 * e1 ^ 3 * x3 * e6 ^ 3 + 3 * x1 ^ 2 * e1 ^ 3 * e7 ^ 2 * e6 + -3 * x2 ^ 2 * e1 ^ 3 * e7 ^ 2 * e6 + 4 * e6 ^ 3 * y1 * y2 * x1 * e1 ^ 2 + -4 * e6 ^ 3 * y1 * y2 * x2 * e1 ^ 2 + 12 * e6 ^ 2 * e7 * y1 * y2 * x2 * e1 ^ 2 + -12 * e7 ^ 2 * y1 * e6 * y2 * x1 * e1 ^ 2 + -12 * e7 ^ 2 * y1 * e6 * y2 * x2 * e1 ^ 2 + e1 * e6 ^ 5 + -3 * e1 ^ 3 * x3 ^ 2 * e7 ^ 2 * e6 - 2 * e6 ^ 3 * x1 * e1 ^ 2 * e5 - -2 * e6 ^ 3 * x2 * e1 ^ 2 * e5 - 2 * e6 ^ 3 * e1 ^ 2 * x3 * e5 - -6 * e6 ^ 3 * e7 * x1 * e1 ^ 2 - 6 * e6 ^ 3 * e7 * x2 * e1 ^ 2 - -6 * e6 ^ 2 * e7 ^ 2 * x1 * e1 ^ 2 - 6 * e6 ^ 2 * e7 ^ 2 * x2 * e1 ^ 2 - -6 * e6 ^ 3 * e1 ^ 2 * x3 * e7 - 6 * e6 ^ 2 * e1 ^ 2 * x3 * e7 ^ 2 + -6 * x1 * e1 ^ 3 * x2 * e6 ^ 2 * e7 + 6 * x1 * e1 ^ 3 * x2 * e7 ^ 2 * e6 + -6 * x1 * e1 ^ 3 * x3 * e7 ^ 2 * e6 + 6 * x2 * e1 ^ 3 * x3 * e7 ^ 2 * e6 - -6 * e5 * x1 * e1 ^ 2 * e7 ^ 2 * e6 - 6 * e5 * x2 * e1 ^ 2 * e7 ^ 2 * e6 - -6 * e5 * e1 ^ 2 * x3 * e7 ^ 2 * e6 - 6 * e5 * e6 ^ 2 * e7 * x1 * e1 ^ 2 - -6 * e5 * e6 ^ 2 * e7 * x2 * e1 ^ 2 + 4 * e6 ^ 3 * e1 ^ 2 * x3 * y1 * y2 + -12 * y1 * y2 * e1 ^ 2 * x3 * e6 ^ 2 * e7 + 6 * x1 * e1 ^ 3 * x3 * e6 ^ 2 * e7 + -6 * x2 * e1 ^ 3 * x3 * e6 ^ 2 * e7 - 6 * e6 ^ 2 * e1 ^ 2 * x3 * e7 * e5 + -12 * y1 * y2 * e1 ^ 2 * x3 * e7 ^ 2 * e6 + 2 * x1 * e1 ^ 3 * x2 * e7 ^ 3 + -2 * x1 * e1 ^ 3 * x3 * e7 ^ 3 + 2 * x2 * e1 ^ 3 * x3 * e7 ^ 3 - -2 * e5 * x1 * e1 ^ 2 * e7 ^ 3 - 2 * e5 * x2 * e1 ^ 2 * e7 ^ 3 - -2 * e5 * e1 ^ 2 * x3 * e7 ^ 3 - 2 * e6 * e1 ^ 2 * x3 * e7 ^ 3 - -2 * e6 * x1 * e1 ^ 2 * e7 ^ 3 - 2 * e6 * x2 * e1 ^ 2 * e7 ^ 3 - -4 * e1 * e6 ^ 4 * y1 * y2 + 4 * e1 * e6 ^ 3 * y1 ^ 2 * y2 ^ 2 + -6 * e1 * e6 ^ 3 * e7 * e5 + 3 * e1 * e5 ^ 2 * e6 ^ 2 * e7 + -3 * e1 * e5 ^ 2 * e6 * e7 ^ 2 + 6 * e1 * e5 * e6 ^ 2 * e7 ^ 2 + -2 * e1 * e5 * e6 * e7 ^ 3 + 4 * e1 * y1 ^ 2 * y2 ^ 2 * e7 ^ 3 + -4 * y1 * y2 * x1 * e1 ^ 2 * e7 ^ 3 + 4 * y1 * y2 * x2 * e1 ^ 2 * e7 ^ 3 + -4 * y1 * y2 * e1 ^ 2 * x3 * e7 ^ 3 - 4 * e1 * e6 ^ 3 * y1 * e5 * y2 - -12 * e1 * e6 ^ 3 * e7 * y1 * y2 + 12 * e1 * e6 ^ 2 * e7 * y1 ^ 2 * y2 ^ 2 - -12 * e1 * e6 ^ 2 * e7 * y1 * e5 * y2 - 12 * e1 * e7 ^ 2 * y1 * e5 * y2 * e6 - -12 * e1 * e7 ^ 2 * y1 * e6 ^ 2 * y2 + 12 * e1 * e7 ^ 2 * y1 ^ 2 * e6 * y2 ^ 2 - -4 * e1 * e5 * y1 * y2 * e7 ^ 3 - 4 * e1 * e6 * y1 * y2 * e7 ^ 3. diff --git a/stdlib/test-suite/complexity/ring.v b/stdlib/test-suite/complexity/ring.v deleted file mode 100644 index 79800ffe4f13..000000000000 --- a/stdlib/test-suite/complexity/ring.v +++ /dev/null @@ -1,8 +0,0 @@ -(* This example, checks the efficiency of the abstract machine used by ring *) -(* Expected time < 1.00s *) - -From Stdlib Require Import ZArith. -Open Scope Z_scope. -Goal forall a, a+a+a+a+a+a+a+a+a+a+a+a+a = a*13. -Timeout 5 Time intro; ring. -Abort. diff --git a/stdlib/test-suite/complexity/ring2.v b/stdlib/test-suite/complexity/ring2.v deleted file mode 100644 index fc443700e03e..000000000000 --- a/stdlib/test-suite/complexity/ring2.v +++ /dev/null @@ -1,53 +0,0 @@ -(* This example checks the efficiency of the abstract machine used by ring *) -(* Expected time < 1.00s *) - -From Stdlib Require Import BinInt Zbool. - -Definition Zadd x y := -match x with -| 0%Z => y -| Zpos x' => - match y with - | 0%Z => x - | Zpos y' => Zpos (x' + y') - | Zneg y' => - match (x' ?= y')%positive with - | Eq => 0%Z - | Lt => Zneg (y' - x') - | Gt => Zpos (x' - y') - end - end -| Zneg x' => - match y with - | 0%Z => x - | Zpos y' => - match (x' ?= y')%positive with - | Eq => 0%Z - | Lt => Zpos (y' - x') - | Gt => Zneg (x' - y') - end - | Zneg y' => Zneg (x' + y') - end -end. - - -From Stdlib Require Import Ring. - -Lemma Zth : ring_theory Z0 (Zpos xH) Zadd Z.mul Z.sub Z.opp (@eq Z). -Admitted. - -Ltac Zcst t := - match isZcst t with - true => t - | _ => constr:(NotConstant) - end. - -Add Ring Zr : Zth - (decidable Zeq_bool_eq, constants [Zcst]). - -Open Scope Z_scope. -Infix "+" := Zadd : Z_scope. - -Goal forall a, a+a+a+a+a+a+a+a+a+a+a+a+a = a*13. -Timeout 5 Time intro; ring. -Abort. diff --git a/stdlib/test-suite/complexity/vm_extgcd.v b/stdlib/test-suite/complexity/vm_extgcd.v deleted file mode 100644 index 3fb1c9d268dc..000000000000 --- a/stdlib/test-suite/complexity/vm_extgcd.v +++ /dev/null @@ -1,10 +0,0 @@ -(* Euclidian algorithm defined by fuel-assisted well-founded recrsion on Z *) -(* Expected time < 1.00s *) - -From Stdlib Require Import ZArith Znumtheory. Local Open Scope Z_scope. -Goal True. - Time - let x := constr:(let '(a,b,c) := extgcd 2 (2^19937-1) in Z.odd (a+b+c)) in - let y := eval vm_compute in x in - first [constr_eq y true | constr_eq y false]. -Abort. diff --git a/stdlib/test-suite/ltac2/notations.v b/stdlib/test-suite/ltac2/notations.v deleted file mode 100644 index 64488675bd1f..000000000000 --- a/stdlib/test-suite/ltac2/notations.v +++ /dev/null @@ -1,43 +0,0 @@ -From Ltac2 Require Import Ltac2. -From Stdlib Require Import ZArith String List. - -(** * Test cases for the notation system itself *) - -Open Scope Z_scope. - -Check 1 + 1 : Z. - -Ltac2 Notation "ex" arg(constr(nat,Z)) := arg. - -Check (1 + 1)%nat%Z = 1%nat. - -Lemma two : nat. - refine (ex (1 + 1)). -Qed. - -Import ListNotations. -Close Scope list_scope. - -Ltac2 Notation "sl" arg(constr(string,list)) := arg. - -Lemma maybe : list bool. -Proof. - refine (sl ["left" =? "right"]). -Qed. - -Lemma Z_add_bounds {amin a amax bmin b bmax : Z}: - amin <= a <= amax -> - bmin <= b <= bmax -> - amin + bmin <= a + b <= amax + bmax. -Admitted. - -Lemma apply l1 l2 v1 v2 u1 u2 : l1 + l2 <= v1 + v2 <= u1 + u2. -Proof. - apply Z_add_bounds. -Admitted. - -(** * Test cases for specific notations with special contexts *) - -(** ** Test eval ... in / reduction tactics *) - -(** Moved to test-suite/output/ltac2_notations_eval_in.v so that the output can be checked s*) diff --git a/stdlib/test-suite/ltac2/preterm_antiquot.v b/stdlib/test-suite/ltac2/preterm_antiquot.v deleted file mode 100644 index b249c6b27e2c..000000000000 --- a/stdlib/test-suite/ltac2/preterm_antiquot.v +++ /dev/null @@ -1,62 +0,0 @@ -From Stdlib Require Import ZArith. -Open Scope Z_scope. - -From Stdlib Require Import Ltac2.Ltac2. - -Ltac2 rec z2nat_preterm x := - let b := eval cbv in (Z.leb $x 0) in - lazy_match! b with - | true => preterm:(O) - | false => - let pred := eval cbv in (Z.pred $x) in - let r := z2nat_preterm pred in - preterm:(S $preterm:r) - end. - - -Ltac2 rec z2nat_constr x := - let b := eval cbv in (Z.leb $x 0) in - lazy_match! b with - | true => constr:(O) - | false => let pred := eval cbv in (Z.pred $x) in - let r := z2nat_constr pred in - constr:(S $r) - end. - -Ltac2 mk_app(a: constr)(b: constr) := - Constr.Unsafe.make (Constr.Unsafe.App a [| b |]). - -Ltac2 rec z2nat_mk_app x := - let b := eval cbv in (Z.leb $x 0) in - lazy_match! b with - | true => Env.instantiate reference:(O) - | false => let pred := eval cbv in (Z.pred $x) in - mk_app (Env.instantiate reference:(S)) (z2nat_mk_app pred) - end. - -(* Time Ltac2 Eval *) -(* let c := z2nat_constr constr:(10000) in *) -(* Message.print (Message.of_constr c). (* 9 secs *) *) - -(* Time Ltac2 Eval *) -(* let c := z2nat_mk_app constr:(10000) in *) -(* Message.print (Message.of_constr c). (* <1 secs *) *) - -Time Ltac2 Eval - let c := z2nat_preterm constr:(10000) in - let c := constr:($preterm:c) in - Message.print (Message.of_constr c). (* 6 secs *) - -(* Time Ltac2 Eval *) -(* let c := z2nat_constr constr:(20000) in *) -(* Message.print (Message.of_constr c). (* 22 secs *) *) - -(* Time Ltac2 Eval *) -(* let c := z2nat_mk_app constr:(20000) in *) -(* Message.print (Message.of_constr c). (* 1.6 secs *) *) - -(* a bit close to stack overflow *) -(* Time Ltac2 Eval *) -(* let c := z2nat_preterm constr:(20000) in *) -(* let c := Constr.pretype c in *) -(* Message.print (Message.of_constr c). (* 32 secs *) *) diff --git a/stdlib/test-suite/micromega/bertot.v b/stdlib/test-suite/micromega/bertot.v deleted file mode 100644 index 0cb8d39fe29f..000000000000 --- a/stdlib/test-suite/micromega/bertot.v +++ /dev/null @@ -1,23 +0,0 @@ -(************************************************************************) -(* *) -(* Micromega: A reflexive tactic using the Positivstellensatz *) -(* *) -(* FrĆ©dĆ©ric Besson (Irisa/Inria) 2006-2008 *) -(* *) -(************************************************************************) - -From Stdlib Require Import ZArith. -From Stdlib Require Import Psatz. - -Open Scope Z_scope. - - - -Goal (forall x y n, - ( ~ x < n /\ x <= n /\ 2 * y = x*(x+1) -> 2 * y = n*(n+1)) - /\ - (x < n /\ x <= n /\ 2 * y = x * (x+1) -> x + 1 <= n /\ 2 *(x+1+y) = (x+1)*(x+2))). -Proof. - intros. - psatz Z 3. -Qed. diff --git a/stdlib/test-suite/micromega/bound.v b/stdlib/test-suite/micromega/bound.v deleted file mode 100644 index 692d25df5a3f..000000000000 --- a/stdlib/test-suite/micromega/bound.v +++ /dev/null @@ -1,29 +0,0 @@ -From Stdlib Require Import ZArith Lia. -Open Scope Z_scope. - -Unset Lia Cache. - -Goal forall x y z, 2 <= x -> - 3 <= x*y -> - 4 <= x*y*z -> - 4^10 <= (x^3*y^2*z)^10. -Proof. - intros. - cbn. - Timeout 10 lia. (* runs forever in 8.15, < 1s *) -Qed. - -Goal forall x, -3 <= x -> - (-3)^3 <= x^3. -Proof. - intros. - Fail lia. - (* but, interval analysis could conclude because the exponent is odd. *) - (* A proof with an explicit case-split *) - assert (0 <= x \/ x <= 0) by lia. - destruct H0. - lia. - assert ( (-x)^3 <= 3^3). - { apply Z.pow_le_mono_l. lia. } - lia. -Qed. diff --git a/stdlib/test-suite/micromega/bug_10158.v b/stdlib/test-suite/micromega/bug_10158.v deleted file mode 100644 index 97d40f8cb8e8..000000000000 --- a/stdlib/test-suite/micromega/bug_10158.v +++ /dev/null @@ -1,48 +0,0 @@ -From Stdlib Require Import ZArith_base. -From Stdlib Require Import Lia. - -Open Scope Z_scope. - -Fixpoint fib (n: nat) : Z := - match n with - | O => 1 - | S O => 1 - | S (S n as p) => fib p + fib n - end. - -Axiom fib_47_computed: fib 47 = 2971215073. - -Lemma fib_bound: - fib 47 < 2 ^ 32. -Proof. - pose proof fib_47_computed. - lia. -Qed. - -From Stdlib Require Import Reals. -From Stdlib Require Import Lra. - -Open Scope R_scope. - -Fixpoint fibr (n: nat) : R := - match n with - | O => 1 - | S O => 1 - | S (S n as p) => fibr p + fibr n - end. - -Axiom fibr_47_computed: fibr 47 = 2971215073. - -Lemma fibr_bound: - fibr 47 < 2 ^ 32. -Proof. - pose proof fibr_47_computed. - lra. -Qed. - -Lemma fibr_bound': - fibr 47 < IZR (Z.pow_pos 2 32). -Proof. - pose proof fibr_47_computed. - lra. -Qed. diff --git a/stdlib/test-suite/micromega/bug_11089.v b/stdlib/test-suite/micromega/bug_11089.v deleted file mode 100644 index d5f966bd2275..000000000000 --- a/stdlib/test-suite/micromega/bug_11089.v +++ /dev/null @@ -1,13 +0,0 @@ -From Stdlib Require Import Lia. -Unset Lia Cache. -Definition t := nat. -Goal forall (n : t), n = n. -Proof. - intros. - lia. -Qed. -Goal let t' := nat in forall (n : t'), n = n. -Proof. - intros. - lia. -Qed. diff --git a/stdlib/test-suite/micromega/bug_11191a.v b/stdlib/test-suite/micromega/bug_11191a.v deleted file mode 100644 index 4fcad7e69425..000000000000 --- a/stdlib/test-suite/micromega/bug_11191a.v +++ /dev/null @@ -1,6 +0,0 @@ -From Stdlib Require Import ZArith Lia. - -Goal forall p n, (0 < Z.pos (p ^ n))%Z. - intros. - lia. -Qed. diff --git a/stdlib/test-suite/micromega/bug_11191b.v b/stdlib/test-suite/micromega/bug_11191b.v deleted file mode 100644 index 982b456f14f7..000000000000 --- a/stdlib/test-suite/micromega/bug_11191b.v +++ /dev/null @@ -1,6 +0,0 @@ -From Stdlib Require Import ZArith Lia. - -Goal forall p, (0 < Z.pos (p ^ 2))%Z. - intros. - lia. -Qed. diff --git a/stdlib/test-suite/micromega/bug_11270.v b/stdlib/test-suite/micromega/bug_11270.v deleted file mode 100644 index 1d9eb5bc4c27..000000000000 --- a/stdlib/test-suite/micromega/bug_11270.v +++ /dev/null @@ -1,6 +0,0 @@ -From Stdlib Require Import Psatz. -Theorem foo : forall a b, 1 <= S (a + a * S b). -Proof. -intros. -lia. -Qed. diff --git a/stdlib/test-suite/micromega/bug_11436.v b/stdlib/test-suite/micromega/bug_11436.v deleted file mode 100644 index f32f9373c9f2..000000000000 --- a/stdlib/test-suite/micromega/bug_11436.v +++ /dev/null @@ -1,19 +0,0 @@ -From Stdlib Require Import ZArith Lia. -Local Open Scope Z_scope. - -Unset Lia Cache. - -Goal forall a q q0 q1 r r0 r1: Z, - 0 <= a < 2 ^ 64 -> - r1 = 4 * q + r -> - 0 <= r < 4 -> - a = 4 * q0 + r0 -> - 0 <= r0 < 4 -> - a + 4 = 2 ^ 64 * q1 + r1 -> - 0 <= r1 < 2 ^ 64 -> - r = r0. -Proof. - intros. - (* subst. *) - Time lia. -Qed. diff --git a/stdlib/test-suite/micromega/bug_11656.v b/stdlib/test-suite/micromega/bug_11656.v deleted file mode 100644 index b1c9cd219b42..000000000000 --- a/stdlib/test-suite/micromega/bug_11656.v +++ /dev/null @@ -1,11 +0,0 @@ -From Stdlib Require Import Lia. -From Stdlib Require Import NArith. -Open Scope N_scope. - -Goal forall (a b c: N), - a <> 0 -> - c <> 0 -> - a * ((b + 1) * c) <> 0. -Proof. - intros. nia. -Qed. diff --git a/stdlib/test-suite/micromega/bug_12184.v b/stdlib/test-suite/micromega/bug_12184.v deleted file mode 100644 index 8b3c70612b06..000000000000 --- a/stdlib/test-suite/micromega/bug_12184.v +++ /dev/null @@ -1,8 +0,0 @@ -From Stdlib Require Import Lia. -From Stdlib Require Import ZArith. - -Goal forall p : positive, (0 < Z.pos (2^p)%positive)%Z. -Proof. - intros p. - lia. -Qed. diff --git a/stdlib/test-suite/micromega/bug_12210.v b/stdlib/test-suite/micromega/bug_12210.v deleted file mode 100644 index a5438b0a7409..000000000000 --- a/stdlib/test-suite/micromega/bug_12210.v +++ /dev/null @@ -1,19 +0,0 @@ -From Stdlib Require Import PeanoNat Lia. - -Goal forall x, Nat.le x x. -Proof. -intros. -lia. -Qed. - -Goal forall x, Nat.lt x x -> False. -Proof. -intros. -lia. -Qed. - -Goal forall x, Nat.eq x x. -Proof. -intros. -lia. -Qed. diff --git a/stdlib/test-suite/micromega/bug_12790.v b/stdlib/test-suite/micromega/bug_12790.v deleted file mode 100644 index b2eb9f59d8d1..000000000000 --- a/stdlib/test-suite/micromega/bug_12790.v +++ /dev/null @@ -1,8 +0,0 @@ -From Stdlib Require Import Lia. - -Goal forall (a b c d x: nat), -S c = a - b -> x <= x + (S c) * d. -Proof. -intros a b c d x H. -lia. -Qed. diff --git a/stdlib/test-suite/micromega/bug_12791.v b/stdlib/test-suite/micromega/bug_12791.v deleted file mode 100644 index b69e5a354ffc..000000000000 --- a/stdlib/test-suite/micromega/bug_12791.v +++ /dev/null @@ -1,9 +0,0 @@ -From Stdlib Require Import Lia. - -Definition t := nat. - -Goal forall (a b: t), let c := a in b = a -> b = c. -Proof. - intros a b c H. - lia. -Qed. diff --git a/stdlib/test-suite/micromega/bug_13227_1.v b/stdlib/test-suite/micromega/bug_13227_1.v deleted file mode 100644 index 4de563924680..000000000000 --- a/stdlib/test-suite/micromega/bug_13227_1.v +++ /dev/null @@ -1,75 +0,0 @@ -From Stdlib Require Import Lia ZArith. -Open Scope Z_scope. - -Unset Lia Cache. - -Axiom word: Type. - -Goal forall (right left : Z) (length_xs : nat) (r14 : Z) (v : nat) - (x : list word) (x2 x1 r8 q2 q r q0 r0 r3 r10 r13 q1 r1 r9 r2 - r4 q3 q4 r5 q5 r6 q6 r7 q7 q8 q9 q10 r11 q11 r12 q12 q13 q14 - z83 z84 : Z), - z84 = Z.of_nat (Datatypes.length x) - (z83 + 1) -> - 0 < Z.of_nat (Datatypes.length x) - (z83 + 1) -> - z83 = 0 -> - q0 <= 0 -> - 0 <= Z.of_nat v -> - 0 <= Z.of_nat length_xs -> - 0 <= Z.of_nat (Datatypes.length x) -> - Z.of_nat (Datatypes.length x) = Z.of_nat v -> - r14 < 2 ^ 64 -> - 0 <= r14 -> - right - left = 2 ^ 64 * q14 + r14 -> - r13 < 2 ^ 64 -> - 0 <= r13 -> - r10 - x1 = 2 ^ 64 * q13 + r13 -> - r12 < 2 ^ 64 -> - 0 <= r12 -> - q = 2 ^ 64 * q12 + r12 -> - r11 < 2 ^ 64 -> - 0 <= r11 -> - r12 * 2 ^ 3 = 2 ^ 64 * q11 + r11 -> - r10 < 2 ^ 64 -> - 0 <= r10 -> - x1 + r11 = 2 ^ 64 * q10 + r10 -> - r9 < 2 ^ 64 -> - 0 <= r9 -> - r10 + r3 = 2 ^ 64 * q9 + r9 -> - r8 < 2 ^ 64 -> - 0 <= r8 -> - x2 - x1 = 2 ^ 64 * q8 + r8 -> - r7 < 2 ^ 64 -> - 0 <= r7 -> - Z.shiftr r8 4 = 2 ^ 64 * q7 + r7 -> - r6 < 2 ^ 64 -> - 0 <= r6 -> - Z.shiftl r7 3 = 2 ^ 64 * q6 + r6 -> - r5 < 2 ^ 64 -> - 0 <= r5 -> - x1 + r6 = 2 ^ 64 * q5 + r5 -> - r4 < 2 ^ 64 -> - 0 <= r4 -> - r5 - x1 = 2 ^ 64 * q4 + r4 -> - r3 < 2 ^ 64 -> - 0 <= r3 -> - 8 = 2 ^ 64 * q3 + r3 -> - r2 < r3 -> - 0 <= r2 -> - r4 = r3 * q2 + r2 -> - r1 < 2 ^ 64 -> - 0 <= r1 -> - 0 < 2 ^ 64 -> - x2 - r9 = 2 ^ 64 * q1 + r1 -> - r0 < r3 -> - 0 <= r0 -> - 0 < r3 -> - r13 = r3 * q0 + r0 -> - r8 = 2 ^ 4 * q + r -> - r8 = 8 * Z.of_nat (Datatypes.length x) -> - r14 = 8 * Z.of_nat length_xs -> - (r1 = 8 * z84 -> False) -> - False. -Proof. - intros. - Time lia. -Qed. diff --git a/stdlib/test-suite/micromega/bug_13794.v b/stdlib/test-suite/micromega/bug_13794.v deleted file mode 100644 index 92fb3cdc7055..000000000000 --- a/stdlib/test-suite/micromega/bug_13794.v +++ /dev/null @@ -1,39 +0,0 @@ -From Stdlib Require Import Lia ZArith NArith. -Unset Nia Cache. - -Open Scope N_scope. - - -Lemma over (n0 n1 n2 n3 n4 n5 n6 : N) - (e0 : 1 + 8 * n0 = n1 * n1 + n2) - (e1 : n1 - 1 = 2 * n3 + n4) - (e2 : n3 * (1 + n3) = 2 * n5) - (e3 : n2 + 2 * n4 * n1 - n4 = 8 * n6) - (o0 : n4 = 0 \/ n4 = 1) : - n6 = n0 - n5. -Proof. - Time nia. -Qed. - -Lemma over2 (n0 n1 n2 n3 n4 n5 n6 : N) - (e0 : 1 + 8 * n0 = n1 * n1 + n2) - (e1 : n1 + 1 = 2 * n3 + n4) - (e2 : n3 * (1 + n3) = 2 * n5) - (e3 : n2 + 2 * n4 * n1 + n4 = 8 * n6) - (o0 : n4 = 0) : - n6 = n0 + n5. -Proof. - Fail nia. -Abort. - -Open Scope Z_scope. - -Lemma over3 (n1 n2 n3 n4 n5 : Z) - (e : 0 <= n1 /\ 0 <= n2 /\ 0 <= n3 /\ 0 <= n4 - /\ 0 <= n5) - (e1 : n1 + 1 = 20 * n3 + n4) - (e3 : n2 + 2 * n4 * n1 + n4 = 8 * n5) : - n5 = 0. -Proof. -Time Fail nia. -Abort. diff --git a/stdlib/test-suite/micromega/bug_14054.v b/stdlib/test-suite/micromega/bug_14054.v deleted file mode 100644 index 5a051a881ba3..000000000000 --- a/stdlib/test-suite/micromega/bug_14054.v +++ /dev/null @@ -1,47 +0,0 @@ -(* bug 13242 *) - -From Stdlib Require Import Lia. -Fail Add Zify InjTyp id. - -(* bug 14054 *) - -From Stdlib Require Import ZArith. Open Scope Z_scope. -From Stdlib.Init Require Byte. -From Stdlib.Strings Require Byte. -From Stdlib Require Import ZifyClasses Lia. - -Notation byte := Corelib.Init.Byte.byte. - -Module byte. - Definition unsigned(b: byte): Z := Z.of_N (Byte.to_N b). -End byte. - -Section WithA. - Context (A: Type). - Fixpoint tuple(n: nat): Type := - match n with - | O => unit - | S m => A * tuple m - end. -End WithA. - -Module LittleEndian. - Fixpoint combine (n : nat) : forall (bs : tuple byte n), Z := - match n with - | O => fun _ => 0 - | S n => fun bs => Z.lor (byte.unsigned (fst bs)) - (Z.shiftl (combine n (snd bs)) 8) - end. - Lemma combine_bound: forall {n: nat} (t: tuple byte n), - 0 <= LittleEndian.combine n t < 2 ^ (8 * Z.of_nat n). - Admitted. -End LittleEndian. - -#[export] Instance InjByteTuple{n: nat}: InjTyp (tuple byte n) Z := {| - inj := LittleEndian.combine n; - pred x := 0 <= x < 2 ^ (8 * Z.of_nat n); - cstr := @LittleEndian.combine_bound n; -|}. -Fail Add Zify InjTyp InjByteTuple. -Fail Add Zify UnOp InjByteTuple. -Fail Add Zify UnOp X. diff --git a/stdlib/test-suite/micromega/bug_14604.v b/stdlib/test-suite/micromega/bug_14604.v deleted file mode 100644 index e918195b9732..000000000000 --- a/stdlib/test-suite/micromega/bug_14604.v +++ /dev/null @@ -1,15 +0,0 @@ -From Stdlib Require Import ZArith Lia. - -(* mul z n = Z.of_nat n * z *) -Fixpoint mul (x:Z) (n : nat) : Z := -match n with -| O => 0%Z -| S n => mul x n + 1 * x%Z -end. - -Lemma test: forall z : Z, (0 <= z)%Z -> (0 <= mul z 100)%Z. -Proof. -cbn -[Z.mul Z.add]. -intros. -Timeout 2 lia. -Qed. diff --git a/stdlib/test-suite/micromega/bug_15481.v b/stdlib/test-suite/micromega/bug_15481.v deleted file mode 100644 index 821b32c6c465..000000000000 --- a/stdlib/test-suite/micromega/bug_15481.v +++ /dev/null @@ -1,12 +0,0 @@ -From Stdlib Require Import ZArith Lia. -Open Scope Z_scope. - -Unset Lia Cache. - -Goal forall x, - 1 <= x -> - 0 <= x ^ 37. -Proof. - intros. cbn. (* to bypass `zify` rules for ^ *) - lia. -Qed. diff --git a/stdlib/test-suite/micromega/bug_15583.v b/stdlib/test-suite/micromega/bug_15583.v deleted file mode 100644 index fa55af3b49c7..000000000000 --- a/stdlib/test-suite/micromega/bug_15583.v +++ /dev/null @@ -1,37 +0,0 @@ -From Stdlib Require Import ZArith Lia. -Open Scope Z_scope. - -Unset Lia Cache. - -From Stdlib Require Import ZArith. Open Scope Z_scope. -From Stdlib Require Import Lia. - -Goal forall - (w0 w1 w2 q0 q : Z) - (H10 : 0 < w2) - (q1 q2 r3 q3 : Z) - (H8 : 0 <= w0) - (H21 : w1 + - 2 ^ 32 * q2 - 2 ^ 32 * q < 2 ^ 32) - (H15 : 0 <= w2 * q0 + 0) - (H4 : w0 - w1 = 2 ^ 32 * q1 + (w2 * q0 + 0)) - (H19 : w2 = 2 ^ 32 * q3 + r3) - (Hc : w1 + - 2 ^ 32 * q2 - 2 ^ 32 * q > w0) - (H : q0 <= 0) , - False. -Proof. - intros. - lia. -Qed. - -Goal forall (T : Type) (f : T -> nat) (vs1 : T) (w0 w1 w2 : Z), - f vs1 = Z.to_nat ((w0 - w1) mod 2 ^ 32 / w2) -> - ((w0 - w1) mod 2 ^ 32) mod w2 = 0 -> - 0 <= w0 < 2 ^ 32 -> - 0 <= w1 < 2 ^ 32 -> - 0 <= w2 < 2 ^ 32 -> - (w1 + (w2 mod 2 ^ 32 * Z.of_nat (f vs1)) mod 2 ^ 32) mod 2 ^ 32 = w0. -Proof. - intros. - Z.div_mod_to_equations. - lia. -Qed. diff --git a/stdlib/test-suite/micromega/bug_15791.v b/stdlib/test-suite/micromega/bug_15791.v deleted file mode 100644 index 4423bf8d4bf9..000000000000 --- a/stdlib/test-suite/micromega/bug_15791.v +++ /dev/null @@ -1,17 +0,0 @@ -From Stdlib Require Import Lia. -Unset Lia Cache. -Set Primitive Projections. - -Definition R := nat. -Record S : Set := { regs : R -> nat }. - -Record D := { state : Set }. -Definition Z : D := {| state := S |}. -Arguments state d. - - -Goal forall (r : R) (s : @state Z), regs s r >= 0. -Proof. - intros. - lia. -Qed. diff --git a/stdlib/test-suite/micromega/bug_18158.v b/stdlib/test-suite/micromega/bug_18158.v deleted file mode 100644 index 002e0f373f91..000000000000 --- a/stdlib/test-suite/micromega/bug_18158.v +++ /dev/null @@ -1,91 +0,0 @@ -From Stdlib Require Import ZArith. -Import Lia. -Open Scope Z_scope. - -Lemma shiftr_lbound a n: - 0 <= a -> True -> 0 <= (Z.shiftr a n). -Proof. now intros; apply Z.shiftr_nonneg. Qed. - - -Lemma shiftr_ubound a n b : - 0 <= n -> 0 <= a < b -> (Z.shiftr a n) < b. -Proof. - intros. - rewrite -> Z.shiftr_div_pow2 by assumption. - - apply Zdiv.Zdiv_lt_upper_bound. - - now apply Z.pow_pos_nonneg. - - - eapply Z.lt_le_trans. - 2: apply Z.le_mul_diag_r; try lia. - lia. -Qed. - -Lemma shiftrContractive8 v r : - 0 <= v < 2 ^ 8 -> 0 <= r -> (Z.shiftr v r) < 2 ^ 8. -Proof. - intros; apply shiftr_ubound; assumption. -Qed. - - -Lemma shiftrContractive16 v r : - 0 <= v < 2 ^ 16 -> 0 <= r -> (Z.shiftr v r) < 2 ^ 16. -Proof. - intros; apply shiftr_ubound; assumption. -Qed. - -Lemma shiftrContractive32 v r : - 0 <= v < 2 ^ 32 -> 0 <= r -> (Z.shiftr v r) < 2 ^ 32. -Proof. - intros; apply shiftr_ubound; assumption. -Qed. - -#[global] Instance sat_shiftr_lbound : ZifyClasses.Saturate BinIntDef.Z.shiftr := - {| - ZifyClasses.PArg1 := fun a => 0 <= a; - ZifyClasses.PArg2 := fun b => True; - ZifyClasses.PRes := fun a b ab => 0 <= ab; - ZifyClasses.SatOk := shiftr_lbound - |}. -Add Zify Saturate sat_shiftr_lbound. - -#[global] Instance sat_shiftr_contr_8 : ZifyClasses.Saturate BinIntDef.Z.shiftr := - {| - ZifyClasses.PArg1 := fun a => 0 <= a < 2 ^ 8; - ZifyClasses.PArg2 := fun b => 0 <= b; - ZifyClasses.PRes := fun a b ab => ab < 2 ^ 8; - ZifyClasses.SatOk := shiftrContractive8 - |}. -Add Zify Saturate sat_shiftr_contr_8. - -#[global] Instance sat_shiftr_contr_16 : ZifyClasses.Saturate BinIntDef.Z.shiftr := - {| - ZifyClasses.PArg1 := fun a => 0 <= a < 2 ^ 16; - ZifyClasses.PArg2 := fun b => 0 <= b; - ZifyClasses.PRes := fun a b ab => ab < 2 ^ 16; - ZifyClasses.SatOk := shiftrContractive16 - |}. -Add Zify Saturate sat_shiftr_contr_16. - - -#[global] Instance sat_shiftr_contr_32 : ZifyClasses.Saturate BinIntDef.Z.shiftr := - {| - ZifyClasses.PArg1 := fun a => 0 <= a < 2 ^ 32; - ZifyClasses.PArg2 := fun b => 0 <= b; - ZifyClasses.PRes := fun a b ab => ab < 2 ^ 32; - ZifyClasses.SatOk := shiftrContractive32 - |}. -Add Zify Saturate sat_shiftr_contr_32. - - -Goal forall x y , - Z.le (Z.shiftr x 16) 255 - -> Z.le (Z.shiftr x 8) 255 - -> Z.le (Z.shiftr x 0 ) 255 - -> Z.le (Z.shiftr y 8) 255 - -> Z.le (Z.shiftr x 24) 255. - intros. - Zify.zify_saturate. - (* [xlia zchecker] used to raise a [Stack overflow] error. It is supposed to fail normally. *) - assert_fails (xlia zchecker). -Abort. diff --git a/stdlib/test-suite/micromega/bug_9162.v b/stdlib/test-suite/micromega/bug_9162.v deleted file mode 100644 index 47c7e31bae50..000000000000 --- a/stdlib/test-suite/micromega/bug_9162.v +++ /dev/null @@ -1,8 +0,0 @@ -From Stdlib Require Import ZArith Lia. -Local Open Scope Z_scope. - -Goal Z.of_N (Z.to_N 0) = 0. -Proof. lia. Qed. - -Goal forall q, (Z.of_N (Z.to_N 0) = 0 -> q = 0) -> Z.of_N (Z.to_N 0) = q. -Proof. lia. Qed. diff --git a/stdlib/test-suite/micromega/div_mod.v b/stdlib/test-suite/micromega/div_mod.v deleted file mode 100644 index 3a8fb119fa99..000000000000 --- a/stdlib/test-suite/micromega/div_mod.v +++ /dev/null @@ -1,30 +0,0 @@ -From Stdlib Require Import ZArith Lia ZifyNat. - -(* regression observed in PR 14037 *) -Goal forall (n:nat), n mod 2 < 2 -> n mod 2 = 0 \/ n mod 2 = 1. -Proof. lia. Qed. - -(* regression observed in PR 14037 *) -Goal forall (n:nat), n / 2 < 2 -> n / 2 = 0 \/ n / 2 = 1. -Proof. lia. Qed. - -Goal forall (n:nat), n mod 2 = 0 \/ n mod 2 = 1. -Proof. lia. Qed. - -Goal forall (n:nat), n / 2 < 2 -> n / 2 = 0 \/ n / 2 = 1. -Proof. lia. Qed. - -Goal forall (n:nat), (n * 3) mod 3 = 0. -Proof. lia. Qed. - -Goal forall (n:nat), (n * 3) / 3 = n. -Proof. lia. Qed. - -Goal forall (m n:nat), m > 0 -> (n * m) / m = n. -Proof. nia. Qed. - -Goal forall (m n:nat), m > 0 -> (n * m) mod m = 0. -Proof. nia. Qed. - -Goal forall (n m:nat), 1 <= (1+n)^m. -Proof. lia. Qed. diff --git a/stdlib/test-suite/micromega/evars_loops_in_8_10_fixed_8_11.v b/stdlib/test-suite/micromega/evars_loops_in_8_10_fixed_8_11.v deleted file mode 100644 index f4ed6e00ee67..000000000000 --- a/stdlib/test-suite/micromega/evars_loops_in_8_10_fixed_8_11.v +++ /dev/null @@ -1,4 +0,0 @@ -From Stdlib Require Import Lia. -Goal forall n (B: n >= 0), exists Goal1 Goal2 Goal3, - (0 * (Goal1 * Goal2 + Goal1) <> Goal3 * 0 * (Goal1 * S Goal2)). -Proof. eexists _, _, _. Fail lia. Abort. diff --git a/stdlib/test-suite/micromega/example.v b/stdlib/test-suite/micromega/example.v deleted file mode 100644 index 1ce0cf80bd55..000000000000 --- a/stdlib/test-suite/micromega/example.v +++ /dev/null @@ -1,427 +0,0 @@ -(************************************************************************) -(* *) -(* Micromega: A reflexive tactic using the Positivstellensatz *) -(* *) -(* FrĆ©dĆ©ric Besson (Irisa/Inria) 2006-2008 *) -(* *) -(************************************************************************) - -From Stdlib Require Import ZArith. -From Stdlib Require Import Psatz. -Open Scope Z_scope. -From Stdlib Require Import ZMicromega. -From Stdlib Require Import VarMap. - -Lemma power_pos : forall x y, 0 <= x \/ False -> x^ y >= 0. -Proof. - intros. - lia. -Qed. - -Lemma not_so_easy : forall x n : Z, - 2*x + 1 <= 2 *n -> x <= n-1. -Proof. - intros. - psatz Z 2. -Qed. - - - -(* From Laurent ThĆ©ry *) - -Goal forall (x y : Z), x = 0 -> x * y = 0. -Proof. - intros. - psatz Z 2. -Qed. - -Goal forall (x y : Z), x = 0 -> x * y = 0. -Proof. - intros. - psatz Z 2. -Qed. - -Goal forall (x y : Z), 2*x = 0 -> x * y = 0. -Proof. - intros. - psatz Z 2. -Qed. - - -Goal forall (x y: Z), - x*x >= 0 -> x * y = 0. -Proof. - intros. - psatz Z 4. -Qed. - -Lemma some_pol : forall x, 4 * x ^ 2 + 3 * x + 2 >= 0. -Proof. - intros. - psatz Z 2. -Qed. - -Lemma Zdiscr: forall a b c x, - a * x ^ 2 + b * x + c = 0 -> b ^ 2 - 4 * a * c >= 0. -Proof. - intros ; psatz Z 4. -Qed. - - -Lemma plus_minus : forall x y, - 0 = x + y -> 0 = x -y -> 0 = x /\ 0 = y. -Proof. - intros. - psatz Z 1. -Qed. - -Lemma mplus_minus : forall x y, - x + y >= 0 -> x -y >= 0 -> x^2 - y^2 >= 0. -Proof. - intros; psatz Z 2. -Qed. - -Lemma pol3: forall x y, 0 <= x + y -> - x^3 + 3*x^2*y + 3*x* y^2 + y^3 >= 0. -Proof. - intros; psatz Z 4. -Qed. - - -(* Motivating example from: Expressiveness + Automation + Soundness: - Towards COmbining SMT Solvers and Interactive Proof Assistants *) -Parameter rho : Z. -Parameter rho_ge : rho >= 0. -Parameter correct : Z -> Z -> Prop. - - -Definition rbound1 (C:Z -> Z -> Z) : Prop := - forall p s t, correct p t /\ s <= t -> C p t - C p s <= (1-rho)*(t-s). - -Definition rbound2 (C:Z -> Z -> Z) : Prop := - forall p s t, correct p t /\ s <= t -> (1-rho)*(t-s) <= C p t - C p s. - - -Lemma bounded_drift : forall s t p q C D, s <= t /\ correct p t /\ correct q t /\ - rbound1 C /\ rbound2 C /\ rbound1 D /\ rbound2 D -> - Z.abs (C p t - D q t) <= Z.abs (C p s - D q s) + 2 * rho * (t- s). -Proof. - intros. - generalize (Z.abs_eq (C p t - D q t)). - generalize (Z.abs_neq (C p t - D q t)). - generalize (Z.abs_eq (C p s -D q s)). - generalize (Z.abs_neq (C p s - D q s)). - unfold rbound2 in H. - unfold rbound1 in H. - intuition. - generalize (H6 _ _ _ (conj H H4)). - generalize (H7 _ _ _ (conj H H4)). - generalize (H8 _ _ _ (conj H H4)). - generalize (H10 _ _ _ (conj H H4)). - generalize (H6 _ _ _ (conj H5 H4)). - generalize (H7 _ _ _ (conj H5 H4)). - generalize (H8 _ _ _ (conj H5 H4)). - generalize (H10 _ _ _ (conj H5 H4)). - generalize rho_ge. - zify; intuition subst ; psatz Z 2. -Qed. - -(* Rule of signs *) - -Lemma sign_pos_pos: forall x y, - x > 0 -> y > 0 -> x*y > 0. -Proof. - intros; psatz Z 2. -Qed. - -Lemma sign_pos_zero: forall x y, - x > 0 -> y = 0 -> x*y = 0. -Proof. - intros; psatz Z 2. -Qed. - -Lemma sign_pos_neg: forall x y, - x > 0 -> y < 0 -> x*y < 0. -Proof. - intros; psatz Z 2. -Qed. - -Lemma sign_zero_pos: forall x y, - x = 0 -> y > 0 -> x*y = 0. -Proof. - intros; psatz Z 2. -Qed. - -Lemma sign_zero_neg: forall x y, - x = 0 -> y < 0 -> x*y = 0. -Proof. - intros; psatz Z 2. -Qed. - -Lemma sign_neg_pos: forall x y, - x < 0 -> y > 0 -> x*y < 0. -Proof. - intros; psatz Z 2. -Qed. - -Lemma sign_neg_zero: forall x y, - x < 0 -> y = 0 -> x*y = 0. -Proof. - intros; psatz Z 2. -Qed. - -Lemma sign_neg_neg: forall x y, - x < 0 -> y < 0 -> x*y > 0. -Proof. - intros; psatz Z 2. -Qed. - - -(* Other (simple) examples *) - -Lemma product : forall x y, x >= 0 -> y >= 0 -> x * y >= 0. -Proof. - intros. - psatz Z 2. -Qed. - - -Lemma pow_2_pos : forall x, x ^ 2 + 1 = 0 -> False. -Proof. - intros ; psatz Z 2. -Qed. - -(* Found in Parrilo's talk *) -(* BUG?: certificate with **very** big coefficients *) -Lemma parrilo_ex : forall x y, x - y^2 + 3 >= 0 -> y + x^2 + 2 = 0 -> False. -Proof. - intros. - psatz Z 2. -Qed. - -(* from hol_light/Examples/sos.ml *) - -Lemma hol_light1 : forall a1 a2 b1 b2, - a1 >= 0 -> a2 >= 0 -> - (a1 * a1 + a2 * a2 = b1 * b1 + b2 * b2 + 2) -> - (a1 * b1 + a2 * b2 = 0) -> a1 * a2 - b1 * b2 >= 0. -Proof. - intros ; psatz Z 4. -Qed. - - -Lemma hol_light2 : forall x a, - 3 * x + 7 * a < 4 -> 3 < 2 * x -> a < 0. -Proof. - intros ; psatz Z 2. -Qed. - -Lemma hol_light3 : forall b a c x, - b ^ 2 < 4 * a * c -> (a * x ^2 + b * x + c = 0) -> False. -Proof. -intros ; psatz Z 4. -Qed. - -Lemma hol_light4 : forall a c b x, - a * x ^ 2 + b * x + c = 0 -> b ^ 2 >= 4 * a * c. -Proof. -intros ; psatz Z 4. -Qed. - -Lemma hol_light5 : forall x y, - 0 <= x /\ x <= 1 /\ 0 <= y /\ y <= 1 - -> x ^ 2 + y ^ 2 < 1 \/ - (x - 1) ^ 2 + y ^ 2 < 1 \/ - x ^ 2 + (y - 1) ^ 2 < 1 \/ - (x - 1) ^ 2 + (y - 1) ^ 2 < 1. -Proof. -intros; psatz Z 3. -Qed. - -Lemma hol_light7 : forall x y z, - 0<= x /\ 0 <= y /\ 0 <= z /\ x + y + z <= 3 - -> x * y + x * z + y * z >= 3 * x * y * z. -Proof. -intros ; psatz Z 3. -Qed. - -Lemma hol_light8 : forall x y z, - x ^ 2 + y ^ 2 + z ^ 2 = 1 -> (x + y + z) ^ 2 <= 3. -Proof. - intros ; psatz Z 2. -Qed. - -Lemma hol_light9 : forall w x y z, - w ^ 2 + x ^ 2 + y ^ 2 + z ^ 2 = 1 - -> (w + x + y + z) ^ 2 <= 4. -Proof. - intros; psatz Z 2. -Qed. - - -Lemma hol_light10 : forall x y, - x >= 1 /\ y >= 1 -> x * y >= x + y - 1. -Proof. - intros ; psatz Z 2. -Qed. - -Lemma hol_light11 : forall x y, - x > 1 /\ y > 1 -> x * y > x + y - 1. -Proof. - intros ; psatz Z 2. -Qed. - - -Lemma hol_light12: forall x y z, - 2 <= x /\ x <= 125841 / 50000 /\ - 2 <= y /\ y <= 125841 / 50000 /\ - 2 <= z /\ z <= 125841 / 50000 - -> 2 * (x * z + x * y + y * z) - (x * x + y * y + z * z) >= 0. -Proof. - intros x y z ; set (e:= (125841 / 50000)). - compute in e. - unfold e ; intros ; psatz Z 2. -Qed. - - -Lemma hol_light14 : forall x y z, - 2 <= x /\ x <= 4 /\ 2 <= y /\ y <= 4 /\ 2 <= z /\ z <= 4 - -> 12 <= 2 * (x * z + x * y + y * z) - (x * x + y * y + z * z). -Proof. - intros ;psatz Z 2. -Qed. - -(* ------------------------------------------------------------------------- *) -(* Inequality from sci.math (see "Leon-Sotelo, por favor"). *) -(* ------------------------------------------------------------------------- *) - -Lemma hol_light16 : forall x y, - 0 <= x /\ 0 <= y /\ (x * y = 1) - -> x + y <= x ^ 2 + y ^ 2. -Proof. - intros ; psatz Z 2. -Qed. - -Lemma hol_light17 : forall x y, - 0 <= x /\ 0 <= y /\ (x * y = 1) - -> x * y * (x + y) <= x ^ 2 + y ^ 2. -Proof. - intros ; psatz Z 3. -Qed. - - -Lemma hol_light18 : forall x y, - 0 <= x /\ 0 <= y -> x * y * (x + y) ^ 2 <= (x ^ 2 + y ^ 2) ^ 2. -Proof. - intros ; psatz Z 4. -Qed. - -(* ------------------------------------------------------------------------- *) -(* Some examples over integers and natural numbers. *) -(* ------------------------------------------------------------------------- *) - -Lemma hol_light22 : forall n, n >= 0 -> n <= n * n. -Proof. - intros. - psatz Z 2. -Qed. - -Lemma hol_light24 : forall x1 y1 x2 y2, x1 >= 0 -> x2 >= 0 -> y1 >= 0 -> y2 >= 0 -> - ((x1 + y1) ^2 + x1 + 1 = (x2 + y2) ^ 2 + x2 + 1) - -> (x1 + y1 = x2 + y2). -Proof. - intros. - psatz Z 2. -Qed. - -Lemma motzkin' : forall x y, (x^2+y^2+1)*(x^2*y^4 + x^4*y^2 + 1 - 3*x^2*y^2) >= 0. -Proof. - intros. - psatz Z 1. -Qed. - -Lemma motzkin : forall x y, (x^2*y^4 + x^4*y^2 + 1 - 3*x^2*y^2) >= 0. -Proof. - intros. - generalize (motzkin' x y). - psatz Z 8. -Qed. - -(** Other tests *) - -Goal forall x y z n, - y >= z /\ y = n \/ ~ y >= z /\ z = n -> - x >= y /\ - (x >= z /\ (x >= n /\ x = x \/ ~ x >= n /\ x = n) \/ - ~ x >= z /\ (x >= n /\ z = x \/ ~ x >= n /\ z = n)) \/ - ~ x >= y /\ - (y >= z /\ (x >= n /\ y = x \/ ~ x >= n /\ y = n) \/ - ~ y >= z /\ (x >= n /\ z = x \/ ~ x >= n /\ z = n)). -Proof. - intros. - psatz Z 2. -Qed. - -(** Incompeteness: require manual case split *) -Goal forall (z0 z z1 z2 z3 z5 :Z) -(H8 : 0 <= z2) -(H5 : z5 > 0) -(H0 : z0 > 0) -(H9 : z2 < z0) -(H1 : z0 * z5 > 0) -(H10 : 0 <= z1 * z0 + z0 * z5 - 1 - z0 * z5 * z) -(H11 : z1 * z0 + z0 * z5 - 1 - z0 * z5 * z < z0 * z5) -(H6 : 0 <= z0 * z1 + z2 - z0 + 1 + z0 * z5 - 1 - z0 * z5 * z3) -(H7 : z0 * z1 + z2 - z0 + 1 + z0 * z5 - 1 - z0 * z5 * z3 < z0 * z5) -(C : z > z3), False. -Proof. - intros. - assert (z1 - z5 * z3 - 1 < 0) by psatz Z 3. - psatz Z 3. -Qed. - -Goal forall - (d sz x n : Z) - (GE : sz * x - sz * d >=1 ) - (R : sz + d * sz - sz * x >= 1), - False. -Proof. - intros. - assert (x - d >= 1) by psatz Z 3. - psatz Z 3. -Qed. - - -Goal forall x6 x8 x9 x10 x11 x12 x13 x14, - x6 >= 0 -> - -x6 + x8 + x9 + -x10 >= 1 -> - x8 >= 0 -> - x11 >= 0 -> - -x11 + x12 + x13 + -x14 >= 1 -> - x6 + -4*x8 + -2*x9 + 3*x10 + x11 + -4*x12 + -2*x13 + 3*x14 >= -5 -> - x10 >= 0 -> - x14 >= 0 -> - x12 >= 0 -> - x8 + -x10 + x12 + -x14 >= 1 -> - False. -Proof. - intros. - psatz Z 1. -Qed. - -Goal forall x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12, -x2 + -1*x4 >= 0 -> --2*x2 + x4 >= -1 -> -x1 + x3 + x4 + -1*x7 + -1*x11 >= 1 -> --1*x2 + x8 + x10 >= 0 -> --2*x3 + -2*x4 + x5 + 2*x6 + x9 >= -1 -> --2*x1 + 3*x3 + x4 + -1*x7 + -1*x11 >= 0 -> --2*x1 + x3 + x4 + -1*x8 + -1*x10 + 2*x12 >= 0 -> --2*x2 + x3 + x4 + -1*x7 + -1*x11 + 2*x12 >= 0 -> --2*x2 + x3 + 3*x4 + -1*x8 + -1*x10 >= 0 -> -2*x2 + -1*x3 + -1*x4 + x5 + 2*x6 + -2*x8 + x9 + -2*x10 >= 0 -> -x1 + -2*x3 + x7 + x11 + -2*x12 >= 0 -> - False. -Proof. - intros. - psatz Z 1. -Qed. diff --git a/stdlib/test-suite/micromega/example_nia.v b/stdlib/test-suite/micromega/example_nia.v deleted file mode 100644 index 4dd78746b38c..000000000000 --- a/stdlib/test-suite/micromega/example_nia.v +++ /dev/null @@ -1,536 +0,0 @@ -(************************************************************************) -(* *) -(* Micromega: A reflexive tactic using the Positivstellensatz *) -(* *) -(* FrĆ©dĆ©ric Besson (Irisa/Inria) 2006-2008 *) -(* *) -(************************************************************************) - -From Stdlib Require Import ZArith. -Open Scope Z_scope. -From Stdlib Require Import ZMicromega Lia. -From Stdlib Require Import VarMap. -Unset Nia Cache. - -Goal forall (x y: Z), 0 < (1+y^2)^(x^2). -Proof. nia. Qed. - -Goal forall (x y: Z), 0 <= (y^2)^x. -Proof. nia. Qed. - -(* false in Q : x=1/2 and n=1 *) - -Lemma int_not_rat : forall x, 2 * x = 1 -> False. -Proof. - intros. - lia. -Qed. - - -Lemma not_so_easy : forall x n : Z, - 2*x + 1 <= 2 *n -> x <= n-1. -Proof. - intros. - lia. -Qed. - -Goal forall a1 da na b1 db nb, - a1 * da = na -> - b1 * db = nb -> - a1 * b1 * da * db = na * nb. -Proof. - intros. - nia. -Qed. - -(* From Laurent ThĆ©ry *) - -Goal forall (x y : Z), x = 0 -> x * y = 0. -Proof. - intros. - nia. -Qed. - -Goal forall (x y : Z), x = 0 -> x * y = 0. -Proof. - intros. - nia. -Qed. - -Goal forall (x y : Z), 2*x = 0 -> x * y = 0. -Proof. - intros. - nia. -Qed. - - -Goal forall (x y: Z), - x*x >= 0 -> x * y = 0. -Proof. - intros. - nia. -Qed. - -Lemma some_pol : forall x, 4 * x ^ 2 + 3 * x + 2 >= 0. -Proof. - intros. - nia. -Qed. - - -Lemma Zdiscr: forall a b c x, - a * x ^ 2 + b * x + c = 0 -> b ^ 2 - 4 * a * c >= 0. -Proof. - intros. - Fail nia. (* Incompletness *) -Abort. - - -Lemma plus_minus : forall x y, - 0 = x + y -> 0 = x -y -> 0 = x /\ 0 = y. -Proof. - intros. - lia. -Qed. - - -Lemma mplus_minus : forall x y, - x + y >= 0 -> x -y >= 0 -> x^2 - y^2 >= 0. -Proof. - intros; nia. -Qed. - -Lemma pol3: forall x y, 0 <= x + y -> - x^3 + 3*x^2*y + 3*x* y^2 + y^3 >= 0. -Proof. - intros. - Fail nia. -Abort. - - -(* Motivating example from: Expressiveness + Automation + Soundness: - Towards COmbining SMT Solvers and Interactive Proof Assistants *) -Parameter rho : Z. -Parameter rho_ge : rho >= 0. -Parameter correct : Z -> Z -> Prop. - - -Definition rbound1 (C:Z -> Z -> Z) : Prop := - forall p s t, correct p t /\ s <= t -> C p t - C p s <= (1-rho)*(t-s). - -Definition rbound2 (C:Z -> Z -> Z) : Prop := - forall p s t, correct p t /\ s <= t -> (1-rho)*(t-s) <= C p t - C p s. - - -Lemma bounded_drift : forall s t p q C D, s <= t /\ correct p t /\ correct q t /\ - rbound1 C /\ rbound2 C /\ rbound1 D /\ rbound2 D -> - Z.abs (C p t - D q t) <= Z.abs (C p s - D q s) + 2 * rho * (t- s). -Proof. - intros. - generalize (Z.abs_eq (C p t - D q t)). - generalize (Z.abs_neq (C p t - D q t)). - generalize (Z.abs_eq (C p s -D q s)). - generalize (Z.abs_neq (C p s - D q s)). - unfold rbound2 in H. - unfold rbound1 in H. - intuition. - generalize (H6 _ _ _ (conj H H4)). - generalize (H7 _ _ _ (conj H H4)). - generalize (H8 _ _ _ (conj H H4)). - generalize (H10 _ _ _ (conj H H4)). - generalize (H6 _ _ _ (conj H5 H4)). - generalize (H7 _ _ _ (conj H5 H4)). - generalize (H8 _ _ _ (conj H5 H4)). - generalize (H10 _ _ _ (conj H5 H4)). - generalize rho_ge. - nia. -Qed. - -(* Rule of signs *) - -Lemma sign_pos_pos: forall x y, - x > 0 -> y > 0 -> x*y > 0. -Proof. - intros; nia. -Qed. - -Lemma sign_pos_zero: forall x y, - x > 0 -> y = 0 -> x*y = 0. -Proof. - intros; nia. -Qed. - -Lemma sign_pos_neg: forall x y, - x > 0 -> y < 0 -> x*y < 0. -Proof. - intros; nia. -Qed. - -Lemma sign_zero_pos: forall x y, - x = 0 -> y > 0 -> x*y = 0. -Proof. - intros; nia. -Qed. - -Lemma sign_zero_zero: forall x y, - x = 0 -> y = 0 -> x*y = 0. -Proof. - intros; nia. -Qed. - -Lemma sign_zero_neg: forall x y, - x = 0 -> y < 0 -> x*y = 0. -Proof. - intros; nia. -Qed. - -Lemma sign_neg_pos: forall x y, - x < 0 -> y > 0 -> x*y < 0. -Proof. - intros; nia. -Qed. - -Lemma sign_neg_zero: forall x y, - x < 0 -> y = 0 -> x*y = 0. -Proof. - intros; nia. -Qed. - -Lemma sign_neg_neg: forall x y, - x < 0 -> y < 0 -> x*y > 0. -Proof. - intros; nia. -Qed. - - -(* Other (simple) examples *) - -Lemma binomial : forall x y, (x+y)^2 = x^2 + 2*x*y + y^2. -Proof. - intros. - lia. -Qed. - -Lemma product : forall x y, x >= 0 -> y >= 0 -> x * y >= 0. -Proof. - intros. - nia. -Qed. - - -Lemma product_strict : forall x y, x > 0 -> y > 0 -> x * y > 0. -Proof. - intros. - nia. -Qed. - - -Lemma pow_2_pos : forall x, x ^ 2 + 1 = 0 -> False. -Proof. - intros. nia. -Qed. - -(* Found in Parrilo's talk *) -(* BUG?: certificate with **very** big coefficients *) -Lemma parrilo_ex : forall x y, x - y^2 + 3 >= 0 -> y + x^2 + 2 = 0 -> False. -Proof. - intros. - nia. -Qed. - -(* from hol_light/Examples/sos.ml *) - -Lemma hol_light1 : forall a1 a2 b1 b2, - a1 >= 0 -> a2 >= 0 -> - (a1 * a1 + a2 * a2 = b1 * b1 + b2 * b2 + 2) -> - (a1 * b1 + a2 * b2 = 0) -> a1 * a2 - b1 * b2 >= 0. -Proof. - intros. - Fail nia. -Abort. - -Lemma hol_light2 : forall x a, - 3 * x + 7 * a < 4 -> 3 < 2 * x -> a < 0. -Proof. - intros; nia. -Qed. - -Lemma hol_light3 : forall b a c x, - b ^ 2 < 4 * a * c -> (a * x ^2 + b * x + c = 0) -> False. -Proof. - intros. - Fail nia. -Abort. - - -Lemma hol_light4 : forall a c b x, - a * x ^ 2 + b * x + c = 0 -> b ^ 2 >= 4 * a * c. -Proof. - intros. - Fail nia. -Abort. - -Lemma hol_light5 : forall x y, - 0 <= x /\ x <= 1 /\ 0 <= y /\ y <= 1 - -> x ^ 2 + y ^ 2 < 1 \/ - (x - 1) ^ 2 + y ^ 2 < 1 \/ - x ^ 2 + (y - 1) ^ 2 < 1 \/ - (x - 1) ^ 2 + (y - 1) ^ 2 < 1. -Proof. -intros; nia. -Qed. - -Lemma hol_light7 : forall x y z, - 0<= x /\ 0 <= y /\ 0 <= z /\ x + y + z <= 3 - -> x * y + x * z + y * z >= 3 * x * y * z. -Proof. - intros. - Fail nia. -Abort. - -Lemma hol_light8 : forall x y z, - x ^ 2 + y ^ 2 + z ^ 2 = 1 -> (x + y + z) ^ 2 <= 3. -Proof. - intros. - Fail nia. -Abort. - -Lemma hol_light9 : forall w x y z, - w ^ 2 + x ^ 2 + y ^ 2 + z ^ 2 = 1 - -> (w + x + y + z) ^ 2 <= 4. -Proof. - intros. - Fail nia. -Abort. - - -Lemma hol_light10 : forall x y, - x >= 1 /\ y >= 1 -> x * y >= x + y - 1. -Proof. - intros. - nia. -Qed. - - -Lemma hol_light11 : forall x y, - x > 1 /\ y > 1 -> x * y > x + y - 1. -Proof. - intros ; nia. -Qed. - -Lemma hol_light12: forall x y z, - 2 <= x /\ x <= 125841 / 50000 /\ - 2 <= y /\ y <= 125841 / 50000 /\ - 2 <= z /\ z <= 125841 / 50000 - -> 2 * (x * z + x * y + y * z) - (x * x + y * y + z * z) >= 0. -Proof. - intros x y z ; set (e:= (125841 / 50000)). - compute in e. - unfold e ; intros ; nia. -Qed. - - -Lemma hol_light14 : forall x y z, - 2 <= x /\ x <= 4 /\ 2 <= y /\ y <= 4 /\ 2 <= z /\ z <= 4 - -> 12 <= 2 * (x * z + x * y + y * z) - (x * x + y * y + z * z). -Proof. - intros ; nia. -Qed. - - -(* ------------------------------------------------------------------------- *) -(* Inequality from sci.math (see "Leon-Sotelo, por favor"). *) -(* ------------------------------------------------------------------------- *) - -Lemma hol_light16 : forall x y, - 0 <= x /\ 0 <= y /\ (x * y = 1) - -> x + y <= x ^ 2 + y ^ 2. -Proof. - intros ; nia. -Qed. - -Lemma hol_light17 : forall x y, - 0 <= x /\ 0 <= y /\ (x * y = 1) - -> x * y * (x + y) <= x ^ 2 + y ^ 2. -Proof. - intros. - nia. -Qed. - - -Lemma hol_light18 : forall x y, - 0 <= x /\ 0 <= y -> x * y * (x + y) ^ 2 <= (x ^ 2 + y ^ 2) ^ 2. -Proof. - intros. - Fail nia. -Abort. - -(* ------------------------------------------------------------------------- *) -(* Some examples over integers and natural numbers. *) -(* ------------------------------------------------------------------------- *) - -Lemma hol_light19 : forall m n, 2 * m + n = (n + m) + m. -Proof. - intros ; lia. -Qed. - -Lemma hol_light22 : forall n, n >= 0 -> n <= n * n. -Proof. - intros. - nia. -Qed. - -Lemma hol_light24 : forall x1 y1 x2 y2, x1 >= 0 -> x2 >= 0 -> y1 >= 0 -> y2 >= 0 -> - ((x1 + y1) ^2 + x1 + 1 = (x2 + y2) ^ 2 + x2 + 1) - -> (x1 + y1 = x2 + y2). -Proof. - intros. - nia. -Qed. - -Lemma motzkin' : forall x y, (x^2+y^2+1)*(x^2*y^4 + x^4*y^2 + 1 - 3*x^2*y^2) >= 0. -Proof. - intros. - Fail nia. -Abort. - - -Lemma motzkin : forall x y, (x^2*y^4 + x^4*y^2 + 1 - 3*x^2*y^2) >= 0. -Proof. - intros. - Fail generalize (motzkin' x y). - Fail nia. -Abort. - -(** Other tests *) - -Goal forall x y z n, - y >= z /\ y = n \/ ~ y >= z /\ z = n -> - x >= y /\ - (x >= z /\ (x >= n /\ x = x \/ ~ x >= n /\ x = n) \/ - ~ x >= z /\ (x >= n /\ z = x \/ ~ x >= n /\ z = n)) \/ - ~ x >= y /\ - (y >= z /\ (x >= n /\ y = x \/ ~ x >= n /\ y = n) \/ - ~ y >= z /\ (x >= n /\ z = x \/ ~ x >= n /\ z = n)). -Proof. - intros. - lia. -Qed. - -(** Incompeteness: require manual case split *) -Goal forall (z0 z z1 z2 z3 z5 :Z) -(H8 : 0 <= z2) -(H5 : z5 > 0) -(H0 : z0 > 0) -(H9 : z2 < z0) -(H1 : z0 * z5 > 0) -(H10 : 0 <= z1 * z0 + z0 * z5 - 1 - z0 * z5 * z) -(H11 : z1 * z0 + z0 * z5 - 1 - z0 * z5 * z < z0 * z5) -(H6 : 0 <= z0 * z1 + z2 - z0 + 1 + z0 * z5 - 1 - z0 * z5 * z3) -(H7 : z0 * z1 + z2 - z0 + 1 + z0 * z5 - 1 - z0 * z5 * z3 < z0 * z5) -(C : z > z3), False. -Proof. - intros. - assert (z1 - z5 * z3 - 1 < 0) by nia. - nia. -Qed. - - -Goal forall - (d sz x n : Z) - (GE : sz * x - sz * d >=1 ) - (R : sz + d * sz - sz * x >= 1), - False. -Proof. - (* Manual proof. - assert (H : sz >= 2) by GE + R. - assert (GEd : x - d >= 1 by GE / H - assert (Rd : 1 + d - x >= 1 by R / H) - 1 >= 2 by GEd + Rd - *) - intros. - assert (x - d >= 1) by nia. - nia. -Qed. - - -Goal forall x6 x8 x9 x10 x11 x12 x13 x14, - x6 >= 0 -> - -x6 + x8 + x9 + -x10 >= 1 -> - x8 >= 0 -> - x11 >= 0 -> - -x11 + x12 + x13 + -x14 >= 1 -> - x6 + -4*x8 + -2*x9 + 3*x10 + x11 + -4*x12 + -2*x13 + 3*x14 >= -5 -> - x10 >= 0 -> - x14 >= 0 -> - x12 >= 0 -> - x8 + -x10 + x12 + -x14 >= 1 -> - False. -Proof. - intros. - lia. -Qed. - -Goal forall x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12, -x2 + -1*x4 >= 0 -> --2*x2 + x4 >= -1 -> -x1 + x3 + x4 + -1*x7 + -1*x11 >= 1 -> --1*x2 + x8 + x10 >= 0 -> --2*x3 + -2*x4 + x5 + 2*x6 + x9 >= -1 -> --2*x1 + 3*x3 + x4 + -1*x7 + -1*x11 >= 0 -> --2*x1 + x3 + x4 + -1*x8 + -1*x10 + 2*x12 >= 0 -> --2*x2 + x3 + x4 + -1*x7 + -1*x11 + 2*x12 >= 0 -> --2*x2 + x3 + 3*x4 + -1*x8 + -1*x10 >= 0 -> -2*x2 + -1*x3 + -1*x4 + x5 + 2*x6 + -2*x8 + x9 + -2*x10 >= 0 -> -x1 + -2*x3 + x7 + x11 + -2*x12 >= 0 -> - False. -Proof. - intros. - lia. -Qed. - -(** Needs some cutting plane *) -Goal - forall (m : Z) - (M : Z) - (x : Z) - (i : Z) - (e1 : Z) - (e2 : Z) - (e5 : Z) - (e6 : Z) - (H2 : e5 >= M) - (H11 : i < m) - (H5 : 0 <= i) - (H15 : m < 4294967296) - (H7 : 0 <= x) - (H26 : e5 < 4294967296) - (H21 : x + i = 4294967296 * e6 + e5) - (H9 : x + m = 4294967296 * e2 + e1) - (H12 : x < e1) - (H13 : e1 < M), - False. -Proof. - intros. - lia. -Qed. - -Lemma mult : forall x x0 x1 x2 n n0 n1 n2, - 0 <= x -> 0 <= x0 -> 0 <= x1 -> 0 <= x2 -> - 0 <= n -> 0 <= n0 -> 0 <= n1 -> 0 <= n2 -> - (n1 * x <= n2 * x1) -> - (n * x0 <= n0 * x2) -> - (n1 * n * (x * x0) > n2 * n0 * (x1 * x2)) -> False. -Proof. - intros. - nia. -Qed. - - -Lemma mult_nat : forall x x0 x1 x2 n n0 n1 n2, - (n1 * x <= n2 * x1)%nat -> - (n * x0 <= n0 * x2)%nat -> - (n1 * n * (x * x0) > n2 * n0 * (x1 * x2))%nat -> False. -Proof. - intros. - nia. -Qed. diff --git a/stdlib/test-suite/micromega/heap3_vcgen_25.v b/stdlib/test-suite/micromega/heap3_vcgen_25.v deleted file mode 100644 index 9872fe524f76..000000000000 --- a/stdlib/test-suite/micromega/heap3_vcgen_25.v +++ /dev/null @@ -1,38 +0,0 @@ -(************************************************************************) -(* *) -(* Micromega: A reflexive tactic using the Positivstellensatz *) -(* *) -(* FrĆ©dĆ©ric Besson (Irisa/Inria) 2006-2008 *) -(* *) -(************************************************************************) - -From Stdlib Require Import ZArith. -From Stdlib Require Import Lia. - -Open Scope Z_scope. - -Lemma vcgen_25 : forall - (n : Z) - (m : Z) - (jt : Z) - (j : Z) - (it : Z) - (i : Z) - (H0 : 1 * it + -2 * i + -1 = 0) - (H : 1 * jt + -2 * j + -1 = 0) - (H1 : 1 * n + -10 = 0) - (H2 : 0 <= -4028 * i + 6222 * j + 705 * m + -16674) - (H3 : 0 <= -418 * i + 651 * j + 94 * m + -1866) - (H4 : 0 <= -209 * i + 302 * j + 47 * m + -839) - (H5 : 0 <= -1 * i + 1 * j + -1) - (H6 : 0 <= -1 * j + 1 * m + 0) - (H7 : 0 <= 1 * j + 5 * m + -27) - (H8 : 0 <= 2 * j + -1 * m + 2) - (H9 : 0 <= 7 * j + 10 * m + -74) - (H10 : 0 <= 18 * j + -139 * m + 1188) - (H11 : 0 <= 1 * i + 0) - (H13 : 0 <= 121 * i + 810 * j + -7465 * m + 64350), - (1 = -2 * i + it). -Proof. - intros ; lia. -Qed. diff --git a/stdlib/test-suite/micromega/non_lin_ci.v b/stdlib/test-suite/micromega/non_lin_ci.v deleted file mode 100644 index e033ef4d82df..000000000000 --- a/stdlib/test-suite/micromega/non_lin_ci.v +++ /dev/null @@ -1,278 +0,0 @@ -From Stdlib Require Import ZArith. -From Stdlib Require Import Lia Psatz. -Open Scope Z_scope. - - - - -(* From fiat-crypto Generalized.v *) - - -Goal forall (x1 : Z) (x2 : Z) (x3 : Z) (x4 : Z) (x5 : Z) (x6 : Z) (x7 : Z) (x8 : Z) (x9 : Z) (x10 : Z) (x11 : Z) (x12 : Z) (x13 : Z) (x14 : Z) (x15 : Z) (x16 : Z) (x17 : Z) (x18 : Z) -(H0 : -1 + -x1^2 + x3*x5 + x1^2*x2 + -x2*x3*x4 >= 0) -(H1 : -1 + x4 >= 0) -(H2 : -1 + x6 >= 0) -(H3 : -1 + -x4 + x1 >= 0) -(H4 : x3 + -x7 = 0) -(H5 : x8 >= 0) -(H6 : -1 + x4 >= 0) -(H7 : x9 >= 0) -(H8 : -x8 + x10 >= 0) -(H9 : -1 + x1^2 + -x9 >= 0) -(H10 : x4 + -x11 >= 0) -(H11 : -x3 + x1*x12 + -x12*x13 >= 0) -(H12 : -1 + -x9 + x1*x4 >= 0) -(H13 : -1 + x4 + -x13 >= 0) -(H14 : x13 >= 0) -(H15 : -1 + x5 >= 0) -(H16 : -1 + x1 + -x2 >= 0) -(H17 : x1^2 + -x13 + -x3*x4 = 0) -(H18 : -1 + x12 + -x14 >= 0) -(H19 : x14 >= 0) -(H20 : x1 + -x14 + -x5*x12 = 0) -(H21 : -1 + x4 + -x15 >= 0) -(H22 : x15 >= 0) -(H23 : x9 + -x15 + -x2*x4 = 0) -(H24 : -x9 + x16 + x4*x17 = 0) -(H25 : x17 + -x18 = 0) -, False -. -Proof. - intros. - Time nia. -Qed. - -Goal - forall (x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 - x14 x15 x16 : Z) - (H6 : x8 < x10 ^ 2 * x15 ^ 2 + 2 * x10 * x15 * x14 + x14 ^ 2) - (H7 : 0 <= x8) - (H12 : 0 <= x14) - (H0 : x8 = x15 * x11 + x9) - (H14 : x10 ^ 2 * x15 + x10 * x14 < x16) - (H17 : x16 <= 0) - (H15 : 0 <= x9) - (H18 : x9 < x15) - (H16 : 0 <= x12) - (H19 : x12 < (x10 * x15 + x14) * x10) - , False. -Proof. - intros. - Time nia. -Qed. - - -(* From fiat-crypto Toplevel1.v *) - - -Goal forall - (x1 x2 x3 x4 x5 x7 : Z) - (H0 : x1 + x2 - x3 = 0) (* substitute x1, nothing happens *) - (H1 : 2 * x2 - x4 - 1 >= 0) - (H2 : - x2 + x4 >= 0) - (H3 : 2 * x2 - x5 - 1 >= 0) - (H5 : x2 - 4 >= 0) - (H7 : - x2 * x7 + x4 * x5 >= 0) - (H6 : x2 * x7 + x2 - x4 * x5 - 1 >= 0) - (H9 : x7 - x2 ^ 2 >= 0), (* x2^2 is *visibly* positive *) - False. -Proof. - intros. - nia. -Qed. - -Goal forall - (x1 x2 x3 x4 x5 x7 : Z) - (H0 : x2 + x1 - x3 = 0) (* substitute x2= x3 -x1 ... *) - (H1 : 2 * x2 - x4 - 1 >= 0) - (H2 : - x2 + x4 >= 0) - (H3 : 2 * x2 - x5 - 1 >= 0) - (H5 : x2 - 4 >= 0) - (H7 : - x2 * x7 + x4 * x5 >= 0) - (H6 : x2 * x7 + x2 - x4 * x5 - 1 >= 0) - (H9 : x7 - x2 ^ 2 >= 0), (* (x3 - x1)^2 is not visibly positive *) - False. -Proof. - intros. - nia. -Qed. - -(* From bedrock2 FlatToRisc.v *) - -(* Variant of the following - omega fails (bad linearisation?)*) -Goal forall - (PXLEN XLEN r : Z) - (q q0 r0 a : Z) - (H3 : 4 * a = 4 * PXLEN * q0 + (4 * q + r)) - (H6 : 0 <= 4 * q + r) - (H7 : 4 * q + r < 4 * PXLEN) - (H8 : r <= 3) - (H4 : r >= 1), - False. -Proof. - intros. - Time lia. -Qed. - -Goal forall - (PXLEN XLEN r : Z) - (q q0 r0 a : Z) - (H3 : 4 * a = 4 * PXLEN * q0 + (4 * q + r)) - (H6 : 0 <= 4 * q + r) - (H7 : 4 * q + r < 4 * PXLEN) - (H8 : r <= 3) - (H4 : r >= 1), - False. -Proof. - intros. - Time nia. -Qed. - - -(** Very slow *) -Goal forall - (XLEN r : Z) - (H : 4 < 2 ^ XLEN) - (H0 : 8 <= XLEN) - (q q0 r0 a : Z) - (H3 : 4 * a = 4 * 2 ^ (XLEN - 2) * q0 + r0) - (H5 : r0 = 4 * q + r) - (H6 : 0 <= r0) - (H7 : r0 < 4 * 2 ^ (XLEN - 2)) - (H2 : 0 <= r) - (H8 : r < 4) - (H4 : r > 0) - (H9 : 0 < 2 ^ (XLEN - 2)), - False. -Proof. - intros. - Time nia. -Qed. - -Goal forall - (XLEN r : Z) - (R : r > 0 \/ r < 0) - (H : 4 < 2 ^ XLEN) - (H0 : 8 <= XLEN) - (H1 : ~ (0 <= XLEN - 2) \/ 0 < 2 ^ (XLEN - 2)) - (q q0 r0 a : Z) - (H2 : 0 <= r0 < 4 * 2 ^ (XLEN - 2)) - (H3 : 4 * a = 4 * 2 ^ (XLEN - 2) * q0 + r0) - (H4 : 0 <= r < 4) - (H5 : r0 = 4 * q + r), - False. -Proof. - intros. - Time nia. -Qed. - -Goal forall - (XLEN r : Z) - (R : r > 0 \/ r < 0) - (H : 4 < 2 ^ XLEN) - (H0 : 8 <= XLEN) - (H1 : ~ (0 <= XLEN - 2) \/ 0 < 2 ^ (XLEN - 2)) - (q q0 r0 a : Z) - (H2 : 0 <= r0 < 4 * 2 ^ (XLEN - 2)) - (H3 : 4 * a = 4 * 2 ^ (XLEN - 2) * q0 + r0) - (H4 : 0 <= r < 4) - (H5 : r0 = 4 * q + r), - False. -Proof. - intros. - intuition idtac. - Time all:nia. -Qed. - - - -Goal forall - (XLEN a q q0 z : Z) - (HR : 4 * a - 4 * z * q0 - 4 * q > 0) - (H0 : 8 <= XLEN) - (H1 : 0 < z) - (H : 0 <= 4 * a - 4 * z * q0 - 4 * q) - (H3 : 4 * a - 4 * z * q0 - 4 * q < 4) - (H4 : 4 * a - 4 * z * q0 < 4 * z), - False. -Proof. - intros. - Time nia. -Qed. - - - -(* From fiat-crypto Modulo.v *) - -Goal forall (b : Z) - (H : 0 <> b) - (c r q1 q2 r2 : Z) - (H2 : r2 < c) - (q0 : Z) - (H7 : r < b) - (H5 : 0 <= r) - (H6 : r < b) - (H12 : 0 < c) - (H13 : 0 <> c) - (H0 : 0 <> c * b) - (H1 : 0 <= r2) - (H14 : 0 <= q0) - (H9 : c * q1 + q0 = c * q2 + r2) - (H4 : 0 <= b * q0 + - r) - (H10 : b * q0 + - r < c * b), - q1 = q2. -Proof. - intros. - Fail nia. -Abort. - - -(* From Sozeau's plugin Equations *) - - -Goal forall x p2 p1 m, - x <> 0%Z -> - (Z.abs (x * p2 ) > Z.abs (Z.abs p1 + Z.abs m))%Z -> - (Z.abs (x * (p1 + x * p2 )) > Z.abs m)%Z. -Proof. - intros. - Time nia. -Qed. - - -Goal forall z z0 z1 m - (Heqz0 : z0 = ((1 + z) * z1)%Z) - (H0 : (0 <= m)%Z) - (H3 : z = m) - (H1 : (0 <= z0)%Z) - (H4 : z1 = z0) - (H2 : (z1 > 0)%Z), - (z1 > z)%Z. -Proof. - intros. - Time nia. -Qed. - - - - -(* Known issues. - - - Found proof may violate Proof using ... - There may be a compliant proof but lia has no way to know. - Proofs could be optimised to minimise the number of hypotheses, - but this seems to costly. -Section S. - Variable z z0 z1 z2 : Z. - Variable H2 : 0 <= z2. - Variable H3 : z2 < z1. - Variable H4 : 0 <= z0. - Variable H5 : z0 < z1. - Variable H6 : z = - z2. - - Goal -z1 -z2 >= 0 -> False. - Proof using H2 H3 H6. - intros. - lia. - Qed. -*) diff --git a/stdlib/test-suite/micromega/qexample.v b/stdlib/test-suite/micromega/qexample.v deleted file mode 100644 index e63616f3b16b..000000000000 --- a/stdlib/test-suite/micromega/qexample.v +++ /dev/null @@ -1,76 +0,0 @@ -(************************************************************************) -(* *) -(* Micromega: A reflexive tactic using the Positivstellensatz *) -(* *) -(* FrĆ©dĆ©ric Besson (Irisa/Inria) 2006-2008 *) -(* *) -(************************************************************************) - -From Stdlib Require Import Lqa. -From Stdlib Require Import QArith. - -Lemma plus_minus : forall x y, - 0 == x + y -> 0 == x -y -> 0 == x /\ 0 == y. -Proof. - intros. - lra. -Qed. - -(* Other (simple) examples *) -Open Scope Q_scope. - -Lemma binomial : forall x y:Q, ((x+y)^2 == x^2 + (2 # 1) *x*y + y^2). -Proof. - intros. - lra. -Qed. - - -Lemma hol_light19 : forall m n, (2 # 1) * m + n == (n + m) + m. -Proof. - intros ; lra. -Qed. -Open Scope Z_scope. -Open Scope Q_scope. - -Lemma vcgen_25 : forall - (n : Q) - (m : Q) - (jt : Q) - (j : Q) - (it : Q) - (i : Q) - (H0 : 1 * it + (-2 # 1) * i + (-1 # 1) == 0) - (H : 1 * jt + (-2 # 1) * j + (-1 # 1) == 0) - (H1 : 1 * n + (-10 # 1) = 0) - (H2 : 0 <= (-4028 # 1) * i + (6222 # 1) * j + (705 # 1) * m + (-16674 # 1)) - (H3 : 0 <= (-418 # 1) * i + (651 # 1) * j + (94 # 1) * m + (-1866 # 1)) - (H4 : 0 <= (-209 # 1) * i + (302 # 1) * j + (47 # 1) * m + (-839 # 1)) - (H5 : 0 <= (-1 # 1) * i + 1 * j + (-1 # 1)) - (H6 : 0 <= (-1 # 1) * j + 1 * m + (0 # 1)) - (H7 : 0 <= (1 # 1) * j + (5 # 1) * m + (-27 # 1)) - (H8 : 0 <= (2 # 1) * j + (-1 # 1) * m + (2 # 1)) - (H9 : 0 <= (7 # 1) * j + (10 # 1) * m + (-74 # 1)) - (H10 : 0 <= (18 # 1) * j + (-139 # 1) * m + (1188 # 1)) - (H11 : 0 <= 1 * i + (0 # 1)) - (H13 : 0 <= (121 # 1) * i + (810 # 1) * j + (-7465 # 1) * m + (64350 # 1)), - (( 1# 1) == (-2 # 1) * i + it). -Proof. - intros. - lra. -Qed. - -Goal forall x : Q, x * x >= 0. - intro; nra. -Qed. - -Goal forall x, -x^2 >= 0 -> x - 1 >= 0 -> False. -Proof. - intros. - psatz Q 3. -Qed. - -Lemma motzkin' : forall x y, (x^2+y^2+1)*(x^2*y^4 + x^4*y^2 + 1 - (3 # 1) *x^2*y^2) >= 0. -Proof. - intros ; psatz Q 3. -Qed. diff --git a/stdlib/test-suite/micromega/reify_bool.v b/stdlib/test-suite/micromega/reify_bool.v deleted file mode 100644 index b72d0bb7570b..000000000000 --- a/stdlib/test-suite/micromega/reify_bool.v +++ /dev/null @@ -1,18 +0,0 @@ -From Stdlib Require Import ZArith. -From Stdlib Require Import Lia. -Import Z. -Unset Lia Cache. - -Goal forall (x y : Z), - implb (Z.eqb x y) (Z.eqb y x) = true. -Proof. - intros. - lia. -Qed. - -Goal forall (x y :Z), implb (Z.eqb x 0) (Z.eqb y 0) = true <-> - orb (negb (Z.eqb x 0))(Z.eqb y 0) = true. -Proof. - intro. - lia. -Qed. diff --git a/stdlib/test-suite/micromega/rexample.v b/stdlib/test-suite/micromega/rexample.v deleted file mode 100644 index 22eeaa32acf9..000000000000 --- a/stdlib/test-suite/micromega/rexample.v +++ /dev/null @@ -1,126 +0,0 @@ -(************************************************************************) -(* *) -(* Micromega: A reflexive tactic using the Positivstellensatz *) -(* *) -(* FrĆ©dĆ©ric Besson (Irisa/Inria) 2006-2008 *) -(* *) -(************************************************************************) - -From Stdlib Require Import Lra. -From Stdlib Require Import Reals. - -Open Scope R_scope. - - -Lemma cst_test : 5^5 = 5 * 5 * 5 *5 *5. -Proof. - lra. -Qed. - -Lemma yplus_minus : forall x y, - 0 = x + y -> 0 = x -y -> 0 = x /\ 0 = y. -Proof. - intros. - lra. -Qed. - -Goal - forall (a c : R) - (Had : a <> a), - a > c. -Proof. - intros. - lra. -Qed. - - -(* Other (simple) examples *) - -Lemma binomial : forall x y, ((x+y)^2 = x^2 + 2 *x*y + y^2). -Proof. - intros. - lra. -Qed. - -Lemma hol_light19 : forall m n, 2 * m + n = (n + m) + m. -Proof. - intros ; lra. -Qed. - - -Lemma vcgen_25 : forall - (n : R) - (m : R) - (jt : R) - (j : R) - (it : R) - (i : R) - (H0 : 1 * it + (-2%R ) * i + (-1%R ) = 0) - (H : 1 * jt + (-2 ) * j + (-1 ) = 0) - (H1 : 1 * n + (-10 ) = 0) - (H2 : 0 <= (-4028 ) * i + (6222 ) * j + (705 ) * m + (-16674 )) - (H3 : 0 <= (-418 ) * i + (651 ) * j + (94 ) * m + (-1866 )) - (H4 : 0 <= (-209 ) * i + (302 ) * j + (47 ) * m + (-839 )) - (H5 : 0 <= (-1 ) * i + 1 * j + (-1 )) - (H6 : 0 <= (-1 ) * j + 1 * m + (0 )) - (H7 : 0 <= (1 ) * j + (5 ) * m + (-27 )) - (H8 : 0 <= (2 ) * j + (-1 ) * m + (2 )) - (H9 : 0 <= (7 ) * j + (10 ) * m + (-74 )) - (H10 : 0 <= (18 ) * j + (-139 ) * m + (1188 )) - (H11 : 0 <= 1 * i + (0 )) - (H13 : 0 <= (121 ) * i + (810 ) * j + (-7465 ) * m + (64350 )), - (( 1 ) = (-2 ) * i + it). -Proof. - intros. - lra. -Qed. - -Goal forall x, -x^2 >= 0 -> x - 1 >= 0 -> False. -Proof. - intros. - psatz R 3. -Qed. - -Goal forall x, -x^2 >= 0 -> x - 1 >= 0 -> False. -Proof. - intros. - nra. -Qed. - - - -Lemma motzkin' : forall x y, (x^2+y^2+1)*(x^2*y^4 + x^4*y^2 + 1 - (3 ) *x^2*y^2) >= 0. -Proof. - intros ; psatz R 2. -Qed. - -Lemma l1 : forall x y z : R, Rabs (x - z) <= Rabs (x - y) + Rabs (y - z). -intros; split_Rabs; lra. -Qed. - -(* Bug 5073 *) -Lemma opp_eq_0_iff a : -a = 0 <-> a = 0. -Proof. - lra. -Qed. - -(* From L. ThĆ©ry *) - -Goal forall (x y : R), x = 0 -> x * y = 0. -Proof. - intros. - nra. -Qed. - -Goal forall (x y : R), 2*x = 0 -> x * y = 0. -Proof. - intros. - nra. -Qed. - - -Goal forall (x y: R), - x*x >= 0 -> x * y = 0. -Proof. - intros. - nra. -Qed. diff --git a/stdlib/test-suite/micromega/rsyntax.v b/stdlib/test-suite/micromega/rsyntax.v deleted file mode 100644 index 8217af98442a..000000000000 --- a/stdlib/test-suite/micromega/rsyntax.v +++ /dev/null @@ -1,66 +0,0 @@ -From Stdlib Require Import ZArith. -From Stdlib Require Import Lra. -From Stdlib Require Import Reals. - -Goal (1 / (1 - 1) = 0)%R. - Fail lra. (* division by zero *) -Abort. - -Goal (0 / (1 - 1) = 0)%R. - lra. (* 0 * x = 0 *) -Qed. - -Goal (10 ^ 2 = 100)%R. - lra. (* pow is reified as a constant *) -Qed. - -Goal (2 / (1/2) ^ 2 = 8)%R. - lra. (* pow is reified as a constant *) -Qed. - - -Goal ( IZR (Z.sqrt 4) = 2)%R. -Proof. - Fail lra. -Abort. - -From Stdlib Require Import DeclConstant. - -#[export] Instance Dsqrt : DeclaredConstant Z.sqrt := {}. - -Goal ( IZR (Z.sqrt 4) = 2)%R. -Proof. - lra. -Qed. - -From Stdlib Require Import QArith. -From Stdlib Require Import Qreals. - -Goal (Q2R (1 # 2) = 1/2)%R. -Proof. - lra. -Qed. - -Goal ( 1 ^ (2 + 2) = 1)%R. -Proof. - Fail lra. -Abort. - -#[export] Instance Dplus : DeclaredConstant Init.Nat.add := {}. - -Goal ( 1 ^ (2 + 2) = 1)%R. -Proof. - lra. -Qed. - -From Stdlib Require Import Lia. - -Goal ( 1 ^ (2 + 2) = 1)%Z. -Proof. - lia. (* exponent is a constant expr *) -Qed. - -Goal (1 / IZR (Z.pow_pos 10 25) = 1 / 10 ^ 25)%R. -Proof. - lra. -Qed. diff --git a/stdlib/test-suite/micromega/sint63.v b/stdlib/test-suite/micromega/sint63.v deleted file mode 100644 index feecc3560bed..000000000000 --- a/stdlib/test-suite/micromega/sint63.v +++ /dev/null @@ -1,41 +0,0 @@ -From Stdlib Require Import ZArith Lia. -From Stdlib Require Import Sint63. -From Stdlib Require ZifySint63. - -Open Scope sint63_scope. - -Goal forall (x : int), -4611686018427387904 <=? x = true. -Proof. lia. Qed. - -Goal max_int = 4611686018427387903. -Proof. lia. Qed. - -Goal digits = 63. -Proof. lia. Qed. - -Goal wB = (2^63)%Z. -Proof. lia. Qed. - -Goal forall x y, x + y <=? max_int = true. -Proof. lia. Qed. - -Goal forall x y z, x + 3 * y - z - y = x + 2 * y - z. -Proof. lia. Qed. - -Goal forall x, x <> 0 -> x / x = 1. -Proof. nia. Qed. - -Goal min_int / -1 = min_int. -Proof. lia. Qed. - -Goal forall x y, is_zero x = true -> 3 * x + y = y. -Proof. lia. Qed. - -Goal forall x, 0 <=? x = true -> abs x = x. -Proof. lia. Qed. - -Goal forall x, x abs x = - x. -Proof. lia. Qed. - -Goal forall x, x <> min_int -> 0 <=? abs x = true. -Proof. lia. Qed. diff --git a/stdlib/test-suite/micromega/square.v b/stdlib/test-suite/micromega/square.v deleted file mode 100644 index 7dc525d12ef6..000000000000 --- a/stdlib/test-suite/micromega/square.v +++ /dev/null @@ -1,58 +0,0 @@ -(************************************************************************) -(* *) -(* Micromega: A reflexive tactic using the Positivstellensatz *) -(* *) -(* FrĆ©dĆ©ric Besson (Irisa/Inria) 2006-2008 *) -(* *) -(************************************************************************) - -From Stdlib Require Import ZArith Zwf Psatz QArith. -Open Scope Z_scope. - -Lemma Zabs_square : forall x, (Z.abs x)^2 = x^2. -Proof. - intros ; nia. -Qed. - -Lemma integer_statement : ~exists n, exists p, n^2 = 2*p^2 /\ n <> 0. -Proof. - intros [n [p [Heq Hnz]]]; pose (n' := Z.abs n); pose (p':=Z.abs p). -assert (facts : 0 <= Z.abs n /\ 0 <= Z.abs p /\ Z.abs n^2=n^2 - /\ Z.abs p^2 = p^2) by auto using Z.abs_nonneg, Zabs_square. -assert (H : (0 < n' /\ 0 <= p' /\ n' ^2 = 2* p' ^2)) by - (destruct facts as [Hf1 [Hf2 [Hf3 Hf4]]]; unfold n', p' ; nia). -generalize p' H; elim n' using (well_founded_ind (Zwf_well_founded 0)); clear. -intros n IHn p [Hn [Hp Heq]]. -assert (Hzwf : Zwf 0 (2*p-n) n) by (unfold Zwf; nia). -assert (Hdecr : 0 < 2*p-n /\ 0 <= n-p /\ (2*p-n)^2=2*(n-p)^2) by nia. -apply (IHn (2*p-n) Hzwf (n-p) Hdecr). -Qed. - -Open Scope Q_scope. - -Lemma QnumZpower : forall x : Q, Qnum (x ^ 2)%Q = ((Qnum x) ^ 2) %Z. -Proof. - intros. - destruct x. - cbv beta iota zeta delta - [Z.mul]. - ring. -Qed. - - -Lemma QdenZpower : forall x : Q, Zpos (Qden (x ^ 2)%Q) = (Zpos (Qden x) ^ 2) %Z. -Proof. - intros. - destruct x. - simpl. - lia. -Qed. - -Theorem sqrt2_not_rational : ~exists x:Q, x^2==2#1. -Proof. - unfold Qeq; intros (x,HQeq); simpl (Qden (2#1)) in HQeq; rewrite Z.mul_1_r in HQeq. - assert (Heq : (Qnum x ^ 2 = 2 * Zpos (Qden x) ^ 2)%Z) by - (rewrite QnumZpower in HQeq ; rewrite QdenZpower in HQeq ; auto). - assert (Hnx : (Qnum x <> 0)%Z) - by (intros Hx; simpl in HQeq; rewrite Hx in HQeq; discriminate HQeq). - apply integer_statement; exists (Qnum x); exists (Zpos (Qden x)); auto. -Qed. diff --git a/stdlib/test-suite/micromega/uint63.v b/stdlib/test-suite/micromega/uint63.v deleted file mode 100644 index 550b181629e9..000000000000 --- a/stdlib/test-suite/micromega/uint63.v +++ /dev/null @@ -1,28 +0,0 @@ -From Stdlib Require Import ZArith Lia. -From Stdlib Require Import Uint63. -From Stdlib Require ZifyUint63. - -Open Scope uint63_scope. - -Goal forall (x:int), 0 <=? x = true. -Proof. lia. Qed. - -Goal forall (x : int), x <=? max_int = true. -Proof. lia. Qed. - -Goal max_int = 9223372036854775807. -Proof. lia. Qed. - -Goal digits = 63. -Proof. lia. Qed. - -Goal wB = (2^63)%Z. -Proof. lia. Qed. - -Goal forall x y, x + y <=? max_int = true. -Proof. lia. Qed. - -Goal forall x, x <> 0 -> x / x = 1. -Proof. - nia. -Qed. diff --git a/stdlib/test-suite/micromega/witness_tactics.v b/stdlib/test-suite/micromega/witness_tactics.v deleted file mode 100644 index c4c12066e594..000000000000 --- a/stdlib/test-suite/micromega/witness_tactics.v +++ /dev/null @@ -1,54 +0,0 @@ -From Stdlib Require Import ZArith QArith. -From Stdlib.micromega Require Import RingMicromega EnvRing Tauto. -From Stdlib.micromega Require Import ZMicromega QMicromega. - -Declare ML Module "rocq-runtime.plugins.micromega". - -Goal True. -Proof. -pose (ff := - IMPL - (EQ - (A isBool - {| - Flhs := PEadd (PEX 1) (PEmul (PEc 2%Q) (PEX 2)); - Fop := OpLe; - Frhs := PEc 3%Q - |} tt) (TT isBool)) None - (IMPL - (EQ - (A isBool - {| - Flhs := PEadd (PEmul (PEc 2%Q) (PEX 1)) (PEX 2); - Fop := OpLe; - Frhs := PEc 3%Q - |} tt) (TT isBool)) None - (EQ - (A isBool - {| Flhs := PEadd (PEX 1) (PEX 2); Fop := OpLe; Frhs := PEc 2%Q |} tt) - (TT isBool))) : BFormula (Formula Q) isProp). -let ff' := eval unfold ff in ff in wlra_Q wit0 ff'. -Check eq_refl : wit0 = (PsatzAdd (PsatzIn Q 2) - (PsatzAdd (PsatzIn Q 1) (PsatzMulE (PsatzC 3%Q) (PsatzIn Q 0))) :: nil)%list. -let ff' := eval unfold ff in ff in wlia wit1 ff'. -Check eq_refl : wit1 = (RatProof (PsatzAdd (PsatzIn Z 2) (PsatzAdd (PsatzIn Z 1) - (PsatzIn Z 0))) DoneProof :: nil)%list. -let ff' := eval unfold ff in ff in wnia wit4 ff'. -Check eq_refl : wit4 = (RatProof (PsatzAdd (PsatzIn Z 2) (PsatzAdd (PsatzIn Z 1) - (PsatzIn Z 0))) DoneProof :: nil)%list. -let ff' := eval unfold ff in ff in wnra_Q wit5 ff'. -Check eq_refl : wit5 = (PsatzAdd (PsatzIn Q 2) - (PsatzAdd (PsatzIn Q 1) (PsatzMulE (PsatzC 3%Q) (PsatzIn Q 0))) :: nil)%list. -Fail let ff' := eval unfold ff in ff in wsos_Q wit6 ff'. -Fail let ff' := eval unfold ff in ff in wsos_Z wit6 ff'. -(* Requires Csdp, not in CI -let ff' := eval unfold ff in ff in wpsatz_Z 3 wit2 ff'. -Check eq_refl : wit2 = (RatProof (PsatzAdd (PsatzC 1) - (PsatzAdd (PsatzIn Z 2) (PsatzAdd (PsatzIn Z 1) (PsatzIn Z 0)))) DoneProof - :: nil)%list. -let ff' := eval unfold ff in ff in wpsatz_Q 3 wit3 ff'. -Check eq_refl : wit3 = (PsatzAdd (PsatzIn Q 0) - (PsatzAdd (PsatzMulE (PsatzIn Q 2) (PsatzC (1 # 2))) - (PsatzAdd (PsatzMulE (PsatzIn Q 1) (PsatzC (1 # 2))) - (PsatzMulE (PsatzIn Q 0) (PsatzC (1 # 2))))) :: nil)%list. *) -Abort. diff --git a/stdlib/test-suite/micromega/zify.v b/stdlib/test-suite/micromega/zify.v deleted file mode 100644 index 8c609c4134b8..000000000000 --- a/stdlib/test-suite/micromega/zify.v +++ /dev/null @@ -1,324 +0,0 @@ -From Stdlib Require Import BinNums BinInt BinNat ZifyInst Zify. - -Definition pos := positive. - -Goal forall (x : pos), x = x. -Proof. - intros. - zify_op. - apply (@eq_refl Z). -Qed. - -Goal (1 <= Pos.to_nat 1)%nat. -Proof. - zify_op. - apply Z.le_refl. -Qed. - -Goal forall (x : positive), not (x = x) -> False. -Proof. - intros. zify_op. - apply H. - apply (@eq_refl Z). -Qed. - -Goal (0 <= 0)%nat. -Proof. - intros. - zify_op. - apply Z.le_refl. -Qed. - - -Lemma N : forall x, (0 <= Z.of_nat x)%Z. -Proof. - intros. - zify. exact cstr. -Defined. - -Lemma N_eq : N = -fun x : nat => let cstr : (0 <= Z.of_nat x)%Z := Znat.Nat2Z.is_nonneg x in cstr. -Proof. - reflexivity. -Qed. - -Goal (Z.of_nat 1 * 0 = 0)%Z. -Proof. - intros. - zify. - match goal with - | |- (1 * 0 = 0)%Z => reflexivity - end. -Qed. - -Lemma C : forall p, - Z.pos p~1 = Z.pos p~1. -Proof. - intros. - zify_op. - reflexivity. -Defined. - -Lemma C_eq : C = fun p : positive => -let cstr : (0 < Z.pos p)%Z := Pos2Z.pos_is_pos p in eq_refl. -Proof. -reflexivity. -Qed. - - -Goal forall p, - (Z.pos p~1 = 2 * Z.pos p + 1)%Z. -Proof. - intros. - zify_op. - reflexivity. -Qed. - -Goal forall z, - (2 * z = 2 * z)%Z. -Proof. - intros. - zify_op. - reflexivity. -Qed. - -Goal (-1= Z.opp 1)%Z. -Proof. - intros. - zify_op. - reflexivity. -Qed. - -Goal forall x, Z.of_N (Pos.Nsucc_double x) = (2 * Z.of_N x + 1)%Z. -Proof. - intros; zify_op; reflexivity. -Qed. - -Goal forall x, Z.of_N (Pos.Ndouble x) = (2 * Z.of_N x)%Z. -Proof. - intros; zify_op; reflexivity. -Qed. - -Goal forall x, Z.of_N (N.succ_double x) = (2 * Z.of_N x + 1)%Z. -Proof. - intros; zify_op; reflexivity. -Qed. - -Goal forall x, Z.of_N (N.double x) = (2 * Z.of_N x)%Z. -Proof. - intros; zify_op; reflexivity. -Qed. - -Goal forall x, Z.pos (N.succ_pos x) = (Z.of_N x + 1)%Z. -Proof. - intros; zify_op; reflexivity. -Qed. - -Goal forall x, Z.of_N (N.div2 x) = (Z.of_N x / 2)%Z. -Proof. - intros; zify_op; reflexivity. -Qed. - -Goal forall x y, Z.of_N (N.pow x y) = (Z.pow (Z.of_N x) (Z.of_N y))%Z. -Proof. - intros; zify_op; reflexivity. -Qed. - -Goal forall x, Z.of_N (N.square x) = (Z.of_N x * Z.of_N x)%Z. -Proof. - intros; zify_op; reflexivity. -Qed. - -Goal forall x, Z.pos (Z.to_pos x) = Z.max 1 x. -Proof. - intros; zify_op; reflexivity. -Qed. - -From Stdlib Require Import Lia. - -Goal forall n n3, -S n + n3 >= 0 + n. -Proof. - intros. - lia. -Qed. - -Goal forall n, Nat.double n = n + n. -Proof. lia. Qed. - -Open Scope Z_scope. - -Goal forall n, Z.of_nat (Nat.div2 n) = Z.of_nat n / 2. -Proof. lia. Qed. - -Goal forall p, - False -> - (Pos.to_nat p) = 0%nat. -Proof. - intros. - zify_op. - match goal with - | H : False |- Z.pos p = Z0 => tauto - end. -Qed. - -Goal forall - fibonacci - (p : positive) - (n : nat) - (b : Z) - (H : 0%nat = (S (Pos.to_nat p) - n)%nat) - (H0 : 0 < Z.pos p < b) - (H1 : Z.pos p < fibonacci (S n)), - Z.abs (Z.pos p) < Z.of_nat n. -Proof. - intros. - lia. -Qed. - - - -Section S. - Variable digits : positive. - Hypothesis digits_ne_1 : digits <> 1%positive. - - Lemma spec_more_than_1_digit : (1 < Z.pos digits)%Z. - Proof. lia. Qed. - - Let digits_gt_1 := spec_more_than_1_digit. - - Goal True. - Proof. - intros. - zify. - exact I. - Qed. - -End S. - - -Record Bla : Type := - mk - { - T : Type; - zero : T - }. - -Definition znat := mk nat 0%nat. - -From Stdlib Require Import ZifyClasses. -From Stdlib Require Import ZifyInst. - -#[export] Instance Zero : CstOp (@zero znat : nat) := Op_O. -Add Zify CstOp Zero. - - -Goal @zero znat = 0%nat. - zify. - reflexivity. -Qed. - -Goal forall (x y : positive) (F : forall (P: Pos.le x y) , positive) (P : Pos.le x y), - (F P + 1 = 1 + F P)%positive. -Proof. - intros. - zify_op. - apply Z.add_comm. -Qed. - -Goal forall (x y : nat) (F : forall (P: le x y) , nat) (P : le x y), - (F P + 1 = 1 + F P)%nat. -Proof. - intros. - zify_op. - apply Z.add_comm. -Qed. - -From Stdlib Require Import Bool. - -Goal true && false = false. -Proof. - lia. -Qed. - -Goal forall p, p || true = true. -Proof. - lia. -Qed. - -Goal forall x y, Z.eqb x y = true -> x = y. -Proof. - intros. - lia. -Qed. - -Goal forall x, Z.leb x x = true. -Proof. - intros. - lia. -Qed. - -Goal forall x, Z.gtb x x = false. -Proof. - intros. - lia. -Qed. - -From Stdlib Require Import ZifyBool. - -#[export] Instance Op_bool_inj : UnOp (inj : bool -> bool) := - { TUOp := id; TUOpInj := fun _ => eq_refl }. -Add Zify UnOp Op_bool_inj. - -Goal forall x y : nat, Nat.eqb x 1 = true -> - Nat.eqb y 0 = true -> - Nat.eqb (x + y) 1 = true. -Proof. - intros x y. - lia. -Qed. - -Goal forall (f : Z -> bool), negb (negb (f 0)) = f 0. -Proof. - intros. lia. -Qed. - - -Ltac Zify.zify_pre_hook ::= unfold is_true in *. - -Goal forall x y : nat, is_true (Nat.eqb x 1) -> - is_true (Nat.eqb y 0) -> - is_true (Nat.eqb (x + y) 1). -Proof. -lia. -Qed. - -Goal forall x y, Pos.eqb x y = Z.eqb (Z.pos x) (Z.pos y). -Proof. - intros; zify_op; reflexivity. -Qed. - -Goal forall x y, Pos.leb x y = Z.leb (Z.pos x) (Z.pos y). -Proof. - intros; zify_op; reflexivity. -Qed. - -Goal forall x y, Pos.ltb x y = Z.ltb (Z.pos x) (Z.pos y). -Proof. - intros; zify_op; reflexivity. -Qed. - -Goal forall x y, N.eqb x y = Z.eqb (Z.of_N x) (Z.of_N y). -Proof. - intros; zify_op; reflexivity. -Qed. - -Goal forall x y, N.leb x y = Z.leb (Z.of_N x) (Z.of_N y). -Proof. - intros; zify_op; reflexivity. -Qed. - -Goal forall x y, N.ltb x y = Z.ltb (Z.of_N x) (Z.of_N y). -Proof. - intros; zify_op; reflexivity. -Qed. diff --git a/stdlib/test-suite/micromega/zomicron.v b/stdlib/test-suite/micromega/zomicron.v deleted file mode 100644 index 6517b2e6ddf5..000000000000 --- a/stdlib/test-suite/micromega/zomicron.v +++ /dev/null @@ -1,249 +0,0 @@ -From Stdlib Require Import ZArith. -From Stdlib Require Import Lia. - -Section S. - Variables H1 H2 H3 H4 : True. - - Lemma bug_9848 : True. - Proof using. - lia. - Qed. -End S. - -Lemma concl_in_Type : forall (k : nat) - (H : (k < 0)%nat) (F : k < 0 -> Type), - F H. -Proof. - intros. - lia. -Qed. - -Lemma bug_10707 : forall - (T : Type) - (t : nat -> Type) - (k : nat) - (default : T) - (arr : t 0 -> T) - (H : (k < 0)%nat) of_nat_lt, - match k with - | 0 | _ => default - end = arr (of_nat_lt H). -Proof. - intros. - lia. -Qed. - -Axiom decompose_nat : nat -> nat -> nat. -Axiom inleft : forall {P}, {m : nat & P m} -> nat. -Axiom foo : nat. - -Lemma bug_7886 : forall (x x0 : nat) - (e : 0 = x0 + S x) - (H : decompose_nat x 0 = inleft (existT (fun m : nat => 0 = m + S x) x0 e)) - (x1 : nat) - (e0 : 0 = x1 + S (S x)) - (H1 : decompose_nat (S x) 0 = inleft (existT (fun m : nat => 0 = m + S (S x)) x1 e0)), - False. -Proof. - intros. - lia. -Qed. - - -Lemma bug_8898 : forall (p : 0 < 0) (H: p = p), False. -Proof. - intros p H. - lia. -Qed. - - - -Open Scope Z_scope. - -Lemma two_x_eq_1 : forall x, 2 * x = 1 -> False. -Proof. - intros. - lia. -Qed. - - -Lemma two_x_y_eq_1 : forall x y, 2 * x + 2 * y = 1 -> False. -Proof. - intros. - lia. -Qed. - -Lemma two_x_y_z_eq_1 : forall x y z, 2 * x + 2 * y + 2 * z= 1 -> False. -Proof. - intros. - lia. -Qed. - -Lemma unused : forall x y, y >= 0 /\ x = 1 -> x = 1. -Proof. - intros x y. - lia. -Qed. - -Lemma omega_nightmare : forall x y, 27 <= 11 * x + 13 * y <= 45 -> -10 <= 7 * x - 9 * y <= 4 -> False. -Proof. - intros ; intuition auto. - lia. -Qed. - -Lemma compact_proof : forall z, - (z < 0) -> - (z >= 0) -> - (0 >= z \/ 0 < z) -> False. -Proof. - intros. - lia. -Qed. - -Lemma dummy_ex : exists (x:Z), x = x. -Proof. - eexists. - lia. - Unshelve. - exact Z0. -Qed. - -Lemma unused_concl : forall x, - False -> x > 0 -> x < 0. -Proof. - intro. - lia. -Qed. - -Lemma unused_concl_match : forall (x:Z), - False -> match x with - | Z0 => True - | _ => x = x - end. -Proof. - intros. - lia. -Qed. - -Lemma fresh : forall (__arith : Prop), - __arith -> True. -Proof. - intros. - lia. -Qed. - - -Lemma fresh1 : forall (__p1 __p2 __p3 __p5:Prop) (x y z:Z), (x = 0 /\ y = 0) /\ z = 0 -> x = 0. -Proof. - intros. - lia. -Qed. - - -Class Foo {x : Z} := { T : Type ; dec : T -> Z }. -Goal forall bound {F : @Foo bound} (x y : T), 0 <= dec x < bound -> 0 <= dec y - < bound -> dec x + dec y >= bound -> dec x + dec y < 2 * bound. -Proof. - intros. - lia. -Qed. - -Section S. - Variables x y: Z. - Variables XGe : x >= 0. - Variables YGt : y > 0. - Variables YLt : y < 0. - - Goal False. - Proof using - XGe. - lia. - Qed. - - Goal False. - Proof using YGt YLt x y. - lia. - Qed. - -End S. - -Section S. - Variable x y: Z. - Variable H1 : 1 > 0 -> x = 1. - Variable H2 : x = y. - - Goal x = y. - Proof using H2. - lia. - Qed. - -End S. - -(* Bug 5073 *) -Lemma opp_eq_0_iff a : -a = 0 <-> a = 0. -Proof. - lia. -Qed. - -Lemma ex_pos : forall x, exists z t, x = z - t /\ z >= 0 /\ t >= 0. -Proof. - intros. - destruct (dec_Zge x 0). - exists x, 0. - lia. - exists 0, (-x). - lia. -Qed. - -Goal forall - (b q r : Z) - (H : b * q + r <= 0) - (H5 : - b < r) - (H6 : r <= 0) - (H2 : 0 <= b), - b = 0 -> False. -Proof. - intros b q r. - lia. -Qed. - - -Section S. - (* From bedrock2, used to be slow *) - Variables (x3 q r q2 r3 : Z) - (H : 2 ^ 2 <> 0 -> r3 + 3 = 2 ^ 2 * q + r) - (H0 : 0 < 2 ^ 2 -> 0 <= r < 2 ^ 2) - (H1 : 2 ^ 2 < 0 -> 2 ^ 2 < r <= 0) - (H2 : 2 ^ 2 = 0 -> q = 0) - (H3 : 2 ^ 2 = 0 -> r = 0) - (q0 r0 : Z) - (H4 : 4 <> 0 -> 0 = 4 * q0 + r0) - (H5 : 0 < 4 -> 0 <= r0 < 4) - (H6 : 4 < 0 -> 4 < r0 <= 0) - (H7 : 4 = 0 -> q0 = 0) - (H8 : 4 = 0 -> r0 = 0) - (q1 r1 : Z) - (H9 : 4 <> 0 -> q + q + (q + q) = 4 * q1 + r1) - (H10 : 0 < 4 -> 0 <= r1 < 4) - (H11 : 4 < 0 -> 4 < r1 <= 0) - (H12 : 4 = 0 -> q1 = 0) - (H13 : 4 = 0 -> r1 = 0) - (r2 : Z) - (H14 : 2 ^ 16 <> 0 -> x3 = 2 ^ 16 * q2 + r2) - (H15 : 0 < 2 ^ 16 -> 0 <= r2 < 2 ^ 16) - (H16 : 2 ^ 16 < 0 -> 2 ^ 16 < r2 <= 0) - (H17 : 2 ^ 16 = 0 -> q2 = 0) - (H18 : 2 ^ 16 = 0 -> r2 = 0) - (q3 : Z) - (H19 : 16383 + 1 <> 0 -> q2 = (16383 + 1) * q3 + r3) - (H20 : 0 < 16383 + 1 -> 0 <= r3 < 16383 + 1) - (H21 : 16383 + 1 < 0 -> 16383 + 1 < r3 <= 0) - (H22 : 16383 + 1 = 0 -> q3 = 0) - (H23 : 16383 + 1 = 0 -> r3 = 0). - - Goal r0 = r1. - Proof using H10 H9 H5 H4. - intros. - lia. - Qed. - -End S. diff --git a/stdlib/test-suite/misc/7595.sh b/stdlib/test-suite/misc/7595.sh deleted file mode 100755 index 836e354ee90c..000000000000 --- a/stdlib/test-suite/misc/7595.sh +++ /dev/null @@ -1,5 +0,0 @@ -#!/bin/sh -set -e - -$coqc -R misc/7595 Test misc/7595/base.v -$coqc -R misc/7595 Test misc/7595/FOO.v diff --git a/stdlib/test-suite/misc/7595/FOO.v b/stdlib/test-suite/misc/7595/FOO.v deleted file mode 100644 index 9669b388af74..000000000000 --- a/stdlib/test-suite/misc/7595/FOO.v +++ /dev/null @@ -1,39 +0,0 @@ -From Stdlib Require Import Test.base. - -Lemma dec_stable `{Decision P} : Ā¬Ā¬P ā†’ P. -Proof. firstorder. Qed. - -(** The tactic [destruct_decide] destructs a sumbool [dec]. If one of the -components is double negated, it will try to remove the double negation. *) -Tactic Notation "destruct_decide" constr(dec) "as" ident(H) := - destruct dec as [H|H]; - try match type of H with - | Ā¬Ā¬_ => apply dec_stable in H - end. -Tactic Notation "destruct_decide" constr(dec) := - let H := fresh in destruct_decide dec as H. - - -(** * Monadic operations *) -#[export] Instance option_guard: MGuard option := Ī» P dec A f, - match dec with left H => f H | _ => None end. - -(** * Tactics *) -Tactic Notation "case_option_guard" "as" ident(Hx) := - match goal with - | H : context C [@mguard option _ ?P ?dec] |- _ => - change (@mguard option _ P dec) with (Ī» A (f : P ā†’ option A), - match @decide P dec with left H' => f H' | _ => None end) in *; - destruct_decide (@decide P dec) as Hx - | |- context C [@mguard option _ ?P ?dec] => - change (@mguard option _ P dec) with (Ī» A (f : P ā†’ option A), - match @decide P dec with left H' => f H' | _ => None end) in *; - destruct_decide (@decide P dec) as Hx - end. -Tactic Notation "case_option_guard" := - let H := fresh in case_option_guard as H. - -(* This proof failed depending on the name of the module. *) -Lemma option_guard_True {A} P `{Decision P} (mx : option A) : - P ā†’ (guard P; mx) = mx. -Proof. intros. case_option_guard. reflexivity. contradiction. Qed. diff --git a/stdlib/test-suite/misc/7595/base.v b/stdlib/test-suite/misc/7595/base.v deleted file mode 100644 index 7db6279bb3e5..000000000000 --- a/stdlib/test-suite/misc/7595/base.v +++ /dev/null @@ -1,28 +0,0 @@ -From Stdlib Require Export Morphisms RelationClasses List Bool Utf8 Setoid. -Set Default Proof Using "Type". -Export ListNotations. -From Stdlib.Program Require Export Basics Syntax. -Global Generalizable All Variables. - -(** * Type classes *) -(** ** Decidable propositions *) -(** This type class by (Spitters/van der Weegen, 2011) collects decidable -propositions. *) -Class Decision (P : Prop) := decide : {P} + {Ā¬P}. -#[export] Hint Mode Decision ! : typeclass_instances. -Arguments decide _ {_} : simpl never, assert. - -(** ** Proof irrelevant types *) -(** This type class collects types that are proof irrelevant. That means, all -elements of the type are equal. We use this notion only used for propositions, -but by universe polymorphism we can generalize it. *) -Class ProofIrrel (A : Type) : Prop := proof_irrel (x y : A) : x = y. -#[export] Hint Mode ProofIrrel ! : typeclass_instances. - -Class MGuard (M : Type ā†’ Type) := - mguard: āˆ€ P {dec : Decision P} {A}, (P ā†’ M A) ā†’ M A. -Arguments mguard _ _ _ !_ _ _ / : assert. -Notation "'guard' P ; z" := (mguard P (Ī» _, z)) - (at level 20, z at level 200, only parsing, right associativity) . -Notation "'guard' P 'as' H ; z" := (mguard P (Ī» H, z)) - (at level 20, z at level 200, only parsing, right associativity) . diff --git a/stdlib/test-suite/misc/PStringExtraction.out b/stdlib/test-suite/misc/PStringExtraction.out deleted file mode 100644 index 59476e0b833c..000000000000 --- a/stdlib/test-suite/misc/PStringExtraction.out +++ /dev/null @@ -1,58 +0,0 @@ - -type comparison = -| Eq -| Lt -| Gt - -type char63 = Uint63.t - -type string = Pstring.t - -(** val make : Uint63.t -> char63 -> string **) - -let make = Pstring.make - -(** val length : string -> Uint63.t **) - -let length = Pstring.length - -(** val sub : string -> Uint63.t -> Uint63.t -> string **) - -let sub = Pstring.sub - -(** val cat : string -> string -> string **) - -let cat = Pstring.cat - -(** val compare : string -> string -> comparison **) - -let compare = (fun x y -> let c = Pstring.compare x y in if c = 0 then Eq else if c < 0 then Lt else Gt) - -(** val s1 : string **) - -let s1 = - (Pstring.unsafe_of_string "hello") - -(** val s2 : string **) - -let s2 = - (Pstring.unsafe_of_string "wwworlddd") - -(** val s : string **) - -let s = - cat s1 - (cat (Pstring.unsafe_of_string ", ") - (cat (sub s2 (Uint63.of_int (2)) (Uint63.of_int (5))) - (Pstring.unsafe_of_string "!"))) - -(** val w : string **) - -let w = - make (length s) (Uint63.of_int (119)) - -(** val c : comparison **) - -let c = - compare s w - diff --git a/stdlib/test-suite/misc/PStringExtraction.sh b/stdlib/test-suite/misc/PStringExtraction.sh deleted file mode 100755 index 4e59bd261448..000000000000 --- a/stdlib/test-suite/misc/PStringExtraction.sh +++ /dev/null @@ -1,15 +0,0 @@ -#!/usr/bin/env bash - -set -e - -code=0 -$coqc misc/PStringExtraction.v > misc/PStringExtraction.real 2>&1 || code=$? - -if [ $code != 0 ]; then - cat misc/PStringExtraction.real - exit $code -fi - -if [[ "$(ocamlc -config-var word_size)" = "64" ]]; then - diff -u misc/PStringExtraction.out misc/PStringExtraction.real -fi diff --git a/stdlib/test-suite/misc/PStringExtraction.v b/stdlib/test-suite/misc/PStringExtraction.v deleted file mode 100644 index 655373fec930..000000000000 --- a/stdlib/test-suite/misc/PStringExtraction.v +++ /dev/null @@ -1,25 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* le m k -> le n k. - eauto with arith. -Qed. - -Lemma le_antis : forall n m : nat, le n m -> le m n -> n = m. - eauto with arith. -Qed. diff --git a/stdlib/test-suite/modules/PO.v b/stdlib/test-suite/modules/PO.v deleted file mode 100644 index ee274a1143f9..000000000000 --- a/stdlib/test-suite/modules/PO.v +++ /dev/null @@ -1,57 +0,0 @@ -Set Implicit Arguments. -Unset Strict Implicit. - -Arguments fst : default implicits. -Arguments snd : default implicits. - -Module Type PO. - Parameter T : Set. - Parameter le : T -> T -> Prop. - - Axiom le_refl : forall x : T, le x x. - Axiom le_trans : forall x y z : T, le x y -> le y z -> le x z. - Axiom le_antis : forall x y : T, le x y -> le y x -> x = y. - - #[global] Hint Resolve le_refl le_trans le_antis. -End PO. - - -Module Pair (X: PO) (Y: PO) <: PO. - Definition T := (X.T * Y.T)%type. - Definition le p1 p2 := X.le (fst p1) (fst p2) /\ Y.le (snd p1) (snd p2). - - #[global] Hint Unfold le. - - Lemma le_refl : forall p : T, le p p. - auto. - Qed. - - Lemma le_trans : forall p1 p2 p3 : T, le p1 p2 -> le p2 p3 -> le p1 p3. - unfold le; intuition; eauto. - Qed. - - Lemma le_antis : forall p1 p2 : T, le p1 p2 -> le p2 p1 -> p1 = p2. - destruct p1. - destruct p2. - unfold le. - intuition. - enough (t = t1) as ->. - enough (t0 = t2) as ->. - reflexivity. - - auto. - - auto. - Qed. - -End Pair. - - - -From Mods Require Nat. - -Module NN := Pair Nat Nat. - -Lemma zz_min : forall p : NN.T, NN.le (0, 0) p. - auto with arith. -Qed. diff --git a/stdlib/test-suite/modules/_CoqProject b/stdlib/test-suite/modules/_CoqProject deleted file mode 100644 index c058d0ea37ca..000000000000 --- a/stdlib/test-suite/modules/_CoqProject +++ /dev/null @@ -1 +0,0 @@ --Q . Mods diff --git a/stdlib/test-suite/output/BinaryPrintingNotations.out b/stdlib/test-suite/output/BinaryPrintingNotations.out deleted file mode 100644 index 742f8114b4da59f057f1ab859d7f7cd15bb4e2d5..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 384 zcmV~$15yA000h8nyUDg~+qP}nwr$&X&D?#gT>(KMVG&U=aS2H&X&G5Lc?Cr!WffI5 zbq!4|Z5>@beFH-yV-r&|a|=r=Ya3fTdk04+XBSsDcMnf5Zy#Sj|A4@t;E>R;@QBE$ z=$P2J_=LoyYCcR`i91)=9bpB_Kwc3?w;O0 z^kV>n7{V|{Fp4pZV*-*?Bf83IKnYb zaEddW;{uns!ZmJii#y!o0grgXGhXnDH@xEmpZLNze(;Mw_H%%P9O5uXILa}ObApqc z;xuPC%Q?<-fs0(?GFQ0DHLi1mo800yceu+v?(=|$JmN7=c*--L^MaSW;x%u0%RAol ZfscIRGhg`1H@@?OpZwxCfB4HkseeTx(6Imj diff --git a/stdlib/test-suite/output/BinaryPrintingNotations.v b/stdlib/test-suite/output/BinaryPrintingNotations.v deleted file mode 100644 index 548fee0365e8af634c80bbe0156d739be9dceb51..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 18453 zcmbW<_jl7)9ES1k;qKj@uG_RUF%7Phuv;il3Z;cW36$ZDt9E6U4-aLHDBhm#bwr_OuGyMe}|-=A0a^_+Y#fI`LxLZ;m%-a^d+2Ol9h3 zF+VzqtGlLNd9P_i+eb3vrD@_vE?A`J|S@k6a7Ns zP$mY1#9>U#7ZQgvu|P;1!Nfu#aU>Iqgv3!yEEW<+GqFTS6qxXY#4$`%gv7B-_(I}1 zCITUGJQG$(oWMjVBu+%4Px0a;CKNADWf=eKyapNO2AmiWKKEp-6Ea6N(h)Ga*P}W?onHcQ`S9ePwW2w4ZB?3$UJk#f+{l zHWV~2WI{pXA|@0x<}jh4aWNAL8r@7NX!J0lpiyLE)@aQ5+|Ok~xyZPL35AYcCKNj6 zG0{QCjK6Q(=W+V)nf-j`O3W#YT*^cTBL}#mGI9eQsLbL;^)aD9($9qA$N&?HBlDS1 z99h7G;>bcK6h{^@p*XUb3B{2mOel^lWkPY}GA0y9E@whU$+`xq5#f?lTUfjfl;>FEOC|=ycgyO}mOekL5#)RU9=@)q43dshz-S$ z=EH0#fHWUrLlLC;C>shP&BxeK3~4^jhJr}*2{sf(noqK!Fw%UA4aJe>(`+b^G@oHZ zk)-)78y%F)VvgB-jt$9==h0Xq`SAi9k{>U!A^GtV8ZrsequxN<7YM`KYn3D^5a)FBtL#*L-ONyHY7j(U_Fg(c=8WSNv#k{^2Wrv^f9p6+c>> zfB1?YEzUoD#g7)}AHL#8i}Md(@uS80hp+h2;{3x`{Ah9h;VXW$IREe!KU$oB_=+Db z&Ody`j~3@2zT!uV^ABJ0gY%C-@`Lk_K=On0k3jN+^N&FCgY%C-@`Lk_K=On0k3jN+ z^N&FCgY%C-@`Lk_K=On0k3jN+^N&FCgY%C-@`Lk_K=On0k3jN+^N&FCgYyq7`N8>z zmHgoR!%BW|{$V9QIRCJcADn+!$q&vytmFshA6D{%^A9We!TE=k{NVh0273Zc85H nc6-T8#l4x!j2&}#`;{>hb-dN?9`}6DcSn{AD=Y4YP%8WnVQmmx diff --git a/stdlib/test-suite/output/Binder.out b/stdlib/test-suite/output/Binder.out deleted file mode 100644 index 846dc5f50c3d..000000000000 --- a/stdlib/test-suite/output/Binder.out +++ /dev/null @@ -1,12 +0,0 @@ -foo = fun '(x, y) => x + y - : nat * nat -> nat - -Arguments foo pat -forall '(a, b), a /\ b - : Prop -foo = Ī» '(x, y), x + y - : nat * nat ā†’ nat - -Arguments foo pat -āˆ€ '(a, b), a āˆ§ b - : Prop diff --git a/stdlib/test-suite/output/Binder.v b/stdlib/test-suite/output/Binder.v deleted file mode 100644 index 2da86128c751..000000000000 --- a/stdlib/test-suite/output/Binder.v +++ /dev/null @@ -1,7 +0,0 @@ -Definition foo '(x,y) := x + y. -Print foo. -Check forall '(a,b), a /\ b. - -From Stdlib Require Import Utf8. -Print foo. -Check forall '(a,b), a /\ b. diff --git a/stdlib/test-suite/output/CoercionsString.out b/stdlib/test-suite/output/CoercionsString.out deleted file mode 100644 index f75b09e27214..000000000000 --- a/stdlib/test-suite/output/CoercionsString.out +++ /dev/null @@ -1,2 +0,0 @@ -"1" 0 - : PAIR diff --git a/stdlib/test-suite/output/CoercionsString.v b/stdlib/test-suite/output/CoercionsString.v deleted file mode 100644 index 337913fd7819..000000000000 --- a/stdlib/test-suite/output/CoercionsString.v +++ /dev/null @@ -1,8 +0,0 @@ -(* Check both removal of coercions with target Funclass and mixing - string and numeral scopes *) - -From Stdlib Require Import String. -Open Scope string_scope. -Inductive PAIR := P (s:string) (n:nat). -Coercion P : string >-> Funclass. -Check ("1" 0). diff --git a/stdlib/test-suite/output/DependentInductionErrors.out b/stdlib/test-suite/output/DependentInductionErrors.out deleted file mode 100644 index b772350b2c2e..000000000000 --- a/stdlib/test-suite/output/DependentInductionErrors.out +++ /dev/null @@ -1,6 +0,0 @@ -File "./output/DependentInductionErrors.v", line 3, characters 7-30: -The command has indeed failed with message: -Tactic failure: To use dependent destruction, first [Require Import Stdlib.Program.Equality.]. -File "./output/DependentInductionErrors.v", line 4, characters 7-28: -The command has indeed failed with message: -Tactic failure: To use dependent induction, first [Require Import Stdlib.Program.Equality.]. diff --git a/stdlib/test-suite/output/DependentInductionErrors.v b/stdlib/test-suite/output/DependentInductionErrors.v deleted file mode 100644 index 0aea50bc0063..000000000000 --- a/stdlib/test-suite/output/DependentInductionErrors.v +++ /dev/null @@ -1,17 +0,0 @@ -Theorem foo (b:bool) : b = true \/ b = false. -Proof. - Fail dependent destruction b. - Fail dependent induction b. -Abort. - -From Stdlib Require Import Equality. - -Theorem foo_with_destruction (b:bool) : b = true \/ b = false. -Proof. - dependent destruction b; auto. -Qed. - -Theorem foo_with_induction (b:bool) : b = true \/ b = false. -Proof. - dependent induction b; auto. -Qed. diff --git a/stdlib/test-suite/output/ExtractionString.out b/stdlib/test-suite/output/ExtractionString.out deleted file mode 100644 index 2a101d9cea71..000000000000 --- a/stdlib/test-suite/output/ExtractionString.out +++ /dev/null @@ -1,52 +0,0 @@ -(** val str : string **) - -let str = - String ((Ascii (False, False, True, False, True, False, True, False)), - (String ((Ascii (False, False, False, True, False, True, True, False)), - (String ((Ascii (True, False, False, True, False, True, True, False)), - (String ((Ascii (True, True, False, False, True, True, True, False)), - (String ((Ascii (False, False, False, False, False, True, False, False)), - (String ((Ascii (True, False, False, True, False, True, True, False)), - (String ((Ascii (True, True, False, False, True, True, True, False)), - (String ((Ascii (False, False, False, False, False, True, False, False)), - (String ((Ascii (True, False, False, False, False, True, True, False)), - (String ((Ascii (False, False, False, False, False, True, False, False)), - (String ((Ascii (True, True, False, False, True, True, True, False)), - (String ((Ascii (False, False, True, False, True, True, True, False)), - (String ((Ascii (False, True, False, False, True, True, True, False)), - (String ((Ascii (True, False, False, True, False, True, True, False)), - (String ((Ascii (False, True, True, True, False, True, True, False)), - (String ((Ascii (True, True, True, False, False, True, True, False)), - EmptyString))))))))))))))))))))))))))))))) -str :: String -str = - String0 (Ascii False False True False True False True False) (String0 - (Ascii False False False True False True True False) (String0 (Ascii True - False False True False True True False) (String0 (Ascii True True False - False True True True False) (String0 (Ascii False False False False False - True False False) (String0 (Ascii True False False True False True True - False) (String0 (Ascii True True False False True True True False) - (String0 (Ascii False False False False False True False False) (String0 - (Ascii True False False False False True True False) (String0 (Ascii - False False False False False True False False) (String0 (Ascii True True - False False True True True False) (String0 (Ascii False False True False - True True True False) (String0 (Ascii False True False False True True - True False) (String0 (Ascii True False False True False True True False) - (String0 (Ascii False True True True False True True False) (String0 - (Ascii True True True False False True True False) - EmptyString))))))))))))))) - - -(** val str : char list **) - -let str = - 'T'::('h'::('i'::('s'::(' '::('i'::('s'::(' '::('a'::(' '::('s'::('t'::('r'::('i'::('n'::('g'::[]))))))))))))))) -(** val str : string **) - -let str = - "This is a string" -str :: Prelude.String -str = - "This is a string" - - diff --git a/stdlib/test-suite/output/ExtractionString.v b/stdlib/test-suite/output/ExtractionString.v deleted file mode 100644 index b0c3da6c842a..000000000000 --- a/stdlib/test-suite/output/ExtractionString.v +++ /dev/null @@ -1,25 +0,0 @@ -From Stdlib Require Import String Extraction. - -Definition str := "This is a string"%string. - -(* Raw extraction of strings, in OCaml *) -Extraction Language OCaml. -Extraction str. - -(* Raw extraction of strings, in Haskell *) -Extraction Language Haskell. -Extraction str. - -(* Extraction to char list, in OCaml *) -From Stdlib Require Import ExtrOcamlString. -Extraction Language OCaml. -Extraction str. - -(* Extraction to native strings, in OCaml *) -From Stdlib Require Import ExtrOcamlNativeString. -Extraction str. - -(* Extraction to native strings, in Haskell *) -From Stdlib Require Import ExtrHaskellString. -Extraction Language Haskell. -Extraction str. diff --git a/stdlib/test-suite/output/Extraction_Haskell_String_12258.out b/stdlib/test-suite/output/Extraction_Haskell_String_12258.out deleted file mode 100644 index 496145086b10..000000000000 --- a/stdlib/test-suite/output/Extraction_Haskell_String_12258.out +++ /dev/null @@ -1,80 +0,0 @@ -{-# OPTIONS_GHC -cpp -XMagicHash #-} -{- For Hugs, use the option -F"cpp -P -traditional" -} - -{- IMPORTANT: If you change this file, make sure that running [cp - Extraction_Haskell_String_12258.out Extraction_Haskell_String_12258.hs && - ghc -o test Extraction_Haskell_String_12258.hs] succeeds -} - -module Main where - -import qualified Prelude - -#ifdef __GLASGOW_HASKELL__ -import qualified GHC.Base -#if __GLASGOW_HASKELL__ >= 900 -import qualified GHC.Exts -#endif -#else --- HUGS -import qualified IOExts -#endif - -#ifdef __GLASGOW_HASKELL__ -unsafeCoerce :: a -> b -#if __GLASGOW_HASKELL__ >= 900 -unsafeCoerce = GHC.Exts.unsafeCoerce# -#else -unsafeCoerce = GHC.Base.unsafeCoerce# -#endif -#else --- HUGS -unsafeCoerce :: a -> b -unsafeCoerce = IOExts.unsafeCoerce -#endif - -#ifdef __GLASGOW_HASKELL__ -type Any = GHC.Base.Any -#else --- HUGS -type Any = () -#endif - -data Output_type_code = - Ascii_dec - | Ascii_eqb - | String_dec - | String_eqb - | Byte_eqb - | Byte_eq_dec - -type Output_type = Any - -output :: Output_type_code -> Output_type -output c = - case c of { - Ascii_dec -> - unsafeCoerce - ((Prelude.==) :: Prelude.Char -> Prelude.Char -> Prelude.Bool); - Ascii_eqb -> - unsafeCoerce - ((Prelude.==) :: Prelude.Char -> Prelude.Char -> Prelude.Bool); - String_dec -> - unsafeCoerce - ((Prelude.==) :: Prelude.String -> Prelude.String -> Prelude.Bool); - String_eqb -> - unsafeCoerce - ((Prelude.==) :: Prelude.String -> Prelude.String -> Prelude.Bool); - Byte_eqb -> - unsafeCoerce - ((Prelude.==) :: Prelude.Char -> Prelude.Char -> Prelude.Bool); - Byte_eq_dec -> - unsafeCoerce - ((Prelude.==) :: Prelude.Char -> Prelude.Char -> Prelude.Bool)} - -type Coq__IO a = GHC.Base.IO a - -main :: GHC.Base.IO () -main = - ((Prelude.>>=) (GHC.Base.return output) (\_ -> GHC.Base.return ())) - - diff --git a/stdlib/test-suite/output/Extraction_Haskell_String_12258.v b/stdlib/test-suite/output/Extraction_Haskell_String_12258.v deleted file mode 100644 index 9c9a533e41f9..000000000000 --- a/stdlib/test-suite/output/Extraction_Haskell_String_12258.v +++ /dev/null @@ -1,52 +0,0 @@ -From Stdlib Require Import Extraction. -From Stdlib Require Import ExtrHaskellString. -Extraction Language Haskell. -Set Extraction File Comment "IMPORTANT: If you change this file, make sure that running [cp Extraction_Haskell_String_12258.out Extraction_Haskell_String_12258.hs && ghc -o test Extraction_Haskell_String_12258.hs] succeeds". -Inductive output_type_code := -| ascii_dec -| ascii_eqb -| string_dec -| string_eqb -| byte_eqb -| byte_eq_dec -. - -Definition output_type_sig (c : output_type_code) : { T : Type & T } - := existT (fun T => T) - _ - match c return match c with ascii_dec => _ | _ => _ end with - | ascii_dec => Ascii.ascii_dec - | ascii_eqb => Ascii.eqb - | string_dec => String.string_dec - | string_eqb => String.eqb - | byte_eqb => Byte.eqb - | byte_eq_dec => Byte.byte_eq_dec - end. - -Definition output_type (c : output_type_code) - := Eval cbv [output_type_sig projT1 projT2] in - projT1 (output_type_sig c). -Definition output (c : output_type_code) : output_type c - := Eval cbv [output_type_sig projT1 projT2] in - match c return output_type c with - | ascii_dec as c - | _ as c - => projT2 (output_type_sig c) - end. - -Axiom IO_unit : Set. -Axiom _IO : Set -> Set. -Axiom _IO_bind : forall {A B}, _IO A -> (A -> _IO B) -> _IO B. -Axiom _IO_return : forall {A : Set}, A -> _IO A. -Axiom cast_io : _IO unit -> IO_unit. -Extract Constant _IO "a" => "GHC.Base.IO a". -Extract Inlined Constant _IO_bind => "(Prelude.>>=)". -Extract Inlined Constant _IO_return => "GHC.Base.return". -Extract Inlined Constant IO_unit => "GHC.Base.IO ()". -Extract Inlined Constant cast_io => "". - -Definition main : IO_unit - := cast_io (_IO_bind (_IO_return output) - (fun _ => _IO_return tt)). - -Recursive Extraction main. diff --git a/stdlib/test-suite/output/Fixpoint.out b/stdlib/test-suite/output/Fixpoint.out deleted file mode 100644 index 998872105209..000000000000 --- a/stdlib/test-suite/output/Fixpoint.out +++ /dev/null @@ -1,96 +0,0 @@ -fix F (A B : Set) (f : A -> B) (l : list A) {struct l} : list B := - match l with - | nil => nil - | a :: l0 => f a :: F A B f l0 - end - : forall A B : Set, (A -> B) -> list A -> list B -let fix f (m : nat) : nat := match m with - | 0 => 0 - | S m' => f m' - end in f 0 - : nat -Ltac f id1 id2 := fix id1 2 with (id2 (n:_) (H:odd n) {struct H} : n >= 1) - = cofix inf : Inf := {| projS := inf |} - : Inf -File "./output/Fixpoint.v", line 57, characters 0-51: -Warning: Not a truly recursive fixpoint. [non-recursive,fixpoints,default] -File "./output/Fixpoint.v", line 60, characters 0-103: -Warning: Not a fully mutually defined fixpoint -(k1 depends on k2 but not conversely). -Well-foundedness check may fail unexpectedly. - [non-full-mutual,fixpoints,default] -File "./output/Fixpoint.v", line 62, characters 0-106: -Warning: Not a fully mutually defined fixpoint -(l2 and l1 are not mutually dependent). -Well-foundedness check may fail unexpectedly. - [non-full-mutual,fixpoints,default] -File "./output/Fixpoint.v", line 64, characters 0-103: -Warning: Not a fully mutually defined fixpoint -(m2 and m1 are not mutually dependent). -Well-foundedness check may fail unexpectedly. - [non-full-mutual,fixpoints,default] -File "./output/Fixpoint.v", line 72, characters 0-25: -Warning: Not a truly recursive cofixpoint. [non-recursive,fixpoints,default] -File "./output/Fixpoint.v", line 75, characters 0-48: -Warning: Not a fully mutually defined cofixpoint -(a2 and a1 are not mutually dependent). - [non-full-mutual,fixpoints,default] -File "./output/Fixpoint.v", line 91, characters 2-15: -The command has indeed failed with message: -Recursive definition of foo and bar is ill-formed. -As a mutual fixpoint: -Not enough abstractions in the definition. -The 1st recursive definition is: "?Goal". -The 2nd recursive definition is: "?Goal0". -The condition holds up to here. -File "./output/Fixpoint.v", line 96, characters 6-19: -The command has indeed failed with message: -Recursive definition of foo and bar is ill-formed. -As a mutual fixpoint decreasing on the 1st argument of foo and -1st argument of bar: -Recursive call to bar has principal argument equal to -"0" instead of -a subterm of "n". -As a mutual fixpoint decreasing on the 1st argument of foo and -2nd argument of bar: -Recursive call to bar has principal argument equal to -"0" instead of -a subterm of "n". -As a mutual fixpoint decreasing on the 2nd argument of foo and -1st argument of bar: -Recursive call to bar has principal argument equal to -"0" instead of -a subterm of "m". -As a mutual fixpoint decreasing on the 2nd argument of foo and -2nd argument of bar: -Recursive call to bar has principal argument equal to -"0" instead of a subterm of "m". -The 1st recursive definition is: -"fun n m : nat => - match n with - | 0 => bar 0 0 - | S n0 => (fun n1 : nat => ?Goal0@{n:=n1}) n0 - end". -The 2nd recursive definition is: "fun n m : nat => ?Goal". -The condition holds up to here. -The condition holds up to here. -The condition holds up to here. -The condition holds up to here. -File "./output/Fixpoint.v", line 123, characters 6-19: -The command has indeed failed with message: -Recursive definition of foo' and bar' is ill-formed. -As a mutual fixpoint decreasing on the 1st argument of foo' and -1st argument of bar': -Fixpoints on proof irrelevant inductive types should produce proof irrelevant -values. -As a mutual fixpoint decreasing on the 1st argument of foo' and -2nd argument of bar': -Recursive call to bar' has principal argument equal to -"0" instead of a subterm of "n". -The 1st recursive definition is: -"fun (n : nat) (m : Prop) => - match n with - | 0 => bar' SI 0 - | S n0 => (fun n1 : nat => ?Goal0@{n:=n1}) n0 - end". -The 2nd recursive definition is: "fun (n : STrue) (m : nat) => ?Goal". diff --git a/stdlib/test-suite/output/Fixpoint.v b/stdlib/test-suite/output/Fixpoint.v deleted file mode 100644 index d9231be879f4..000000000000 --- a/stdlib/test-suite/output/Fixpoint.v +++ /dev/null @@ -1,126 +0,0 @@ -From Stdlib Require Import List. - -Check - (fix F (A B : Set) (f : A -> B) (l : list A) {struct l} : - list B := match l with - | nil => nil - | a :: l => f a :: F _ _ f l - end). - -(* V8 printing of this term used to failed in V8.0 and V8.0pl1 (cf BZ#860) *) -Check - let fix f (m : nat) : nat := - match m with - | O => 0 - | S m' => f m' - end - in f 0. - -From Stdlib Require Import BinInt Lia. -Open Scope Z_scope. - -Inductive even: Z -> Prop := -| even_base: even 0 -| even_succ: forall n, odd (n - 1) -> even n -with odd: Z -> Prop := -| odd_succ: forall n, even (n - 1) -> odd n. - -(* Check printing of fix *) -Ltac f id1 id2 := fix id1 2 with (id2 n (H:odd n) {struct H} : n >= 1). -Print Ltac f. - -(* Incidentally check use of fix in proofs *) -Lemma even_pos_odd_pos: forall n, even n -> n >= 0. -Proof. -fix even_pos_odd_pos 2 with (odd_pos_even_pos n (H:odd n) {struct H} : n >= 1). - intros. - destruct H. - lia. - apply odd_pos_even_pos in H. - lia. - intros. - destruct H. - apply even_pos_odd_pos in H. - lia. -Qed. - -CoInductive Inf := IS { projS : Inf }. -Definition expand_Inf (x : Inf) := IS (projS x). -CoFixpoint inf := IS inf. -Eval compute in inf. - -Module Recursivity. - -Open Scope nat_scope. - -Fixpoint f n := match n with 0 => 0 | S n => f n end. -Fixpoint g n := match n with 0 => 0 | S n => n end. -Fixpoint h1 n := match n with 0 => 0 | S n => h2 n end -with h2 n := match n with 0 => 0 | S n => h1 n end. -Fixpoint k1 n := match n with 0 => 0 | S n => k2 n end -with k2 n := match n with 0 => 0 | S n => n end. -Fixpoint l1 n := match n with 0 => 0 | S n => l1 n end -with l2 n := match n with 0 => 0 | S n => l2 n end. -Fixpoint m1 n := match n with 0 => 0 | S n => m1 n end -with m2 n := match n with 0 => 0 | S n => n end. -(* Why not to allow this definition ? -Fixpoint h1' n := match n with 0 => 0 | S n => h2' n end -with h2' n := h1' n. -*) -CoInductive S := cons : nat -> S -> S. -CoFixpoint c := cons 0 c. -CoFixpoint d := cons 0 c. -CoFixpoint e1 := cons 0 e2 -with e2 := cons 1 e1. -CoFixpoint a1 := cons 0 a1 -with a2 := cons 1 a2. -(* Why not to allow this definition ? -CoFixpoint b1 := cons 0 b2 -with b2 := b1. -*) - -End Recursivity. - -Module Guard. - -Open Scope nat_scope. - -Lemma foo : nat -> nat -> bool -with bar : nat -> nat -> bool. -Proof. - Fail Guarded. (* not enough abstractions in the definition *) - all:intros n m. - Guarded. - - destruct n as [|n]. - + exact (bar 0 0). - Fail Guarded. (* failure is correct here *) -Abort. - -Lemma foo : nat -> nat -> bool -with bar : nat -> nat -> bool. -Proof. - all:intros n m. - - destruct n as [|n]. - + exact true. - + Guarded. - exact (bar m n). - - Guarded. - destruct m as [|m]. - + exact false. - + exact (foo m n). - Guarded. -Defined. - -Inductive STrue : SProp := SI. - -Lemma foo' : nat -> Prop -> bool -with bar' : STrue -> nat -> bool. -Proof. - all:intros n m. - - destruct n as [|n]. - Guarded. - + exact (bar' SI 0). - Fail Guarded. -Abort. - -End Guard. diff --git a/stdlib/test-suite/output/FloatExtraction.out b/stdlib/test-suite/output/FloatExtraction.out deleted file mode 100644 index 8ded8bce34ac..000000000000 --- a/stdlib/test-suite/output/FloatExtraction.out +++ /dev/null @@ -1,83 +0,0 @@ -File "./output/FloatExtraction.v", line 25, characters 8-12: -Warning: The constant 0.01 is not a binary64 floating-point value. A closest -value 0x1.47ae147ae147bp-7 will be used and unambiguously printed 0.01. -[inexact-float,parsing,default] -File "./output/FloatExtraction.v", line 25, characters 20-25: -Warning: The constant -0.01 is not a binary64 floating-point value. A closest -value -0x1.47ae147ae147bp-7 will be used and unambiguously printed -0.01. -[inexact-float,parsing,default] -File "./output/FloatExtraction.v", line 25, characters 27-35: -Warning: The constant 1.7e+308 is not a binary64 floating-point value. A -closest value 0x1.e42d130773b76p+1023 will be used and unambiguously printed -1.6999999999999999e+308. [inexact-float,parsing,default] -File "./output/FloatExtraction.v", line 25, characters 37-46: -Warning: The constant -1.7e-308 is not a binary64 floating-point value. A -closest value -0x0.c396c98f8d899p-1022 will be used and unambiguously printed --1.7000000000000002e-308. [inexact-float,parsing,default] - -(** val infinity : Float64.t **) - -let infinity = - (Float64.of_float (infinity)) - -(** val neg_infinity : Float64.t **) - -let neg_infinity = - (Float64.of_float (neg_infinity)) - -(** val nan : Float64.t **) - -let nan = - (Float64.of_float (nan)) - -(** val one : Float64.t **) - -let one = - (Float64.of_float (0x1p+0)) - -(** val zero : Float64.t **) - -let zero = - (Float64.of_float (0x0p+0)) - -(** val two : Float64.t **) - -let two = - (Float64.of_float (0x1p+1)) - -(** val list_floats : Float64.t list **) - -let list_floats = - nan :: (infinity :: (neg_infinity :: (zero :: (one :: (two :: ((Float64.of_float (0x1p-1)) :: ((Float64.of_float (0x1.47ae147ae147bp-7)) :: ((Float64.of_float (-0x1p-1)) :: ((Float64.of_float (-0x1.47ae147ae147bp-7)) :: ((Float64.of_float (0x1.e42d130773b76p+1023)) :: ((Float64.of_float (-0x0.c396c98f8d899p-1022)) :: []))))))))))) - - -(** val sqrt : Float64.t -> Float64.t **) - -let sqrt = Float64.sqrt - -(** val opp : Float64.t -> Float64.t **) - -let opp = Float64.opp - -(** val mul : Float64.t -> Float64.t -> Float64.t **) - -let mul = Float64.mul - -(** val sub : Float64.t -> Float64.t -> Float64.t **) - -let sub = Float64.sub - -(** val div : Float64.t -> Float64.t -> Float64.t **) - -let div = Float64.div - -(** val discr : Float64.t -> Float64.t -> Float64.t -> Float64.t **) - -let discr a b c = - sub (mul b b) (mul (mul (Float64.of_float (0x1p+2)) a) c) - -(** val x1 : Float64.t -> Float64.t -> Float64.t -> Float64.t **) - -let x1 a b c = - div (sub (opp b) (sqrt (discr a b c))) (mul (Float64.of_float (0x1p+1)) a) - diff --git a/stdlib/test-suite/output/FloatExtraction.v b/stdlib/test-suite/output/FloatExtraction.v deleted file mode 100644 index f15f35d7147a..000000000000 --- a/stdlib/test-suite/output/FloatExtraction.v +++ /dev/null @@ -1,33 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* list [ "[]" "( :: )" ]. - -Local Open Scope float_scope. - -(* Avoid exponents with less than three digits as they are usually - displayed with two digits (1e7 is displayed 1e+07) except on - Windows where three digits are used (1e+007). *) -Definition list_floats := - [nan; infinity; neg_infinity; zero; one; two; - 0.5; 0.01; -0.5; -0.01; 1.7e+308; -1.7e-308]. - -Recursive Extraction list_floats. - -Definition discr a b c := b * b - 4.0 * a * c. - -Definition x1 a b c := (- b - sqrt (discr a b c)) / (2.0 * a). - -Recursive Extraction x1. diff --git a/stdlib/test-suite/output/FunExt.out b/stdlib/test-suite/output/FunExt.out deleted file mode 100644 index 81981da7204a..000000000000 --- a/stdlib/test-suite/output/FunExt.out +++ /dev/null @@ -1,18 +0,0 @@ -File "./output/FunExt.v", line 15, characters 5-24: -The command has indeed failed with message: -Tactic failure: Not an extensional equality. -File "./output/FunExt.v", line 17, characters 5-24: -The command has indeed failed with message: -Tactic failure: Not an extensional equality. -File "./output/FunExt.v", line 18, characters 5-26: -The command has indeed failed with message: -Tactic failure: Not an extensional equality. -File "./output/FunExt.v", line 93, characters 9-28: -The command has indeed failed with message: -Tactic failure: Not an extensional equality. -File "./output/FunExt.v", line 149, characters 9-28: -The command has indeed failed with message: -Tactic failure: Already an intensional equality. -File "./output/FunExt.v", line 162, characters 9-29: -The command has indeed failed with message: -Hypothesis e depends on the body of H' diff --git a/stdlib/test-suite/output/FunExt.v b/stdlib/test-suite/output/FunExt.v deleted file mode 100644 index f1b0f63b5fc1..000000000000 --- a/stdlib/test-suite/output/FunExt.v +++ /dev/null @@ -1,169 +0,0 @@ -(* -*- coq-prog-args: ("-async-proofs" "no") -*- *) -From Stdlib Require Import FunctionalExtensionality. - -(* Basic example *) -Goal (forall x y z, x+y+z = z+y+x) -> (fun x y z => z+y+x) = (fun x y z => x+y+z). -intro H. -extensionality in H. -symmetry in H. -assumption. -Qed. - -(* Test rejection of non-equality *) -Goal forall H:(forall A:Prop, A), H=H -> forall H'':True, H''=H''. -intros H H' H''. -Fail extensionality in H. -clear H'. -Fail extensionality in H. -Fail extensionality in H''. -Abort. - -(* Test success on dependent equality *) -Goal forall (p : forall x, S x = x + 1), p = p -> S = fun x => x + 1. -intros p H. -extensionality in p. -assumption. -Qed. - -(* Test dependent functional extensionality *) -Goal forall (P:nat->Type) (Q:forall a, P a -> Type) (f g:forall a (b:P a), Q a b), - (forall x y, f x y = g x y) -> f = g. -intros * H. -extensionality in H. -assumption. -Qed. - -(* Other tests, courtesy of Jason Gross *) - -Goal forall A B C (D : forall a : A, C a -> Type) (f g : forall a : A, B -> forall c : C a, D a c), (forall a b c, f a b c = g a b c) -> f = g. -Proof. - intros A B C D f g H. - extensionality in H. - match type of H with f = g => idtac end. - exact H. -Qed. - -Section test_section. - Context A B C (D : forall a : A, C a -> Type) (f g : forall a : A, B -> forall c : C a, D a c) - (H : forall a b c, f a b c = g a b c). - Goal f = g. - Proof. - extensionality in H. - match type of H with f = g => idtac end. - exact H. - Qed. -End test_section. - -Section test2. - Context A B C (D : forall a : A, C a -> Type) (f g : forall a : A, B -> forall c : C a, D a c) - (H : forall b a c, f a b c = g a b c). - Goal (fun b a c => f a b c) = (fun b a c => g a b c). - Proof. - extensionality in H. - match type of H with (fun b a => f a b) = (fun b' a' => g a' b') => idtac end. - exact H. - Qed. -End test2. - -Section test3. - Context A B C (D : forall a : A, C a -> Type) (f g : forall a : A, B -> forall c : C a, D a c) - (H : forall a c, (fun b => f a b c) = (fun b => g a b c)). - Goal (fun a c b => f a b c) = (fun a c b => g a b c). - Proof. - extensionality in H. - match type of H with (fun a c b => f a b c) = (fun a' c' b' => g a' b' c') => idtac end. - exact H. - Qed. -End test3. - -Section test4. - Context A B C (D : forall a : A, C a -> Type) (f g : forall a : A, B -> forall c : C a, D a c -> Type) - (H : forall b, (forall a c d, f a b c d) = (forall a c d, g a b c d)). - Goal (fun b => forall a c d, f a b c d) = (fun b => forall a c d, g a b c d). - Proof. - extensionality in H. - exact H. - Qed. -End test4. - -Section test5. - Goal nat -> True. - Proof. - intro n. - Fail extensionality in n. - constructor. - Qed. -End test5. - -Section test6. - Goal let f := fun A (x : A) => x in let pf := fun A x => @eq_refl _ (f A x) in f = f. - Proof. - intros f pf. - extensionality in pf. - match type of pf with f = f => idtac end. - exact pf. - Qed. -End test6. - -Section test7. - Context A B C (D : forall a : A, C a -> Type) (f g : forall a : A, B -> forall c : C a, D a c) - (H : forall a b c, True -> f a b c = g a b c). - Goal True. - Proof. - extensionality in H. - match type of H with (fun a b c (_ : True) => f a b c) = (fun a' b' c' (_ : True) => g a' b' c') => idtac end. - constructor. - Qed. -End test7. - -Section test8. - Context A B C (D : forall a : A, C a -> Type) (f g : forall a : A, B -> forall c : C a, D a c) - (H : True -> forall a b c, f a b c = g a b c). - Goal True. - Proof. - extensionality in H. - match type of H with (fun (_ : True) => f) = (fun (_ : True) => g) => idtac end. - constructor. - Qed. -End test8. - -Section test9. - Context A B C (D : forall a : A, C a -> Type) (f g : forall a : A, B -> forall c : C a, D a c) - (H : forall b a c, f a b c = g a b c). - Goal (fun b a c => f a b c) = (fun b a c => g a b c). - Proof. - pose H as H'. - extensionality in H. - extensionality in H'. - let T := type of H in let T' := type of H' in constr_eq T T'. - match type of H with (fun b a => f a b) = (fun b' a' => g a' b') => idtac end. - exact H'. - Qed. -End test9. - -Section test10. - Context A B C (D : forall a : A, C a -> Type) (f g : forall a : A, B -> forall c : C a, D a c) - (H : f = g). - Goal True. - Proof. - Fail extensionality in H. - constructor. - Qed. -End test10. - -Section test11. - Context A B C (D : forall a : A, C a -> Type) (f g : forall a : A, B -> forall c : C a, D a c) - (H : forall a b c, f a b c = f a b c). - Goal True. - Proof. - pose H as H'. - pose (eq_refl : H = H') as e. - extensionality in H. - Fail extensionality in H'. - clear e. - extensionality in H'. - let T := type of H in let T' := type of H' in constr_eq T T'. - lazymatch type of H with f = f => idtac end. - constructor. - Qed. -End test11. diff --git a/stdlib/test-suite/output/Function.out b/stdlib/test-suite/output/Function.out deleted file mode 100644 index b3651514d7f9..000000000000 --- a/stdlib/test-suite/output/Function.out +++ /dev/null @@ -1,3 +0,0 @@ -File "./output/Function.v", line 28, characters 4-5: -Warning: Unused variable n might be a misspelled constructor. Use _ or _n to -silence this warning. [unused-pattern-matching-variable,default] diff --git a/stdlib/test-suite/output/Function.v b/stdlib/test-suite/output/Function.v deleted file mode 100644 index 98a18fb174b7..000000000000 --- a/stdlib/test-suite/output/Function.v +++ /dev/null @@ -1,37 +0,0 @@ -From Stdlib Require Import FunInd List. - -(* Explanations: This kind of pattern matching displays a legitimate - unused variable warning in v8.13. - -Fixpoint f (l:list nat) : nat := - match l with - | nil => O - | S n :: nil => 1 - | x :: l' => f l' - end. -*) - -(* In v8.13 the same code with "Function" generates a lot more - warnings about variables created automatically by Function. These - are not legitimate. PR #13776 (post v8.13) removes all warnings - about pattern matching variables (and non truly recursive fixpoint) - for "Function". So this should not generate any warning. Note that - this PR removes also the legitimate warnings. It would be better if - this test generate the same warning as the Fixpoint above. This - test would then need to be updated. *) - -(* Ensuring the warning is a warning. *) -Fixpoint f (l:list nat) : nat := - match l with - | nil => O - | S n :: nil => 1 - | n :: l' => f l' - end. - -(* But no warning generated here. *) -Function g (l:list nat) : nat := - match l with - | nil => O - | S n :: nil => 1 - | n :: l' => g l' - end. diff --git a/stdlib/test-suite/output/InfoMicromega.out b/stdlib/test-suite/output/InfoMicromega.out deleted file mode 100644 index 980db181d2a6..000000000000 --- a/stdlib/test-suite/output/InfoMicromega.out +++ /dev/null @@ -1,2 +0,0 @@ -Micromega used hypotheses: H2, H0 and H -Micromega used hypotheses: H2, H0 and H diff --git a/stdlib/test-suite/output/InfoMicromega.v b/stdlib/test-suite/output/InfoMicromega.v deleted file mode 100644 index 094245f16d63..000000000000 --- a/stdlib/test-suite/output/InfoMicromega.v +++ /dev/null @@ -1,17 +0,0 @@ -From Stdlib Require Import Reals Lra. -Open Scope R_scope. - -Set Info Micromega. - -Goal forall (x y z:R), x + y > 0 -> x - y > 0 -> x + z = 0 -> x < 0 -> False. -Proof. - intros. - lra. -Qed. - -Goal forall (x y z:R), x + y > 0 -> x - y > 0 -> x + z = 0 -> x < 0 -> False. -Proof. - intros. - clear - H2 H0 H. - lra. -Qed. diff --git a/stdlib/test-suite/output/Intuition.out b/stdlib/test-suite/output/Intuition.out deleted file mode 100644 index e273307d75d2..000000000000 --- a/stdlib/test-suite/output/Intuition.out +++ /dev/null @@ -1,6 +0,0 @@ -1 goal - - m, n : Z - H : (m >= n)%Z - ============================ - (m >= m)%Z diff --git a/stdlib/test-suite/output/Intuition.v b/stdlib/test-suite/output/Intuition.v deleted file mode 100644 index b42a021b9961..000000000000 --- a/stdlib/test-suite/output/Intuition.v +++ /dev/null @@ -1,5 +0,0 @@ -From Stdlib Require Import BinInt. -Goal forall m n : Z, (m >= n)%Z -> (m >= m)%Z /\ (m >= n)%Z. -intros; intuition. -Show. -Abort. diff --git a/stdlib/test-suite/output/MExtraction.out b/stdlib/test-suite/output/MExtraction.out deleted file mode 100644 index 179e588c09d7..000000000000 --- a/stdlib/test-suite/output/MExtraction.out +++ /dev/null @@ -1,2645 +0,0 @@ - -type __ = Obj.t - -type unit0 = -| Tt - -(** val negb : bool -> bool **) - -let negb = function -| true -> false -| false -> true - -type nat = -| O -| S of nat - -type ('a, 'b) sum = -| Inl of 'a -| Inr of 'b - -(** val fst : ('a1 * 'a2) -> 'a1 **) - -let fst = function -| x,_ -> x - -(** val snd : ('a1 * 'a2) -> 'a2 **) - -let snd = function -| _,y -> y - -(** val app : 'a1 list -> 'a1 list -> 'a1 list **) - -let rec app l m = - match l with - | [] -> m - | a::l1 -> a::(app l1 m) - -type comparison = -| Eq -| Lt -| Gt - -(** val compOpp : comparison -> comparison **) - -let compOpp = function -| Eq -> Eq -| Lt -> Gt -| Gt -> Lt - -module Coq__1 = struct - (** val add : nat -> nat -> nat **) - - let rec add n0 m = - match n0 with - | O -> m - | S p -> S (add p m) -end -include Coq__1 - -(** val map : ('a1 -> 'a2) -> 'a1 list -> 'a2 list **) - -let rec map f = function -| [] -> [] -| a::l0 -> (f a)::(map f l0) - -(** val nth : nat -> 'a1 list -> 'a1 -> 'a1 **) - -let rec nth n0 l default = - match n0 with - | O -> (match l with - | [] -> default - | x::_ -> x) - | S m -> (match l with - | [] -> default - | _::l' -> nth m l' default) - -(** val rev_append : 'a1 list -> 'a1 list -> 'a1 list **) - -let rec rev_append l l' = - match l with - | [] -> l' - | a::l0 -> rev_append l0 (a::l') - -(** val fold_left : ('a1 -> 'a2 -> 'a1) -> 'a2 list -> 'a1 -> 'a1 **) - -let rec fold_left f l a0 = - match l with - | [] -> a0 - | b::l0 -> fold_left f l0 (f a0 b) - -(** val fold_right : ('a2 -> 'a1 -> 'a1) -> 'a1 -> 'a2 list -> 'a1 **) - -let rec fold_right f a0 = function -| [] -> a0 -| b::l0 -> f b (fold_right f a0 l0) - -type positive = -| XI of positive -| XO of positive -| XH - -type n = -| N0 -| Npos of positive - -type z = -| Z0 -| Zpos of positive -| Zneg of positive - -module Pos = - struct - (** val succ : positive -> positive **) - - let rec succ = function - | XI p -> XO (succ p) - | XO p -> XI p - | XH -> XO XH - - (** val add : positive -> positive -> positive **) - - let rec add x y = - match x with - | XI p -> - (match y with - | XI q0 -> XO (add_carry p q0) - | XO q0 -> XI (add p q0) - | XH -> XO (succ p)) - | XO p -> - (match y with - | XI q0 -> XI (add p q0) - | XO q0 -> XO (add p q0) - | XH -> XI p) - | XH -> (match y with - | XI q0 -> XO (succ q0) - | XO q0 -> XI q0 - | XH -> XO XH) - - (** val add_carry : positive -> positive -> positive **) - - and add_carry x y = - match x with - | XI p -> - (match y with - | XI q0 -> XI (add_carry p q0) - | XO q0 -> XO (add_carry p q0) - | XH -> XI (succ p)) - | XO p -> - (match y with - | XI q0 -> XO (add_carry p q0) - | XO q0 -> XI (add p q0) - | XH -> XO (succ p)) - | XH -> - (match y with - | XI q0 -> XI (succ q0) - | XO q0 -> XO (succ q0) - | XH -> XI XH) - - (** val pred_double : positive -> positive **) - - let rec pred_double = function - | XI p -> XI (XO p) - | XO p -> XI (pred_double p) - | XH -> XH - - type mask = - | IsNul - | IsPos of positive - | IsNeg - - (** val mul : positive -> positive -> positive **) - - let rec mul x y = - match x with - | XI p -> add y (XO (mul p y)) - | XO p -> XO (mul p y) - | XH -> y - - (** val iter : ('a1 -> 'a1) -> 'a1 -> positive -> 'a1 **) - - let rec iter f x = function - | XI n' -> f (iter f (iter f x n') n') - | XO n' -> iter f (iter f x n') n' - | XH -> f x - - (** val compare_cont : comparison -> positive -> positive -> comparison **) - - let rec compare_cont r x y = - match x with - | XI p -> - (match y with - | XI q0 -> compare_cont r p q0 - | XO q0 -> compare_cont Gt p q0 - | XH -> Gt) - | XO p -> - (match y with - | XI q0 -> compare_cont Lt p q0 - | XO q0 -> compare_cont r p q0 - | XH -> Gt) - | XH -> (match y with - | XH -> r - | _ -> Lt) - - (** val compare : positive -> positive -> comparison **) - - let compare = - compare_cont Eq - - (** val eqb : positive -> positive -> bool **) - - let rec eqb p q0 = - match p with - | XI p2 -> (match q0 with - | XI q1 -> eqb p2 q1 - | _ -> false) - | XO p2 -> (match q0 with - | XO q1 -> eqb p2 q1 - | _ -> false) - | XH -> (match q0 with - | XH -> true - | _ -> false) - - (** val of_succ_nat : nat -> positive **) - - let rec of_succ_nat = function - | O -> XH - | S x -> succ (of_succ_nat x) - end - -module Coq_Pos = - struct - (** val succ : positive -> positive **) - - let rec succ = function - | XI p -> XO (succ p) - | XO p -> XI p - | XH -> XO XH - - (** val add : positive -> positive -> positive **) - - let rec add x y = - match x with - | XI p -> - (match y with - | XI q0 -> XO (add_carry p q0) - | XO q0 -> XI (add p q0) - | XH -> XO (succ p)) - | XO p -> - (match y with - | XI q0 -> XI (add p q0) - | XO q0 -> XO (add p q0) - | XH -> XI p) - | XH -> (match y with - | XI q0 -> XO (succ q0) - | XO q0 -> XI q0 - | XH -> XO XH) - - (** val add_carry : positive -> positive -> positive **) - - and add_carry x y = - match x with - | XI p -> - (match y with - | XI q0 -> XI (add_carry p q0) - | XO q0 -> XO (add_carry p q0) - | XH -> XI (succ p)) - | XO p -> - (match y with - | XI q0 -> XO (add_carry p q0) - | XO q0 -> XI (add p q0) - | XH -> XO (succ p)) - | XH -> - (match y with - | XI q0 -> XI (succ q0) - | XO q0 -> XO (succ q0) - | XH -> XI XH) - - (** val pred_double : positive -> positive **) - - let rec pred_double = function - | XI p -> XI (XO p) - | XO p -> XI (pred_double p) - | XH -> XH - - type mask = Pos.mask = - | IsNul - | IsPos of positive - | IsNeg - - (** val succ_double_mask : mask -> mask **) - - let succ_double_mask = function - | IsNul -> IsPos XH - | IsPos p -> IsPos (XI p) - | IsNeg -> IsNeg - - (** val double_mask : mask -> mask **) - - let double_mask = function - | IsPos p -> IsPos (XO p) - | x0 -> x0 - - (** val double_pred_mask : positive -> mask **) - - let double_pred_mask = function - | XI p -> IsPos (XO (XO p)) - | XO p -> IsPos (XO (pred_double p)) - | XH -> IsNul - - (** val sub_mask : positive -> positive -> mask **) - - let rec sub_mask x y = - match x with - | XI p -> - (match y with - | XI q0 -> double_mask (sub_mask p q0) - | XO q0 -> succ_double_mask (sub_mask p q0) - | XH -> IsPos (XO p)) - | XO p -> - (match y with - | XI q0 -> succ_double_mask (sub_mask_carry p q0) - | XO q0 -> double_mask (sub_mask p q0) - | XH -> IsPos (pred_double p)) - | XH -> (match y with - | XH -> IsNul - | _ -> IsNeg) - - (** val sub_mask_carry : positive -> positive -> mask **) - - and sub_mask_carry x y = - match x with - | XI p -> - (match y with - | XI q0 -> succ_double_mask (sub_mask_carry p q0) - | XO q0 -> double_mask (sub_mask p q0) - | XH -> IsPos (pred_double p)) - | XO p -> - (match y with - | XI q0 -> double_mask (sub_mask_carry p q0) - | XO q0 -> succ_double_mask (sub_mask_carry p q0) - | XH -> double_pred_mask p) - | XH -> IsNeg - - (** val sub : positive -> positive -> positive **) - - let sub x y = - match sub_mask x y with - | IsPos z0 -> z0 - | _ -> XH - - (** val mul : positive -> positive -> positive **) - - let rec mul x y = - match x with - | XI p -> add y (XO (mul p y)) - | XO p -> XO (mul p y) - | XH -> y - - (** val compare_cont : comparison -> positive -> positive -> comparison **) - - let rec compare_cont r x y = - match x with - | XI p -> - (match y with - | XI q0 -> compare_cont r p q0 - | XO q0 -> compare_cont Gt p q0 - | XH -> Gt) - | XO p -> - (match y with - | XI q0 -> compare_cont Lt p q0 - | XO q0 -> compare_cont r p q0 - | XH -> Gt) - | XH -> (match y with - | XH -> r - | _ -> Lt) - - (** val compare : positive -> positive -> comparison **) - - let compare = - compare_cont Eq - - (** val leb : positive -> positive -> bool **) - - let leb x y = - match compare x y with - | Gt -> false - | _ -> true - - (** val size_nat : positive -> nat **) - - let rec size_nat = function - | XI p2 -> S (size_nat p2) - | XO p2 -> S (size_nat p2) - | XH -> S O - - (** val max : positive -> positive -> positive **) - - let max p p' = - match compare p p' with - | Gt -> p - | _ -> p' - - (** val gcdn : nat -> positive -> positive -> positive **) - - let rec gcdn n0 a b = - match n0 with - | O -> XH - | S n1 -> - (match a with - | XI a' -> - (match b with - | XI b' -> - (match compare a' b' with - | Eq -> a - | Lt -> gcdn n1 (sub b' a') a - | Gt -> gcdn n1 (sub a' b') b) - | XO b0 -> gcdn n1 a b0 - | XH -> XH) - | XO a0 -> - (match b with - | XI _ -> gcdn n1 a0 b - | XO b0 -> XO (gcdn n1 a0 b0) - | XH -> XH) - | XH -> XH) - - (** val gcd : positive -> positive -> positive **) - - let gcd a b = - gcdn (Coq__1.add (size_nat a) (size_nat b)) a b - end - -module N = - struct - (** val of_nat : nat -> n **) - - let of_nat = function - | O -> N0 - | S n' -> Npos (Pos.of_succ_nat n') - end - -(** val pow_pos : ('a1 -> 'a1 -> 'a1) -> 'a1 -> positive -> 'a1 **) - -let rec pow_pos rmul x = function -| XI i0 -> let p = pow_pos rmul x i0 in rmul x (rmul p p) -| XO i0 -> let p = pow_pos rmul x i0 in rmul p p -| XH -> x - -module Z = - struct - (** val double : z -> z **) - - let double = function - | Z0 -> Z0 - | Zpos p -> Zpos (XO p) - | Zneg p -> Zneg (XO p) - - (** val succ_double : z -> z **) - - let succ_double = function - | Z0 -> Zpos XH - | Zpos p -> Zpos (XI p) - | Zneg p -> Zneg (Pos.pred_double p) - - (** val pred_double : z -> z **) - - let pred_double = function - | Z0 -> Zneg XH - | Zpos p -> Zpos (Pos.pred_double p) - | Zneg p -> Zneg (XI p) - - (** val pos_sub : positive -> positive -> z **) - - let rec pos_sub x y = - match x with - | XI p -> - (match y with - | XI q0 -> double (pos_sub p q0) - | XO q0 -> succ_double (pos_sub p q0) - | XH -> Zpos (XO p)) - | XO p -> - (match y with - | XI q0 -> pred_double (pos_sub p q0) - | XO q0 -> double (pos_sub p q0) - | XH -> Zpos (Pos.pred_double p)) - | XH -> - (match y with - | XI q0 -> Zneg (XO q0) - | XO q0 -> Zneg (Pos.pred_double q0) - | XH -> Z0) - - (** val add : z -> z -> z **) - - let add x y = - match x with - | Z0 -> y - | Zpos x' -> - (match y with - | Z0 -> x - | Zpos y' -> Zpos (Pos.add x' y') - | Zneg y' -> pos_sub x' y') - | Zneg x' -> - (match y with - | Z0 -> x - | Zpos y' -> pos_sub y' x' - | Zneg y' -> Zneg (Pos.add x' y')) - - (** val opp : z -> z **) - - let opp = function - | Z0 -> Z0 - | Zpos x0 -> Zneg x0 - | Zneg x0 -> Zpos x0 - - (** val sub : z -> z -> z **) - - let sub m n0 = - add m (opp n0) - - (** val mul : z -> z -> z **) - - let mul x y = - match x with - | Z0 -> Z0 - | Zpos x' -> - (match y with - | Z0 -> Z0 - | Zpos y' -> Zpos (Pos.mul x' y') - | Zneg y' -> Zneg (Pos.mul x' y')) - | Zneg x' -> - (match y with - | Z0 -> Z0 - | Zpos y' -> Zneg (Pos.mul x' y') - | Zneg y' -> Zpos (Pos.mul x' y')) - - (** val pow_pos : z -> positive -> z **) - - let pow_pos z0 = - Pos.iter (mul z0) (Zpos XH) - - (** val pow : z -> z -> z **) - - let pow x = function - | Z0 -> Zpos XH - | Zpos p -> pow_pos x p - | Zneg _ -> Z0 - - (** val compare : z -> z -> comparison **) - - let compare x y = - match x with - | Z0 -> (match y with - | Z0 -> Eq - | Zpos _ -> Lt - | Zneg _ -> Gt) - | Zpos x' -> (match y with - | Zpos y' -> Pos.compare x' y' - | _ -> Gt) - | Zneg x' -> - (match y with - | Zneg y' -> compOpp (Pos.compare x' y') - | _ -> Lt) - - (** val leb : z -> z -> bool **) - - let leb x y = - match compare x y with - | Gt -> false - | _ -> true - - (** val ltb : z -> z -> bool **) - - let ltb x y = - match compare x y with - | Lt -> true - | _ -> false - - (** val eqb : z -> z -> bool **) - - let eqb x y = - match x with - | Z0 -> (match y with - | Z0 -> true - | _ -> false) - | Zpos p -> (match y with - | Zpos q0 -> Pos.eqb p q0 - | _ -> false) - | Zneg p -> (match y with - | Zneg q0 -> Pos.eqb p q0 - | _ -> false) - - (** val max : z -> z -> z **) - - let max n0 m = - match compare n0 m with - | Lt -> m - | _ -> n0 - - (** val of_nat : nat -> z **) - - let of_nat = function - | O -> Z0 - | S n1 -> Zpos (Pos.of_succ_nat n1) - - (** val of_N : n -> z **) - - let of_N = function - | N0 -> Z0 - | Npos p -> Zpos p - - (** val pos_div_eucl : positive -> z -> z * z **) - - let rec pos_div_eucl a b = - match a with - | XI a' -> - let q0,r = pos_div_eucl a' b in - let r' = add (mul (Zpos (XO XH)) r) (Zpos XH) in - if ltb r' b - then (mul (Zpos (XO XH)) q0),r' - else (add (mul (Zpos (XO XH)) q0) (Zpos XH)),(sub r' b) - | XO a' -> - let q0,r = pos_div_eucl a' b in - let r' = mul (Zpos (XO XH)) r in - if ltb r' b - then (mul (Zpos (XO XH)) q0),r' - else (add (mul (Zpos (XO XH)) q0) (Zpos XH)),(sub r' b) - | XH -> if leb (Zpos (XO XH)) b then Z0,(Zpos XH) else (Zpos XH),Z0 - - (** val div_eucl : z -> z -> z * z **) - - let div_eucl a b = - match a with - | Z0 -> Z0,Z0 - | Zpos a' -> - (match b with - | Z0 -> Z0,a - | Zpos _ -> pos_div_eucl a' b - | Zneg b' -> - let q0,r = pos_div_eucl a' (Zpos b') in - (match r with - | Z0 -> (opp q0),Z0 - | _ -> (opp (add q0 (Zpos XH))),(add b r))) - | Zneg a' -> - (match b with - | Z0 -> Z0,a - | Zpos _ -> - let q0,r = pos_div_eucl a' b in - (match r with - | Z0 -> (opp q0),Z0 - | _ -> (opp (add q0 (Zpos XH))),(sub b r)) - | Zneg b' -> let q0,r = pos_div_eucl a' (Zpos b') in q0,(opp r)) - - (** val div : z -> z -> z **) - - let div a b = - let q0,_ = div_eucl a b in q0 - - (** val gtb : z -> z -> bool **) - - let gtb x y = - match compare x y with - | Gt -> true - | _ -> false - - (** val abs : z -> z **) - - let abs = function - | Zneg p -> Zpos p - | x -> x - - (** val to_N : z -> n **) - - let to_N = function - | Zpos p -> Npos p - | _ -> N0 - - (** val gcd : z -> z -> z **) - - let gcd a b = - match a with - | Z0 -> abs b - | Zpos a0 -> - (match b with - | Z0 -> abs a - | Zpos b0 -> Zpos (Coq_Pos.gcd a0 b0) - | Zneg b0 -> Zpos (Coq_Pos.gcd a0 b0)) - | Zneg a0 -> - (match b with - | Z0 -> abs a - | Zpos b0 -> Zpos (Coq_Pos.gcd a0 b0) - | Zneg b0 -> Zpos (Coq_Pos.gcd a0 b0)) - end - -type 'c pExpr = -| PEc of 'c -| PEX of positive -| PEadd of 'c pExpr * 'c pExpr -| PEsub of 'c pExpr * 'c pExpr -| PEmul of 'c pExpr * 'c pExpr -| PEopp of 'c pExpr -| PEpow of 'c pExpr * n - -type 'c pol = -| Pc of 'c -| Pinj of positive * 'c pol -| PX of 'c pol * positive * 'c pol - -(** val p0 : 'a1 -> 'a1 pol **) - -let p0 cO = - Pc cO - -(** val p1 : 'a1 -> 'a1 pol **) - -let p1 cI = - Pc cI - -(** val peq : ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> bool **) - -let rec peq ceqb p p' = - match p with - | Pc c -> (match p' with - | Pc c' -> ceqb c c' - | _ -> false) - | Pinj (j, q0) -> - (match p' with - | Pinj (j', q') -> - (match Coq_Pos.compare j j' with - | Eq -> peq ceqb q0 q' - | _ -> false) - | _ -> false) - | PX (p2, i, q0) -> - (match p' with - | PX (p'0, i', q') -> - (match Coq_Pos.compare i i' with - | Eq -> if peq ceqb p2 p'0 then peq ceqb q0 q' else false - | _ -> false) - | _ -> false) - -(** val mkPinj : positive -> 'a1 pol -> 'a1 pol **) - -let mkPinj j p = match p with -| Pc _ -> p -| Pinj (j', q0) -> Pinj ((Coq_Pos.add j j'), q0) -| PX (_, _, _) -> Pinj (j, p) - -(** val mkPinj_pred : positive -> 'a1 pol -> 'a1 pol **) - -let mkPinj_pred j p = - match j with - | XI j0 -> Pinj ((XO j0), p) - | XO j0 -> Pinj ((Coq_Pos.pred_double j0), p) - | XH -> p - -(** val mkPX : - 'a1 -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol **) - -let mkPX cO ceqb p i q0 = - match p with - | Pc c -> if ceqb c cO then mkPinj XH q0 else PX (p, i, q0) - | Pinj (_, _) -> PX (p, i, q0) - | PX (p', i', q') -> - if peq ceqb q' (p0 cO) - then PX (p', (Coq_Pos.add i' i), q0) - else PX (p, i, q0) - -(** val mkXi : 'a1 -> 'a1 -> positive -> 'a1 pol **) - -let mkXi cO cI i = - PX ((p1 cI), i, (p0 cO)) - -(** val mkX : 'a1 -> 'a1 -> 'a1 pol **) - -let mkX cO cI = - mkXi cO cI XH - -(** val popp : ('a1 -> 'a1) -> 'a1 pol -> 'a1 pol **) - -let rec popp copp = function -| Pc c -> Pc (copp c) -| Pinj (j, q0) -> Pinj (j, (popp copp q0)) -| PX (p2, i, q0) -> PX ((popp copp p2), i, (popp copp q0)) - -(** val paddC : ('a1 -> 'a1 -> 'a1) -> 'a1 pol -> 'a1 -> 'a1 pol **) - -let rec paddC cadd p c = - match p with - | Pc c1 -> Pc (cadd c1 c) - | Pinj (j, q0) -> Pinj (j, (paddC cadd q0 c)) - | PX (p2, i, q0) -> PX (p2, i, (paddC cadd q0 c)) - -(** val psubC : ('a1 -> 'a1 -> 'a1) -> 'a1 pol -> 'a1 -> 'a1 pol **) - -let rec psubC csub p c = - match p with - | Pc c1 -> Pc (csub c1 c) - | Pinj (j, q0) -> Pinj (j, (psubC csub q0 c)) - | PX (p2, i, q0) -> PX (p2, i, (psubC csub q0 c)) - -(** val paddI : - ('a1 -> 'a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> - positive -> 'a1 pol -> 'a1 pol **) - -let rec paddI cadd pop q0 j = function -| Pc c -> mkPinj j (paddC cadd q0 c) -| Pinj (j', q') -> - (match Z.pos_sub j' j with - | Z0 -> mkPinj j (pop q' q0) - | Zpos k -> mkPinj j (pop (Pinj (k, q')) q0) - | Zneg k -> mkPinj j' (paddI cadd pop q0 k q')) -| PX (p2, i, q') -> - (match j with - | XI j0 -> PX (p2, i, (paddI cadd pop q0 (XO j0) q')) - | XO j0 -> PX (p2, i, (paddI cadd pop q0 (Coq_Pos.pred_double j0) q')) - | XH -> PX (p2, i, (pop q' q0))) - -(** val psubI : - ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> - 'a1 pol -> positive -> 'a1 pol -> 'a1 pol **) - -let rec psubI cadd copp pop q0 j = function -| Pc c -> mkPinj j (paddC cadd (popp copp q0) c) -| Pinj (j', q') -> - (match Z.pos_sub j' j with - | Z0 -> mkPinj j (pop q' q0) - | Zpos k -> mkPinj j (pop (Pinj (k, q')) q0) - | Zneg k -> mkPinj j' (psubI cadd copp pop q0 k q')) -| PX (p2, i, q') -> - (match j with - | XI j0 -> PX (p2, i, (psubI cadd copp pop q0 (XO j0) q')) - | XO j0 -> PX (p2, i, (psubI cadd copp pop q0 (Coq_Pos.pred_double j0) q')) - | XH -> PX (p2, i, (pop q' q0))) - -(** val paddX : - 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol - -> positive -> 'a1 pol -> 'a1 pol **) - -let rec paddX cO ceqb pop p' i' p = match p with -| Pc _ -> PX (p', i', p) -| Pinj (j, q') -> - (match j with - | XI j0 -> PX (p', i', (Pinj ((XO j0), q'))) - | XO j0 -> PX (p', i', (Pinj ((Coq_Pos.pred_double j0), q'))) - | XH -> PX (p', i', q')) -| PX (p2, i, q') -> - (match Z.pos_sub i i' with - | Z0 -> mkPX cO ceqb (pop p2 p') i q' - | Zpos k -> mkPX cO ceqb (pop (PX (p2, k, (p0 cO))) p') i' q' - | Zneg k -> mkPX cO ceqb (paddX cO ceqb pop p' k p2) i q') - -(** val psubX : - 'a1 -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 - pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol **) - -let rec psubX cO copp ceqb pop p' i' p = match p with -| Pc _ -> PX ((popp copp p'), i', p) -| Pinj (j, q') -> - (match j with - | XI j0 -> PX ((popp copp p'), i', (Pinj ((XO j0), q'))) - | XO j0 -> PX ((popp copp p'), i', (Pinj ((Coq_Pos.pred_double j0), q'))) - | XH -> PX ((popp copp p'), i', q')) -| PX (p2, i, q') -> - (match Z.pos_sub i i' with - | Z0 -> mkPX cO ceqb (pop p2 p') i q' - | Zpos k -> mkPX cO ceqb (pop (PX (p2, k, (p0 cO))) p') i' q' - | Zneg k -> mkPX cO ceqb (psubX cO copp ceqb pop p' k p2) i q') - -(** val padd : - 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol - -> 'a1 pol **) - -let rec padd cO cadd ceqb p = function -| Pc c' -> paddC cadd p c' -| Pinj (j', q') -> paddI cadd (padd cO cadd ceqb) q' j' p -| PX (p'0, i', q') -> - (match p with - | Pc c -> PX (p'0, i', (paddC cadd q' c)) - | Pinj (j, q0) -> - (match j with - | XI j0 -> PX (p'0, i', (padd cO cadd ceqb (Pinj ((XO j0), q0)) q')) - | XO j0 -> - PX (p'0, i', - (padd cO cadd ceqb (Pinj ((Coq_Pos.pred_double j0), q0)) q')) - | XH -> PX (p'0, i', (padd cO cadd ceqb q0 q'))) - | PX (p2, i, q0) -> - (match Z.pos_sub i i' with - | Z0 -> - mkPX cO ceqb (padd cO cadd ceqb p2 p'0) i (padd cO cadd ceqb q0 q') - | Zpos k -> - mkPX cO ceqb (padd cO cadd ceqb (PX (p2, k, (p0 cO))) p'0) i' - (padd cO cadd ceqb q0 q') - | Zneg k -> - mkPX cO ceqb (paddX cO ceqb (padd cO cadd ceqb) p'0 k p2) i - (padd cO cadd ceqb q0 q'))) - -(** val psub : - 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 - -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol **) - -let rec psub cO cadd csub copp ceqb p = function -| Pc c' -> psubC csub p c' -| Pinj (j', q') -> psubI cadd copp (psub cO cadd csub copp ceqb) q' j' p -| PX (p'0, i', q') -> - (match p with - | Pc c -> PX ((popp copp p'0), i', (paddC cadd (popp copp q') c)) - | Pinj (j, q0) -> - (match j with - | XI j0 -> - PX ((popp copp p'0), i', - (psub cO cadd csub copp ceqb (Pinj ((XO j0), q0)) q')) - | XO j0 -> - PX ((popp copp p'0), i', - (psub cO cadd csub copp ceqb (Pinj ((Coq_Pos.pred_double j0), q0)) - q')) - | XH -> PX ((popp copp p'0), i', (psub cO cadd csub copp ceqb q0 q'))) - | PX (p2, i, q0) -> - (match Z.pos_sub i i' with - | Z0 -> - mkPX cO ceqb (psub cO cadd csub copp ceqb p2 p'0) i - (psub cO cadd csub copp ceqb q0 q') - | Zpos k -> - mkPX cO ceqb (psub cO cadd csub copp ceqb (PX (p2, k, (p0 cO))) p'0) - i' (psub cO cadd csub copp ceqb q0 q') - | Zneg k -> - mkPX cO ceqb - (psubX cO copp ceqb (psub cO cadd csub copp ceqb) p'0 k p2) i - (psub cO cadd csub copp ceqb q0 q'))) - -(** val pmulC_aux : - 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 -> - 'a1 pol **) - -let rec pmulC_aux cO cmul ceqb p c = - match p with - | Pc c' -> Pc (cmul c' c) - | Pinj (j, q0) -> mkPinj j (pmulC_aux cO cmul ceqb q0 c) - | PX (p2, i, q0) -> - mkPX cO ceqb (pmulC_aux cO cmul ceqb p2 c) i (pmulC_aux cO cmul ceqb q0 c) - -(** val pmulC : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> - 'a1 -> 'a1 pol **) - -let pmulC cO cI cmul ceqb p c = - if ceqb c cO - then p0 cO - else if ceqb c cI then p else pmulC_aux cO cmul ceqb p c - -(** val pmulI : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> - 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol **) - -let rec pmulI cO cI cmul ceqb pmul0 q0 j = function -| Pc c -> mkPinj j (pmulC cO cI cmul ceqb q0 c) -| Pinj (j', q') -> - (match Z.pos_sub j' j with - | Z0 -> mkPinj j (pmul0 q' q0) - | Zpos k -> mkPinj j (pmul0 (Pinj (k, q')) q0) - | Zneg k -> mkPinj j' (pmulI cO cI cmul ceqb pmul0 q0 k q')) -| PX (p', i', q') -> - (match j with - | XI j' -> - mkPX cO ceqb (pmulI cO cI cmul ceqb pmul0 q0 j p') i' - (pmulI cO cI cmul ceqb pmul0 q0 (XO j') q') - | XO j' -> - mkPX cO ceqb (pmulI cO cI cmul ceqb pmul0 q0 j p') i' - (pmulI cO cI cmul ceqb pmul0 q0 (Coq_Pos.pred_double j') q') - | XH -> - mkPX cO ceqb (pmulI cO cI cmul ceqb pmul0 q0 XH p') i' (pmul0 q' q0)) - -(** val pmul : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 - -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol **) - -let rec pmul cO cI cadd cmul ceqb p p'' = match p'' with -| Pc c -> pmulC cO cI cmul ceqb p c -| Pinj (j', q') -> pmulI cO cI cmul ceqb (pmul cO cI cadd cmul ceqb) q' j' p -| PX (p', i', q') -> - (match p with - | Pc c -> pmulC cO cI cmul ceqb p'' c - | Pinj (j, q0) -> - let qQ' = - match j with - | XI j0 -> pmul cO cI cadd cmul ceqb (Pinj ((XO j0), q0)) q' - | XO j0 -> - pmul cO cI cadd cmul ceqb (Pinj ((Coq_Pos.pred_double j0), q0)) q' - | XH -> pmul cO cI cadd cmul ceqb q0 q' - in - mkPX cO ceqb (pmul cO cI cadd cmul ceqb p p') i' qQ' - | PX (p2, i, q0) -> - let qQ' = pmul cO cI cadd cmul ceqb q0 q' in - let pQ' = pmulI cO cI cmul ceqb (pmul cO cI cadd cmul ceqb) q' XH p2 in - let qP' = pmul cO cI cadd cmul ceqb (mkPinj XH q0) p' in - let pP' = pmul cO cI cadd cmul ceqb p2 p' in - padd cO cadd ceqb - (mkPX cO ceqb (padd cO cadd ceqb (mkPX cO ceqb pP' i (p0 cO)) qP') i' - (p0 cO)) - (mkPX cO ceqb pQ' i qQ')) - -(** val psquare : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 - -> bool) -> 'a1 pol -> 'a1 pol **) - -let rec psquare cO cI cadd cmul ceqb = function -| Pc c -> Pc (cmul c c) -| Pinj (j, q0) -> Pinj (j, (psquare cO cI cadd cmul ceqb q0)) -| PX (p2, i, q0) -> - let twoPQ = - pmul cO cI cadd cmul ceqb p2 - (mkPinj XH (pmulC cO cI cmul ceqb q0 (cadd cI cI))) - in - let q2 = psquare cO cI cadd cmul ceqb q0 in - let p3 = psquare cO cI cadd cmul ceqb p2 in - mkPX cO ceqb (padd cO cadd ceqb (mkPX cO ceqb p3 i (p0 cO)) twoPQ) i q2 - -(** val mk_X : 'a1 -> 'a1 -> positive -> 'a1 pol **) - -let mk_X cO cI j = - mkPinj_pred j (mkX cO cI) - -(** val ppow_pos : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 - -> bool) -> ('a1 pol -> 'a1 pol) -> 'a1 pol -> 'a1 pol -> positive -> 'a1 - pol **) - -let rec ppow_pos cO cI cadd cmul ceqb subst_l res p = function -| XI p3 -> - subst_l - (pmul cO cI cadd cmul ceqb - (ppow_pos cO cI cadd cmul ceqb subst_l - (ppow_pos cO cI cadd cmul ceqb subst_l res p p3) p p3) - p) -| XO p3 -> - ppow_pos cO cI cadd cmul ceqb subst_l - (ppow_pos cO cI cadd cmul ceqb subst_l res p p3) p p3 -| XH -> subst_l (pmul cO cI cadd cmul ceqb res p) - -(** val ppow_N : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 - -> bool) -> ('a1 pol -> 'a1 pol) -> 'a1 pol -> n -> 'a1 pol **) - -let ppow_N cO cI cadd cmul ceqb subst_l p = function -| N0 -> p1 cI -| Npos p2 -> ppow_pos cO cI cadd cmul ceqb subst_l (p1 cI) p p2 - -(** val norm_aux : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 - -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol **) - -let rec norm_aux cO cI cadd cmul csub copp ceqb = function -| PEc c -> Pc c -| PEX j -> mk_X cO cI j -| PEadd (pe1, pe2) -> - (match pe1 with - | PEopp pe3 -> - psub cO cadd csub copp ceqb - (norm_aux cO cI cadd cmul csub copp ceqb pe2) - (norm_aux cO cI cadd cmul csub copp ceqb pe3) - | _ -> - (match pe2 with - | PEopp pe3 -> - psub cO cadd csub copp ceqb - (norm_aux cO cI cadd cmul csub copp ceqb pe1) - (norm_aux cO cI cadd cmul csub copp ceqb pe3) - | _ -> - padd cO cadd ceqb (norm_aux cO cI cadd cmul csub copp ceqb pe1) - (norm_aux cO cI cadd cmul csub copp ceqb pe2))) -| PEsub (pe1, pe2) -> - psub cO cadd csub copp ceqb (norm_aux cO cI cadd cmul csub copp ceqb pe1) - (norm_aux cO cI cadd cmul csub copp ceqb pe2) -| PEmul (pe1, pe2) -> - pmul cO cI cadd cmul ceqb (norm_aux cO cI cadd cmul csub copp ceqb pe1) - (norm_aux cO cI cadd cmul csub copp ceqb pe2) -| PEopp pe1 -> popp copp (norm_aux cO cI cadd cmul csub copp ceqb pe1) -| PEpow (pe1, n0) -> - ppow_N cO cI cadd cmul ceqb (fun p -> p) - (norm_aux cO cI cadd cmul csub copp ceqb pe1) n0 - -type kind = -| IsProp -| IsBool - -type 'a trace = -| Null -| Push of 'a * 'a trace -| Merge of 'a trace * 'a trace - -type ('tA, 'tX, 'aA, 'aF) gFormula = -| TT of kind -| FF of kind -| X of kind * 'tX -| A of kind * 'tA * 'aA -| AND of kind * ('tA, 'tX, 'aA, 'aF) gFormula * ('tA, 'tX, 'aA, 'aF) gFormula -| OR of kind * ('tA, 'tX, 'aA, 'aF) gFormula * ('tA, 'tX, 'aA, 'aF) gFormula -| NOT of kind * ('tA, 'tX, 'aA, 'aF) gFormula -| IMPL of kind * ('tA, 'tX, 'aA, 'aF) gFormula * 'aF option - * ('tA, 'tX, 'aA, 'aF) gFormula -| IFF of kind * ('tA, 'tX, 'aA, 'aF) gFormula * ('tA, 'tX, 'aA, 'aF) gFormula -| EQ of ('tA, 'tX, 'aA, 'aF) gFormula * ('tA, 'tX, 'aA, 'aF) gFormula - -(** val mapX : - (kind -> 'a2 -> 'a2) -> kind -> ('a1, 'a2, 'a3, 'a4) gFormula -> ('a1, - 'a2, 'a3, 'a4) gFormula **) - -let rec mapX f _ = function -| X (k0, x) -> X (k0, (f k0 x)) -| AND (k0, f1, f2) -> AND (k0, (mapX f k0 f1), (mapX f k0 f2)) -| OR (k0, f1, f2) -> OR (k0, (mapX f k0 f1), (mapX f k0 f2)) -| NOT (k0, f1) -> NOT (k0, (mapX f k0 f1)) -| IMPL (k0, f1, o, f2) -> IMPL (k0, (mapX f k0 f1), o, (mapX f k0 f2)) -| IFF (k0, f1, f2) -> IFF (k0, (mapX f k0 f1), (mapX f k0 f2)) -| EQ (f1, f2) -> EQ ((mapX f IsBool f1), (mapX f IsBool f2)) -| x -> x - -(** val foldA : - ('a5 -> 'a3 -> 'a5) -> kind -> ('a1, 'a2, 'a3, 'a4) gFormula -> 'a5 -> 'a5 **) - -let rec foldA f _ f0 acc = - match f0 with - | A (_, _, an) -> f acc an - | AND (k0, f1, f2) -> foldA f k0 f1 (foldA f k0 f2 acc) - | OR (k0, f1, f2) -> foldA f k0 f1 (foldA f k0 f2 acc) - | NOT (k0, f1) -> foldA f k0 f1 acc - | IMPL (k0, f1, _, f2) -> foldA f k0 f1 (foldA f k0 f2 acc) - | IFF (k0, f1, f2) -> foldA f k0 f1 (foldA f k0 f2 acc) - | EQ (f1, f2) -> foldA f IsBool f1 (foldA f IsBool f2 acc) - | _ -> acc - -(** val cons_id : 'a1 option -> 'a1 list -> 'a1 list **) - -let cons_id id l = - match id with - | Some id0 -> id0::l - | None -> l - -(** val ids_of_formula : kind -> ('a1, 'a2, 'a3, 'a4) gFormula -> 'a4 list **) - -let rec ids_of_formula _ = function -| IMPL (k0, _, id, f') -> cons_id id (ids_of_formula k0 f') -| _ -> [] - -(** val collect_annot : kind -> ('a1, 'a2, 'a3, 'a4) gFormula -> 'a3 list **) - -let rec collect_annot _ = function -| A (_, _, a) -> a::[] -| AND (k0, f1, f2) -> app (collect_annot k0 f1) (collect_annot k0 f2) -| OR (k0, f1, f2) -> app (collect_annot k0 f1) (collect_annot k0 f2) -| NOT (k0, f0) -> collect_annot k0 f0 -| IMPL (k0, f1, _, f2) -> app (collect_annot k0 f1) (collect_annot k0 f2) -| IFF (k0, f1, f2) -> app (collect_annot k0 f1) (collect_annot k0 f2) -| EQ (f1, f2) -> app (collect_annot IsBool f1) (collect_annot IsBool f2) -| _ -> [] - -type rtyp = __ - -type eKind = __ - -type 'a bFormula = ('a, eKind, unit0, unit0) gFormula - -(** val map_bformula : - kind -> ('a1 -> 'a2) -> ('a1, 'a3, 'a4, 'a5) gFormula -> ('a2, 'a3, 'a4, - 'a5) gFormula **) - -let rec map_bformula _ fct = function -| TT k -> TT k -| FF k -> FF k -| X (k, p) -> X (k, p) -| A (k, a, t0) -> A (k, (fct a), t0) -| AND (k0, f1, f2) -> - AND (k0, (map_bformula k0 fct f1), (map_bformula k0 fct f2)) -| OR (k0, f1, f2) -> - OR (k0, (map_bformula k0 fct f1), (map_bformula k0 fct f2)) -| NOT (k0, f0) -> NOT (k0, (map_bformula k0 fct f0)) -| IMPL (k0, f1, a, f2) -> - IMPL (k0, (map_bformula k0 fct f1), a, (map_bformula k0 fct f2)) -| IFF (k0, f1, f2) -> - IFF (k0, (map_bformula k0 fct f1), (map_bformula k0 fct f2)) -| EQ (f1, f2) -> - EQ ((map_bformula IsBool fct f1), (map_bformula IsBool fct f2)) - -type ('x, 'annot) clause = ('x * 'annot) list - -type ('x, 'annot) cnf = ('x, 'annot) clause list - -(** val cnf_tt : ('a1, 'a2) cnf **) - -let cnf_tt = - [] - -(** val cnf_ff : ('a1, 'a2) cnf **) - -let cnf_ff = - []::[] - -(** val add_term : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) -> ('a1, 'a2) - clause -> ('a1, 'a2) clause option **) - -let rec add_term unsat deduce t0 = function -| [] -> - (match deduce (fst t0) (fst t0) with - | Some u -> if unsat u then None else Some (t0::[]) - | None -> Some (t0::[])) -| t'::cl0 -> - (match deduce (fst t0) (fst t') with - | Some u -> - if unsat u - then None - else (match add_term unsat deduce t0 cl0 with - | Some cl' -> Some (t'::cl') - | None -> None) - | None -> - (match add_term unsat deduce t0 cl0 with - | Some cl' -> Some (t'::cl') - | None -> None)) - -(** val or_clause : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) clause -> ('a1, - 'a2) clause -> ('a1, 'a2) clause option **) - -let rec or_clause unsat deduce cl1 cl2 = - match cl1 with - | [] -> Some cl2 - | t0::cl -> - (match add_term unsat deduce t0 cl2 with - | Some cl' -> or_clause unsat deduce cl cl' - | None -> None) - -(** val xor_clause_cnf : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) clause -> ('a1, - 'a2) cnf -> ('a1, 'a2) cnf **) - -let xor_clause_cnf unsat deduce t0 f = - fold_left (fun acc e -> - match or_clause unsat deduce t0 e with - | Some cl -> cl::acc - | None -> acc) f [] - -(** val or_clause_cnf : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) clause -> ('a1, - 'a2) cnf -> ('a1, 'a2) cnf **) - -let or_clause_cnf unsat deduce t0 f = - match t0 with - | [] -> f - | _::_ -> xor_clause_cnf unsat deduce t0 f - -(** val or_cnf : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) cnf -> ('a1, - 'a2) cnf -> ('a1, 'a2) cnf **) - -let rec or_cnf unsat deduce f f' = - match f with - | [] -> cnf_tt - | e::rst -> - rev_append (or_cnf unsat deduce rst f') (or_clause_cnf unsat deduce e f') - -(** val and_cnf : ('a1, 'a2) cnf -> ('a1, 'a2) cnf -> ('a1, 'a2) cnf **) - -let and_cnf = - rev_append - -type ('term, 'annot, 'tX, 'aF) tFormula = ('term, 'tX, 'annot, 'aF) gFormula - -(** val is_cnf_tt : ('a1, 'a2) cnf -> bool **) - -let is_cnf_tt = function -| [] -> true -| _::_ -> false - -(** val is_cnf_ff : ('a1, 'a2) cnf -> bool **) - -let is_cnf_ff = function -| [] -> false -| c0::l -> - (match c0 with - | [] -> (match l with - | [] -> true - | _::_ -> false) - | _::_ -> false) - -(** val and_cnf_opt : ('a1, 'a2) cnf -> ('a1, 'a2) cnf -> ('a1, 'a2) cnf **) - -let and_cnf_opt f1 f2 = - if if is_cnf_ff f1 then true else is_cnf_ff f2 - then cnf_ff - else if is_cnf_tt f2 then f1 else and_cnf f1 f2 - -(** val or_cnf_opt : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) cnf -> ('a1, - 'a2) cnf -> ('a1, 'a2) cnf **) - -let or_cnf_opt unsat deduce f1 f2 = - if if is_cnf_tt f1 then true else is_cnf_tt f2 - then cnf_tt - else if is_cnf_ff f2 then f1 else or_cnf unsat deduce f1 f2 - -(** val mk_and : - ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> (bool -> kind -> ('a1, - 'a3, 'a4, 'a5) tFormula -> ('a2, 'a3) cnf) -> kind -> bool -> ('a1, 'a3, - 'a4, 'a5) tFormula -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a2, 'a3) cnf **) - -let mk_and unsat deduce rEC k pol0 f1 f2 = - if pol0 - then and_cnf_opt (rEC pol0 k f1) (rEC pol0 k f2) - else or_cnf_opt unsat deduce (rEC pol0 k f1) (rEC pol0 k f2) - -(** val mk_or : - ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> (bool -> kind -> ('a1, - 'a3, 'a4, 'a5) tFormula -> ('a2, 'a3) cnf) -> kind -> bool -> ('a1, 'a3, - 'a4, 'a5) tFormula -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a2, 'a3) cnf **) - -let mk_or unsat deduce rEC k pol0 f1 f2 = - if pol0 - then or_cnf_opt unsat deduce (rEC pol0 k f1) (rEC pol0 k f2) - else and_cnf_opt (rEC pol0 k f1) (rEC pol0 k f2) - -(** val mk_impl : - ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> (bool -> kind -> ('a1, - 'a3, 'a4, 'a5) tFormula -> ('a2, 'a3) cnf) -> kind -> bool -> ('a1, 'a3, - 'a4, 'a5) tFormula -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a2, 'a3) cnf **) - -let mk_impl unsat deduce rEC k pol0 f1 f2 = - if pol0 - then or_cnf_opt unsat deduce (rEC (negb pol0) k f1) (rEC pol0 k f2) - else and_cnf_opt (rEC (negb pol0) k f1) (rEC pol0 k f2) - -(** val mk_iff : - ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> (bool -> kind -> ('a1, - 'a3, 'a4, 'a5) tFormula -> ('a2, 'a3) cnf) -> kind -> bool -> ('a1, 'a3, - 'a4, 'a5) tFormula -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a2, 'a3) cnf **) - -let mk_iff unsat deduce rEC k pol0 f1 f2 = - or_cnf_opt unsat deduce - (and_cnf_opt (rEC (negb pol0) k f1) (rEC false k f2)) - (and_cnf_opt (rEC pol0 k f1) (rEC true k f2)) - -(** val is_bool : kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> bool option **) - -let is_bool _ = function -| TT _ -> Some true -| FF _ -> Some false -| _ -> None - -(** val xcnf : - ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a3 -> ('a2, 'a3) - cnf) -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> bool -> kind -> ('a1, 'a3, 'a4, - 'a5) tFormula -> ('a2, 'a3) cnf **) - -let rec xcnf unsat deduce normalise1 negate0 pol0 _ = function -| TT _ -> if pol0 then cnf_tt else cnf_ff -| FF _ -> if pol0 then cnf_ff else cnf_tt -| X (_, _) -> cnf_ff -| A (_, x, t0) -> if pol0 then normalise1 x t0 else negate0 x t0 -| AND (k0, e1, e2) -> - mk_and unsat deduce (fun x x0 x1 -> - xcnf unsat deduce normalise1 negate0 x x0 x1) k0 pol0 e1 e2 -| OR (k0, e1, e2) -> - mk_or unsat deduce (fun x x0 x1 -> - xcnf unsat deduce normalise1 negate0 x x0 x1) k0 pol0 e1 e2 -| NOT (k0, e) -> xcnf unsat deduce normalise1 negate0 (negb pol0) k0 e -| IMPL (k0, e1, _, e2) -> - mk_impl unsat deduce (fun x x0 x1 -> - xcnf unsat deduce normalise1 negate0 x x0 x1) k0 pol0 e1 e2 -| IFF (k0, e1, e2) -> - (match is_bool k0 e2 with - | Some isb -> - xcnf unsat deduce normalise1 negate0 (if isb then pol0 else negb pol0) - k0 e1 - | None -> - mk_iff unsat deduce (fun x x0 x1 -> - xcnf unsat deduce normalise1 negate0 x x0 x1) k0 pol0 e1 e2) -| EQ (e1, e2) -> - (match is_bool IsBool e2 with - | Some isb -> - xcnf unsat deduce normalise1 negate0 (if isb then pol0 else negb pol0) - IsBool e1 - | None -> - mk_iff unsat deduce (fun x x0 x1 -> - xcnf unsat deduce normalise1 negate0 x x0 x1) IsBool pol0 e1 e2) - -(** val radd_term : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) -> ('a1, 'a2) - clause -> (('a1, 'a2) clause, 'a2 trace) sum **) - -let rec radd_term unsat deduce t0 = function -| [] -> - (match deduce (fst t0) (fst t0) with - | Some u -> if unsat u then Inr (Push ((snd t0), Null)) else Inl (t0::[]) - | None -> Inl (t0::[])) -| t'::cl0 -> - (match deduce (fst t0) (fst t') with - | Some u -> - if unsat u - then Inr (Push ((snd t0), (Push ((snd t'), Null)))) - else (match radd_term unsat deduce t0 cl0 with - | Inl cl' -> Inl (t'::cl') - | Inr l -> Inr l) - | None -> - (match radd_term unsat deduce t0 cl0 with - | Inl cl' -> Inl (t'::cl') - | Inr l -> Inr l)) - -(** val ror_clause : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) list -> ('a1, - 'a2) clause -> (('a1, 'a2) clause, 'a2 trace) sum **) - -let rec ror_clause unsat deduce cl1 cl2 = - match cl1 with - | [] -> Inl cl2 - | t0::cl -> - (match radd_term unsat deduce t0 cl2 with - | Inl cl' -> ror_clause unsat deduce cl cl' - | Inr l -> Inr l) - -(** val xror_clause_cnf : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) list -> ('a1, - 'a2) clause list -> ('a1, 'a2) clause list * 'a2 trace **) - -let xror_clause_cnf unsat deduce t0 f = - fold_left (fun pat e -> - let acc,tg = pat in - (match ror_clause unsat deduce t0 e with - | Inl cl -> (cl::acc),tg - | Inr l -> acc,(Merge (tg, l)))) - f ([],Null) - -(** val ror_clause_cnf : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) list -> ('a1, - 'a2) clause list -> ('a1, 'a2) clause list * 'a2 trace **) - -let ror_clause_cnf unsat deduce t0 f = - match t0 with - | [] -> f,Null - | _::_ -> xror_clause_cnf unsat deduce t0 f - -(** val ror_cnf : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) clause list -> - ('a1, 'a2) clause list -> ('a1, 'a2) cnf * 'a2 trace **) - -let rec ror_cnf unsat deduce f f' = - match f with - | [] -> cnf_tt,Null - | e::rst -> - let rst_f',t0 = ror_cnf unsat deduce rst f' in - let e_f',t' = ror_clause_cnf unsat deduce e f' in - (rev_append rst_f' e_f'),(Merge (t0, t')) - -(** val ror_cnf_opt : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) cnf -> ('a1, - 'a2) cnf -> ('a1, 'a2) cnf * 'a2 trace **) - -let ror_cnf_opt unsat deduce f1 f2 = - if is_cnf_tt f1 - then cnf_tt,Null - else if is_cnf_tt f2 - then cnf_tt,Null - else if is_cnf_ff f2 then f1,Null else ror_cnf unsat deduce f1 f2 - -(** val ratom : ('a1, 'a2) cnf -> 'a2 -> ('a1, 'a2) cnf * 'a2 trace **) - -let ratom c a = - if if is_cnf_ff c then true else is_cnf_tt c - then c,(Push (a, Null)) - else c,Null - -(** val rxcnf_and : - ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> (bool -> kind -> ('a1, - 'a3, 'a4, 'a5) tFormula -> ('a2, 'a3) cnf * 'a3 trace) -> bool -> kind -> - ('a1, 'a3, 'a4, 'a5) tFormula -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a2, - 'a3) cnf * 'a3 trace **) - -let rxcnf_and unsat deduce rXCNF polarity k e1 e2 = - let e3,t1 = rXCNF polarity k e1 in - let e4,t2 = rXCNF polarity k e2 in - if polarity - then (and_cnf_opt e3 e4),(Merge (t1, t2)) - else let f',t' = ror_cnf_opt unsat deduce e3 e4 in - f',(Merge (t1, (Merge (t2, t')))) - -(** val rxcnf_or : - ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> (bool -> kind -> ('a1, - 'a3, 'a4, 'a5) tFormula -> ('a2, 'a3) cnf * 'a3 trace) -> bool -> kind -> - ('a1, 'a3, 'a4, 'a5) tFormula -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a2, - 'a3) cnf * 'a3 trace **) - -let rxcnf_or unsat deduce rXCNF polarity k e1 e2 = - let e3,t1 = rXCNF polarity k e1 in - let e4,t2 = rXCNF polarity k e2 in - if polarity - then let f',t' = ror_cnf_opt unsat deduce e3 e4 in - f',(Merge (t1, (Merge (t2, t')))) - else (and_cnf_opt e3 e4),(Merge (t1, t2)) - -(** val rxcnf_impl : - ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> (bool -> kind -> ('a1, - 'a3, 'a4, 'a5) tFormula -> ('a2, 'a3) cnf * 'a3 trace) -> bool -> kind -> - ('a1, 'a3, 'a4, 'a5) tFormula -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a2, - 'a3) cnf * 'a3 trace **) - -let rxcnf_impl unsat deduce rXCNF polarity k e1 e2 = - let e3,t1 = rXCNF (negb polarity) k e1 in - if polarity - then if is_cnf_tt e3 - then e3,t1 - else if is_cnf_ff e3 - then rXCNF polarity k e2 - else let e4,t2 = rXCNF polarity k e2 in - let f',t' = ror_cnf_opt unsat deduce e3 e4 in - f',(Merge (t1, (Merge (t2, t')))) - else let e4,t2 = rXCNF polarity k e2 in (and_cnf_opt e3 e4),(Merge (t1, t2)) - -(** val rxcnf_iff : - ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> (bool -> kind -> ('a1, - 'a3, 'a4, 'a5) tFormula -> ('a2, 'a3) cnf * 'a3 trace) -> bool -> kind -> - ('a1, 'a3, 'a4, 'a5) tFormula -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a2, - 'a3) cnf * 'a3 trace **) - -let rxcnf_iff unsat deduce rXCNF polarity k e1 e2 = - let c1,t1 = rXCNF (negb polarity) k e1 in - let c2,t2 = rXCNF false k e2 in - let c3,t3 = rXCNF polarity k e1 in - let c4,t4 = rXCNF true k e2 in - let f',t' = ror_cnf_opt unsat deduce (and_cnf_opt c1 c2) (and_cnf_opt c3 c4) - in - f',(Merge (t1, (Merge (t2, (Merge (t3, (Merge (t4, t')))))))) - -(** val rxcnf : - ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a3 -> ('a2, 'a3) - cnf) -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> bool -> kind -> ('a1, 'a3, 'a4, - 'a5) tFormula -> ('a2, 'a3) cnf * 'a3 trace **) - -let rec rxcnf unsat deduce normalise1 negate0 polarity _ = function -| TT _ -> if polarity then cnf_tt,Null else cnf_ff,Null -| FF _ -> if polarity then cnf_ff,Null else cnf_tt,Null -| X (_, _) -> cnf_ff,Null -| A (_, x, t0) -> - ratom (if polarity then normalise1 x t0 else negate0 x t0) t0 -| AND (k0, e1, e2) -> - rxcnf_and unsat deduce (fun x x0 x1 -> - rxcnf unsat deduce normalise1 negate0 x x0 x1) polarity k0 e1 e2 -| OR (k0, e1, e2) -> - rxcnf_or unsat deduce (fun x x0 x1 -> - rxcnf unsat deduce normalise1 negate0 x x0 x1) polarity k0 e1 e2 -| NOT (k0, e) -> rxcnf unsat deduce normalise1 negate0 (negb polarity) k0 e -| IMPL (k0, e1, _, e2) -> - rxcnf_impl unsat deduce (fun x x0 x1 -> - rxcnf unsat deduce normalise1 negate0 x x0 x1) polarity k0 e1 e2 -| IFF (k0, e1, e2) -> - rxcnf_iff unsat deduce (fun x x0 x1 -> - rxcnf unsat deduce normalise1 negate0 x x0 x1) polarity k0 e1 e2 -| EQ (e1, e2) -> - rxcnf_iff unsat deduce (fun x x0 x1 -> - rxcnf unsat deduce normalise1 negate0 x x0 x1) polarity IsBool e1 e2 - -type ('term, 'annot, 'tX) to_constrT = { mkTT : (kind -> 'tX); - mkFF : (kind -> 'tX); - mkA : (kind -> 'term -> 'annot -> - 'tX); - mkAND : (kind -> 'tX -> 'tX -> 'tX); - mkOR : (kind -> 'tX -> 'tX -> 'tX); - mkIMPL : (kind -> 'tX -> 'tX -> 'tX); - mkIFF : (kind -> 'tX -> 'tX -> 'tX); - mkNOT : (kind -> 'tX -> 'tX); - mkEQ : ('tX -> 'tX -> 'tX) } - -(** val aformula : - ('a1, 'a2, 'a3) to_constrT -> kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> 'a3 **) - -let rec aformula to_constr _ = function -| TT b -> to_constr.mkTT b -| FF b -> to_constr.mkFF b -| X (_, p) -> p -| A (b, x, t0) -> to_constr.mkA b x t0 -| AND (k0, f1, f2) -> - to_constr.mkAND k0 (aformula to_constr k0 f1) (aformula to_constr k0 f2) -| OR (k0, f1, f2) -> - to_constr.mkOR k0 (aformula to_constr k0 f1) (aformula to_constr k0 f2) -| NOT (k0, f0) -> to_constr.mkNOT k0 (aformula to_constr k0 f0) -| IMPL (k0, f1, _, f2) -> - to_constr.mkIMPL k0 (aformula to_constr k0 f1) (aformula to_constr k0 f2) -| IFF (k0, f1, f2) -> - to_constr.mkIFF k0 (aformula to_constr k0 f1) (aformula to_constr k0 f2) -| EQ (f1, f2) -> - to_constr.mkEQ (aformula to_constr IsBool f1) (aformula to_constr IsBool f2) - -(** val is_X : kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> 'a3 option **) - -let is_X _ = function -| X (_, p) -> Some p -| _ -> None - -(** val abs_and : - ('a1, 'a2, 'a3) to_constrT -> kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> - ('a1, 'a2, 'a3, 'a4) tFormula -> (kind -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula) -> - ('a1, 'a3, 'a2, 'a4) gFormula **) - -let abs_and to_constr k f1 f2 c = - match is_X k f1 with - | Some _ -> X (k, (aformula to_constr k (c k f1 f2))) - | None -> - (match is_X k f2 with - | Some _ -> X (k, (aformula to_constr k (c k f1 f2))) - | None -> c k f1 f2) - -(** val abs_or : - ('a1, 'a2, 'a3) to_constrT -> kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> - ('a1, 'a2, 'a3, 'a4) tFormula -> (kind -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula) -> - ('a1, 'a3, 'a2, 'a4) gFormula **) - -let abs_or to_constr k f1 f2 c = - match is_X k f1 with - | Some _ -> - (match is_X k f2 with - | Some _ -> X (k, (aformula to_constr k (c k f1 f2))) - | None -> c k f1 f2) - | None -> c k f1 f2 - -(** val abs_not : - ('a1, 'a2, 'a3) to_constrT -> kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> - (kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula) - -> ('a1, 'a3, 'a2, 'a4) gFormula **) - -let abs_not to_constr k f1 c = - match is_X k f1 with - | Some _ -> X (k, (aformula to_constr k (c k f1))) - | None -> c k f1 - -(** val mk_arrow : - 'a4 option -> kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, - 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula **) - -let mk_arrow o k f1 f2 = - match o with - | Some _ -> - (match is_X k f1 with - | Some _ -> f2 - | None -> IMPL (k, f1, o, f2)) - | None -> IMPL (k, f1, None, f2) - -(** val abst_simpl : - ('a1, 'a2, 'a3) to_constrT -> ('a2 -> bool) -> kind -> ('a1, 'a2, 'a3, - 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula **) - -let rec abst_simpl to_constr needA _ = function -| A (k, x, t0) -> - if needA t0 then A (k, x, t0) else X (k, (to_constr.mkA k x t0)) -| AND (k0, f1, f2) -> - AND (k0, (abst_simpl to_constr needA k0 f1), - (abst_simpl to_constr needA k0 f2)) -| OR (k0, f1, f2) -> - OR (k0, (abst_simpl to_constr needA k0 f1), - (abst_simpl to_constr needA k0 f2)) -| NOT (k0, f0) -> NOT (k0, (abst_simpl to_constr needA k0 f0)) -| IMPL (k0, f1, o, f2) -> - IMPL (k0, (abst_simpl to_constr needA k0 f1), o, - (abst_simpl to_constr needA k0 f2)) -| IFF (k0, f1, f2) -> - IFF (k0, (abst_simpl to_constr needA k0 f1), - (abst_simpl to_constr needA k0 f2)) -| EQ (f1, f2) -> - EQ ((abst_simpl to_constr needA IsBool f1), - (abst_simpl to_constr needA IsBool f2)) -| x -> x - -(** val abst_and : - ('a1, 'a2, 'a3) to_constrT -> (bool -> kind -> ('a1, 'a2, 'a3, 'a4) - tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula) -> bool -> kind -> ('a1, 'a2, - 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, - 'a4) tFormula **) - -let abst_and to_constr rEC pol0 k f1 f2 = - if pol0 - then abs_and to_constr k (rEC pol0 k f1) (rEC pol0 k f2) (fun x x0 x1 -> - AND (x, x0, x1)) - else abs_or to_constr k (rEC pol0 k f1) (rEC pol0 k f2) (fun x x0 x1 -> AND - (x, x0, x1)) - -(** val abst_or : - ('a1, 'a2, 'a3) to_constrT -> (bool -> kind -> ('a1, 'a2, 'a3, 'a4) - tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula) -> bool -> kind -> ('a1, 'a2, - 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, - 'a4) tFormula **) - -let abst_or to_constr rEC pol0 k f1 f2 = - if pol0 - then abs_or to_constr k (rEC pol0 k f1) (rEC pol0 k f2) (fun x x0 x1 -> OR - (x, x0, x1)) - else abs_and to_constr k (rEC pol0 k f1) (rEC pol0 k f2) (fun x x0 x1 -> OR - (x, x0, x1)) - -(** val abst_impl : - ('a1, 'a2, 'a3) to_constrT -> (bool -> kind -> ('a1, 'a2, 'a3, 'a4) - tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula) -> bool -> 'a4 option -> kind - -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula -> - ('a1, 'a2, 'a3, 'a4) tFormula **) - -let abst_impl to_constr rEC pol0 o k f1 f2 = - if pol0 - then abs_or to_constr k (rEC (negb pol0) k f1) (rEC pol0 k f2) (mk_arrow o) - else abs_and to_constr k (rEC (negb pol0) k f1) (rEC pol0 k f2) (mk_arrow o) - -(** val or_is_X : - kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula -> - bool **) - -let or_is_X k f1 f2 = - match is_X k f1 with - | Some _ -> true - | None -> (match is_X k f2 with - | Some _ -> true - | None -> false) - -(** val abs_iff : - ('a1, 'a2, 'a3) to_constrT -> kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> - ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, - 'a2, 'a3, 'a4) tFormula -> kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, - 'a2, 'a3, 'a4) tFormula **) - -let abs_iff to_constr k nf1 ff2 f1 tf2 r def = - if (&&) (or_is_X k nf1 ff2) (or_is_X k f1 tf2) - then X (r, (aformula to_constr r def)) - else def - -(** val abst_iff : - ('a1, 'a2, 'a3) to_constrT -> ('a2 -> bool) -> (bool -> kind -> ('a1, - 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula) -> bool -> kind - -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula -> - ('a1, 'a2, 'a3, 'a4) tFormula **) - -let abst_iff to_constr needA rEC pol0 k f1 f2 = - abs_iff to_constr k (rEC (negb pol0) k f1) (rEC false k f2) (rEC pol0 k f1) - (rEC true k f2) k (IFF (k, (abst_simpl to_constr needA k f1), - (abst_simpl to_constr needA k f2))) - -(** val abst_eq : - ('a1, 'a2, 'a3) to_constrT -> ('a2 -> bool) -> (bool -> kind -> ('a1, - 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula) -> bool -> - ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, - 'a2, 'a3, 'a4) tFormula **) - -let abst_eq to_constr needA rEC pol0 f1 f2 = - abs_iff to_constr IsBool (rEC (negb pol0) IsBool f1) (rEC false IsBool f2) - (rEC pol0 IsBool f1) (rEC true IsBool f2) IsProp (EQ - ((abst_simpl to_constr needA IsBool f1), - (abst_simpl to_constr needA IsBool f2))) - -(** val abst_form : - ('a1, 'a2, 'a3) to_constrT -> ('a2 -> bool) -> bool -> kind -> ('a1, 'a2, - 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula **) - -let rec abst_form to_constr needA pol0 _ = function -| TT k -> if pol0 then TT k else X (k, (to_constr.mkTT k)) -| FF k -> if pol0 then X (k, (to_constr.mkFF k)) else FF k -| X (k, p) -> X (k, p) -| A (k, x, t0) -> - if needA t0 then A (k, x, t0) else X (k, (to_constr.mkA k x t0)) -| AND (k0, f1, f2) -> - abst_and to_constr (abst_form to_constr needA) pol0 k0 f1 f2 -| OR (k0, f1, f2) -> - abst_or to_constr (abst_form to_constr needA) pol0 k0 f1 f2 -| NOT (k0, f0) -> - abs_not to_constr k0 (abst_form to_constr needA (negb pol0) k0 f0) - (fun x x0 -> NOT (x, x0)) -| IMPL (k0, f1, o, f2) -> - abst_impl to_constr (abst_form to_constr needA) pol0 o k0 f1 f2 -| IFF (k0, f1, f2) -> - abst_iff to_constr needA (abst_form to_constr needA) pol0 k0 f1 f2 -| EQ (f1, f2) -> - abst_eq to_constr needA (abst_form to_constr needA) pol0 f1 f2 - -(** val cnf_checker : - (('a1 * 'a2) list -> 'a3 -> bool) -> ('a1, 'a2) cnf -> 'a3 list -> bool **) - -let rec cnf_checker checker f l = - match f with - | [] -> true - | e::f0 -> - (match l with - | [] -> false - | c::l0 -> if checker e c then cnf_checker checker f0 l0 else false) - -(** val tauto_checker : - ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a3 -> ('a2, 'a3) - cnf) -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> (('a2 * 'a3) list -> 'a4 -> - bool) -> ('a1, rtyp, 'a3, unit0) gFormula -> 'a4 list -> bool **) - -let tauto_checker unsat deduce normalise1 negate0 checker f w = - cnf_checker checker (xcnf unsat deduce normalise1 negate0 true IsProp f) w - -(** val cneqb : ('a1 -> 'a1 -> bool) -> 'a1 -> 'a1 -> bool **) - -let cneqb ceqb x y = - negb (ceqb x y) - -(** val cltb : - ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 -> 'a1 -> bool **) - -let cltb ceqb cleb x y = - (&&) (cleb x y) (cneqb ceqb x y) - -type 'c polC = 'c pol - -type op1 = -| Equal -| NonEqual -| Strict -| NonStrict - -type 'c nFormula = 'c polC * op1 - -(** val opMult : op1 -> op1 -> op1 option **) - -let opMult o o' = - match o with - | Equal -> Some Equal - | NonEqual -> - (match o' with - | Equal -> Some Equal - | NonEqual -> Some NonEqual - | _ -> None) - | Strict -> (match o' with - | NonEqual -> None - | _ -> Some o') - | NonStrict -> - (match o' with - | Equal -> Some Equal - | NonEqual -> None - | _ -> Some NonStrict) - -(** val opAdd : op1 -> op1 -> op1 option **) - -let opAdd o o' = - match o with - | Equal -> Some o' - | NonEqual -> (match o' with - | Equal -> Some NonEqual - | _ -> None) - | Strict -> (match o' with - | NonEqual -> None - | _ -> Some Strict) - | NonStrict -> - (match o' with - | Equal -> Some NonStrict - | NonEqual -> None - | x -> Some x) - -type 'c psatz = -| PsatzLet of 'c psatz * 'c psatz -| PsatzIn of nat -| PsatzSquare of 'c polC -| PsatzMulC of 'c polC * 'c psatz -| PsatzMulE of 'c psatz * 'c psatz -| PsatzAdd of 'c psatz * 'c psatz -| PsatzC of 'c -| PsatzZ - -(** val map_option : ('a1 -> 'a2 option) -> 'a1 option -> 'a2 option **) - -let map_option f = function -| Some x -> f x -| None -> None - -(** val map_option2 : - ('a1 -> 'a2 -> 'a3 option) -> 'a1 option -> 'a2 option -> 'a3 option **) - -let map_option2 f o o' = - match o with - | Some x -> (match o' with - | Some x' -> f x x' - | None -> None) - | None -> None - -(** val pexpr_times_nformula : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 - -> bool) -> 'a1 polC -> 'a1 nFormula -> 'a1 nFormula option **) - -let pexpr_times_nformula cO cI cplus ctimes ceqb e = function -| ef,o -> - (match o with - | Equal -> Some ((pmul cO cI cplus ctimes ceqb e ef),Equal) - | _ -> None) - -(** val nformula_times_nformula : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 - -> bool) -> 'a1 nFormula -> 'a1 nFormula -> 'a1 nFormula option **) - -let nformula_times_nformula cO cI cplus ctimes ceqb f1 f2 = - let e1,o1 = f1 in - let e2,o2 = f2 in - map_option (fun x -> Some ((pmul cO cI cplus ctimes ceqb e1 e2),x)) - (opMult o1 o2) - -(** val nformula_plus_nformula : - 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> 'a1 - nFormula -> 'a1 nFormula option **) - -let nformula_plus_nformula cO cplus ceqb f1 f2 = - let e1,o1 = f1 in - let e2,o2 = f2 in - map_option (fun x -> Some ((padd cO cplus ceqb e1 e2),x)) (opAdd o1 o2) - -(** val eval_Psatz : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 - -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz -> 'a1 - nFormula option **) - -let rec eval_Psatz cO cI cplus ctimes ceqb cleb l = function -| PsatzLet (p2, p3) -> - (match eval_Psatz cO cI cplus ctimes ceqb cleb l p2 with - | Some f -> eval_Psatz cO cI cplus ctimes ceqb cleb (f::l) p3 - | None -> None) -| PsatzIn n0 -> Some (nth n0 l ((Pc cO),Equal)) -| PsatzSquare e0 -> Some ((psquare cO cI cplus ctimes ceqb e0),NonStrict) -| PsatzMulC (re, e0) -> - map_option (pexpr_times_nformula cO cI cplus ctimes ceqb re) - (eval_Psatz cO cI cplus ctimes ceqb cleb l e0) -| PsatzMulE (f1, f2) -> - map_option2 (nformula_times_nformula cO cI cplus ctimes ceqb) - (eval_Psatz cO cI cplus ctimes ceqb cleb l f1) - (eval_Psatz cO cI cplus ctimes ceqb cleb l f2) -| PsatzAdd (f1, f2) -> - map_option2 (nformula_plus_nformula cO cplus ceqb) - (eval_Psatz cO cI cplus ctimes ceqb cleb l f1) - (eval_Psatz cO cI cplus ctimes ceqb cleb l f2) -| PsatzC c -> if cltb ceqb cleb cO c then Some ((Pc c),Strict) else None -| PsatzZ -> Some ((Pc cO),Equal) - -(** val check_inconsistent : - 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> - bool **) - -let check_inconsistent cO ceqb cleb = function -| e,op -> - (match e with - | Pc c -> - (match op with - | Equal -> cneqb ceqb c cO - | NonEqual -> ceqb c cO - | Strict -> cleb c cO - | NonStrict -> cltb ceqb cleb c cO) - | _ -> false) - -(** val check_normalised_formulas : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 - -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz -> bool **) - -let check_normalised_formulas cO cI cplus ctimes ceqb cleb l cm = - match eval_Psatz cO cI cplus ctimes ceqb cleb l cm with - | Some f -> check_inconsistent cO ceqb cleb f - | None -> false - -type op2 = -| OpEq -| OpNEq -| OpLe -| OpGe -| OpLt -| OpGt - -type 't formula = { flhs : 't pExpr; fop : op2; frhs : 't pExpr } - -(** val norm : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 - -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol **) - -let norm = - norm_aux - -(** val psub0 : - 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 - -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol **) - -let psub0 = - psub - -(** val padd0 : - 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol - -> 'a1 pol **) - -let padd0 = - padd - -(** val popp0 : ('a1 -> 'a1) -> 'a1 pol -> 'a1 pol **) - -let popp0 = - popp - -(** val normalise : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 - -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 - nFormula **) - -let normalise cO cI cplus ctimes cminus copp ceqb f = - let { flhs = lhs; fop = op; frhs = rhs } = f in - let lhs0 = norm cO cI cplus ctimes cminus copp ceqb lhs in - let rhs0 = norm cO cI cplus ctimes cminus copp ceqb rhs in - (match op with - | OpEq -> (psub0 cO cplus cminus copp ceqb lhs0 rhs0),Equal - | OpNEq -> (psub0 cO cplus cminus copp ceqb lhs0 rhs0),NonEqual - | OpLe -> (psub0 cO cplus cminus copp ceqb rhs0 lhs0),NonStrict - | OpGe -> (psub0 cO cplus cminus copp ceqb lhs0 rhs0),NonStrict - | OpLt -> (psub0 cO cplus cminus copp ceqb rhs0 lhs0),Strict - | OpGt -> (psub0 cO cplus cminus copp ceqb lhs0 rhs0),Strict) - -(** val xnormalise : ('a1 -> 'a1) -> 'a1 nFormula -> 'a1 nFormula list **) - -let xnormalise copp = function -| e,o -> - (match o with - | Equal -> (e,Strict)::(((popp0 copp e),Strict)::[]) - | NonEqual -> (e,Equal)::[] - | Strict -> ((popp0 copp e),NonStrict)::[] - | NonStrict -> ((popp0 copp e),Strict)::[]) - -(** val xnegate : ('a1 -> 'a1) -> 'a1 nFormula -> 'a1 nFormula list **) - -let xnegate copp = function -| e,o -> - (match o with - | NonEqual -> (e,Strict)::(((popp0 copp e),Strict)::[]) - | x -> (e,x)::[]) - -(** val cnf_of_list : - 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list - -> 'a2 -> ('a1 nFormula, 'a2) cnf **) - -let cnf_of_list cO ceqb cleb l tg = - fold_right (fun x acc -> - if check_inconsistent cO ceqb cleb x then acc else ((x,tg)::[])::acc) - cnf_tt l - -(** val cnf_normalise : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 - -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) - -> 'a1 formula -> 'a2 -> ('a1 nFormula, 'a2) cnf **) - -let cnf_normalise cO cI cplus ctimes cminus copp ceqb cleb t0 tg = - let f = normalise cO cI cplus ctimes cminus copp ceqb t0 in - if check_inconsistent cO ceqb cleb f - then cnf_ff - else cnf_of_list cO ceqb cleb (xnormalise copp f) tg - -(** val cnf_negate : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 - -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) - -> 'a1 formula -> 'a2 -> ('a1 nFormula, 'a2) cnf **) - -let cnf_negate cO cI cplus ctimes cminus copp ceqb cleb t0 tg = - let f = normalise cO cI cplus ctimes cminus copp ceqb t0 in - if check_inconsistent cO ceqb cleb f - then cnf_tt - else cnf_of_list cO ceqb cleb (xnegate copp f) tg - -(** val xdenorm : positive -> 'a1 pol -> 'a1 pExpr **) - -let rec xdenorm jmp = function -| Pc c -> PEc c -| Pinj (j, p2) -> xdenorm (Coq_Pos.add j jmp) p2 -| PX (p2, j, q0) -> - PEadd ((PEmul ((xdenorm jmp p2), (PEpow ((PEX jmp), (Npos j))))), - (xdenorm (Coq_Pos.succ jmp) q0)) - -(** val denorm : 'a1 pol -> 'a1 pExpr **) - -let denorm p = - xdenorm XH p - -(** val map_PExpr : ('a2 -> 'a1) -> 'a2 pExpr -> 'a1 pExpr **) - -let rec map_PExpr c_of_S = function -| PEc c -> PEc (c_of_S c) -| PEX p -> PEX p -| PEadd (e1, e2) -> PEadd ((map_PExpr c_of_S e1), (map_PExpr c_of_S e2)) -| PEsub (e1, e2) -> PEsub ((map_PExpr c_of_S e1), (map_PExpr c_of_S e2)) -| PEmul (e1, e2) -> PEmul ((map_PExpr c_of_S e1), (map_PExpr c_of_S e2)) -| PEopp e0 -> PEopp (map_PExpr c_of_S e0) -| PEpow (e0, n0) -> PEpow ((map_PExpr c_of_S e0), n0) - -(** val map_Formula : ('a2 -> 'a1) -> 'a2 formula -> 'a1 formula **) - -let map_Formula c_of_S f = - let { flhs = l; fop = o; frhs = r } = f in - { flhs = (map_PExpr c_of_S l); fop = o; frhs = (map_PExpr c_of_S r) } - -(** val simpl_cone : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 psatz -> - 'a1 psatz **) - -let simpl_cone cO cI ctimes ceqb e = match e with -| PsatzSquare t0 -> - (match t0 with - | Pc c -> if ceqb cO c then PsatzZ else PsatzC (ctimes c c) - | _ -> PsatzSquare t0) -| PsatzMulE (t1, t2) -> - (match t1 with - | PsatzMulE (x, x0) -> - (match x with - | PsatzC p2 -> - (match t2 with - | PsatzC c -> PsatzMulE ((PsatzC (ctimes c p2)), x0) - | PsatzZ -> PsatzZ - | _ -> e) - | _ -> - (match x0 with - | PsatzC p2 -> - (match t2 with - | PsatzC c -> PsatzMulE ((PsatzC (ctimes c p2)), x) - | PsatzZ -> PsatzZ - | _ -> e) - | _ -> - (match t2 with - | PsatzC c -> if ceqb cI c then t1 else PsatzMulE (t1, t2) - | PsatzZ -> PsatzZ - | _ -> e))) - | PsatzC c -> - (match t2 with - | PsatzMulE (x, x0) -> - (match x with - | PsatzC p2 -> PsatzMulE ((PsatzC (ctimes c p2)), x0) - | _ -> - (match x0 with - | PsatzC p2 -> PsatzMulE ((PsatzC (ctimes c p2)), x) - | _ -> if ceqb cI c then t2 else PsatzMulE (t1, t2))) - | PsatzAdd (y, z0) -> - PsatzAdd ((PsatzMulE ((PsatzC c), y)), (PsatzMulE ((PsatzC c), z0))) - | PsatzC c0 -> PsatzC (ctimes c c0) - | PsatzZ -> PsatzZ - | _ -> if ceqb cI c then t2 else PsatzMulE (t1, t2)) - | PsatzZ -> PsatzZ - | _ -> - (match t2 with - | PsatzC c -> if ceqb cI c then t1 else PsatzMulE (t1, t2) - | PsatzZ -> PsatzZ - | _ -> e)) -| PsatzAdd (t1, t2) -> - (match t1 with - | PsatzZ -> t2 - | _ -> (match t2 with - | PsatzZ -> t1 - | _ -> PsatzAdd (t1, t2))) -| _ -> e - -type q = { qnum : z; qden : positive } - -(** val qeq_bool : q -> q -> bool **) - -let qeq_bool x y = - Z.eqb (Z.mul x.qnum (Zpos y.qden)) (Z.mul y.qnum (Zpos x.qden)) - -(** val qle_bool : q -> q -> bool **) - -let qle_bool x y = - Z.leb (Z.mul x.qnum (Zpos y.qden)) (Z.mul y.qnum (Zpos x.qden)) - -(** val qplus : q -> q -> q **) - -let qplus x y = - { qnum = (Z.add (Z.mul x.qnum (Zpos y.qden)) (Z.mul y.qnum (Zpos x.qden))); - qden = (Coq_Pos.mul x.qden y.qden) } - -(** val qmult : q -> q -> q **) - -let qmult x y = - { qnum = (Z.mul x.qnum y.qnum); qden = (Coq_Pos.mul x.qden y.qden) } - -(** val qopp : q -> q **) - -let qopp x = - { qnum = (Z.opp x.qnum); qden = x.qden } - -(** val qminus : q -> q -> q **) - -let qminus x y = - qplus x (qopp y) - -(** val qinv : q -> q **) - -let qinv x = - match x.qnum with - | Z0 -> { qnum = Z0; qden = XH } - | Zpos p -> { qnum = (Zpos x.qden); qden = p } - | Zneg p -> { qnum = (Zneg x.qden); qden = p } - -(** val qpower_positive : q -> positive -> q **) - -let qpower_positive = - pow_pos qmult - -(** val qpower : q -> z -> q **) - -let qpower q0 = function -| Z0 -> { qnum = (Zpos XH); qden = XH } -| Zpos p -> qpower_positive q0 p -| Zneg p -> qinv (qpower_positive q0 p) - -type 'a t = -| Empty -| Elt of 'a -| Branch of 'a t * 'a * 'a t - -(** val find : 'a1 -> 'a1 t -> positive -> 'a1 **) - -let rec find default vm p = - match vm with - | Empty -> default - | Elt i -> i - | Branch (l, e, r) -> - (match p with - | XI p2 -> find default r p2 - | XO p2 -> find default l p2 - | XH -> e) - -(** val singleton : 'a1 -> positive -> 'a1 -> 'a1 t **) - -let rec singleton default x v = - match x with - | XI p -> Branch (Empty, default, (singleton default p v)) - | XO p -> Branch ((singleton default p v), default, Empty) - | XH -> Elt v - -(** val vm_add : 'a1 -> positive -> 'a1 -> 'a1 t -> 'a1 t **) - -let rec vm_add default x v = function -| Empty -> singleton default x v -| Elt vl -> - (match x with - | XI p -> Branch (Empty, vl, (singleton default p v)) - | XO p -> Branch ((singleton default p v), vl, Empty) - | XH -> Elt v) -| Branch (l, o, r) -> - (match x with - | XI p -> Branch (l, o, (vm_add default p v r)) - | XO p -> Branch ((vm_add default p v l), o, r) - | XH -> Branch (l, v, r)) - -(** val zeval_const : z pExpr -> z option **) - -let rec zeval_const = function -| PEc c -> Some c -| PEX _ -> None -| PEadd (e1, e2) -> - map_option2 (fun x y -> Some (Z.add x y)) (zeval_const e1) (zeval_const e2) -| PEsub (e1, e2) -> - map_option2 (fun x y -> Some (Z.sub x y)) (zeval_const e1) (zeval_const e2) -| PEmul (e1, e2) -> - map_option2 (fun x y -> Some (Z.mul x y)) (zeval_const e1) (zeval_const e2) -| PEopp e0 -> map_option (fun x -> Some (Z.opp x)) (zeval_const e0) -| PEpow (e1, n0) -> - map_option (fun x -> Some (Z.pow x (Z.of_N n0))) (zeval_const e1) - -type zWitness = z psatz - -(** val zWeakChecker : z nFormula list -> z psatz -> bool **) - -let zWeakChecker = - check_normalised_formulas Z0 (Zpos XH) Z.add Z.mul Z.eqb Z.leb - -(** val psub1 : z pol -> z pol -> z pol **) - -let psub1 = - psub0 Z0 Z.add Z.sub Z.opp Z.eqb - -(** val popp1 : z pol -> z pol **) - -let popp1 = - popp0 Z.opp - -(** val padd1 : z pol -> z pol -> z pol **) - -let padd1 = - padd0 Z0 Z.add Z.eqb - -(** val normZ : z pExpr -> z pol **) - -let normZ = - norm Z0 (Zpos XH) Z.add Z.mul Z.sub Z.opp Z.eqb - -(** val zunsat : z nFormula -> bool **) - -let zunsat = - check_inconsistent Z0 Z.eqb Z.leb - -(** val zdeduce : z nFormula -> z nFormula -> z nFormula option **) - -let zdeduce = - nformula_plus_nformula Z0 Z.add Z.eqb - -(** val xnnormalise : z formula -> z nFormula **) - -let xnnormalise t0 = - let { flhs = lhs; fop = o; frhs = rhs } = t0 in - let lhs0 = normZ lhs in - let rhs0 = normZ rhs in - (match o with - | OpEq -> (psub1 rhs0 lhs0),Equal - | OpNEq -> (psub1 rhs0 lhs0),NonEqual - | OpLe -> (psub1 rhs0 lhs0),NonStrict - | OpGe -> (psub1 lhs0 rhs0),NonStrict - | OpLt -> (psub1 rhs0 lhs0),Strict - | OpGt -> (psub1 lhs0 rhs0),Strict) - -(** val xnormalise0 : z nFormula -> z nFormula list **) - -let xnormalise0 = function -| e,o -> - (match o with - | Equal -> - ((psub1 e (Pc (Zpos XH))),NonStrict)::(((psub1 (Pc (Zneg XH)) e),NonStrict)::[]) - | NonEqual -> (e,Equal)::[] - | Strict -> ((psub1 (Pc Z0) e),NonStrict)::[] - | NonStrict -> ((psub1 (Pc (Zneg XH)) e),NonStrict)::[]) - -(** val cnf_of_list0 : - 'a1 -> z nFormula list -> (z nFormula * 'a1) list list **) - -let cnf_of_list0 tg l = - fold_right (fun x acc -> if zunsat x then acc else ((x,tg)::[])::acc) - cnf_tt l - -(** val normalise0 : z formula -> 'a1 -> (z nFormula, 'a1) cnf **) - -let normalise0 t0 tg = - let f = xnnormalise t0 in - if zunsat f then cnf_ff else cnf_of_list0 tg (xnormalise0 f) - -(** val xnegate0 : z nFormula -> z nFormula list **) - -let xnegate0 = function -| e,o -> - (match o with - | NonEqual -> - ((psub1 e (Pc (Zpos XH))),NonStrict)::(((psub1 (Pc (Zneg XH)) e),NonStrict)::[]) - | Strict -> ((psub1 e (Pc (Zpos XH))),NonStrict)::[] - | x -> (e,x)::[]) - -(** val negate : z formula -> 'a1 -> (z nFormula, 'a1) cnf **) - -let negate t0 tg = - let f = xnnormalise t0 in - if zunsat f then cnf_tt else cnf_of_list0 tg (xnegate0 f) - -(** val cnfZ : - kind -> (z formula, 'a1, 'a2, 'a3) tFormula -> (z nFormula, 'a1) - cnf * 'a1 trace **) - -let cnfZ k f = - rxcnf zunsat zdeduce normalise0 negate true k f - -(** val ceiling : z -> z -> z **) - -let ceiling a b = - let q0,r = Z.div_eucl a b in - (match r with - | Z0 -> q0 - | _ -> Z.add q0 (Zpos XH)) - -type zArithProof = -| DoneProof -| RatProof of zWitness * zArithProof -| CutProof of zWitness * zArithProof -| SplitProof of z polC * zArithProof * zArithProof -| EnumProof of zWitness * zWitness * zArithProof list -| ExProof of positive * zArithProof - -(** val zgcdM : z -> z -> z **) - -let zgcdM x y = - Z.max (Z.gcd x y) (Zpos XH) - -(** val zgcd_pol : z polC -> z * z **) - -let rec zgcd_pol = function -| Pc c -> Z0,c -| Pinj (_, p2) -> zgcd_pol p2 -| PX (p2, _, q0) -> - let g1,c1 = zgcd_pol p2 in - let g2,c2 = zgcd_pol q0 in (zgcdM (zgcdM g1 c1) g2),c2 - -(** val zdiv_pol : z polC -> z -> z polC **) - -let rec zdiv_pol p x = - match p with - | Pc c -> Pc (Z.div c x) - | Pinj (j, p2) -> Pinj (j, (zdiv_pol p2 x)) - | PX (p2, j, q0) -> PX ((zdiv_pol p2 x), j, (zdiv_pol q0 x)) - -(** val makeCuttingPlane : z polC -> z polC * z **) - -let makeCuttingPlane p = - let g,c = zgcd_pol p in - if Z.gtb g Z0 - then (zdiv_pol (psubC Z.sub p c) g),(Z.opp (ceiling (Z.opp c) g)) - else p,Z0 - -(** val genCuttingPlane : z nFormula -> ((z polC * z) * op1) option **) - -let genCuttingPlane = function -| e,op -> - (match op with - | Equal -> - let g,c = zgcd_pol e in - if (&&) (Z.gtb g Z0) - ((&&) (negb (Z.eqb c Z0)) (negb (Z.eqb (Z.gcd g c) g))) - then None - else Some ((makeCuttingPlane e),Equal) - | NonEqual -> Some ((e,Z0),op) - | Strict -> Some ((makeCuttingPlane (psubC Z.sub e (Zpos XH))),NonStrict) - | NonStrict -> Some ((makeCuttingPlane e),NonStrict)) - -(** val nformula_of_cutting_plane : ((z polC * z) * op1) -> z nFormula **) - -let nformula_of_cutting_plane = function -| e_z,o -> let e,z0 = e_z in (padd1 e (Pc z0)),o - -(** val is_pol_Z0 : z polC -> bool **) - -let is_pol_Z0 = function -| Pc z0 -> (match z0 with - | Z0 -> true - | _ -> false) -| _ -> false - -(** val eval_Psatz0 : z nFormula list -> zWitness -> z nFormula option **) - -let eval_Psatz0 = - eval_Psatz Z0 (Zpos XH) Z.add Z.mul Z.eqb Z.leb - -(** val valid_cut_sign : op1 -> bool **) - -let valid_cut_sign = function -| Equal -> true -| NonStrict -> true -| _ -> false - -(** val bound_var : positive -> z formula **) - -let bound_var v = - { flhs = (PEX v); fop = OpGe; frhs = (PEc Z0) } - -(** val mk_eq_pos : positive -> positive -> positive -> z formula **) - -let mk_eq_pos x y t0 = - { flhs = (PEX x); fop = OpEq; frhs = (PEsub ((PEX y), (PEX t0))) } - -(** val max_var : positive -> z pol -> positive **) - -let rec max_var jmp = function -| Pc _ -> jmp -| Pinj (j, p2) -> max_var (Coq_Pos.add j jmp) p2 -| PX (p2, _, q0) -> - Coq_Pos.max (max_var jmp p2) (max_var (Coq_Pos.succ jmp) q0) - -(** val max_var_nformulae : z nFormula list -> positive **) - -let max_var_nformulae l = - fold_left (fun acc f -> Coq_Pos.max acc (max_var XH (fst f))) l XH - -(** val zChecker : z nFormula list -> zArithProof -> bool **) - -let rec zChecker l = function -| DoneProof -> false -| RatProof (w, pf0) -> - (match eval_Psatz0 l w with - | Some f -> if zunsat f then true else zChecker (f::l) pf0 - | None -> false) -| CutProof (w, pf0) -> - (match eval_Psatz0 l w with - | Some f -> - (match genCuttingPlane f with - | Some cp -> zChecker ((nformula_of_cutting_plane cp)::l) pf0 - | None -> true) - | None -> false) -| SplitProof (p, pf1, pf2) -> - (match genCuttingPlane (p,NonStrict) with - | Some cp1 -> - (match genCuttingPlane ((popp1 p),NonStrict) with - | Some cp2 -> - (&&) (zChecker ((nformula_of_cutting_plane cp1)::l) pf1) - (zChecker ((nformula_of_cutting_plane cp2)::l) pf2) - | None -> false) - | None -> false) -| EnumProof (w1, w2, pf0) -> - (match eval_Psatz0 l w1 with - | Some f1 -> - (match eval_Psatz0 l w2 with - | Some f2 -> - (match genCuttingPlane f1 with - | Some p -> - let p2,op3 = p in - let e1,z1 = p2 in - (match genCuttingPlane f2 with - | Some p3 -> - let p4,op4 = p3 in - let e2,z2 = p4 in - if (&&) ((&&) (valid_cut_sign op3) (valid_cut_sign op4)) - (is_pol_Z0 (padd1 e1 e2)) - then let rec label pfs lb ub = - match pfs with - | [] -> Z.gtb lb ub - | pf1::rsr -> - (&&) (zChecker (((psub1 e1 (Pc lb)),Equal)::l) pf1) - (label rsr (Z.add lb (Zpos XH)) ub) - in label pf0 (Z.opp z1) z2 - else false - | None -> true) - | None -> true) - | None -> false) - | None -> false) -| ExProof (x, prf) -> - let fr = max_var_nformulae l in - if Coq_Pos.leb x fr - then let z0 = Coq_Pos.succ fr in - let t0 = Coq_Pos.succ z0 in - let nfx = xnnormalise (mk_eq_pos x z0 t0) in - let posz = xnnormalise (bound_var z0) in - let post = xnnormalise (bound_var t0) in - zChecker (nfx::(posz::(post::l))) prf - else false - -(** val zTautoChecker : z formula bFormula -> zArithProof list -> bool **) - -let zTautoChecker f w = - tauto_checker zunsat zdeduce normalise0 negate (fun cl -> - zChecker (map fst cl)) f w - -type qWitness = q psatz - -(** val qWeakChecker : q nFormula list -> q psatz -> bool **) - -let qWeakChecker = - check_normalised_formulas { qnum = Z0; qden = XH } { qnum = (Zpos XH); - qden = XH } qplus qmult qeq_bool qle_bool - -(** val qnormalise : q formula -> 'a1 -> (q nFormula, 'a1) cnf **) - -let qnormalise t0 tg = - cnf_normalise { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH } - qplus qmult qminus qopp qeq_bool qle_bool t0 tg - -(** val qnegate : q formula -> 'a1 -> (q nFormula, 'a1) cnf **) - -let qnegate t0 tg = - cnf_negate { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH } qplus - qmult qminus qopp qeq_bool qle_bool t0 tg - -(** val qunsat : q nFormula -> bool **) - -let qunsat = - check_inconsistent { qnum = Z0; qden = XH } qeq_bool qle_bool - -(** val qdeduce : q nFormula -> q nFormula -> q nFormula option **) - -let qdeduce = - nformula_plus_nformula { qnum = Z0; qden = XH } qplus qeq_bool - -(** val normQ : q pExpr -> q pol **) - -let normQ = - norm { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH } qplus qmult - qminus qopp qeq_bool - -(** val cnfQ : - kind -> (q formula, 'a1, 'a2, 'a3) tFormula -> (q nFormula, 'a1) - cnf * 'a1 trace **) - -let cnfQ k f = - rxcnf qunsat qdeduce qnormalise qnegate true k f - -(** val qTautoChecker : q formula bFormula -> qWitness list -> bool **) - -let qTautoChecker f w = - tauto_checker qunsat qdeduce qnormalise qnegate (fun cl -> - qWeakChecker (map fst cl)) f w - -type rcst = -| C0 -| C1 -| CQ of q -| CZ of z -| CPlus of rcst * rcst -| CMinus of rcst * rcst -| CMult of rcst * rcst -| CPow of rcst * (z, nat) sum -| CInv of rcst -| COpp of rcst - -(** val z_of_exp : (z, nat) sum -> z **) - -let z_of_exp = function -| Inl z1 -> z1 -| Inr n0 -> Z.of_nat n0 - -(** val q_of_Rcst : rcst -> q **) - -let rec q_of_Rcst = function -| C0 -> { qnum = Z0; qden = XH } -| C1 -> { qnum = (Zpos XH); qden = XH } -| CQ q0 -> q0 -| CZ z0 -> { qnum = z0; qden = XH } -| CPlus (r1, r2) -> qplus (q_of_Rcst r1) (q_of_Rcst r2) -| CMinus (r1, r2) -> qminus (q_of_Rcst r1) (q_of_Rcst r2) -| CMult (r1, r2) -> qmult (q_of_Rcst r1) (q_of_Rcst r2) -| CPow (r1, z0) -> qpower (q_of_Rcst r1) (z_of_exp z0) -| CInv r0 -> qinv (q_of_Rcst r0) -| COpp r0 -> qopp (q_of_Rcst r0) - -type rWitness = q psatz - -(** val rWeakChecker : q nFormula list -> q psatz -> bool **) - -let rWeakChecker = - check_normalised_formulas { qnum = Z0; qden = XH } { qnum = (Zpos XH); - qden = XH } qplus qmult qeq_bool qle_bool - -(** val rnormalise : q formula -> 'a1 -> (q nFormula, 'a1) cnf **) - -let rnormalise t0 tg = - cnf_normalise { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH } - qplus qmult qminus qopp qeq_bool qle_bool t0 tg - -(** val rnegate : q formula -> 'a1 -> (q nFormula, 'a1) cnf **) - -let rnegate t0 tg = - cnf_negate { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH } qplus - qmult qminus qopp qeq_bool qle_bool t0 tg - -(** val runsat : q nFormula -> bool **) - -let runsat = - check_inconsistent { qnum = Z0; qden = XH } qeq_bool qle_bool - -(** val rdeduce : q nFormula -> q nFormula -> q nFormula option **) - -let rdeduce = - nformula_plus_nformula { qnum = Z0; qden = XH } qplus qeq_bool - -(** val rTautoChecker : rcst formula bFormula -> rWitness list -> bool **) - -let rTautoChecker f w = - tauto_checker runsat rdeduce rnormalise rnegate (fun cl -> - rWeakChecker (map fst cl)) - (map_bformula IsProp (map_Formula q_of_Rcst) f) w - diff --git a/stdlib/test-suite/output/MExtraction.v b/stdlib/test-suite/output/MExtraction.v deleted file mode 100644 index a31c99366664..000000000000 --- a/stdlib/test-suite/output/MExtraction.v +++ /dev/null @@ -1,68 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* "( * )" [ "(,)" ]. -Extract Inductive list => list [ "[]" "(::)" ]. -Extract Inductive bool => bool [ true false ]. -Extract Inductive sumbool => bool [ true false ]. -Extract Inductive option => option [ Some None ]. -Extract Inductive sumor => option [ Some None ]. -(** Then, in a ternary alternative { }+{ }+{ }, - - leftmost choice (Inleft Left) is (Some true), - - middle choice (Inleft Right) is (Some false), - - rightmost choice (Inright) is (None) *) - - -(** To preserve its laziness, andb is normally expanded. - Let's rather use the ocaml && *) -Extract Inlined Constant andb => "(&&)". - -Import Reals.Rdefinitions. - -Extract Constant R => "int". -Extract Constant R0 => "0". -Extract Constant R1 => "1". -Extract Constant Rplus => "( + )". -Extract Constant Rmult => "( * )". -Extract Constant Ropp => "fun x -> - x". -Extract Constant Rinv => "fun x -> 1 / x". - -(** In order to avoid annoying build dependencies the actual - extraction is only performed as a test in the test suite. *) -Recursive Extraction - Tauto.mapX Tauto.foldA Tauto.collect_annot Tauto.ids_of_formula Tauto.map_bformula - Tauto.abst_form - ZMicromega.cnfZ ZMicromega.Zeval_const QMicromega.cnfQ - List.map simpl_cone (*map_cone indexes*) - denorm QArith_base.Qpower vm_add - normZ normQ normQ Z.to_N N.of_nat ZTautoChecker ZWeakChecker QTautoChecker RTautoChecker find. - -(* Local Variables: *) -(* coding: utf-8 *) -(* End: *) diff --git a/stdlib/test-suite/output/NNumberSyntax.out b/stdlib/test-suite/output/NNumberSyntax.out deleted file mode 100644 index 163b30a3ced2..000000000000 --- a/stdlib/test-suite/output/NNumberSyntax.out +++ /dev/null @@ -1,86 +0,0 @@ -32%N - : N -eq_refl : 42%N = 42%N - : 42%N = 42%N -fun f : nat -> N => (f 0%nat + 0)%N - : (nat -> N) -> N -fun x : positive => N.pos x~0 - : positive -> N -fun x : positive => (N.pos x + 1)%N - : positive -> N -fun x : positive => N.pos x - : positive -> N -fun x : positive => N.pos x~1 - : positive -> N -fun x : positive => (N.pos x~0 + 0)%N - : positive -> N -(N.of_nat 0 + 1)%N - : N -(0 + N.of_nat (0 + 0))%N - : N -N.of_nat 0 = 0%N - : Prop -0%N - : N -1%N - : N -2%N - : N -255%N - : N -255%N - : N -0%N - : N -1%N - : N -2%N - : N -255%N - : N -255%N - : N -0x2a - : N -0x0 - : N -0x2a - : N -0x0 - : N -0x0 - : N -0x1 - : N -0x2 - : N -0xff - : N -0xff - : N -0x0 - : N -0x0 - : N -0x1 - : N -0x2 - : N -0xff - : N -0xff - : N -0x0 - : N -0x0 - : N -0x1 - : N -0x2 - : N -0xff - : N -0xff - : N -(0 + N.of_nat 11)%N - : N diff --git a/stdlib/test-suite/output/NNumberSyntax.v b/stdlib/test-suite/output/NNumberSyntax.v deleted file mode 100644 index df8d813bb0ff..000000000000 --- a/stdlib/test-suite/output/NNumberSyntax.v +++ /dev/null @@ -1,50 +0,0 @@ -From Stdlib Require Import NArith. -Check 32%N. -Check (eq_refl : 0x2a%N = 42%N). -Check (fun f : nat -> N => (f 0%nat + 0)%N). -Check (fun x : positive => Npos (xO x)). -Check (fun x : positive => (Npos x + 1)%N). -Check (fun x : positive => Npos x). -Check (fun x : positive => Npos (xI x)). -Check (fun x : positive => (Npos (xO x) + 0)%N). -Check (N.of_nat 0 + 1)%N. -Check (0 + N.of_nat (0 + 0))%N. -Check (N.of_nat 0 = 0%N). -Check 0x00%N. -Check 0x01%N. -Check 0x02%N. -Check 0xff%N. -Check 0xFF%N. -Check 0x00%xN. -Check 0x01%xN. -Check 0x02%xN. -Check 0xff%xN. -Check 0xFF%xN. - -(* Check hexadecimal printing *) -Open Scope hex_N_scope. -Check 42%N. -Check 0%N. -Check 42%xN. -Check 0%xN. -Check 0x00%N. -Check 0x01%N. -Check 0x02%N. -Check 0xff%N. -Check 0xFF%N. -Check 0x0%xN. -Check 0x00%xN. -Check 0x01%xN. -Check 0x02%xN. -Check 0xff%xN. -Check 0xFF%xN. -Check 0x0. -Check 0x00. -Check 0x01. -Check 0x02. -Check 0xff. -Check 0xFF. -Close Scope hex_N_scope. - -From Stdlib Require Import Arith. -Check (0 + N.of_nat 11)%N. diff --git a/stdlib/test-suite/output/NoAxiomFromR.out b/stdlib/test-suite/output/NoAxiomFromR.out deleted file mode 100644 index 7d7c521343dd..000000000000 --- a/stdlib/test-suite/output/NoAxiomFromR.out +++ /dev/null @@ -1 +0,0 @@ -Closed under the global context diff --git a/stdlib/test-suite/output/NoAxiomFromR.v b/stdlib/test-suite/output/NoAxiomFromR.v deleted file mode 100644 index c478ce59effc..000000000000 --- a/stdlib/test-suite/output/NoAxiomFromR.v +++ /dev/null @@ -1,10 +0,0 @@ -From Stdlib Require Import Psatz. - -Inductive TT : Set := -| C : nat -> TT. - -Lemma lem4 : forall (n m : nat), -S m <= m -> C (S m) <> C n -> False. -Proof. firstorder lia. Qed. - -Print Assumptions lem4. diff --git a/stdlib/test-suite/output/NotationSyntax.out b/stdlib/test-suite/output/NotationSyntax.out deleted file mode 100644 index 918befbc07e2..000000000000 --- a/stdlib/test-suite/output/NotationSyntax.out +++ /dev/null @@ -1,48 +0,0 @@ -File "./output/NotationSyntax.v", line 2, characters 38-50: -The command has indeed failed with message: -"only parsing" is given more than once. -File "./output/NotationSyntax.v", line 3, characters 38-51: -The command has indeed failed with message: -A notation cannot be both "only printing" and "only parsing". -File "./output/NotationSyntax.v", line 4, characters 39-52: -The command has indeed failed with message: -"only printing" is given more than once. -File "./output/NotationSyntax.v", line 5, characters 33-43: -Warning: The format modifier is irrelevant for only-parsing rules. -[irrelevant-format-only-parsing,parsing,default] -File "./output/NotationSyntax.v", line 8, characters 20-30: -Warning: -Notations for numbers or strings are primitive; skipping this modifier. -[primitive-token-modifier,parsing,default] -1%nat - : nat -File "./output/NotationSyntax.v", line 10, characters 23-26: -The command has indeed failed with message: -Notations for numbers or strings are primitive and need not be reserved. -File "./output/NotationSyntax.v", line 12, characters 25-35: -Warning: -Notations for numbers or strings are primitive; skipping this modifier. -[primitive-token-modifier,parsing,default] -"tt" - : unit -"tt"%string - : string -File "./output/NotationSyntax.v", line 16, characters 23-31: -The command has indeed failed with message: -Notations for numbers or strings are primitive and need not be reserved. -"t""t" - : unit -# "|" true - : option bool -"|"%string - : string -2 "|" 4 - : nat * nat -"I'm true" - : bool -"" - : bool -symbolwith"doublequote - : bool -" - : bool diff --git a/stdlib/test-suite/output/NotationSyntax.v b/stdlib/test-suite/output/NotationSyntax.v deleted file mode 100644 index cd7b3ab940e5..000000000000 --- a/stdlib/test-suite/output/NotationSyntax.v +++ /dev/null @@ -1,53 +0,0 @@ -(* Various meaningless notations *) -Fail Notation "#" := 0 (only parsing, only parsing). -Fail Notation "#" := 0 (only parsing, only printing). -Fail Notation "#" := 0 (only printing, only printing). -Notation "#" := 0 (only parsing, format "#"). - -(* Alerting about primitive syntax *) -Notation "1" := tt (at level 3). -Check 1%nat. -Fail Reserved Notation "1". - -Notation """tt""" := tt (at level 2). -Check "tt". -From Stdlib Require Import String. -Check "tt"%string. -Fail Reserved Notation """tt""". - -(* Test string literals themselves with double quotes *) -Notation """t""""t""" := tt. -Check "t""t". - -Module A. - -(* Not forced to be a keyword *) -Notation "# ""|"" a" := (Some a) (at level 0, a at level 0). -Check # "|" true. -Check "|"%string. - -(* Now forced to be a keyword *) -Notation "a ""|"" b" := (a, b) (at level 50). -Check 2 "|" 4. - -End A. - -Module B. - -Notation " ""I'm true"" " := true. -Check "I'm true". - -Notation """""" := false. (* Empty string *) -Check "". - -End B. - -Module C. - -Notation "symbolwith""doublequote" := true (only printing). -Check true. - -Notation "'""'" := false (only printing). (* double quote *) -Check false. - -End C. diff --git a/stdlib/test-suite/output/NotationsCoercionsString.out b/stdlib/test-suite/output/NotationsCoercionsString.out deleted file mode 100644 index 6ca63aa6aca4..000000000000 --- a/stdlib/test-suite/output/NotationsCoercionsString.out +++ /dev/null @@ -1,6 +0,0 @@ -Let "x" e1 e2 - : expr -Let "x" e1 e2 - : expr -Let "x" e1 e2 : list string - : list string diff --git a/stdlib/test-suite/output/NotationsCoercionsString.v b/stdlib/test-suite/output/NotationsCoercionsString.v deleted file mode 100644 index d5beac4de108..000000000000 --- a/stdlib/test-suite/output/NotationsCoercionsString.v +++ /dev/null @@ -1,23 +0,0 @@ -(* Tests about skipping a coercion vs using a notation involving a coercion *) - -From Stdlib Require Import String. - -(* Skipping a coercion vs using a notation for the application of the - coercion (from Robbert Krebbers, see PR #8890) *) - -Module A. - -Inductive expr := - | Var : string -> expr - | Lam : string -> expr -> expr - | App : expr -> expr -> expr. - -Notation Let x e1 e2 := (App (Lam x e2) e1). -Parameter e1 e2 : expr. -Check (Let "x" e1 e2). (* always printed the same *) -Coercion App : expr >-> Funclass. -Check (Let "x" e1 e2). (* printed the same from #8890, in 8.10 *) -Axiom free_vars :> expr -> list string. -Check (Let "x" e1 e2) : list string. (* printed the same from #11172, in 8.12 *) - -End A. diff --git a/stdlib/test-suite/output/NotationsZArith.out b/stdlib/test-suite/output/NotationsZArith.out deleted file mode 100644 index 407f6f587165..000000000000 --- a/stdlib/test-suite/output/NotationsZArith.out +++ /dev/null @@ -1,22 +0,0 @@ -3 + 3 - : Z -3 + 3 - : znat --4 - : Z -Init.Nat.add - : nat -> nat -> nat -S - : nat -> nat -Init.Nat.mul - : nat -> nat -> nat -le - : nat -> nat -> Prop -plus - : nat -> nat -> nat -succ - : nat -> nat -Init.Nat.mul - : nat -> nat -> nat -le - : nat -> nat -> Prop diff --git a/stdlib/test-suite/output/NotationsZArith.v b/stdlib/test-suite/output/NotationsZArith.v deleted file mode 100644 index 3de5b7f0672b..000000000000 --- a/stdlib/test-suite/output/NotationsZArith.v +++ /dev/null @@ -1,61 +0,0 @@ -(**********************************************************************) -(* Conflict between notation and notation below coercions *) - -(* Case of a printer conflict *) - -From Stdlib Require Import BinInt. -Coercion Zpos : positive >-> Z. -Open Scope Z_scope. - - (* Check that (Zpos 3) is better printed by the printer for Z than - by the printer for positive *) - -Check (3 + Zpos 3). - -(* Case of a num printer only below coercion (submitted by Georges Gonthier) *) - -Open Scope nat_scope. - -Inductive znat : Set := Zpos (n : nat) | Zneg (m : nat). -Coercion Zpos: nat >-> znat. - -Declare Scope znat_scope. -Delimit Scope znat_scope with znat. -Open Scope znat_scope. - -Parameter addz : znat -> znat -> znat. -Notation "z1 + z2" := (addz z1 z2) : znat_scope. - - (* Check that "3+3", where 3 is in nat and the coercion to znat is implicit, - is printed the same way, and not "S 2 + S 2" as if numeral printing was - only tested with coercion still present *) - -Check (3+3). - -(* This is another aspect of bug #1179 (raises anomaly in 8.1) *) - -From Stdlib Require Import ZArith. -Open Scope Z_scope. -Notation "- 4" := (-2 + -2). -Check -4. - -(**********************************************************************) -(* Check printing of notations from other modules *) - -(* 1- Non imported case *) - -Require TestSuite.make_notation. - -Check plus. -Check S. -Check mult. -Check le. - -(* 2- Imported case *) - -Import make_notation. - -Check plus. -Check S. -Check mult. -Check le. diff --git a/stdlib/test-suite/output/PosSyntax.out b/stdlib/test-suite/output/PosSyntax.out deleted file mode 100644 index fd6528d8d627..000000000000 --- a/stdlib/test-suite/output/PosSyntax.out +++ /dev/null @@ -1,95 +0,0 @@ -32%positive - : positive -eq_refl : 42%positive = 42%positive - : 42%positive = 42%positive -fun f : nat -> positive => (f 0%nat + 1)%positive - : (nat -> positive) -> positive -fun x : positive => (x~0)%positive - : positive -> positive -fun x : positive => (x + 1)%positive - : positive -> positive -fun x : positive => x - : positive -> positive -fun x : positive => (x~1)%positive - : positive -> positive -fun x : positive => (x~0 + 1)%positive - : positive -> positive -(Pos.of_nat 0 + 1)%positive - : positive -(1 + Pos.of_nat (0 + 0))%positive - : positive -Pos.of_nat 1 = 1%positive - : Prop -File "./output/PosSyntax.v", line 13, characters 11-12: -The command has indeed failed with message: -Cannot interpret this number as a value of type positive -File "./output/PosSyntax.v", line 14, characters 11-14: -The command has indeed failed with message: -Cannot interpret this number as a value of type positive -File "./output/PosSyntax.v", line 15, characters 11-15: -The command has indeed failed with message: -Cannot interpret this number as a value of type positive -1%positive - : positive -2%positive - : positive -255%positive - : positive -255%positive - : positive -1%positive - : positive -2%positive - : positive -255%positive - : positive -255%positive - : positive -0x2a - : positive -0x1 - : positive -File "./output/PosSyntax.v", line 29, characters 11-14: -The command has indeed failed with message: -Cannot interpret this number as a value of type positive -File "./output/PosSyntax.v", line 30, characters 11-15: -The command has indeed failed with message: -Cannot interpret this number as a value of type positive -0x1 - : positive -0x2 - : positive -0xff - : positive -0xff - : positive -File "./output/PosSyntax.v", line 35, characters 11-14: -The command has indeed failed with message: -Cannot interpret this number as a value of type positive -File "./output/PosSyntax.v", line 36, characters 11-15: -The command has indeed failed with message: -Cannot interpret this number as a value of type positive -0x1 - : positive -0x2 - : positive -0xff - : positive -0xff - : positive -File "./output/PosSyntax.v", line 41, characters 11-14: -The command has indeed failed with message: -Cannot interpret this number as a value of type positive -File "./output/PosSyntax.v", line 42, characters 11-15: -The command has indeed failed with message: -Cannot interpret this number as a value of type positive -0x1 - : positive -0x2 - : positive -0xff - : positive -0xff - : positive -(1 + Pos.of_nat 11)%positive - : positive diff --git a/stdlib/test-suite/output/PosSyntax.v b/stdlib/test-suite/output/PosSyntax.v deleted file mode 100644 index ada53ea0b18d..000000000000 --- a/stdlib/test-suite/output/PosSyntax.v +++ /dev/null @@ -1,50 +0,0 @@ -From Stdlib Require Import PArith. -Check 32%positive. -Check (eq_refl : 0x2a%positive = 42%positive). -Check (fun f : nat -> positive => (f 0%nat + 1)%positive). -Check (fun x : positive => xO x). -Check (fun x : positive => (x + 1)%positive). -Check (fun x : positive => x). -Check (fun x : positive => xI x). -Check (fun x : positive => (xO x + 1)%positive). -Check (Pos.of_nat 0 + 1)%positive. -Check (1 + Pos.of_nat (0 + 0))%positive. -Check (Pos.of_nat 1 = 1%positive). -Fail Check 0%positive. -Fail Check 0x0%positive. -Fail Check 0x00%positive. -Check 0x01%positive. -Check 0x02%positive. -Check 0xff%positive. -Check 0xFF%positive. -Check 0x01%xpositive. -Check 0x02%xpositive. -Check 0xff%xpositive. -Check 0xFF%xpositive. - -(* Check hexadecimal printing *) -Open Scope hex_positive_scope. -Check 42%positive. -Check 1%positive. -Fail Check 0x0%positive. -Fail Check 0x00%positive. -Check 0x01%positive. -Check 0x02%positive. -Check 0xff%positive. -Check 0xFF%positive. -Fail Check 0x0. -Fail Check 0x00. -Check 0x01. -Check 0x02. -Check 0xff. -Check 0xFF. -Fail Check 0x0%xpositive. -Fail Check 0x00%xpositive. -Check 0x01%xpositive. -Check 0x02%xpositive. -Check 0xff%xpositive. -Check 0xFF%xpositive. -Close Scope hex_positive_scope. - -From Stdlib Require Import Arith. -Check (1 + Pos.of_nat 11)%positive. diff --git a/stdlib/test-suite/output/PrintAssumptionsArith.out b/stdlib/test-suite/output/PrintAssumptionsArith.out deleted file mode 100644 index d095d3b787e1..000000000000 --- a/stdlib/test-suite/output/PrintAssumptionsArith.out +++ /dev/null @@ -1,14 +0,0 @@ -Axioms: -extensionality : - forall (P Q : Type) (f g : P -> Q), (forall x : P, f x = g x) -> f = g -Axioms: -extensionality : - forall (P Q : Type) (f g : P -> Q), (forall x : P, f x = g x) -> f = g -Axioms: -extensionality : - forall (P Q : Type) (f g : P -> Q), (forall x : P, f x = g x) -> f = g -Axioms: -extensionality : - forall (P Q : Type) (f g : P -> Q), (forall x : P, f x = g x) -> f = g -Closed under the global context -Closed under the global context diff --git a/stdlib/test-suite/output/PrintAssumptionsArith.v b/stdlib/test-suite/output/PrintAssumptionsArith.v deleted file mode 100644 index 2d0dec0ef856..000000000000 --- a/stdlib/test-suite/output/PrintAssumptionsArith.v +++ /dev/null @@ -1,69 +0,0 @@ -(** Print Assumption and opaque modules : - - Print Assumption used to consider as axioms the modular fields - unexported by their signature, cf bug report #2186. This should - now be fixed, let's test this here. *) - -(* The original test-case of the bug-report *) - -From Stdlib Require Import Arith. - -Axiom extensionality : forall P Q (f g:P -> Q), - (forall x, f x = g x) -> f = g. - -Module Type ADD_COMM_EXT. - Axiom add_comm_ext : forall n, (fun x => x + n) = (fun x => n + x). -End ADD_COMM_EXT. - -Module AddCommExt_Opaque : ADD_COMM_EXT. - Lemma add_comm_ext : forall n, (fun x => x + n) = (fun x => n + x). - Proof. - intro n; apply extensionality; auto with arith. - Qed. -End AddCommExt_Opaque. - -Module AddCommExt_Transparent <: ADD_COMM_EXT. - Lemma add_comm_ext : forall n, (fun x => x + n) = (fun x => n + x). - Proof. - intro n; apply extensionality; auto with arith. - Qed. -End AddCommExt_Transparent. - -Print Assumptions AddCommExt_Opaque.add_comm_ext. -(* Should answer: extensionality *) - -Print Assumptions AddCommExt_Transparent.add_comm_ext. -(* Should answer: extensionality *) - -Lemma add1_comm_ext_opaque : - (fun x => x + 1) = (fun x => 1 + x). -Proof (AddCommExt_Opaque.add_comm_ext 1). - -Lemma add1_comm_ext_transparent : - (fun x => x + 1) = (fun x => 1 + x). -Proof (AddCommExt_Transparent.add_comm_ext 1). - -Print Assumptions add1_comm_ext_opaque. -(* Should answer: extensionality *) - -Print Assumptions add1_comm_ext_transparent. -(* Should answer: extensionality *) - -Module Type FALSE_POSITIVE. - Axiom add_comm : forall n x, x + n = n + x. -End FALSE_POSITIVE. - -Module false_positive : FALSE_POSITIVE. - Lemma add_comm : forall n x, x + n = n + x. - Proof. auto with arith. Qed. - - Print Assumptions add_comm. - (* Should answer : Closed under the global context *) -End false_positive. - -Lemma comm_plus5 : forall x, - x + 5 = 5 + x. -Proof (false_positive.add_comm 5). - -Print Assumptions comm_plus5. -(* Should answer : Closed under the global context *) diff --git a/stdlib/test-suite/output/QArithSyntax.out b/stdlib/test-suite/output/QArithSyntax.out deleted file mode 100644 index ced52524f288..000000000000 --- a/stdlib/test-suite/output/QArithSyntax.out +++ /dev/null @@ -1,72 +0,0 @@ -eq_refl : 1.02 = 1.02 - : 1.02 = 1.02 -1.02e1 - : Q -10.2 - : Q -1.02e3 - : Q -1020 - : Q -1.02e2 - : Q -102 - : Q -eq_refl : 10.2e-1 = 1.02 - : 10.2e-1 = 1.02 -eq_refl : -0.0001 = -0.0001 - : -0.0001 = -0.0001 -eq_refl : -0.50 = -0.50 - : -0.50 = -0.50 -0 - : Q -0 - : Q -42 - : Q -42 - : Q -1.23 - : Q -0x1.23%xQ - : Q -0.0012 - : Q -42e3 - : Q -42e-3 - : Q -eq_refl : -0x1a = -0x1a - : -0x1a = -0x1a -eq_refl : 0xb.2c = 0xb.2c - : 0xb.2c = 0xb.2c -eq_refl : -0x1ae2 = -0x1ae2 - : -0x1ae2 = -0x1ae2 -0xb.2cp2 - : Q -2860 # 64 - : Q -0xb.2cp8 - : Q -0xb2c - : Q -eq_refl : -0xb.2cp-2 = -2860 # 1024 - : -0xb.2cp-2 = -2860 # 1024 -0x0 - : Q -0x0 - : Q -0x2a - : Q -0x2a - : Q -1.23%Q - : Q -0x1.23 - : Q -0x0.0012 - : Q -0x2ap3 - : Q -0x2ap-3 - : Q diff --git a/stdlib/test-suite/output/QArithSyntax.v b/stdlib/test-suite/output/QArithSyntax.v deleted file mode 100644 index 1edfa786d056..000000000000 --- a/stdlib/test-suite/output/QArithSyntax.v +++ /dev/null @@ -1,39 +0,0 @@ -From Stdlib Require Import QArith. -Open Scope Q_scope. -Check (eq_refl : 1.02 = 102 # 100). -Check 1.02e1. -Check 102 # 10. -Check 1.02e+03. -Check 1020. -Check 1.02e+02. -Check 102 # 1. -Check (eq_refl : 10.2e-1 = 1.02). -Check (eq_refl : -0.0001 = -1 # 10000). -Check (eq_refl : -0.50 = - 50 # 100). -Check 0. -Check 000. -Check 42. -Check 0x2a. -Check 1.23. -Check 0x1.23. -Check 0.0012. -Check 42e3. -Check 42e-3. -Open Scope hex_Q_scope. -Check (eq_refl : -0x1a = - 26 # 1). -Check (eq_refl : 0xb.2c = 2860 # 256). -Check (eq_refl : -0x1ae2 = -6882). -Check 0xb.2cp2. -Check 2860 # 64. -Check 0xb.2cp8. -Check 2860. -Check (eq_refl : -0xb.2cp-2 = -2860 # 1024). -Check 0x0. -Check 0x00. -Check 42. -Check 0x2a. -Check 1.23. -Check 0x1.23. -Check 0x0.0012. -Check 0x2ap3. -Check 0x2ap-3. diff --git a/stdlib/test-suite/output/RealNumberSyntax.out b/stdlib/test-suite/output/RealNumberSyntax.out deleted file mode 100644 index a7b7dabb20bc..000000000000 --- a/stdlib/test-suite/output/RealNumberSyntax.out +++ /dev/null @@ -1,84 +0,0 @@ -32%R - : R -(-31)%R - : R -1.5%R - : R -1.5e1%R - : R -eq_refl : 1.02 = 102e-2 - : 1.02 = 102e-2 -1.02e1 - : R -102e-1 - : R -1.02e3 - : R -102e1 - : R -1.02e2 - : R -102 - : R -10.2e-1 - : R -1.02 - : R -eq_refl : -0.0001 = -1e-4 - : -0.0001 = -1e-4 -eq_refl : -0.50 = -50e-2 - : -0.50 = -50e-2 -eq_refl : -26 = -26 - : -26 = -26 -eq_refl : 0xb.2c%xR = 0xb2cp-8%xR - : 0xb.2c%xR = 0xb2cp-8%xR -eq_refl : -6882 = -6882 - : -6882 = -6882 -0xb.2cp2%xR - : R -0xb2cp-6%xR - : R -0xb.2cp8%xR - : R -2860 - : R -(-0xb.2cp-2)%xR - : R -- 0xb2cp-10%xR - : R -0 - : R -0 - : R -42 - : R -42 - : R -1.23 - : R -0x1.23%xR - : R -0.0012 - : R -42e3 - : R -42e-3 - : R -0x0 - : R -0x0 - : R -0x2a - : R -0x2a - : R -1.23%R - : R -0x1.23 - : R -0x0.0012 - : R -0x2ap3 - : R -0x2ap-3 - : R diff --git a/stdlib/test-suite/output/RealNumberSyntax.v b/stdlib/test-suite/output/RealNumberSyntax.v deleted file mode 100644 index dd009ae6aae1..000000000000 --- a/stdlib/test-suite/output/RealNumberSyntax.v +++ /dev/null @@ -1,64 +0,0 @@ -From Stdlib Require Import Reals.Rdefinitions. -Check 32%R. -Check (-31)%R. - -Check 1.5_%R. -Check 1_.5_e1_%R. - -Open Scope R_scope. - -Check (eq_refl : 1.02 = IZR 102 / IZR (Z.pow_pos 10 2)). -Check 1.02e1. -Check IZR 102 / IZR (Z.pow_pos 10 1). -Check 1.02e+03. -Check IZR 102 * IZR (Z.pow_pos 10 1). -Check 1.02e+02. -Check IZR 102. -Check 10.2e-1. -Check 1.02. -Check (eq_refl : -0.0001 = IZR (-1) / IZR (Z.pow_pos 10 4)). -Check (eq_refl : -0.50 = IZR (-50) / IZR (Z.pow_pos 10 2)). -Check (eq_refl : -0x1a = - 26). -Check (eq_refl : 0xb.2c = IZR 2860 / IZR (Z.pow_pos 2 8)). -Check (eq_refl : -0x1ae2 = -6882). -Check 0xb.2cp2. -Check IZR 2860 / IZR (Z.pow_pos 2 6). -Check 0xb.2cp8. -Check 2860. -Check -0xb.2cp-2. -Check - (IZR 2860 / IZR (Z.pow_pos 2 10)). -Check 0. -Check 000. -Check 42. -Check 0x2a. -Check 1.23. -Check 0x1.23. -Check 0.0012. -Check 42e3. -Check 42e-3. - -Open Scope hex_R_scope. - -Check 0x0. -Check 0x000. -Check 42. -Check 0x2a. -Check 1.23. -Check 0x1.23. -Check 0x0.0012. -Check 0x2ap3. -Check 0x2ap-3. - -Close Scope hex_R_scope. - -From Stdlib Require Import Reals. - -Goal 254e3 = 2540 * 10 ^ 2. -ring. -Qed. - -From Stdlib Require Import Psatz. - -Goal 254e3 = 2540 * 10 ^ 2. -lra. -Qed. diff --git a/stdlib/test-suite/output/Search_2.out b/stdlib/test-suite/output/Search_2.out deleted file mode 100644 index ed3157453f9f..000000000000 --- a/stdlib/test-suite/output/Search_2.out +++ /dev/null @@ -1,37 +0,0 @@ -Nat.land_comm: forall a b : nat, Nat.land a b = Nat.land b a -Nat.lor_comm: forall a b : nat, Nat.lor a b = Nat.lor b a -Nat.lxor_comm: forall a b : nat, Nat.lxor a b = Nat.lxor b a -Nat.lcm_comm: forall a b : nat, Nat.lcm a b = Nat.lcm b a -Nat.min_comm: forall n m : nat, Nat.min n m = Nat.min m n -Nat.gcd_comm: forall n m : nat, Nat.gcd n m = Nat.gcd m n -Bool.xorb_comm: forall b b' : bool, xorb b b' = xorb b' b -Nat.max_comm: forall n m : nat, Nat.max n m = Nat.max m n -Nat.mul_comm: forall n m : nat, n * m = m * n -Nat.add_comm: forall n m : nat, n + m = m + n -Bool.orb_comm: forall b1 b2 : bool, (b1 || b2)%bool = (b2 || b1)%bool -Bool.andb_comm: forall b1 b2 : bool, (b1 && b2)%bool = (b2 && b1)%bool -Nat.eqb_sym: forall x y : nat, (x =? y) = (y =? x) -Nat.bit0_eqb: forall a : nat, Nat.testbit a 0 = (a mod 2 =? 1) -Nat.Div0.div_exact: forall a b : nat, a = b * (a / b) <-> a mod b = 0 -Nat.land_ones: forall a n : nat, Nat.land a (Nat.ones n) = a mod 2 ^ n -Nat.testbit_spec': - forall a n : nat, Nat.b2n (Nat.testbit a n) = (a / 2 ^ n) mod 2 -Nat.pow_div_l: - forall a b c : nat, b <> 0 -> a mod b = 0 -> (a / b) ^ c = a ^ c / b ^ c -Nat.testbit_eqb: forall a n : nat, Nat.testbit a n = ((a / 2 ^ n) mod 2 =? 1) -Nat.testbit_false: - forall a n : nat, Nat.testbit a n = false <-> (a / 2 ^ n) mod 2 = 0 -Nat.testbit_true: - forall a n : nat, Nat.testbit a n = true <-> (a / 2 ^ n) mod 2 = 1 -Nat.bit0_eqb: forall a : nat, Nat.testbit a 0 = (a mod 2 =? 1) -Nat.Div0.div_exact: forall a b : nat, a = b * (a / b) <-> a mod b = 0 -Nat.land_ones: forall a n : nat, Nat.land a (Nat.ones n) = a mod 2 ^ n -Nat.testbit_spec': - forall a n : nat, Nat.b2n (Nat.testbit a n) = (a / 2 ^ n) mod 2 -Nat.pow_div_l: - forall a b c : nat, b <> 0 -> a mod b = 0 -> (a / b) ^ c = a ^ c / b ^ c -Nat.testbit_eqb: forall a n : nat, Nat.testbit a n = ((a / 2 ^ n) mod 2 =? 1) -Nat.testbit_false: - forall a n : nat, Nat.testbit a n = false <-> (a / 2 ^ n) mod 2 = 0 -Nat.testbit_true: - forall a n : nat, Nat.testbit a n = true <-> (a / 2 ^ n) mod 2 = 1 diff --git a/stdlib/test-suite/output/Search_2.v b/stdlib/test-suite/output/Search_2.v deleted file mode 100644 index 6453fa3880c0..000000000000 --- a/stdlib/test-suite/output/Search_2.v +++ /dev/null @@ -1,5 +0,0 @@ -From Stdlib Require Import PeanoNat. - -Search (_ ?n ?m = _ ?m ?n). -Search "'mod'" -"mod". -Search "mod"%nat -"mod". diff --git a/stdlib/test-suite/output/Search_3.out b/stdlib/test-suite/output/Search_3.out deleted file mode 100644 index b395587efc7d..000000000000 --- a/stdlib/test-suite/output/Search_3.out +++ /dev/null @@ -1,32 +0,0 @@ -iff_Symmetric: Symmetric iff -iff_Reflexive: Reflexive iff -impl_Reflexive: Reflexive Basics.impl -eq_Symmetric: forall {A : Type}, Symmetric eq -eq_Reflexive: forall {A : Type}, Reflexive eq -Equivalence_Reflexive: - forall {A : Type} {R : Relation_Definitions.relation A}, - Equivalence R -> Reflexive R -Equivalence_Symmetric: - forall {A : Type} {R : Relation_Definitions.relation A}, - Equivalence R -> Symmetric R -PreOrder_Reflexive: - forall {A : Type} {R : Relation_Definitions.relation A}, - PreOrder R -> Reflexive R -PER_Symmetric: - forall {A : Type} {R : Relation_Definitions.relation A}, - PER R -> Symmetric R -neq_Symmetric: forall {A : Type}, Symmetric (fun x y : A => x <> y) -reflexive_eq_dom_reflexive: - forall {A B : Type} {R' : Relation_Definitions.relation B}, - Reflexive R' -> Reflexive (eq ==> R')%signature -B.b: B.a -A.b: A.a -F.L: F.P 0 -inr: forall {A B : Type}, B -> A + B -inl: forall {A B : Type}, A -> A + B -(use "About" for full details on the implicit arguments of inl and inr) -f: None = 0 -partition_cons1: - forall [A : Type] (f : A -> bool) (a : A) (l : list A) [l1 l2 : list A], - partition f l = (l1, l2) -> - f a = true -> partition f (a :: l) = (a :: l1, l2) diff --git a/stdlib/test-suite/output/Search_3.v b/stdlib/test-suite/output/Search_3.v deleted file mode 100644 index d06e092f26ed..000000000000 --- a/stdlib/test-suite/output/Search_3.v +++ /dev/null @@ -1,40 +0,0 @@ - -From Stdlib Require Import Morphisms. - -Search is:Instance [ Reflexive | Symmetric ]. - -Module Bug12525. - (* This was revealing a kernel bug with delta-resolution *) - Module A. Axiom a:Prop. Axiom b:a. End A. - Module B. Include A. End B. - Module M. - Search B.a. - End M. -End Bug12525. - -From Stdlib Require Lia. - -Module Bug12647. - (* Similar to #12525 *) - Module Type Foo. - Axiom P : nat -> Prop. - Axiom L : P 0. - End Foo. - - Module Bar (F : Foo). - Search F.P. - End Bar. -End Bug12647. - -Module WithCoercions. - Search headconcl:(_ + _) inside Datatypes. - Coercion Some_nat := @Some nat. - Axiom f : None = 0. - Search (None = 0). -End WithCoercions. - -From Stdlib Require Import List. - -Module Wish13349. -Search partition "1" inside List. -End Wish13349. diff --git a/stdlib/test-suite/output/Sint63NumberSyntax.out b/stdlib/test-suite/output/Sint63NumberSyntax.out deleted file mode 100644 index 79c3b04053c4..000000000000 --- a/stdlib/test-suite/output/Sint63NumberSyntax.out +++ /dev/null @@ -1,80 +0,0 @@ -2%sint63 - : int -2 - : int --3 - : int -4611686018427387903 - : int --4611686018427387904 - : int -427 - : int -427 - : int -427 - : int -427 - : int -427 - : int -File "./output/Sint63NumberSyntax.v", line 14, characters 11-17: -The command has indeed failed with message: -Cannot interpret this number as a value of type int -File "./output/Sint63NumberSyntax.v", line 15, characters 11-17: -The command has indeed failed with message: -Cannot interpret this number as a value of type int -0 - : int -0 - : int -File "./output/Sint63NumberSyntax.v", line 18, characters 12-14: -The command has indeed failed with message: -The reference xg was not found in the current environment. -File "./output/Sint63NumberSyntax.v", line 19, characters 12-14: -The command has indeed failed with message: -The reference xG was not found in the current environment. -File "./output/Sint63NumberSyntax.v", line 20, characters 13-15: -The command has indeed failed with message: -The reference x1 was not found in the current environment. -File "./output/Sint63NumberSyntax.v", line 21, characters 12-13: -The command has indeed failed with message: -The reference x was not found in the current environment. -2 + 2 - : int -File "./output/Sint63NumberSyntax.v", line 23, characters 11-30: -The command has indeed failed with message: -Cannot interpret this number as a value of type int -File "./output/Sint63NumberSyntax.v", line 24, characters 11-31: -The command has indeed failed with message: -Cannot interpret this number as a value of type int -0x1%uint63 - : int -0x7fffffffffffffff%uint63 - : int -2 - : nat -2%sint63 - : int -t = 2%si63 - : int -File "./output/Sint63NumberSyntax.v", line 37, characters 0-36: -Warning: Hiding binding of key sint63 to sint63_scope -[hiding-delimiting-key,parsing,default] -t = 2%si63 - : int -2 - : nat -2 - : int -File "./output/Sint63NumberSyntax.v", line 43, characters 0-39: -Warning: Hiding binding of key sint63 to nat_scope -[hiding-delimiting-key,parsing,default] -(2 + 2)%sint63 - : int -2 + 2 - : int - = 4 - : int - = 37151199385380486 - : int diff --git a/stdlib/test-suite/output/Sint63NumberSyntax.v b/stdlib/test-suite/output/Sint63NumberSyntax.v deleted file mode 100644 index 1c99e0e01585..000000000000 --- a/stdlib/test-suite/output/Sint63NumberSyntax.v +++ /dev/null @@ -1,49 +0,0 @@ -From Stdlib Require Import Sint63. - -Check 2%sint63. -Open Scope sint63_scope. -Check 2. -Check -3. -Check 4611686018427387903. -Check -4611686018427387904. -Check 0x1ab. -Check 0X1ab. -Check 0x1Ab. -Check 0x1aB. -Check 0x1AB. -Fail Check 0x1ap5. (* exponents not implemented (yet?) *) -Fail Check 0x1aP5. -Check 0x0. -Check 0x000. -Fail Check 0xg. -Fail Check 0xG. -Fail Check 00x1. -Fail Check 0x. -Check (PrimInt63.add 2 2). -Fail Check 4611686018427387904. -Fail Check -4611686018427387905. - -Set Printing All. -Check 1%sint63. -Check (-1)%sint63. -Unset Printing All. - -Open Scope nat_scope. -Check 2. (* : nat *) -Check 2%sint63. -Delimit Scope sint63_scope with si63. -Definition t := 2%sint63. -Print t. -Delimit Scope nat_scope with sint63. -Print t. -Check 2. -Close Scope nat_scope. -Check 2. -Close Scope sint63_scope. -Delimit Scope sint63_scope with sint63. - -Check (2 + 2)%sint63. -Open Scope sint63_scope. -Check (2+2). -Eval vm_compute in 2+2. -Eval vm_compute in 65675757 * 565675998. diff --git a/stdlib/test-suite/output/StringSyntax.out b/stdlib/test-suite/output/StringSyntax.out deleted file mode 100644 index 65668bd8a6f1..000000000000 --- a/stdlib/test-suite/output/StringSyntax.out +++ /dev/null @@ -1,1110 +0,0 @@ -byte_rect = -fun (P : byte -> Type) (f : P "000") (f0 : P "001") (f1 : P "002") (f2 : P "003") (f3 : P "004") (f4 : P "005") (f5 : P "006") (f6 : P "007") (f7 : P "008") (f8 : P "009") (f9 : P "010") (f10 : P "011") (f11 : P "012") (f12 : P "013") (f13 : P "014") (f14 : P "015") (f15 : P "016") (f16 : P "017") (f17 : P "018") (f18 : P "019") (f19 : P "020") (f20 : P "021") (f21 : P "022") (f22 : P "023") (f23 : P "024") (f24 : P "025") (f25 : P "026") (f26 : P "027") (f27 : P "028") (f28 : P "029") (f29 : P "030") (f30 : P "031") (f31 : P " ") (f32 : P "!") (f33 : P """") (f34 : P "#") (f35 : P "$") (f36 : P "%") (f37 : P "&") (f38 : P "'") (f39 : P "(") (f40 : P ")") (f41 : P "*") (f42 : P "+") (f43 : P ",") (f44 : P "-") (f45 : P ".") (f46 : P "/") (f47 : P "0") (f48 : P "1") (f49 : P "2") (f50 : P "3") (f51 : P "4") (f52 : P "5") (f53 : P "6") (f54 : P "7") (f55 : P "8") (f56 : P "9") (f57 : P ":") (f58 : P ";") (f59 : P "<") (f60 : P "=") (f61 : P ">") (f62 : P "?") - (f63 : P "@") (f64 : P "A") (f65 : P "B") (f66 : P "C") (f67 : P "D") (f68 : P "E") (f69 : P "F") (f70 : P "G") (f71 : P "H") (f72 : P "I") (f73 : P "J") (f74 : P "K") (f75 : P "L") (f76 : P "M") (f77 : P "N") (f78 : P "O") (f79 : P "P") (f80 : P "Q") (f81 : P "R") (f82 : P "S") (f83 : P "T") (f84 : P "U") (f85 : P "V") (f86 : P "W") (f87 : P "X") (f88 : P "Y") (f89 : P "Z") (f90 : P "[") (f91 : P "\") (f92 : P "]") (f93 : P "^") (f94 : P "_") (f95 : P "`") (f96 : P "a") (f97 : P "b") (f98 : P "c") (f99 : P "d") (f100 : P "e") (f101 : P "f") (f102 : P "g") (f103 : P "h") (f104 : P "i") (f105 : P "j") (f106 : P "k") (f107 : P "l") (f108 : P "m") (f109 : P "n") (f110 : P "o") (f111 : P "p") (f112 : P "q") (f113 : P "r") (f114 : P "s") (f115 : P "t") (f116 : P "u") (f117 : P "v") (f118 : P "w") (f119 : P "x") (f120 : P "y") (f121 : P "z") (f122 : P "{") (f123 : P "|") (f124 : P "}") (f125 : P "~") (f126 : P "127") (f127 : P "128") (f128 : P "129") (f129 : P "130") - (f130 : P "131") (f131 : P "132") (f132 : P "133") (f133 : P "134") (f134 : P "135") (f135 : P "136") (f136 : P "137") (f137 : P "138") (f138 : P "139") (f139 : P "140") (f140 : P "141") (f141 : P "142") (f142 : P "143") (f143 : P "144") (f144 : P "145") (f145 : P "146") (f146 : P "147") (f147 : P "148") (f148 : P "149") (f149 : P "150") (f150 : P "151") (f151 : P "152") (f152 : P "153") (f153 : P "154") (f154 : P "155") (f155 : P "156") (f156 : P "157") (f157 : P "158") (f158 : P "159") (f159 : P "160") (f160 : P "161") (f161 : P "162") (f162 : P "163") (f163 : P "164") (f164 : P "165") (f165 : P "166") (f166 : P "167") (f167 : P "168") (f168 : P "169") (f169 : P "170") (f170 : P "171") (f171 : P "172") (f172 : P "173") (f173 : P "174") (f174 : P "175") (f175 : P "176") (f176 : P "177") (f177 : P "178") (f178 : P "179") (f179 : P "180") (f180 : P "181") (f181 : P "182") (f182 : P "183") (f183 : P "184") (f184 : P "185") (f185 : P "186") (f186 : P "187") - (f187 : P "188") (f188 : P "189") (f189 : P "190") (f190 : P "191") (f191 : P "192") (f192 : P "193") (f193 : P "194") (f194 : P "195") (f195 : P "196") (f196 : P "197") (f197 : P "198") (f198 : P "199") (f199 : P "200") (f200 : P "201") (f201 : P "202") (f202 : P "203") (f203 : P "204") (f204 : P "205") (f205 : P "206") (f206 : P "207") (f207 : P "208") (f208 : P "209") (f209 : P "210") (f210 : P "211") (f211 : P "212") (f212 : P "213") (f213 : P "214") (f214 : P "215") (f215 : P "216") (f216 : P "217") (f217 : P "218") (f218 : P "219") (f219 : P "220") (f220 : P "221") (f221 : P "222") (f222 : P "223") (f223 : P "224") (f224 : P "225") (f225 : P "226") (f226 : P "227") (f227 : P "228") (f228 : P "229") (f229 : P "230") (f230 : P "231") (f231 : P "232") (f232 : P "233") (f233 : P "234") (f234 : P "235") (f235 : P "236") (f236 : P "237") (f237 : P "238") (f238 : P "239") (f239 : P "240") (f240 : P "241") (f241 : P "242") (f242 : P "243") (f243 : P "244") - (f244 : P "245") (f245 : P "246") (f246 : P "247") (f247 : P "248") (f248 : P "249") (f249 : P "250") (f250 : P "251") (f251 : P "252") (f252 : P "253") (f253 : P "254") (f254 : P "255") (b : byte) => -match b as b0 return (P b0) with -| "000" => f -| "001" => f0 -| "002" => f1 -| "003" => f2 -| "004" => f3 -| "005" => f4 -| "006" => f5 -| "007" => f6 -| "008" => f7 -| "009" => f8 -| "010" => f9 -| "011" => f10 -| "012" => f11 -| "013" => f12 -| "014" => f13 -| "015" => f14 -| "016" => f15 -| "017" => f16 -| "018" => f17 -| "019" => f18 -| "020" => f19 -| "021" => f20 -| "022" => f21 -| "023" => f22 -| "024" => f23 -| "025" => f24 -| "026" => f25 -| "027" => f26 -| "028" => f27 -| "029" => f28 -| "030" => f29 -| "031" => f30 -| " " => f31 -| "!" => f32 -| """" => f33 -| "#" => f34 -| "$" => f35 -| "%" => f36 -| "&" => f37 -| "'" => f38 -| "(" => f39 -| ")" => f40 -| "*" => f41 -| "+" => f42 -| "," => f43 -| "-" => f44 -| "." => f45 -| "/" => f46 -| "0" => f47 -| "1" => f48 -| "2" => f49 -| "3" => f50 -| "4" => f51 -| "5" => f52 -| "6" => f53 -| "7" => f54 -| "8" => f55 -| "9" => f56 -| ":" => f57 -| ";" => f58 -| "<" => f59 -| "=" => f60 -| ">" => f61 -| "?" => f62 -| "@" => f63 -| "A" => f64 -| "B" => f65 -| "C" => f66 -| "D" => f67 -| "E" => f68 -| "F" => f69 -| "G" => f70 -| "H" => f71 -| "I" => f72 -| "J" => f73 -| "K" => f74 -| "L" => f75 -| "M" => f76 -| "N" => f77 -| "O" => f78 -| "P" => f79 -| "Q" => f80 -| "R" => f81 -| "S" => f82 -| "T" => f83 -| "U" => f84 -| "V" => f85 -| "W" => f86 -| "X" => f87 -| "Y" => f88 -| "Z" => f89 -| "[" => f90 -| "\" => f91 -| "]" => f92 -| "^" => f93 -| "_" => f94 -| "`" => f95 -| "a" => f96 -| "b" => f97 -| "c" => f98 -| "d" => f99 -| "e" => f100 -| "f" => f101 -| "g" => f102 -| "h" => f103 -| "i" => f104 -| "j" => f105 -| "k" => f106 -| "l" => f107 -| "m" => f108 -| "n" => f109 -| "o" => f110 -| "p" => f111 -| "q" => f112 -| "r" => f113 -| "s" => f114 -| "t" => f115 -| "u" => f116 -| "v" => f117 -| "w" => f118 -| "x" => f119 -| "y" => f120 -| "z" => f121 -| "{" => f122 -| "|" => f123 -| "}" => f124 -| "~" => f125 -| "127" => f126 -| "128" => f127 -| "129" => f128 -| "130" => f129 -| "131" => f130 -| "132" => f131 -| "133" => f132 -| "134" => f133 -| "135" => f134 -| "136" => f135 -| "137" => f136 -| "138" => f137 -| "139" => f138 -| "140" => f139 -| "141" => f140 -| "142" => f141 -| "143" => f142 -| "144" => f143 -| "145" => f144 -| "146" => f145 -| "147" => f146 -| "148" => f147 -| "149" => f148 -| "150" => f149 -| "151" => f150 -| "152" => f151 -| "153" => f152 -| "154" => f153 -| "155" => f154 -| "156" => f155 -| "157" => f156 -| "158" => f157 -| "159" => f158 -| "160" => f159 -| "161" => f160 -| "162" => f161 -| "163" => f162 -| "164" => f163 -| "165" => f164 -| "166" => f165 -| "167" => f166 -| "168" => f167 -| "169" => f168 -| "170" => f169 -| "171" => f170 -| "172" => f171 -| "173" => f172 -| "174" => f173 -| "175" => f174 -| "176" => f175 -| "177" => f176 -| "178" => f177 -| "179" => f178 -| "180" => f179 -| "181" => f180 -| "182" => f181 -| "183" => f182 -| "184" => f183 -| "185" => f184 -| "186" => f185 -| "187" => f186 -| "188" => f187 -| "189" => f188 -| "190" => f189 -| "191" => f190 -| "192" => f191 -| "193" => f192 -| "194" => f193 -| "195" => f194 -| "196" => f195 -| "197" => f196 -| "198" => f197 -| "199" => f198 -| "200" => f199 -| "201" => f200 -| "202" => f201 -| "203" => f202 -| "204" => f203 -| "205" => f204 -| "206" => f205 -| "207" => f206 -| "208" => f207 -| "209" => f208 -| "210" => f209 -| "211" => f210 -| "212" => f211 -| "213" => f212 -| "214" => f213 -| "215" => f214 -| "216" => f215 -| "217" => f216 -| "218" => f217 -| "219" => f218 -| "220" => f219 -| "221" => f220 -| "222" => f221 -| "223" => f222 -| "224" => f223 -| "225" => f224 -| "226" => f225 -| "227" => f226 -| "228" => f227 -| "229" => f228 -| "230" => f229 -| "231" => f230 -| "232" => f231 -| "233" => f232 -| "234" => f233 -| "235" => f234 -| "236" => f235 -| "237" => f236 -| "238" => f237 -| "239" => f238 -| "240" => f239 -| "241" => f240 -| "242" => f241 -| "243" => f242 -| "244" => f243 -| "245" => f244 -| "246" => f245 -| "247" => f246 -| "248" => f247 -| "249" => f248 -| "250" => f249 -| "251" => f250 -| "252" => f251 -| "253" => f252 -| "254" => f253 -| "255" => f254 -end - : forall P : byte -> Type, - P "000" -> - P "001" -> - P "002" -> - P "003" -> - P "004" -> - P "005" -> - P "006" -> - P "007" -> - P "008" -> - P "009" -> - P "010" -> - P "011" -> - P "012" -> - P "013" -> - P "014" -> - P "015" -> - P "016" -> - P "017" -> - P "018" -> - P "019" -> - P "020" -> - P "021" -> - P "022" -> - P "023" -> - P "024" -> - P "025" -> - P "026" -> - P "027" -> - P "028" -> - P "029" -> - P "030" -> - P "031" -> - P " " -> - P "!" -> - P """" -> - P "#" -> - P "$" -> - P "%" -> - P "&" -> - P "'" -> - P "(" -> - P ")" -> - P "*" -> - P "+" -> - P "," -> - P "-" -> - P "." -> - P "/" -> - P "0" -> - P "1" -> - P "2" -> - P "3" -> - P "4" -> - P "5" -> - P "6" -> - P "7" -> - P "8" -> - P "9" -> - P ":" -> - P ";" -> - P "<" -> - P "=" -> - P ">" -> - P "?" -> - P "@" -> - P "A" -> - P "B" -> - P "C" -> - P "D" -> - P "E" -> - P "F" -> - P "G" -> - P "H" -> - P "I" -> - P "J" -> - P "K" -> - P "L" -> - P "M" -> - P "N" -> - P "O" -> - P "P" -> - P "Q" -> - P "R" -> - P "S" -> - P "T" -> - P "U" -> - P "V" -> - P "W" -> - P "X" -> - P "Y" -> - P "Z" -> - P "[" -> - P "\" -> - P "]" -> - P "^" -> - P "_" -> - P "`" -> - P "a" -> - P "b" -> - P "c" -> - P "d" -> - P "e" -> - P "f" -> - P "g" -> - P "h" -> - P "i" -> - P "j" -> - P "k" -> - P "l" -> - P "m" -> - P "n" -> - P "o" -> - P "p" -> - P "q" -> - P "r" -> - P "s" -> - P "t" -> - P "u" -> - P "v" -> - P "w" -> - P "x" -> - P "y" -> - P "z" -> - P "{" -> - P "|" -> - P "}" -> - P "~" -> - P "127" -> - P "128" -> - P "129" -> - P "130" -> - P "131" -> - P "132" -> - P "133" -> - P "134" -> - P "135" -> - P "136" -> - P "137" -> - P "138" -> - P "139" -> - P "140" -> - P "141" -> - P "142" -> - P "143" -> - P "144" -> - P "145" -> - P "146" -> - P "147" -> - P "148" -> - P "149" -> - P "150" -> - P "151" -> - P "152" -> - P "153" -> - P "154" -> - P "155" -> - P "156" -> - P "157" -> - P "158" -> - P "159" -> - P "160" -> - P "161" -> - P "162" -> - P "163" -> - P "164" -> - P "165" -> - P "166" -> - P "167" -> - P "168" -> P "169" -> P "170" -> P "171" -> P "172" -> P "173" -> P "174" -> P "175" -> P "176" -> P "177" -> P "178" -> P "179" -> P "180" -> P "181" -> P "182" -> P "183" -> P "184" -> P "185" -> P "186" -> P "187" -> P "188" -> P "189" -> P "190" -> P "191" -> P "192" -> P "193" -> P "194" -> P "195" -> P "196" -> P "197" -> P "198" -> P "199" -> P "200" -> P "201" -> P "202" -> P "203" -> P "204" -> P "205" -> P "206" -> P "207" -> P "208" -> P "209" -> P "210" -> P "211" -> P "212" -> P "213" -> P "214" -> P "215" -> P "216" -> P "217" -> P "218" -> P "219" -> P "220" -> P "221" -> P "222" -> P "223" -> P "224" -> P "225" -> P "226" -> P "227" -> P "228" -> P "229" -> P "230" -> P "231" -> P "232" -> P "233" -> P "234" -> P "235" -> P "236" -> P "237" -> P "238" -> P "239" -> P "240" -> P "241" -> P "242" -> P "243" -> P "244" -> P "245" -> P "246" -> P "247" -> P "248" -> P "249" -> P "250" -> P "251" -> P "252" -> P "253" -> P "254" -> P "255" -> forall b : byte, P b - -Arguments byte_rect P%function_scope f f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 f18 f19 f20 f21 f22 f23 f24 f25 f26 f27 f28 f29 f30 f31 f32 f33 f34 f35 f36 f37 f38 f39 f40 f41 f42 f43 f44 f45 f46 f47 f48 f49 f50 f51 f52 f53 f54 f55 f56 f57 f58 f59 f60 f61 f62 f63 f64 f65 f66 f67 f68 f69 f70 f71 f72 f73 f74 f75 f76 f77 f78 f79 f80 f81 f82 f83 f84 f85 f86 f87 f88 f89 f90 f91 f92 f93 f94 f95 f96 f97 f98 f99 f100 f101 f102 f103 f104 f105 f106 f107 f108 f109 f110 f111 f112 f113 f114 f115 f116 f117 f118 f119 f120 f121 f122 f123 f124 f125 f126 f127 f128 f129 f130 f131 f132 f133 f134 f135 f136 f137 f138 f139 f140 f141 f142 f143 f144 f145 f146 f147 f148 f149 f150 f151 f152 f153 f154 f155 f156 f157 f158 f159 f160 f161 f162 f163 f164 f165 f166 f167 f168 f169 f170 f171 f172 f173 f174 f175 f176 f177 f178 f179 f180 f181 f182 f183 f184 f185 f186 f187 f188 f189 f190 f191 f192 f193 f194 f195 f196 f197 f198 f199 f200 f201 f202 f203 f204 f205 f206 f207 f208 - f209 f210 f211 f212 f213 f214 f215 f216 f217 f218 f219 f220 f221 f222 f223 f224 f225 f226 f227 f228 f229 f230 f231 f232 f233 f234 f235 f236 f237 f238 f239 f240 f241 f242 f243 f244 f245 f246 f247 f248 f249 f250 f251 f252 f253 f254 b%byte_scope -byte_rec = -fun P : byte -> Set => byte_rect P - : forall P : byte -> Set, - P "000" -> - P "001" -> - P "002" -> - P "003" -> - P "004" -> - P "005" -> - P "006" -> - P "007" -> - P "008" -> - P "009" -> - P "010" -> - P "011" -> - P "012" -> - P "013" -> - P "014" -> - P "015" -> - P "016" -> - P "017" -> - P "018" -> - P "019" -> - P "020" -> - P "021" -> - P "022" -> - P "023" -> - P "024" -> - P "025" -> - P "026" -> - P "027" -> - P "028" -> - P "029" -> - P "030" -> - P "031" -> - P " " -> - P "!" -> - P """" -> - P "#" -> - P "$" -> - P "%" -> - P "&" -> - P "'" -> - P "(" -> - P ")" -> - P "*" -> - P "+" -> - P "," -> - P "-" -> - P "." -> - P "/" -> - P "0" -> - P "1" -> - P "2" -> - P "3" -> - P "4" -> - P "5" -> - P "6" -> - P "7" -> - P "8" -> - P "9" -> - P ":" -> - P ";" -> - P "<" -> - P "=" -> - P ">" -> - P "?" -> - P "@" -> - P "A" -> - P "B" -> - P "C" -> - P "D" -> - P "E" -> - P "F" -> - P "G" -> - P "H" -> - P "I" -> - P "J" -> - P "K" -> - P "L" -> - P "M" -> - P "N" -> - P "O" -> - P "P" -> - P "Q" -> - P "R" -> - P "S" -> - P "T" -> - P "U" -> - P "V" -> - P "W" -> - P "X" -> - P "Y" -> - P "Z" -> - P "[" -> - P "\" -> - P "]" -> - P "^" -> - P "_" -> - P "`" -> - P "a" -> - P "b" -> - P "c" -> - P "d" -> - P "e" -> - P "f" -> - P "g" -> - P "h" -> - P "i" -> - P "j" -> - P "k" -> - P "l" -> - P "m" -> - P "n" -> - P "o" -> - P "p" -> - P "q" -> - P "r" -> - P "s" -> - P "t" -> - P "u" -> - P "v" -> - P "w" -> - P "x" -> - P "y" -> - P "z" -> - P "{" -> - P "|" -> - P "}" -> - P "~" -> - P "127" -> - P "128" -> - P "129" -> - P "130" -> - P "131" -> - P "132" -> - P "133" -> - P "134" -> - P "135" -> - P "136" -> - P "137" -> - P "138" -> - P "139" -> - P "140" -> - P "141" -> - P "142" -> - P "143" -> - P "144" -> - P "145" -> - P "146" -> - P "147" -> - P "148" -> - P "149" -> - P "150" -> - P "151" -> - P "152" -> - P "153" -> - P "154" -> - P "155" -> - P "156" -> - P "157" -> - P "158" -> - P "159" -> - P "160" -> - P "161" -> - P "162" -> - P "163" -> - P "164" -> - P "165" -> - P "166" -> - P "167" -> - P "168" -> P "169" -> P "170" -> P "171" -> P "172" -> P "173" -> P "174" -> P "175" -> P "176" -> P "177" -> P "178" -> P "179" -> P "180" -> P "181" -> P "182" -> P "183" -> P "184" -> P "185" -> P "186" -> P "187" -> P "188" -> P "189" -> P "190" -> P "191" -> P "192" -> P "193" -> P "194" -> P "195" -> P "196" -> P "197" -> P "198" -> P "199" -> P "200" -> P "201" -> P "202" -> P "203" -> P "204" -> P "205" -> P "206" -> P "207" -> P "208" -> P "209" -> P "210" -> P "211" -> P "212" -> P "213" -> P "214" -> P "215" -> P "216" -> P "217" -> P "218" -> P "219" -> P "220" -> P "221" -> P "222" -> P "223" -> P "224" -> P "225" -> P "226" -> P "227" -> P "228" -> P "229" -> P "230" -> P "231" -> P "232" -> P "233" -> P "234" -> P "235" -> P "236" -> P "237" -> P "238" -> P "239" -> P "240" -> P "241" -> P "242" -> P "243" -> P "244" -> P "245" -> P "246" -> P "247" -> P "248" -> P "249" -> P "250" -> P "251" -> P "252" -> P "253" -> P "254" -> P "255" -> forall b : byte, P b - -Arguments byte_rec P%function_scope f f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 f18 f19 f20 f21 f22 f23 f24 f25 f26 f27 f28 f29 f30 f31 f32 f33 f34 f35 f36 f37 f38 f39 f40 f41 f42 f43 f44 f45 f46 f47 f48 f49 f50 f51 f52 f53 f54 f55 f56 f57 f58 f59 f60 f61 f62 f63 f64 f65 f66 f67 f68 f69 f70 f71 f72 f73 f74 f75 f76 f77 f78 f79 f80 f81 f82 f83 f84 f85 f86 f87 f88 f89 f90 f91 f92 f93 f94 f95 f96 f97 f98 f99 f100 f101 f102 f103 f104 f105 f106 f107 f108 f109 f110 f111 f112 f113 f114 f115 f116 f117 f118 f119 f120 f121 f122 f123 f124 f125 f126 f127 f128 f129 f130 f131 f132 f133 f134 f135 f136 f137 f138 f139 f140 f141 f142 f143 f144 f145 f146 f147 f148 f149 f150 f151 f152 f153 f154 f155 f156 f157 f158 f159 f160 f161 f162 f163 f164 f165 f166 f167 f168 f169 f170 f171 f172 f173 f174 f175 f176 f177 f178 f179 f180 f181 f182 f183 f184 f185 f186 f187 f188 f189 f190 f191 f192 f193 f194 f195 f196 f197 f198 f199 f200 f201 f202 f203 f204 f205 f206 f207 f208 - f209 f210 f211 f212 f213 f214 f215 f216 f217 f218 f219 f220 f221 f222 f223 f224 f225 f226 f227 f228 f229 f230 f231 f232 f233 f234 f235 f236 f237 f238 f239 f240 f241 f242 f243 f244 f245 f246 f247 f248 f249 f250 f251 f252 f253 f254 b%byte_scope -byte_ind = -fun (P : byte -> Prop) (f : P "000") (f0 : P "001") (f1 : P "002") (f2 : P "003") (f3 : P "004") (f4 : P "005") (f5 : P "006") (f6 : P "007") (f7 : P "008") (f8 : P "009") (f9 : P "010") (f10 : P "011") (f11 : P "012") (f12 : P "013") (f13 : P "014") (f14 : P "015") (f15 : P "016") (f16 : P "017") (f17 : P "018") (f18 : P "019") (f19 : P "020") (f20 : P "021") (f21 : P "022") (f22 : P "023") (f23 : P "024") (f24 : P "025") (f25 : P "026") (f26 : P "027") (f27 : P "028") (f28 : P "029") (f29 : P "030") (f30 : P "031") (f31 : P " ") (f32 : P "!") (f33 : P """") (f34 : P "#") (f35 : P "$") (f36 : P "%") (f37 : P "&") (f38 : P "'") (f39 : P "(") (f40 : P ")") (f41 : P "*") (f42 : P "+") (f43 : P ",") (f44 : P "-") (f45 : P ".") (f46 : P "/") (f47 : P "0") (f48 : P "1") (f49 : P "2") (f50 : P "3") (f51 : P "4") (f52 : P "5") (f53 : P "6") (f54 : P "7") (f55 : P "8") (f56 : P "9") (f57 : P ":") (f58 : P ";") (f59 : P "<") (f60 : P "=") (f61 : P ">") (f62 : P "?") - (f63 : P "@") (f64 : P "A") (f65 : P "B") (f66 : P "C") (f67 : P "D") (f68 : P "E") (f69 : P "F") (f70 : P "G") (f71 : P "H") (f72 : P "I") (f73 : P "J") (f74 : P "K") (f75 : P "L") (f76 : P "M") (f77 : P "N") (f78 : P "O") (f79 : P "P") (f80 : P "Q") (f81 : P "R") (f82 : P "S") (f83 : P "T") (f84 : P "U") (f85 : P "V") (f86 : P "W") (f87 : P "X") (f88 : P "Y") (f89 : P "Z") (f90 : P "[") (f91 : P "\") (f92 : P "]") (f93 : P "^") (f94 : P "_") (f95 : P "`") (f96 : P "a") (f97 : P "b") (f98 : P "c") (f99 : P "d") (f100 : P "e") (f101 : P "f") (f102 : P "g") (f103 : P "h") (f104 : P "i") (f105 : P "j") (f106 : P "k") (f107 : P "l") (f108 : P "m") (f109 : P "n") (f110 : P "o") (f111 : P "p") (f112 : P "q") (f113 : P "r") (f114 : P "s") (f115 : P "t") (f116 : P "u") (f117 : P "v") (f118 : P "w") (f119 : P "x") (f120 : P "y") (f121 : P "z") (f122 : P "{") (f123 : P "|") (f124 : P "}") (f125 : P "~") (f126 : P "127") (f127 : P "128") (f128 : P "129") (f129 : P "130") - (f130 : P "131") (f131 : P "132") (f132 : P "133") (f133 : P "134") (f134 : P "135") (f135 : P "136") (f136 : P "137") (f137 : P "138") (f138 : P "139") (f139 : P "140") (f140 : P "141") (f141 : P "142") (f142 : P "143") (f143 : P "144") (f144 : P "145") (f145 : P "146") (f146 : P "147") (f147 : P "148") (f148 : P "149") (f149 : P "150") (f150 : P "151") (f151 : P "152") (f152 : P "153") (f153 : P "154") (f154 : P "155") (f155 : P "156") (f156 : P "157") (f157 : P "158") (f158 : P "159") (f159 : P "160") (f160 : P "161") (f161 : P "162") (f162 : P "163") (f163 : P "164") (f164 : P "165") (f165 : P "166") (f166 : P "167") (f167 : P "168") (f168 : P "169") (f169 : P "170") (f170 : P "171") (f171 : P "172") (f172 : P "173") (f173 : P "174") (f174 : P "175") (f175 : P "176") (f176 : P "177") (f177 : P "178") (f178 : P "179") (f179 : P "180") (f180 : P "181") (f181 : P "182") (f182 : P "183") (f183 : P "184") (f184 : P "185") (f185 : P "186") (f186 : P "187") - (f187 : P "188") (f188 : P "189") (f189 : P "190") (f190 : P "191") (f191 : P "192") (f192 : P "193") (f193 : P "194") (f194 : P "195") (f195 : P "196") (f196 : P "197") (f197 : P "198") (f198 : P "199") (f199 : P "200") (f200 : P "201") (f201 : P "202") (f202 : P "203") (f203 : P "204") (f204 : P "205") (f205 : P "206") (f206 : P "207") (f207 : P "208") (f208 : P "209") (f209 : P "210") (f210 : P "211") (f211 : P "212") (f212 : P "213") (f213 : P "214") (f214 : P "215") (f215 : P "216") (f216 : P "217") (f217 : P "218") (f218 : P "219") (f219 : P "220") (f220 : P "221") (f221 : P "222") (f222 : P "223") (f223 : P "224") (f224 : P "225") (f225 : P "226") (f226 : P "227") (f227 : P "228") (f228 : P "229") (f229 : P "230") (f230 : P "231") (f231 : P "232") (f232 : P "233") (f233 : P "234") (f234 : P "235") (f235 : P "236") (f236 : P "237") (f237 : P "238") (f238 : P "239") (f239 : P "240") (f240 : P "241") (f241 : P "242") (f242 : P "243") (f243 : P "244") - (f244 : P "245") (f245 : P "246") (f246 : P "247") (f247 : P "248") (f248 : P "249") (f249 : P "250") (f250 : P "251") (f251 : P "252") (f252 : P "253") (f253 : P "254") (f254 : P "255") (b : byte) => -match b as b0 return (P b0) with -| "000" => f -| "001" => f0 -| "002" => f1 -| "003" => f2 -| "004" => f3 -| "005" => f4 -| "006" => f5 -| "007" => f6 -| "008" => f7 -| "009" => f8 -| "010" => f9 -| "011" => f10 -| "012" => f11 -| "013" => f12 -| "014" => f13 -| "015" => f14 -| "016" => f15 -| "017" => f16 -| "018" => f17 -| "019" => f18 -| "020" => f19 -| "021" => f20 -| "022" => f21 -| "023" => f22 -| "024" => f23 -| "025" => f24 -| "026" => f25 -| "027" => f26 -| "028" => f27 -| "029" => f28 -| "030" => f29 -| "031" => f30 -| " " => f31 -| "!" => f32 -| """" => f33 -| "#" => f34 -| "$" => f35 -| "%" => f36 -| "&" => f37 -| "'" => f38 -| "(" => f39 -| ")" => f40 -| "*" => f41 -| "+" => f42 -| "," => f43 -| "-" => f44 -| "." => f45 -| "/" => f46 -| "0" => f47 -| "1" => f48 -| "2" => f49 -| "3" => f50 -| "4" => f51 -| "5" => f52 -| "6" => f53 -| "7" => f54 -| "8" => f55 -| "9" => f56 -| ":" => f57 -| ";" => f58 -| "<" => f59 -| "=" => f60 -| ">" => f61 -| "?" => f62 -| "@" => f63 -| "A" => f64 -| "B" => f65 -| "C" => f66 -| "D" => f67 -| "E" => f68 -| "F" => f69 -| "G" => f70 -| "H" => f71 -| "I" => f72 -| "J" => f73 -| "K" => f74 -| "L" => f75 -| "M" => f76 -| "N" => f77 -| "O" => f78 -| "P" => f79 -| "Q" => f80 -| "R" => f81 -| "S" => f82 -| "T" => f83 -| "U" => f84 -| "V" => f85 -| "W" => f86 -| "X" => f87 -| "Y" => f88 -| "Z" => f89 -| "[" => f90 -| "\" => f91 -| "]" => f92 -| "^" => f93 -| "_" => f94 -| "`" => f95 -| "a" => f96 -| "b" => f97 -| "c" => f98 -| "d" => f99 -| "e" => f100 -| "f" => f101 -| "g" => f102 -| "h" => f103 -| "i" => f104 -| "j" => f105 -| "k" => f106 -| "l" => f107 -| "m" => f108 -| "n" => f109 -| "o" => f110 -| "p" => f111 -| "q" => f112 -| "r" => f113 -| "s" => f114 -| "t" => f115 -| "u" => f116 -| "v" => f117 -| "w" => f118 -| "x" => f119 -| "y" => f120 -| "z" => f121 -| "{" => f122 -| "|" => f123 -| "}" => f124 -| "~" => f125 -| "127" => f126 -| "128" => f127 -| "129" => f128 -| "130" => f129 -| "131" => f130 -| "132" => f131 -| "133" => f132 -| "134" => f133 -| "135" => f134 -| "136" => f135 -| "137" => f136 -| "138" => f137 -| "139" => f138 -| "140" => f139 -| "141" => f140 -| "142" => f141 -| "143" => f142 -| "144" => f143 -| "145" => f144 -| "146" => f145 -| "147" => f146 -| "148" => f147 -| "149" => f148 -| "150" => f149 -| "151" => f150 -| "152" => f151 -| "153" => f152 -| "154" => f153 -| "155" => f154 -| "156" => f155 -| "157" => f156 -| "158" => f157 -| "159" => f158 -| "160" => f159 -| "161" => f160 -| "162" => f161 -| "163" => f162 -| "164" => f163 -| "165" => f164 -| "166" => f165 -| "167" => f166 -| "168" => f167 -| "169" => f168 -| "170" => f169 -| "171" => f170 -| "172" => f171 -| "173" => f172 -| "174" => f173 -| "175" => f174 -| "176" => f175 -| "177" => f176 -| "178" => f177 -| "179" => f178 -| "180" => f179 -| "181" => f180 -| "182" => f181 -| "183" => f182 -| "184" => f183 -| "185" => f184 -| "186" => f185 -| "187" => f186 -| "188" => f187 -| "189" => f188 -| "190" => f189 -| "191" => f190 -| "192" => f191 -| "193" => f192 -| "194" => f193 -| "195" => f194 -| "196" => f195 -| "197" => f196 -| "198" => f197 -| "199" => f198 -| "200" => f199 -| "201" => f200 -| "202" => f201 -| "203" => f202 -| "204" => f203 -| "205" => f204 -| "206" => f205 -| "207" => f206 -| "208" => f207 -| "209" => f208 -| "210" => f209 -| "211" => f210 -| "212" => f211 -| "213" => f212 -| "214" => f213 -| "215" => f214 -| "216" => f215 -| "217" => f216 -| "218" => f217 -| "219" => f218 -| "220" => f219 -| "221" => f220 -| "222" => f221 -| "223" => f222 -| "224" => f223 -| "225" => f224 -| "226" => f225 -| "227" => f226 -| "228" => f227 -| "229" => f228 -| "230" => f229 -| "231" => f230 -| "232" => f231 -| "233" => f232 -| "234" => f233 -| "235" => f234 -| "236" => f235 -| "237" => f236 -| "238" => f237 -| "239" => f238 -| "240" => f239 -| "241" => f240 -| "242" => f241 -| "243" => f242 -| "244" => f243 -| "245" => f244 -| "246" => f245 -| "247" => f246 -| "248" => f247 -| "249" => f248 -| "250" => f249 -| "251" => f250 -| "252" => f251 -| "253" => f252 -| "254" => f253 -| "255" => f254 -end - : forall P : byte -> Prop, - P "000" -> - P "001" -> - P "002" -> - P "003" -> - P "004" -> - P "005" -> - P "006" -> - P "007" -> - P "008" -> - P "009" -> - P "010" -> - P "011" -> - P "012" -> - P "013" -> - P "014" -> - P "015" -> - P "016" -> - P "017" -> - P "018" -> - P "019" -> - P "020" -> - P "021" -> - P "022" -> - P "023" -> - P "024" -> - P "025" -> - P "026" -> - P "027" -> - P "028" -> - P "029" -> - P "030" -> - P "031" -> - P " " -> - P "!" -> - P """" -> - P "#" -> - P "$" -> - P "%" -> - P "&" -> - P "'" -> - P "(" -> - P ")" -> - P "*" -> - P "+" -> - P "," -> - P "-" -> - P "." -> - P "/" -> - P "0" -> - P "1" -> - P "2" -> - P "3" -> - P "4" -> - P "5" -> - P "6" -> - P "7" -> - P "8" -> - P "9" -> - P ":" -> - P ";" -> - P "<" -> - P "=" -> - P ">" -> - P "?" -> - P "@" -> - P "A" -> - P "B" -> - P "C" -> - P "D" -> - P "E" -> - P "F" -> - P "G" -> - P "H" -> - P "I" -> - P "J" -> - P "K" -> - P "L" -> - P "M" -> - P "N" -> - P "O" -> - P "P" -> - P "Q" -> - P "R" -> - P "S" -> - P "T" -> - P "U" -> - P "V" -> - P "W" -> - P "X" -> - P "Y" -> - P "Z" -> - P "[" -> - P "\" -> - P "]" -> - P "^" -> - P "_" -> - P "`" -> - P "a" -> - P "b" -> - P "c" -> - P "d" -> - P "e" -> - P "f" -> - P "g" -> - P "h" -> - P "i" -> - P "j" -> - P "k" -> - P "l" -> - P "m" -> - P "n" -> - P "o" -> - P "p" -> - P "q" -> - P "r" -> - P "s" -> - P "t" -> - P "u" -> - P "v" -> - P "w" -> - P "x" -> - P "y" -> - P "z" -> - P "{" -> - P "|" -> - P "}" -> - P "~" -> - P "127" -> - P "128" -> - P "129" -> - P "130" -> - P "131" -> - P "132" -> - P "133" -> - P "134" -> - P "135" -> - P "136" -> - P "137" -> - P "138" -> - P "139" -> - P "140" -> - P "141" -> - P "142" -> - P "143" -> - P "144" -> - P "145" -> - P "146" -> - P "147" -> - P "148" -> - P "149" -> - P "150" -> - P "151" -> - P "152" -> - P "153" -> - P "154" -> - P "155" -> - P "156" -> - P "157" -> - P "158" -> - P "159" -> - P "160" -> - P "161" -> - P "162" -> - P "163" -> - P "164" -> - P "165" -> - P "166" -> - P "167" -> - P "168" -> P "169" -> P "170" -> P "171" -> P "172" -> P "173" -> P "174" -> P "175" -> P "176" -> P "177" -> P "178" -> P "179" -> P "180" -> P "181" -> P "182" -> P "183" -> P "184" -> P "185" -> P "186" -> P "187" -> P "188" -> P "189" -> P "190" -> P "191" -> P "192" -> P "193" -> P "194" -> P "195" -> P "196" -> P "197" -> P "198" -> P "199" -> P "200" -> P "201" -> P "202" -> P "203" -> P "204" -> P "205" -> P "206" -> P "207" -> P "208" -> P "209" -> P "210" -> P "211" -> P "212" -> P "213" -> P "214" -> P "215" -> P "216" -> P "217" -> P "218" -> P "219" -> P "220" -> P "221" -> P "222" -> P "223" -> P "224" -> P "225" -> P "226" -> P "227" -> P "228" -> P "229" -> P "230" -> P "231" -> P "232" -> P "233" -> P "234" -> P "235" -> P "236" -> P "237" -> P "238" -> P "239" -> P "240" -> P "241" -> P "242" -> P "243" -> P "244" -> P "245" -> P "246" -> P "247" -> P "248" -> P "249" -> P "250" -> P "251" -> P "252" -> P "253" -> P "254" -> P "255" -> forall b : byte, P b - -Arguments byte_ind P%function_scope f f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 f18 f19 f20 f21 f22 f23 f24 f25 f26 f27 f28 f29 f30 f31 f32 f33 f34 f35 f36 f37 f38 f39 f40 f41 f42 f43 f44 f45 f46 f47 f48 f49 f50 f51 f52 f53 f54 f55 f56 f57 f58 f59 f60 f61 f62 f63 f64 f65 f66 f67 f68 f69 f70 f71 f72 f73 f74 f75 f76 f77 f78 f79 f80 f81 f82 f83 f84 f85 f86 f87 f88 f89 f90 f91 f92 f93 f94 f95 f96 f97 f98 f99 f100 f101 f102 f103 f104 f105 f106 f107 f108 f109 f110 f111 f112 f113 f114 f115 f116 f117 f118 f119 f120 f121 f122 f123 f124 f125 f126 f127 f128 f129 f130 f131 f132 f133 f134 f135 f136 f137 f138 f139 f140 f141 f142 f143 f144 f145 f146 f147 f148 f149 f150 f151 f152 f153 f154 f155 f156 f157 f158 f159 f160 f161 f162 f163 f164 f165 f166 f167 f168 f169 f170 f171 f172 f173 f174 f175 f176 f177 f178 f179 f180 f181 f182 f183 f184 f185 f186 f187 f188 f189 f190 f191 f192 f193 f194 f195 f196 f197 f198 f199 f200 f201 f202 f203 f204 f205 f206 f207 f208 - f209 f210 f211 f212 f213 f214 f215 f216 f217 f218 f219 f220 f221 f222 f223 f224 f225 f226 f227 f228 f229 f230 f231 f232 f233 f234 f235 f236 f237 f238 f239 f240 f241 f242 f243 f244 f245 f246 f247 f248 f249 f250 f251 f252 f253 f254 b%byte_scope -"000" - : byte -"a" - : byte -"127" - : byte -File "./output/StringSyntax.v", line 18, characters 11-16: -The command has indeed failed with message: -Expects a single character or a three-digit ASCII code. -"000" - : ascii -"a" - : ascii -"127" - : ascii -File "./output/StringSyntax.v", line 25, characters 11-16: -The command has indeed failed with message: -Expects a single character or a three-digit ASCII code. -"000" - : string -"a" - : string -"127" - : string -"ā‚¬" - : string -"" - : string - = "a"%char - : ascii - = "a"%byte - : byte - = "a"%string - : string - = ["a"%byte] - : list byte - = ["000"; "001"; "002"; "003"; "004"; "005"; "006"; "007"; "008"; "009"; "010"; "011"; "012"; "013"; "014"; "015"; "016"; "017"; "018"; "019"; "020"; "021"; "022"; "023"; "024"; "025"; "026"; "027"; "028"; "029"; "030"; "031"; " "; "!"; """"; "#"; "$"; "%"; "&"; "'"; "("; ")"; "*"; "+"; ","; "-"; "."; "/"; "0"; "1"; "2"; "3"; "4"; "5"; "6"; "7"; "8"; "9"; ":"; ";"; "<"; "="; ">"; "?"; "@"; "A"; "B"; "C"; "D"; "E"; "F"; "G"; "H"; "I"; "J"; "K"; "L"; "M"; "N"; "O"; "P"; "Q"; "R"; "S"; "T"; "U"; "V"; "W"; "X"; "Y"; "Z"; "["; "\"; "]"; "^"; "_"; "`"; "a"; "b"; "c"; "d"; "e"; "f"; "g"; "h"; "i"; "j"; "k"; "l"; "m"; "n"; "o"; "p"; "q"; "r"; "s"; "t"; "u"; "v"; "w"; "x"; "y"; "z"; "{"; "|"; "}"; "~"; "127"; "128"; "129"; "130"; "131"; "132"; "133"; "134"; "135"; "136"; "137"; "138"; "139"; "140"; "141"; "142"; "143"; "144"; "145"; "146"; "147"; "148"; "149"; "150"; "151"; "152"; "153"; "154"; "155"; "156"; "157"; "158"; "159"; "160"; "161"; "162"; "163"; "164"; "165"; "166"; "167"; - "168"; "169"; "170"; "171"; "172"; "173"; "174"; "175"; "176"; "177"; "178"; "179"; "180"; "181"; "182"; "183"; "184"; "185"; "186"; "187"; "188"; "189"; "190"; "191"; "192"; "193"; "194"; "195"; "196"; "197"; "198"; "199"; "200"; "201"; "202"; "203"; "204"; "205"; "206"; "207"; "208"; "209"; "210"; "211"; "212"; "213"; "214"; "215"; "216"; "217"; "218"; "219"; "220"; "221"; "222"; "223"; "224"; "225"; "226"; "227"; "228"; "229"; "230"; "231"; "232"; "233"; "234"; "235"; "236"; "237"; "238"; "239"; "240"; "241"; "242"; "243"; "244"; "245"; "246"; "247"; "248"; "249"; "250"; "251"; "252"; "253"; "254"; "255"] - : list byte - = ["000"; "001"; "002"; "003"; "004"; "005"; "006"; "007"; "008"; "009"; "010"; "011"; "012"; "013"; "014"; "015"; "016"; "017"; "018"; "019"; "020"; "021"; "022"; "023"; "024"; "025"; "026"; "027"; "028"; "029"; "030"; "031"; " "; "!"; """"; "#"; "$"; "%"; "&"; "'"; "("; ")"; "*"; "+"; ","; "-"; "."; "/"; "0"; "1"; "2"; "3"; "4"; "5"; "6"; "7"; "8"; "9"; ":"; ";"; "<"; "="; ">"; "?"; "@"; "A"; "B"; "C"; "D"; "E"; "F"; "G"; "H"; "I"; "J"; "K"; "L"; "M"; "N"; "O"; "P"; "Q"; "R"; "S"; "T"; "U"; "V"; "W"; "X"; "Y"; "Z"; "["; "\"; "]"; "^"; "_"; "`"; "a"; "b"; "c"; "d"; "e"; "f"; "g"; "h"; "i"; "j"; "k"; "l"; "m"; "n"; "o"; "p"; "q"; "r"; "s"; "t"; "u"; "v"; "w"; "x"; "y"; "z"; "{"; "|"; "}"; "~"; "127"; "128"; "129"; "130"; "131"; "132"; "133"; "134"; "135"; "136"; "137"; "138"; "139"; "140"; "141"; "142"; "143"; "144"; "145"; "146"; "147"; "148"; "149"; "150"; "151"; "152"; "153"; "154"; "155"; "156"; "157"; "158"; "159"; "160"; "161"; "162"; "163"; "164"; "165"; "166"; "167"; - "168"; "169"; "170"; "171"; "172"; "173"; "174"; "175"; "176"; "177"; "178"; "179"; "180"; "181"; "182"; "183"; "184"; "185"; "186"; "187"; "188"; "189"; "190"; "191"; "192"; "193"; "194"; "195"; "196"; "197"; "198"; "199"; "200"; "201"; "202"; "203"; "204"; "205"; "206"; "207"; "208"; "209"; "210"; "211"; "212"; "213"; "214"; "215"; "216"; "217"; "218"; "219"; "220"; "221"; "222"; "223"; "224"; "225"; "226"; "227"; "228"; "229"; "230"; "231"; "232"; "233"; "234"; "235"; "236"; "237"; "238"; "239"; "240"; "241"; "242"; "243"; "244"; "245"; "246"; "247"; "248"; "249"; "250"; "251"; "252"; "253"; "254"; "255"] - : list ascii -"abc" - : string -"000" - : nat -"001" - : nat -"002" - : nat -"255" - : nat -File "./output/StringSyntax.v", line 95, characters 11-16: -The command has indeed failed with message: -Expects a single character or a three-digit ASCII code. -"abc" - : string2 -"abc" : string2 - : string2 -"abc" : string1 - : string1 diff --git a/stdlib/test-suite/output/StringSyntax.v b/stdlib/test-suite/output/StringSyntax.v deleted file mode 100644 index 90f621b3baba..000000000000 --- a/stdlib/test-suite/output/StringSyntax.v +++ /dev/null @@ -1,117 +0,0 @@ -From Stdlib Require Import List. -From Stdlib.Strings Require Import String Byte Ascii. -Import ListNotations. - -Set Printing Depth 100000. -Set Printing Width 1000. - -Close Scope char_scope. -Close Scope string_scope. - -Open Scope byte_scope. -Print byte_rect. -Print byte_rec. -Print byte_ind. -Check "000". -Check "a". -Check "127". -Fail Check "ā‚¬". -Close Scope byte_scope. - -Open Scope char_scope. -Check "000". -Check "a". -Check "127". -Fail Check "ā‚¬". -Close Scope char_scope. - -Open Scope string_scope. -Check "000". -Check "a". -Check "127". -Check "ā‚¬". -Check String "001" EmptyString. -Close Scope string_scope. - -Compute ascii_of_byte "a". -Compute byte_of_ascii "a". -Compute string_of_list_byte ("a"::nil)%byte. -Compute list_byte_of_string "a". - -Local Open Scope byte_scope. -Compute List.fold_right - (fun n ls => match Byte.of_nat n with - | Some b => cons b ls - | None => ls - end) - nil - (ListDef.seq 0 256). -Local Close Scope byte_scope. -Local Open Scope char_scope. -Compute List.map Ascii.ascii_of_nat (ListDef.seq 0 256). -Local Close Scope char_scope. - -(* Test numeral notations for parameterized inductives *) -Module Test2. - -Notation string := (list Byte.byte). -Definition id_string := @id string. - -String Notation string id_string id_string : list_scope. - -Check "abc"%list. - -End Test2. - -(* Test the via ... using ... option *) -Module Test3. - -Inductive I := -| IO : I -| IS : I -> I. - -Definition of_byte (x : Byte.byte) : I := - let fix f n := - match n with - | O => IO - | S n => IS (f n) - end in - f (Byte.to_nat x). - -Definition to_byte (x : I) : option Byte.byte := - let fix f i := - match i with - | IO => O - | IS i => S (f i) - end in - Byte.of_nat (f x). - -String Notation nat of_byte to_byte (via I mapping [O => IO, S => IS]) : nat_scope. - -Check "000". -Check "001". -Check "002". -Check "255". -Fail Check "256". - -End Test3. - -(* Test overlapping string notations *) -Module Test4. - -Notation string1 := (list Byte.byte). -Definition id_string1 := @id string1. - -String Notation string1 id_string1 id_string1 : list_scope. - -Notation string2 := (list Ascii.ascii). -Definition a2b := List.map byte_of_ascii. -Definition b2a := List.map ascii_of_byte. - -String Notation string2 b2a a2b : list_scope. - -Check "abc"%list. -Check ["a";"b";"c"]%char%list : string2. -Check ["a";"b";"c"]%byte%list : string1. - -End Test4. diff --git a/stdlib/test-suite/output/StringSyntaxPrimitive.out b/stdlib/test-suite/output/StringSyntaxPrimitive.out deleted file mode 100644 index fcfa96a2b8b6..000000000000 --- a/stdlib/test-suite/output/StringSyntaxPrimitive.out +++ /dev/null @@ -1,20 +0,0 @@ -"abc" - : intList -"abc" - : intList -mk_intList [97%uint63; 98%uint63; 99%uint63] - : intList -"abc" - : intArray -"abc" - : intArray - = "abc" - : nestArray -"abc" - : nestArray -"100" - : floatList -"100" - : floatList -mk_floatList [1%float; 0%float; 0%float] - : floatList diff --git a/stdlib/test-suite/output/StringSyntaxPrimitive.v b/stdlib/test-suite/output/StringSyntaxPrimitive.v deleted file mode 100644 index 818378c4793a..000000000000 --- a/stdlib/test-suite/output/StringSyntaxPrimitive.v +++ /dev/null @@ -1,159 +0,0 @@ -From Stdlib Require Import List. -From Stdlib.Strings Require Import String Byte Ascii. -From Stdlib Require PArray PrimFloat. -From Stdlib Require Import BinNums Uint63. - -Set Printing Depth 100000. -Set Printing Width 1000. - -Close Scope char_scope. -Close Scope string_scope. - -(* Notations for primitive integers inside polymorphic datatypes *) -Module Test1. - Inductive intList := mk_intList (_ : list int). - Definition i63_from_byte (b : byte) : int := Uint63Axioms.of_Z (BinInt.Z.of_N (Byte.to_N b)). - Definition i63_to_byte (i : int) : byte := - match Byte.of_N (BinInt.Z.to_N (Uint63Axioms.to_Z i)) with Some x => x | None => x00%byte end. - - Definition to_byte_list '(mk_intList a) := List.map i63_to_byte a. - - Definition from_byte_list (xs : list byte) : intList:= - mk_intList (List.map i63_from_byte xs). - - Declare Scope intList_scope. - Delimit Scope intList_scope with intList. - - String Notation intList from_byte_list to_byte_list : intList_scope. - - Open Scope intList_scope. - Import List.ListNotations. - Check mk_intList [97; 98; 99]%uint63%list. - Check "abc"%intList. - - Definition int' := int. - Check mk_intList (@cons int' 97 [98; 99])%uint63%list. -End Test1. - -Import PArray. - -(* Notations for primitive arrays *) -Module Test2. - Inductive intArray := mk_intArray (_ : array int). - - Definition i63_from_byte (b : byte) : Uint63.int := Uint63Axioms.of_Z (BinInt.Z.of_N (Byte.to_N b)). - Definition i63_to_byte (i : Uint63.int) : byte := - match Byte.of_N (BinInt.Z.to_N (Uint63Axioms.to_Z i)) with Some x => x | None => x00%byte end. - - Definition i63_to_nat x := BinInt.Z.to_nat (Uint63Axioms.to_Z x). - Local Definition nat_length {X} (x : array X) :nat := i63_to_nat (length x). - - Local Fixpoint list_length_i63 {A} (xs : list A) :int := - match xs with - | nil => 0 - | cons _ xs => 1 + list_length_i63 xs - end. - - Definition to_byte_list '(mk_intArray a) := - ((fix go (n : nat) (i : Uint63.int) (acc : list byte) := - match n with - | 0 => acc - | S n => go n (i - 1) (cons (i63_to_byte a.[i]) acc) - end) (nat_length a) (length a - 1) nil)%uint63. - - Definition from_byte_list (xs : list byte) := - (let arr := make (list_length_i63 xs) 0 in - mk_intArray ((fix go i xs acc := - match xs with - | nil => acc - | cons x xs => go (i + 1) xs (acc.[i <- i63_from_byte x]) - end) 0 xs arr))%uint63. - - Declare Scope intArray_scope. - Delimit Scope intArray_scope with intArray. - - String Notation intArray from_byte_list to_byte_list : intArray_scope. - - Open Scope intArray_scope. - Check mk_intArray ( [| 97; 98; 99 | 0|])%uint63%array. - Check "abc"%intArray. - -End Test2. - -(* Primitive arrays inside primitive arrays *) -Module Test3. - - Inductive nestArray := mk_nestArray (_ : array (array int)). - Definition to_byte_list '(mk_nestArray a) := - ((fix go (n : nat) (i : Uint63.int) (acc : list byte) := - match n with - | 0 => acc - | S n => go n (i - 1) (cons (Test2.i63_to_byte a.[i].[0]) acc) - end) (Test2.nat_length a) (length a - 1) nil)%uint63. - - Definition from_byte_list (xs : list byte) := - (let arr := make (Test2.list_length_i63 xs) (make 0 0) in - mk_nestArray ((fix go i xs acc := - match xs with - | nil => acc - | cons x xs => go (i + 1) xs (acc.[i <- make 1 (Test2.i63_from_byte x)]) - end) 0 xs arr))%uint63. - - Declare Scope nestArray_scope. - Delimit Scope nestArray_scope with nestArray. - - String Notation nestArray from_byte_list to_byte_list : nestArray_scope. - - Open Scope nestArray_scope. - Eval cbv in mk_nestArray ( [| make 1 97; make 1 98; make 1 99 | make 0 0|])%uint63%array. - Check "abc"%nestArray. -End Test3. - - - -(* Notations for primitive floats inside polymorphic datatypes *) -Module Test4. - Import PrimFloat. - Inductive floatList := mk_floatList (_ : list float). - Definition float_from_byte (b : byte) : float := - if Byte.eqb b "0"%byte then PrimFloat.zero else PrimFloat.one. - Definition float_to_byte (f : float) : byte := - if PrimFloat.is_zero f then "0" else "1". - Definition to_byte_list '(mk_floatList a) := List.map float_to_byte a. - - Definition from_byte_list (xs : list byte) : floatList:= - mk_floatList (List.map float_from_byte xs). - - Declare Scope floatList_scope. - Delimit Scope floatList_scope with floatList. - - String Notation floatList from_byte_list to_byte_list : floatList_scope. - - Open Scope floatList_scope. - Import List.ListNotations. - Check mk_floatList [97; 0; 0]%float%list. - Check "100"%floatList. - - Definition float' := float. - Check mk_floatList (@cons float' 1 [0; 0])%float%list. -End Test4. - -Module Bug11237. - -Inductive bytes := wrap_bytes { unwrap_bytes : list byte }. - -Declare Scope bytes_scope. -Delimit Scope bytes_scope with bytes. -Bind Scope bytes_scope with bytes. -String Notation bytes wrap_bytes unwrap_bytes : bytes_scope. - -Open Scope bytes_scope. - -Example test_match := - match "foo" with - | "foo" => "bar" - | "bar" => "foo" - | x => x - end. - -End Bug11237. diff --git a/stdlib/test-suite/output/Unicode.out b/stdlib/test-suite/output/Unicode.out deleted file mode 100644 index abe6c39e8fbb..000000000000 --- a/stdlib/test-suite/output/Unicode.out +++ /dev/null @@ -1,41 +0,0 @@ -1 goal - - very_very_long_type_name1 : Type - very_very_long_type_name2 : Type - f : very_very_long_type_name1 ā†’ very_very_long_type_name2 ā†’ Prop - ============================ - True - ā†’ True - ā†’ āˆ€ (x : very_very_long_type_name1) (y : very_very_long_type_name2), - f x y āˆ§ f x y āˆ§ f x y āˆ§ f x y āˆ§ f x y āˆ§ f x y -1 goal - - very_very_long_type_name1 : Type - very_very_long_type_name2 : Type - f : very_very_long_type_name1 ā†’ very_very_long_type_name2 ā†’ Prop - ============================ - True - ā†’ True - ā†’ āˆ€ (x : very_very_long_type_name2) (y : very_very_long_type_name1) - (z : very_very_long_type_name2), f y x āˆ§ f y z -1 goal - - very_very_long_type_name1 : Type - very_very_long_type_name2 : Type - f : very_very_long_type_name1 ā†’ very_very_long_type_name2 ā†’ Prop - ============================ - True - ā†’ True - ā†’ āˆ€ (x : very_very_long_type_name2) (y : very_very_long_type_name1) - (z : very_very_long_type_name2), - f y x āˆ§ f y z āˆ§ f y x āˆ§ f y z āˆ§ f y x āˆ§ f y z -1 goal - - very_very_long_type_name1 : Type - very_very_long_type_name2 : Type - f : very_very_long_type_name1 ā†’ very_very_long_type_name2 ā†’ Prop - ============================ - True - ā†’ True - ā†’ āˆƒ (x : very_very_long_type_name1) (y : very_very_long_type_name2), - f x y āˆ§ f x y āˆ§ f x y āˆ§ f x y āˆ§ f x y āˆ§ f x y diff --git a/stdlib/test-suite/output/Unicode.v b/stdlib/test-suite/output/Unicode.v deleted file mode 100644 index 43bd8a506dee..000000000000 --- a/stdlib/test-suite/output/Unicode.v +++ /dev/null @@ -1,28 +0,0 @@ -From Stdlib Require Import Utf8. - -Section test. -Context (very_very_long_type_name1 : Type) (very_very_long_type_name2 : Type). -Context (f : very_very_long_type_name1 -> very_very_long_type_name2 -> Prop). - -Lemma test : True -> True -> - forall (x : very_very_long_type_name1) (y : very_very_long_type_name2), - f x y /\ f x y /\ f x y /\ f x y /\ f x y /\ f x y. -Proof. Show. Abort. - -Lemma test : True -> True -> - forall (x : very_very_long_type_name2) (y : very_very_long_type_name1) - (z : very_very_long_type_name2), - f y x /\ f y z. -Proof. Show. Abort. - -Lemma test : True -> True -> - forall (x : very_very_long_type_name2) (y : very_very_long_type_name1) - (z : very_very_long_type_name2), - f y x /\ f y z /\ f y x /\ f y z /\ f y x /\ f y z. -Proof. Show. Abort. - -Lemma test : True -> True -> - exists (x : very_very_long_type_name1) (y : very_very_long_type_name2), - f x y /\ f x y /\ f x y /\ f x y /\ f x y /\ f x y. -Proof. Show. Abort. -End test. diff --git a/stdlib/test-suite/output/ZNumberSyntax.out b/stdlib/test-suite/output/ZNumberSyntax.out deleted file mode 100644 index f2719ba76496..000000000000 --- a/stdlib/test-suite/output/ZNumberSyntax.out +++ /dev/null @@ -1,148 +0,0 @@ -32%Z - : Z -eq_refl : 42%Z = 42%Z - : 42%Z = 42%Z -fun f : nat -> Z => (f 0%nat + 0)%Z - : (nat -> Z) -> Z -fun x : positive => Z.pos x~0 - : positive -> Z -fun x : positive => (Z.pos x + 1)%Z - : positive -> Z -fun x : positive => Z.pos x - : positive -> Z -fun x : positive => Z.neg x~0 - : positive -> Z -fun x : positive => (Z.pos x~0 + 0)%Z - : positive -> Z -fun x : positive => (- Z.pos x~0)%Z - : positive -> Z -fun x : positive => (- Z.pos x~0 + 0)%Z - : positive -> Z -(Z.of_nat 0 + 1)%Z - : Z -(0 + Z.of_nat (0 + 0))%Z - : Z -Z.of_nat 0 = 0%Z - : Prop -0%Z - : Z -0%Z - : Z -1%Z - : Z -2%Z - : Z -255%Z - : Z -255%Z - : Z -(- 0)%Z - : Z -(- 0)%Z - : Z -(-1)%Z - : Z -(-2)%Z - : Z -(-255)%Z - : Z -(-255)%Z - : Z -0%Z - : Z -0%Z - : Z -1%Z - : Z -2%Z - : Z -255%Z - : Z -255%Z - : Z -(- 0)%Z - : Z -(- 0)%Z - : Z -(-1)%Z - : Z -(-2)%Z - : Z -(-255)%Z - : Z -(-255)%Z - : Z -0x2a - : Z --0x2a - : Z -0x0 - : Z -0x2a - : Z --0x2a - : Z -0x0 - : Z -0x0 - : Z -0x0 - : Z -0x1 - : Z -0x2 - : Z -0xff - : Z -0xff - : Z -(- 0)%Z - : Z -(- 0)%Z - : Z --0x1 - : Z --0x2 - : Z --0xff - : Z --0xff - : Z -0x0 - : Z -0x0 - : Z -0x1 - : Z -0x2 - : Z -0xff - : Z -0xff - : Z -0x0 - : Z -0x0 - : Z -0x1 - : Z -0x2 - : Z -0xff - : Z -0xff - : Z -(- 0)%Z - : Z -(- 0)%Z - : Z --0x1 - : Z --0x2 - : Z --0xff - : Z --0xff - : Z -(0 + Z.of_nat 11)%Z - : Z diff --git a/stdlib/test-suite/output/ZNumberSyntax.v b/stdlib/test-suite/output/ZNumberSyntax.v deleted file mode 100644 index 72ab1fecea95..000000000000 --- a/stdlib/test-suite/output/ZNumberSyntax.v +++ /dev/null @@ -1,82 +0,0 @@ -From Stdlib Require Import ZArith. -Check 32%Z. -Check (eq_refl : 0x2a%Z = 42%Z). -Check (fun f : nat -> Z => (f 0%nat + 0)%Z). -Check (fun x : positive => Zpos (xO x)). -Check (fun x : positive => (Zpos x + 1)%Z). -Check (fun x : positive => Zpos x). -Check (fun x : positive => Zneg (xO x)). -Check (fun x : positive => (Zpos (xO x) + 0)%Z). -Check (fun x : positive => (- Zpos (xO x))%Z). -Check (fun x : positive => (- Zpos (xO x) + 0)%Z). -Check (Z.of_nat 0 + 1)%Z. -Check (0 + Z.of_nat (0 + 0))%Z. -Check (Z.of_nat 0 = 0%Z). -Check 0x0%Z. -Check 0x00%Z. -Check 0x01%Z. -Check 0x02%Z. -Check 0xff%Z. -Check 0xFF%Z. -Check (-0x0)%Z. -Check (-0x00)%Z. -Check (-0x01)%Z. -Check (-0x02)%Z. -Check (-0xff)%Z. -Check (-0xFF)%Z. -Check 0x0%xZ. -Check 0x00%xZ. -Check 0x01%xZ. -Check 0x02%xZ. -Check 0xff%xZ. -Check 0xFF%xZ. -Check (-0x0)%xZ%Z. -Check (-0x00)%xZ%Z. -Check (-0x01)%xZ. -Check (-0x02)%xZ. -Check (-0xff)%xZ. -Check (-0xFF)%xZ. - -(* Check hexadecimal printing *) -Open Scope hex_Z_scope. -Check 42%Z. -Check (-42)%Z. -Check 0%Z. -Check 42%xZ. -Check (-42)%xZ. -Check 0%xZ. -Check 0x0%Z. -Check 0x00%Z. -Check 0x01%Z. -Check 0x02%Z. -Check 0xff%Z. -Check 0xFF%Z. -Check (-0x0)%Z. -Check (-0x00)%Z. -Check (-0x01)%Z. -Check (-0x02)%Z. -Check (-0xff)%Z. -Check (-0xFF)%Z. -Check 0x0. -Check 0x00. -Check 0x01. -Check 0x02. -Check 0xff. -Check 0xFF. -Check 0x0%xZ. -Check 0x00%xZ. -Check 0x01%xZ. -Check 0x02%xZ. -Check 0xff%xZ. -Check 0xFF%xZ. -Check (-0x0)%xZ%Z. -Check (-0x00)%xZ%Z. -Check (-0x01)%xZ. -Check (-0x02)%xZ. -Check (-0xff)%xZ. -Check (-0xFF)%xZ. -Close Scope hex_Z_scope. - -(* Submitted by Pierre Casteran *) -From Stdlib Require Import Arith. -Check (0 + Z.of_nat 11)%Z. diff --git a/stdlib/test-suite/output/allBytes.out b/stdlib/test-suite/output/allBytes.out deleted file mode 100644 index f4520e515955..000000000000 --- a/stdlib/test-suite/output/allBytes.out +++ /dev/null @@ -1,4 +0,0 @@ -File "./output/allBytes.v", line 23, characters 0-44: -Warning: Lonely notation "" was already defined with a different format. -[notation-incompatible-format,parsing,default] - !"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~ diff --git a/stdlib/test-suite/output/allBytes.v b/stdlib/test-suite/output/allBytes.v deleted file mode 100644 index 0dec0b8afeaa..000000000000 --- a/stdlib/test-suite/output/allBytes.v +++ /dev/null @@ -1,123 +0,0 @@ -(* Taken from bedrock2 *) - -(* Note: not an utf8 file *) -From Stdlib Require Import BinInt List. -From Stdlib.Init Require Byte. -From Stdlib.Strings Require Byte 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 ""). - -Set Warnings "-notation-incompatible-prefix". - -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, at level 0). -Notation "'.'" := (Byte.x2e) (only printing). -Notation "'/'" := (Byte.x2f) (only printing, at level 0). -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, at level 0). - -Global Set Printing Width 300. - -Goal False. - let cc := eval cbv in allBytes in idtac cc. -Abort. diff --git a/stdlib/test-suite/output/btauto_counterexample.out b/stdlib/test-suite/output/btauto_counterexample.out deleted file mode 100644 index 86360e2d76f2..000000000000 --- a/stdlib/test-suite/output/btauto_counterexample.out +++ /dev/null @@ -1,3 +0,0 @@ -File "./output/btauto_counterexample.v", line 12, characters 7-13: -The command has indeed failed with message: -Tactic failure: Not a tautology: [combine := true]. diff --git a/stdlib/test-suite/output/btauto_counterexample.v b/stdlib/test-suite/output/btauto_counterexample.v deleted file mode 100644 index d224579bfbdd..000000000000 --- a/stdlib/test-suite/output/btauto_counterexample.v +++ /dev/null @@ -1,13 +0,0 @@ - -From Stdlib Require Import Btauto. -Local Open Scope bool_scope. - -Axiom unsigned : bool. -Axiom combine : bool. - -Lemma foo - : (false && unsigned) || (false && combine) = - combine . -Proof. - Fail btauto. -Abort. diff --git a/stdlib/test-suite/output/bug_13942.out b/stdlib/test-suite/output/bug_13942.out deleted file mode 100644 index b6bb3a0c6edc..000000000000 --- a/stdlib/test-suite/output/bug_13942.out +++ /dev/null @@ -1,163 +0,0 @@ -File "./output/bug_13942.v", line 102, characters 2-34: -The command has indeed failed with message: -The following term contains unresolved implicit arguments: - (fi fu) -More precisely: -- ?A: Cannot infer the implicit parameter A of fi whose type is - "Type" in - environment: - K : Type - M : Type -> Type - H : FMap K M - A : Type - B : Type - i : Union (M A) - i' : Union (M B) - fi' : Insert K B (M B) -- ?hi: Cannot infer the implicit parameter hi of fi whose type is - "Insert K ?A (M ?A)" (no type class instance found) in - environment: - K : Type - M : Type -> Type - H : FMap K M - A : Type - B : Type - i : Union (M A) - i' : Union (M B) - fi' : Insert K B (M B) -- ?hu: Cannot infer the implicit parameter hu of fu whose type is - "Union (M ?A)" (no type class instance found) in - environment: - K : Type - M : Type -> Type - H : FMap K M - A : Type - B : Type - i : Union (M A) - i' : Union (M B) - fi' : Insert K B (M B) -File "./output/bug_13942.v", line 106, characters 2-39: -The command has indeed failed with message: -The following term contains unresolved implicit arguments: - (fi fu) -More precisely: -- ?hi: Cannot infer the implicit parameter hi of fi whose type is - "Insert K A (M A)" (no type class instance found) in - environment: - K : Type - M : Type -> Type - H : FMap K M - A : Type - B : Type - i : Union (M A) - i' : Union (M B) - fi' : Insert K B (M B) -File "./output/bug_13942.v", line 120, characters 2-34: -The command has indeed failed with message: -The following term contains unresolved implicit arguments: - (fi fu) -More precisely: -- ?A: Cannot infer the implicit parameter A of fi whose type is - "Type" in - environment: - K : Type - M : Type -> Type - H : FMap K M - A : Type - B : Type - i' : Union (M B) - fi' : Insert K B (M B) - i : Union (M A) -- ?hi: Cannot infer the implicit parameter hi of fi whose type is - "Insert K ?A (M ?A)" (no type class instance found) in - environment: - K : Type - M : Type -> Type - H : FMap K M - A : Type - B : Type - i' : Union (M B) - fi' : Insert K B (M B) - i : Union (M A) -- ?hu: Cannot infer the implicit parameter hu of fu whose type is - "Union (M ?A)" (no type class instance found) in - environment: - K : Type - M : Type -> Type - H : FMap K M - A : Type - B : Type - i' : Union (M B) - fi' : Insert K B (M B) - i : Union (M A) -File "./output/bug_13942.v", line 124, characters 2-40: -The command has indeed failed with message: -The following term contains unresolved implicit arguments: - (fi fu) -More precisely: -- ?hi: Cannot infer the implicit parameter hi of fi whose type is - "Insert K A (M A)" (no type class instance found) in - environment: - K : Type - M : Type -> Type - H : FMap K M - A : Type - B : Type - i' : Union (M B) - fi' : Insert K B (M B) - i : Union (M A) -File "./output/bug_13942.v", line 140, characters 2-20: -The command has indeed failed with message: -In environment: -K : Type -M : Type -> Type -H : FMap K M -A : Type -B : Type -ifalse : Choose false -> Union (M B) -itrue : Choose true -> Union (M B) -ib : Insert K B (M B) -i : Choose false -> Union (M A) -Could not find an instance for the following existential variables: -?hi : Insert K ?A (M ?A) - -?hu : Union (M ?A) -File "./output/bug_13942.v", line 145, characters 16-18: -The command has indeed failed with message: -Could not find an instance for "Union (M B)" in -environment: -K : Type -M : Type -> Type -H : FMap K M -A : Type -B : Type -ifalse : Choose false -> Union (M B) -itrue : Choose true -> Union (M B) -ib : Insert K B (M B) -i : Choose false -> Union (M A) - -fi fu : B - : B -File "./output/bug_13942.v", line 307, characters 20-31: -The command has indeed failed with message: -Could not find an instance for "Insert K K (M A)" in -environment: -K : Type -M : Type ā†’ Type -H : FMap M -H0 : āˆ€ A : Type, Lookup K A (M A) -Empty : Type ā†’ Type -H1 : āˆ€ A : Type, Empty (M A) -H2 : āˆ€ A : Type, PartialAlter K A (M A) -OMap : (Type ā†’ Type) ā†’ Type -OMap0 : OMap M -H3 : Merge M -H4 : āˆ€ A : Type, FinMapToList K A (M A) -EqDecision : Type ā†’ Type -EqDecision0 : EqDecision K -H5 : FinMap K M -A : Type -m1, m2 : M A -i : K -x : A - diff --git a/stdlib/test-suite/output/bug_13942.v b/stdlib/test-suite/output/bug_13942.v deleted file mode 100644 index f22beb0381f5..000000000000 --- a/stdlib/test-suite/output/bug_13942.v +++ /dev/null @@ -1,314 +0,0 @@ - -Set Warnings "-deprecated". - -Module Backtrack. - Class A (T : Type). - (* Global Hint Mode A + : typeclass_instances. *) - Class B (T T' : Type) := b : T'. - (* Global Hint Mode B - + : typeclass_instances. *) - - Instance anat : A nat := {}. - Instance abool : A bool := {}. - Instance bnatnat : B nat nat := { b := 0 }. - - Definition foo {T'} {T} {a : A T'} {b : B T' T} : T := b. - - (* This relies on backtracking: we first solve - A ? with abool (most recent decl), the find out that B bool _ - is not solvable and backtrack, find anat and finally solve B. - *) - Definition test := (foo : nat). - - (* This forces a different resolution path, where A ? is stuck at first, - then we solve B's constraint, and we come back to A nat which is solvable. - *) - Global Hint Mode A + : typeclass_instances. - - Definition test' := (foo : nat). - -End Backtrack. - - -Module Minimized. - Class Insert (K V M : Type) : Prop. - Global Hint Mode Insert - - + : typeclass_instances. - Class Lookup (K A M : Type) : Prop. - Global Hint Mode Lookup - - ! : typeclass_instances. - - Class Union (A : Type) : Prop. - Global Hint Mode Union ! : typeclass_instances. - Class FMap (K : Type) (M : Type -> Type) : Prop. - - Section Foo. - Context K M `{FMap K M}. - Context {A B : Type}. - Axiom fi : forall {A} {hi : Insert K A (M A)}, A -> A. - Axiom fu : forall {A} {hu : Union (M A)}, A. - - Section OrderOne. - Context {i : Union (M A)}. - Context {i' : Union (M B)}. - Context {fi' : Insert K B (M B)}. - - (** Succees because Union has mode !, so (M _) is enough to trigger - i', and then fi'. Union should probably be using + to avoid ambiguities. - *) - Definition test := (fi fu). - End OrderOne. - - (* We check here that typeclass resolution backtracks correctly when reporting - errors and does not follow modes too eagerly. *) - Section OrderTwo. - Context {i' : Union (M B)}. - Context {fi' : Insert K B (M B)}. - Context {i : Union (M A)}. - - (** Here we get two constraints, first is [Insert K ?A (M ?A)], second is [Union (M ?A)]. - The first is stuck so we proceed on the second one, which has two solutions. - The i / M A is chosen first, but it has no insert instance, - so we backtrack on this first solution to find i', even if i respected the mode - of Union (just !). *) - Definition test' := (fi fu). - End OrderTwo. - End Foo. -End Minimized. - -Module Minimized'. - Class Insert (K V M : Type) : Prop. - Global Hint Mode Insert - - + : typeclass_instances. - Class Lookup (K A M : Type) : Prop. - Global Hint Mode Lookup - - + : typeclass_instances. - - Class Union (A : Type) : Prop. - Global Hint Mode Union + : typeclass_instances. - Class FMap (K : Type) (M : Type -> Type) : Prop. - - Section Foo. - Context K M `{FMap K M}. - Context {A B : Type}. - Axiom fi : forall {A} {hi : Insert K A (M A)}, A -> A. - Axiom fu : forall {A} {hu : Union (M A)}, A. - Axiom fu' : forall {A} {hu : Union (M A)}, A -> A. - Axiom fi' : forall {A} {hi : Insert K A (M A)}, A. - - Section OrderOne. - Context {i : Union (M A)}. - Context {i' : Union (M B)}. - Context {fi' : Insert K B (M B)}. - - (** Fail because Union has now mode +, so (M _) is not enough to trigger - i' and fi'. So we get a general type error - *) - Fail Definition test := (fi fu). - - (** Here we get the precise missing Insert instance when A is chosen: *) - - Fail Definition test' : A := (fi fu). - - (** Of course the unambiguous querry works *) - Definition test : B := (fi fu). - - End OrderOne. - - Section OrderTwo. - Context {i' : Union (M B)}. - Context {fi' : Insert K B (M B)}. - Context {i : Union (M A)}. - - (** Here this fails because this is entirely ambiguous: it cannot decide - even on the A type. *) - Fail Definition test := (fi fu). - Definition test' : B := (fi fu). - - (** Here we get the precise missing instance when A is chosen: *) - Fail Definition test'' : A := (fi fu). - - End OrderTwo. - - (** There can still be internal backtracking: here - we check that if the union instance depends on another - class we get the right behavior.*) - Section OrderThree. - Class Choose (b : bool). - Context {ifalse : Choose false -> Union (M B)}. - Context {itrue : Choose true -> Union (M B)}. - Context {ib : Insert K B (M B)}. - Context {i : Choose false -> Union (M A)}. - - (** Here this fails because this is entirely ambiguous: it cannot decide - even on the A type. *) - Fail Type (fi fu). - - (** Here we commit to B, but neither ifalse nor itrue applies, so - Union (M B) is reported as unsolvable. - *) - Fail Type (fi fu : B). - - Context {ct : Choose false}. - (** Here we can find ifalse to get Union (M B), after backtracking - on the failing application of itrue (which last declared instance) - *) - Type (fi fu : B). - - End OrderThree. - End Foo. - - -End Minimized'. - -From Stdlib Require Export Morphisms RelationClasses List Bool Setoid Peano Utf8. -From Stdlib Require Import Permutation. -Export ListNotations. -From Stdlib.Program Require Export Basics Syntax. - -Module Import base. -Global Generalizable All Variables. -Obligation Tactic := idtac. - -(** Throughout this development we use [stdpp_scope] for all general purpose -notations that do not belong to a more specific scope. *) -Declare Scope stdpp_scope. -Delimit Scope stdpp_scope with stdpp. -Global Open Scope stdpp_scope. - -Class Union A := union: A ā†’ A ā†’ A. -Global Hint Mode Union ! : typeclass_instances. -Instance: Params (@union) 2 := {}. -Infix "āˆŖ" := union (at level 50, left associativity) : stdpp_scope. - -Class ElemOf A B := elem_of: A ā†’ B ā†’ Prop. -Global Hint Mode ElemOf - ! : typeclass_instances. -Instance: Params (@elem_of) 3 := {}. -Infix "āˆˆ" := elem_of (at level 70) : stdpp_scope. - -Class FMap (M : Type ā†’ Type) := fmap : āˆ€ {A B}, (A ā†’ B) ā†’ M A ā†’ M B. -Global Arguments fmap {_ _ _ _} _ !_ / : assert. -Instance: Params (@fmap) 4 := {}. -Infix "<$>" := fmap (at level 61, left associativity) : stdpp_scope. - -(** * Operations on maps *) -(** In this section we define operational type classes for the operations -on maps. In the file [fin_maps] we will axiomatize finite maps. -The function look up [m !! k] should yield the element at key [k] in [m]. *) -Class Lookup (K A M : Type) := lookup: K ā†’ M ā†’ option A. -Global Hint Mode Lookup - - ! : typeclass_instances. -Instance: Params (@lookup) 4 := {}. -Notation "m !! i" := (lookup i m) (at level 20) : stdpp_scope. -Global Arguments lookup _ _ _ _ !_ !_ / : simpl nomatch, assert. - -(** The function insert [<[k:=a]>m] should update the element at key [k] with -value [a] in [m]. *) -Class Insert (K A M : Type) := insert: K ā†’ A ā†’ M ā†’ M. -Global Hint Mode Insert - - ! : typeclass_instances. -Instance: Params (@insert) 5 := {}. -Notation "<[ k := a ]>" := (insert k a) - (at level 5, right associativity, format "<[ k := a ]>") : stdpp_scope. -Global Arguments insert _ _ _ _ !_ _ !_ / : simpl nomatch, assert. - -(** The function delete [delete k m] should delete the value at key [k] in -[m]. If the key [k] is not a member of [m], the original map should be -returned. *) -Class Delete (K M : Type) := delete: K ā†’ M ā†’ M. -Global Hint Mode Delete - ! : typeclass_instances. -Instance: Params (@delete) 4 := {}. -Global Arguments delete _ _ _ !_ !_ / : simpl nomatch, assert. - -(** The function [partial_alter f k m] should update the value at key [k] using the -function [f], which is called with the original value at key [k] or [None] -if [k] is not a member of [m]. The value at [k] should be deleted if [f] -yields [None]. *) -Class PartialAlter (K A M : Type) := - partial_alter: (option A ā†’ option A) ā†’ K ā†’ M ā†’ M. -Global Hint Mode PartialAlter - - ! : typeclass_instances. -Instance: Params (@partial_alter) 4 := {}. -Global Arguments partial_alter _ _ _ _ _ !_ !_ / : simpl nomatch, assert. - -(** The function [merge f m1 m2] should merge the maps [m1] and [m2] by -constructing a new map whose value at key [k] is [f (m1 !! k) (m2 !! k)].*) -Class Merge (M : Type ā†’ Type) := - merge: āˆ€ {A B C}, (option A ā†’ option B ā†’ option C) ā†’ M A ā†’ M B ā†’ M C. -Global Hint Mode Merge ! : typeclass_instances. -Instance: Params (@merge) 4 := {}. -Global Arguments merge _ _ _ _ _ _ !_ !_ / : simpl nomatch, assert. - -(** The function [union_with f m1 m2] is supposed to yield the union of [m1] -and [m2] using the function [f] to combine values of members that are in -both [m1] and [m2]. *) -Class UnionWith (A M : Type) := - union_with: (A ā†’ A ā†’ option A) ā†’ M ā†’ M ā†’ M. -Global Hint Mode UnionWith - ! : typeclass_instances. -Instance: Params (@union_with) 3 := {}. -Global Arguments union_with {_ _ _} _ !_ !_ / : simpl nomatch, assert. - -(** We redefine the standard library's [In] and [NoDup] using type classes. *) -Inductive elem_of_list {A} : ElemOf A (list A) := - | elem_of_list_here (x : A) l : x āˆˆ x :: l - | elem_of_list_further (x y : A) l : x āˆˆ l ā†’ x āˆˆ y :: l. -Existing Instance elem_of_list. - -End base. - -(** * Monadic operations *) -Global Instance option_fmap: FMap option := @option_map. - -Global Instance option_union_with {A} : UnionWith A (option A) := Ī» f mx my, - match mx, my with - | Some x, Some y => f x y - | Some x, None => Some x - | None, Some y => Some y - | None, None => None - end. -Global Instance option_union {A} : Union (option A) := union_with (Ī» x _, Some x). - -Unset Default Proof Using. - -Class FinMapToList K A M := map_to_list: M ā†’ list (K * A). -Global Hint Mode FinMapToList ! - - : typeclass_instances. -Global Hint Mode FinMapToList - - ! : typeclass_instances. - -Class FinMap K M `{FMap M, āˆ€ A, Lookup K A (M A), āˆ€ A, Empty (M A), āˆ€ A, - PartialAlter K A (M A), OMap M, Merge M, āˆ€ A, FinMapToList K A (M A), - EqDecision K} := { - map_eq {A} (m1 m2 : M A) : (āˆ€ i, m1 !! i = m2 !! i) ā†’ m1 = m2; - lookup_partial_alter {A} f (m : M A) i : - partial_alter f i m !! i = f (m !! i); - lookup_partial_alter_ne {A} f (m : M A) i j : - i ā‰  j ā†’ partial_alter f i m !! j = m !! j; - lookup_fmap {A B} (f : A ā†’ B) (m : M A) i : (f <$> m) !! i = f <$> m !! i; - NoDup_map_to_list {A} (m : M A) : NoDup (map_to_list m); - elem_of_map_to_list {A} (m : M A) i x : - (i,x) āˆˆ map_to_list m ā†” m !! i = Some x; - lookup_merge {A B C} (f : option A ā†’ option B ā†’ option C) - `{!DiagNone f} (m1 : M A) (m2 : M B) i : - merge f m1 m2 !! i = f (m1 !! i) (m2 !! i) -}. - -(** * Derived operations *) -(** All of the following functions are defined in a generic way for arbitrary -finite map implementations. These generic implementations do not cause a -significant performance loss, which justifies including them in the finite map -interface as primitive operations. *) -Global Instance map_insert `{PartialAlter K A M} : Insert K A M := - Ī» i x, partial_alter (Ī» _, Some x) i. -Global Instance map_delete `{PartialAlter K A M} : Delete K M := - partial_alter (Ī» _, None). - -Global Instance map_union_with `{Merge M} {A} : UnionWith A (M A) := - Ī» f, merge (union_with f). -Global Instance map_union `{Merge M} {A} : Union (M A) := union_with (Ī» x _, Some x). - -(** * Theorems *) -Section theorems. - Context `{FinMap K M}. - - (** Just the Insert instance is missing, as we've commited on (M A) *) - Fail Lemma union_delete_insert {A} (m1 m2 : M A) i x : - m1 !! i = Some x ā†’ - delete i m1 āˆŖ <[i:=i]> m2 = m1 āˆŖ m2. - - Lemma union_delete_insert {A} (m1 m2 : M A) i x : - m1 !! i = Some x ā†’ - delete i m1 āˆŖ <[i:=x]> m2 = m1 āˆŖ m2. - Proof. Abort. - -End theorems. diff --git a/stdlib/test-suite/output/bug_15709.out b/stdlib/test-suite/output/bug_15709.out deleted file mode 100644 index 55352e765c6b..000000000000 --- a/stdlib/test-suite/output/bug_15709.out +++ /dev/null @@ -1,2 +0,0 @@ -String "]" - : string -> string diff --git a/stdlib/test-suite/output/bug_15709.v b/stdlib/test-suite/output/bug_15709.v deleted file mode 100644 index 7eb5679a73de..000000000000 --- a/stdlib/test-suite/output/bug_15709.v +++ /dev/null @@ -1,4 +0,0 @@ -From Stdlib Require Import String. -From Stdlib Require Import Ascii. - -Check String "]". diff --git a/stdlib/test-suite/output/bug_19702.out b/stdlib/test-suite/output/bug_19702.out deleted file mode 100644 index f2fc675f8fd8..000000000000 --- a/stdlib/test-suite/output/bug_19702.out +++ /dev/null @@ -1,21 +0,0 @@ -f1 : āˆ€ {n1 : nat} (n2 : nat), T n2 ā†’ T n1 - -f1 is not universe polymorphic -Arguments f1 {n1}%nat_scope n2%nat_scope w -f1 is transparent -Expands to: Constant bug_19702.f1 -Declared in library bug_19702, line 6, characters 11-13 -f1 : āˆ€ {n1 : nat} [n2 : nat], T n2 ā†’ T n1 - -f1 is not universe polymorphic -Arguments f1 {n1}%nat_scope [n2]%nat_scope w -f1 is transparent -Expands to: Constant bug_19702.f1 -Declared in library bug_19702, line 6, characters 11-13 -f1 : āˆ€ {n1 n2 : nat}, T n2 ā†’ T n1 - -f1 is not universe polymorphic -Arguments f1 {n1 n2}%nat_scope w -f1 is transparent -Expands to: Constant bug_19702.f1 -Declared in library bug_19702, line 6, characters 11-13 diff --git a/stdlib/test-suite/output/bug_19702.v b/stdlib/test-suite/output/bug_19702.v deleted file mode 100644 index e6711bceef4f..000000000000 --- a/stdlib/test-suite/output/bug_19702.v +++ /dev/null @@ -1,30 +0,0 @@ -From Stdlib Require Import Utf8. - -Axiom T : nat -> Type. -Axiom default : forall n, T n. - -Definition f1 {n1} n2 (w : T n2) := default n1. -About f1. -(* -f1 : āˆ€ n1 n2 : nat, T n2 ā†’ T n1 // wrong - -f1 is not universe polymorphic -Arguments f1 {n1}%nat_scope n2%nat_scope w // correct -f1 is transparent -Expands to: Constant Top.f1 -*) - - -Arguments f1 {_} [_]. -About f1. -(* -f1 : āˆ€ [n1 n2 : nat], T n2 ā†’ T n1 // wrong - -f1 is not universe polymorphic -Arguments f1 {n1}%nat_scope [n2]%nat_scope w // correct -f1 is transparent -Expands to: Constant Top.f1 -*) - -Arguments f1 {_ _}. -About f1. diff --git a/stdlib/test-suite/output/bug_9370.out b/stdlib/test-suite/output/bug_9370.out deleted file mode 100644 index 8d34b7143aad..000000000000 --- a/stdlib/test-suite/output/bug_9370.out +++ /dev/null @@ -1,12 +0,0 @@ -1 goal - - ============================ - 1 = 1 -1 goal - - ============================ - 1 = 1 -1 goal - - ============================ - 1 = 1 diff --git a/stdlib/test-suite/output/bug_9370.v b/stdlib/test-suite/output/bug_9370.v deleted file mode 100644 index d11ba45a2c8c..000000000000 --- a/stdlib/test-suite/output/bug_9370.v +++ /dev/null @@ -1,12 +0,0 @@ -From Stdlib Require Import Reals. -Open Scope R_scope. -Goal 1/1=1. -Proof. - field_simplify (1/1). -Show. - field_simplify. -Show. - field_simplify. -Show. - reflexivity. -Qed. diff --git a/stdlib/test-suite/output/primitive_tokens_string.out b/stdlib/test-suite/output/primitive_tokens_string.out deleted file mode 100644 index 152e2c3e6f41..000000000000 --- a/stdlib/test-suite/output/primitive_tokens_string.out +++ /dev/null @@ -1,21 +0,0 @@ -"foo" - : string -match "a" with -| "a" => true -| _ => false -end - : bool -String (Ascii.Ascii false true true false false true true false) - (String (Ascii.Ascii true true true true false true true false) - (String (Ascii.Ascii true true true true false true true false) - EmptyString)) - : string -match - String (Ascii.Ascii true false false false false true true false) - EmptyString -with -| String (Ascii.Ascii true false false false false true true false) - EmptyString => true -| _ => false -end - : bool diff --git a/stdlib/test-suite/output/primitive_tokens_string.v b/stdlib/test-suite/output/primitive_tokens_string.v deleted file mode 100644 index 6a50a80dc3ef..000000000000 --- a/stdlib/test-suite/output/primitive_tokens_string.v +++ /dev/null @@ -1,13 +0,0 @@ -From Stdlib Require Import String. - -Open Scope string_scope. - -Unset Printing Notations. - -Check "foo". -Check match "a" with "a" => true | _ => false end. - -Set Printing Raw Literals. - -Check "foo". -Check match "a" with "a" => true | _ => false end. diff --git a/stdlib/test-suite/output/simpl.out b/stdlib/test-suite/output/simpl.out deleted file mode 100644 index 174282c91b19..000000000000 --- a/stdlib/test-suite/output/simpl.out +++ /dev/null @@ -1,443 +0,0 @@ -1 goal - - x : nat - ============================ - x = S x -1 goal - - x : nat - ============================ - 0 + x = S x -1 goal - - x : nat - ============================ - x = 1 + x -"** NonRecursiveDefinition" - : string - = true - : bool - = true - : bool - = true - : bool - = true && true - : bool - = true && true - : bool - = true - : bool -"** RecursiveDefinition" - : string - = 0 - : nat - = 0 - : nat - = 0 - : nat - = 0 + 0 - : nat - = 0 + 0 - : nat - = 0 - : nat -"** NonPrimitiveProjection" - : string -"DirectTuple (NonPrimitiveProjection)" - : string - = 0 - : nat - = 0 - : nat - = 0 - : nat - = TUPLE.(p) - : nat - = TUPLE.(p) - : nat - = 0 - : nat -"NamedTuple (NonPrimitiveProjection)" - : string - = 0 - : nat - = 0 - : nat - = 0 - : nat - = a.(p) - : nat - = a.(p) - : nat - = 0 - : nat - = 0 - : nat - = a.(p) - : nat - = 0 - : nat -"DirectCoFix (NonPrimitiveProjection)" - : string - = COFIX - : U - = COFIX - : U - = COFIX - : U - = COFIX.(p) - : U - = COFIX.(p) - : U - = COFIX - : U -"NamedCoFix (NonPrimitiveProjection)" - : string - = a - : U - = a - : U - = a - : U - = a.(p) - : U - = a.(p) - : U - = a - : U - = a - : U - = a.(p) - : U - = a - : U -"** PrimitiveProjectionFolded" - : string -"DirectTuple (PrimitiveProjectionFolded)" - : string - = 0 - : nat - = 0 - : nat - = 0 - : nat - = TUPLE.(p) - : nat - = TUPLE.(p) - : nat - = 0 - : nat -"NamedTuple (PrimitiveProjectionFolded)" - : string - = 0 - : nat - = 0 - : nat - = 0 - : nat - = a.(p) - : nat - = a.(p) - : nat - = 0 - : nat - = 0 - : nat - = a.(p) - : nat - = 0 - : nat -"DirectCoFix (PrimitiveProjectionFolded)" - : string - = COFIX - : U - = COFIX - : U - = COFIX - : U - = COFIX.(p) - : U - = COFIX.(p) - : U - = COFIX - : U -"NamedCoFix (PrimitiveProjectionFolded)" - : string - = a - : U - = a - : U - = a - : U - = a.(p) - : U - = a.(p) - : U - = a - : U - = a - : U - = a.(p) - : U - = a - : U -"** PrimitiveProjectionUnfolded" - : string -"DirectTuple (PrimitiveProjectionUnfolded)" - : string -1 goal - - ============================ - P 0 -1 goal - - ============================ - P 0 -1 goal - - ============================ - P 0 -1 goal - - ============================ - P 0 -1 goal - - ============================ - P {| p := 0 |}.(p) -1 goal - - ============================ - P 0 -"NamedTuple (PrimitiveProjectionUnfolded)" - : string -1 goal - - ============================ - P 0 -1 goal - - ============================ - P 0 -1 goal - - ============================ - P a.(p) -1 goal - - ============================ - P 0 -1 goal - - ============================ - P a.(p) -1 goal - - ============================ - P a.(p) -1 goal - - ============================ - P 0 -1 goal - - ============================ - P a.(p) -1 goal - - ============================ - P a.(p) -"DirectCoFix (PrimitiveProjectionUnfolded)" - : string -1 goal - - ============================ - P COFIX -1 goal - - ============================ - P COFIX -1 goal - - ============================ - P COFIX -1 goal - - ============================ - P COFIX -1 goal - - ============================ - P COFIX.(q) -1 goal - - ============================ - P COFIX -"NamedCoFix (PrimitiveProjectionUnfolded)" - : string -1 goal - - ============================ - P a -1 goal - - ============================ - P a -1 goal - - ============================ - P a.(q) -1 goal - - ============================ - P a -1 goal - - ============================ - P a.(q) -1 goal - - ============================ - P a.(q) -1 goal - - ============================ - P a -1 goal - - ============================ - P a.(q) -1 goal - - ============================ - P a.(q) -"** PrimitiveProjectionConstant" - : string -"DirectTuple (PrimitiveProjectionConstant)" - : string -1 goal - - ============================ - P 0 -1 goal - - ============================ - P 0 -1 goal - - ============================ - P TUPLE.(p) -1 goal - - ============================ - P TUPLE.(p) -1 goal - - ============================ - P TUPLE.(p) -1 goal - - ============================ - P TUPLE.(p) -"NamedTuple (PrimitiveProjectionConstant)" - : string -1 goal - - ============================ - P 0 -1 goal - - ============================ - P 0 -1 goal - - ============================ - P a.(p) -1 goal - - ============================ - P a.(p) -1 goal - - ============================ - P a.(p) -1 goal - - ============================ - P a.(p) -1 goal - - ============================ - P 0 -1 goal - - ============================ - P a.(p) -1 goal - - ============================ - P a.(p) -"DirectCoFix (PrimitiveProjectionConstant)" - : string -1 goal - - ============================ - P COFIX -1 goal - - ============================ - P COFIX -1 goal - - ============================ - P COFIX.(q) -1 goal - - ============================ - P COFIX.(q) -1 goal - - ============================ - P COFIX.(q) -1 goal - - ============================ - P COFIX.(q) -"NamedCoFix (PrimitiveProjectionConstant)" - : string -1 goal - - ============================ - P a -1 goal - - ============================ - P a -1 goal - - ============================ - P a.(q) -1 goal - - ============================ - P a.(q) -1 goal - - ============================ - P a.(q) -1 goal - - ============================ - P a.(q) -1 goal - - ============================ - P a -1 goal - - ============================ - P a.(q) -1 goal - - ============================ - P a.(q) diff --git a/stdlib/test-suite/output/simpl.v b/stdlib/test-suite/output/simpl.v deleted file mode 100644 index c5a9570d1edf..000000000000 --- a/stdlib/test-suite/output/simpl.v +++ /dev/null @@ -1,320 +0,0 @@ -(* Simpl with patterns *) - -Goal forall x, 0+x = 1+x. -intro x. -simpl (_ + x). -Show. -change (0+x = 1+x). -simpl (_ + x) at 2. -Show. -change (0+x = 1+x). -simpl (0 + _). -Show. -Abort. - -From Stdlib Require Import String. -Open Scope string_scope. -Module NonRecursiveDefinition. -Check "** NonRecursiveDefinition". -Open Scope bool_scope. -Eval simpl in true && true. (* -> true *) -Eval cbn in true && true. (* -> true *) -Eval hnf in true && true. (* -> true *) -Arguments andb : simpl never. -Eval simpl in true && true. (* -> true && true *) -Eval cbn in true && true. (* -> true && true *) -Eval hnf in true && true. (* -> true *) -End NonRecursiveDefinition. - -Module RecursiveDefinition. -Check "** RecursiveDefinition". -Eval simpl in 0 + 0. (* -> 0 *) -Eval cbn in 0 + 0. (* -> 0 *) -Eval hnf in 0 + 0. (* -> 0 *) -Arguments Nat.add : simpl never. -Eval simpl in 0 + 0. (* -> 0 + 0 *) -Eval cbn in 0 + 0. (* -> 0 + 0 *) -Eval hnf in 0 + 0. (* -> 0 + 0 *) (* hnf modified by simpl never, bug never 2 *) -End RecursiveDefinition. - -Set Printing Projections. - -Module NonPrimitiveProjection. -Check "** NonPrimitiveProjection". -Module DirectTuple. -Check "DirectTuple (NonPrimitiveProjection)". -Record T := {p:nat}. -Notation TUPLE := {|p:=0|}. -Eval simpl in TUPLE.(p). (* -> 0 *) -Eval cbn in TUPLE.(p). (* -> 0 *) -Eval hnf in TUPLE.(p). (* -> 0 *) -Arguments p : simpl never. -Eval simpl in TUPLE.(p). (* -> TUPLE.(p) *) -Eval cbn in TUPLE.(p). (* -> TUPLE.(p) *) -Eval hnf in TUPLE.(p). (* -> 0 *) -End DirectTuple. - -Module NamedTuple. -Check "NamedTuple (NonPrimitiveProjection)". -Record T := {p:nat}. -Definition a := {|p:=0|}. -Eval simpl in a.(p). (* -> 0 *) -Eval cbn in a.(p). (* -> 0 *) -Eval hnf in a.(p). (* -> 0 *) -Arguments p : simpl never. -Eval simpl in a.(p). (* -> a.(p) *) -Eval cbn in a.(p). (* -> a.(p) *) -Eval hnf in a.(p). (* -> 0 *) -Arguments p : simpl nomatch. -Arguments a : simpl never. -Eval simpl in a.(p). (* -> 0 *) (* never not respected on purpose [*] *) -Eval cbn in a.(p). (* -> a.(p) *) -Eval hnf in a.(p). (* -> 0 *) -End NamedTuple. -(* [*] Enrico: https://github.com/coq/coq/pull/18581#issuecomment-1914325999 *) - -Module DirectCoFix. -Check "DirectCoFix (NonPrimitiveProjection)". -CoInductive U := {p:U}. -Notation COFIX := (cofix a := {|p:=a|}). -Eval simpl in COFIX.(p). (* -> COFIX *) -Eval cbn in COFIX.(p). (* -> COFIX *) -Eval hnf in COFIX.(p). (* -> COFIX *) -Arguments p : simpl never. -Eval simpl in COFIX.(p). (* -> COFIX.(p) *) -Eval cbn in COFIX.(p). (* -> COFIX.(p) *) -Eval hnf in COFIX.(p). (* -> COFIX *) -End DirectCoFix. - -Module NamedCoFix. -Check "NamedCoFix (NonPrimitiveProjection)". -CoInductive U := {p:U}. -CoFixpoint a := {|p:=a|}. -Eval simpl in a.(p). (* -> a *) -Eval cbn in a.(p). (* -> a *) -Eval hnf in a.(p). (* -> a *) -Arguments p : simpl never. -Eval simpl in a.(p). (* -> a.(p) *) -Eval cbn in a.(p). (* -> a.(p) *) -Eval hnf in a.(p). (* -> a *) -Arguments p : simpl nomatch. -Arguments a : simpl never. -Eval simpl in a.(p). (* -> a *) (* never not respected on purpose *) -Eval cbn in a.(p). (* -> a.(p) *) -Eval hnf in a.(p). (* -> a *) -End NamedCoFix. -End NonPrimitiveProjection. - -Module PrimitiveProjectionFolded. -Check "** PrimitiveProjectionFolded". -Set Primitive Projections. - -Module DirectTuple. -Check "DirectTuple (PrimitiveProjectionFolded)". -Record T := {p:nat}. -Notation TUPLE := {|p:=0|}. -Eval simpl in TUPLE.(p). (* -> 0 *) -Eval cbn in TUPLE.(p). (* -> 0 *) -Eval hnf in TUPLE.(p). (* -> 0 *) -Arguments p : simpl never. -Eval simpl in TUPLE.(p). (* -> TUPLE.(p) *) -Eval cbn in TUPLE.(p). (* -> TUPLE.(p) *) -Eval hnf in TUPLE.(p). (* -> 0 *) -End DirectTuple. - -Module NamedTuple. -Check "NamedTuple (PrimitiveProjectionFolded)". -Record T := {p:nat}. -Definition a := {|p:=0|}. -Eval simpl in a.(p). (* -> 0 *) -Eval cbn in a.(p). (* -> 0 *) -Eval hnf in a.(p). (* -> 0 *) -Arguments p : simpl never. -Eval simpl in a.(p). (* -> a.(p) *) -Eval cbn in a.(p). (* -> a.(p) *) -Eval hnf in a.(p). (* -> 0 *) -Arguments p : simpl nomatch. -Arguments a : simpl never. -Eval simpl in a.(p). (* -> ) *) (* never not respected on purpose *) -Eval cbn in a.(p). (* -> a.(p) *) -Eval hnf in a.(p). (* -> 0 *) -End NamedTuple. - -Module DirectCoFix. -Check "DirectCoFix (PrimitiveProjectionFolded)". -CoInductive U := {p:U}. -Notation COFIX := (cofix a := {|p:=a|}). -Eval simpl in COFIX.(p). (* -> COFIX *) -Eval cbn in COFIX.(p). (* -> COFIX *) -Eval hnf in COFIX.(p). (* -> COFIX *) -Arguments p : simpl never. -Eval simpl in COFIX.(p). (* -> COFIX.(p) *) -Eval cbn in COFIX.(p). (* -> COFIX.(p) *) -Eval hnf in COFIX.(p). (* -> COFIX *) -End DirectCoFix. - -Module NamedCoFix. -Check "NamedCoFix (PrimitiveProjectionFolded)". -CoInductive U := {p:U}. -CoFixpoint a := {|p:=a|}. -Eval simpl in a.(p). (* -> a *) -Eval cbn in a.(p). (* -> a *) -Eval hnf in a.(p). (* -> a *) -Arguments p : simpl never. -Eval simpl in a.(p). (* -> a.(p) *) -Eval cbn in a.(p). (* -> a.(p) *) -Eval hnf in a.(p). (* -> a *) -Arguments p : simpl nomatch. -Arguments a : simpl never. -Eval simpl in a.(p). (* -> a *) (* never not respected on purpose *) -Eval cbn in a.(p). (* -> a.(p) *) -Eval hnf in a.(p). (* -> a *) -End NamedCoFix. -End PrimitiveProjectionFolded. - -Module PrimitiveProjectionUnfolded. -Check "** PrimitiveProjectionUnfolded". -(* we use an unfold trick to create an unfolded projection *) -Set Primitive Projections. - -Module DirectTuple. -Check "DirectTuple (PrimitiveProjectionUnfolded)". -Record T := {p:nat}. -Definition a := {|p:=0|}. -Axiom P : nat -> Prop. -Goal P a.(p). unfold p. cbv delta [a]. simpl. Show. Abort. (* -> 0 *) -Goal P a.(p). unfold p. cbv delta [a]. cbn. Show. Abort. (* -> 0 *) -Goal P a.(p). unfold p. cbv delta [a]. hnf. Show. Abort. (* -> 0 *) -Arguments p : simpl never. -Goal P a.(p). unfold p. cbv delta [a]. simpl. Show. Abort. (* -> 0 *) (* bug never 3 *) -Goal P a.(p). unfold p. cbv delta [a]. cbn. Show. Abort. (* -> {| p := 0 |}.(p) *) -Goal P a.(p). unfold p. cbv delta [a]. hnf. Show. Abort. (* -> 0 *) -End DirectTuple. - -Module NamedTuple. -Check "NamedTuple (PrimitiveProjectionUnfolded)". -Record T := {p:nat}. -Definition a := {|p:=0|}. -Axiom P : nat -> Prop. -Goal P a.(p). unfold p. simpl. Show. Abort. (* -> 0 *) -Goal P a.(p). unfold p. cbn. Show. Abort. (* -> 0 *) -Goal P a.(p). unfold p. hnf. Show. Abort. (* -> a.(p) *) (* bug primproj 2 *) -Arguments p : simpl never. -Goal P a.(p). unfold p. simpl. Show. Abort. (* -> 0 *) (* bug never 3 *) -Goal P a.(p). unfold p. cbn. Show. Abort. (* -> a.(p) *) -Goal P a.(p). unfold p. hnf. Show. Abort. (* -> a.(p) *) (* bug primproj 2 *) -Arguments p : simpl nomatch. -Arguments a : simpl never. -Goal P a.(p). unfold p. simpl. Show. Abort. (* -> 0 *) (* bug never 1 *) -Goal P a.(p). unfold p. cbn. Show. Abort. (* -> a.(p) *) -Goal P a.(p). unfold p. hnf. Show. Abort. (* -> a.(p) *) (* bug primproj 2 *) -End NamedTuple. - -Module DirectCoFix. -Check "DirectCoFix (PrimitiveProjectionUnfolded)". -CoInductive U := {q:U}. -CoFixpoint a := {|q:=a|}. -Notation COFIX := (cofix a := {|q:=a|}). -Axiom P : U -> Prop. -Goal P a.(q). unfold q. cbv delta [a]. simpl. Show. Abort. (* -> COFIX *) -Goal P a.(q). unfold q. cbv delta [a]. cbn. Show. Abort. (* -> COFIX *) -Goal P a.(q). unfold q. cbv delta [a]. hnf. Show. Abort. (* -> COFIX *) -Arguments q : simpl never. -Goal P a.(q). unfold q. cbv delta [a]. simpl. Show. Abort. (* -> COFIX *) (* never not respected on purpose *) -Goal P a.(q). unfold q. cbv delta [a]. cbn. Show. Abort. (* -> COFIX.(q) *) -Goal P a.(q). unfold q. cbv delta [a]. hnf. Show. Abort. (* -> COFIX *) -End DirectCoFix. - -Module NamedCoFix. -Check "NamedCoFix (PrimitiveProjectionUnfolded)". -CoInductive U := {q:U}. -CoFixpoint a := {|q:=a|}. -Notation COFIX := (cofix a := {|q:=a|}). -Axiom P : U -> Prop. -Goal P a.(q). unfold q. simpl. Show. Abort. (* -> a *) -Goal P a.(q). unfold q. cbn. Show. Abort. (* -> a *) -Goal P a.(q). unfold q. hnf. Show. Abort. (* -> a.(q) *) (* bug primproj 4 *) -Arguments q : simpl never. -Goal P a.(q). unfold q. simpl. Show. Abort. (* -> a *) -Goal P a.(q). unfold q. cbn. Show. Abort. (* -> a.(q) *) -Goal P a.(q). unfold q. hnf. Show. Abort. (* -> a.(q) *) (* bug primproj 4 *) -Arguments q : simpl nomatch. -Arguments a : simpl never. -Goal P a.(q). unfold q. simpl. Show. Abort. (* -> a *) -Goal P a.(q). unfold q. cbn. Show. Abort. (* -> a.(q) *) -Goal P a.(q). unfold q. hnf. Show. Abort. (* -> a.(q) *) (* bug primproj 4 *) -End NamedCoFix. -End PrimitiveProjectionUnfolded. - -Module PrimitiveProjectionConstant. -Check "** PrimitiveProjectionConstant". -(* we use a partial application to create a projection constant *) -Set Primitive Projections. - -Module DirectTuple. -Check "DirectTuple (PrimitiveProjectionConstant)". -Record T := {p:nat}. -Notation TUPLE := {|p:=0|}. -Definition a := {|p:=0|}. -Axiom P : nat -> Prop. -Goal P (id p a). unfold id. cbv delta [a]. simpl. Show. Abort. (* -> 0 *) -Goal P (id p a). unfold id. cbv delta [a]. cbn. Show. Abort. (* -> 0 *) -Goal P (id p a). unfold id. cbv delta [a]. hnf. Show. Abort. (* -> TUPLE.(p) *) (* bug primproj 1 *) -Arguments p : simpl never. -Goal P (id p a). unfold id. cbv delta [a]. simpl. Show. Abort. (* -> TUPLE.(p) *) -Goal P (id p a). unfold id. cbv delta [a]. cbn. Show. Abort. (* -> TUPLE.(p) *) -Goal P (id p a). unfold id. cbv delta [a]. hnf. Show. Abort. (* -> TUPLE.(p) *) (* bug primproj 1 *) -End DirectTuple. - -Module NamedTuple. -Check "NamedTuple (PrimitiveProjectionConstant)". -Record T := {p:nat}. -Definition a := {|p:=0|}. -Axiom P : nat -> Prop. -Goal P (id p a). unfold id. simpl. Show. Abort. (* -> 0 *) -Goal P (id p a). unfold id. cbn. Show. Abort. (* -> 0 *) -Goal P (id p a). unfold id. hnf. Show. Abort. (* -> a.(p) *) (* bug primproj 2 *) -Arguments p : simpl never. -Goal P (id p a). unfold id. simpl. Show. Abort. (* -> a.(p) *) -Goal P (id p a). unfold id. cbn. Show. Abort. (* -> a.(p) *) -Goal P (id p a). unfold id. hnf. Show. Abort. (* -> a.(p) *) (* bug primproj 2 *) -Arguments p : simpl nomatch. -Arguments a : simpl never. -Goal P (id p a). unfold id. simpl. Show. Abort. (* -> 0 *) (* never not respected on purpose *) -Goal P (id p a). unfold id. cbn. Show. Abort. (* -> a.(p) *) -Goal P (id p a). unfold id. hnf. Show. Abort. (* -> a.(p) *) -End NamedTuple. - -Module DirectCoFix. -Check "DirectCoFix (PrimitiveProjectionConstant)". -CoInductive U := {q:U}. -Notation COFIX := (cofix a := {|q:=a|}). -Axiom P : U -> Prop. -Goal P (id q COFIX). unfold id. simpl. Show. Abort. (* -> COFIX *) -Goal P (id q COFIX). unfold id. cbn. Show. Abort. (* -> COFIX *) -Goal P (id q COFIX). unfold id. hnf. Show. Abort. (* -> COFIX.(q) *) (* bug primproj 3 *) -Arguments q : simpl never. -Goal P (id q COFIX). unfold id. simpl. Show. Abort. (* -> COFIX.(q) *) -Goal P (id q COFIX). unfold id. cbn. Show. Abort. (* -> COFIX.(q) *) -Goal P (id q COFIX). unfold id. hnf. Show. Abort. (* -> COFIX.(q) *) (* bug primproj 3 *) -End DirectCoFix. - -Module NamedCoFix. -Check "NamedCoFix (PrimitiveProjectionConstant)". -CoInductive U := {q:U}. -CoFixpoint a := {|q:=a|}. -Axiom P : U -> Prop. -Goal P (id q a). unfold id. simpl. Show. Abort. (* -> a *) -Goal P (id q a). unfold id. cbn. Show. Abort. (* -> a *) -Goal P (id q a). unfold id. hnf. Show. Abort. (* -> a.(q) *) (* bug primproj 4 *) -Arguments q : simpl never. -Goal P (id q a). unfold id. simpl. Show. Abort. (* -> a.(q) *) -Goal P (id q a). unfold id. cbn. Show. Abort. (* -> a.(q) *) -Goal P (id q a). unfold id. hnf. Show. Abort. (* -> a.(q) *) (* bug primproj 4 *) -Arguments q : simpl nomatch. -Arguments a : simpl never. -Goal P (id q a). unfold id. simpl. Show. Abort. (* -> a *) (* never not respected on purpose *) -Goal P (id q a). unfold id. cbn. Show. Abort. (* -> a.(q) *) -Goal P (id q a). unfold id. hnf. Show. Abort. (* -> a.(q) *) (* bug primproj 4 *) -End NamedCoFix. -End PrimitiveProjectionConstant. diff --git a/stdlib/test-suite/output/sint63NumberNotation.out b/stdlib/test-suite/output/sint63NumberNotation.out deleted file mode 100644 index 9d325b38c76a..000000000000 --- a/stdlib/test-suite/output/sint63NumberNotation.out +++ /dev/null @@ -1,24 +0,0 @@ - = 0 - : uint - = 1 - : uint - = 9223372036854775807 - : uint -let v := 0 in v : uint - : uint -let v := 1 in v : uint - : uint -let v := 9223372036854775807 in v : uint - : uint - = 0 - : sint - = 1 - : sint - = -1 - : sint -let v := 0 in v : sint - : sint -let v := 1 in v : sint - : sint -let v := -1 in v : sint - : sint diff --git a/stdlib/test-suite/output/sint63NumberNotation.v b/stdlib/test-suite/output/sint63NumberNotation.v deleted file mode 100644 index 2a727e95a2c5..000000000000 --- a/stdlib/test-suite/output/sint63NumberNotation.v +++ /dev/null @@ -1,36 +0,0 @@ -From Stdlib Require Import Uint63. -Import ZArith. - -Declare Scope uint_scope. -Declare Scope sint_scope. -Delimit Scope uint_scope with uint. -Delimit Scope sint_scope with sint. - -Record uint := wrapu { unwrapu : int }. -Record sint := wraps { unwraps : int }. - -Definition uof_Z (v : Z) := wrapu (of_Z v). -Definition uto_Z (v : uint) := to_Z (unwrapu v). - -Definition sof_Z (v : Z) := wraps (of_Z (v mod (2 ^ 31))). -Definition as_signed (bw : Z) (v : Z) := - (((2 ^ (bw - 1) + v) mod (2 ^ bw)) - 2 ^ (bw - 1))%Z. - -Definition sto_Z (v : sint) := as_signed 31 (to_Z (unwraps v)). -Number Notation uint uof_Z uto_Z : uint_scope. -Number Notation sint sof_Z sto_Z : sint_scope. -Open Scope uint_scope. -Compute uof_Z 0. -Compute uof_Z 1. -Compute uof_Z (-1). -Check let v := 0 in v : uint. -Check let v := 1 in v : uint. -Check let v := -1 in v : uint. -Close Scope uint_scope. -Open Scope sint_scope. -Compute sof_Z 0. -Compute sof_Z 1. -Compute sof_Z (-1). -Check let v := 0 in v : sint. -Check let v := 1 in v : sint. -Check let v := -1 in v : sint. diff --git a/stdlib/test-suite/prerequisite/admit.v b/stdlib/test-suite/prerequisite/admit.v deleted file mode 100644 index fb3276632da4..000000000000 --- a/stdlib/test-suite/prerequisite/admit.v +++ /dev/null @@ -1,2 +0,0 @@ -Axiom proof_admitted : False. -Ltac admit := case proof_admitted. diff --git a/stdlib/test-suite/prerequisite/make_notation.v b/stdlib/test-suite/prerequisite/make_notation.v deleted file mode 100644 index e83e349e8a0e..000000000000 --- a/stdlib/test-suite/prerequisite/make_notation.v +++ /dev/null @@ -1,14 +0,0 @@ -(* Used in Notation.v to test import of notations from files in sections *) - -Notation "'Z'" := O (at level 9). -Notation plus := plus. -Notation succ := S. -Notation mult := mult (only parsing). -Notation less := le (only parsing). - -(* Test bug 2168: ending section of some name was removing objects of the - same name *) - -Notation add2 n:=(S n). -Section add2. -End add2. diff --git a/stdlib/test-suite/report.sh b/stdlib/test-suite/report.sh deleted file mode 100755 index 45083533d894..000000000000 --- a/stdlib/test-suite/report.sh +++ /dev/null @@ -1,43 +0,0 @@ -#!/usr/bin/env bash - -# save failed logs to logs/, then print failure information -# returns failure code if any failed logs exist - -# save step - -SAVEDIR="logs" - -# reset for local builds -rm -rf "$SAVEDIR" -mkdir "$SAVEDIR" - -FAILED=$(mktemp) -grep -F 'Error!' -r . -l --null --include="*.log" > "$FAILED" - -rsync -a --from0 --files-from="$FAILED" . "$SAVEDIR" -cp summary.log "$SAVEDIR"/ - -# cleanup -rm "$FAILED" - -# print info -if [ -n "$CI" ] || [ -n "$PRINT_LOGS" ]; then - find logs/ -name '*.log' -not -name 'summary.log' -print0 | while IFS= read -r -d '' file; do - printf '%s\n' "$file" - cat "$file" - printf '\n' - done - printed_logs=1 -fi - -if grep -q -F 'Error!' summary.log ; then - echo FAILURES; - grep -F 'Error!' summary.log; - if [ -z "$printed_logs" ]; then - echo 'To print details of failed tests, rerun with environment variable PRINT_LOGS=1' - echo 'eg "make report PRINT_LOGS=1" from the test suite directory"' - echo 'See README.md in the test suite directory for more information.' - fi - false -else echo NO FAILURES; -fi diff --git a/stdlib/test-suite/stm/Nijmegen_QArithSternBrocot_Zaux.v b/stdlib/test-suite/stm/Nijmegen_QArithSternBrocot_Zaux.v deleted file mode 100644 index 7b5a2f150be4..000000000000 --- a/stdlib/test-suite/stm/Nijmegen_QArithSternBrocot_Zaux.v +++ /dev/null @@ -1,3042 +0,0 @@ -(* -*- coq-prog-args: ("-async-proofs" "on"); -*- *) - -(* This program is free software; you can redistribute it and/or *) -(* modify it under the terms of the GNU Lesser General Public License *) -(* as published by the Free Software Foundation; either version 2.1 *) -(* of the License, or (at your option) any later version. *) -(* *) -(* This program is distributed in the hope that it will be useful, *) -(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) -(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) -(* GNU General Public License for more details. *) -(* *) -(* You should have received a copy of the GNU Lesser General Public *) -(* License along with this program; if not, write to the Free *) -(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *) -(* 02110-1301 USA *) - - -(** This file includes random facts about Integers (and natural numbers) which are not found in the standard library. Some of the lemma here are not used in the QArith development but are rather useful. -*) - -From Stdlib Require Export ZArith. -From Stdlib Require Export ZArithRing. -From Stdlib Require Import Lia. - -Tactic Notation "ElimCompare" constr(c) constr(d) := elim_compare c d. - -Ltac Flip := - apply Z.gt_lt || apply Z.lt_gt || apply Z.le_ge || apply Z.ge_le; assumption. - -Ltac Falsum := - try intro; apply False_ind; - repeat - match goal with - | id1:(~ ?X1) |- ?X2 => - (apply id1; assumption || reflexivity) || clear id1 - end. - - -Ltac Step_l a := - match goal with - | |- (?X1 < ?X2)%Z => replace X1 with a; [ idtac | try ring ] - end. - -Ltac Step_r a := - match goal with - | |- (?X1 < ?X2)%Z => replace X2 with a; [ idtac | try ring ] - end. - -Ltac CaseEq formula := - generalize (refl_equal formula); pattern formula at -1 in |- *; - case formula. - - -Lemma pair_1 : forall (A B : Set) (H : A * B), H = pair (fst H) (snd H). -Proof. - intros. - case H. - intros. - simpl in |- *. - reflexivity. -Qed. - -Lemma pair_2 : - forall (A B : Set) (H1 H2 : A * B), - fst H1 = fst H2 -> snd H1 = snd H2 -> H1 = H2. -Proof. - intros A B H1 H2. - case H1. - case H2. - simpl in |- *. - intros. - rewrite H. - rewrite H0. - reflexivity. -Qed. - - -Section projection. - Variable A : Set. - Variable P : A -> Prop. - - Definition projP1 (H : sig P) := let (x, h) := H in x. - Definition projP2 (H : sig P) := - let (x, h) as H return (P (projP1 H)) := H in h. -End projection. - - -(*###########################################################################*) -(* Declaring some relations on natural numbers for stepl and stepr tactics. *) -(*###########################################################################*) - -Lemma le_stepl: forall x y z, le x y -> x=z -> le z y. -Proof. - intros x y z H_le H_eq; subst z; trivial. -Qed. - -Lemma le_stepr: forall x y z, le x y -> y=z -> le x z. -Proof. - intros x y z H_le H_eq; subst z; trivial. -Qed. - -Lemma lt_stepl: forall x y z, lt x y -> x=z -> lt z y. -Proof. - intros x y z H_lt H_eq; subst z; trivial. -Qed. - -Lemma lt_stepr: forall x y z, lt x y -> y=z -> lt x z. -Proof. - intros x y z H_lt H_eq; subst z; trivial. -Qed. - -Lemma neq_stepl:forall (x y z:nat), x<>y -> x=z -> z<>y. -Proof. - intros x y z H_lt H_eq; subst; assumption. -Qed. - -Lemma neq_stepr:forall (x y z:nat), x<>y -> y=z -> x<>z. -Proof. - intros x y z H_lt H_eq; subst; assumption. -Qed. - - -Declare Left Step le_stepl. -Declare Right Step le_stepr. -Declare Left Step lt_stepl. -Declare Right Step lt_stepr. -Declare Left Step neq_stepl. -Declare Right Step neq_stepr. - -(*###########################################################################*) -(** Some random facts about natural numbers, positive numbers and integers *) -(*###########################################################################*) - - -Lemma not_O_S : forall n : nat, n <> 0 -> {p : nat | n = S p}. -Proof. - intros [| np] Hn; [ exists 0; apply False_ind; apply Hn | exists np ]; - reflexivity. -Qed. - - -Lemma lt_minus_neq : forall m n : nat, m < n -> n - m <> 0. -Proof. - intros. - lia. -Qed. - -Lemma lt_minus_eq_0 : forall m n : nat, m < n -> m - n = 0. -Proof. - intros. - lia. -Qed. - -Lemma le_plus_Sn_1_SSn : forall n : nat, S n + 1 <= S (S n). -Proof. - intros. - lia. -Qed. - -Lemma le_plus_O_l : forall p q : nat, p + q <= 0 -> p = 0. -Proof. - intros; lia. -Qed. - -Lemma le_plus_O_r : forall p q : nat, p + q <= 0 -> q = 0. -Proof. - intros; lia. -Qed. - -Lemma minus_pred : forall m n : nat, 0 < n -> pred m - pred n = m - n. -Proof. - intros. - lia. -Qed. - - -(*###########################################################################*) -(* Declaring some relations on integers for stepl and stepr tactics. *) -(*###########################################################################*) - -Lemma Zle_stepl: forall x y z, (x<=y)%Z -> x=z -> (z<=y)%Z. -Proof. - intros x y z H_le H_eq; subst z; trivial. -Qed. - -Lemma Zle_stepr: forall x y z, (x<=y)%Z -> y=z -> (x<=z)%Z. -Proof. - intros x y z H_le H_eq; subst z; trivial. -Qed. - -Lemma Zlt_stepl: forall x y z, (x x=z -> (z y=z -> (xy)%Z -> x=z -> (z<>y)%Z. -Proof. - intros x y z H_lt H_eq; subst; assumption. -Qed. - -Lemma Zneq_stepr:forall (x y z:Z), (x<>y)%Z -> y=z -> (x<>z)%Z. -Proof. - intros x y z H_lt H_eq; subst; assumption. -Qed. - -Declare Left Step Zle_stepl. -Declare Right Step Zle_stepr. -Declare Left Step Zlt_stepl. -Declare Right Step Zlt_stepr. -Declare Left Step Zneq_stepl. -Declare Right Step Zneq_stepr. - - -(*###########################################################################*) -(** Informative case analysis *) -(*###########################################################################*) - -Lemma Zlt_cotrans : - forall x y : Z, (x < y)%Z -> forall z : Z, {(x < z)%Z} + {(z < y)%Z}. -Proof. - intros. - case (Z_lt_ge_dec x z). - intro. - left. - assumption. - intro. - right. - apply Z.le_lt_trans with (m := x). - apply Z.ge_le. - assumption. - assumption. -Qed. - -Lemma Zlt_cotrans_pos : - forall x y : Z, (0 < x + y)%Z -> {(0 < x)%Z} + {(0 < y)%Z}. -Proof. - intros. - case (Zlt_cotrans 0 (x + y) H x). - intro. - left. - assumption. - intro. - right. - apply Zplus_lt_reg_l with (p := x). - rewrite Zplus_0_r. - assumption. -Qed. - - -Lemma Zlt_cotrans_neg : - forall x y : Z, (x + y < 0)%Z -> {(x < 0)%Z} + {(y < 0)%Z}. -Proof. - intros x y H; case (Zlt_cotrans (x + y) 0 H x); intro Hxy; - [ right; apply Zplus_lt_reg_l with (p := x); rewrite Zplus_0_r | left ]; - assumption. -Qed. - - - -Lemma not_Zeq_inf : forall x y : Z, x <> y -> {(x < y)%Z} + {(y < x)%Z}. -Proof. - intros. - case Z_lt_ge_dec with x y. - intro. - left. - assumption. - intro H0. - generalize (Z.ge_le _ _ H0). - intro. - case (Z_le_lt_eq_dec _ _ H1). - intro. - right. - assumption. - intro. - apply False_rec. - apply H. - symmetry in |- *. - assumption. -Qed. - -Lemma Z_dec : forall x y : Z, {(x < y)%Z} + {(x > y)%Z} + {x = y}. -Proof. - intros. - case (Z_lt_ge_dec x y). - intro H. - left. - left. - assumption. - intro H. - generalize (Z.ge_le _ _ H). - intro H0. - case (Z_le_lt_eq_dec y x H0). - intro H1. - left. - right. - apply Z.lt_gt. - assumption. - intro. - right. - symmetry in |- *. - assumption. -Qed. - - -Lemma Z_dec' : forall x y : Z, {(x < y)%Z} + {(y < x)%Z} + {x = y}. -Proof. - intros x y. - case (Z.eq_dec x y); intro H; - [ right; assumption | left; apply (not_Zeq_inf _ _ H) ]. -Qed. - -Lemma Z_lt_le_dec : forall x y : Z, {(x < y)%Z} + {(y <= x)%Z}. -Proof. - intros. - case (Z_lt_ge_dec x y). - intro. - left. - assumption. - intro. - right. - apply Z.ge_le. - assumption. -Qed. - -Lemma Z_le_lt_dec : forall x y : Z, {(x <= y)%Z} + {(y < x)%Z}. -Proof. - intros; case (Z_lt_le_dec y x); [ right | left ]; assumption. -Qed. - -Lemma Z_lt_lt_S_eq_dec : - forall x y : Z, (x < y)%Z -> {(x + 1 < y)%Z} + {(x + 1)%Z = y}. -Proof. - intros. - generalize (Zlt_le_succ _ _ H). - unfold Z.succ in |- *. - apply Z_le_lt_eq_dec. -Qed. - -Lemma quadro_leq_inf : - forall a b c d : Z, - {(c <= a)%Z /\ (d <= b)%Z} + {~ ((c <= a)%Z /\ (d <= b)%Z)}. -Proof. - intros. - case (Z_lt_le_dec a c). - intro z. - right. - intro. - elim H. - intros. - generalize z. - apply Zle_not_lt. - assumption. - intro. - case (Z_lt_le_dec b d). - intro z0. - right. - intro. - elim H. - intros. - generalize z0. - apply Zle_not_lt. - assumption. - intro. - left. - split. - assumption. - assumption. -Qed. - -(*###########################################################################*) -(** General auxiliary lemmata *) -(*###########################################################################*) - -Lemma Zminus_eq : forall x y : Z, (x - y)%Z = 0%Z -> x = y. -Proof. - intros. - apply Zplus_reg_l with (- y)%Z. - rewrite Zplus_opp_l. - unfold Zminus in H. - rewrite Zplus_comm. - assumption. -Qed. - -Lemma Zlt_minus : forall a b : Z, (b < a)%Z -> (0 < a - b)%Z. -Proof. - intros a b. - intros. - apply Zplus_lt_reg_l with b. - unfold Zminus in |- *. - rewrite (Zplus_comm a). - rewrite (Zplus_assoc b (- b)). - rewrite Zplus_opp_r. - simpl in |- *. - rewrite <- Zplus_0_r_reverse. - assumption. -Qed. - - -Lemma Zle_minus : forall a b : Z, (b <= a)%Z -> (0 <= a - b)%Z. -Proof. - intros a b. - intros. - apply Zplus_le_reg_l with b. - unfold Zminus in |- *. - rewrite (Zplus_comm a). - rewrite (Zplus_assoc b (- b)). - rewrite Zplus_opp_r. - simpl in |- *. - rewrite <- Zplus_0_r_reverse. - assumption. -Qed. - -Lemma Zlt_plus_plus : - forall m n p q : Z, (m < n)%Z -> (p < q)%Z -> (m + p < n + q)%Z. -Proof. - intros. - apply Z.lt_trans with (m := (n + p)%Z). - rewrite Zplus_comm. - rewrite Zplus_comm with (n := n). - apply Zplus_lt_compat_l. - assumption. - apply Zplus_lt_compat_l. - assumption. -Qed. - -Lemma Zgt_plus_plus : - forall m n p q : Z, (m > n)%Z -> (p > q)%Z -> (m + p > n + q)%Z. - intros. - apply Zgt_trans with (m := (n + p)%Z). - rewrite Zplus_comm. - rewrite Zplus_comm with (n := n). - apply Zplus_gt_compat_l. - assumption. - apply Zplus_gt_compat_l. - assumption. -Qed. - -Lemma Zle_lt_plus_plus : - forall m n p q : Z, (m <= n)%Z -> (p < q)%Z -> (m + p < n + q)%Z. -Proof. - intros. - case (Zle_lt_or_eq m n). - assumption. - intro. - apply Zlt_plus_plus. - assumption. - assumption. - intro. - rewrite H1. - apply Zplus_lt_compat_l. - assumption. -Qed. - -Lemma Zge_gt_plus_plus : - forall m n p q : Z, (m >= n)%Z -> (p > q)%Z -> (m + p > n + q)%Z. -Proof. - intros. - case (Zle_lt_or_eq n m). - apply Z.ge_le. - assumption. - intro. - apply Zgt_plus_plus. - apply Z.lt_gt. - assumption. - assumption. - intro. - rewrite H1. - apply Zplus_gt_compat_l. - assumption. -Qed. - -Lemma Zgt_ge_plus_plus : - forall m n p q : Z, (m > n)%Z -> (p >= q)%Z -> (m + p > n + q)%Z. -Proof. - intros. - rewrite Zplus_comm. - replace (n + q)%Z with (q + n)%Z. - apply Zge_gt_plus_plus. - assumption. - assumption. - apply Zplus_comm. -Qed. - -Lemma Zlt_resp_pos : forall x y : Z, (0 < x)%Z -> (0 < y)%Z -> (0 < x + y)%Z. -Proof. - intros. - rewrite <- Zplus_0_r with 0%Z. - apply Zlt_plus_plus; assumption. -Qed. - - -Lemma Zle_resp_neg : - forall x y : Z, (x <= 0)%Z -> (y <= 0)%Z -> (x + y <= 0)%Z. -Proof. - intros. - rewrite <- Zplus_0_r with 0%Z. - apply Zplus_le_compat; assumption. -Qed. - - -Lemma Zlt_pos_opp : forall x : Z, (0 < x)%Z -> (- x < 0)%Z. -Proof. - intros. - apply Zplus_lt_reg_l with x. - rewrite Zplus_opp_r. - rewrite Zplus_0_r. - assumption. -Qed. - -Lemma Zlt_neg_opp : forall x : Z, (x < 0)%Z -> (0 < - x)%Z. -Proof. - intros. - apply Zplus_lt_reg_l with x. - rewrite Zplus_opp_r. - rewrite Zplus_0_r. - assumption. -Qed. - - -Lemma Zle_neg_opp : forall x : Z, (x <= 0)%Z -> (0 <= - x)%Z. -Proof. - intros. - apply Zplus_le_reg_l with x. - rewrite Zplus_opp_r. - rewrite Zplus_0_r. - assumption. -Qed. - -Lemma Zle_pos_opp : forall x : Z, (0 <= x)%Z -> (- x <= 0)%Z. -Proof. - intros. - apply Zplus_le_reg_l with x. - rewrite Zplus_opp_r. - rewrite Zplus_0_r. - assumption. -Qed. - - -Lemma Zge_opp : forall x y : Z, (x <= y)%Z -> (- x >= - y)%Z. -Proof. - intros. - apply Z.le_ge. - apply Zplus_le_reg_l with (p := (x + y)%Z). - ring_simplify (x + y + - y)%Z (x + y + - x)%Z. - assumption. -Qed. - - - -(* Omega can't solve this *) -Lemma Zmult_pos_pos : forall x y : Z, (0 < x)%Z -> (0 < y)%Z -> (0 < x * y)%Z. -Proof. - intros [| px| px] [| py| py] Hx Hy; trivial || constructor. -Qed. - -Lemma Zmult_neg_neg : forall x y : Z, (x < 0)%Z -> (y < 0)%Z -> (0 < x * y)%Z. -Proof. - intros [| px| px] [| py| py] Hx Hy; trivial || constructor. -Qed. - -Lemma Zmult_neg_pos : forall x y : Z, (x < 0)%Z -> (0 < y)%Z -> (x * y < 0)%Z. -Proof. - intros [| px| px] [| py| py] Hx Hy; trivial || constructor. -Qed. - -Lemma Zmult_pos_neg : forall x y : Z, (0 < x)%Z -> (y < 0)%Z -> (x * y < 0)%Z. -Proof. - intros [| px| px] [| py| py] Hx Hy; trivial || constructor. -Qed. - - - -Local Hint Resolve Zmult_pos_pos Zmult_neg_neg Zmult_neg_pos Zmult_pos_neg: zarith. - - -Lemma Zle_reg_mult_l : - forall x y a : Z, (0 < a)%Z -> (x <= y)%Z -> (a * x <= a * y)%Z. -Proof. - intros. - apply Zplus_le_reg_l with (p := (- a * x)%Z). - ring_simplify (- a * x + a * x)%Z. - replace (- a * x + a * y)%Z with ((y - x) * a)%Z. - apply Zmult_gt_0_le_0_compat. - apply Z.lt_gt. - assumption. - unfold Zminus in |- *. - apply Zle_left. - assumption. - ring. -Qed. - -Lemma Zsimpl_plus_l_dep : - forall x y m n : Z, (x + m)%Z = (y + n)%Z -> x = y -> m = n. -Proof. - intros. - apply Zplus_reg_l with x. - rewrite <- H0 in H. - assumption. -Qed. - - -Lemma Zsimpl_plus_r_dep : - forall x y m n : Z, (m + x)%Z = (n + y)%Z -> x = y -> m = n. -Proof. - intros. - apply Zplus_reg_l with x. - rewrite Zplus_comm. - rewrite Zplus_comm with x n. - rewrite <- H0 in H. - assumption. -Qed. - -Lemma Zmult_simpl : - forall n m p q : Z, n = m -> p = q -> (n * p)%Z = (m * q)%Z. -Proof. - intros. - rewrite H. - rewrite H0. - reflexivity. -Qed. - -Lemma Zsimpl_mult_l : - forall n m p : Z, n <> 0%Z -> (n * m)%Z = (n * p)%Z -> m = p. -Proof. - intros. - apply Zplus_reg_l with (n := (- p)%Z). - replace (- p + p)%Z with 0%Z. - apply Zmult_integral_l with (n := n). - assumption. - replace ((- p + m) * n)%Z with (n * m + - (n * p))%Z. - apply Zegal_left. - assumption. - ring. - ring. -Qed. - -Lemma Zlt_reg_mult_l : - forall x y z : Z, (x > 0)%Z -> (y < z)%Z -> (x * y < x * z)%Z. (*QA*) -Proof. - intros. - case (Zcompare_Gt_spec x 0). - unfold Z.gt in H. - assumption. - intros. - cut (x = Zpos x0). - intro. - rewrite H2. - unfold Z.lt in H0. - unfold Z.lt in |- *. - cut ((Zpos x0 * y ?= Zpos x0 * z)%Z = (y ?= z)%Z). - intro. - exact (trans_eq H3 H0). - apply Zcompare_mult_compat. - cut (x = (x + - (0))%Z). - intro. - exact (trans_eq H2 H1). - simpl in |- *. - apply (sym_eq (A:=Z)). - exact (Zplus_0_r x). -Qed. - - -Lemma Zlt_opp : forall x y : Z, (x < y)%Z -> (- x > - y)%Z. (*QA*) -Proof. - intros. - red in |- *. - apply sym_eq. - cut (Datatypes.Gt = (y ?= x)%Z). - intro. - cut ((y ?= x)%Z = (- x ?= - y)%Z). - intro. - exact (trans_eq H0 H1). - exact (Zcompare_opp y x). - apply sym_eq. - exact (Z.lt_gt x y H). -Qed. - - -Lemma Zlt_conv_mult_l : - forall x y z : Z, (x < 0)%Z -> (y < z)%Z -> (x * y > x * z)%Z. (*QA*) -Proof. - intros. - cut (- x > 0)%Z. - intro. - cut (- x * y < - x * z)%Z. - intro. - cut (- (- x * y) > - (- x * z))%Z. - intro. - cut (- - (x * y) > - - (x * z))%Z. - intro. - cut ((- - (x * y))%Z = (x * y)%Z). - intro. - rewrite H5 in H4. - cut ((- - (x * z))%Z = (x * z)%Z). - intro. - rewrite H6 in H4. - assumption. - exact (Z.opp_involutive (x * z)). - exact (Z.opp_involutive (x * y)). - cut ((- (- x * y))%Z = (- - (x * y))%Z). - intro. - rewrite H4 in H3. - cut ((- (- x * z))%Z = (- - (x * z))%Z). - intro. - rewrite H5 in H3. - assumption. - cut ((- x * z)%Z = (- (x * z))%Z). - intro. - exact (f_equal Z.opp H5). - exact (Zopp_mult_distr_l_reverse x z). - cut ((- x * y)%Z = (- (x * y))%Z). - intro. - exact (f_equal Z.opp H4). - exact (Zopp_mult_distr_l_reverse x y). - exact (Zlt_opp (- x * y) (- x * z) H2). - exact (Zlt_reg_mult_l (- x) y z H1 H0). - exact (Zlt_opp x 0 H). -Qed. - -Lemma Zgt_not_eq : forall x y : Z, (x > y)%Z -> x <> y. (*QA*) -Proof. - intros. - cut (y < x)%Z. - intro. - cut (y <> x). - intro. - red in |- *. - intros. - cut (y = x). - intros. - apply H1. - assumption. - exact (sym_eq H2). - exact (Zorder.Zlt_not_eq y x H0). - exact (Z.gt_lt x y H). -Qed. - -Lemma Zmult_resp_nonzero : - forall x y : Z, x <> 0%Z -> y <> 0%Z -> (x * y)%Z <> 0%Z. -Proof. - intros x y Hx Hy Hxy. - apply Hx. - apply Zmult_integral_l with y; assumption. -Qed. - - -Lemma Zopp_app : forall y : Z, y <> 0%Z -> (- y)%Z <> 0%Z. -Proof. - intros. - intro. - apply H. - apply Zplus_reg_l with (- y)%Z. - rewrite Zplus_opp_l. - rewrite H0. - simpl in |- *. - reflexivity. -Qed. - - -Lemma Zle_neq_Zlt : forall a b : Z, (a <= b)%Z -> b <> a -> (a < b)%Z. -Proof. - intros a b H H0. - case (Z_le_lt_eq_dec _ _ H); trivial. - intro; apply False_ind; apply H0; symmetry in |- *; assumption. -Qed. - -Lemma not_Zle_lt : forall x y : Z, ~ (y <= x)%Z -> (x < y)%Z. -Proof. - intros; apply Z.gt_lt; apply Znot_le_gt; assumption. -Qed. - -Lemma not_Zlt : forall x y : Z, ~ (y < x)%Z -> (x <= y)%Z. -Proof. - intros x y H1 H2; apply H1; apply Z.gt_lt; assumption. -Qed. - - -Lemma Zmult_absorb : - forall x y z : Z, x <> 0%Z -> (x * y)%Z = (x * z)%Z -> y = z. (*QA*) -Proof. - intros. - case (dec_eq y z). - intro. - assumption. - intro. - case (not_Zeq y z). - assumption. - intro. - case (not_Zeq x 0). - assumption. - intro. - apply False_ind. - cut (x * y > x * z)%Z. - intro. - cut ((x * y)%Z <> (x * z)%Z). - intro. - apply H5. - assumption. - exact (Zgt_not_eq (x * y) (x * z) H4). - exact (Zlt_conv_mult_l x y z H3 H2). - intro. - apply False_ind. - cut (x * y < x * z)%Z. - intro. - cut ((x * y)%Z <> (x * z)%Z). - intro. - apply H5. - assumption. - exact (Zorder.Zlt_not_eq (x * y) (x * z) H4). - cut (x > 0)%Z. - intro. - exact (Zlt_reg_mult_l x y z H4 H2). - exact (Z.lt_gt 0 x H3). - intro. - apply False_ind. - cut (x * z < x * y)%Z. - intro. - cut ((x * z)%Z <> (x * y)%Z). - intro. - apply H4. - apply (sym_eq (A:=Z)). - assumption. - exact (Zorder.Zlt_not_eq (x * z) (x * y) H3). - apply False_ind. - case (not_Zeq x 0). - assumption. - intro. - cut (x * z > x * y)%Z. - intro. - cut ((x * z)%Z <> (x * y)%Z). - intro. - apply H5. - apply (sym_eq (A:=Z)). - assumption. - exact (Zgt_not_eq (x * z) (x * y) H4). - exact (Zlt_conv_mult_l x z y H3 H2). - intro. - cut (x * z < x * y)%Z. - intro. - cut ((x * z)%Z <> (x * y)%Z). - intro. - apply H5. - apply (sym_eq (A:=Z)). - assumption. - exact (Zorder.Zlt_not_eq (x * z) (x * y) H4). - cut (x > 0)%Z. - intro. - exact (Zlt_reg_mult_l x z y H4 H2). - exact (Z.lt_gt 0 x H3). -Qed. - -Lemma Zlt_mult_mult : - forall a b c d : Z, - (0 < a)%Z -> (0 < d)%Z -> (a < b)%Z -> (c < d)%Z -> (a * c < b * d)%Z. -Proof. - intros. - apply Z.lt_trans with (a * d)%Z. - apply Zlt_reg_mult_l. - Flip. - assumption. - rewrite Zmult_comm. - rewrite Zmult_comm with b d. - apply Zlt_reg_mult_l. - Flip. - assumption. -Qed. - -Lemma Zgt_mult_conv_absorb_l : - forall a x y : Z, (a < 0)%Z -> (a * x > a * y)%Z -> (x < y)%Z. (*QC*) -Proof. - intros. - case (dec_eq x y). - intro. - apply False_ind. - rewrite H1 in H0. - cut ((a * y)%Z = (a * y)%Z). - change ((a * y)%Z <> (a * y)%Z) in |- *. - apply Zgt_not_eq. - assumption. - trivial. - - intro. - case (not_Zeq x y H1). - trivial. - - intro. - apply False_ind. - cut (a * y > a * x)%Z. - apply Zgt_asym with (m := (a * y)%Z) (n := (a * x)%Z). - assumption. - apply Zlt_conv_mult_l. - assumption. - assumption. -Qed. - -Lemma Zgt_mult_reg_absorb_l : - forall a x y : Z, (a > 0)%Z -> (a * x > a * y)%Z -> (x > y)%Z. (*QC*) -Proof. - intros. - cut (- - a > - - (0))%Z. - intro. - cut (- a < - (0))%Z. - simpl in |- *. - intro. - replace x with (- - x)%Z. - replace y with (- - y)%Z. - apply Zlt_opp. - apply Zgt_mult_conv_absorb_l with (a := (- a)%Z) (x := (- x)%Z). - assumption. - rewrite Zmult_opp_opp. - rewrite Zmult_opp_opp. - assumption. - apply Z.opp_involutive. - apply Z.opp_involutive. - apply Z.gt_lt. - apply Zlt_opp. - apply Z.gt_lt. - assumption. - simpl in |- *. - rewrite Z.opp_involutive. - assumption. -Qed. - -Lemma Zopp_Zlt : forall x y : Z, (y < x)%Z -> (- x < - y)%Z. -Proof. - intros x y Hyx. - apply Zgt_mult_conv_absorb_l with (a := (-1)%Z). - constructor. - replace (-1 * - y)%Z with y. - replace (-1 * - x)%Z with x. - Flip. - ring. - ring. -Qed. - - -Lemma Zmin_cancel_Zlt : forall x y : Z, (- x < - y)%Z -> (y < x)%Z. -Proof. - intros. - apply Zgt_mult_conv_absorb_l with (a := (-1)%Z). - constructor. - replace (-1 * y)%Z with (- y)%Z. - replace (-1 * x)%Z with (- x)%Z. - apply Z.lt_gt. - assumption. - ring. - ring. -Qed. - - -Lemma Zmult_cancel_Zle : - forall a x y : Z, (a < 0)%Z -> (a * x <= a * y)%Z -> (y <= x)%Z. -Proof. - intros. - case (Z_le_gt_dec y x). - trivial. - intro. - apply False_ind. - apply (Z.lt_irrefl (a * x)). - apply Z.le_lt_trans with (m := (a * y)%Z). - assumption. - apply Z.gt_lt. - apply Zlt_conv_mult_l. - assumption. - apply Z.gt_lt. - assumption. -Qed. - -Lemma Zlt_mult_cancel_l : - forall x y z : Z, (0 < x)%Z -> (x * y < x * z)%Z -> (y < z)%Z. -Proof. - intros. - apply Z.gt_lt. - apply Zgt_mult_reg_absorb_l with x. - apply Z.lt_gt. - assumption. - apply Z.lt_gt. - assumption. -Qed. - - -Lemma Zmin_cancel_Zle : forall x y : Z, (- x <= - y)%Z -> (y <= x)%Z. -Proof. - intros. - apply Zmult_cancel_Zle with (a := (-1)%Z). - constructor. - replace (-1 * y)%Z with (- y)%Z. - replace (-1 * x)%Z with (- x)%Z. - assumption. - ring. - ring. -Qed. - - - -Lemma Zmult_resp_Zle : - forall a x y : Z, (0 < a)%Z -> (a * y <= a * x)%Z -> (y <= x)%Z. -Proof. - intros. - case (Z_le_gt_dec y x). - trivial. - intro. - apply False_ind. - apply (Z.lt_irrefl (a * y)). - apply Z.le_lt_trans with (m := (a * x)%Z). - assumption. - apply Zlt_reg_mult_l. - apply Z.lt_gt. - assumption. - apply Z.gt_lt. - assumption. -Qed. - -Lemma Zopp_Zle : forall x y : Z, (y <= x)%Z -> (- x <= - y)%Z. -Proof. - intros. - apply Zmult_cancel_Zle with (a := (-1)%Z). - constructor. - replace (-1 * - y)%Z with y. - replace (-1 * - x)%Z with x. - assumption. - clear y H; ring. - clear x H; ring. -Qed. - - -Lemma Zle_lt_eq_S : forall x y : Z, (x <= y)%Z -> (y < x + 1)%Z -> y = x. -Proof. - intros. - case (Z_le_lt_eq_dec x y H). - intro H1. - apply False_ind. - generalize (Zlt_le_succ x y H1). - intro. - apply (Zlt_not_le y (x + 1) H0). - replace (x + 1)%Z with (Z.succ x). - assumption. - reflexivity. - intro H1. - symmetry in |- *. - assumption. -Qed. - -Lemma Zlt_le_eq_S : - forall x y : Z, (x < y)%Z -> (y <= x + 1)%Z -> y = (x + 1)%Z. -Proof. - intros. - case (Z_le_lt_eq_dec y (x + 1) H0). - intro H1. - apply False_ind. - generalize (Zlt_le_succ x y H). - intro. - apply (Zlt_not_le y (x + 1) H1). - replace (x + 1)%Z with (Z.succ x). - assumption. - reflexivity. - trivial. -Qed. - - -Lemma double_not_equal_zero : - forall c d : Z, ~ (c = 0%Z /\ d = 0%Z) -> c <> d \/ c <> 0%Z. -Proof. - intros. - case (Z_zerop c). - intro. - rewrite e. - left. - apply sym_not_eq. - intro. - apply H; repeat split; assumption. - intro; right; assumption. -Qed. - -Lemma triple_not_equal_zero : - forall a b c : Z, - ~ (a = 0%Z /\ b = 0%Z /\ c = 0%Z) -> a <> 0%Z \/ b <> 0%Z \/ c <> 0%Z. -Proof. - intros a b c H; case (Z_zerop a); intro Ha; - [ case (Z_zerop b); intro Hb; - [ case (Z_zerop c); intro Hc; - [ apply False_ind; apply H; repeat split | right; right ] - | right; left ] - | left ]; assumption. -Qed. - -Lemma mediant_1 : - forall m n m' n' : Z, (m' * n < m * n')%Z -> ((m + m') * n < m * (n + n'))%Z. -Proof. - intros. - rewrite Zmult_plus_distr_r. - rewrite Zmult_plus_distr_l. - apply Zplus_lt_compat_l. - assumption. -Qed. - -Lemma mediant_2 : - forall m n m' n' : Z, - (m' * n < m * n')%Z -> (m' * (n + n') < (m + m') * n')%Z. -Proof. - intros. - rewrite Zmult_plus_distr_l. - rewrite Zmult_plus_distr_r. - apply Zplus_lt_compat_r. - assumption. -Qed. - - -Lemma mediant_3 : - forall a b m n m' n' : Z, - (0 <= a * m + b * n)%Z -> - (0 <= a * m' + b * n')%Z -> (0 <= a * (m + m') + b * (n + n'))%Z. -Proof. - intros. - replace (a * (m + m') + b * (n + n'))%Z with - (a * m + b * n + (a * m' + b * n'))%Z. - apply Zplus_le_0_compat. - assumption. - assumption. - ring. -Qed. - -Lemma fraction_lt_trans : - forall a b c d e f : Z, - (0 < b)%Z -> - (0 < d)%Z -> - (0 < f)%Z -> (a * d < c * b)%Z -> (c * f < e * d)%Z -> (a * f < e * b)%Z. -Proof. - intros. - apply Z.gt_lt. - apply Zgt_mult_reg_absorb_l with d. - Flip. - apply Zgt_trans with (c * b * f)%Z. - replace (d * (e * b))%Z with (b * (e * d))%Z. - replace (c * b * f)%Z with (b * (c * f))%Z. - apply Z.lt_gt. - apply Zlt_reg_mult_l. - Flip. - assumption. - ring. - ring. - replace (c * b * f)%Z with (f * (c * b))%Z. - replace (d * (a * f))%Z with (f * (a * d))%Z. - apply Z.lt_gt. - apply Zlt_reg_mult_l. - Flip. - assumption. - ring. - ring. -Qed. - - -Lemma square_pos : forall a : Z, a <> 0%Z -> (0 < a * a)%Z. -Proof. - intros [| p| p]; intros; [ Falsum | constructor | constructor ]. -Qed. - -Local Hint Resolve square_pos: zarith. - -(*###########################################################################*) -(** Properties of positive numbers, mapping between Z and nat *) -(*###########################################################################*) - - -Definition Z2positive (z : Z) := - match z with - | Zpos p => p - | Zneg p => p - | Z0 => 1%positive - end. - - -Lemma ZL9 : forall p : positive, Z_of_nat (nat_of_P p) = Zpos p. (*QF*) -Proof. - intro. - cut (exists h : nat, nat_of_P p = S h). - intro. - case H. - intros. - unfold Z_of_nat in |- *. - rewrite H0. - - apply f_equal with (A := positive) (B := Z) (f := Zpos). - cut (P_of_succ_nat (nat_of_P p) = P_of_succ_nat (S x)). - intro. - rewrite P_of_succ_nat_o_nat_of_P_eq_succ in H1. - cut (Pos.pred (Pos.succ p) = Pos.pred (P_of_succ_nat (S x))). - intro. - rewrite Pos.pred_succ in H2. - simpl in H2. - rewrite Pos.pred_succ in H2. - apply sym_eq. - assumption. - apply f_equal with (A := positive) (B := positive) (f := Pos.pred). - assumption. - apply f_equal with (f := P_of_succ_nat). - assumption. - apply ZL4. -Qed. - -Coercion Z_of_nat : nat >-> Z. - -Lemma ZERO_lt_POS : forall p : positive, (0 < Zpos p)%Z. -Proof. - intros. - constructor. -Qed. - - -Lemma POS_neq_ZERO : forall p : positive, Zpos p <> 0%Z. -Proof. - intros. - apply sym_not_eq. - apply Zorder.Zlt_not_eq. - apply ZERO_lt_POS. -Qed. - -Lemma NEG_neq_ZERO : forall p : positive, Zneg p <> 0%Z. -Proof. - intros. - apply Zorder.Zlt_not_eq. - unfold Z.lt in |- *. - constructor. -Qed. - - -Lemma POS_resp_eq : forall p0 p1 : positive, Zpos p0 = Zpos p1 -> p0 = p1. -Proof. - intros. - injection H. - trivial. -Qed. - -Lemma nat_nat_pos : forall m n : nat, ((m + 1) * (n + 1) > 0)%Z. (*QF*) -Proof. - intros. - apply Z.lt_gt. - cut (Z_of_nat m + 1 > 0)%Z. - intro. - cut (0 < Z_of_nat n + 1)%Z. - intro. - cut ((Z_of_nat m + 1) * 0 < (Z_of_nat m + 1) * (Z_of_nat n + 1))%Z. - rewrite Zmult_0_r. - intro. - assumption. - - apply Zlt_reg_mult_l. - assumption. - assumption. - change (0 < Z.succ (Z_of_nat n))%Z in |- *. - apply Zle_lt_succ. - change (Z_of_nat 0 <= Z_of_nat n)%Z in |- *. - apply Znat.inj_le. - apply Nat.le_0_l. - apply Z.lt_gt. - change (0 < Z.succ (Z_of_nat m))%Z in |- *. - apply Zle_lt_succ. - change (Z_of_nat 0 <= Z_of_nat m)%Z in |- *. - apply Znat.inj_le. - apply Nat.le_0_l. -Qed. - - -Theorem S_predn : forall m : nat, m <> 0 -> S (pred m) = m. (*QF*) -Proof. - intros. - case (O_or_S m). - intro. - case s. - intros. - rewrite <- e. - rewrite <- pred_Sn with (n := x). - trivial. - intro. - apply False_ind. - apply H. - apply sym_eq. - assumption. -Qed. - -Lemma absolu_1 : forall x : Z, Z.abs_nat x = 0 -> x = 0%Z. (*QF*) -Proof. - intros. - case (dec_eq x 0). - intro. - assumption. - intro. - apply False_ind. - cut ((x < 0)%Z \/ (x > 0)%Z). - intro. - ElimCompare x 0%Z. - intro. - cut (x = 0%Z). - assumption. - cut ((x ?= 0)%Z = Datatypes.Eq -> x = 0%Z). - intro. - apply H3. - assumption. - apply proj1 with (B := x = 0%Z -> (x ?= 0)%Z = Datatypes.Eq). - change ((x ?= 0)%Z = Datatypes.Eq <-> x = 0%Z) in |- *. - apply Zcompare_Eq_iff_eq. - - (***) - intro. - cut (exists h : nat, Z.abs_nat x = S h). - intro. - case H3. - rewrite H. - exact O_S. - - change (x < 0)%Z in H2. - cut (0 > x)%Z. - intro. - cut (exists p : positive, (0 + - x)%Z = Zpos p). - simpl in |- *. - intro. - case H4. - intros. - cut (exists q : positive, x = Zneg q). - intro. - case H6. - intros. - rewrite H7. - unfold Z.abs_nat in |- *. - generalize x1. - exact ZL4. - cut (x = (- Zpos x0)%Z). - simpl in |- *. - intro. - exists x0. - assumption. - cut ((- - x)%Z = x). - intro. - rewrite <- H6. - exact (f_equal Z.opp H5). - apply Z.opp_involutive. - apply Zcompare_Gt_spec. - assumption. - apply Z.lt_gt. - assumption. - - (***) - intro. - cut (exists h : nat, Z.abs_nat x = S h). - intro. - case H3. - rewrite H. - exact O_S. - - cut (exists p : positive, (x + - (0))%Z = Zpos p). - simpl in |- *. - rewrite Zplus_0_r. - intro. - case H3. - intros. - rewrite H4. - unfold Z.abs_nat in |- *. - generalize x0. - exact ZL4. - apply Zcompare_Gt_spec. - assumption. - - (***) - cut ((x < 0)%Z \/ (0 < x)%Z). - intro. - apply - or_ind with (A := (x < 0)%Z) (B := (0 < x)%Z) (P := (x < 0)%Z \/ (x > 0)%Z). - intro. - left. - assumption. - intro. - right. - apply Z.lt_gt. - assumption. - assumption. - apply not_Zeq. - assumption. -Qed. - -Lemma absolu_2 : forall x : Z, x <> 0%Z -> Z.abs_nat x <> 0. (*QF*) -Proof. - intros. - intro. - apply H. - apply absolu_1. - assumption. -Qed. - - - - -Lemma absolu_inject_nat : forall n : nat, Z.abs_nat (Z_of_nat n) = n. -Proof. - simple induction n; simpl in |- *. - reflexivity. - intros. - apply nat_of_P_o_P_of_succ_nat_eq_succ. -Qed. - - -Lemma eq_inj : forall m n : nat, m = n :>Z -> m = n. -Proof. - intros. - generalize (f_equal Z.abs_nat H). - intro. - rewrite (absolu_inject_nat m) in H0. - rewrite (absolu_inject_nat n) in H0. - assumption. -Qed. - -Lemma lt_inj : forall m n : nat, (m < n)%Z -> m < n. -Proof. - intros. - lia. -Qed. - -Lemma le_inj : forall m n : nat, (m <= n)%Z -> m <= n. -Proof. - intros. - lia. -Qed. - - -Lemma inject_nat_S_inf : forall x : Z, (0 < x)%Z -> {n : nat | x = S n}. -Proof. - intros [| p| p] Hp; try discriminate Hp. - exists (pred (nat_of_P p)). - rewrite S_predn. - symmetry in |- *; apply ZL9. - clear Hp; - apply Nat.neq_0_lt_0, lt_O_nat_of_P. -Qed. - - - -Lemma le_absolu : - forall x y : Z, - (0 <= x)%Z -> (0 <= y)%Z -> (x <= y)%Z -> Z.abs_nat x <= Z.abs_nat y. -Proof. - intros [| x| x] [| y| y] Hx Hy Hxy; - apply Nat.le_0_l || - (try - match goal with - | id1:(0 <= Zneg _)%Z |- _ => - apply False_ind; apply id1; constructor - | id1:(Zpos _ <= 0)%Z |- _ => - apply False_ind; apply id1; constructor - | id1:(Zpos _ <= Zneg _)%Z |- _ => - apply False_ind; apply id1; constructor - end). - simpl in |- *. - apply le_inj. - do 2 rewrite ZL9. - assumption. -Qed. - -Lemma lt_absolu : - forall x y : Z, - (0 <= x)%Z -> (0 <= y)%Z -> (x < y)%Z -> Z.abs_nat x < Z.abs_nat y. -Proof. - intros [| x| x] [| y| y] Hx Hy Hxy; inversion Hxy; - try - match goal with - | id1:(0 <= Zneg _)%Z |- _ => - apply False_ind; apply id1; constructor - | id1:(Zpos _ <= 0)%Z |- _ => - apply False_ind; apply id1; constructor - | id1:(Zpos _ <= Zneg _)%Z |- _ => - apply False_ind; apply id1; constructor - end; simpl in |- *; apply lt_inj; repeat rewrite ZL9; - assumption. -Qed. - -Lemma absolu_plus : - forall x y : Z, - (0 <= x)%Z -> (0 <= y)%Z -> Z.abs_nat (x + y) = Z.abs_nat x + Z.abs_nat y. -Proof. - intros [| x| x] [| y| y] Hx Hy; trivial; - try - match goal with - | id1:(0 <= Zneg _)%Z |- _ => - apply False_ind; apply id1; constructor - | id1:(Zpos _ <= 0)%Z |- _ => - apply False_ind; apply id1; constructor - | id1:(Zpos _ <= Zneg _)%Z |- _ => - apply False_ind; apply id1; constructor - end. - rewrite <- BinInt.Zpos_plus_distr. - unfold Z.abs_nat in |- *. - apply nat_of_P_plus_morphism. -Qed. - -Lemma pred_absolu : - forall x : Z, (0 < x)%Z -> pred (Z.abs_nat x) = Z.abs_nat (x - 1). -Proof. - intros x Hx. - generalize (Z_lt_lt_S_eq_dec 0 x Hx); simpl in |- *; intros [H1| H1]; - [ replace (Z.abs_nat x) with (Z.abs_nat (x - 1 + 1)); - [ idtac | apply f_equal with Z; auto with zarith ]; - rewrite absolu_plus; - [ unfold Z.abs_nat at 2, nat_of_P, Pos.iter_op in |- *; lia - | auto with zarith - | intro; discriminate ] - | rewrite <- H1; reflexivity ]. -Qed. - -Definition pred_nat : forall (x : Z) (Hx : (0 < x)%Z), nat. -intros [| px| px] Hx; try abstract (discriminate Hx). -exact (pred (nat_of_P px)). -Defined. - -Lemma pred_nat_equal : - forall (x : Z) (Hx1 Hx2 : (0 < x)%Z), pred_nat x Hx1 = pred_nat x Hx2. -Proof. - intros [| px| px] Hx1 Hx2; try (discriminate Hx1); trivial. -Qed. - -#[local] Definition pred_nat_unfolded_subproof px : - Pos.to_nat px <> 0. -Proof. -apply Nat.neq_0_lt_0, lt_O_nat_of_P. -Qed. - -Lemma pred_nat_unfolded : - forall (x : Z) (Hx : (0 < x)%Z), x = S (pred_nat x Hx). -Proof. - intros [| px| px] Hx; try discriminate Hx. - unfold pred_nat in |- *. - rewrite S_predn. - symmetry in |- *; apply ZL9. - clear Hx; apply pred_nat_unfolded_subproof. -Qed. - -Lemma absolu_pred_nat : - forall (m : Z) (Hm : (0 < m)%Z), S (pred_nat m Hm) = Z.abs_nat m. -Proof. - intros [| px| px] Hx; try discriminate Hx. - unfold pred_nat in |- *. - rewrite S_predn. - reflexivity. - apply pred_nat_unfolded_subproof. -Qed. - -Lemma pred_nat_absolu : - forall (m : Z) (Hm : (0 < m)%Z), pred_nat m Hm = Z.abs_nat (m - 1). -Proof. - intros [| px| px] Hx; try discriminate Hx. - unfold pred_nat in |- *. - rewrite <- pred_absolu; reflexivity || assumption. -Qed. - -Lemma minus_pred_nat : - forall (n m : Z) (Hn : (0 < n)%Z) (Hm : (0 < m)%Z) (Hnm : (0 < n - m)%Z), - S (pred_nat n Hn) - S (pred_nat m Hm) = S (pred_nat (n - m) Hnm). -Proof. - intros. - simpl in |- *. - destruct n; try discriminate Hn. - destruct m; try discriminate Hm. - unfold pred_nat at 1 2 in |- *. - rewrite minus_pred; try apply lt_O_nat_of_P. - apply eq_inj. - rewrite <- pred_nat_unfolded. - rewrite Znat.inj_minus1. - repeat rewrite ZL9. - reflexivity. - apply le_inj. - apply Zlt_le_weak. - repeat rewrite ZL9. - apply Zlt_O_minus_lt. - assumption. -Qed. - - -(*###########################################################################*) -(** Properties of Zsgn *) -(*###########################################################################*) - - -Lemma Zsgn_1 : - forall x : Z, {Z.sgn x = 0%Z} + {Z.sgn x = 1%Z} + {Z.sgn x = (-1)%Z}. (*QF*) -Proof. - intros. - case x. - left. - left. - unfold Z.sgn in |- *. - reflexivity. - intro. - simpl in |- *. - left. - right. - reflexivity. - intro. - right. - simpl in |- *. - reflexivity. -Qed. - - -Lemma Zsgn_2 : forall x : Z, Z.sgn x = 0%Z -> x = 0%Z. (*QF*) -Proof. - intros [| p1| p1]; simpl in |- *; intro H; constructor || discriminate H. -Qed. - - -Lemma Zsgn_3 : forall x : Z, x <> 0%Z -> Z.sgn x <> 0%Z. (*QF*) -Proof. - intro. - case x. - intros. - apply False_ind. - apply H. - reflexivity. - intros. - simpl in |- *. - discriminate. - intros. - simpl in |- *. - discriminate. -Qed. - - - - -Theorem Zsgn_4 : forall a : Z, a = (Z.sgn a * Z.abs_nat a)%Z. (*QF*) -Proof. - intro. - case a. - simpl in |- *. - reflexivity. - intro. - unfold Z.sgn in |- *. - unfold Z.abs_nat in |- *. - rewrite Zmult_1_l. - symmetry in |- *. - apply ZL9. - intros. - unfold Z.sgn in |- *. - unfold Z.abs_nat in |- *. - rewrite ZL9. - constructor. -Qed. - - -Theorem Zsgn_5 : - forall a b x y : Z, - x <> 0%Z -> - y <> 0%Z -> - (Z.sgn a * x)%Z = (Z.sgn b * y)%Z -> (Z.sgn a * y)%Z = (Z.sgn b * x)%Z. (*QF*) -Proof. - intros a b x y H H0. - case a. - - case b. - simpl in |- *. - trivial. - - intro. - unfold Z.sgn in |- *. - intro. - rewrite Zmult_1_l in H1. - simpl in H1. - apply False_ind. - apply H0. - symmetry in |- *. - assumption. - intro. - unfold Z.sgn in |- *. - intro. - apply False_ind. - apply H0. - apply Z.opp_inj. - simpl in |- *. - transitivity (-1 * y)%Z. - constructor. - transitivity (0 * x)%Z. - symmetry in |- *. - assumption. - simpl in |- *. - reflexivity. - intro. - unfold Z.sgn at 1 in |- *. - unfold Z.sgn at 2 in |- *. - intro. - transitivity y. - rewrite Zmult_1_l. - reflexivity. - transitivity (Z.sgn b * (Z.sgn b * y))%Z. - case (Zsgn_1 b). - intro. - case s. - intro. - apply False_ind. - apply H. - rewrite e in H1. - change ((1 * x)%Z = 0%Z) in H1. - rewrite Zmult_1_l in H1. - assumption. - intro. - rewrite e. - rewrite Zmult_1_l. - rewrite Zmult_1_l. - reflexivity. - intro. - rewrite e. - ring. - rewrite Zmult_1_l in H1. - rewrite H1. - reflexivity. - intro. - unfold Z.sgn at 1 in |- *. - unfold Z.sgn at 2 in |- *. - intro. - transitivity (Z.sgn b * (-1 * (Z.sgn b * y)))%Z. - case (Zsgn_1 b). - intros. - case s. - intro. - apply False_ind. - apply H. - apply Z.opp_inj. - transitivity (-1 * x)%Z. - ring. - unfold Z.opp in |- *. - rewrite e in H1. - transitivity (0 * y)%Z. - assumption. - simpl in |- *. - reflexivity. - intro. - rewrite e. - ring. - intro. - rewrite e. - ring. - rewrite <- H1. - ring. -Qed. - -Lemma Zsgn_6 : forall x : Z, x = 0%Z -> Z.sgn x = 0%Z. -Proof. - intros. - rewrite H. - simpl in |- *. - reflexivity. -Qed. - - -Lemma Zsgn_7 : forall x : Z, (x > 0)%Z -> Z.sgn x = 1%Z. -Proof. - intro. - case x. - intro. - apply False_ind. - apply (Z.lt_irrefl 0). - Flip. - intros. - simpl in |- *. - reflexivity. - intros. - apply False_ind. - apply (Z.lt_irrefl (Zneg p)). - apply Z.lt_trans with 0%Z. - constructor. - Flip. -Qed. - - -Lemma Zsgn_7' : forall x : Z, (0 < x)%Z -> Z.sgn x = 1%Z. -Proof. - intros; apply Zsgn_7; Flip. -Qed. - - -Lemma Zsgn_8 : forall x : Z, (x < 0)%Z -> Z.sgn x = (-1)%Z. -Proof. - intro. - case x. - intro. - apply False_ind. - apply (Z.lt_irrefl 0). - assumption. - intros. - apply False_ind. - apply (Z.lt_irrefl 0). - apply Z.lt_trans with (Zpos p). - constructor. - assumption. - intros. - simpl in |- *. - reflexivity. -Qed. - -Lemma Zsgn_9 : forall x : Z, Z.sgn x = 1%Z -> (0 < x)%Z. -Proof. - intro. - case x. - intro. - apply False_ind. - simpl in H. - discriminate. - intros. - constructor. - intros. - apply False_ind. - discriminate. -Qed. - -Lemma Zsgn_10 : forall x : Z, Z.sgn x = (-1)%Z -> (x < 0)%Z. -Proof. - intro. - case x. - intro. - apply False_ind. - discriminate. - intros. - apply False_ind. - discriminate. - intros. - constructor. -Qed. - -Lemma Zsgn_11 : forall x : Z, (Z.sgn x < 0)%Z -> (x < 0)%Z. -Proof. - intros. - apply Zsgn_10. - case (Zsgn_1 x). - intro. - apply False_ind. - case s. - intro. - generalize (Zorder.Zlt_not_eq _ _ H). - intro. - apply (H0 e). - intro. - rewrite e in H. - generalize (Zorder.Zlt_not_eq _ _ H). - intro. - discriminate. - trivial. -Qed. - -Lemma Zsgn_12 : forall x : Z, (0 < Z.sgn x)%Z -> (0 < x)%Z. -Proof. - intros. - apply Zsgn_9. - case (Zsgn_1 x). - intro. - case s. - intro. - generalize (Zorder.Zlt_not_eq _ _ H). - intro. - generalize (sym_eq e). - intro. - apply False_ind. - apply (H0 H1). - trivial. - intro. - rewrite e in H. - generalize (Zorder.Zlt_not_eq _ _ H). - intro. - apply False_ind. - discriminate. -Qed. - -Lemma Zsgn_13 : forall x : Z, (0 <= Z.sgn x)%Z -> (0 <= x)%Z. -Proof. - intros. - case (Z_le_lt_eq_dec 0 (Z.sgn x) H). - intro. - apply Zlt_le_weak. - apply Zsgn_12. - assumption. - intro. - assert (x = 0%Z). - apply Zsgn_2. - symmetry in |- *. - assumption. - rewrite H0. - apply Z.le_refl. -Qed. - -Lemma Zsgn_14 : forall x : Z, (Z.sgn x <= 0)%Z -> (x <= 0)%Z. -Proof. - intros. - case (Z_le_lt_eq_dec (Z.sgn x) 0 H). - intro. - apply Zlt_le_weak. - apply Zsgn_11. - assumption. - intro. - assert (x = 0%Z). - apply Zsgn_2. - assumption. - rewrite H0. - apply Z.le_refl. -Qed. - -Lemma Zsgn_15 : forall x y : Z, Z.sgn (x * y) = (Z.sgn x * Z.sgn y)%Z. -Proof. - intros [|p1|p1]; [intros y|intros [|p2|p2] ..]; simpl in |- *; constructor. -Qed. - -Lemma Zsgn_16 : - forall x y : Z, - Z.sgn (x * y) = 1%Z -> {(0 < x)%Z /\ (0 < y)%Z} + {(x < 0)%Z /\ (y < 0)%Z}. -Proof. - intros [|p1|p1]; [intros y|intros [|p2|p2] ..]; simpl in |- *; intro H; - try discriminate H; [ left | right ]; repeat split. -Qed. - -Lemma Zsgn_17 : - forall x y : Z, - Z.sgn (x * y) = (-1)%Z -> {(0 < x)%Z /\ (y < 0)%Z} + {(x < 0)%Z /\ (0 < y)%Z}. -Proof. - intros [|p1|p1]; [intros y|intros [|p2|p2] ..]; simpl in |- *; intro H; - try discriminate H; [ left | right ]; repeat split. -Qed. - -Lemma Zsgn_18 : forall x y : Z, Z.sgn (x * y) = 0%Z -> {x = 0%Z} + {y = 0%Z}. -Proof. - intros [|p1|p1]; [intros y|intros [|p2|p2] ..]; simpl in |- *; intro H; - try discriminate H; [ left | right | right ]; constructor. -Qed. - - - -Lemma Zsgn_19 : forall x y : Z, (0 < Z.sgn x + Z.sgn y)%Z -> (0 < x + y)%Z. -Proof. - Proof. - intros [|p1|p1]; [intros y|intros [|p2|p2] ..]; simpl in |- *; intro H; - discriminate H || (constructor || apply Zsgn_12; assumption). -Qed. - -Lemma Zsgn_20 : forall x y : Z, (Z.sgn x + Z.sgn y < 0)%Z -> (x + y < 0)%Z. -Proof. - Proof. - intros [|p1|p1]; [intros y|intros [|p2|p2] ..]; simpl in |- *; intro H; - discriminate H || (constructor || apply Zsgn_11; assumption). -Qed. - - -Lemma Zsgn_21 : forall x y : Z, (0 < Z.sgn x + Z.sgn y)%Z -> (0 <= x)%Z. -Proof. - intros [|p1|p1]; [intros y|intros [|p2|p2] ..]; simpl in |- *; intros H H0; - discriminate H || discriminate H0. -Qed. - -Lemma Zsgn_22 : forall x y : Z, (Z.sgn x + Z.sgn y < 0)%Z -> (x <= 0)%Z. -Proof. - Proof. - intros [|p1|p1]; [intros y|intros [|p2|p2] ..]; simpl in |- *; intros H H0; - discriminate H || discriminate H0. -Qed. - -Lemma Zsgn_23 : forall x y : Z, (0 < Z.sgn x + Z.sgn y)%Z -> (0 <= y)%Z. -Proof. - intros [|p1|p1] [|p2|p2]; simpl in |- *; - intros H H0; discriminate H || discriminate H0. -Qed. - -Lemma Zsgn_24 : forall x y : Z, (Z.sgn x + Z.sgn y < 0)%Z -> (y <= 0)%Z. -Proof. - intros [|p1|p1] [|p2|p2]; simpl in |- *; - intros H H0; discriminate H || discriminate H0. -Qed. - -Lemma Zsgn_25 : forall x : Z, Z.sgn (- x) = (- Z.sgn x)%Z. -Proof. - intros [| p1| p1]; simpl in |- *; reflexivity. -Qed. - - -Lemma Zsgn_26 : forall x : Z, (0 < x)%Z -> (0 < Z.sgn x)%Z. -Proof. - intros [| p| p] Hp; trivial. -Qed. - -Lemma Zsgn_27 : forall x : Z, (x < 0)%Z -> (Z.sgn x < 0)%Z. -Proof. - intros [| p| p] Hp; trivial. -Qed. - -Local Hint Resolve Zsgn_1 Zsgn_2 Zsgn_3 Zsgn_4 Zsgn_5 Zsgn_6 Zsgn_7 Zsgn_7' Zsgn_8 - Zsgn_9 Zsgn_10 Zsgn_11 Zsgn_12 Zsgn_13 Zsgn_14 Zsgn_15 Zsgn_16 Zsgn_17 - Zsgn_18 Zsgn_19 Zsgn_20 Zsgn_21 Zsgn_22 Zsgn_23 Zsgn_24 Zsgn_25 Zsgn_26 - Zsgn_27: zarith. - -(*###########################################################################*) -(** Properties of Zabs *) -(*###########################################################################*) - -Lemma Zabs_1 : forall z p : Z, (Z.abs z < p)%Z -> (z < p)%Z /\ (- p < z)%Z. -Proof. - intros z p. - case z. - intros. - simpl in H. - split. - assumption. - apply Zgt_mult_conv_absorb_l with (a := (-1)%Z). - replace (-1)%Z with (Z.pred 0). - apply Zlt_pred. - simpl; trivial. - ring_simplify (-1 * - p)%Z (-1 * 0)%Z. - apply Z.lt_gt. - assumption. - - intros. - simpl in H. - split. - assumption. - apply Z.lt_trans with (m := 0%Z). - apply Zgt_mult_conv_absorb_l with (a := (-1)%Z). - replace (-1)%Z with (Z.pred 0). - apply Zlt_pred. - simpl; trivial. - ring_simplify (-1 * - p)%Z (-1 * 0)%Z. - apply Z.lt_gt. - apply Z.lt_trans with (m := Zpos p0). - constructor. - assumption. - constructor. - - intros. - simpl in H. - split. - apply Z.lt_trans with (m := Zpos p0). - constructor. - assumption. - - apply Zgt_mult_conv_absorb_l with (a := (-1)%Z). - replace (-1)%Z with (Z.pred 0). - apply Zlt_pred. - simpl;trivial. - ring_simplify (-1 * - p)%Z. - replace (-1 * Zneg p0)%Z with (- Zneg p0)%Z. - replace (- Zneg p0)%Z with (Zpos p0). - apply Z.lt_gt. - assumption. - symmetry in |- *. - apply Zopp_neg. - rewrite Zopp_mult_distr_l_reverse with (n := 1%Z). - simpl in |- *. - constructor. -Qed. - - -Lemma Zabs_2 : forall z p : Z, (Z.abs z > p)%Z -> (z > p)%Z \/ (- p > z)%Z. -Proof. - intros z p. - case z. - intros. - simpl in H. - left. - assumption. - - intros. - simpl in H. - left. - assumption. - - intros. - simpl in H. - right. - apply Z.lt_gt. - apply Zgt_mult_conv_absorb_l with (a := (-1)%Z). - constructor. - ring_simplify (-1 * - p)%Z. - replace (-1 * Zneg p0)%Z with (Zpos p0). - assumption. - reflexivity. -Qed. - -Lemma Zabs_3 : forall z p : Z, (z < p)%Z /\ (- p < z)%Z -> (Z.abs z < p)%Z. -Proof. - intros z p. - case z. - intro. - simpl in |- *. - elim H. - intros. - assumption. - - intros. - elim H. - intros. - simpl in |- *. - assumption. - - intros. - elim H. - intros. - simpl in |- *. - apply Zgt_mult_conv_absorb_l with (a := (-1)%Z). - constructor. - replace (-1 * Zpos p0)%Z with (Zneg p0). - replace (-1 * p)%Z with (- p)%Z. - apply Z.lt_gt. - assumption. - ring. - simpl in |- *. - reflexivity. -Qed. - -Lemma Zabs_4 : forall z p : Z, (Z.abs z < p)%Z -> (- p < z < p)%Z. -Proof. - intros. - split. - apply proj2 with (A := (z < p)%Z). - apply Zabs_1. - assumption. - apply proj1 with (B := (- p < z)%Z). - apply Zabs_1. - assumption. -Qed. - - -Lemma Zabs_5 : forall z p : Z, (Z.abs z <= p)%Z -> (- p <= z <= p)%Z. -Proof. - intros. - split. - replace (- p)%Z with (Z.succ (- Z.succ p)). - apply Zlt_le_succ. - apply proj2 with (A := (z < Z.succ p)%Z). - apply Zabs_1. - apply Zle_lt_succ. - assumption. - unfold Z.succ in |- *. - ring. - apply Zlt_succ_le. - apply proj1 with (B := (- Z.succ p < z)%Z). - apply Zabs_1. - apply Zle_lt_succ. - assumption. -Qed. - -Lemma Zabs_6 : forall z p : Z, (Z.abs z <= p)%Z -> (z <= p)%Z. -Proof. - intros. - apply proj2 with (A := (- p <= z)%Z). - apply Zabs_5. - assumption. -Qed. - -Lemma Zabs_7 : forall z p : Z, (Z.abs z <= p)%Z -> (- p <= z)%Z. -Proof. - intros. - apply proj1 with (B := (z <= p)%Z). - apply Zabs_5. - assumption. -Qed. - -Lemma Zabs_8 : forall z p : Z, (- p <= z <= p)%Z -> (Z.abs z <= p)%Z. -Proof. - intros. - apply Zlt_succ_le. - apply Zabs_3. - elim H. - intros. - split. - apply Zle_lt_succ. - assumption. - apply Z.lt_le_trans with (m := (- p)%Z). - apply Z.gt_lt. - apply Zlt_opp. - apply Zlt_succ. - assumption. -Qed. - -Lemma Zabs_min : forall z : Z, Z.abs z = Z.abs (- z). -Proof. - intro. - case z. - simpl in |- *. - reflexivity. - intro. - simpl in |- *. - reflexivity. - intro. - simpl in |- *. - reflexivity. -Qed. - -Lemma Zabs_9 : - forall z p : Z, (0 <= p)%Z -> (p < z)%Z \/ (z < - p)%Z -> (p < Z.abs z)%Z. -Proof. - intros. - case H0. - intro. - replace (Z.abs z) with z. - assumption. - symmetry in |- *. - apply Z.abs_eq. - apply Zlt_le_weak. - apply Z.le_lt_trans with (m := p). - assumption. - assumption. - intro. - cut (Z.abs z = (- z)%Z). - intro. - rewrite H2. - apply Zmin_cancel_Zlt. - ring_simplify (- - z)%Z. - assumption. - rewrite Zabs_min. - apply Z.abs_eq. - apply Zlt_le_weak. - apply Z.le_lt_trans with (m := p). - assumption. - apply Zmin_cancel_Zlt. - ring_simplify (- - z)%Z. - assumption. -Qed. - -Lemma Zabs_10 : forall z : Z, (0 <= Z.abs z)%Z. -Proof. - intro. - case (Z_zerop z). - intro. - rewrite e. - simpl in |- *. - apply Z.le_refl. - intro. - case (not_Zeq z 0 n). - intro. - apply Zlt_le_weak. - apply Zabs_9. - apply Z.le_refl. - simpl in |- *. - right. - assumption. - intro. - apply Zlt_le_weak. - apply Zabs_9. - apply Z.le_refl. - simpl in |- *. - left. - assumption. -Qed. - -Lemma Zabs_11 : forall z : Z, z <> 0%Z -> (0 < Z.abs z)%Z. -Proof. - intros. - apply Zabs_9. - apply Z.le_refl. - simpl in |- *. - apply not_Zeq. - intro. - apply H. - symmetry in |- *. - assumption. -Qed. - -Lemma Zabs_12 : forall z m : Z, (m < Z.abs z)%Z -> {(m < z)%Z} + {(z < - m)%Z}. -Proof. - intros [| p| p] m; simpl in |- *; intros H; - [ left | left | right; apply Zmin_cancel_Zlt; rewrite Z.opp_involutive ]; - assumption. -Qed. - -Lemma Zabs_mult : forall z p : Z, Z.abs (z * p) = (Z.abs z * Z.abs p)%Z. -Proof. - intros. - case z. - simpl in |- *. - reflexivity. - case p. - simpl in |- *. - reflexivity. - intros. - simpl in |- *. - reflexivity. - intros. - simpl in |- *. - reflexivity. - case p. - intro. - simpl in |- *. - reflexivity. - intros. - simpl in |- *. - reflexivity. - intros. - simpl in |- *. - reflexivity. -Qed. - -Lemma Zabs_plus : forall z p : Z, (Z.abs (z + p) <= Z.abs z + Z.abs p)%Z. -Proof. - intros. - case z. - simpl in |- *. - apply Z.le_refl. - case p. - intro. - simpl in |- *. - apply Z.le_refl. - intros. - simpl in |- *. - apply Z.le_refl. - intros. - unfold Z.abs at 2 in |- *. - unfold Z.abs at 2 in |- *. - apply Zabs_8. - split. - apply Zplus_le_reg_l with (Zpos p1 - Zneg p0)%Z. - replace (Zpos p1 - Zneg p0 + - (Zpos p1 + Zpos p0))%Z with - (- (Zpos p0 + Zneg p0))%Z. - replace (Zpos p1 - Zneg p0 + (Zpos p1 + Zneg p0))%Z with (2 * Zpos p1)%Z. - replace (- (Zpos p0 + Zneg p0))%Z with 0%Z. - apply Zmult_gt_0_le_0_compat. - constructor. - apply Zlt_le_weak. - constructor. - rewrite <- Zopp_neg with p0. - ring. - ring. - ring. - apply Zplus_le_compat. - apply Z.le_refl. - apply Zlt_le_weak. - constructor. - - case p. - simpl in |- *. - intro. - apply Z.le_refl. - intros. - unfold Z.abs at 2 in |- *. - unfold Z.abs at 2 in |- *. - apply Zabs_8. - split. - apply Zplus_le_reg_l with (Zpos p1 + Zneg p0)%Z. - replace (Zpos p1 + Zneg p0 + - (Zpos p1 + Zpos p0))%Z with - (Zneg p0 - Zpos p0)%Z. - replace (Zpos p1 + Zneg p0 + (Zneg p1 + Zpos p0))%Z with 0%Z. - apply Zplus_le_reg_l with (Zpos p0). - replace (Zpos p0 + (Zneg p0 - Zpos p0))%Z with (Zneg p0). - simpl in |- *. - apply Zlt_le_weak. - constructor. - ring. - replace (Zpos p1 + Zneg p0 + (Zneg p1 + Zpos p0))%Z with - (Zpos p1 + Zneg p1 + (Zpos p0 + Zneg p0))%Z. - replace 0%Z with (0 + 0)%Z. - apply Zplus_eq_compat. - rewrite <- Zopp_neg with p1. - ring. - rewrite <- Zopp_neg with p0. - ring. - simpl in |- *. - constructor. - ring. - ring. - apply Zplus_le_compat. - apply Zlt_le_weak. - constructor. - apply Z.le_refl. - intros. - simpl in |- *. - apply Z.le_refl. -Qed. - -Lemma Zabs_neg : forall z : Z, (z <= 0)%Z -> Z.abs z = (- z)%Z. -Proof. - intro. - case z. - simpl in |- *. - intro. - reflexivity. - intros. - apply False_ind. - apply H. - simpl in |- *. - reflexivity. - intros. - simpl in |- *. - reflexivity. -Qed. - -Lemma Zle_Zabs: forall z, (z <= Z.abs z)%Z. -Proof. - intros [|z|z]; simpl; auto with zarith; apply Zle_neg_pos. -Qed. - -Local Hint Resolve Zabs_1 Zabs_2 Zabs_3 Zabs_4 Zabs_5 Zabs_6 Zabs_7 Zabs_8 Zabs_9 - Zabs_10 Zabs_11 Zabs_12 Zabs_min Zabs_neg Zabs_mult Zabs_plus Zle_Zabs: zarith. - - -(*###########################################################################*) -(** Induction on Z *) -(*###########################################################################*) - -Lemma Zind : - forall (P : Z -> Prop) (p : Z), - P p -> - (forall q : Z, (p <= q)%Z -> P q -> P (q + 1)%Z) -> - forall q : Z, (p <= q)%Z -> P q. -Proof. - intros P p. - intro. - intro. - cut (forall q : Z, (p <= q)%Z -> exists k : nat, q = (p + k)%Z). - intro. - cut (forall k : nat, P (p + k)%Z). - intro. - intros. - cut (exists k : nat, q = (p + Z_of_nat k)%Z). - intro. - case H4. - intros. - rewrite H5. - apply H2. - apply H1. - assumption. - intro. - induction k as [| k Hreck]. - simpl in |- *. - ring_simplify (p + 0)%Z. - assumption. - replace (p + Z_of_nat (S k))%Z with (p + k + 1)%Z. - apply H0. - apply Zplus_le_reg_l with (p := (- p)%Z). - replace (- p + p)%Z with (Z_of_nat 0). - ring_simplify (- p + (p + Z_of_nat k))%Z. - apply Znat.inj_le. - apply Nat.le_0_l. - ring_simplify; auto with arith. - assumption. - rewrite (Znat.inj_S k). - unfold Z.succ in |- *. - ring. - intros. - cut (exists k : nat, (q - p)%Z = Z_of_nat k). - intro. - case H2. - intro k. - intros. - exists k. - apply Zplus_reg_l with (n := (- p)%Z). - replace (- p + q)%Z with (q - p)%Z. - rewrite H3. - ring. - ring. - apply Z_of_nat_complete. - unfold Zminus in |- *. - apply Zle_left. - assumption. -Qed. - -Lemma Zrec : - forall (P : Z -> Set) (p : Z), - P p -> - (forall q : Z, (p <= q)%Z -> P q -> P (q + 1)%Z) -> - forall q : Z, (p <= q)%Z -> P q. -Proof. - intros F p. - intro. - intro. - cut (forall q : Z, (p <= q)%Z -> {k : nat | q = (p + k)%Z}). - intro. - cut (forall k : nat, F (p + k)%Z). - intro. - intros. - cut {k : nat | q = (p + Z_of_nat k)%Z}. - intro. - case H4. - intros. - rewrite e. - apply H2. - apply H1. - assumption. - intro. - induction k as [| k Hreck]. - simpl in |- *. - rewrite Zplus_0_r. - assumption. - replace (p + Z_of_nat (S k))%Z with (p + k + 1)%Z. - apply H0. - apply Zplus_le_reg_l with (p := (- p)%Z). - replace (- p + p)%Z with (Z_of_nat 0). - replace (- p + (p + Z_of_nat k))%Z with (Z_of_nat k). - apply Znat.inj_le. - apply Nat.le_0_l. - rewrite Zplus_assoc; rewrite Zplus_opp_l; reflexivity. - rewrite Zplus_opp_l; reflexivity. - assumption. - rewrite (Znat.inj_S k). - unfold Z.succ in |- *. - apply Zplus_assoc_reverse. - intros. - cut {k : nat | (q - p)%Z = Z_of_nat k}. - intro H2. - case H2. - intro k. - intros. - exists k. - apply Zplus_reg_l with (n := (- p)%Z). - replace (- p + q)%Z with (q - p)%Z. - rewrite e. - rewrite Zplus_assoc; rewrite Zplus_opp_l; reflexivity. - unfold Zminus in |- *. - apply Zplus_comm. - apply Z_of_nat_complete_inf. - unfold Zminus in |- *. - apply Zle_left. - assumption. -Qed. - -Lemma Zrec_down : - forall (P : Z -> Set) (p : Z), - P p -> - (forall q : Z, (q <= p)%Z -> P q -> P (q - 1)%Z) -> - forall q : Z, (q <= p)%Z -> P q. -Proof. - intros F p. - intro. - intro. - cut (forall q : Z, (q <= p)%Z -> {k : nat | q = (p - k)%Z}). - intro. - cut (forall k : nat, F (p - k)%Z). - intro. - intros. - cut {k : nat | q = (p - Z_of_nat k)%Z}. - intro. - case H4. - intros. - rewrite e. - apply H2. - apply H1. - assumption. - intro. - induction k as [| k Hreck]. - simpl in |- *. - replace (p - 0)%Z with p. - assumption. - unfold Zminus in |- *. - unfold Z.opp in |- *. - rewrite Zplus_0_r; reflexivity. - replace (p - Z_of_nat (S k))%Z with (p - k - 1)%Z. - apply H0. - apply Zplus_le_reg_l with (p := (- p)%Z). - replace (- p + p)%Z with (- Z_of_nat 0)%Z. - replace (- p + (p - Z_of_nat k))%Z with (- Z_of_nat k)%Z. - apply Z.ge_le. - apply Zge_opp. - apply Znat.inj_le. - apply Nat.le_0_l. - unfold Zminus in |- *; rewrite Zplus_assoc; rewrite Zplus_opp_l; reflexivity. - rewrite Zplus_opp_l; reflexivity. - assumption. - rewrite (Znat.inj_S k). - unfold Z.succ in |- *. - unfold Zminus at 1 2 in |- *. - rewrite Zplus_assoc_reverse. - rewrite <- Zopp_plus_distr. - reflexivity. - intros. - cut {k : nat | (p - q)%Z = Z_of_nat k}. - intro. - case H2. - intro k. - intros. - exists k. - apply Z.opp_inj. - apply Zplus_reg_l with (n := p). - replace (p + - (p - Z_of_nat k))%Z with (Z_of_nat k). - rewrite <- e. - reflexivity. - unfold Zminus in |- *. - rewrite Zopp_plus_distr. - rewrite Zplus_assoc. - rewrite Zplus_opp_r. - rewrite Z.opp_involutive. - reflexivity. - apply Z_of_nat_complete_inf. - unfold Zminus in |- *. - apply Zle_left. - assumption. -Qed. - -Lemma Zind_down : - forall (P : Z -> Prop) (p : Z), - P p -> - (forall q : Z, (q <= p)%Z -> P q -> P (q - 1)%Z) -> - forall q : Z, (q <= p)%Z -> P q. -Proof. - intros F p. - intro. - intro. - cut (forall q : Z, (q <= p)%Z -> exists k : nat, q = (p - k)%Z). - intro. - cut (forall k : nat, F (p - k)%Z). - intro. - intros. - cut (exists k : nat, q = (p - Z_of_nat k)%Z). - intro. - case H4. - intros x e. - rewrite e. - apply H2. - apply H1. - assumption. - intro. - induction k as [| k Hreck]. - simpl in |- *. - replace (p - 0)%Z with p. - assumption. - ring. - replace (p - Z_of_nat (S k))%Z with (p - k - 1)%Z. - apply H0. - apply Zplus_le_reg_l with (p := (- p)%Z). - replace (- p + p)%Z with (- Z_of_nat 0)%Z. - replace (- p + (p - Z_of_nat k))%Z with (- Z_of_nat k)%Z. - apply Z.ge_le. - apply Zge_opp. - apply Znat.inj_le. - apply Nat.le_0_l. - ring. - ring_simplify; auto with arith. - assumption. - rewrite (Znat.inj_S k). - unfold Z.succ in |- *. - ring. - intros. - cut (exists k : nat, (p - q)%Z = Z_of_nat k). - intro. - case H2. - intro k. - intros. - exists k. - apply Z.opp_inj. - apply Zplus_reg_l with (n := p). - replace (p + - (p - Z_of_nat k))%Z with (Z_of_nat k). - rewrite <- H3. - ring. - ring. - apply Z_of_nat_complete. - unfold Zminus in |- *. - apply Zle_left. - assumption. -Qed. - -Lemma Zrec_wf : - forall (P : Z -> Set) (p : Z), - (forall q : Z, (forall r : Z, (p <= r < q)%Z -> P r) -> P q) -> - forall q : Z, (p <= q)%Z -> P q. -Proof. - intros P p WF_ind_step q Hq. - cut (forall x : Z, (p <= x)%Z -> forall y : Z, (p <= y < x)%Z -> P y). - intro. - apply (H (Z.succ q)). - apply Zle_le_succ. - assumption. - - split; [ assumption | exact (Zlt_succ q) ]. - - intros x0 Hx0; generalize Hx0; pattern x0 in |- *. - apply Zrec with (p := p). - intros. - absurd (p <= p)%Z. - apply Zgt_not_le. - apply Zgt_le_trans with (m := y). - apply Z.lt_gt. - elim H. - intros. - assumption. - elim H. - intros. - assumption. - apply Z.le_refl. - - intros. - apply WF_ind_step. - intros. - apply (H0 H). - split. - elim H2. - intros. - assumption. - apply Z.lt_le_trans with y. - elim H2. - intros. - assumption. - apply Zgt_succ_le. - apply Z.lt_gt. - elim H1. - intros. - unfold Z.succ in |- *. - assumption. - assumption. -Qed. - -Lemma Zrec_wf2 : - forall (q : Z) (P : Z -> Set) (p : Z), - (forall q : Z, (forall r : Z, (p <= r < q)%Z -> P r) -> P q) -> - (p <= q)%Z -> P q. -Proof. - intros. - apply Zrec_wf with (p := p). - assumption. - assumption. -Qed. - -Lemma Zrec_wf_double : - forall (P : Z -> Z -> Set) (p0 q0 : Z), - (forall n m : Z, - (forall p q : Z, (q0 <= q)%Z -> (p0 <= p < n)%Z -> P p q) -> - (forall p : Z, (q0 <= p < m)%Z -> P n p) -> P n m) -> - forall p q : Z, (q0 <= q)%Z -> (p0 <= p)%Z -> P p q. -Proof. - intros P p0 q0 Hrec p. - intros. - generalize q H. - pattern p in |- *. - apply Zrec_wf with (p := p0). - intros p1 H1. - intros. - pattern q1 in |- *. - apply Zrec_wf with (p := q0). - intros q2 H3. - apply Hrec. - intros. - apply H1. - assumption. - assumption. - intros. - apply H3. - assumption. - assumption. - assumption. -Qed. - -Lemma Zind_wf : - forall (P : Z -> Prop) (p : Z), - (forall q : Z, (forall r : Z, (p <= r < q)%Z -> P r) -> P q) -> - forall q : Z, (p <= q)%Z -> P q. -Proof. - intros P p WF_ind_step q Hq. - cut (forall x : Z, (p <= x)%Z -> forall y : Z, (p <= y < x)%Z -> P y). - intro. - apply (H (Z.succ q)). - apply Zle_le_succ. - assumption. - - split; [ assumption | exact (Zlt_succ q) ]. - - intros x0 Hx0; generalize Hx0; pattern x0 in |- *. - apply Zind with (p := p). - intros. - absurd (p <= p)%Z. - apply Zgt_not_le. - apply Zgt_le_trans with (m := y). - apply Z.lt_gt. - elim H. - intros. - assumption. - elim H. - intros. - assumption. - apply Z.le_refl. - - intros. - apply WF_ind_step. - intros. - apply (H0 H). - split. - elim H2. - intros. - assumption. - apply Z.lt_le_trans with y. - elim H2. - intros. - assumption. - apply Zgt_succ_le. - apply Z.lt_gt. - elim H1. - intros. - unfold Z.succ in |- *. - assumption. - assumption. -Qed. - -Lemma Zind_wf2 : - forall (q : Z) (P : Z -> Prop) (p : Z), - (forall q : Z, (forall r : Z, (p <= r < q)%Z -> P r) -> P q) -> - (p <= q)%Z -> P q. -Proof. - intros. - apply Zind_wf with (p := p). - assumption. - assumption. -Qed. - -Lemma Zind_wf_double : - forall (P : Z -> Z -> Prop) (p0 q0 : Z), - (forall n m : Z, - (forall p q : Z, (q0 <= q)%Z -> (p0 <= p < n)%Z -> P p q) -> - (forall p : Z, (q0 <= p < m)%Z -> P n p) -> P n m) -> - forall p q : Z, (q0 <= q)%Z -> (p0 <= p)%Z -> P p q. -Proof. - intros P p0 q0 Hrec p. - intros. - generalize q H. - pattern p in |- *. - apply Zind_wf with (p := p0). - intros p1 H1. - intros. - pattern q1 in |- *. - apply Zind_wf with (p := q0). - intros q2 H3. - apply Hrec. - intros. - apply H1. - assumption. - assumption. - intros. - apply H3. - assumption. - assumption. - assumption. -Qed. - -(*###########################################################################*) -(** Properties of Zmax *) -(*###########################################################################*) - -Definition Zmax (n m : Z) := (n + m - Z.min n m)%Z. - -Lemma ZmaxSS : forall n m : Z, (Zmax n m + 1)%Z = Zmax (n + 1) (m + 1). -Proof. - intros. - unfold Zmax in |- *. - replace (Z.min (n + 1) (m + 1)) with (Z.min n m + 1)%Z. - ring. - symmetry in |- *. - change (Z.min (Z.succ n) (Z.succ m) = Z.succ (Z.min n m)) in |- *. - symmetry in |- *. - apply Zmin_SS. -Qed. - -Lemma Zle_max_l : forall n m : Z, (n <= Zmax n m)%Z. -Proof. - intros. - unfold Zmax in |- *. - apply Zplus_le_reg_l with (p := (- n + Z.min n m)%Z). - ring_simplify (- n + Z.min n m + n)%Z. - ring_simplify (- n + Z.min n m + (n + m - Z.min n m))%Z. - apply Z.le_min_r. -Qed. - -Lemma Zle_max_r : forall n m : Z, (m <= Zmax n m)%Z. -Proof. - intros. - unfold Zmax in |- *. - apply Zplus_le_reg_l with (p := (- m + Z.min n m)%Z). - ring_simplify (- m + Z.min n m + m)%Z. - ring_simplify (- m + Z.min n m + (n + m - Z.min n m))%Z. - apply Z.le_min_l. -Qed. - - -Lemma Zmin_or_informative : forall n m : Z, {Z.min n m = n} + {Z.min n m = m}. -Proof. - intros. - case (Z_lt_ge_dec n m). - unfold Z.min in |- *. - unfold Z.lt in |- *. - intro z. - rewrite z. - left. - reflexivity. - intro. - cut ({(n > m)%Z} + {n = m :>Z}). - intro. - case H. - intros z0. - unfold Z.min in |- *. - unfold Z.gt in z0. - rewrite z0. - right. - reflexivity. - intro. - rewrite e. - right. - apply Zmin_n_n. - cut ({(m < n)%Z} + {m = n :>Z}). - intro. - elim H. - intro. - left. - apply Z.lt_gt. - assumption. - intro. - right. - symmetry in |- *. - assumption. - apply Z_le_lt_eq_dec. - apply Z.ge_le. - assumption. -Qed. - -Lemma Zmax_case : forall (n m : Z) (P : Z -> Set), P n -> P m -> P (Zmax n m). -Proof. - intros. - unfold Zmax in |- *. - case Zmin_or_informative with (n := n) (m := m). - intro. - rewrite e. - cut ((n + m - n)%Z = m). - intro. - rewrite H1. - assumption. - ring. - intro. - rewrite e. - cut ((n + m - m)%Z = n). - intro. - rewrite H1. - assumption. - ring. -Qed. - -Lemma Zmax_or_informative : forall n m : Z, {Zmax n m = n} + {Zmax n m = m}. -Proof. - intros. - unfold Zmax in |- *. - case Zmin_or_informative with (n := n) (m := m). - intro. - rewrite e. - right. - ring. - intro. - rewrite e. - left. - ring. -Qed. - -Lemma Zmax_n_n : forall n : Z, Zmax n n = n. -Proof. - intros. - unfold Zmax in |- *. - rewrite (Zmin_n_n n). - ring. -Qed. - -Local Hint Resolve ZmaxSS Zle_max_r Zle_max_l Zmax_n_n: zarith. - -(*###########################################################################*) -(** Properties of Arity *) -(*###########################################################################*) - -Lemma Zeven_S : forall x : Z, Zeven.Zodd x -> Zeven.Zeven (x + 1). -Proof. - exact Zeven.Zeven_Sn. -Qed. - -Lemma Zeven_pred : forall x : Z, Zeven.Zodd x -> Zeven.Zeven (x - 1). -Proof. - exact Zeven.Zeven_pred. -Qed. - -(* This lemma used to be useful since it was mentioned with an unnecessary premise - `x>=0` as Z_modulo_2 in ZArith, but the ZArith version has been fixed. *) - -Definition Z_modulo_2_always : - forall x : Z, {y : Z | x = (2 * y)%Z} + {y : Z | x = (2 * y + 1)%Z} := - Zeven.Z_modulo_2. - -(*###########################################################################*) -(** Properties of Zdiv *) -(*###########################################################################*) - -Lemma Z_div_mod_eq_2 : - forall a b : Z, (0 < b)%Z -> (b * (a / b))%Z = (a - a mod b)%Z. -Proof. - intros. - apply Zplus_minus_eq. - rewrite Zplus_comm. - apply Z_div_mod_eq_full. -Qed. - -Lemma Z_div_le : - forall a b c : Z, (0 < c)%Z -> (b <= a)%Z -> (b / c <= a / c)%Z. -Proof. - intros. - apply Z.ge_le. - apply Z_div_ge; Flip; assumption. -Qed. - -Lemma Z_div_nonneg : - forall a b : Z, (0 < b)%Z -> (0 <= a)%Z -> (0 <= a / b)%Z. -Proof. - intros. - apply Z.ge_le. - apply Z_div_ge0; Flip; assumption. -Qed. - -Lemma Z_div_neg : forall a b : Z, (0 < b)%Z -> (a < 0)%Z -> (a / b < 0)%Z. -Proof. - intros. - rewrite (Z_div_mod_eq_full a b) in H0. - elim (Z_mod_lt a b). - intros H1 _. - apply Znot_ge_lt. - intro. - apply (Zlt_not_le (b * (a / b) + a mod b) 0 H0). - apply Zplus_le_0_compat. - apply Zmult_le_0_compat. - apply Zlt_le_weak; assumption. - Flip. - assumption. - Flip. -Qed. - -Local Hint Resolve Z_div_mod_eq_2 Z_div_le Z_div_nonneg Z_div_neg: zarith. - -(*###########################################################################*) -(** Properties of Zpower *) -(*###########################################################################*) - -Lemma Zpower_1 : forall a : Z, (a ^ 1)%Z = a. -Proof. - intros; unfold Zpower in |- *; unfold Zpower_pos in |- *; simpl in |- *; - auto with zarith. -Qed. - -Lemma Zpower_2 : forall a : Z, (a ^ 2)%Z = (a * a)%Z. -Proof. - intros; unfold Zpower in |- *; unfold Zpower_pos in |- *; simpl in |- *; - ring. -Qed. - -Local Hint Resolve Zpower_1 Zpower_2: zarith. diff --git a/stdlib/test-suite/success/Abstract.v b/stdlib/test-suite/success/Abstract.v deleted file mode 100644 index f69d5e81cfd3..000000000000 --- a/stdlib/test-suite/success/Abstract.v +++ /dev/null @@ -1,25 +0,0 @@ -(* Cf BZ#546 *) - -From Stdlib Require Import Lia. - -Section S. - -Variables n m : nat. -Variable H : n Set := -| Dummy0 : Dummy 0 -| Dummy2 : Dummy 2 -| DummyApp : forall i j, Dummy i -> Dummy j -> Dummy (i+j). - -Definition Bug : Dummy (2*n). -Proof. -induction n. - simpl ; apply Dummy0. - replace (2 * S n0) with (2*n0 + 2) ; auto with arith. - apply DummyApp. - 2:exact Dummy2. - apply IHn0 ; abstract lia. -Defined. - -End S. diff --git a/stdlib/test-suite/success/DiscrR.v b/stdlib/test-suite/success/DiscrR.v deleted file mode 100644 index 8147a103281f..000000000000 --- a/stdlib/test-suite/success/DiscrR.v +++ /dev/null @@ -1,41 +0,0 @@ -From Stdlib Require Import Reals. -From Stdlib Require Import DiscrR. - -Lemma ex0 : 1%R <> 0%R. -Proof. - discrR. -Qed. - -Lemma ex1 : 0%R <> 2%R. -Proof. - discrR. -Qed. -Lemma ex2 : 4%R <> 3%R. -Proof. - discrR. -Qed. - -Lemma ex3 : 3%R <> 5%R. -Proof. - discrR. -Qed. - -Lemma ex4 : (-1)%R <> 0%R. -Proof. - discrR. -Qed. - -Lemma ex5 : (-2)%R <> (-3)%R. -Proof. - discrR. -Qed. - -Lemma ex6 : 8%R <> (-3)%R. -Proof. - discrR. -Qed. - -Lemma ex7 : (-8)%R <> 3%R. -Proof. - discrR. -Qed. diff --git a/stdlib/test-suite/success/EquivDec.v b/stdlib/test-suite/success/EquivDec.v deleted file mode 100644 index 1a7ce5ad2594..000000000000 --- a/stdlib/test-suite/success/EquivDec.v +++ /dev/null @@ -1,6 +0,0 @@ -From Stdlib Require Import EquivDec. - -Example test_None_eqb_None: None ==b None = true. Proof. reflexivity. Qed. -Example test_None_eqb_Some: None ==b Some true = false. Proof. reflexivity. Qed. -Example test_Some_eqb_Some: Some 1 ==b Some 1 = true. Proof. reflexivity. Qed. -Example test_Some_neqb_Some: Some 0 ==b Some 1 = false. Proof. reflexivity. Qed. diff --git a/stdlib/test-suite/success/Field.v b/stdlib/test-suite/success/Field.v deleted file mode 100644 index ade124caa3ca..000000000000 --- a/stdlib/test-suite/success/Field.v +++ /dev/null @@ -1,97 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* R) (x0 x1 : R), -(f x1 - f x0) * (1 / (x1 - x0)) + (g x1 - g x0) * (1 / (x1 - x0)) = -(f x1 + g x1 - (f x0 + g x0)) * (1 / (x1 - x0)). -Proof. - intros. - field. -Abort. - -(* Example 3 *) -Goal forall a b : R, 1 / (a * b) * (1 / (1 / b)) = 1 / a. -Proof. - intros. - field. -Abort. - -Goal forall a b : R, 1 / (a * b) * (1 / 1 / b) = 1 / a. -Proof. - intros. - field_simplify_eq. -Abort. - -Goal forall a b : R, 1 / (a * b) * (1 / 1 / b) = 1 / a. -Proof. - intros. - field_simplify (1 / (a * b) * (1 / 1 / b)). -Abort. - -(* Example 4 *) -Goal -forall a b : R, a <> 0 -> b <> 0 -> 1 / (a * b) / (1 / b) = 1 / a. -Proof. - intros. - field; auto. -Qed. - -(* Example 5 *) -Goal forall a : R, 1 = 1 * (1 / a) * a. -Proof. - intros. - field. -Abort. - -(* Example 6 *) -Goal forall a b : R, b = b * / a * a. -Proof. - intros. - field. -Abort. - -(* Example 7 *) -Goal forall a b : R, b = b * (1 / a) * a. -Proof. - intros. - field. -Abort. - -(* Example 8 *) -Goal forall x y : R, - x * (1 / x + x / (x + y)) = - - (1 / y) * y * (- (x * (x / (x + y))) - 1). -Proof. - intros. - field. -Abort. - -(* Example 9 *) -Goal forall a b : R, 1 / (a * b) * (1 / 1 / b) = 1 / a -> False. -Proof. -intros. -field_simplify_eq in H. -Abort. diff --git a/stdlib/test-suite/success/Funind.v b/stdlib/test-suite/success/Funind.v deleted file mode 100644 index 6f64a9947e61..000000000000 --- a/stdlib/test-suite/success/Funind.v +++ /dev/null @@ -1,523 +0,0 @@ -From Stdlib Require Import FunInd. - -Definition iszero (n : nat) : bool := - match n with - | O => true - | _ => false - end. - -Functional Scheme iszero_ind := Induction for iszero Sort Prop. - -Lemma toto : forall n : nat, n = 0 -> iszero n = true. -intros x eg. - functional induction iszero x; simpl. -trivial. -inversion eg. -Qed. - - -Function ftest (n m : nat) : nat := - match n with - | O => match m with - | O => 0 - | _ => 1 - end - | S p => 0 - end. -(* MS: FIXME: apparently can't define R_ftest_complete. Rest of the file goes through. *) - -Lemma test1 : forall n m : nat, ftest n m <= 2. -intros n m. - functional induction ftest n m; auto. -Qed. - -Lemma test2 : forall m n, ~ 2 = ftest n m. -Proof. -intros n m;intro H. -functional inversion H ftest. -Qed. - -Lemma test3 : forall n m, ftest n m = 0 -> (n = 0 /\ m = 0) \/ n <> 0. -Proof. -functional inversion 1 ftest;auto. -Qed. - - -From Stdlib Require Import Arith. -Lemma test11 : forall m : nat, ftest 0 m <= 2. -intros m. - functional induction ftest 0 m. -auto. -auto. -auto with *. -Qed. - -Function lamfix (m n : nat) {struct n } : nat := - match n with - | O => m - | S p => lamfix m p - end. - -(* Parameter v1 v2 : nat. *) - -Lemma lamfix_lem : forall v1 v2 : nat, lamfix v1 v2 = v1. -intros v1 v2. - functional induction lamfix v1 v2. -trivial. -assumption. -Defined. - - - -(* polymorphic function *) -From Stdlib Require Import List. - -Functional Scheme app_ind := Induction for app Sort Prop. - -Lemma appnil : forall (A : Set) (l l' : list A), l' = nil -> l = l ++ l'. -intros A l l'. - functional induction app l l'; intuition. - rewrite <- H0; trivial. -Qed. - - - - - -From Stdlib Require Export Arith. - - -Function trivfun (n : nat) : nat := - match n with - | O => 0 - | S m => trivfun m - end. - - -(* essaie de parametre variables non locaux:*) - -Parameter varessai : nat. - -Lemma first_try : trivfun varessai = 0. - functional induction trivfun varessai. -trivial. -assumption. -Defined. - - - Functional Scheme triv_ind := Induction for trivfun Sort Prop. - -Lemma bisrepetita : forall n' : nat, trivfun n' = 0. -intros n'. - functional induction trivfun n'. -trivial. -assumption. -Qed. - - - - - - - -Function iseven (n : nat) : bool := - match n with - | O => true - | S (S m) => iseven m - | _ => false - end. - - -Function funex (n : nat) : nat := - match iseven n with - | true => n - | false => match n with - | O => 0 - | S r => funex r - end - end. - - -Function nat_equal_bool (n m : nat) {struct n} : bool := - match n with - | O => match m with - | O => true - | _ => false - end - | S p => match m with - | O => false - | S q => nat_equal_bool p q - end - end. - - -From Stdlib Require Import Nat. -Functional Scheme div2_ind := Induction for Nat.div2 Sort Prop. -Lemma div2_inf : forall n : nat, Nat.div2 n <= n. -intros n. - functional induction Nat.div2 n. -auto. -auto. - -apply le_S. -apply le_n_S. -exact IHn0. -Qed. - -(* reuse this lemma as a scheme:*) - -Function nested_lam (n : nat) : nat -> nat := - match n with - | O => fun m : nat => 0 - | S n' => fun m : nat => m + nested_lam n' m - end. - - -Lemma nest : forall n m : nat, nested_lam n m = n * m. -intros n m. - functional induction nested_lam n m; simpl;auto. -Qed. - - -Function essai (x : nat) (p : nat * nat) {struct x} : nat := - let (n, m) := (p: nat*nat) in - match n with - | O => 0 - | S q => match x with - | O => 1 - | S r => S (essai r (q, m)) - end - end. - -Lemma essai_essai : - forall (x : nat) (p : nat * nat), let (n, m) := p in 0 < n -> 0 < essai x p. -intros x p. - functional induction essai x p; intros. -inversion H. -auto with arith. - auto with arith. -Qed. - -Function plus_x_not_five'' (n m : nat) {struct n} : nat := - let x := nat_equal_bool m 5 in - let y := 0 in - match n with - | O => y - | S q => - let recapp := plus_x_not_five'' q m in - match x with - | true => S recapp - | false => S recapp - end - end. - -Lemma notplusfive'' : forall x y : nat, y = 5 -> plus_x_not_five'' x y = x. -intros a b. - functional induction plus_x_not_five'' a b; intros hyp; simpl; auto. -Qed. - -Lemma iseq_eq : forall n m : nat, n = m -> nat_equal_bool n m = true. -intros n m. - functional induction nat_equal_bool n m; simpl; intros hyp; auto. -rewrite <- hyp in y; simpl in y;tauto. -inversion hyp. -Qed. - -Lemma iseq_eq' : forall n m : nat, nat_equal_bool n m = true -> n = m. -intros n m. - functional induction nat_equal_bool n m; simpl; intros eg; auto. -inversion eg. -inversion eg. -Qed. - - -Inductive istrue : bool -> Prop := - istrue0 : istrue true. - -Functional Scheme add_ind := Induction for add Sort Prop. - -Lemma inf_x_plusxy' : forall x y : nat, x <= x + y. -intros n m. - functional induction add n m; intros. -auto with arith. -auto with arith. -Qed. - - -Lemma inf_x_plusxy'' : forall x : nat, x <= x + 0. -intros n. -unfold plus. - functional induction plus n 0; intros. -auto with arith. -apply le_n_S. -assumption. -Qed. - -Lemma inf_x_plusxy''' : forall x : nat, x <= 0 + x. -intros n. - functional induction plus 0 n; intros; auto with arith. -Qed. - -Function mod2 (n : nat) : nat := - match n with - | O => 0 - | S (S m) => S (mod2 m) - | _ => 0 - end. - -Lemma princ_mod2 : forall n : nat, mod2 n <= n. -intros n. - functional induction mod2 n; simpl; auto with arith. -Qed. - -Function isfour (n : nat) : bool := - match n with - | S (S (S (S O))) => true - | _ => false - end. - -Function isononeorfour (n : nat) : bool := - match n with - | S O => true - | S (S (S (S O))) => true - | _ => false - end. - -Lemma toto'' : forall n : nat, istrue (isfour n) -> istrue (isononeorfour n). -intros n. - functional induction isononeorfour n; intros istr; simpl; - inversion istr. -apply istrue0. -destruct n. inversion istr. -destruct n. tauto. -destruct n. inversion istr. -destruct n. inversion istr. -destruct n. tauto. -simpl in *. inversion H0. -Qed. - -Lemma toto' : forall n m : nat, n = 4 -> istrue (isononeorfour n). -intros n. - functional induction isononeorfour n; intros m istr; inversion istr. -apply istrue0. -rewrite H in y; simpl in y;tauto. -Qed. - -Function ftest4 (n m : nat) : nat := - match n with - | O => match m with - | O => 0 - | S q => 1 - end - | S p => match m with - | O => 0 - | S r => 1 - end - end. - -Lemma test4 : forall n m : nat, ftest n m <= 2. -intros n m. - functional induction ftest n m; auto with arith. -Qed. - -Lemma test4' : forall n m : nat, ftest4 (S n) m <= 2. -intros n m. -assert ({n0 | n0 = S n}). -exists (S n);reflexivity. -destruct H as [n0 H1]. -rewrite <- H1;revert H1. - functional induction ftest4 n0 m. -inversion 1. -inversion 1. - -auto with arith. -auto with arith. -Qed. - -Function ftest44 (x : nat * nat) (n m : nat) : nat := - let (p, q) := (x: nat*nat) in - match n with - | O => match m with - | O => 0 - | S q => 1 - end - | S p => match m with - | O => 0 - | S r => 1 - end - end. - -Lemma test44 : - forall (pq : nat * nat) (n m o r s : nat), ftest44 pq n (S m) <= 2. -intros pq n m o r s. - functional induction ftest44 pq n (S m). -auto with arith. -auto with arith. -auto with arith. -auto with arith. -Qed. - -Function ftest2 (n m : nat) {struct n} : nat := - match n with - | O => match m with - | O => 0 - | S q => 0 - end - | S p => ftest2 p m - end. - -Lemma test2' : forall n m : nat, ftest2 n m <= 2. -intros n m. - functional induction ftest2 n m; simpl; intros; auto. -Qed. - -Function ftest3 (n m : nat) {struct n} : nat := - match n with - | O => 0 - | S p => match m with - | O => ftest3 p 0 - | S r => 0 - end - end. - -Lemma test3' : forall n m : nat, ftest3 n m <= 2. -intros n m. - functional induction ftest3 n m. -intros. -auto. -intros. -auto. -intros. -simpl. -auto. -Qed. - -Function ftest5 (n m : nat) {struct n} : nat := - match n with - | O => 0 - | S p => match m with - | O => ftest5 p 0 - | S r => ftest5 p r - end - end. - -Lemma test5 : forall n m : nat, ftest5 n m <= 2. -intros n m. - functional induction ftest5 n m. -intros. -auto. -intros. -auto. -intros. -simpl. -auto. -Qed. - -Function ftest7 (n : nat) : nat := - match ftest5 n 0 with - | O => 0 - | S r => 0 - end. - -Lemma essai7 : - forall (Hrec : forall n : nat, ftest5 n 0 = 0 -> ftest7 n <= 2) - (Hrec0 : forall n r : nat, ftest5 n 0 = S r -> ftest7 n <= 2) - (n : nat), ftest7 n <= 2. -intros hyp1 hyp2 n. - functional induction ftest7 n; auto. -Qed. - -Function ftest6 (n m : nat) {struct n} : nat := - match n with - | O => 0 - | S p => match ftest5 p 0 with - | O => ftest6 p 0 - | S r => ftest6 p r - end - end. - - -Lemma princ6 : - (forall n m : nat, n = 0 -> ftest6 0 m <= 2) -> - (forall n m p : nat, - ftest6 p 0 <= 2 -> ftest5 p 0 = 0 -> n = S p -> ftest6 (S p) m <= 2) -> - (forall n m p r : nat, - ftest6 p r <= 2 -> ftest5 p 0 = S r -> n = S p -> ftest6 (S p) m <= 2) -> - forall x y : nat, ftest6 x y <= 2. -intros hyp1 hyp2 hyp3 n m. -generalize hyp1 hyp2 hyp3. -clear hyp1 hyp2 hyp3. - functional induction ftest6 n m; auto. -Qed. - -Lemma essai6 : forall n m : nat, ftest6 n m <= 2. -intros n m. - functional induction ftest6 n m; simpl; auto. -Qed. - -(* Some tests with modules *) -Module M. -Function test_m (n:nat) : nat := - match n with - | 0 => 0 - | S n => S (S (test_m n)) - end. - -Lemma test_m_is_double : forall n, div2 (test_m n) = n. -Proof. -intros n. -functional induction (test_m n). -reflexivity. -simpl;rewrite IHn0;reflexivity. -Qed. -End M. -(* We redefine a new Function with the same name *) -Function test_m (n:nat) : nat := - pred n. - -Lemma test_m_is_pred : forall n, test_m n = pred n. -Proof. -intro n. -functional induction (test_m n). (* the test_m_ind to use is the last defined saying that test_m = pred*) -reflexivity. -Qed. - -(* Checks if the dot notation are correctly treated in infos *) -Lemma M_test_m_is_double : forall n, div2 (M.test_m n) = n. -intro n. -(* here we should apply M.test_m_ind *) -functional induction (M.test_m n). -reflexivity. -simpl;rewrite IHn0;reflexivity. -Qed. - -Import M. -(* Now test_m is the one which defines double *) - -Lemma test_m_is_double : forall n, div2 (M.test_m n) = n. -intro n. -(* here we should apply M.test_m_ind *) -functional induction (test_m n). -reflexivity. -simpl;rewrite IHn0;reflexivity. -Qed. - -(* An example with projections *) - -From Stdlib Require Import FunInd. -From Stdlib Require Import List. - -Record foo (X:Type):= {a:nat; b:X}. - -Inductive ind X: Type := -| C: foo X -> ind X -| D: ind X -> ind X. - -Function f X (deflt:X) (x:ind X) {struct x} := - match x with - @C _ fo => match fo.(a X) with - O => fo.(b X) - | S n => deflt - end - | D _ d => f _ deflt d - end. diff --git a/stdlib/test-suite/success/Injection.v b/stdlib/test-suite/success/Injection.v deleted file mode 100644 index 5b0f581487a3..000000000000 --- a/stdlib/test-suite/success/Injection.v +++ /dev/null @@ -1,178 +0,0 @@ -From Stdlib Require Eqdep_dec. - -(* Check the behaviour of Injection *) - -(* Check that Injection tries Intro until *) - -Unset Structural Injection. -Lemma l1 : forall x : nat, S x = S (S x) -> False. - injection 1. -apply n_Sn. -Qed. - -Lemma l2 : forall (x : nat) (H : S x = S (S x)), H = H -> False. - injection H. -intros. -apply (n_Sn x H0). -Qed. - -(* Check that no tuple needs to be built *) -Lemma l3 : - forall x y : nat, - existT (fun n : nat => {n = n} + {n = n}) x (left _ (refl_equal x)) = - existT (fun n : nat => {n = n} + {n = n}) y (left _ (refl_equal y)) -> - x = y. -intros x y H. - injection H. -exact (fun H => H). -Qed. - -(* Check that a tuple is built (actually the same as the initial one) *) -Lemma l4 : - forall p1 p2 : {0 = 0} + {0 = 0}, - existT (fun n : nat => {n = n} + {n = n}) 0 p1 = - existT (fun n : nat => {n = n} + {n = n}) 0 p2 -> - existT (fun n : nat => {n = n} + {n = n}) 0 p1 = - existT (fun n : nat => {n = n} + {n = n}) 0 p2. -intros. - injection H. -exact (fun H => H). -Qed. -Set Structural Injection. - -(* Test injection as *) - -Lemma l5 : forall x y z t : nat, (x,y) = (z,t) -> x=z. -intros; injection H as Hxz Hyt. -exact Hxz. -Qed. - -(* Check the variants of injection *) - -Goal forall x y, S x = S y -> True. -injection 1 as H'. -Undo. -intros. -injection H as H'. -Undo. -Ltac f x := injection x. -f H. -Abort. - -Goal (forall x y : nat, x = y -> S x = S y) -> True. -intros. -try injection (H O) || exact I. -Qed. - -Goal (forall x y : nat, x = y -> S x = S y) -> True. -intros. -einjection (H O). -2:instantiate (1:=O). -Abort. - -Goal (forall x y : nat, x = y -> S x = S y) -> True. -intros. -einjection (H O ?[y]) as H0. -instantiate (y:=O). -Abort. - -(* Test the injection intropattern *) - -Goal forall (a b:nat) l l', cons a l = cons b l' -> a=b. -intros * [= H1 H2]. -exact H1. -Qed. - -(* Test injection using K, knowing that an equality is decidable *) -(* Basic case, using sigT *) - -Scheme Equality for nat. -Unset Structural Injection. -Goal forall n:nat, forall P:nat -> Type, forall H1 H2:P n, - existT P n H1 = existT P n H2 -> H1 = H2. -intros. -injection H. -intro H0. exact H0. -Abort. -Set Structural Injection. - -Goal forall n:nat, forall P:nat -> Type, forall H1 H2:P n, - existT P n H1 = existT P n H2 -> H1 = H2. -intros. -injection H as H0. -exact H0. -Abort. - -(* Test injection using K, knowing that an equality is decidable *) -(* Basic case, using sigT, with "as" clause *) - -Goal forall n:nat, forall P:nat -> Type, forall H1 H2:P n, - existT P n H1 = existT P n H2 -> H1 = H2. -intros. -injection H as H. -exact H. -Abort. - -(* Test injection using K, knowing that an equality is decidable *) -(* Dependent case not directly exposing sigT *) - -Inductive my_sig (A : Type) (P : A -> Type) : Type := - my_exist : forall x : A, P x -> my_sig A P. - -Goal forall n:nat, forall P:nat -> Type, forall H1 H2:P n, - my_exist _ _ n H1 = my_exist _ _ n H2 -> H1 = H2. -intros. -injection H as H. -exact H. -Abort. - -(* Test injection using K, knowing that an equality is decidable *) -(* Dependent case not directly exposing sigT deeply nested *) - -Goal forall n:nat, forall P:nat -> Type, forall H1 H2:P n, - (my_exist _ _ n H1,0) = (my_exist _ _ n H2,0) -> H1 = H2. -intros * [= H]. -exact H. -Abort. - -(* Test the Keep Proof Equalities option. *) -Set Keep Proof Equalities. -Unset Structural Injection. - -Inductive pbool : Prop := Pbool1 | Pbool2. - -Inductive pbool_shell : Set := Pbsc : pbool -> pbool_shell. - -Goal Pbsc Pbool1 = Pbsc Pbool2 -> True. -injection 1. -match goal with - |- Pbool1 = Pbool2 -> True => idtac | |- True => fail -end. -Abort. - -(* Injection in the presence of local definitions *) -Inductive A := B (T := unit) (x y : bool) (z := x). -Goal forall x y x' y', B x y = B x' y' -> y = y'. -intros * [= H1 H2]. -exact H2. -Qed. - -(* Injection does not project at positions in Prop... allow it? - -Inductive t (A:Prop) : Set := c : A -> t A. -Goal forall p q : True\/True, c _ p = c _ q -> False. -intros. -injection H. -Abort. - -*) - -(* Injection does not project on discriminable positions... allow it? - -Goal 1=2 -> 1=0. -intro H. -injection H. -intro; assumption. -Qed. - -*) diff --git a/stdlib/test-suite/success/LraTest.v b/stdlib/test-suite/success/LraTest.v deleted file mode 100644 index ba6f5998a013..000000000000 --- a/stdlib/test-suite/success/LraTest.v +++ /dev/null @@ -1,14 +0,0 @@ -From Stdlib Require Import Reals. -From Stdlib Require Import Lra. - -Open Scope R_scope. - -Lemma l1 : forall x y z : R, Rabs (x - z) <= Rabs (x - y) + Rabs (y - z). -intros; split_Rabs; lra. -Qed. - -Lemma l2 : - forall x y : R, x < Rabs y -> y < 1 -> x >= 0 -> - y <= 1 -> Rabs x <= 1. -intros. -split_Rabs; lra. -Qed. diff --git a/stdlib/test-suite/success/MatchFail.v b/stdlib/test-suite/success/MatchFail.v deleted file mode 100644 index 55483d0c1969..000000000000 --- a/stdlib/test-suite/success/MatchFail.v +++ /dev/null @@ -1,29 +0,0 @@ -From Stdlib Require Export ZArith. -From Stdlib Require Export ZArithRing. - -(* Cette tactique a pour objectif de remplacer toute instance - de (POS (xI e)) ou de (POS (xO e)) par - 2*(POS e)+1 ou 2*(POS e), pour rendre les expressions plus - Ć  mĆŖme d'ĆŖtre utilisĆ©es par Ring, lorsque ces expressions contiennent - des variables de type positive. *) -Ltac compute_POS := - match goal with - | |- context [(Zpos (xI ?X1))] => - let v := constr:(X1) in - match constr:(v) with - | 1%positive => fail 1 - | _ => rewrite (BinInt.Pos2Z.inj_xI v) - end - | |- context [(Zpos (xO ?X1))] => - let v := constr:(X1) in - match constr:(v) with - | 1%positive => fail 1 - | _ => rewrite (BinInt.Pos2Z.inj_xO v) - end - end. - -Goal forall x : positive, Zpos (xI (xI x)) = (4 * Zpos x + 3)%Z. -intros. -repeat compute_POS. - ring. -Qed. diff --git a/stdlib/test-suite/success/NatRing.v b/stdlib/test-suite/success/NatRing.v deleted file mode 100644 index d17d72c9a05c..000000000000 --- a/stdlib/test-suite/success/NatRing.v +++ /dev/null @@ -1,10 +0,0 @@ -From Stdlib Require Import ArithRing. - -Lemma l1 : 2 = 1 + 1. -ring. -Qed. - -Lemma l2 : forall x : nat, S (S x) = 1 + S x. -intro. -ring. -Qed. diff --git a/stdlib/test-suite/success/Nia.v b/stdlib/test-suite/success/Nia.v deleted file mode 100644 index 45657f363db0..000000000000 --- a/stdlib/test-suite/success/Nia.v +++ /dev/null @@ -1,673 +0,0 @@ -(* -*- coqchk-prog-args: ("-bytecode-compiler" "yes") -*- *) -From Stdlib Require Import ZArith. -From Stdlib Require Import Lia. -Open Scope Z_scope. - -(** Add [Z.to_euclidean_division_equations] to the end of [zify], just for this - file. *) -From Stdlib Require Zify. -Ltac Zify.zify_post_hook ::= Z.to_euclidean_division_equations. - -Lemma Z_zerop_or x : x = 0 \/ x <> 0. Proof. apply Z.eq_decidable. Qed. -Lemma Z_eq_dec_or (x y : Z) : x = y \/ x <> y. Proof. apply Z.eq_decidable. Qed. - -Ltac with_mod tac := - match goal with - | [ |- context[?x mod ?y] ] => tac x y - | [ H : context[?x mod ?y] |- _ ] => tac x y - end. - -Ltac with_rem tac := - match goal with - | [ |- context[Z.rem ?x ?y] ] => tac x y - | [ H : context[Z.rem ?x ?y] |- _ ] => tac x y - end. - -Ltac with_div tac := - match goal with - | [ |- context[?x / ?y] ] => tac x y - | [ H : context[?x / ?y] |- _ ] => tac x y - end. - -Ltac with_quot tac := - match goal with - | [ |- context[Z.quot ?x ?y] ] => tac x y - | [ H : context[Z.quot ?x ?y] |- _ ] => tac x y - end. - -Ltac with_mod_rem tac := first [ with_mod tac | with_rem tac ]. -Ltac with_div_quot tac := first [ with_div tac | with_quot tac ]. -Ltac with_div_mod tac := first [ with_div tac | with_mod tac ]. -Ltac with_quot_rem tac := first [ with_quot tac | with_rem tac ]. - -Ltac pose_eq_fact x y := Z.euclidean_division_equations_pose_eq_fact x y. - -Ltac saturate_mod_div_0 := - repeat first [ with_mod_rem ltac:(fun x y => pose_eq_fact (x / y) 0) - | with_div_quot ltac:(fun x y => pose_eq_fact y 0) ]. -Ltac saturate_quot_div_0 := - repeat first [ with_quot ltac:(fun x y => pose_eq_fact (x Ć· y) 0) - | with_div ltac:(fun x y => pose_eq_fact (x / y) 0) ]. -Ltac saturate_mod_div_eq := - let with_the_quot tac := first [ with_div_mod ltac:(fun x y => tac (x / y)) - | with_quot_rem ltac:(fun x y => tac (x Ć· y)) ] in - repeat with_the_quot ltac:(fun q => with_the_quot ltac:(fun q' => pose_eq_fact q q')). - -Ltac destr_step := - match goal with - | [ H : and _ _ |- _ ] => destruct H - | [ H : or _ _ |- _ ] => destruct H - end. - -Ltac t := intros; saturate_mod_div_0; try nia. -Ltac t_zero := intros; saturate_mod_div_0; saturate_quot_div_0; try nia. -(* sometimes this next one is faster? *) -Ltac t_zero_subst := intros; saturate_mod_div_0; saturate_quot_div_0; repeat destr_step; try nia. -Ltac t_eq := intros; saturate_mod_div_eq; try nia. -Ltac t_all := intros; saturate_mod_div_0; saturate_mod_div_eq; try nia. - -Example mod_0_l: forall x : Z, 0 mod x = 0. Proof. t. Qed. -Example mod_0_r: forall x : Z, x mod 0 = x. Proof. intros; nia. Qed. -Example Z_mod_same_full: forall a : Z, a mod a = 0. Proof. t. Qed. -Example Zmod_0_l: forall a : Z, 0 mod a = 0. Proof. t. Qed. -Example Zmod_0_r: forall a : Z, a mod 0 = a. Proof. intros; nia. Qed. -Example mod_mod_same: forall x y : Z, (x mod y) mod y = x mod y. Proof. t. Qed. -Example Zmod_mod: forall a n : Z, (a mod n) mod n = a mod n. Proof. t. Qed. -Example Zmod_1_r: forall a : Z, a mod 1 = 0. Proof. intros; nia. Qed. -Example Zmod_div: forall a b : Z, a mod b / b = 0. Proof. intros; nia. Qed. -Example Z_mod_1_r: forall a : Z, a mod 1 = 0. Proof. intros; nia. Qed. -Example Z_mod_same: forall a : Z, a > 0 -> a mod a = 0. Proof. t. Qed. -Example Z_mod_mult: forall a b : Z, (a * b) mod b = 0. Proof. intros; nia. Qed. -Example Z_mod_same': forall a : Z, a <> 0 -> a mod a = 0. Proof. t. Qed. -Example Z_mod_0_l: forall a : Z, a <> 0 -> 0 mod a = 0. Proof. t. Qed. -Example Zmod_opp_opp: forall a b : Z, - a mod - b = - (a mod b). Proof. t_eq. Qed. -Example Z_mod_le: forall a b : Z, 0 <= a -> 0 < b -> a mod b <= a. Proof. t. Qed. -Example Zmod_le: forall a b : Z, 0 < b -> 0 <= a -> a mod b <= a. Proof. t. Qed. -Example Zplus_mod_idemp_r: forall a b n : Z, (b + a mod n) mod n = (b + a) mod n. -Proof. - intros a b n. - destruct (Z_zerop n); [ subst; nia | ]. - assert ((b + a mod n) / n = (b / n) + (b mod n + a mod n) / n) - by nia. - assert ((b + a) / n = (b / n) + (a / n) + (b mod n + a mod n) / n) - by nia. - nia. -Qed. -Example Zplus_mod_idemp_l: forall a b n : Z, (a mod n + b) mod n = (a + b) mod n. -Proof. - intros a b n. - destruct (Z_zerop n); [ subst; nia | ]. - assert ((a mod n + b) / n = (b / n) + (b mod n + a mod n) / n) by nia. - assert ((a + b) / n = (b / n) + (a / n) + (b mod n + a mod n) / n) by nia. - nia. -Qed. -Example Z_mod_zero_opp_full: forall a b : Z, a mod b = 0 -> - a mod b = 0. -Proof. - intros a b. - pose proof (Z_eq_dec_or (a/b) (-(-a/b))). - nia. -Qed. -Example Zmult_mod_idemp_r: forall a b n : Z, (b * (a mod n)) mod n = (b * a) mod n. -Proof. - intros a b n. - destruct (Z_zerop n); [ subst; nia | ]. - assert ((b * (a mod n)) / n = (b / n) * (a mod n) + ((b mod n) * (a mod n)) / n) - by nia. - assert ((b * a) / n = (b / n) * (a / n) * n + (b / n) * (a mod n) + (b mod n) * (a / n) + ((b mod n) * (a mod n)) / n) - by nia. - nia. -Qed. -Example Zmult_mod_idemp_l: forall a b n : Z, (a mod n * b) mod n = (a * b) mod n. -Proof. - intros a b n. - destruct (Z_zerop n); [ subst; nia | ]. - assert (((a mod n) * b) / n = (b / n) * (a mod n) + ((b mod n) * (a mod n)) / n) - by nia. - assert ((a * b) / n = (b / n) * (a / n) * n + (b / n) * (a mod n) + (b mod n) * (a / n) + ((b mod n) * (a mod n)) / n) - by nia. - nia. -Qed. -Example Zminus_mod_idemp_r: forall a b n : Z, (a - b mod n) mod n = (a - b) mod n. -Proof. - intros a b n. - destruct (Z_zerop n); [ subst; nia | ]. - assert ((a - b mod n) / n = a / n + ((a mod n) - (b mod n)) / n) by nia. - assert ((a - b) / n = a / n - b / n + ((a mod n) - (b mod n)) / n) by nia. - nia. -Qed. -Example Zminus_mod_idemp_l: forall a b n : Z, (a mod n - b) mod n = (a - b) mod n. -Proof. - intros a b n. - destruct (Z_zerop n); [ subst; nia | ]. - assert ((a mod n - b) / n = - (b / n) + ((a mod n) - (b mod n)) / n) by nia. - assert ((a - b) / n = a / n - b / n + ((a mod n) - (b mod n)) / n) by nia. - nia. -Qed. -Example Z_mod_plus_full: forall a b c : Z, (a + b * c) mod c = a mod c. -Proof. - intros a b c. - pose proof (Z_eq_dec_or ((a+b*c)/c) (a/c + b)). - nia. -Qed. -Example Z_mod_zero_opp_r: forall a b : Z, a mod b = 0 -> a mod - b = 0. -Proof. - intros a b. - pose proof (Z_eq_dec_or (a/b) (-(a/-b))). - nia. -Qed. -Example Zmod_1_l: forall a : Z, 1 < a -> 1 mod a = 1. Proof. t. Qed. -Example Z_mod_1_l: forall a : Z, 1 < a -> 1 mod a = 1. Proof. t. Qed. -Example Z_mod_mul: forall a b : Z, b <> 0 -> (a * b) mod b = 0. Proof. intros; nia. Qed. -Example Zminus_mod: forall a b n : Z, (a - b) mod n = (a mod n - b mod n) mod n. -Proof. - intros a b n. - destruct (Z_zerop n); [ subst; nia | ]. - assert ((a - b) / n = (a / n) - (b / n) + ((a mod n) - (b mod n)) / n) by nia. - nia. -Qed. -Example Zplus_mod: forall a b n : Z, (a + b) mod n = (a mod n + b mod n) mod n. -Proof. - intros a b n. - destruct (Z_zerop n); [ subst; nia | ]. - assert ((a + b) / n = (a / n) + (b / n) + ((a mod n) + (b mod n)) / n) by nia. - nia. -Qed. -Example Zmult_mod: forall a b n : Z, (a * b) mod n = (a mod n * (b mod n)) mod n. -Proof. - intros a b n. - destruct (Z_zerop n); [ subst; nia | ]. - assert ((a * b) / n = n * (a / n) * (b / n) + (a mod n) * (b / n) + (a / n) * (b mod n) + ((a mod n) * (b mod n)) / n) - by nia. - nia. -Qed. -Example Z_mod_mod: forall a n : Z, n <> 0 -> (a mod n) mod n = a mod n. Proof. t. Qed. -Example Z_mod_div: forall a b : Z, b <> 0 -> a mod b / b = 0. Proof. intros; nia. Qed. -Example Z_div_exact_full_1: forall a b : Z, a = b * (a / b) -> a mod b = 0. Proof. intros; nia. Qed. -Example Z_mod_pos_bound: forall a b : Z, 0 < b -> 0 <= a mod b < b. Proof. intros; nia. Qed. -Example Z_mod_sign_mul: forall a b : Z, b <> 0 -> 0 <= a mod b * b. Proof. intros; nia. Qed. -Example Z_mod_neg_bound: forall a b : Z, b < 0 -> b < a mod b <= 0. Proof. intros; nia. Qed. -Example Z_mod_neg: forall a b : Z, b < 0 -> b < a mod b <= 0. Proof. intros; nia. Qed. -Example div_mod_small: forall x y : Z, 0 <= x < y -> x mod y = x. Proof. t. Qed. -Example Zmod_small: forall a n : Z, 0 <= a < n -> a mod n = a. Proof. t. Qed. -Example Z_mod_small: forall a b : Z, 0 <= a < b -> a mod b = a. Proof. t. Qed. -Example Z_div_zero_opp_full: forall a b : Z, a mod b = 0 -> - a / b = - (a / b). Proof. intros; nia. Qed. -Example Z_mod_zero_opp: forall a b : Z, b > 0 -> a mod b = 0 -> - a mod b = 0. -Proof. - intros a b. - pose proof (Z_eq_dec_or (a/b) (-(-a/b))). - nia. -Qed. -Example Z_div_zero_opp_r: forall a b : Z, a mod b = 0 -> a / - b = - (a / b). Proof. intros; nia. Qed. -Example Z_mod_lt: forall a b : Z, b > 0 -> 0 <= a mod b < b. Proof. intros; nia. Qed. -Example Z_mod_opp_opp: forall a b : Z, b <> 0 -> - a mod - b = - (a mod b). Proof. t_eq. Qed. -Example Z_mod_bound_pos: forall a b : Z, 0 <= a -> 0 < b -> 0 <= a mod b < b. Proof. intros; nia. Qed. -Example Z_mod_opp_l_z: forall a b : Z, b <> 0 -> a mod b = 0 -> - a mod b = 0. -Proof. - intros a b. - pose proof (Z_eq_dec_or (a/b) (-(-a/b))). - nia. -Qed. -Example Z_mod_plus: forall a b c : Z, c > 0 -> (a + b * c) mod c = a mod c. -Proof. - intros a b c. - pose proof (Z_eq_dec_or ((a+b*c)/c) (a/c+b)). - nia. -Qed. -Example Z_mod_opp_r_z: forall a b : Z, b <> 0 -> a mod b = 0 -> a mod - b = 0. -Proof. - intros a b. - pose proof (Z_eq_dec_or (a/b) (-(a/-b))). - nia. -Qed. -Example Zmod_eq: forall a b : Z, b > 0 -> a mod b = a - a / b * b. Proof. intros; nia. Qed. -Example Z_div_exact_2: forall a b : Z, b > 0 -> a mod b = 0 -> a = b * (a / b). Proof. intros; nia. Qed. -Example Z_div_mod_eq: forall a b : Z, b > 0 -> a = b * (a / b) + a mod b. Proof. intros; nia. Qed. -Example Z_div_exact_1: forall a b : Z, b > 0 -> a = b * (a / b) -> a mod b = 0. Proof. intros; nia. Qed. -Example Z_mod_add: forall a b c : Z, c <> 0 -> (a + b * c) mod c = a mod c. -Proof. - intros a b c. - pose proof (Z_eq_dec_or ((a+b*c)/c) (a/c+b)). - nia. -Qed. -Example Z_mod_nz_opp_r: forall a b : Z, a mod b <> 0 -> a mod - b = a mod b - b. -Proof. - intros a b. - assert (b <> 0 -> a mod b <> 0 -> a / -b = -(a/b)-1) by t. - nia. -Qed. -Example Z_mul_mod_idemp_l: forall a b n : Z, n <> 0 -> (a mod n * b) mod n = (a * b) mod n. -Proof. - intros a b n ?. - assert (((a mod n) * b) / n = (b / n) * (a mod n) + ((b mod n) * (a mod n)) / n) - by nia. - assert ((a * b) / n = (b / n) * (a / n) * n + (b / n) * (a mod n) + (b mod n) * (a / n) + ((b mod n) * (a mod n)) / n) - by nia. - nia. -Qed. -Example Z_mod_nz_opp_full: forall a b : Z, a mod b <> 0 -> - a mod b = b - a mod b. -Proof. - intros a b. - assert (b <> 0 -> a mod b <> 0 -> -a/b = -1-a/b) by nia. - nia. -Qed. -Example Z_add_mod_idemp_r: forall a b n : Z, n <> 0 -> (a + b mod n) mod n = (a + b) mod n. -Proof. - intros a b n ?. - assert ((a + b mod n) / n = (a / n) + (a mod n + b mod n) / n) by nia. - assert ((a + b) / n = (a / n) + (b / n) + (a mod n + b mod n) / n) by nia. - nia. -Qed. -Example Z_add_mod_idemp_l: forall a b n : Z, n <> 0 -> (a mod n + b) mod n = (a + b) mod n. -Proof. - intros a b n ?. - assert ((a mod n + b) / n = (b / n) + (a mod n + b mod n) / n) by nia. - assert ((a + b) / n = (a / n) + (b / n) + (a mod n + b mod n) / n) by nia. - nia. -Qed. -Example Z_mul_mod_idemp_r: forall a b n : Z, n <> 0 -> (a * (b mod n)) mod n = (a * b) mod n. -Proof. - intros a b n ?. - assert ((a * (b mod n)) / n = (a / n) * (b mod n) + ((a mod n) * (b mod n)) / n) - by nia. - assert ((a * b) / n = (b / n) * (a / n) * n + (b / n) * (a mod n) + (b mod n) * (a / n) + ((a mod n) * (b mod n)) / n) - by nia. - nia. -Qed. -Example Zmod_eq_full: forall a b : Z, b <> 0 -> a mod b = a - a / b * b. Proof. intros; nia. Qed. -Example div_eq: forall x y : Z, y <> 0 -> x mod y = 0 -> x / y * y = x. Proof. intros; nia. Qed. -Example Z_mod_eq: forall a b : Z, b <> 0 -> a mod b = a - b * (a / b). Proof. intros; nia. Qed. -Example Z_mod_sign_nz: forall a b : Z, b <> 0 -> a mod b <> 0 -> Z.sgn (a mod b) = Z.sgn b. Proof. intros; nia. Qed. -Example Z_div_exact_full_2: forall a b : Z, b <> 0 -> a mod b = 0 -> a = b * (a / b). Proof. intros; nia. Qed. -Example Z_div_mod: forall a b : Z, b <> 0 -> a = b * (a / b) + a mod b. Proof. intros; nia. Qed. -Example Z_add_mod: forall a b n : Z, n <> 0 -> (a + b) mod n = (a mod n + b mod n) mod n. -Proof. - intros a b n ?. - assert ((a + b) / n = (a / n) + (b / n) + (a mod n + b mod n) / n) by nia. - nia. -Qed. -Example Z_mul_mod: forall a b n : Z, n <> 0 -> (a * b) mod n = (a mod n * (b mod n)) mod n. -Proof. - intros a b n ?. - assert ((a * b) / n = (b / n) * (a / n) * n + (b / n) * (a mod n) + (b mod n) * (a / n) + ((a mod n) * (b mod n)) / n) - by nia. - nia. -Qed. -Example Z_div_exact: forall a b : Z, b <> 0 -> a = b * (a / b) <-> a mod b = 0. Proof. intros; nia. Qed. -Example Z_div_opp_l_z: forall a b : Z, b <> 0 -> a mod b = 0 -> - a / b = - (a / b). Proof. intros; nia. Qed. -Example Z_div_opp_r_z: forall a b : Z, b <> 0 -> a mod b = 0 -> a / - b = - (a / b). Proof. intros; nia. Qed. -Example Z_mod_opp_r_nz: forall a b : Z, b <> 0 -> a mod b <> 0 -> a mod - b = a mod b - b. -Proof. - intros a b. - assert (b <> 0 -> a mod b <> 0 -> a/(-b) = -1-a/b) by nia. - nia. -Qed. -Example Z_mod_opp_l_nz: forall a b : Z, b <> 0 -> a mod b <> 0 -> - a mod b = b - a mod b. -Proof. - intros a b. - assert (b <> 0 -> a mod b <> 0 -> -a/b = -1-a/b) by nia. - nia. -Qed. -Example mod_eq: forall x x' y : Z, x / y = x' / y -> x mod y = x' mod y -> y <> 0 -> x = x'. Proof. intros; nia. Qed. -Example Z_div_nz_opp_r: forall a b : Z, b <> 0 -> a mod b <> 0 -> a / - b = - (a / b) - 1. Proof. intros; nia. Qed. -Example Z_div_nz_opp_full: forall a b : Z, b <> 0 -> a mod b <> 0 -> - a / b = - (a / b) - 1. Proof. intros; nia. Qed. -Example Zmod_unique: forall a b q r : Z, 0 <= r < b -> a = b * q + r -> r = a mod b. Proof. intros; nia. Qed. -Example Z_mod_unique_neg: forall a b q r : Z, b < r <= 0 -> a = b * q + r -> r = a mod b. Proof. intros; nia. Qed. -Example Z_mod_unique_pos: forall a b q r : Z, 0 <= r < b -> a = b * q + r -> r = a mod b. Proof. intros; nia. Qed. -Example Z_mod_bound_or: forall a b : Z, b <> 0 -> 0 <= a mod b < b \/ b < a mod b <= 0. Proof. intros; nia. Qed. -Example Z_div_opp_l_nz: forall a b : Z, b <> 0 -> a mod b <> 0 -> - a / b = - (a / b) - 1. Proof. intros; nia. Qed. -Example Z_div_opp_r_nz: forall a b : Z, b <> 0 -> a mod b <> 0 -> a / - b = - (a / b) - 1. Proof. intros; nia. Qed. -Example Z_mod_small_iff: forall a b : Z, b <> 0 -> a mod b = a <-> 0 <= a < b \/ b < a <= 0. Proof. t. Qed. -Example Z_mod_unique: forall a b q r : Z, 0 <= r < b \/ b < r <= 0 -> a = b * q + r -> r = a mod b. Proof. intros. nia. Qed. -Example Z_opp_mod_bound_or: forall a b : Z, b <> 0 -> 0 <= - (a mod b) < - b \/ - b < - (a mod b) <= 0. Proof. intros; nia. Qed. - -Example Zdiv_0_r: forall a : Z, a / 0 = 0. Proof. intros; nia. Qed. -Example Zdiv_0_l: forall a : Z, 0 / a = 0. Proof. intros; nia. Qed. -Example Z_div_1_r: forall a : Z, a / 1 = a. Proof. intros; nia. Qed. -Example Zdiv_1_r: forall a : Z, a / 1 = a. Proof. intros; nia. Qed. -Example Zdiv_opp_opp: forall a b : Z, - a / - b = a / b. Proof. intros; nia. Qed. -Example Z_div_0_l: forall a : Z, a <> 0 -> 0 / a = 0. Proof. intros; nia. Qed. -Example Z_div_pos: forall a b : Z, b > 0 -> 0 <= a -> 0 <= a / b. Proof. intros; nia. Qed. -Example Z_div_ge0: forall a b : Z, b > 0 -> a >= 0 -> a / b >= 0. Proof. intros; nia. Qed. -Example Z_div_pos': forall a b : Z, 0 <= a -> 0 < b -> 0 <= a / b. Proof. intros; nia. Qed. -Example Z_mult_div_ge: forall a b : Z, b > 0 -> b * (a / b) <= a. Proof. intros; nia. Qed. -Example Z_mult_div_ge_neg: forall a b : Z, b < 0 -> b * (a / b) >= a. Proof. intros; nia. Qed. -Example Z_mul_div_le: forall a b : Z, 0 < b -> b * (a / b) <= a. Proof. intros; nia. Qed. -Example Z_mul_div_ge: forall a b : Z, b < 0 -> a <= b * (a / b). Proof. intros; nia. Qed. -Example Z_div_same: forall a : Z, a > 0 -> a / a = 1. Proof. intros; nia. Qed. -Example Z_div_mult: forall a b : Z, b > 0 -> a * b / b = a. Proof. intros; nia. Qed. -Example Z_mul_succ_div_gt: forall a b : Z, 0 < b -> a < b * Z.succ (a / b). Proof. intros; nia. Qed. -Example Z_mul_succ_div_lt: forall a b : Z, b < 0 -> b * Z.succ (a / b) < a. Proof. intros; nia. Qed. -Example Zdiv_1_l: forall a : Z, 1 < a -> 1 / a = 0. Proof. intros; nia. Qed. -Example Z_div_1_l: forall a : Z, 1 < a -> 1 / a = 0. Proof. intros; nia. Qed. -Example Z_div_str_pos: forall a b : Z, 0 < b <= a -> 0 < a / b. Proof. intros; nia. Qed. -Example Z_div_ge: forall a b c : Z, c > 0 -> a >= b -> a / c >= b / c. Proof. intros; nia. Qed. -Example Z_div_mult_full: forall a b : Z, b <> 0 -> a * b / b = a. Proof. intros; nia. Qed. -Example Z_div_same': forall a : Z, a <> 0 -> a / a = 1. Proof. intros; nia. Qed. -Example Zdiv_lt_upper_bound: forall a b q : Z, 0 < b -> a < q * b -> a / b < q. Proof. intros; nia. Qed. -Example Z_div_mul: forall a b : Z, b <> 0 -> a * b / b = a. Proof. intros; nia. Qed. -Example Z_div_lt: forall a b : Z, 0 < a -> 1 < b -> a / b < a. Proof. intros; nia. Qed. -Example Z_div_le_mono: forall a b c : Z, 0 < c -> a <= b -> a / c <= b / c. Proof. intros; nia. Qed. -Example Zdiv_sgn: forall a b : Z, 0 <= Z.sgn (a / b) * Z.sgn a * Z.sgn b. Proof. intros; nia. Qed. -Example Z_div_same_full: forall a : Z, a <> 0 -> a / a = 1. Proof. intros; nia. Qed. -Example Z_div_lt_upper_bound: forall a b q : Z, 0 < b -> a < b * q -> a / b < q. Proof. intros; nia. Qed. -Example Z_div_le: forall a b c : Z, c > 0 -> a <= b -> a / c <= b / c. Proof. intros; nia. Qed. -Example Z_div_le_lower_bound: forall a b q : Z, 0 < b -> b * q <= a -> q <= a / b. Proof. intros; nia. Qed. -Example Zdiv_le_lower_bound: forall a b q : Z, 0 < b -> q * b <= a -> q <= a / b. Proof. intros; nia. Qed. -Example Zdiv_le_upper_bound: forall a b q : Z, 0 < b -> a <= q * b -> a / b <= q. Proof. intros; nia. Qed. -Example Z_div_le_upper_bound: forall a b q : Z, 0 < b -> a <= b * q -> a / b <= q. Proof. intros; nia. Qed. -Example Z_div_small: forall a b : Z, 0 <= a < b -> a / b = 0. Proof. intros; nia. Qed. -Example Zdiv_small: forall a b : Z, 0 <= a < b -> a / b = 0. Proof. intros; nia. Qed. -Example Z_div_opp_opp: forall a b : Z, b <> 0 -> - a / - b = a / b. Proof. intros; nia. Qed. -Example Z_div_unique_exact: forall a b q : Z, b <> 0 -> a = b * q -> q = a / b. Proof. intros; nia. Qed. -Example Zdiv_le_compat_l: forall p q r : Z, 0 <= p -> 0 < q < r -> p / r <= p / q. -Proof. - intros p q r ??. - assert (p mod r <= p mod q \/ p mod q <= p mod r) by nia. - assert (0 <= p / r) by nia. - assert (0 <= p / q) by nia. - nia. -Qed. -Example Z_div_le_compat_l: forall p q r : Z, 0 <= p -> 0 < q <= r -> p / r <= p / q. -Proof. - intros p q r ??. - assert (p mod r <= p mod q \/ p mod q <= p mod r) by nia. - assert (0 <= p / r) by nia. - assert (0 <= p / q) by nia. - nia. -Qed. -Example Z_div_plus: forall a b c : Z, c > 0 -> (a + b * c) / c = a / c + b. Proof. intros; nia. Qed. -Example Z_div_lt': forall a b : Z, b >= 2 -> a > 0 -> a / b < a. Proof. intros; nia. Qed. -Example Zdiv_mult_le: forall a b c : Z, 0 <= a -> 0 <= b -> 0 <= c -> c * (a / b) <= c * a / b. Proof. intros; nia. Qed. -Example Z_div_add_l: forall a b c : Z, b <> 0 -> (a * b + c) / b = a + c / b. Proof. intros; nia. Qed. -Example Z_div_plus_full_l: forall a b c : Z, b <> 0 -> (a * b + c) / b = a + c / b. Proof. intros; nia. Qed. -Example Z_div_add: forall a b c : Z, c <> 0 -> (a + b * c) / c = a / c + b. Proof. intros; nia. Qed. -Example Z_div_plus_full: forall a b c : Z, c <> 0 -> (a + b * c) / c = a / c + b. Proof. intros; nia. Qed. -Example Z_div_mul_le: forall a b c : Z, 0 <= a -> 0 < b -> 0 <= c -> c * (a / b) <= c * a / b. Proof. intros; nia. Qed. -Example Z_div_mul_cancel_r: forall a b c : Z, b <> 0 -> c <> 0 -> a * c / (b * c) = a / b. Proof. intros; nia. Qed. -Example Z_div_div: forall a b c : Z, b <> 0 -> 0 < c -> a / b / c = a / (b * c). Proof. intros; nia. Qed. -Example Z_div_mul_cancel_l: forall a b c : Z, b <> 0 -> c <> 0 -> c * a / (c * b) = a / b. Proof. intros; nia. Qed. -Example Z_div_unique_neg: forall a b q r : Z, b < r <= 0 -> a = b * q + r -> q = a / b. Proof. intros; nia. Qed. -Example Zdiv_unique: forall a b q r : Z, 0 <= r < b -> a = b * q + r -> q = a / b. Proof. intros; nia. Qed. -Example Z_div_unique_pos: forall a b q r : Z, 0 <= r < b -> a = b * q + r -> q = a / b. Proof. intros; nia. Qed. -Example Z_div_small_iff: forall a b : Z, b <> 0 -> a / b = 0 <-> 0 <= a < b \/ b < a <= 0. Proof. intros; nia. Qed. -Example Z_div_unique: forall a b q r : Z, 0 <= r < b \/ b < r <= 0 -> a = b * q + r -> q = a / b. Proof. intros; nia. Qed. -Example Z_divide_mod : forall a b : Z, (b | a) -> a mod b = 0. Proof. intros. nia. Qed. -Example Z_mod_divide: forall a b : Z, b <> 0 -> a mod b = 0 <-> (b | a). Proof. split; intros. Fail all: nia. Abort. -Example Zmod_divides: forall a b : Z, b <> 0 -> a mod b = 0 <-> (exists c : Z, a = b * c). Proof. split; intros. Fail all: nia. Abort. - -(** Now we do the same, but with [Z.quot] and [Z.rem] instead. *) -Example N2Z_inj_quot : forall n m : N, Z.of_N (n / m) = Z.of_N n Ć· Z.of_N m. Proof. intros; nia. Qed. -Example N2Z_inj_rem : forall n m : N, Z.of_N (n mod m) = Z.rem (Z.of_N n) (Z.of_N m). Proof. intros; nia. Qed. -Example OrdersEx_Z_as_DT_mul_quot_ge : forall a b : Z, a <= 0 -> b <> 0 -> a <= b * (a Ć· b) <= 0. Proof. t_zero. Qed. -Example OrdersEx_Z_as_DT_mul_quot_le : forall a b : Z, 0 <= a -> b <> 0 -> 0 <= b * (a Ć· b) <= a. Proof. t_zero. Qed. -Example OrdersEx_Z_as_DT_Private_Div_NZQuot_div_0_l : forall a : Z, 0 < a -> 0 Ć· a = 0. Proof. intros; nia. Qed. -Example OrdersEx_Z_as_DT_Private_Div_NZQuot_div_1_l : forall a : Z, 1 < a -> 1 Ć· a = 0. Proof. intros; nia. Qed. -Example OrdersEx_Z_as_DT_Private_Div_NZQuot_div_1_r : forall a : Z, 0 <= a -> a Ć· 1 = a. Proof. intros; nia. Qed. -Example OrdersEx_Z_as_DT_Private_Div_NZQuot_div_add : forall a b c : Z, 0 <= a -> 0 <= a + b * c -> 0 < c -> (a + b * c) Ć· c = a Ć· c + b. Proof. intros; nia. Qed. -Example OrdersEx_Z_as_DT_Private_Div_NZQuot_div_add_l : forall a b c : Z, 0 <= c -> 0 <= a * b + c -> 0 < b -> (a * b + c) Ć· b = a + c Ć· b. Proof. intros; nia. Qed. -Example OrdersEx_Z_as_DT_Private_Div_NZQuot_div_div : forall a b c : Z, 0 <= a -> 0 < b -> 0 < c -> a Ć· b Ć· c = a Ć· (b * c). -Proof. intros; assert (0 < b * c) by nia; nia. Qed. -Example OrdersEx_Z_as_DT_Private_Div_NZQuot_div_le_lower_bound : forall a b q : Z, 0 <= a -> 0 < b -> b * q <= a -> q <= a Ć· b. Proof. intros; nia. Qed. -Example OrdersEx_Z_as_DT_Private_Div_NZQuot_div_le_mono : forall a b c : Z, 0 < c -> 0 <= a <= b -> a Ć· c <= b Ć· c. Proof. intros; nia. Qed. -Example OrdersEx_Z_as_DT_Private_Div_NZQuot_div_le_upper_bound : forall a b q : Z, 0 <= a -> 0 < b -> a <= b * q -> a Ć· b <= q. Proof. intros; nia. Qed. -Example OrdersEx_Z_as_DT_Private_Div_NZQuot_div_lt : forall a b : Z, 0 < a -> 1 < b -> a Ć· b < a. Proof. intros; nia. Qed. -Example OrdersEx_Z_as_DT_Private_Div_NZQuot_div_lt_upper_bound : forall a b q : Z, 0 <= a -> 0 < b -> a < b * q -> a Ć· b < q. Proof. intros; nia. Qed. -Example OrdersEx_Z_as_DT_Private_Div_NZQuot_div_mul : forall a b : Z, 0 <= a -> 0 < b -> a * b Ć· b = a. Proof. intros; nia. Qed. -Example OrdersEx_Z_as_DT_Private_Div_NZQuot_div_mul_le : forall a b c : Z, 0 <= a -> 0 < b -> 0 <= c -> c * (a Ć· b) <= c * a Ć· b. Proof. intros; nia. Qed. -Example OrdersEx_Z_as_DT_Private_Div_NZQuot_div_pos : forall a b : Z, 0 <= a -> 0 < b -> 0 <= a Ć· b. Proof. intros; nia. Qed. -Example OrdersEx_Z_as_DT_Private_Div_NZQuot_div_same : forall a : Z, 0 < a -> a Ć· a = 1. Proof. intros; nia. Qed. -Example OrdersEx_Z_as_DT_Private_Div_NZQuot_div_small : forall a b : Z, 0 <= a < b -> a Ć· b = 0. Proof. intros; nia. Qed. -Example OrdersEx_Z_as_DT_Private_Div_NZQuot_div_small_iff : forall a b : Z, 0 <= a -> 0 < b -> a Ć· b = 0 <-> a < b. Proof. intros; nia. Qed. -Example OrdersEx_Z_as_DT_Private_Div_NZQuot_div_str_pos : forall a b : Z, 0 < b <= a -> 0 < a Ć· b. Proof. intros; nia. Qed. -Example OrdersEx_Z_as_DT_Private_Div_NZQuot_div_str_pos_iff : forall a b : Z, 0 <= a -> 0 < b -> 0 < a Ć· b <-> b <= a. Proof. intros; nia. Qed. -Example OrdersEx_Z_as_DT_Private_Div_NZQuot_div_unique_exact : forall a b q : Z, 0 <= a -> 0 < b -> a = b * q -> q = a Ć· b. Proof. intros; nia. Qed. -Example OrdersEx_Z_as_DT_Private_Div_NZQuot_mul_div_le : forall a b : Z, 0 <= a -> 0 < b -> b * (a Ć· b) <= a. Proof. intros; nia. Qed. -Example OrdersEx_Z_as_DT_quot_0_l : forall a : Z, a <> 0 -> 0 Ć· a = 0. Proof. intros; nia. Qed. -Example OrdersEx_Z_as_DT_quot_1_l : forall a : Z, 1 < a -> 1 Ć· a = 0. Proof. intros; nia. Qed. -Example OrdersEx_Z_as_DT_quot_1_r : forall a : Z, a Ć· 1 = a. Proof. intros; nia. Qed. -Example OrdersEx_Z_as_DT_quot_div_nonneg : forall a b : Z, 0 <= a -> 0 < b -> a Ć· b = a / b. Proof. intros; nia. Qed. -Example OrdersEx_Z_as_DT_quot_le_lower_bound : forall a b q : Z, 0 < b -> b * q <= a -> q <= a Ć· b. Proof. intros; nia. Qed. -Example OrdersEx_Z_as_DT_quot_le_mono : forall a b c : Z, 0 < c -> a <= b -> a Ć· c <= b Ć· c. Proof. t_zero. Qed. -Example OrdersEx_Z_as_DT_quot_le_upper_bound : forall a b q : Z, 0 < b -> a <= b * q -> a Ć· b <= q. Proof. intros; nia. Qed. -Example OrdersEx_Z_as_DT_quot_lt : forall a b : Z, 0 < a -> 1 < b -> a Ć· b < a. Proof. intros; nia. Qed. -Example OrdersEx_Z_as_DT_quot_lt_upper_bound : forall a b q : Z, 0 <= a -> 0 < b -> a < b * q -> a Ć· b < q. Proof. intros; nia. Qed. -Example OrdersEx_Z_as_DT_quot_mul : forall a b : Z, b <> 0 -> a * b Ć· b = a. Proof. intros; nia. Qed. -Example OrdersEx_Z_as_DT_quot_mul_le : forall a b c : Z, 0 <= a -> 0 < b -> 0 <= c -> c * (a Ć· b) <= c * a Ć· b. Proof. intros; nia. Qed. -Example OrdersEx_Z_as_DT_quot_pos : forall a b : Z, 0 <= a -> 0 < b -> 0 <= a Ć· b. Proof. intros; nia. Qed. -Example OrdersEx_Z_as_DT_quot_same : forall a : Z, a <> 0 -> a Ć· a = 1. Proof. intros; nia. Qed. -Example OrdersEx_Z_as_DT_quot_small : forall a b : Z, 0 <= a < b -> a Ć· b = 0. Proof. intros; nia. Qed. -Example OrdersEx_Z_as_DT_quot_str_pos : forall a b : Z, 0 < b <= a -> 0 < a Ć· b. Proof. intros; nia. Qed. -Example OrdersEx_Z_as_DT_quot_unique_exact : forall a b q : Z, b <> 0 -> a = b * q -> q = a Ć· b. Proof. intros; nia. Qed. -Example OrdersEx_Z_as_DT_quot_unique : forall a b q r : Z, 0 <= a -> 0 <= r < b -> a = b * q + r -> q = a Ć· b. Proof. intros; nia. Qed. -Example OrdersEx_Z_as_OT_mul_quot_ge : forall a b : Z, a <= 0 -> b <> 0 -> a <= b * (a Ć· b) <= 0. -Proof. - intros. - assert (0 < a Ć· b \/ a Ć· b = 0 \/ a Ć· b < 0) by nia. - nia. -Qed. -Example OrdersEx_Z_as_OT_mul_quot_le : forall a b : Z, 0 <= a -> b <> 0 -> 0 <= b * (a Ć· b) <= a. -Proof. - intros. - assert (0 < a Ć· b \/ a Ć· b = 0 \/ a Ć· b < 0) by nia. - nia. -Qed. -Example OrdersEx_Z_as_OT_Private_Div_NZQuot_div_0_l : forall a : Z, 0 < a -> 0 Ć· a = 0. Proof. intros; nia. Qed. -Example OrdersEx_Z_as_OT_Private_Div_NZQuot_div_1_l : forall a : Z, 1 < a -> 1 Ć· a = 0. Proof. intros; nia. Qed. -Example OrdersEx_Z_as_OT_Private_Div_NZQuot_div_1_r : forall a : Z, 0 <= a -> a Ć· 1 = a. Proof. intros; nia. Qed. -Example OrdersEx_Z_as_OT_Private_Div_NZQuot_div_add : forall a b c : Z, 0 <= a -> 0 <= a + b * c -> 0 < c -> (a + b * c) Ć· c = a Ć· c + b. Proof. intros; nia. Qed. -Example OrdersEx_Z_as_OT_Private_Div_NZQuot_div_add_l : forall a b c : Z, 0 <= c -> 0 <= a * b + c -> 0 < b -> (a * b + c) Ć· b = a + c Ć· b. Proof. intros; nia. Qed. -Example OrdersEx_Z_as_OT_Private_Div_NZQuot_div_le_lower_bound : forall a b q : Z, 0 <= a -> 0 < b -> b * q <= a -> q <= a Ć· b. Proof. intros; nia. Qed. -Example OrdersEx_Z_as_OT_Private_Div_NZQuot_div_le_mono : forall a b c : Z, 0 < c -> 0 <= a <= b -> a Ć· c <= b Ć· c. Proof. intros; nia. Qed. -Example OrdersEx_Z_as_OT_Private_Div_NZQuot_div_le_upper_bound : forall a b q : Z, 0 <= a -> 0 < b -> a <= b * q -> a Ć· b <= q. Proof. intros; nia. Qed. -Example OrdersEx_Z_as_OT_Private_Div_NZQuot_div_lt : forall a b : Z, 0 < a -> 1 < b -> a Ć· b < a. Proof. intros; nia. Qed. -Example OrdersEx_Z_as_OT_Private_Div_NZQuot_div_lt_upper_bound : forall a b q : Z, 0 <= a -> 0 < b -> a < b * q -> a Ć· b < q. Proof. intros; nia. Qed. -Example OrdersEx_Z_as_OT_Private_Div_NZQuot_div_mul_cancel_l : forall a b c : Z, 0 <= a -> 0 < b -> 0 < c -> c * a Ć· (c * b) = a Ć· b. Proof. intros; nia. Qed. -Example OrdersEx_Z_as_OT_Private_Div_NZQuot_div_mul_cancel_r : forall a b c : Z, 0 <= a -> 0 < b -> 0 < c -> a * c Ć· (b * c) = a Ć· b. Proof. intros; nia. Qed. -Example OrdersEx_Z_as_OT_Private_Div_NZQuot_div_mul : forall a b : Z, 0 <= a -> 0 < b -> a * b Ć· b = a. Proof. intros; nia. Qed. -Example OrdersEx_Z_as_OT_Private_Div_NZQuot_div_mul_le : forall a b c : Z, 0 <= a -> 0 < b -> 0 <= c -> c * (a Ć· b) <= c * a Ć· b. Proof. intros; nia. Qed. -Example OrdersEx_Z_as_OT_Private_Div_NZQuot_div_pos : forall a b : Z, 0 <= a -> 0 < b -> 0 <= a Ć· b. Proof. intros; nia. Qed. -Example OrdersEx_Z_as_OT_Private_Div_NZQuot_div_same : forall a : Z, 0 < a -> a Ć· a = 1. Proof. intros; nia. Qed. -Example OrdersEx_Z_as_OT_Private_Div_NZQuot_div_small : forall a b : Z, 0 <= a < b -> a Ć· b = 0. Proof. intros; nia. Qed. -Example OrdersEx_Z_as_OT_Private_Div_NZQuot_div_small_iff : forall a b : Z, 0 <= a -> 0 < b -> a Ć· b = 0 <-> a < b. Proof. intros; nia. Qed. -Example OrdersEx_Z_as_OT_Private_Div_NZQuot_div_str_pos : forall a b : Z, 0 < b <= a -> 0 < a Ć· b. Proof. intros; nia. Qed. -Example OrdersEx_Z_as_OT_Private_Div_NZQuot_div_str_pos_iff : forall a b : Z, 0 <= a -> 0 < b -> 0 < a Ć· b <-> b <= a. Proof. intros; nia. Qed. -Example OrdersEx_Z_as_OT_Private_Div_NZQuot_div_unique_exact : forall a b q : Z, 0 <= a -> 0 < b -> a = b * q -> q = a Ć· b. Proof. intros; nia. Qed. -Example OrdersEx_Z_as_OT_Private_Div_NZQuot_div_unique : forall a b q r : Z, 0 <= a -> 0 <= r < b -> a = b * q + r -> q = a Ć· b. Proof. intros; nia. Qed. -Example OrdersEx_Z_as_OT_Private_Div_NZQuot_mul_div_le : forall a b : Z, 0 <= a -> 0 < b -> b * (a Ć· b) <= a. Proof. intros; nia. Qed. -Example OrdersEx_Z_as_OT_quot_0_l : forall a : Z, a <> 0 -> 0 Ć· a = 0. Proof. intros; nia. Qed. -Example OrdersEx_Z_as_OT_quot_1_l : forall a : Z, 1 < a -> 1 Ć· a = 0. Proof. intros; nia. Qed. -Example OrdersEx_Z_as_OT_quot_1_r : forall a : Z, a Ć· 1 = a. Proof. intros; nia. Qed. -Example OrdersEx_Z_as_OT_quot_div_nonneg : forall a b : Z, 0 <= a -> 0 < b -> a Ć· b = a / b. Proof. intros; nia. Qed. -Example OrdersEx_Z_as_OT_quot_le_lower_bound : forall a b q : Z, 0 < b -> b * q <= a -> q <= a Ć· b. Proof. intros; nia. Qed. -Example OrdersEx_Z_as_OT_quot_le_mono : forall a b c : Z, 0 < c -> a <= b -> a Ć· c <= b Ć· c. Proof. t_zero. Qed. -Example OrdersEx_Z_as_OT_quot_le_upper_bound : forall a b q : Z, 0 < b -> a <= b * q -> a Ć· b <= q. Proof. intros; nia. Qed. -Example OrdersEx_Z_as_OT_quot_lt : forall a b : Z, 0 < a -> 1 < b -> a Ć· b < a. Proof. intros; nia. Qed. -Example OrdersEx_Z_as_OT_quot_lt_upper_bound : forall a b q : Z, 0 <= a -> 0 < b -> a < b * q -> a Ć· b < q. Proof. intros; nia. Qed. -Example OrdersEx_Z_as_OT_quot_mul : forall a b : Z, b <> 0 -> a * b Ć· b = a. Proof. intros; nia. Qed. -Example OrdersEx_Z_as_OT_quot_mul_le : forall a b c : Z, 0 <= a -> 0 < b -> 0 <= c -> c * (a Ć· b) <= c * a Ć· b. Proof. intros; nia. Qed. -Example OrdersEx_Z_as_OT_quot_opp_l : forall a b : Z, b <> 0 -> - a Ć· b = - (a Ć· b). Proof. intros; nia. Qed. -Example OrdersEx_Z_as_OT_quot_pos : forall a b : Z, 0 <= a -> 0 < b -> 0 <= a Ć· b. Proof. intros; nia. Qed. -Example OrdersEx_Z_as_OT_quot_same : forall a : Z, a <> 0 -> a Ć· a = 1. Proof. intros; nia. Qed. -Example OrdersEx_Z_as_OT_quot_small : forall a b : Z, 0 <= a < b -> a Ć· b = 0. Proof. intros; nia. Qed. -Example OrdersEx_Z_as_OT_quot_str_pos : forall a b : Z, 0 < b <= a -> 0 < a Ć· b. Proof. intros; nia. Qed. -Example OrdersEx_Z_as_OT_quot_unique_exact : forall a b q : Z, b <> 0 -> a = b * q -> q = a Ć· b. Proof. intros; nia. Qed. -Example OrdersEx_Z_as_OT_quot_unique : forall a b q r : Z, 0 <= a -> 0 <= r < b -> a = b * q + r -> q = a Ć· b. Proof. intros; nia. Qed. -Example Z2N_inj_rem : forall n m : Z, 0 <= n -> 0 <= m -> Z.to_N (Z.rem n m) = (Z.to_N n mod Z.to_N m)%N. Proof. intros. Abort. -Example Zabs2N_inj_rem : forall n m : Z, Z.abs_N (Z.rem n m) = (Z.abs_N n mod Z.abs_N m)%N. Proof. intros. Abort. -Example Z_add_rem_idemp_l : forall a b n : Z, n <> 0 -> 0 <= a * b -> Z.rem (Z.rem a n + b) n = Z.rem (a + b) n. Proof. intros. Fail nia. Abort. -Example Z_add_rem_idemp_r : forall a b n : Z, n <> 0 -> 0 <= a * b -> Z.rem (a + Z.rem b n) n = Z.rem (a + b) n. Proof. intros. Fail nia. Abort. -Example Z_gcd_quot_gcd : forall a b g : Z, g <> 0 -> g = Z.gcd a b -> Z.gcd (a Ć· g) (b Ć· g) = 1. Proof. intros. Fail nia. Abort. -Example Z_gcd_rem : forall a b : Z, b <> 0 -> Z.gcd (Z.rem a b) b = Z.gcd b a. Proof. intros. Fail nia. Abort. -Example Z_mul_pred_quot_gt : forall a b : Z, 0 <= a -> b < 0 -> a < b * Z.pred (a Ć· b). Proof. intros; nia. Qed. -Example Z_mul_pred_quot_lt : forall a b : Z, a <= 0 -> 0 < b -> b * Z.pred (a Ć· b) < a. Proof. intros; nia. Qed. -Example Z_mul_quot_ge : forall a b : Z, a <= 0 -> b <> 0 -> a <= b * (a Ć· b) <= 0. Proof. intros. Fail nia. Abort. -Example Z_mul_quot_le : forall a b : Z, 0 <= a -> b <> 0 -> 0 <= b * (a Ć· b) <= a. Proof. intros. Fail nia. Abort. -Example Z_mul_rem_distr_l : forall a b c : Z, b <> 0 -> c <> 0 -> Z.rem (c * a) (c * b) = c * Z.rem a b. Proof. intros. Fail nia. Abort. -Example Z_mul_rem_distr_r : forall a b c : Z, b <> 0 -> c <> 0 -> Z.rem (a * c) (b * c) = Z.rem a b * c. Proof. intros. Fail nia. Abort. -Example Z_mul_rem_idemp_l : forall a b n : Z, n <> 0 -> Z.rem (Z.rem a n * b) n = Z.rem (a * b) n. Proof. intros. Fail nia. Abort. -Example Z_mul_rem_idemp_r : forall a b n : Z, n <> 0 -> Z.rem (a * Z.rem b n) n = Z.rem (a * b) n. Proof. intros. Fail nia. Abort. -Example Z_mul_succ_quot_gt : forall a b : Z, 0 <= a -> 0 < b -> a < b * Z.succ (a Ć· b). Proof. intros; nia. Qed. -Example Z_mul_succ_quot_lt : forall a b : Z, a <= 0 -> b < 0 -> b * Z.succ (a Ć· b) < a. Proof. intros; nia. Qed. -Example Z_Private_Div_NZQuot_add_mod : forall a b n : Z, 0 <= a -> 0 <= b -> 0 < n -> Z.rem (a + b) n = Z.rem (Z.rem a n + Z.rem b n) n. Proof. intros. Fail nia. Abort. -Example Z_Private_Div_NZQuot_add_mod_idemp_l : forall a b n : Z, 0 <= a -> 0 <= b -> 0 < n -> Z.rem (Z.rem a n + b) n = Z.rem (a + b) n. Proof. intros. Fail nia. Abort. -Example Z_Private_Div_NZQuot_add_mod_idemp_r : forall a b n : Z, 0 <= a -> 0 <= b -> 0 < n -> Z.rem (a + Z.rem b n) n = Z.rem (a + b) n. Proof. intros. Fail nia. Abort. -Example Z_Private_Div_NZQuot_div_0_l : forall a : Z, 0 < a -> 0 Ć· a = 0. Proof. intros; nia. Qed. -Example Z_Private_Div_NZQuot_div_1_l : forall a : Z, 1 < a -> 1 Ć· a = 0. Proof. intros; nia. Qed. -Example Z_Private_Div_NZQuot_div_1_r : forall a : Z, 0 <= a -> a Ć· 1 = a. Proof. intros; nia. Qed. -Example Z_Private_Div_NZQuot_div_add : forall a b c : Z, 0 <= a -> 0 <= a + b * c -> 0 < c -> (a + b * c) Ć· c = a Ć· c + b. Proof. intros; nia. Qed. -Example Z_Private_Div_NZQuot_div_add_l : forall a b c : Z, 0 <= c -> 0 <= a * b + c -> 0 < b -> (a * b + c) Ć· b = a + c Ć· b. Proof. intros; nia. Qed. -Example Z_Private_Div_NZQuot_div_exact : forall a b : Z, 0 <= a -> 0 < b -> a = b * (a Ć· b) <-> Z.rem a b = 0. Proof. intros; nia. Qed. -Example Z_Private_Div_NZQuot_div_le_lower_bound : forall a b q : Z, 0 <= a -> 0 < b -> b * q <= a -> q <= a Ć· b. Proof. intros; nia. Qed. -Example Z_Private_Div_NZQuot_div_le_mono : forall a b c : Z, 0 < c -> 0 <= a <= b -> a Ć· c <= b Ć· c. Proof. intros; nia. Qed. -Example Z_Private_Div_NZQuot_div_le_upper_bound : forall a b q : Z, 0 <= a -> 0 < b -> a <= b * q -> a Ć· b <= q. Proof. intros; nia. Qed. -Example Z_Private_Div_NZQuot_div_lt : forall a b : Z, 0 < a -> 1 < b -> a Ć· b < a. Proof. intros; nia. Qed. -Example Z_Private_Div_NZQuot_div_lt_upper_bound : forall a b q : Z, 0 <= a -> 0 < b -> a < b * q -> a Ć· b < q. Proof. intros; nia. Qed. -Example Z_Private_Div_NZQuot_div_mul_cancel_l : forall a b c : Z, 0 <= a -> 0 < b -> 0 < c -> c * a Ć· (c * b) = a Ć· b. Proof. intros; nia. Qed. -Example Z_Private_Div_NZQuot_div_mul_cancel_r : forall a b c : Z, 0 <= a -> 0 < b -> 0 < c -> a * c Ć· (b * c) = a Ć· b. Proof. intros; nia. Qed. -Example Z_Private_Div_NZQuot_div_mul : forall a b : Z, 0 <= a -> 0 < b -> a * b Ć· b = a. Proof. intros; nia. Qed. -Example Z_Private_Div_NZQuot_div_mul_le : forall a b c : Z, 0 <= a -> 0 < b -> 0 <= c -> c * (a Ć· b) <= c * a Ć· b. Proof. intros; nia. Qed. -Example Z_Private_Div_NZQuot_div_pos : forall a b : Z, 0 <= a -> 0 < b -> 0 <= a Ć· b. Proof. intros; nia. Qed. -Example Z_Private_Div_NZQuot_div_same : forall a : Z, 0 < a -> a Ć· a = 1. Proof. intros; nia. Qed. -Example Z_Private_Div_NZQuot_div_small : forall a b : Z, 0 <= a < b -> a Ć· b = 0. Proof. intros; nia. Qed. -Example Z_Private_Div_NZQuot_div_small_iff : forall a b : Z, 0 <= a -> 0 < b -> a Ć· b = 0 <-> a < b. Proof. intros; nia. Qed. -Example Z_Private_Div_NZQuot_div_str_pos : forall a b : Z, 0 < b <= a -> 0 < a Ć· b. Proof. intros; nia. Qed. -Example Z_Private_Div_NZQuot_div_str_pos_iff : forall a b : Z, 0 <= a -> 0 < b -> 0 < a Ć· b <-> b <= a. Proof. intros; nia. Qed. -Example Z_Private_Div_NZQuot_div_unique_exact : forall a b q : Z, 0 <= a -> 0 < b -> a = b * q -> q = a Ć· b. Proof. intros; nia. Qed. -Example Z_Private_Div_NZQuot_div_unique : forall a b q r : Z, 0 <= a -> 0 <= r < b -> a = b * q + r -> q = a Ć· b. Proof. intros; nia. Qed. -Example Z_Private_Div_NZQuot_mod_0_l : forall a : Z, 0 < a -> Z.rem 0 a = 0. Proof. intros; nia. Qed. -Example Z_Private_Div_NZQuot_mod_1_l : forall a : Z, 1 < a -> Z.rem 1 a = 1. Proof. intros. Fail nia. Abort. -Example Z_Private_Div_NZQuot_mod_1_r : forall a : Z, 0 <= a -> Z.rem a 1 = 0. Proof. intros; nia. Qed. -Example Z_Private_Div_NZQuot_mod_add : forall a b c : Z, 0 <= a -> 0 <= a + b * c -> 0 < c -> Z.rem (a + b * c) c = Z.rem a c. Proof. intros. Fail nia. Abort. -Example Z_Private_Div_NZQuot_mod_divides : forall a b : Z, 0 <= a -> 0 < b -> Z.rem a b = 0 <-> (exists c : Z, a = b * c). Proof. intros. Fail nia. Abort. -Example Z_Private_Div_NZQuot_mod_le : forall a b : Z, 0 <= a -> 0 < b -> Z.rem a b <= a. Proof. intros. Fail nia. Abort. -Example Z_Private_Div_NZQuot_mod_mod : forall a n : Z, 0 <= a -> 0 < n -> Z.rem (Z.rem a n) n = Z.rem a n. Proof. intros. Fail nia. Abort. -Example Z_Private_Div_NZQuot_mod_mul : forall a b : Z, 0 <= a -> 0 < b -> Z.rem (a * b) b = 0. Proof. intros; nia. Qed. -Example Z_Private_Div_NZQuot_mod_mul_r : forall a b c : Z, 0 <= a -> 0 < b -> 0 < c -> Z.rem a (b * c) = Z.rem a b + b * Z.rem (a Ć· b) c. Proof. intros. Fail nia. Abort. -Example Z_Private_Div_NZQuot_mod_same : forall a : Z, 0 < a -> Z.rem a a = 0. Proof. intros. Fail nia. Abort. -Example Z_Private_Div_NZQuot_mod_small : forall a b : Z, 0 <= a < b -> Z.rem a b = a. Proof. intros. Fail nia. Abort. -Example Z_Private_Div_NZQuot_mod_small_iff : forall a b : Z, 0 <= a -> 0 < b -> Z.rem a b = a <-> a < b. Proof. intros. Fail nia. Abort. -Example Z_Private_Div_NZQuot_mul_div_le : forall a b : Z, 0 <= a -> 0 < b -> b * (a Ć· b) <= a. Proof. intros; nia. Qed. -Example Z_Private_Div_NZQuot_mul_mod_distr_l : forall a b c : Z, 0 <= a -> 0 < b -> 0 < c -> Z.rem (c * a) (c * b) = c * Z.rem a b. Proof. intros. Fail nia. Abort. -Example Z_Private_Div_NZQuot_mul_mod_distr_r : forall a b c : Z, 0 <= a -> 0 < b -> 0 < c -> Z.rem (a * c) (b * c) = Z.rem a b * c. Proof. intros. Fail nia. Abort. -Example Z_Private_Div_NZQuot_mul_mod_idemp_l : forall a b n : Z, 0 <= a -> 0 <= b -> 0 < n -> Z.rem (Z.rem a n * b) n = Z.rem (a * b) n. Proof. intros. Fail nia. Abort. -Example Z_Private_Div_NZQuot_mul_mod_idemp_r : forall a b n : Z, 0 <= a -> 0 <= b -> 0 < n -> Z.rem (a * Z.rem b n) n = Z.rem (a * b) n. Proof. intros. Fail nia. Abort. -Example Z_Private_Div_NZQuot_mul_succ_div_gt : forall a b : Z, 0 <= a -> 0 < b -> a < b * Z.succ (a Ć· b). Proof. intros; nia. Qed. -Example Z_Private_Div_Quot2Div_div_mod : forall a b : Z, b <> 0 -> a = b * (a Ć· b) + Z.rem a b. Proof. intros; nia. Qed. -Example Z_Private_Div_Quot2Div_div_wd : Morphisms.Proper (Morphisms.respectful eq (Morphisms.respectful eq eq)) Z.quot. Proof. repeat intro; subst; nia. Qed. -Example Z_Private_Div_Quot2Div_mod_bound_pos : forall a b : Z, 0 <= a -> 0 < b -> 0 <= Z.rem a b < b. Proof. intros; nia. Qed. -Example Z_Private_Div_Quot2Div_mod_wd : Morphisms.Proper (Morphisms.respectful eq (Morphisms.respectful eq eq)) Z.rem. Proof. repeat intro; subst; nia. Qed. -Example Z_quot_0_l : forall a : Z, a <> 0 -> 0 Ć· a = 0. Proof. intros; nia. Qed. -Example Z_quot_0_r_ext : forall x y : Z, y = 0 -> x Ć· y = 0. Proof. intros; nia. Qed. -Example Z_quot_1_l : forall a : Z, 1 < a -> 1 Ć· a = 0. Proof. intros; nia. Qed. -Example Z_quot_1_r : forall a : Z, a Ć· 1 = a. Proof. intros; nia. Qed. -Example Zquot2_quot : forall n : Z, Z.quot2 n = n Ć· 2. Proof. intros; nia. Qed. -Example Z_quot_div_nonneg : forall a b : Z, 0 <= a -> 0 < b -> a Ć· b = a / b. Proof. intros; nia. Qed. -Example Z_quot_exact : forall a b : Z, b <> 0 -> a = b * (a Ć· b) <-> Z.rem a b = 0. Proof. intros; nia. Qed. -Example Z_quot_le_compat_l : forall p q r : Z, 0 <= p -> 0 < q <= r -> p Ć· r <= p Ć· q. Proof. intros. Fail nia. Abort. -Example Z_quot_le_lower_bound : forall a b q : Z, 0 < b -> b * q <= a -> q <= a Ć· b. Proof. intros; nia. Qed. -Example Z_quot_le_mono : forall a b c : Z, 0 < c -> a <= b -> a Ć· c <= b Ć· c. Proof. intros. Fail nia. Abort. -Example Z_quot_le_upper_bound : forall a b q : Z, 0 < b -> a <= b * q -> a Ć· b <= q. Proof. intros; nia. Qed. -Example Z_quot_lt : forall a b : Z, 0 < a -> 1 < b -> a Ć· b < a. Proof. intros; nia. Qed. -Example Z_quot_lt_upper_bound : forall a b q : Z, 0 <= a -> 0 < b -> a < b * q -> a Ć· b < q. Proof. intros; nia. Qed. -Example Z_quot_mul : forall a b : Z, b <> 0 -> a * b Ć· b = a. Proof. intros; nia. Qed. -Example Z_quot_mul_le : forall a b c : Z, 0 <= a -> 0 < b -> 0 <= c -> c * (a Ć· b) <= c * a Ć· b. Proof. intros; nia. Qed. -Example Z_quot_opp_l : forall a b : Z, b <> 0 -> - a Ć· b = - (a Ć· b). Proof. intros; nia. Qed. -Example Z_quot_pos : forall a b : Z, 0 <= a -> 0 < b -> 0 <= a Ć· b. Proof. intros; nia. Qed. -Example Z_quot_rem' : forall a b : Z, a = b * (a Ć· b) + Z.rem a b. Proof. intros; nia. Qed. -Example Z_quot_rem : forall a b : Z, b <> 0 -> a = b * (a Ć· b) + Z.rem a b. Proof. intros; nia. Qed. -Example Z_quot_same : forall a : Z, a <> 0 -> a Ć· a = 1. Proof. intros; nia. Qed. -Example Z_quot_small : forall a b : Z, 0 <= a < b -> a Ć· b = 0. Proof. intros; nia. Qed. -Example Z_quot_small_iff : forall a b : Z, b <> 0 -> a Ć· b = 0 <-> Z.abs a < Z.abs b. Proof. intros; nia. Qed. -Example Z_quot_str_pos : forall a b : Z, 0 < b <= a -> 0 < a Ć· b. Proof. intros; nia. Qed. -Example Z_quot_unique_exact : forall a b q : Z, b <> 0 -> a = b * q -> q = a Ć· b. Proof. intros; nia. Qed. -Example Z_quot_unique : forall a b q r : Z, 0 <= a -> 0 <= r < b -> a = b * q + r -> q = a Ć· b. Proof. intros; nia. Qed. -Example Z_quot_wd : Morphisms.Proper (Morphisms.respectful Z.eq (Morphisms.respectful Z.eq Z.eq)) Z.quot. Proof. repeat intro. Fail nia. Abort. -Example Zquot_Zeven_rem : forall a : Z, Z.even a = (Z.rem a 2 =? 0). Proof. intros. Fail nia. Abort. -Example Zquot_Z_mult_quot_ge : forall a b : Z, a <= 0 -> a <= b * (a Ć· b) <= 0. Proof. intros. Fail nia. Abort. -Example Zquot_Z_mult_quot_le : forall a b : Z, 0 <= a -> 0 <= b * (a Ć· b) <= a. Proof. intros. Fail nia. Abort. -Example Zquot_Zodd_rem : forall a : Z, Z.odd a = negb (Z.rem a 2 =? 0). Proof. intros. Fail nia. Abort. -Example Zquot_Zplus_rem : forall a b n : Z, 0 <= a * b -> Z.rem (a + b) n = Z.rem (Z.rem a n + Z.rem b n) n. Proof. intros. Abort. -Example Zquot_Zplus_rem_idemp_l : forall a b n : Z, 0 <= a * b -> Z.rem (Z.rem a n + b) n = Z.rem (a + b) n. Proof. intros. Abort. -Example Zquot_Zplus_rem_idemp_r : forall a b n : Z, 0 <= a * b -> Z.rem (b + Z.rem a n) n = Z.rem (b + a) n. Proof. intros. Abort. -Example Zquot_Zquot_0_l : forall a : Z, 0 Ć· a = 0. Proof. intros; nia. Qed. -Example Zquot_Zquot_0_r : forall a : Z, a Ć· 0 = 0. Proof. intros; nia. Qed. -Example Zquot_Z_quot_exact_full : forall a b : Z, a = b * (a Ć· b) <-> Z.rem a b = 0. Proof. intros; nia. Qed. -Example Zquot_Zquot_le_lower_bound : forall a b q : Z, 0 < b -> q * b <= a -> q <= a Ć· b. Proof. intros; nia. Qed. -Example Zquot_Zquot_le_upper_bound : forall a b q : Z, 0 < b -> a <= q * b -> a Ć· b <= q. Proof. intros; nia. Qed. -Example Zquot_Z_quot_lt : forall a b : Z, 0 < a -> 2 <= b -> a Ć· b < a. Proof. intros; nia. Qed. -Example Zquot_Zquot_lt_upper_bound : forall a b q : Z, 0 <= a -> 0 < b -> a < q * b -> a Ć· b < q. Proof. intros; nia. Qed. -From Stdlib Require Zquot. -Example Zquot_Zquot_mod_unique_full : forall a b q r : Z, Zquot.Remainder a b r -> a = b * q + r -> q = a Ć· b /\ r = Z.rem a b. Proof. intros. Fail nia. Abort. -Example Zquot_Z_quot_monotone : forall a b c : Z, 0 <= c -> a <= b -> a Ć· c <= b Ć· c. Proof. intros. Fail nia. Abort. -Example Zquot_Zquot_mult_cancel_l : forall a b c : Z, c <> 0 -> c * a Ć· (c * b) = a Ć· b. Proof. intros. Abort. -Example Zquot_Zquot_mult_cancel_r : forall a b c : Z, c <> 0 -> a * c Ć· (b * c) = a Ć· b. Proof. intros. Abort. -Example Zquot_Zquot_mult_le : forall a b c : Z, 0 <= a -> 0 <= b -> 0 <= c -> c * (a Ć· b) <= c * a Ć· b. Proof. intros; nia. Qed. -Example Zquot_Z_quot_pos : forall a b : Z, 0 <= a -> 0 <= b -> 0 <= a Ć· b. Proof. intros; nia. Qed. -Example Zquot_Zquotrem_Zdiv_eucl_pos : forall a b : Z, 0 <= a -> 0 < b -> a Ć· b = a / b /\ Z.rem a b = a mod b. Proof. intros; nia. Qed. -Example Zquot_Zquot_sgn : forall a b : Z, 0 <= Z.sgn (a Ć· b) * Z.sgn a * Z.sgn b. Proof. intros; nia. Qed. -Example Zquot_Zquot_unique_full : forall a b q r : Z, Zquot.Remainder a b r -> a = b * q + r -> q = a Ć· b. Proof. intros. Fail nia. Abort. -Example Zquot_Zquot_Zdiv_pos : forall a b : Z, 0 <= a -> 0 <= b -> a Ć· b = a / b. Proof. intros; nia. Qed. -Example Zquot_Zquot_Zquot : forall a b c : Z, a Ć· b Ć· c = a Ć· (b * c). Proof. intros. Abort. -Example Zquot_Zrem_0_l : forall a : Z, Z.rem 0 a = 0. Proof. intros; nia. Qed. -Example Zquot_Zrem_0_r : forall a : Z, Z.rem a 0 = a. Proof. intros; nia. Qed. -Example Zquot_Zrem_divides : forall a b : Z, Z.rem a b = 0 <-> (exists c : Z, a = b * c). Proof. intros. Fail nia. Abort. -Example Zquot_Zrem_even : forall a : Z, Z.rem a 2 = (if Z.even a then 0 else Z.sgn a). Proof. intros. Fail nia. Abort. -Example Zquot_Zrem_le : forall a b : Z, 0 <= a -> 0 <= b -> Z.rem a b <= a. Proof. intros. Fail nia. Abort. -Example Zquot_Zrem_lt_neg : forall a b : Z, a <= 0 -> b <> 0 -> - Z.abs b < Z.rem a b <= 0. Proof. intros; nia. Qed. -Example Zquot_Zrem_lt_neg_neg : forall a b : Z, a <= 0 -> b < 0 -> b < Z.rem a b <= 0. Proof. intros; nia. Qed. -Example Zquot_Zrem_lt_neg_pos : forall a b : Z, a <= 0 -> 0 < b -> - b < Z.rem a b <= 0. Proof. intros; nia. Qed. -Example Zquot_Zrem_lt_pos : forall a b : Z, 0 <= a -> b <> 0 -> 0 <= Z.rem a b < Z.abs b. Proof. intros; nia. Qed. -Example Zquot_Zrem_lt_pos_neg : forall a b : Z, 0 <= a -> b < 0 -> 0 <= Z.rem a b < - b. Proof. intros; nia. Qed. -Example Zquot_Zrem_lt_pos_pos : forall a b : Z, 0 <= a -> 0 < b -> 0 <= Z.rem a b < b. Proof. intros; nia. Qed. -Example Zquot_Z_rem_mult : forall a b : Z, Z.rem (a * b) b = 0. Proof. intros; nia. Qed. -Example Zquot_Zrem_odd : forall a : Z, Z.rem a 2 = (if Z.odd a then Z.sgn a else 0). Proof. intros. Fail nia. Abort. -Example Zquot_Zrem_opp_l : forall a b : Z, Z.rem (- a) b = - Z.rem a b. Proof. intros. Fail nia. Abort. -Example Zquot_Zrem_opp_opp : forall a b : Z, Z.rem (- a) (- b) = - Z.rem a b. Proof. intros. Fail nia. Abort. -Example Zquot_Zrem_opp_r : forall a b : Z, Z.rem a (- b) = Z.rem a b. Proof. intros. Fail nia. Abort. -Example Zquot_Z_rem_plus : forall a b c : Z, 0 <= (a + b * c) * a -> Z.rem (a + b * c) c = Z.rem a c. Proof. intros. Fail nia. Abort. -Example Zquot_Zrem_rem : forall a n : Z, Z.rem (Z.rem a n) n = Z.rem a n. Proof. intros. Fail nia. Abort. -Example Zquot_Z_rem_same : forall a : Z, Z.rem a a = 0. Proof. intros. Fail nia. Abort. -Example Zquot_Zrem_sgn2 : forall a b : Z, 0 <= Z.rem a b * a. Proof. intros. Fail nia. Abort. -Example Zquot_Zrem_sgn : forall a b : Z, 0 <= Z.sgn (Z.rem a b) * Z.sgn a. Proof. intros; nia. Qed. -Example Zquot_Zrem_unique_full : forall a b q r : Z, Zquot.Remainder a b r -> a = b * q + r -> r = Z.rem a b. Proof. intros. Fail nia. Abort. -Example Zquot_Zrem_Zmod_pos : forall a b : Z, 0 <= a -> 0 < b -> Z.rem a b = a mod b. Proof. intros; nia. Qed. -Example Zquot_Zrem_Zmod_zero : forall a b : Z, b <> 0 -> Z.rem a b = 0 <-> a mod b = 0. Proof. intros; nia. Qed. -Example Z_rem_0_l : forall a : Z, a <> 0 -> Z.rem 0 a = 0. Proof. intros; nia. Qed. -Example Z_rem_0_r_ext : forall x y : Z, y = 0 -> Z.rem x y = x. Proof. intros; nia. Qed. -Example Z_rem_1_l : forall a : Z, 1 < a -> Z.rem 1 a = 1. Proof. intros. Fail nia. Abort. -Example Z_rem_1_r : forall a : Z, Z.rem a 1 = 0. Proof. intros; nia. Qed. -Example Z_rem_abs : forall a b : Z, b <> 0 -> Z.rem (Z.abs a) (Z.abs b) = Z.abs (Z.rem a b). Proof. intros. Fail nia. Abort. -Example Z_rem_abs_l : forall a b : Z, b <> 0 -> Z.rem (Z.abs a) b = Z.abs (Z.rem a b). Proof. intros. Fail nia. Abort. -Example Z_rem_abs_r : forall a b : Z, b <> 0 -> Z.rem a (Z.abs b) = Z.rem a b. Proof. intros. Fail nia. Abort. -Example Z_rem_add : forall a b c : Z, c <> 0 -> 0 <= (a + b * c) * a -> Z.rem (a + b * c) c = Z.rem a c. Proof. intros. Fail nia. Abort. -Example Z_rem_bound_abs : forall a b : Z, b <> 0 -> Z.abs (Z.rem a b) < Z.abs b. Proof. intros; nia. Qed. -Example Z_rem_bound_neg_neg : forall x y : Z, y < 0 -> x <= 0 -> y < Z.rem x y <= 0. Proof. intros; nia. Qed. -Example Z_rem_bound_neg_pos : forall x y : Z, y < 0 -> 0 <= x -> 0 <= Z.rem x y < - y. Proof. intros; nia. Qed. -Example Z_rem_bound_pos : forall a b : Z, 0 <= a -> 0 < b -> 0 <= Z.rem a b < b. Proof. intros; nia. Qed. -Example Z_rem_bound_pos_neg : forall x y : Z, 0 < y -> x <= 0 -> - y < Z.rem x y <= 0. Proof. intros; nia. Qed. -Example Z_rem_bound_pos_pos : forall x y : Z, 0 < y -> 0 <= x -> 0 <= Z.rem x y < y. Proof. intros; nia. Qed. -Example Z_rem_eq : forall a b : Z, b <> 0 -> Z.rem a b = a - b * (a Ć· b). Proof. intros; nia. Qed. -Example Z_rem_le : forall a b : Z, 0 <= a -> 0 < b -> Z.rem a b <= a. Proof. intros. Fail nia. Abort. -Example Z_rem_mod_eq_0 : forall a b : Z, b <> 0 -> Z.rem a b = 0 <-> a mod b = 0. Proof. intros; nia. Qed. -Example Z_rem_mod : forall a b : Z, b <> 0 -> Z.rem a b = Z.sgn a * (Z.abs a mod Z.abs b). Proof. intros. Fail nia. Abort. -Example Z_rem_mod_nonneg : forall a b : Z, 0 <= a -> 0 < b -> Z.rem a b = a mod b. Proof. intros; nia. Qed. -Example Z_rem_mul : forall a b : Z, b <> 0 -> Z.rem (a * b) b = 0. Proof. intros; nia. Qed. -Example Z_rem_nonneg : forall a b : Z, b <> 0 -> 0 <= a -> 0 <= Z.rem a b. Proof. intros; nia. Qed. -Example Z_rem_nonpos : forall a b : Z, b <> 0 -> a <= 0 -> Z.rem a b <= 0. Proof. intros; nia. Qed. -Example Z_rem_opp_l : forall a b : Z, b <> 0 -> Z.rem (- a) b = - Z.rem a b. Proof. intros. Fail nia. Abort. -Example Z_rem_opp_l' : forall a b : Z, Z.rem (- a) b = - Z.rem a b. Proof. intros. Fail nia. Abort. -Example Z_rem_opp_opp : forall a b : Z, b <> 0 -> Z.rem (- a) (- b) = - Z.rem a b. Proof. intros. Fail nia. Abort. -Example Z_rem_opp_r : forall a b : Z, b <> 0 -> Z.rem a (- b) = Z.rem a b. Proof. intros. Fail nia. Abort. -Example Z_rem_opp_r' : forall a b : Z, Z.rem a (- b) = Z.rem a b. Proof. intros. Fail nia. Abort. -Example Z_rem_quot : forall a b : Z, b <> 0 -> Z.rem a b Ć· b = 0. Proof. intros; nia. Qed. -Example Z_rem_rem : forall a n : Z, n <> 0 -> Z.rem (Z.rem a n) n = Z.rem a n. Proof. intros. Fail nia. Abort. -Example Z_rem_same : forall a : Z, a <> 0 -> Z.rem a a = 0. Proof. intros. Fail nia. Abort. -Example Z_rem_sign : forall a b : Z, a <> 0 -> b <> 0 -> Z.sgn (Z.rem a b) <> - Z.sgn a. Proof. intros; nia. Qed. -Example Z_rem_sign_mul : forall a b : Z, b <> 0 -> 0 <= Z.rem a b * a. Proof. intros. Fail nia. Abort. -Example Z_rem_sign_nz : forall a b : Z, b <> 0 -> Z.rem a b <> 0 -> Z.sgn (Z.rem a b) = Z.sgn a. Proof. intros; nia. Qed. -Example Z_rem_small : forall a b : Z, 0 <= a < b -> Z.rem a b = a. Proof. intros. Fail nia. Abort. -Example Z_rem_small_iff : forall a b : Z, b <> 0 -> Z.rem a b = a <-> Z.abs a < Z.abs b. Proof. intros. Fail nia. Abort. -Example Z_rem_unique : forall a b q r : Z, 0 <= a -> 0 <= r < b -> a = b * q + r -> r = Z.rem a b. Proof. intros; nia. Qed. -Example Z_rem_divide: forall a b : Z, b <> 0 -> Z.rem a b = 0 <-> (b | a). Proof. split; intros. Fail all: nia. Abort. -Example Zrem_divides: forall a b : Z, b <> 0 -> Z.rem a b = 0 <-> (exists c : Z, a = b * c). Proof. split; intros. Fail all: nia. Abort. -Example Z_rem_wd : Morphisms.Proper (Morphisms.respectful Z.eq (Morphisms.respectful Z.eq Z.eq)) Z.rem. Proof. repeat intro; subst. Fail nia. Abort. diff --git a/stdlib/test-suite/success/Nsatz.v b/stdlib/test-suite/success/Nsatz.v deleted file mode 100644 index e6516770eab4..000000000000 --- a/stdlib/test-suite/success/Nsatz.v +++ /dev/null @@ -1,537 +0,0 @@ - -(* compile en user 3m39.915s sur cachalot *) -From Stdlib Require Import BinNat. -From Stdlib Require Import Nsatz. -From Stdlib Require List. -Import List.ListNotations. - -(* Example with a generic domain *) - -Section test. - -Context {A:Type}`{Aid:Integral_domain A}. - -Lemma example3 : forall x y z, - x+y+z==0 -> - x*y+x*z+y*z==0-> - x*y*z==0 -> x^3%Z==0. -Proof. - Time nsatz. -Qed. - -Lemma example4 : forall x y z u, - x+y+z+u==0 -> - x*y+x*z+x*u+y*z+y*u+z*u==0-> - x*y*z+x*y*u+x*z*u+y*z*u==0-> - x*y*z*u==0 -> x^4%Z==0. -Proof. -Time nsatz. -Qed. - -Lemma example5 : forall x y z u v, - x+y+z+u+v==0 -> - x*y+x*z+x*u+x*v+y*z+y*u+y*v+z*u+z*v+u*v==0-> - x*y*z+x*y*u+x*y*v+x*z*u+x*z*v+x*u*v+y*z*u+y*z*v+y*u*v+z*u*v==0-> - x*y*z*u+y*z*u*v+z*u*v*x+u*v*x*y+v*x*y*z==0 -> - x*y*z*u*v==0 -> x^5%Z==0. -Proof. -Time nsatz. -Qed. - -Goal forall x y:Z, x = y -> (x+0)%Z = (y*1+0)%Z. -nsatz. -Qed. - -From Stdlib Require Import Rbase. - -Goal forall x y:R, x = y -> (x+0)%R = (y*1+0)%R. -nsatz. -Qed. - -Goal forall a b c x:R, a = b -> b = c -> (a*a)%R = (c*c)%R. -nsatz. -Qed. - -End test. - -Section Geometry. -(* See the interactive pictures of Laurent ThĆ©ry - on http://www-sop.inria.fr/marelle/CertiGeo/ - and research paper on - https://docs.google.com/fileview?id=0ByhB3nPmbnjTYzFiZmIyNGMtYTkwNC00NWFiLWJiNzEtODM4NmVkYTc2NTVk&hl=fr -*) - -From Stdlib Require Import Rbase. -From Stdlib Require Import List. - -Record point:Type:={ - X:R; - Y:R}. - -Definition collinear(A B C:point):= - (X A - X B)*(Y C - Y B)-(Y A - Y B)*(X C - X B)=0. - -Definition parallel (A B C D:point):= - ((X A)-(X B))*((Y C)-(Y D))=((Y A)-(Y B))*((X C)-(X D)). - -Definition notparallel (A B C D:point)(x:R):= - x*(((X A)-(X B))*((Y C)-(Y D))-((Y A)-(Y B))*((X C)-(X D)))=1. - -Definition orthogonal (A B C D:point):= - ((X A)-(X B))*((X C)-(X D))+((Y A)-(Y B))*((Y C)-(Y D))=0. - -Definition equal2(A B:point):= - (X A)=(X B) /\ (Y A)=(Y B). - -Definition equal3(A B:point):= - ((X A)-(X B))^2%Z+((Y A)-(Y B))^2%Z = 0. - -Definition nequal2(A B:point):= - (X A)<>(X B) \/ (Y A)<>(Y B). - -Definition nequal3(A B:point):= - not (((X A)-(X B))^2%Z+((Y A)-(Y B))^2%Z = 0). - -Definition middle(A B I:point):= - 2%R*(X I)=(X A)+(X B) /\ 2%R*(Y I)=(Y A)+(Y B). - -Definition distance2(A B:point):= - (X B - X A)^2%Z + (Y B - Y A)^2%Z. - -(* AB = CD *) -Definition samedistance2(A B C D:point):= - (X B - X A)^2%Z + (Y B - Y A)^2%Z = (X D - X C)^2%Z + (Y D - Y C)^2%Z. -Definition determinant(A O B:point):= - (X A - X O)*(Y B - Y O) - (Y A - Y O)*(X B - X O). -Definition scalarproduct(A O B:point):= - (X A - X O)*(X B - X O) + (Y A - Y O)*(Y B - Y O). -Definition norm2(A O B:point):= - ((X A - X O)^2%Z+(Y A - Y O)^2%Z)*((X B - X O)^2%Z+(Y B - Y O)^2%Z). - -Definition equaldistance(A B C D:point):= - ((X B) - (X A))^2%Z + ((Y B) - (Y A))^2%Z = - ((X D) - (X C))^2%Z + ((Y D) - (Y C))^2%Z. - -Definition equaltangente(A B C D E F:point):= - let s1:= determinant A B C in - let c1:= scalarproduct A B C in - let s2:= determinant D E F in - let c2:= scalarproduct D E F in - s1 * c2 = s2 * c1. - -Ltac cnf2 f := - match f with - | ?A \/ (?B /\ ?C) => - let c1 := cnf2 (A\/B) in - let c2 := cnf2 (A\/C) in constr:(c1/\c2) - | (?B /\ ?C) \/ ?A => - let c1 := cnf2 (B\/A) in - let c2 := cnf2 (C\/A) in constr:(c1/\c2) - | (?A \/ ?B) \/ ?C => - let c1 := cnf2 (B\/C) in cnf2 (A \/ c1) - | _ => f - end -with cnf f := - match f with - | ?A \/ ?B => - let c1 := cnf A in - let c2 := cnf B in - cnf2 (c1 \/ c2) - | ?A /\ ?B => - let c1 := cnf A in - let c2 := cnf B in - constr:(c1 /\ c2) - | _ => f - end. - -Ltac scnf := - match goal with - | |- ?f => let c := cnf f in - assert c;[repeat split| tauto] - end. - -Ltac disj_to_pol f := - match f with - | ?a = ?b \/ ?g => let p := disj_to_pol g in constr:((a - b)* p) - | ?a = ?b => constr:(a - b) - end. - -Lemma fastnsatz1:forall x y:R, x - y = 0 -> x = y. -nsatz. -Qed. - -Ltac fastnsatz:= - try trivial; try apply fastnsatz1; try trivial; nsatz. - -Ltac proof_pol_disj := - match goal with - | |- ?g => let p := disj_to_pol g in - let h := fresh "hp" in - assert (h:p = 0); - [idtac| - prod_disj h p] - | _ => idtac - end -with prod_disj h p := - match goal with - | |- ?a = ?b \/ ?g => - match p with - | ?q * ?p1 => - let h0 := fresh "hp" in - let h1 := fresh "hp" in - let h2 := fresh "hp" in - assert (h0:a - b = 0 \/ p1 = 0); - [apply Rmult_integral; exact h| - destruct h0 as [h1|h2]; - [left; fastnsatz| - right; prod_disj h2 p1]] - end - | _ => fastnsatz - end. - -(* -Goal forall a b c d e f:R, a=b \/ c=d \/ e=f \/ e=a. -intros. scnf; proof_pol_disj . -admit.*) - -Ltac geo_unfold := - unfold collinear, parallel, notparallel, orthogonal, - equal2, equal3, nequal2, nequal3, - middle, samedistance2, - determinant, scalarproduct, norm2, distance2, - equaltangente, determinant, scalarproduct, equaldistance. - -Ltac geo_rewrite_hyps:= - repeat (match goal with - | h:X _ = _ |- _ => rewrite h in *; clear h - | h:Y _ = _ |- _ => rewrite h in *; clear h - end). - -Ltac geo_split_hyps:= - repeat (match goal with - | h:_ /\ _ |- _ => destruct h - end). - -Ltac geo_begin:= - geo_unfold; - intros; - geo_rewrite_hyps; - geo_split_hyps; - scnf; proof_pol_disj. - -(* Examples *) - -Lemma medians: forall A B C A1 B1 C1 H:point, - middle B C A1 -> - middle A C B1 -> - middle A B C1 -> - collinear A A1 H -> collinear B B1 H -> - collinear C C1 H - \/ collinear A B C. -Proof. geo_begin. -idtac "Medians". - Time nsatz. -(*Finished transaction in 2. secs (2.69359u,0.s) -*) Qed. - -Lemma Pythagore: forall A B C:point, - orthogonal A B A C -> - distance2 A C + distance2 A B = distance2 B C. -Proof. geo_begin. -idtac "Pythagore". -Time nsatz. -(*Finished transaction in 0. secs (0.354946u,0.s) -*) Qed. - -Lemma Thales: forall O A B C D:point, - collinear O A C -> collinear O B D -> - parallel A B C D -> - (distance2 O B * distance2 O C = distance2 O D * distance2 O A - /\ distance2 O B * distance2 C D = distance2 O D * distance2 A B) - \/ collinear O A B. -geo_begin. -idtac "Thales". -Time nsatz. (*Finished transaction in 2. secs (1.598757u,0.s)*) -Time nsatz. -Qed. - -Lemma segments_of_chords: forall A B C D M O:point, - equaldistance O A O B -> - equaldistance O A O C -> - equaldistance O A O D -> - collinear A B M -> - collinear C D M -> - (distance2 M A) * (distance2 M B) = (distance2 M C) * (distance2 M D) - \/ parallel A B C D. -Proof. -geo_begin. -idtac "segments_of_chords". -Time nsatz. -(*Finished transaction in 3. secs (2.704589u,0.s) -*) Qed. - - -Lemma isoceles: forall A B C:point, - equaltangente A B C B C A -> - distance2 A B = distance2 A C - \/ collinear A B C. -Proof. geo_begin. Time nsatz. -(*Finished transaction in 1. secs (1.140827u,0.s)*) Qed. - -Lemma minh: forall A B C D O E H I:point, - X A = 0 -> Y A = 0 -> Y O = 0 -> - equaldistance O A O B -> - equaldistance O A O C -> - equaldistance O A O D -> - orthogonal A C B D -> - collinear A C E -> - collinear B D E -> - collinear A B H -> - orthogonal E H A B -> - collinear C D I -> - middle C D I -> - collinear H E I - \/ (X C)^2%Z * (X B)^5%Z * (X O)^2%Z - * (X C - 2%Z * X O)^3%Z * (-2%Z * X O + X B)=0 - \/ parallel A C B D. -Proof. geo_begin. -idtac "minh". -Time nsatz with radicalmax :=1%N strategy:=1%Z - parameters:=[X O; X B; X C] - variables:= (@nil R). -(*Finished transaction in 13. secs (10.102464u,0.s) -*) -Qed. - -Lemma Pappus: forall A B C A1 B1 C1 P Q S:point, - X A = 0 -> Y A = 0 -> Y B = 0 -> Y C = 0 -> - collinear A1 B1 C1 -> - collinear A B1 P -> collinear A1 B P -> - collinear A C1 Q -> collinear A1 C Q -> - collinear B C1 S -> collinear B1 C S -> - collinear P Q S - \/ (Y A1 - Y B1)^2%Z=0 \/ (X A = X B1) - \/ (X A1 = X C) \/ (X C = X B1) - \/ parallel A B1 A1 B \/ parallel A C1 A1 C \/ parallel B C1 B1 C. -Proof. -geo_begin. -idtac "Pappus". -Time nsatz with radicalmax :=1%N strategy:=0%Z - parameters:=[X B; X A1; Y A1; X B1; Y B1; X C; Y C1] - variables:= [X B; - X A1; - Y A1; - X B1; - Y B1; - X C; - Y C1; - X C1; Y P; X P; Y Q; X Q; Y S; X S]. -(*Finished transaction in 8. secs (7.795815u,0.000999999999999s) -*) -Qed. - -Lemma Simson: forall A B C O D E F G:point, - X A = 0 -> Y A = 0 -> - equaldistance O A O B -> - equaldistance O A O C -> - equaldistance O A O D -> - orthogonal E D B C -> - collinear B C E -> - orthogonal F D A C -> - collinear A C F -> - orthogonal G D A B -> - collinear A B G -> - collinear E F G - \/ (X C)^2%Z = 0 \/ (Y C)^2%Z = 0 \/ (X B)^2%Z = 0 \/ (Y B)^2%Z = 0 \/ (Y C - Y B)^2%Z = 0 - \/ equal3 B A - \/ equal3 A C \/ (X C - X B)^2%Z = 0 - \/ equal3 B C. -Proof. -geo_begin. -idtac "Simson". -Time nsatz with radicalmax :=1%N strategy:=0%Z - parameters:=[X B; Y B; X C; Y C; Y D] - variables:= (@nil R). (* compute -[X Y]. *) -(*Finished transaction in 8. secs (7.550852u,0.s) -*) -Qed. - -Lemma threepoints: forall A B C A1 B1 A2 B2 H1 H2 H3:point, - (* H1 intersection of bisections *) - middle B C A1 -> orthogonal H1 A1 B C -> - middle A C B1 -> orthogonal H1 B1 A C -> - (* H2 intersection of medians *) - collinear A A1 H2 -> collinear B B1 H2 -> - (* H3 intersection of altitudes *) - collinear B C A2 -> orthogonal A A2 B C -> - collinear A C B2 -> orthogonal B B2 A C -> - collinear A A1 H3 -> collinear B B1 H3 -> - collinear H1 H2 H3 - \/ collinear A B C. -Proof. geo_begin. -idtac "threepoints". -Time nsatz. -(*Finished transaction in 7. secs (6.282045u,0.s) -*) Qed. - -Lemma Feuerbach: forall A B C A1 B1 C1 O A2 B2 C2 O2:point, - forall r r2:R, - X A = 0 -> Y A = 0 -> X B = 1 -> Y B = 0-> - middle A B C1 -> middle B C A1 -> middle C A B1 -> - distance2 O A1 = distance2 O B1 -> - distance2 O A1 = distance2 O C1 -> - collinear A B C2 -> orthogonal A B O2 C2 -> - collinear B C A2 -> orthogonal B C O2 A2 -> - collinear A C B2 -> orthogonal A C O2 B2 -> - distance2 O2 A2 = distance2 O2 B2 -> - distance2 O2 A2 = distance2 O2 C2 -> - r^2%Z = distance2 O A1 -> - r2^2%Z = distance2 O2 A2 -> - distance2 O O2 = (r + r2)^2%Z - \/ distance2 O O2 = (r - r2)^2%Z - \/ collinear A B C. -Proof. geo_begin. -idtac "Feuerbach". -Time nsatz. -(*Finished transaction in 21. secs (19.021109u,0.s)*) -Qed. - - - - -Lemma Euler_circle: forall A B C A1 B1 C1 A2 B2 C2 O:point, - middle A B C1 -> middle B C A1 -> middle C A B1 -> - orthogonal A B C C2 -> collinear A B C2 -> - orthogonal B C A A2 -> collinear B C A2 -> - orthogonal A C B B2 -> collinear A C B2 -> - distance2 O A1 = distance2 O B1 -> - distance2 O A1 = distance2 O C1 -> - (distance2 O A2 = distance2 O A1 - /\distance2 O B2 = distance2 O A1 - /\distance2 O C2 = distance2 O A1) - \/ collinear A B C. -Proof. geo_begin. -idtac "Euler_circle 3 goals". -Time nsatz. -(*Finished transaction in 13. secs (11.208296u,0.124981s)*) -Time nsatz. -(*Finished transaction in 10. secs (8.846655u,0.s)*) -Time nsatz. -(*Finished transaction in 11. secs (9.186603u,0.s)*) -Qed. - - - -Lemma Desargues: forall A B C A1 B1 C1 P Q T S:point, - X S = 0 -> Y S = 0 -> Y A = 0 -> - collinear A S A1 -> collinear B S B1 -> collinear C S C1 -> - collinear B1 C1 P -> collinear B C P -> - collinear A1 C1 Q -> collinear A C Q -> - collinear A1 B1 T -> collinear A B T -> - collinear P Q T - \/ X A = X B \/ X A = X C \/ X B = X C \/ X A = 0 \/ Y B = 0 \/ Y C = 0 - \/ collinear S B C \/ parallel A C A1 C1 \/ parallel A B A1 B1. -Proof. -geo_begin. -idtac "Desargues". -Time -let lv := rev [X A; - X B; - Y B; - X C; - Y C; - Y A1; X A1; - Y B1; - Y C1; - X T; - Y T; - X Q; - Y Q; X P; Y P; X C1; X B1] in -nsatz with radicalmax :=1%N strategy:=0%Z - parameters:=[X A; X B; Y B; X C; Y C; X A1; Y B1; Y C1] - variables:= lv. (*Finished transaction in 8. secs (8.02578u,0.001s)*) -Qed. - -Lemma chords: forall O A B C D M:point, - equaldistance O A O B -> - equaldistance O A O C -> - equaldistance O A O D -> - collinear A B M -> collinear C D M -> - scalarproduct A M B = scalarproduct C M D - \/ parallel A B C D. -Proof. geo_begin. -idtac "chords". - Time nsatz. -(*Finished transaction in 4. secs (3.959398u,0.s)*) -Qed. - -Lemma Ceva: forall A B C D E F M:point, - collinear M A D -> collinear M B E -> collinear M C F -> - collinear B C D -> collinear E A C -> collinear F A B -> - (distance2 D B) * (distance2 E C) * (distance2 F A) = - (distance2 D C) * (distance2 E A) * (distance2 F B) - \/ collinear A B C. -Proof. geo_begin. -idtac "Ceva". -Time nsatz. -(*Finished transaction in 105. secs (104.121171u,0.474928s)*) -Qed. - -Lemma bissectrices: forall A B C M:point, - equaltangente C A M M A B -> - equaltangente A B M M B C -> - equaltangente B C M M C A - \/ equal3 A B. -Proof. geo_begin. -idtac "bissectrices". -Time nsatz. -(*Finished transaction in 2. secs (1.937705u,0.s)*) -Qed. - -Lemma bisections: forall A B C A1 B1 C1 H:point, - middle B C A1 -> orthogonal H A1 B C -> - middle A C B1 -> orthogonal H B1 A C -> - middle A B C1 -> - orthogonal H C1 A B - \/ collinear A B C. -Proof. geo_begin. -idtac "bisections". -Time nsatz. (*Finished transaction in 2. secs (2.024692u,0.002s)*) -Qed. - -Lemma altitudes: forall A B C A1 B1 C1 H:point, - collinear B C A1 -> orthogonal A A1 B C -> - collinear A C B1 -> orthogonal B B1 A C -> - collinear A B C1 -> orthogonal C C1 A B -> - collinear A A1 H -> collinear B B1 H -> - collinear C C1 H - \/ equal2 A B - \/ collinear A B C. -Proof. geo_begin. -idtac "altitudes". -Time nsatz. (*Finished transaction in 3. secs (3.001544u,0.s)*) -Time nsatz. (*Finished transaction in 4. secs (3.113527u,0.s)*) -Qed. - -Lemma hauteurs:forall A B C A1 B1 C1 H:point, - collinear B C A1 -> orthogonal A A1 B C -> - collinear A C B1 -> orthogonal B B1 A C -> - collinear A B C1 -> orthogonal C C1 A B -> - collinear A A1 H -> collinear B B1 H -> - - collinear C C1 H - \/ collinear A B C. - -geo_begin. -idtac "hauteurs". -Time - let lv := constr:([Y A1; - X A1; Y B1; X B1; Y A; Y B; X B; X A; X H; Y C; - Y C1; Y H; X C1; X C]) in -nsatz with radicalmax := 2%N strategy := 1%Z parameters := (@Datatypes.nil R) - variables := lv. -(*Finished transaction in 5. secs (4.360337u,0.008999s)*) -Qed. - - -End Geometry. diff --git a/stdlib/test-suite/success/NumberScopes.v b/stdlib/test-suite/success/NumberScopes.v deleted file mode 100644 index 57da19bbdceb..000000000000 --- a/stdlib/test-suite/success/NumberScopes.v +++ /dev/null @@ -1,41 +0,0 @@ - -(* We check that various definitions or lemmas have the correct - argument scopes, especially the ones created via functor application. *) - -Close Scope nat_scope. - -From Stdlib Require Import PArith. -Check (Pos.add 1 2). -Check (Pos.add_comm 1 2). -Check (Pos.min_comm 1 2). -Definition f_pos (x:positive) := x. -Definition f_pos' (x:Pos.t) := x. -Check (f_pos 1). -Check (f_pos' 1). - -From Stdlib Require Import ZArith. -Check (Z.add 1 2). -Check (Z.add_comm 1 2). -Check (Z.min_comm 1 2). -Definition f_Z (x:Z) := x. -Definition f_Z' (x:Z.t) := x. -Check (f_Z 1). -Check (f_Z' 1). - -From Stdlib Require Import NArith. -Check (N.add 1 2). -Check (N.add_comm 1 2). -Check (N.min_comm 1 2). -Definition f_N (x:N) := x. -Definition f_N' (x:N.t) := x. -Check (f_N 1). -Check (f_N' 1). - -From Stdlib Require Import Arith. -Check (Nat.add 1 2). -Check (Nat.add_comm 1 2). -Check (Nat.min_comm 1 2). -Definition f_nat (x:nat) := x. -Definition f_nat' (x:Nat.t) := x. -Check (f_nat 1). -Check (f_nat' 1). diff --git a/stdlib/test-suite/success/Omega.v b/stdlib/test-suite/success/Omega.v deleted file mode 100644 index bb97f9a6615e..000000000000 --- a/stdlib/test-suite/success/Omega.v +++ /dev/null @@ -1,93 +0,0 @@ -From Stdlib Require Import Lia ZArith. - -(* Submitted by Xavier Urbain 18 Jan 2002 *) - -Lemma lem1 : - forall x y : Z, (-5 < x < 5)%Z -> (-5 < y)%Z -> (-5 < x + y + 5)%Z. -Proof. -intros x y. - lia. -Qed. - -(* Proposed by Pierre CrĆ©gut *) - -Lemma lem2 : forall x : Z, (x < 4)%Z -> (x > 2)%Z -> x = 3%Z. -intro. - lia. -Qed. - -(* Proposed by Jean-Christophe FilliĆ¢tre *) - -Lemma lem3 : forall x y : Z, x = y -> (x + x)%Z = (y + y)%Z. -Proof. -intros. - lia. -Qed. - -(* Proposed by Jean-Christophe FilliĆ¢tre: confusion between an Omega *) -(* internal variable and a section variable (June 2001) *) - -Section A. -Variable x y : Z. -Hypothesis H : (x > y)%Z. -Lemma lem4 : (x > y)%Z. - lia. -Qed. -End A. - -(* Proposed by Yves Bertot: because a section var, L was wrongly renamed L0 *) -(* May 2002 *) - -Section B. -Variable R1 R2 S1 S2 H S : Z. -Hypothesis I : (R1 < 0)%Z -> R2 = (R1 + (2 * S1 - 1))%Z. -Hypothesis J : (R1 < 0)%Z -> S2 = (S1 - 1)%Z. -Hypothesis K : (R1 >= 0)%Z -> R2 = R1. -Hypothesis L : (R1 >= 0)%Z -> S2 = S1. -Hypothesis M : (H <= 2 * S)%Z. -Hypothesis N : (S < H)%Z. -Lemma lem5 : (H > 0)%Z. - lia. -Qed. -End B. - -(* From Nicolas Oury (BZ#180): handling -> on Set (fixed Oct 2002) *) -Lemma lem6 : - forall (A : Set) (i : Z), (i <= 0)%Z -> ((i <= 0)%Z -> A) -> (i <= 0)%Z. -intros. - lia. -Qed. - -(* Adapted from an example in Nijmegen/FTA/ftc/RefSeparating (Oct 2002) *) -From Stdlib Require Import Lia. -Section C. -Parameter g : forall m : nat, m <> 0 -> Prop. -Parameter f : forall (m : nat) (H : m <> 0), g m H. -Variable n : nat. -Variable ap_n : n <> 0. -Let delta := f n ap_n. -Lemma lem7 : n = n. - lia. -Qed. -End C. - -(* Problem of dependencies *) -From Stdlib Require Import Lia. -Lemma lem8 : forall H : 0 = 0 -> 0 = 0, H = H -> 0 = 0. -intros; lia. -Qed. - -(* Bug that what caused by the use of intro_using in Omega *) -From Stdlib Require Import Lia. -Lemma lem9 : - forall p q : nat, ~ (p <= q /\ p < q \/ q <= p /\ p < q) -> p < p \/ p <= p. -intros; lia. -Qed. - -(* Check that the interpretation of mult on nat enforces its positivity *) -(* Submitted by Hubert Thierry (BZ#743) *) -(* Postponed... problem with goals of the form "(n*m=0)%nat -> (n*m=0)%Z" *) -Lemma lem10 : forall n m:nat, le n (plus n (mult n m)). -Proof. -intros; lia. -Qed. diff --git a/stdlib/test-suite/success/Omega0.v b/stdlib/test-suite/success/Omega0.v deleted file mode 100644 index 6de1671a3cd6..000000000000 --- a/stdlib/test-suite/success/Omega0.v +++ /dev/null @@ -1,145 +0,0 @@ -From Stdlib Require Import ZArith Lia. -Open Scope Z_scope. - -(* Pierre L: examples gathered while debugging romega. *) - -Lemma test_romega_0 : - forall m m', - 0<= m <= 1 -> 0<= m' <= 1 -> (0 < m <-> 0 < m') -> m = m'. -Proof. -intros. -lia. -Qed. - -Lemma test_romega_0b : - forall m m', - 0<= m <= 1 -> 0<= m' <= 1 -> (0 < m <-> 0 < m') -> m = m'. -Proof. -intros m m'. -lia. -Qed. - -Lemma test_romega_1 : - forall (z z1 z2 : Z), - z2 <= z1 -> - z1 <= z2 -> - z1 >= 0 -> - z2 >= 0 -> - z1 >= z2 /\ z = z1 \/ z1 <= z2 /\ z = z2 -> - z >= 0. -Proof. -intros. -lia. -Qed. - -Lemma test_romega_1b : - forall (z z1 z2 : Z), - z2 <= z1 -> - z1 <= z2 -> - z1 >= 0 -> - z2 >= 0 -> - z1 >= z2 /\ z = z1 \/ z1 <= z2 /\ z = z2 -> - z >= 0. -Proof. -intros z z1 z2. -lia. -Qed. - -Lemma test_romega_2 : forall a b c:Z, - 0<=a-b<=1 -> b-c<=2 -> a-c<=3. -Proof. -intros. -lia. -Qed. - -Lemma test_romega_2b : forall a b c:Z, - 0<=a-b<=1 -> b-c<=2 -> a-c<=3. -Proof. -intros a b c. -lia. -Qed. - -Lemma test_romega_3 : forall a b h hl hr ha hb, - 0 <= ha - hl <= 1 -> - -2 <= hl - hr <= 2 -> - h =b+1 -> - (ha >= hr /\ a = ha \/ ha <= hr /\ a = hr) -> - (hl >= hr /\ b = hl \/ hl <= hr /\ b = hr) -> - (-3 <= ha -hr <=3 -> 0 <= hb - a <= 1) -> - (-2 <= ha-hr <=2 -> hb = a + 1) -> - 0 <= hb - h <= 1. -Proof. -intros. -lia. -Qed. - -Lemma test_romega_3b : forall a b h hl hr ha hb, - 0 <= ha - hl <= 1 -> - -2 <= hl - hr <= 2 -> - h =b+1 -> - (ha >= hr /\ a = ha \/ ha <= hr /\ a = hr) -> - (hl >= hr /\ b = hl \/ hl <= hr /\ b = hr) -> - (-3 <= ha -hr <=3 -> 0 <= hb - a <= 1) -> - (-2 <= ha-hr <=2 -> hb = a + 1) -> - 0 <= hb - h <= 1. -Proof. -intros a b h hl hr ha hb. -lia. -Qed. - - -Lemma test_romega_4 : forall hr ha, - ha = 0 -> - (ha = 0 -> hr =0) -> - hr = 0. -Proof. -intros hr ha. -lia. -Qed. - -Lemma test_romega_5 : forall hr ha, - ha = 0 -> - (~ha = 0 \/ hr =0) -> - hr = 0. -Proof. -intros hr ha. -lia. -Qed. - -Lemma test_romega_6 : forall z, z>=0 -> 0>z+2 -> False. -Proof. -intros. -lia. -Qed. - -Lemma test_romega_6b : forall z, z>=0 -> 0>z+2 -> False. -Proof. -intros z. -lia. -Qed. - -Lemma test_romega_7 : forall z, - 0>=0 /\ z=0 \/ 0<=0 /\ z =0 -> 1 = z+1. -Proof. -intros. -lia. -Qed. - -Lemma test_romega_7b : forall z, - 0>=0 /\ z=0 \/ 0<=0 /\ z =0 -> 1 = z+1. -Proof. -intros. -lia. -Qed. - -(* Magaud BZ#240 *) - -Lemma test_romega_8 : forall x y:Z, x*x ~ y*y <= x*x. -intros. -lia. -Qed. - -Lemma test_romega_8b : forall x y:Z, x*x ~ y*y <= x*x. -intros x y. -lia. -Qed. diff --git a/stdlib/test-suite/success/Omega2.v b/stdlib/test-suite/success/Omega2.v deleted file mode 100644 index 1fbefdfdf3f4..000000000000 --- a/stdlib/test-suite/success/Omega2.v +++ /dev/null @@ -1,27 +0,0 @@ -From Stdlib Require Import ZArith Lia. - -(* Submitted by Yegor Bryukhov (BZ#922) *) - -Open Scope Z_scope. - -Lemma Test46 : -forall v1 v2 v3 v4 v5 : Z, -((2 * v4) + (5)) + (8 * v2) <= ((4 * v4) + (3 * v4)) + (5 * v4) -> -9 * v4 > (1 * v4) + ((2 * v1) + (0 * v2)) -> -((9 * v3) + (2 * v5)) + (5 * v2) = 3 * v4 -> -0 > 6 * v1 -> -(0 * v3) + (6 * v2) <> 2 -> -(0 * v3) + (5 * v5) <> ((4 * v2) + (8 * v2)) + (2 * v5) -> -7 * v3 > 5 * v5 -> -0 * v4 >= ((5 * v1) + (4 * v1)) + ((6 * v5) + (3 * v5)) -> -7 * v2 = ((3 * v2) + (6 * v5)) + (7 * v2) -> -0 * v3 > 7 * v1 -> -9 * v2 < 9 * v5 -> -(2 * v3) + (8 * v1) <= 5 * v4 -> -5 * v2 = ((5 * v1) + (0 * v5)) + (1 * v2) -> -0 * v5 <= 9 * v2 -> -((7 * v1) + (1 * v3)) + ((2 * v3) + (1 * v3)) >= ((6 * v5) + (4)) + ((1) + (9)) --> False. -intros. -lia. -Qed. diff --git a/stdlib/test-suite/success/OmegaPre.v b/stdlib/test-suite/success/OmegaPre.v deleted file mode 100644 index b62da201178a..000000000000 --- a/stdlib/test-suite/success/OmegaPre.v +++ /dev/null @@ -1,124 +0,0 @@ -From Stdlib Require Import ZArith Nnat Lia. -Open Scope Z_scope. - -(** Test of the zify preprocessor for (R)Omega *) - -(* More details in file PreOmega.v - - (r)omega with Z : starts with zify_op - (r)omega with nat : starts with zify_nat - (r)omega with positive : starts with zify_positive - (r)omega with N : starts with uses zify_N - (r)omega with * : starts zify (a saturation of the others) -*) - -(* zify_op *) - -Goal forall a:Z, Z.max a a = a. -intros. -lia. -Qed. - -Goal forall a b:Z, Z.max a b = Z.max b a. -intros. -lia. -Qed. - -Goal forall a b c:Z, Z.max a (Z.max b c) = Z.max (Z.max a b) c. -intros. -lia. -Qed. - -Goal forall a b:Z, Z.max a b + Z.min a b = a + b. -intros. -lia. -Qed. - -Goal forall a:Z, (Z.abs a)*(Z.sgn a) = a. -intros. -intuition; subst; lia. -Qed. - -Goal forall a:Z, Z.abs a = a -> a >= 0. -intros. -lia. -Qed. - -Goal forall a:Z, Z.sgn a = a -> a = 1 \/ a = 0 \/ a = -1. -intros. -lia. -Qed. - -(* zify_nat *) - -Goal forall m: nat, (m<2)%nat -> (0<= m+m <=2)%nat. -intros. -lia. -Qed. - -Goal forall m:nat, (m<1)%nat -> (m=0)%nat. -intros. -lia. -Qed. - -Goal forall m: nat, (m<=100)%nat -> (0<= m+m <=200)%nat. -intros. -lia. -Qed. -(* 2000 instead of 200: works, but quite slow *) - -Goal forall m: nat, (m*m>=0)%nat. -intros. -lia. -Qed. - -(* zify_positive *) - -Goal forall m: positive, (m<2)%positive -> (2 <= m+m /\ m+m <= 2)%positive. -intros. -lia. -Qed. - -Goal forall m:positive, (m<2)%positive -> (m=1)%positive. -intros. -lia. -Qed. - -Goal forall m: positive, (m<=1000)%positive -> (2<=m+m/\m+m <=2000)%positive. -intros. -lia. -Qed. - -Goal forall m: positive, (m*m>=1)%positive. -intros. -lia. -Qed. - -(* zify_N *) - -Goal forall m:N, (m<2)%N -> (0 <= m+m /\ m+m <= 2)%N. -intros. -lia. -Qed. - -Goal forall m:N, (m<1)%N -> (m=0)%N. -intros. -lia. -Qed. - -Goal forall m:N, (m<=1000)%N -> (0<=m+m/\m+m <=2000)%N. -intros. -lia. -Qed. - -Goal forall m:N, (m*m>=0)%N. -intros. -lia. -Qed. - -(* mix of datatypes *) - -Goal forall p, Z.of_N (N.of_nat (N.to_nat (Npos p))) = Zpos p. -intros. -lia. -Qed. diff --git a/stdlib/test-suite/success/PrintSortedUniverses.v b/stdlib/test-suite/success/PrintSortedUniverses.v deleted file mode 100644 index 3b18646e54ff..000000000000 --- a/stdlib/test-suite/success/PrintSortedUniverses.v +++ /dev/null @@ -1,2 +0,0 @@ -From Stdlib Require Reals. -Print Sorted Universes. diff --git a/stdlib/test-suite/success/ProgramCases.v b/stdlib/test-suite/success/ProgramCases.v deleted file mode 100644 index 466ab8b0008d..000000000000 --- a/stdlib/test-suite/success/ProgramCases.v +++ /dev/null @@ -1,33 +0,0 @@ -From Stdlib Require Import Vector Program. - -Module T. - -Inductive T A B : forall n, t A n -> Type := cons n m p c d e : A -> B -> T A B n c -> T A B m d -> T A B p e. - -Program Definition h {A B : Type} {n1 n2 : nat} (v1 : t A n1) (v2 : t A n2) (p1 : T A B n1 v1) (p2 : T A B n2 v2) : nat := - match p1, p2 with - | cons _ _ i1 j1 k1 c1 d1 e1 a1 b1 q1 r1, cons _ _ i2 j2 k2 c2 d2 e2 a2 b2 q2 r2 => 0 - end. - -Program Definition h2 {A B : Type} b {n1 n2 : nat} (v1 : t A n1) (v2 : t A n2) (p1 : T A B n1 v1) (p2 : T A B n2 v2) : nat := - match b, p1, p2 with - | true, cons _ _ i1 j1 k1 c1 d1 e1 a1 b1 q1 r1, _ => 0 - | false, _, cons _ _ i2 j2 k2 c2 d2 e2 a2 b2 q2 r2 => 0 - end. - -End T. - -Module U. - -Inductive U A B : forall n, t A n -> Type := - | cons n m p c d e : A -> B -> U A B n c -> U A B m d -> U A B p e - | nil n c : U A B n c. - -Program Definition h {A B : Type} {n1 n2 : nat} (v1 : t A n1) (v2 : t A n2) (p1 : U A B n1 v1) (p2 : U A B n2 v2) : nat := - match p1, p2 with - | cons _ _ i1 j1 k1 c1 d1 e1 a1 b1 q1 r1, _ => 0 - | _, cons _ _ i2 j2 k2 c2 d2 e2 a2 b2 q2 r2 => 0 - | _, _ => 0 - end. - -End U. diff --git a/stdlib/test-suite/success/ProgramWf.v b/stdlib/test-suite/success/ProgramWf.v deleted file mode 100644 index 0b27cdd00f33..000000000000 --- a/stdlib/test-suite/success/ProgramWf.v +++ /dev/null @@ -1,146 +0,0 @@ -(* Before loading Program, check non-anomaly on missing library Program *) - -Fail Program Definition f n (e:n=n): {n|n=0} := match n,e with 0, refl => 0 | _, _ => 0 end. - -(* Then we test Program properly speaking *) - -From Stdlib Require Import Arith Program. -From Stdlib Require Import ZArith Zwf. - -Set Implicit Arguments. -(* Set Printing All. *) -Print sigT_rect. -Obligation Tactic := program_simplify ; auto with *. -About MR. - -Program Fixpoint merge (n m : nat) {measure (n + m) lt} : nat := - match n with - | 0 => 0 - | S n' => merge n' m - end. - -Print merge. - - -Print Z.lt. -Print Zwf. - -Local Open Scope Z_scope. - -Program Fixpoint Zwfrec (n m : Z) {measure (n + m) (Zwf 0)} : Z := - match n ?= m with - | Lt => Zwfrec n (Z.pred m) - | _ => 0 - end. - -Next Obligation. - red. Admitted. - -Close Scope Z_scope. - -Program Fixpoint merge_wf (n m : nat) {wf lt m} : nat := - match n with - | 0 => 0 - | S n' => merge n' m - end. - -Print merge_wf. - -Program Fixpoint merge_one (n : nat) {measure n} : nat := - match n with - | 0 => 0 - | S n' => merge_one n' - end. - -Print Hint well_founded. -Print merge_one. Eval cbv delta [merge_one] beta zeta in merge_one. - -Import WfExtensionality. - -Lemma merge_unfold n m : merge n m = - match n with - | 0 => 0 - | S n' => merge n' m - end. -Proof. intros. unfold merge at 1. unfold merge_func. - unfold_sub merge (merge n m). - simpl. destruct n ; reflexivity. -Qed. - -Print merge. - -From Stdlib Require Import Arith. -Unset Implicit Arguments. - -Time Program Fixpoint check_n (n : nat) (P : { i | i < n } -> bool) (p : nat) - (H : forall (i : { i | i < n }), i < p -> P i = true) - {measure (n - p)} : - Exc (forall (p : { i | i < n}), P p = true) := - match le_lt_dec n p with - | left _ => value _ - | right cmp => - if dec (P p) then - check_n n P (S p) _ - else - error - end. - -From Stdlib Require Import Lia Setoid. - -Next Obligation. - intros ; simpl in *. apply H. - simpl in * ; lia. -Qed. - -Next Obligation. simpl in *; intros. - revert e ; clear_subset_proofs. intros. - case (le_gt_dec p i) ; intro. simpl in *. assert(p = i) by lia. subst. - revert e ; clear_subset_proofs ; tauto. - - apply H. simpl. lia. -Qed. - -Program Fixpoint check_n' (n : nat) (m : {m:nat | m = n}) (p : nat) (q:{q : nat | q = p}) - {measure (p - n)} : nat := - _. -Module FurtherArguments. - -Program Fixpoint zero (n : nat) {measure n} : nat -> nat := - match n with - | 0 => fun _ => 0 - | S n' => zero n' - end. - -Program Fixpoint f n {B} (b:B) {measure n} : forall {A}, A -> A * B := - match n with - | 0 => fun A a => (a, b) - | S n => fun A a => f n b a - end. - -End FurtherArguments. - -Module Notations. - -Reserved Notation "[ x ]". -Program Fixpoint zero (n : nat) {measure n} : nat -> nat := - match n with - | 0 => fun _ => 0 - | S n' => [ n' ] - end - -where "[ n ]" := (zero n). - -Check eq_refl : ([ 0 ] 0) = 0. - -Reserved Notation "[[ x | y ]]". -Program Fixpoint zero' (n : nat) {measure n} : nat -> nat := - match n with - | 0 => fun _ => 0 - | S n' => fun a => [[ n' | a ]] - end - -where "[[ n | p ]]" := (zero' n p). - -Check eq_refl : [[ 0 | 0 ]] = 0. - -End Notations. diff --git a/stdlib/test-suite/success/ProgramWfPoly.v b/stdlib/test-suite/success/ProgramWfPoly.v deleted file mode 100644 index 586ae94f0f02..000000000000 --- a/stdlib/test-suite/success/ProgramWfPoly.v +++ /dev/null @@ -1,178 +0,0 @@ -(* An example extracted by the minimizer from category-theory *) - -Require Coq.FSets.FMaps. -Require Coq.Program.Program. - -Axiom proof_admitted : False. -Tactic Notation "admit" := abstract case proof_admitted. - -Declare Scope category_theory_scope. -Open Scope category_theory_scope. - -Module Export Category_DOT_Lib_WRAPPED. -Module Export Lib. -#[export] Set Universe Polymorphism. -#[export] Set Uniform Inductive Parameters. -#[export] Unset Universe Minimization ToSet. - -End Lib. - -End Category_DOT_Lib_WRAPPED. -Module Export Category_DOT_Lib_DOT_FMapExt_WRAPPED. -Module Export FMapExt. -Import Coq.FSets.FMapFacts. - -Module FMapExt (E : DecidableType) (M : WSfun E). - -Module P := WProperties_fun E M. -Module F := P.F. - -#[export] Hint Extern 5 => - match goal with - [ H : M.MapsTo _ _ (M.empty _) |- _ ] => - apply F.empty_mapsto_iff in H; contradiction - end : core. - -End FMapExt. - -End FMapExt. - -End Category_DOT_Lib_DOT_FMapExt_WRAPPED. -Module Export Lib. -Module Export FMapExt. -Include Category_DOT_Lib_DOT_FMapExt_WRAPPED.FMapExt. -End FMapExt. - -End Lib. -Import Coq.NArith.NArith. -Import Coq.FSets.FMaps. - -Module PO := PairOrderedType N_as_OT N_as_OT. -Module M := FMapList.Make(PO). -Module Import FMapExt := FMapExt PO M. - -Inductive partial (P : Prop) : Set := -| Proved : P -> partial -| Uncertain : partial. - -Notation "[ P ]" := (partial P) : type_scope. - -Notation "'Yes'" := (Proved _ _) : partial_scope. -Notation "'No'" := (Uncertain _) : partial_scope. - -#[local] Open Scope partial_scope. - -Notation "'Reduce' v" := (if v then Yes else No) (at level 100) : partial_scope. -Notation "x && y" := (if x then Reduce y else No) : partial_scope. - -Record environment : Set := { - vars : positive -> N -}. - -Inductive term : Set := - | Var : positive -> term - | Value : N -> term. - -Program Definition term_eq_dec (x y : term) : {x = y} + {x <> y} := - match x, y with - | Var x, Var y => if Pos.eq_dec x y then left _ else right _ - | Value x, Value y => if N.eq_dec x y then left _ else right _ - | _, _ => right _ - end. -Definition subst_all {A} (f : A -> term -> term -> A) : - A -> list (term * term) -> A. -exact (fold_right (fun '(v, v') rest => f rest v v')). -Defined. - -Definition term_denote env (x : term) : N := - match x with - | Var n => vars env n - | Value n => n - end. - -Inductive map_expr : Set := - | Empty : map_expr - | Add : term -> term -> term -> map_expr -> map_expr. - -Fixpoint map_expr_denote env (m : map_expr) : M.t N := - match m with - | Empty => M.empty N - | Add x y f m' => M.add (term_denote env x, term_denote env y) - (term_denote env f) (map_expr_denote env m') - end. - -Inductive formula : Set := - | Top : formula - | Bottom : formula - | Maps : term -> term -> term -> map_expr -> formula - | Impl : formula -> formula -> formula. -Fixpoint subst_formula (t : formula) (v v' : term) : formula. -Admitted. - -Fixpoint formula_denote env (t : formula) : Prop := - match t with - | Top => True - | Bottom => False - | Maps x y f m => - M.MapsTo (term_denote env x, term_denote env y) - (term_denote env f) (map_expr_denote env m) - | Impl p q => formula_denote env p -> formula_denote env q - end. -Fixpoint formula_size (t : formula) : nat. -Admitted. -Fixpoint substitutions (xs : list (term * term)) : list (term * term). -Admitted. -Fixpoint remove_conflicts (x y f : term) (m : map_expr) : map_expr. -Admitted. - -Import ListNotations. - -Program Definition formula_forward (t : formula) env (hyp : formula) - (cont : forall env' defs, - [formula_denote env' (subst_all subst_formula t defs)]) : - [formula_denote env hyp -> formula_denote env t] := - match hyp with - | Top => Reduce (cont env []) - | Bottom => Yes - | Maps x y f m => - let fix go n : [formula_denote env (Maps x y f n) - -> formula_denote env t] := - match n with - | Empty => Yes - | Add x' y' f' m' => - cont env (substitutions [(x, x'); (y, y'); (f, f')]) && go m' - end in Reduce (go (remove_conflicts x y f m)) - | Impl _ _ => Reduce (cont env []) - end. -Next Obligation. -Admitted. -Next Obligation. -admit. -Defined. -Admit Obligations. - -Fixpoint map_contains env (x y : N) (m : map_expr) : option term := - match m with - | Empty => None - | Add x' y' f' m' => - if (N.eqb x (term_denote env x') && - N.eqb y (term_denote env y'))%bool - then Some f' - else map_contains env x y m' - end. - -Program Fixpoint formula_backward (t : formula) env {measure (formula_size t)} : - [formula_denote env t] := - match t with - | Top => Yes - | Bottom => No - | Maps x y f m => - match map_contains env (term_denote env x) (term_denote env y) m with - | Some f' => Reduce (term_eq_dec f' f) - | None => No - end - | Impl p q => - formula_forward q env p - (fun env' defs' => formula_backward (subst_all subst_formula q defs') env') - end. -Admit Obligations. (* used to raise a universe instance length mismatch *) diff --git a/stdlib/test-suite/success/ROmega.v b/stdlib/test-suite/success/ROmega.v deleted file mode 100644 index c975e98edb53..000000000000 --- a/stdlib/test-suite/success/ROmega.v +++ /dev/null @@ -1,95 +0,0 @@ -(* This file used to test the `romega` tactics. - In Coq 8.9 (end of 2018), these tactics are deprecated. - The tests in this file remain but now call the `lia` tactic. *) -From Stdlib Require Import ZArith Lia. - -(* Submitted by Xavier Urbain 18 Jan 2002 *) - -Lemma lem1 : - forall x y : Z, (-5 < x < 5)%Z -> (-5 < y)%Z -> (-5 < x + y + 5)%Z. -Proof. -intros x y. -lia. -Qed. - -(* Proposed by Pierre CrĆ©gut *) - -Lemma lem2 : forall x : Z, (x < 4)%Z -> (x > 2)%Z -> x = 3%Z. -intro. - lia. -Qed. - -(* Proposed by Jean-Christophe FilliĆ¢tre *) - -Lemma lem3 : forall x y : Z, x = y -> (x + x)%Z = (y + y)%Z. -Proof. -intros. -lia. -Qed. - -(* Proposed by Jean-Christophe FilliĆ¢tre: confusion between an Omega *) -(* internal variable and a section variable (June 2001) *) - -Section A. -Variable x y : Z. -Hypothesis H : (x > y)%Z. -Lemma lem4 : (x > y)%Z. - lia. -Qed. -End A. - -(* Proposed by Yves Bertot: because a section var, L was wrongly renamed L0 *) -(* May 2002 *) - -Section B. -Variable R1 R2 S1 S2 H S : Z. -Hypothesis I : (R1 < 0)%Z -> R2 = (R1 + (2 * S1 - 1))%Z. -Hypothesis J : (R1 < 0)%Z -> S2 = (S1 - 1)%Z. -Hypothesis K : (R1 >= 0)%Z -> R2 = R1. -Hypothesis L : (R1 >= 0)%Z -> S2 = S1. -Hypothesis M : (H <= 2 * S)%Z. -Hypothesis N : (S < H)%Z. -Lemma lem5 : (H > 0)%Z. - lia. -Qed. -End B. - -(* From Nicolas Oury (BZ#180): handling -> on Set (fixed Oct 2002) *) -Lemma lem6 : - forall (A : Set) (i : Z), (i <= 0)%Z -> ((i <= 0)%Z -> A) -> (i <= 0)%Z. -intros. - lia. -Qed. - -(* Adapted from an example in Nijmegen/FTA/ftc/RefSeparating (Oct 2002) *) -Section C. -Parameter g : forall m : nat, m <> 0 -> Prop. -Parameter f : forall (m : nat) (H : m <> 0), g m H. -Variable n : nat. -Variable ap_n : n <> 0. -Let delta := f n ap_n. -Lemma lem7 : n = n. - lia. -Qed. -End C. - -(* Problem of dependencies *) -Lemma lem8 : forall H : 0 = 0 -> 0 = 0, H = H -> 0 = 0. -intros. -lia. -Qed. - -(* Bug that what caused by the use of intro_using in Omega *) -Lemma lem9 : - forall p q : nat, ~ (p <= q /\ p < q \/ q <= p /\ p < q) -> p < p \/ p <= p. -intros. -lia. -Qed. - -(* Check that the interpretation of mult on nat enforces its positivity *) -(* Submitted by Hubert Thierry (BZ#743) *) -(* Postponed... problem with goals of the form "(n*m=0)%nat -> (n*m=0)%Z" *) -Lemma lem10 : forall n m : nat, le n (plus n (mult n m)). -Proof. -intros; lia. -Qed. diff --git a/stdlib/test-suite/success/ROmega0.v b/stdlib/test-suite/success/ROmega0.v deleted file mode 100644 index 13b378ec0d26..000000000000 --- a/stdlib/test-suite/success/ROmega0.v +++ /dev/null @@ -1,170 +0,0 @@ -From Stdlib Require Import ZArith Lia. -Open Scope Z_scope. - -(* Pierre L: examples gathered while debugging romega. *) -(* Starting from Coq 8.9 (late 2018), `romega` tactics are deprecated. - The tests in this file remain but now call the `lia` tactic. *) - -Lemma test_lia_0 : - forall m m', - 0<= m <= 1 -> 0<= m' <= 1 -> (0 < m <-> 0 < m') -> m = m'. -Proof. -intros. -lia. -Qed. - -Lemma test_lia_0b : - forall m m', - 0<= m <= 1 -> 0<= m' <= 1 -> (0 < m <-> 0 < m') -> m = m'. -Proof. -intros m m'. -lia. -Qed. - -Lemma test_lia_1 : - forall (z z1 z2 : Z), - z2 <= z1 -> - z1 <= z2 -> - z1 >= 0 -> - z2 >= 0 -> - z1 >= z2 /\ z = z1 \/ z1 <= z2 /\ z = z2 -> - z >= 0. -Proof. -intros. -lia. -Qed. - -Lemma test_lia_1b : - forall (z z1 z2 : Z), - z2 <= z1 -> - z1 <= z2 -> - z1 >= 0 -> - z2 >= 0 -> - z1 >= z2 /\ z = z1 \/ z1 <= z2 /\ z = z2 -> - z >= 0. -Proof. -intros z z1 z2. -lia. -Qed. - -Lemma test_lia_2 : forall a b c:Z, - 0<=a-b<=1 -> b-c<=2 -> a-c<=3. -Proof. -intros. -lia. -Qed. - -Lemma test_lia_2b : forall a b c:Z, - 0<=a-b<=1 -> b-c<=2 -> a-c<=3. -Proof. -intros a b c. -lia. -Qed. - -Lemma test_lia_3 : forall a b h hl hr ha hb, - 0 <= ha - hl <= 1 -> - -2 <= hl - hr <= 2 -> - h =b+1 -> - (ha >= hr /\ a = ha \/ ha <= hr /\ a = hr) -> - (hl >= hr /\ b = hl \/ hl <= hr /\ b = hr) -> - (-3 <= ha -hr <=3 -> 0 <= hb - a <= 1) -> - (-2 <= ha-hr <=2 -> hb = a + 1) -> - 0 <= hb - h <= 1. -Proof. -intros. -lia. -Qed. - -Lemma test_lia_3b : forall a b h hl hr ha hb, - 0 <= ha - hl <= 1 -> - -2 <= hl - hr <= 2 -> - h =b+1 -> - (ha >= hr /\ a = ha \/ ha <= hr /\ a = hr) -> - (hl >= hr /\ b = hl \/ hl <= hr /\ b = hr) -> - (-3 <= ha -hr <=3 -> 0 <= hb - a <= 1) -> - (-2 <= ha-hr <=2 -> hb = a + 1) -> - 0 <= hb - h <= 1. -Proof. -intros a b h hl hr ha hb. -lia. -Qed. - - -Lemma test_lia_4 : forall hr ha, - ha = 0 -> - (ha = 0 -> hr =0) -> - hr = 0. -Proof. -intros hr ha. -lia. -Qed. - -Lemma test_lia_5 : forall hr ha, - ha = 0 -> - (~ha = 0 \/ hr =0) -> - hr = 0. -Proof. -intros hr ha. -lia. -Qed. - -Lemma test_lia_6 : forall z, z>=0 -> 0>z+2 -> False. -Proof. -intros. -lia. -Qed. - -Lemma test_lia_6b : forall z, z>=0 -> 0>z+2 -> False. -Proof. -intros z. -lia. -Qed. - -Lemma test_lia_7 : forall z, - 0>=0 /\ z=0 \/ 0<=0 /\ z =0 -> 1 = z+1. -Proof. -intros. -lia. -Qed. - -Lemma test_lia_7b : forall z, - 0>=0 /\ z=0 \/ 0<=0 /\ z =0 -> 1 = z+1. -Proof. -intros. -lia. -Qed. - -(* Magaud BZ#240 *) - -Lemma test_lia_8 : forall x y:Z, x*x ~ y*y <= x*x. -Proof. -intros. -lia. -Qed. - -Lemma test_lia_8b : forall x y:Z, x*x ~ y*y <= x*x. -Proof. -intros x y. -lia. -Qed. - -(* Besson BZ#1298 *) - -Lemma test_lia9 : forall z z':Z, z<>z' -> z'=z -> False. -Proof. -intros. -lia. -Qed. - -(* Letouzey, May 2017 *) - -Lemma test_lia10 : forall x a a' b b', - a' <= b -> - a <= b' -> - b < b' -> - a < a' -> - a <= x < b' <-> a <= x < b \/ a' <= x < b'. -Proof. - intros. - lia. -Qed. diff --git a/stdlib/test-suite/success/ROmega2.v b/stdlib/test-suite/success/ROmega2.v deleted file mode 100644 index 51cf44b4658e..000000000000 --- a/stdlib/test-suite/success/ROmega2.v +++ /dev/null @@ -1,43 +0,0 @@ -(* Starting from Coq 8.9 (late 2018), `romega` tactics are deprecated. - The tests in this file remain but now call the `lia` tactic. *) -From Stdlib Require Import ZArith Lia. - -(* Submitted by Yegor Bryukhov (BZ#922) *) - -Open Scope Z_scope. - - -(* First a simplified version used during debug of romega on Test46 *) -Lemma Test46_simplified : -forall v1 v2 v5 : Z, -0 = v2 + v5 -> -0 < v5 -> -0 < v2 -> -4*v2 <> 5*v1. -intros. -lia. -Qed. - - -(* The complete problem *) -Lemma Test46 : -forall v1 v2 v3 v4 v5 : Z, -((2 * v4) + (5)) + (8 * v2) <= ((4 * v4) + (3 * v4)) + (5 * v4) -> -9 * v4 > (1 * v4) + ((2 * v1) + (0 * v2)) -> -((9 * v3) + (2 * v5)) + (5 * v2) = 3 * v4 -> -0 > 6 * v1 -> -(0 * v3) + (6 * v2) <> 2 -> -(0 * v3) + (5 * v5) <> ((4 * v2) + (8 * v2)) + (2 * v5) -> -7 * v3 > 5 * v5 -> -0 * v4 >= ((5 * v1) + (4 * v1)) + ((6 * v5) + (3 * v5)) -> -7 * v2 = ((3 * v2) + (6 * v5)) + (7 * v2) -> -0 * v3 > 7 * v1 -> -9 * v2 < 9 * v5 -> -(2 * v3) + (8 * v1) <= 5 * v4 -> -5 * v2 = ((5 * v1) + (0 * v5)) + (1 * v2) -> -0 * v5 <= 9 * v2 -> -((7 * v1) + (1 * v3)) + ((2 * v3) + (1 * v3)) >= ((6 * v5) + (4)) + ((1) + (9)) --> False. -intros. -lia. -Qed. diff --git a/stdlib/test-suite/success/ROmega4.v b/stdlib/test-suite/success/ROmega4.v deleted file mode 100644 index 51f21a482e21..000000000000 --- a/stdlib/test-suite/success/ROmega4.v +++ /dev/null @@ -1,26 +0,0 @@ -(** ROmega is now aware of the bodies of context variables - (of type Z or nat). - See also #148 for the corresponding improvement in Omega. -*) - -From Stdlib Require Import ZArith Lia. -Open Scope Z. - -Goal let x := 3 in x = 3. -intros. -lia. -Qed. - -(** Example seen in #4132 - (actually solvable even if b isn't known to be 5) *) - -Lemma foo - (x y x' zxy zxy' z : Z) - (b := 5) - (Ry : - b <= y < b) - (Bx : x' <= b) - (H : - zxy' <= zxy) - (H' : zxy' <= x') : - b <= zxy. -Proof. -lia. -Qed. diff --git a/stdlib/test-suite/success/ROmegaPre.v b/stdlib/test-suite/success/ROmegaPre.v deleted file mode 100644 index 6be6c2a1d88b..000000000000 --- a/stdlib/test-suite/success/ROmegaPre.v +++ /dev/null @@ -1,120 +0,0 @@ -From Stdlib Require Import ZArith Nnat Lia. -Open Scope Z_scope. - -(** Test of the zify preprocessor for (R)Omega *) -(* Starting from Coq 8.9 (late 2018), `romega` tactics are deprecated. - The tests in this file remain but now call the `lia` tactic. *) - -(* More details in file PreOmega.v -*) - -(* zify_op *) - -Goal forall a:Z, Z.max a a = a. -intros. -lia. -Qed. - -Goal forall a b:Z, Z.max a b = Z.max b a. -intros. -lia. -Qed. - -Goal forall a b c:Z, Z.max a (Z.max b c) = Z.max (Z.max a b) c. -intros. -lia. -Qed. - -Goal forall a b:Z, Z.max a b + Z.min a b = a + b. -intros. -lia. -Qed. - -Goal forall a:Z, (Z.abs a)*(Z.sgn a) = a. -intros. -intuition; subst; lia. -Qed. - -Goal forall a:Z, Z.abs a = a -> a >= 0. -intros. -lia. -Qed. - -Goal forall a:Z, Z.sgn a = a -> a = 1 \/ a = 0 \/ a = -1. -intros. -lia. -Qed. - -(* zify_nat *) - -Goal forall m: nat, (m<2)%nat -> (0<= m+m <=2)%nat. -intros. -lia. -Qed. - -Goal forall m:nat, (m<1)%nat -> (m=0)%nat. -intros. -lia. -Qed. - -Goal forall m: nat, (m<=100)%nat -> (0<= m+m <=200)%nat. -intros. -lia. -Qed. -(* 2000 instead of 200: works, but quite slow *) - -Goal forall m: nat, (m*m>=0)%nat. -intros. -lia. -Qed. - -(* zify_positive *) - -Goal forall m: positive, (m<2)%positive -> (2 <= m+m /\ m+m <= 2)%positive. -intros. -lia. -Qed. - -Goal forall m:positive, (m<2)%positive -> (m=1)%positive. -intros. -lia. -Qed. - -Goal forall m: positive, (m<=1000)%positive -> (2<=m+m/\m+m <=2000)%positive. -intros. -lia. -Qed. - -Goal forall m: positive, (m*m>=1)%positive. -intros. -lia. -Qed. - -(* zify_N *) - -Goal forall m:N, (m<2)%N -> (0 <= m+m /\ m+m <= 2)%N. -intros. -lia. -Qed. - -Goal forall m:N, (m<1)%N -> (m=0)%N. -intros. -lia. -Qed. - -Goal forall m:N, (m<=1000)%N -> (0<=m+m/\m+m <=2000)%N. -intros. -lia. -Qed. - -Goal forall m:N, (m*m>=0)%N. -intros. -lia. -Qed. - -(* mix of datatypes *) - -Goal forall p, Z.of_N (N.of_nat (N.to_nat (Npos p))) = Zpos p. -intros. -lia. -Qed. diff --git a/stdlib/test-suite/success/RecTutorial.v b/stdlib/test-suite/success/RecTutorial.v deleted file mode 100644 index a9df8fc37828..000000000000 --- a/stdlib/test-suite/success/RecTutorial.v +++ /dev/null @@ -1,1211 +0,0 @@ -Module Type LocalNat. - -Inductive nat : Set := - | O : nat - | S : nat->nat. -Check nat. -Check O. -Check S. - -End LocalNat. - -Print nat. - - -Print le. - -Theorem zero_leq_three: 0 <= 3. - -Proof. - constructor 2. - constructor 2. - constructor 2. - constructor 1. - -Qed. - -Print zero_leq_three. - - -Lemma zero_leq_three': 0 <= 3. - repeat constructor. -Qed. - - -Lemma zero_lt_three : 0 < 3. -Proof. - unfold lt. - repeat constructor. -Qed. - - -From Stdlib Require Import List. - -Print list. - -Check list. - -Check (nil (A:=nat)). - -Check (nil (A:= nat -> nat)). - -Check (fun A: Set => (cons (A:=A))). - -Check (cons 3 (cons 2 nil)). - - - - -From Stdlib Require Import Bvector. - -Print Vector.t. - -Check (Vector.nil nat). - -Check (fun (A:Set)(a:A)=> Vector.cons _ a _ (Vector.nil _)). - -Check (Vector.cons _ 5 _ (Vector.cons _ 3 _ (Vector.nil _))). - - - - - - - - - - - - - -Lemma eq_3_3 : 2 + 1 = 3. -Proof. - reflexivity. -Qed. -Print eq_3_3. - -Lemma eq_proof_proof : refl_equal (2*6) = refl_equal (3*4). -Proof. - reflexivity. -Qed. -Print eq_proof_proof. - -Lemma eq_lt_le : ( 2 < 4) = (3 <= 4). -Proof. - reflexivity. -Qed. - -Lemma eq_nat_nat : nat = nat. -Proof. - reflexivity. -Qed. - -Lemma eq_Set_Set : Set = Set. -Proof. - reflexivity. -Qed. - -Lemma eq_Type_Type : Type = Type. -Proof. - reflexivity. -Qed. - - -Check (2 + 1 = 3). - - -Check (Type = Type). - -Goal Type = Type. -reflexivity. -Qed. - - -Print or. - -Print and. - - -Print sumbool. - -Print ex. - -From Stdlib Require Import ZArith. -From Stdlib Require Import Compare_dec. - -Check le_lt_dec. - -Definition max (n p :nat) := match le_lt_dec n p with - | left _ => p - | right _ => n - end. - -Theorem le_max : forall n p, n <= p -> max n p = p. -Proof. - intros n p ; unfold max ; case (le_lt_dec n p); simpl. - trivial. - intros; absurd (p < p); eauto with arith. -Qed. - -From Stdlib Require Extraction. -Extraction max. - - - - - - -Inductive tree(A:Set) : Set := - node : A -> forest A -> tree A -with - forest (A: Set) : Set := - nochild : forest A | - addchild : tree A -> forest A -> forest A. - - - - - -Inductive - even : nat->Prop := - evenO : even O | - evenS : forall n, odd n -> even (S n) -with - odd : nat->Prop := - oddS : forall n, even n -> odd (S n). - -Lemma odd_49 : odd (7 * 7). - simpl; repeat constructor. -Qed. - - - -Definition nat_case := - fun (Q : Type)(g0 : Q)(g1 : nat -> Q)(n:nat) => - match n return Q with - | 0 => g0 - | S p => g1 p - end. - -Eval simpl in (nat_case nat 0 (fun p => p) 34). - -Eval simpl in (fun g0 g1 => nat_case nat g0 g1 34). - -Eval simpl in (fun g0 g1 => nat_case nat g0 g1 0). - - -Definition pred (n:nat) := match n with O => O | S m => m end. - -Eval simpl in pred 56. - -Eval simpl in pred 0. - -Eval simpl in fun p => pred (S p). - - -Definition xorb (b1 b2:bool) := -match b1, b2 with - | false, true => true - | true, false => true - | _ , _ => false -end. - - - Definition pred_spec (n:nat) := {m:nat | n=0 /\ m=0 \/ n = S m}. - - - Definition predecessor : forall n:nat, pred_spec n. - intro n;case n. - unfold pred_spec;exists 0;auto. - unfold pred_spec; intro n0;exists n0; auto. - Defined. - -Print predecessor. - -Extraction predecessor. - -Theorem nat_expand : - forall n:nat, n = match n with 0 => 0 | S p => S p end. - intro n;case n;simpl;auto. -Qed. - -Check (fun p:False => match p return 2=3 with end). - -Theorem fromFalse : False -> 0=1. - intro absurd. - contradiction. -Qed. - -Section equality_elimination. - Variables (A: Type) - (a b : A) - (p : a = b) - (Q : A -> Type). - Check (fun H : Q a => - match p in (eq _ y) return Q y with - refl_equal => H - end). - -End equality_elimination. - - -Theorem trans : forall n m p:nat, n=m -> m=p -> n=p. -Proof. - intros n m p eqnm. - case eqnm. - trivial. -Qed. - -Lemma Rw : forall x y: nat, y = y * x -> y * x * x = y. - intros x y e; do 2 rewrite <- e. - reflexivity. -Qed. - - -From Stdlib Require Import Arith. - -Check Nat.mul_1_l. -(* -Nat.mul_1_l - : forall n : nat, 1 * n = n -*) - -Check Nat.mul_add_distr_r. -(* -Nat.mul_add_distr_r - : forall n m p : nat, (n + m) * p = n * p + m * p - -*) - -Lemma mul_distr_S : forall n p : nat, n * p + p = (S n)* p. - simpl; auto with arith. -Qed. - -Lemma four_n : forall n:nat, n+n+n+n = 4*n. - intro n;rewrite <- (Nat.mul_1_l n). - - Undo. - intro n; pattern n at 1. - - - rewrite <- Nat.mul_1_l. - repeat rewrite mul_distr_S. - trivial. -Qed. - - -Section Le_case_analysis. - Variables (n p : nat) - (H : n <= p) - (Q : nat -> Prop) - (H0 : Q n) - (HS : forall m, n <= m -> Q (S m)). - Check ( - match H in (_ <= q) return (Q q) with - | le_n _ => H0 - | le_S _ m Hm => HS m Hm - end - ). - - -End Le_case_analysis. - - -Lemma predecessor_of_positive : forall n, 1 <= n -> exists p:nat, n = S p. -Proof. - intros n H; case H. - exists 0; trivial. - intros m Hm; exists m; trivial. -Qed. - -Definition Vtail_total - (A : Set) (n : nat) (v : Vector.t A n) : Vector.t A (pred n):= -match v in (Vector.t _ n0) return (Vector.t A (pred n0)) with -| Vector.nil _ => Vector.nil A -| Vector.cons _ _ n0 v0 => v0 -end. - -Definition Vtail' (A:Set)(n:nat)(v:Vector.t A n) : Vector.t A (pred n). - case v. - simpl. - exact (Vector.nil A). - simpl. - auto. -Defined. - -(* -Inductive Lambda : Set := - lambda : (Lambda -> False) -> Lambda. - - -Error: Non strictly positive occurrence of "Lambda" in - "(Lambda -> False) -> Lambda" - -*) - -Section Paradox. - Variable Lambda : Set. - Variable lambda : (Lambda -> False) ->Lambda. - - Variable matchL : Lambda -> forall Q:Prop, ((Lambda ->False) -> Q) -> Q. - (* - understand matchL Q l (fun h : Lambda -> False => t) - - as match l return Q with lambda h => t end - *) - - Definition application (f x: Lambda) :False := - matchL f False (fun h => h x). - - Definition Delta : Lambda := lambda (fun x : Lambda => application x x). - - Definition loop : False := application Delta Delta. - - Theorem two_is_three : 2 = 3. - Proof. - elim loop. - Qed. - -End Paradox. - - -From Stdlib Require Import ZArith. - - - -Inductive itree : Set := -| ileaf : itree -| inode : Z-> (nat -> itree) -> itree. - -Definition isingle l := inode l (fun i => ileaf). - -Definition t1 := inode 0 (fun n => isingle (Z.of_nat (2*n))). - -Definition t2 := inode 0 - (fun n : nat => - inode (Z.of_nat n) - (fun p => isingle (Z.of_nat (n*p)))). - - -Inductive itree_le : itree-> itree -> Prop := - | le_leaf : forall t, itree_le ileaf t - | le_node : forall l l' s s', - Z.le l l' -> - (forall i, exists j:nat, itree_le (s i) (s' j)) -> - itree_le (inode l s) (inode l' s'). - - -Theorem itree_le_trans : - forall t t', itree_le t t' -> - forall t'', itree_le t' t'' -> itree_le t t''. - induction t. - constructor 1. - - intros t'; case t'. - inversion 1. - intros z0 i0 H0. - intro t'';case t''. - inversion 1. - intros. - inversion_clear H1. - constructor 2. - inversion_clear H0;eauto with zarith. - inversion_clear H0. - intro i2; case (H4 i2). - intros. - generalize (H i2 _ H0). - intros. - case (H3 x);intros. - generalize (H5 _ H6). - exists x0;auto. -Qed. - - - -Inductive itree_le' : itree-> itree -> Prop := - | le_leaf' : forall t, itree_le' ileaf t - | le_node' : forall l l' s s' g, - Z.le l l' -> - (forall i, itree_le' (s i) (s' (g i))) -> - itree_le' (inode l s) (inode l' s'). - - - - - -Lemma t1_le_t2 : itree_le t1 t2. - unfold t1, t2. - constructor. - auto with zarith. - intro i; exists (2 * i). - unfold isingle. - constructor. - auto with zarith. - exists i;constructor. -Qed. - - - -Lemma t1_le'_t2 : itree_le' t1 t2. - unfold t1, t2. - constructor 2 with (fun i : nat => 2 * i). - auto with zarith. - unfold isingle; - intro i ; constructor 2 with (fun i :nat => i). - auto with zarith. - constructor . -Qed. - - -From Stdlib Require Import List. - -Inductive ltree (A:Set) : Set := - lnode : A -> list (ltree A) -> ltree A. - -Inductive prop : Prop := - prop_intro : Prop -> prop. - -Lemma prop_inject: prop. -Proof prop_intro prop. - - -Inductive ex_Prop (P : Prop -> Prop) : Prop := - exP_intro : forall X : Prop, P X -> ex_Prop P. - -Lemma ex_Prop_inhabitant : ex_Prop (fun P => P -> P). -Proof. - exists (ex_Prop (fun P => P -> P)). - trivial. -Qed. - - - - - -Fail Check (fun (P:Prop->Prop)(p: ex_Prop P) => - match p with exP_intro X HX => X end). -(* -Error: -Incorrect elimination of "p" in the inductive type -"ex_Prop", the return type has sort "Type" while it should be -"Prop" - -Elimination of an inductive object of sort "Prop" -is not allowed on a predicate in sort "Type" -because proofs can be eliminated only to build proofs -*) - - -Fail Check (match prop_inject with (prop_intro p) => p end). -(* -Error: -Incorrect elimination of "prop_inject" in the inductive type -"prop", the return type has sort "Type" while it should be -"Prop" - -Elimination of an inductive object of sort "Prop" -is not allowed on a predicate in sort "Type" -because proofs can be eliminated only to build proofs -*) -Print prop_inject. - -(* -prop_inject = -prop_inject = prop_intro prop - : prop -*) - - -Inductive typ : Type := - typ_intro : Type -> typ. - -Definition typ_inject: typ. -split. -Fail exact typ. -(* -Error: Universe Inconsistency. -*) -Abort. - -Fail Inductive aSet : Set := - aSet_intro: Set -> aSet. -(* -User error: Large non-propositional inductive types must be in Type -*) - -Inductive ex_Set (P : Set -> Prop) : Type := - exS_intro : forall X : Set, P X -> ex_Set P. - - -Module Type Version1. - -Inductive comes_from_the_left (P Q:Prop): P \/ Q -> Prop := - c1 : forall p, comes_from_the_left P Q (or_introl (A:=P) Q p). - -Goal (comes_from_the_left _ _ (or_introl True I)). -split. -Qed. - -Goal ~(comes_from_the_left _ _ (or_intror True I)). - red;inversion 1. - (* discriminate H0. - *) -Abort. - -End Version1. - -Fail Definition comes_from_the_left (P Q:Prop)(H:P \/ Q): Prop := - match H with - | or_introl p => True - | or_intror q => False - end. - -(* -Error: -Incorrect elimination of "H" in the inductive type -"or", the return type has sort "Type" while it should be -"Prop" - -Elimination of an inductive object of sort "Prop" -is not allowed on a predicate in sort "Type" -because proofs can be eliminated only to build proofs -*) - -Definition comes_from_the_left_sumbool - (P Q:Prop)(x:{P}+{Q}): Prop := - match x with - | left p => True - | right q => False - end. - - - - -Close Scope Z_scope. - - - - - -Theorem S_is_not_O : forall n, S n <> 0. - -Set Nested Proofs Allowed. - -Definition Is_zero (x:nat):= match x with - | 0 => True - | _ => False - end. - Lemma O_is_zero : forall m, m = 0 -> Is_zero m. - Proof. - intros m H; subst m. - (* - ============================ - Is_zero 0 - *) - simpl;trivial. - Qed. - - red; intros n Hn. - apply O_is_zero with (m := S n). - assumption. -Qed. - -Theorem disc2 : forall n, S (S n) <> 1. -Proof. - intros n Hn; discriminate. -Qed. - - -Theorem disc3 : forall n, S (S n) = 0 -> forall Q:Prop, Q. -Proof. - intros n Hn Q. - discriminate. -Qed. - - - -Theorem inj_succ : forall n m, S n = S m -> n = m. -Proof. - - -Lemma inj_pred : forall n m, n = m -> pred n = pred m. -Proof. - intros n m eq_n_m. - rewrite eq_n_m. - trivial. -Qed. - - intros n m eq_Sn_Sm. - apply inj_pred with (n:= S n) (m := S m); assumption. -Qed. - -Lemma list_inject : forall (A:Set)(a b :A)(l l':list A), - a :: b :: l = b :: a :: l' -> a = b /\ l = l'. -Proof. - intros A a b l l' e. - injection e. - auto. -Qed. - - -Theorem not_le_Sn_0 : forall n:nat, ~ (S n <= 0). -Proof. - red; intros n H. - case H. -Undo. - -Lemma not_le_Sn_0_with_constraints : - forall n p , S n <= p -> p = 0 -> False. -Proof. - intros n p H; case H ; - intros; discriminate. -Qed. - -eapply not_le_Sn_0_with_constraints; eauto. -Qed. - - -Theorem not_le_Sn_0' : forall n:nat, ~ (S n <= 0). -Proof. - red; intros n H ; inversion H. -Qed. - -Derive Inversion le_Sn_0_inv with (forall n :nat, S n <= 0). -Check le_Sn_0_inv. - -Theorem le_Sn_0'' : forall n p : nat, ~ S n <= 0 . -Proof. - intros n p H; - inversion H using le_Sn_0_inv. -Qed. - -Derive Inversion_clear le_Sn_0_inv' with (forall n :nat, S n <= 0). -Check le_Sn_0_inv'. - - -Theorem le_reverse_rules : - forall n m:nat, n <= m -> - n = m \/ - exists p, n <= p /\ m = S p. -Proof. - intros n m H; inversion H. - left;trivial. - right; exists m0; split; trivial. -Restart. - intros n m H; inversion_clear H. - left;trivial. - right; exists m0; split; trivial. -Qed. - -Inductive ArithExp : Set := - Zero : ArithExp - | Succ : ArithExp -> ArithExp - | Plus : ArithExp -> ArithExp -> ArithExp. - -Inductive RewriteRel : ArithExp -> ArithExp -> Prop := - RewSucc : forall e1 e2 :ArithExp, - RewriteRel e1 e2 -> RewriteRel (Succ e1) (Succ e2) - | RewPlus0 : forall e:ArithExp, - RewriteRel (Plus Zero e) e - | RewPlusS : forall e1 e2:ArithExp, - RewriteRel e1 e2 -> - RewriteRel (Plus (Succ e1) e2) (Succ (Plus e1 e2)). - - - -Fixpoint plus (n p:nat) {struct n} : nat := - match n with - | 0 => p - | S m => S (plus m p) - end. - -Fixpoint plus' (n p:nat) {struct p} : nat := - match p with - | 0 => n - | S q => S (plus' n q) - end. - -Fixpoint plus'' (n p:nat) {struct n} : nat := - match n with - | 0 => p - | S m => plus'' m (S p) - end. - -Module Type even_test_v1. - -Fixpoint even_test (n:nat) : bool := - match n - with 0 => true - | 1 => false - | S (S p) => even_test p - end. - -End even_test_v1. - -Module even_test_v2. - -Fixpoint even_test (n:nat) : bool := - match n - with - | 0 => true - | S p => odd_test p - end -with odd_test (n:nat) : bool := - match n - with - | 0 => false - | S p => even_test p - end. - -Eval simpl in even_test. - -Eval simpl in (fun x : nat => even_test x). - -Eval simpl in (fun x : nat => plus 5 x). -Eval simpl in (fun x : nat => even_test (plus 5 x)). - -Eval simpl in (fun x : nat => even_test (plus x 5)). - -End even_test_v2. - - -Section Principle_of_Induction. -Variable P : nat -> Prop. -Hypothesis base_case : P 0. -Hypothesis inductive_step : forall n:nat, P n -> P (S n). -Fixpoint nat_ind (n:nat) : (P n) := - match n return P n with - | 0 => base_case - | S m => inductive_step m (nat_ind m) - end. - -End Principle_of_Induction. - -Scheme Even_induction := Minimality for even Sort Prop -with Odd_induction := Minimality for odd Sort Prop. -Arguments Even_induction P P0 : rename. - -Theorem even_plus_four : forall n:nat, even n -> even (4+n). -Proof. - intros n H. - elim H using Even_induction with (P0 := fun n => odd (4+n)); - simpl;repeat constructor;assumption. -Qed. - - -Section Principle_of_Double_Induction. -Variable P : nat -> nat ->Prop. -Hypothesis base_case1 : forall x:nat, P 0 x. -Hypothesis base_case2 : forall x:nat, P (S x) 0. -Hypothesis inductive_step : forall n m:nat, P n m -> P (S n) (S m). -Fixpoint nat_double_ind (n m:nat){struct n} : P n m := - match n, m return P n m with - | 0 , x => base_case1 x - | (S x), 0 => base_case2 x - | (S x), (S y) => inductive_step x y (nat_double_ind x y) - end. -End Principle_of_Double_Induction. - -Section Principle_of_Double_Recursion. -Variable P : nat -> nat -> Set. -Hypothesis base_case1 : forall x:nat, P 0 x. -Hypothesis base_case2 : forall x:nat, P (S x) 0. -Hypothesis inductive_step : forall n m:nat, P n m -> P (S n) (S m). -Fixpoint nat_double_rec (n m:nat){struct n} : P n m := - match n, m return P n m with - | 0 , x => base_case1 x - | (S x), 0 => base_case2 x - | (S x), (S y) => inductive_step x y (nat_double_rec x y) - end. -End Principle_of_Double_Recursion. - -Definition min : nat -> nat -> nat := - nat_double_rec (fun (x y:nat) => nat) - (fun (x:nat) => 0) - (fun (y:nat) => 0) - (fun (x y r:nat) => S r). - -Eval compute in (min 5 8). -Eval compute in (min 8 5). - - - -Lemma not_circular : forall n:nat, n <> S n. -Proof. - intro n. - apply nat_ind with (P:= fun n => n <> S n). - discriminate. - red; intros n0 Hn0 eqn0Sn0;injection eqn0Sn0;auto. -Qed. - -Definition eq_nat_dec : forall n p:nat , {n=p}+{n <> p}. -Proof. - intros n p. - apply nat_double_rec with (P:= fun (n q:nat) => {q=p}+{q <> p}). -Undo. - pattern p,n. - elim n using nat_double_rec. - destruct x; auto. - destruct x; auto. - intros n0 m H; case H. - intro eq; rewrite eq ; auto. - intro neg; right; red ; injection 1; auto. -Defined. - -Definition eq_nat_dec' : forall n p:nat, {n=p}+{n <> p}. - decide equality. -Defined. - -Print Acc. - - -Fail Fixpoint div (x y:nat){struct x}: nat := - if eq_nat_dec x 0 - then 0 - else if eq_nat_dec y 0 - then x - else S (div (x-y) y). -(* -Error: -Recursive definition of div is ill-formed. -In environment -div : nat -> nat -> nat -x : nat -y : nat -_ : x <> 0 -_ : y <> 0 - -Recursive call to div has principal argument equal to -"x - y" -instead of a subterm of x - -*) - -Lemma minus_smaller_S: forall x y:nat, x - y < S x. -Proof. - intros x y; pattern y, x; - elim x using nat_double_ind. - destruct x0; auto with arith. - simpl; auto with arith. - simpl; auto with arith. -Qed. - -Lemma minus_smaller_positive : forall x y:nat, x <>0 -> y <> 0 -> - x - y < x. -Proof. - destruct x; destruct y; - ( simpl;intros; apply minus_smaller_S || - intros; absurd (0=0); auto). -Qed. - -Definition minus_decrease : forall x y:nat, Acc lt x -> - x <> 0 -> - y <> 0 -> - Acc lt (x-y). -Proof. - intros x y H; case H. - intros Hz posz posy. - apply Hz; apply minus_smaller_positive; assumption. -Defined. - -Print minus_decrease. - - - -Fixpoint div_aux (x y:nat)(H: Acc lt x):nat. - refine (if eq_nat_dec x 0 - then 0 - else if eq_nat_dec y 0 - then y - else div_aux (x-y) y _). - apply (minus_decrease x y H);assumption. -Defined. - - -Print div_aux. -(* -div_aux = -(fix div_aux (x y : nat) (H : Acc lt x) {struct H} : nat := - match eq_nat_dec x 0 with - | left _ => 0 - | right _ => - match eq_nat_dec y 0 with - | left _ => y - | right _0 => div_aux (x - y) y (minus_decrease x y H _ _0) - end - end) - : forall x : nat, nat -> Acc lt x -> nat -*) - -From Stdlib Require Import Wf_nat. -Definition div x y := div_aux x y (lt_wf x). - -Extraction div. -(* -let div x y = - div_aux x y -*) - -Extraction div_aux. - -(* -let rec div_aux x y = - match eq_nat_dec x O with - | Left -> O - | Right -> - (match eq_nat_dec y O with - | Left -> y - | Right -> div_aux (minus x y) y) -*) - -Lemma vector0_is_vnil : forall (A:Set)(v:Vector.t A 0), v = Vector.nil A. -Proof. - intros A v;inversion v. -Abort. - - -Fail Lemma vector0_is_vnil_aux : forall (A:Set)(n:nat)(v:Vector.t A n), - n= 0 -> v = Vector.nil A. -(* -Error: In environment -A : Set -n : nat -v : Vector.t A n -The term "[]" has type "Vector.t A 0" while it is expected to have type - "Vector.t A n" -*) -From Stdlib Require Import JMeq. - -Lemma vector0_is_vnil_aux : forall (A:Set)(n:nat)(v:Vector.t A n), - n= 0 -> JMeq v (Vector.nil A). -Proof. - destruct v. - auto. - intro; discriminate. -Qed. - -Lemma vector0_is_vnil : forall (A:Set)(v:Vector.t A 0), v = Vector.nil A. -Proof. - intros a v;apply JMeq_eq. - apply vector0_is_vnil_aux. - trivial. -Qed. - - -Arguments Vector.cons [A] _ [n]. -Arguments Vector.nil {A}. -Arguments Vector.hd [A n]. -Arguments Vector.tl [A n]. - -Definition Vid : forall (A : Type)(n:nat), Vector.t A n -> Vector.t A n. -Proof. - destruct n; intro v. - exact Vector.nil. - exact (Vector.cons (Vector.hd v) (Vector.tl v)). -Defined. - -Eval simpl in (fun (A:Set)(v:Vector.t A 0) => (Vid _ _ v)). - -Eval simpl in (fun (A:Set)(v:Vector.t A 0) => v). - - - -Lemma Vid_eq : forall (n:nat) (A:Type)(v:Vector.t A n), v=(Vid _ n v). -Proof. - destruct v. - reflexivity. - reflexivity. -Defined. - -Theorem zero_nil : forall A (v:Vector.t A 0), v = Vector.nil. -Proof. - intros. - change (Vector.nil (A:=A)) with (Vid _ 0 v). - apply Vid_eq. -Defined. - - -Theorem decomp : - forall (A : Set) (n : nat) (v : Vector.t A (S n)), - v = Vector.cons (Vector.hd v) (Vector.tl v). -Proof. - intros. - change (Vector.cons (Vector.hd v) (Vector.tl v)) with (Vid _ (S n) v). - apply Vid_eq. -Defined. - - - -Definition vector_double_rect : - forall (A:Set) (P: forall (n:nat),(Vector.t A n)->(Vector.t A n) -> Type), - P 0 Vector.nil Vector.nil -> - (forall n (v1 v2 : Vector.t A n) a b, P n v1 v2 -> - P (S n) (Vector.cons a v1) (Vector.cons b v2)) -> - forall n (v1 v2 : Vector.t A n), P n v1 v2. - induction n. - intros; rewrite (zero_nil _ v1); rewrite (zero_nil _ v2). - auto. - intros v1 v2; rewrite (decomp _ _ v1);rewrite (decomp _ _ v2). - apply X0; auto. -Defined. - -From Stdlib Require Import Bool. - -Definition bitwise_or n v1 v2 : Vector.t bool n := - vector_double_rect bool (fun n v1 v2 => Vector.t bool n) - Vector.nil - (fun n v1 v2 a b r => Vector.cons (orb a b) r) n v1 v2. - - -Fixpoint vector_nth (A:Set)(n:nat)(p:nat)(v:Vector.t A p){struct v} - : option A := - match n,v with - _ , Vector.nil => None - | 0 , Vector.cons b _ => Some b - | S n', Vector.cons _ v' => vector_nth A n' _ v' - end. - -Arguments vector_nth [A] _ [p]. - - -Lemma nth_bitwise : forall (n:nat) (v1 v2: Vector.t bool n) i a b, - vector_nth i v1 = Some a -> - vector_nth i v2 = Some b -> - vector_nth i (bitwise_or _ v1 v2) = Some (orb a b). -Proof. - intros n v1 v2; pattern n,v1,v2. - apply vector_double_rect. - simpl. - destruct i; discriminate 1. - destruct i; simpl;auto. - injection 1 as ->; injection 1 as ->; auto. -Qed. - - Set Implicit Arguments. - - CoInductive Stream (A:Set) : Set := - | Cons : A -> Stream A -> Stream A. - - CoInductive LList (A: Set) : Set := - | LNil : LList A - | LCons : A -> LList A -> LList A. - - - - - - Definition head (A:Set)(s : Stream A) := match s with Cons a s' => a end. - - Definition tail (A : Set)(s : Stream A) := - match s with Cons a s' => s' end. - - CoFixpoint repeat (A:Set)(a:A) : Stream A := Cons a (repeat a). - - CoFixpoint iterate (A: Set)(f: A -> A)(a : A) : Stream A:= - Cons a (iterate f (f a)). - - CoFixpoint map (A B:Set)(f: A -> B)(s : Stream A) : Stream B:= - match s with Cons a tl => Cons (f a) (map f tl) end. - -Eval simpl in (fun (A:Set)(a:A) => repeat a). - -Eval simpl in (fun (A:Set)(a:A) => head (repeat a)). - - -CoInductive EqSt (A: Set) : Stream A -> Stream A -> Prop := - eqst : forall s1 s2: Stream A, - head s1 = head s2 -> - EqSt (tail s1) (tail s2) -> - EqSt s1 s2. - - -Section Parks_Principle. -Variable A : Set. -Variable R : Stream A -> Stream A -> Prop. -Hypothesis bisim1 : forall s1 s2:Stream A, R s1 s2 -> - head s1 = head s2. -Hypothesis bisim2 : forall s1 s2:Stream A, R s1 s2 -> - R (tail s1) (tail s2). - -CoFixpoint park_ppl : forall s1 s2:Stream A, R s1 s2 -> - EqSt s1 s2 := - fun s1 s2 (p : R s1 s2) => - eqst s1 s2 (bisim1 p) - (park_ppl (bisim2 p)). -End Parks_Principle. - - -Theorem map_iterate : forall (A:Set)(f:A->A)(x:A), - EqSt (iterate f (f x)) (map f (iterate f x)). -Proof. - intros A f x. - apply park_ppl with - (R:= fun s1 s2 => exists x: A, - s1 = iterate f (f x) /\ s2 = map f (iterate f x)). - - intros s1 s2 (x0,(eqs1,eqs2));rewrite eqs1;rewrite eqs2;reflexivity. - intros s1 s2 (x0,(eqs1,eqs2)). - exists (f x0);split;[rewrite eqs1|rewrite eqs2]; reflexivity. - exists x;split; reflexivity. -Qed. - -Ltac infiniteproof f := - cofix f; constructor; [clear f| simpl; try (apply f; clear f)]. - - -Theorem map_iterate' : forall (A:Set)(f:A->A)(x:A), - EqSt (iterate f (f x)) (map f (iterate f x)). -infiniteproof map_iterate'. - reflexivity. -Qed. - - -Arguments LNil {A}. - -Lemma Lnil_not_Lcons : forall (A:Set)(a:A)(l:LList A), - LNil <> (LCons a l). - intros;discriminate. -Qed. - -Lemma injection_demo : forall (A:Set)(a b : A)(l l': LList A), - LCons a (LCons b l) = LCons b (LCons a l') -> - a = b /\ l = l'. -Proof. - intros A a b l l' e; injection e; auto. -Qed. - - -Inductive Finite (A:Set) : LList A -> Prop := -| Lnil_fin : Finite (LNil (A:=A)) -| Lcons_fin : forall a l, Finite l -> Finite (LCons a l). - -CoInductive Infinite (A:Set) : LList A -> Prop := -| LCons_inf : forall a l, Infinite l -> Infinite (LCons a l). - -Lemma LNil_not_Infinite : forall (A:Set), ~ Infinite (LNil (A:=A)). -Proof. - intros A H;inversion H. -Qed. - -Lemma Finite_not_Infinite : forall (A:Set)(l:LList A), - Finite l -> ~ Infinite l. -Proof. - intros A l H; elim H. - apply LNil_not_Infinite. - intros a l0 F0 I0' I1. - case I0'; inversion_clear I1. - trivial. -Qed. - -Lemma Not_Finite_Infinite : forall (A:Set)(l:LList A), - ~ Finite l -> Infinite l. -Proof. - cofix H. - destruct l. - intro; absurd (Finite (LNil (A:=A)));[auto|constructor]. - constructor. - apply H. - red; intro H1;case H0. - constructor. - trivial. -Qed. diff --git a/stdlib/test-suite/success/Record.v b/stdlib/test-suite/success/Record.v deleted file mode 100644 index 8fd319859d4e..000000000000 --- a/stdlib/test-suite/success/Record.v +++ /dev/null @@ -1,125 +0,0 @@ -(* Nijmegen expects redefinition of sorts *) -Definition CProp := Prop. -Record test : CProp := {n : nat ; m : bool ; _ : n <> 0 }. -From Stdlib Require Import Program. -From Stdlib Require Import List. -Import ListNotations. - -Record vector {A : Type} {n : nat} := { vec_list : list A ; vec_len : length vec_list = n }. -Arguments vector : clear implicits. - -Coercion vec_list : vector >-> list. - -#[export] Hint Rewrite @vec_len : datatypes. - -Ltac crush := repeat (program_simplify ; autorewrite with list datatypes ; auto with *). - -Obligation Tactic := crush. - -Program Definition vnil {A} : vector A 0 := {| vec_list := [] |}. - -Program Definition vcons {A n} (a : A) (v : vector A n) : vector A (S n) := - {| vec_list := cons a (vec_list v) |}. - -#[export] Hint Rewrite map_length rev_length : datatypes. - -Program Definition vmap {A B n} (f : A -> B) (v : vector A n) : vector B n := - {| vec_list := map f v |}. - -Program Definition vreverse {A n} (v : vector A n) : vector A n := - {| vec_list := rev v |}. - -Fixpoint va_list {A B} (v : list (A -> B)) (w : list A) : list B := - match v, w with - | nil, nil => nil - | cons f fs, cons x xs => cons (f x) (va_list fs xs) - | _, _ => nil - end. - -Program Definition va {A B n} (v : vector (A -> B) n) (w : vector A n) : vector B n := - {| vec_list := va_list v w |}. - -Next Obligation. - destruct v as [v Hv]; destruct w as [w Hw] ; simpl. - subst n. revert w Hw. induction v ; destruct w ; crush. - rewrite IHv ; auto. -Qed. - -(* Correct type inference of record notation. Initial example by Spiwack. *) - -Inductive Machin := { - Bazar : option Machin -}. - -Definition bli : Machin := - {| Bazar := Some ({| Bazar := None |}:Machin) |}. - -Definition bli' : option (option Machin) := - Some (Some {| Bazar := None |} ). - -Definition bli'' : Machin := - {| Bazar := Some {| Bazar := None |} |}. - -Definition bli''' := {| Bazar := Some {| Bazar := None |} |}. - -(** Correctly use scoping information *) - -From Stdlib Require Import ZArith. - -Record Foo := { bar : Z }. -Definition foo := {| bar := 0 |}. - -(** Notations inside records *) - -From Stdlib Require Import Relation_Definitions. - -Record DecidableOrder : Type := -{ A : Type -; le : relation A where "x <= y" := (le x y) -; le_refl : reflexive _ le -; le_antisym : antisymmetric _ le -; le_trans : transitive _ le -; le_total : forall x y, {x <= y}+{y <= x} -}. - -(* Test syntactic sugar suggested by wish report #2138 *) - -Record R : Type := { - P (A : Type) : Prop := exists x : A -> A, x = x; - Q A : P A -> P A -}. - -(* We allow reusing an implicit parameter named in non-recursive types *) -(* This is used in a couple of development such as UniMatch *) - -Record S {A:Type} := { a : A; b : forall A:Type, A }. - -(* Bug #13165 on implicit arguments in defined fields *) -Record T := { - f {n:nat} (p:n=n) := nat; - g := f (eq_refl 0) -}. - -(* Slight improvement in when SProp relevance is detected *) -Inductive True : SProp := I. -Inductive eqI : True -> SProp := reflI : eqI I. - -Record U (c:True) := { - u := c; - v := reflI : eqI u; - }. - -Module MaximalImplicit. - -Record T := { f : forall a, a = 0 }. -Arguments f _ {a}. -Check fun x => x.(f) : 0 = 0. - -End MaximalImplicit. - -Module NoRecursiveRecordVariant. - -Fail Record t := {a:t}. -Fail Variant t := C : t -> t. - -End NoRecursiveRecordVariant. diff --git a/stdlib/test-suite/success/Reg.v b/stdlib/test-suite/success/Reg.v deleted file mode 100644 index 0f59e14ba353..000000000000 --- a/stdlib/test-suite/success/Reg.v +++ /dev/null @@ -1,144 +0,0 @@ -From Stdlib Require Import Reals. - -Axiom y : R -> R. -Axiom d_y : derivable y. -Axiom n_y : forall x : R, y x <> 0%R. -Axiom dy_0 : derive_pt y 0 (d_y 0%R) = 1%R. - -Lemma essai0 : continuity_pt (fun x : R => ((x + 2) / y x + x / y x)%R) 0. -assert (H := d_y). -assert (H0 := n_y). -reg. -Qed. - -Lemma essai1 : derivable_pt (fun x : R => (/ 2 * sin x)%R) 1. -reg. -Qed. - -Lemma essai2 : continuity (fun x : R => (Rsqr x * cos (x * x) + x)%R). -reg. -Qed. - -Lemma essai3 : derivable_pt (fun x : R => (x * (Rsqr x + 3))%R) 0. -reg. -Qed. - -Lemma essai4 : derivable (fun x : R => ((x + x) * sin x)%R). -reg. -Qed. - -Lemma essai5 : derivable (fun x : R => (1 + sin (2 * x + 3) * cos (cos x))%R). -reg. -Qed. - -Lemma essai6 : derivable (fun x : R => cos (x + 3)). -reg. -Qed. - -Lemma essai7 : - derivable_pt (fun x : R => (cos (/ sqrt x) * Rsqr (sin x + 1))%R) 1. -reg. -apply Rlt_0_1. -red; intro; rewrite sqrt_1 in H; assert (H0 := R1_neq_R0); elim H0; - assumption. -Qed. - -Lemma essai8 : derivable_pt (fun x : R => sqrt (Rsqr x + sin x + 1)) 0. -reg. - rewrite sin_0. - rewrite Rsqr_0. - replace (0 + 0 + 1)%R with 1%R; [ apply Rlt_0_1 | ring ]. -Qed. - -Lemma essai9 : derivable_pt (id + sin) 1. -reg. -Qed. - -Lemma essai10 : derivable_pt (fun x : R => (x + 2)%R) 0. -reg. -Qed. - -Lemma essai11 : derive_pt (fun x : R => (x + 2)%R) 0 essai10 = 1%R. -reg. -Qed. - -Lemma essai12 : derivable (fun x : R => (x + Rsqr (x + 2))%R). -reg. -Qed. - -Lemma essai13 : - derive_pt (fun x : R => (x + Rsqr (x + 2))%R) 0 (essai12 0%R) = 5%R. -reg. -Qed. - -Lemma essai14 : derivable_pt (fun x : R => (2 * x + x)%R) 2. -reg. -Qed. - -Lemma essai15 : derive_pt (fun x : R => (2 * x + x)%R) 2 essai14 = 3%R. -reg. -Qed. - -Lemma essai16 : derivable_pt (fun x : R => (x + sin x)%R) 0. -reg. -Qed. - -Lemma essai17 : derive_pt (fun x : R => (x + sin x)%R) 0 essai16 = 2%R. -reg. - rewrite cos_0. -reflexivity. -Qed. - -Lemma essai18 : derivable_pt (fun x : R => (x + y x)%R) 0. -assert (H := d_y). -reg. -Qed. - -Lemma essai19 : derive_pt (fun x : R => (x + y x)%R) 0 essai18 = 2%R. -assert (H := dy_0). -assert (H0 := d_y). -reg. -Qed. - -Axiom z : R -> R. -Axiom d_z : derivable z. - -Lemma essai20 : derivable_pt (fun x : R => z (y x)) 0. -reg. -apply d_y. -apply d_z. -Qed. - -Lemma essai21 : derive_pt (fun x : R => z (y x)) 0 essai20 = 1%R. -assert (H := dy_0). -reg. -Abort. - -Lemma essai22 : derivable (fun x : R => (sin (z x) + Rsqr (z x) / y x)%R). -assert (H := d_y). -reg. -apply n_y. -apply d_z. -Qed. - -(* Pour tester la continuite de sqrt en 0 *) -Lemma essai23 : - continuity_pt - (fun x : R => (sin (sqrt (x - 1)) + exp (Rsqr (sqrt x + 3)))%R) 1. -reg. -left; apply Rlt_0_1. -right; unfold Rminus; rewrite Rplus_opp_r; reflexivity. -Qed. - -Lemma essai24 : - derivable (fun x : R => (sqrt (x * x + 2 * x + 2) + Rabs (x * x + 1))%R). -reg. - replace (x * x + 2 * x + 2)%R with (Rsqr (x + 1) + 1)%R. -apply Rplus_le_lt_0_compat; [ apply Rle_0_sqr | apply Rlt_0_1 ]. -unfold Rsqr; ring. -red; intro; cut (0 < x * x + 1)%R. -intro; rewrite H in H0; elim (Rlt_irrefl _ H0). -apply Rplus_le_lt_0_compat; - [ replace (x * x)%R with (Rsqr x); [ apply Rle_0_sqr | reflexivity ] - | apply Rlt_0_1 ]. -Qed. diff --git a/stdlib/test-suite/success/SchemeEqualityZArith.v b/stdlib/test-suite/success/SchemeEqualityZArith.v deleted file mode 100644 index 4c26d332cadd..000000000000 --- a/stdlib/test-suite/success/SchemeEqualityZArith.v +++ /dev/null @@ -1,66 +0,0 @@ -(* An example from fiat_crypto which fails for two reasons: - - parameters of the form [Type * Type] are not yet supported - - Prop arguments are not supported *) -Require Import ZArith. -Module M. - -Fixpoint tuple' T n : Type := - match n with - | O => T - | S n' => (tuple' T n' * T)%type - end. - -Definition tuple T n : Type := - match n with - | O => unit - | S n' => tuple' T n' - end. - -Definition reg_state := tuple Z 16. - -Definition flag_state := tuple (option bool) 6. - -Class parameters := { - param_key : Type; - param_value : Type; - param_ltb : param_key -> param_key -> bool -}. - -Axiom sorted : forall {p : parameters}, list (param_key * param_value) -> bool. - -Record rep (p : parameters) := { - value : list (param_key * param_value); - _value_ok : sorted value = true -}. - -Record word (width : Z) := { - word_rep : Type; - word_ltu : word_rep -> word_rep -> bool; -}. - -Open Scope Z_scope. - -Record naive_rep width := { - unsigned : Z ; - _unsigned_in_range : unsigned mod (2^width) = unsigned -}. - -Definition naive width : word width := {| - word_rep := naive_rep width; - word_ltu x y := Z.ltb (unsigned _ x) (unsigned _ y); -|}. - -Definition SortedList_parameters {width} (w:word width) value : parameters := {| - param_value := value; - param_key := word_rep _ w; - param_ltb := word_ltu _ w -|}. - -Definition mem_state := rep (SortedList_parameters (naive 64) Z). - -Record machine_state := { machine_reg_state :> reg_state ; machine_flag_state :> flag_state ; machine_mem_state :> mem_state }. - -(* Should succeed! *) -Fail Scheme Boolean Equality for machine_state. - -End M. diff --git a/stdlib/test-suite/success/TestRefine.v b/stdlib/test-suite/success/TestRefine.v deleted file mode 100644 index cdf90f3050a9..000000000000 --- a/stdlib/test-suite/success/TestRefine.v +++ /dev/null @@ -1,223 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* match x0 with - | O => _ - | S p => _ - end)). - -Restart. - - refine - (fun x0 : nat => match x0 as n return (n = n) with - | O => _ - | S p => _ - end). (* OK *) - -Restart. - - refine - (fun x0 : nat => match x0 as n return (n = n) with - | O => _ - | S p => _ - end). (* OK *) - -Restart. - -(** -Refine [x0:nat]Cases x0 of O => ? | (S p) => ? end. (* cannot be executed *) -**) - -Abort. - - -(************************************************************************) - -Lemma T : nat. - - refine (S _). - -Abort. - - -(************************************************************************) - -Lemma essai2 : forall x : nat, x = x. - -refine (fix f (x : nat) : x = x := _). - -Restart. - - refine - (fix f (x : nat) : x = x := - match x as n return (n = n :>nat) with - | O => _ - | S p => _ - end). - -Restart. - - refine - (fix f (x : nat) : x = x := - match x as n return (n = n) with - | O => _ - | S p => _ - end). - -Restart. - - refine - (fix f (x : nat) : x = x := - match x as n return (n = n :>nat) with - | O => _ - | S p => f_equal S _ - end). - -Restart. - - refine - (fix f (x : nat) : x = x := - match x as n return (n = n :>nat) with - | O => _ - | S p => f_equal S _ - end). - -Abort. - - -(************************************************************************) -Parameter f : nat * nat -> nat -> nat. - -Lemma essai : nat. - - refine (f _ ((fun x : nat => _:nat) 0)). - -Restart. - - refine (f _ 0). - -Abort. - - -(************************************************************************) - -Parameter P : nat -> Prop. - -Lemma essai : {x : nat | x = 1}. - - refine (exist _ 1 _). (* ECHEC *) - -Restart. - -(* mais si on contraint par le but alors ca marche : *) -(* Remarque : on peut toujours faire Ƨa *) - refine (exist _ 1 _:{x : nat | x = 1}). - -Restart. - - refine (exist (fun x : nat => x = 1) 1 _). - -Abort. - - -(************************************************************************) - -Lemma essai : forall n : nat, {x : nat | x = S n}. - - refine - (fun n : nat => - match n return {x : nat | x = S n} with - | O => _ - | S p => _ - end). - -Restart. - - refine - (fun n : nat => match n with - | O => _ - | S p => _ - end). - -Restart. - - refine - (fun n : nat => - match n return {x : nat | x = S n} with - | O => _ - | S p => _ - end). - -Restart. - - refine - (fix f (n : nat) : {x : nat | x = S n} := - match n return {x : nat | x = S n} with - | O => _ - | S p => _ - end). - -Restart. - - refine - (fix f (n : nat) : {x : nat | x = S n} := - match n return {x : nat | x = S n} with - | O => _ - | S p => _ - end). - -exists 1. trivial. -elim (f p). - refine - (fun (x : nat) (h : x = S p) => exist (fun x : nat => x = S (S p)) (S x) _). - rewrite h. auto. -Qed. - - - -(* Quelques essais de recurrence bien fondĆ©e *) - -From Stdlib Require Import Init.Wf. -From Stdlib Require Import Wf_nat. - -Lemma essai_wf : nat -> nat. - - refine - (fun x : nat => - well_founded_induction _ (fun _ : nat => nat -> nat) - (fun (phi0 : nat) (w : forall phi : nat, phi < phi0 -> nat -> nat) => - w x _) x x). -exact lt_wf. - -Abort. - - -From Stdlib Require Import Arith_base. - -Lemma fibo : nat -> nat. - refine - (well_founded_induction _ (fun _ : nat => nat) - (fun (x0 : nat) (fib : forall x : nat, x < x0 -> nat) => - match zerop x0 with - | left _ => 1 - | right h1 => - match zerop (pred x0) with - | left _ => 1 - | right h2 => fib (pred x0) _ + fib (pred (pred x0)) _ - end - end)). -exact lt_wf. -auto with arith. -apply Nat.lt_trans with (m := pred x0); auto with arith. -Qed. diff --git a/stdlib/test-suite/success/ZModulo.v b/stdlib/test-suite/success/ZModulo.v deleted file mode 100644 index ad334b92744f..000000000000 --- a/stdlib/test-suite/success/ZModulo.v +++ /dev/null @@ -1,1083 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* 1%positive. - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Definition wB := base digits. - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Definition t := Z. - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Definition zdigits := Zpos digits. - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Definition to_Z x := x mod wB. - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Notation "[| x |]" := (to_Z x) (at level 0, x at level 99). - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Notation "[+| c |]" := - (interp_carry 1 wB to_Z c) (at level 0, c at level 99). - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Notation "[-| c |]" := - (interp_carry (-1) wB to_Z c) (at level 0, c at level 99). - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Notation "[|| x ||]" := - (zn2z_to_Z wB to_Z x) (at level 0, x at level 99). - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Lemma spec_more_than_1_digit: 1 < Zpos digits. - Proof. - generalize digits_ne_1; destruct digits; red; auto. - destruct 1; auto. - Qed. - Let digits_gt_1 := spec_more_than_1_digit. - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Lemma wB_pos : wB > 0. - Proof. - apply Z.lt_gt. - unfold wB, base; auto with zarith. - Qed. - #[local] - Hint Resolve wB_pos : core. - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Lemma spec_to_Z_1 : forall x, 0 <= [|x|]. - Proof. - unfold to_Z; intros; destruct (Z_mod_lt x wB wB_pos); auto. - Qed. - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Lemma spec_to_Z_2 : forall x, [|x|] < wB. - Proof. - unfold to_Z; intros; destruct (Z_mod_lt x wB wB_pos); auto. - Qed. - #[local] - Hint Resolve spec_to_Z_1 spec_to_Z_2 : core. - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Lemma spec_to_Z : forall x, 0 <= [|x|] < wB. - Proof. - auto. - Qed. - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Definition of_pos x := - let (q,r) := Z.pos_div_eucl x wB in (N_of_Z q, r). - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Lemma spec_of_pos : forall p, - Zpos p = (Z.of_N (fst (of_pos p)))*wB + [|(snd (of_pos p))|]. - Proof. - intros; unfold of_pos; simpl. - generalize (Z_div_mod_POS wB wB_pos p). - destruct (Z.pos_div_eucl p wB); simpl; destruct 1. - unfold to_Z; rewrite Zmod_small; auto. - assert (0 <= z). { - replace z with (Zpos p / wB) by - (symmetry; apply Zdiv_unique with z0; auto). - apply Z_div_pos; auto with zarith. - } - replace (Z.of_N (N_of_Z z)) with z by - (destruct z; simpl; auto; elim H1; auto). - rewrite Z.mul_comm; auto. - Qed. - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Lemma spec_zdigits : [|zdigits|] = Zpos digits. - Proof. - unfold to_Z, zdigits. - apply Zmod_small. - unfold wB, base. - split; auto with zarith. - apply Zpower2_lt_lin; auto with zarith. - Qed. - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Definition zero := 0. - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Definition one := 1. - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Definition minus_one := wB - 1. - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Lemma spec_0 : [|zero|] = 0. - Proof. - unfold to_Z, zero. - apply Zmod_small; generalize wB_pos. lia. - Qed. - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Lemma spec_1 : [|one|] = 1. - Proof. - unfold to_Z, one. - apply Zmod_small; split; auto with zarith. - unfold wB, base. - apply Z.lt_trans with (Zpos digits); auto. - apply Zpower2_lt_lin; auto with zarith. - Qed. - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Lemma spec_Bm1 : [|minus_one|] = wB - 1. - Proof. - unfold to_Z, minus_one. - apply Zmod_small; split. 2: lia. - unfold wB, base. - cut (1 <= 2 ^ Zpos digits). { lia. } - apply Z.le_trans with (Zpos digits). { lia. } - apply Zpower2_le_lin; auto with zarith. - Qed. - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Definition compare x y := Z.compare [|x|] [|y|]. - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Lemma spec_compare : forall x y, - compare x y = Z.compare [|x|] [|y|]. - Proof. reflexivity. Qed. - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Definition eq0 x := - match [|x|] with Z0 => true | _ => false end. - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Lemma spec_eq0 : forall x, eq0 x = true -> [|x|] = 0. - Proof. - unfold eq0; intros; now destruct [|x|]. - Qed. - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Definition opp_c x := - if eq0 x then C0 0 else C1 (- x). - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Definition opp x := - x. - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Definition opp_carry x := - x - 1. - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Lemma spec_opp_c : forall x, [-|opp_c x|] = -[|x|]. - Proof. - intros; unfold opp_c, to_Z; auto. - case_eq (eq0 x); intros; unfold interp_carry. - - fold [|x|]; rewrite (spec_eq0 x H); auto. - - assert (x mod wB <> 0). - { unfold eq0, to_Z in H. - intro H0; rewrite H0 in H; discriminate. } - rewrite Z_mod_nz_opp_full; lia. - Qed. - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Lemma spec_opp : forall x, [|opp x|] = (-[|x|]) mod wB. - Proof. - intros; unfold opp, to_Z; auto. - change ((- x) mod wB = (0 - (x mod wB)) mod wB). - rewrite Zminus_mod_idemp_r; simpl; auto. - Qed. - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Lemma spec_opp_carry : forall x, [|opp_carry x|] = wB - [|x|] - 1. - Proof. - intros; unfold opp_carry, to_Z; auto. - replace (- x - 1) with (- 1 - x) by lia. - rewrite <- Zminus_mod_idemp_r. - replace ( -1 - x mod wB) with (0 + ( -1 - x mod wB)) by lia. - rewrite <- (Z_mod_same_full wB). - rewrite Zplus_mod_idemp_l. - replace (wB + (-1 - x mod wB)) with (wB - x mod wB -1) by lia. - apply Zmod_small. - generalize (Z_mod_lt x wB wB_pos); lia. - Qed. - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Definition succ_c x := - let y := Z.succ x in - if eq0 y then C1 0 else C0 y. - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Definition add_c x y := - let z := [|x|] + [|y|] in - if Z_lt_le_dec z wB then C0 z else C1 (z-wB). - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Definition add_carry_c x y := - let z := [|x|]+[|y|]+1 in - if Z_lt_le_dec z wB then C0 z else C1 (z-wB). - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Definition succ := Z.succ. - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Definition add := Z.add. - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Definition add_carry x y := x + y + 1. - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Lemma Zmod_equal : - forall x y z, z>0 -> (x-y) mod z = 0 -> x mod z = y mod z. - Proof. - intros. - generalize (Z_div_mod_eq_full (x-y) z); rewrite H0, Z.add_0_r. - remember ((x-y)/z) as k. - rewrite Z.sub_move_r, Z.add_comm, Z.mul_comm. intros ->. - now apply Z_mod_plus. - Qed. - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Lemma spec_succ_c : forall x, [+|succ_c x|] = [|x|] + 1. - Proof. - intros; unfold succ_c, to_Z, Z.succ. - case_eq (eq0 (x+1)); intros; unfold interp_carry. - - - rewrite Z.mul_1_l. - replace (wB + 0 mod wB) with wB by auto with zarith. - symmetry. rewrite Z.add_move_r. - assert ((x+1) mod wB = 0) by (apply spec_eq0; auto). - replace (wB-1) with ((wB-1) mod wB) by - (apply Zmod_small; generalize wB_pos; lia). - rewrite <- Zminus_mod_idemp_l; rewrite Z_mod_same; simpl; auto. - apply Zmod_equal; auto. - - - assert ((x+1) mod wB <> 0). { - unfold eq0, to_Z in *; now destruct ((x+1) mod wB). - } - assert (x mod wB + 1 <> wB). { - contradict H0. - rewrite Z.add_move_r in H0; simpl in H0. - rewrite <- Zplus_mod_idemp_l; rewrite H0. - replace (wB-1+1) with wB by lia; apply Z_mod_same; auto. - } - rewrite <- Zplus_mod_idemp_l. - apply Zmod_small. - generalize (Z_mod_lt x wB wB_pos); lia. - Qed. - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Lemma spec_add_c : forall x y, [+|add_c x y|] = [|x|] + [|y|]. - Proof. - intros; unfold add_c, to_Z, interp_carry. - destruct Z_lt_le_dec. - - apply Zmod_small; - generalize (Z_mod_lt x wB wB_pos) (Z_mod_lt y wB wB_pos); lia. - - rewrite Z.mul_1_l, Z.add_comm, Z.add_move_r. - apply Zmod_small; - generalize (Z_mod_lt x wB wB_pos) (Z_mod_lt y wB wB_pos); lia. - Qed. - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Lemma spec_add_carry_c : forall x y, [+|add_carry_c x y|] = [|x|] + [|y|] + 1. - Proof. - intros; unfold add_carry_c, to_Z, interp_carry. - destruct Z_lt_le_dec. - - apply Zmod_small; - generalize (Z_mod_lt x wB wB_pos) (Z_mod_lt y wB wB_pos); lia. - - rewrite Z.mul_1_l, Z.add_comm, Z.add_move_r. - apply Zmod_small; - generalize (Z_mod_lt x wB wB_pos) (Z_mod_lt y wB wB_pos); lia. - Qed. - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Lemma spec_succ : forall x, [|succ x|] = ([|x|] + 1) mod wB. - Proof. - intros; unfold succ, to_Z, Z.succ. - symmetry; apply Zplus_mod_idemp_l. - Qed. - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Lemma spec_add : forall x y, [|add x y|] = ([|x|] + [|y|]) mod wB. - Proof. - intros; unfold add, to_Z; apply Zplus_mod. - Qed. - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Lemma spec_add_carry : - forall x y, [|add_carry x y|] = ([|x|] + [|y|] + 1) mod wB. - Proof. - intros; unfold add_carry, to_Z. - rewrite <- Zplus_mod_idemp_l. - rewrite (Zplus_mod x y). - rewrite Zplus_mod_idemp_l; auto. - Qed. - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Definition pred_c x := - if eq0 x then C1 (wB-1) else C0 (x-1). - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Definition sub_c x y := - let z := [|x|]-[|y|] in - if Z_lt_le_dec z 0 then C1 (wB+z) else C0 z. - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Definition sub_carry_c x y := - let z := [|x|]-[|y|]-1 in - if Z_lt_le_dec z 0 then C1 (wB+z) else C0 z. - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Definition pred := Z.pred. - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Definition sub := Z.sub. - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Definition sub_carry x y := x - y - 1. - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Lemma spec_pred_c : forall x, [-|pred_c x|] = [|x|] - 1. - Proof. - intros; unfold pred_c, to_Z, interp_carry. - case_eq (eq0 x); intros. - - fold [|x|]; rewrite spec_eq0; auto. - replace ((wB-1) mod wB) with (wB-1). - + lia. - + symmetry; apply Zmod_small; generalize wB_pos; lia. - - - assert (x mod wB <> 0). - + unfold eq0, to_Z in *; now destruct (x mod wB). - + rewrite <- Zminus_mod_idemp_l. - apply Zmod_small. - generalize (Z_mod_lt x wB wB_pos); lia. - Qed. - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Lemma spec_sub_c : forall x y, [-|sub_c x y|] = [|x|] - [|y|]. - Proof. - intros; unfold sub_c, to_Z, interp_carry. - destruct Z_lt_le_dec. - - replace ((wB + (x mod wB - y mod wB)) mod wB) with - (wB + (x mod wB - y mod wB)). - + lia. - + symmetry; apply Zmod_small. - generalize wB_pos (Z_mod_lt x wB wB_pos) (Z_mod_lt y wB wB_pos); lia. - - - apply Zmod_small. - generalize wB_pos (Z_mod_lt x wB wB_pos) (Z_mod_lt y wB wB_pos); lia. - Qed. - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Lemma spec_sub_carry_c : forall x y, [-|sub_carry_c x y|] = [|x|] - [|y|] - 1. - Proof. - intros; unfold sub_carry_c, to_Z, interp_carry. - destruct Z_lt_le_dec. - - replace ((wB + (x mod wB - y mod wB - 1)) mod wB) with - (wB + (x mod wB - y mod wB -1)). - + lia. - + symmetry; apply Zmod_small. - generalize wB_pos (Z_mod_lt x wB wB_pos) (Z_mod_lt y wB wB_pos); lia. - - - apply Zmod_small. - generalize wB_pos (Z_mod_lt x wB wB_pos) (Z_mod_lt y wB wB_pos); lia. - Qed. - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Lemma spec_pred : forall x, [|pred x|] = ([|x|] - 1) mod wB. - Proof. - intros; unfold pred, to_Z, Z.pred. - rewrite <- Zplus_mod_idemp_l; auto. - Qed. - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Lemma spec_sub : forall x y, [|sub x y|] = ([|x|] - [|y|]) mod wB. - Proof. - intros; unfold sub, to_Z; apply Zminus_mod. - Qed. - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Lemma spec_sub_carry : - forall x y, [|sub_carry x y|] = ([|x|] - [|y|] - 1) mod wB. - Proof. - intros; unfold sub_carry, to_Z. - rewrite <- Zminus_mod_idemp_l. - rewrite (Zminus_mod x y). - rewrite Zminus_mod_idemp_l. - auto. - Qed. - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Definition mul_c x y := - let (h,l) := Z.div_eucl ([|x|]*[|y|]) wB in - if eq0 h then if eq0 l then W0 else WW h l else WW h l. - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Definition mul := Z.mul. - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Definition square_c x := mul_c x x. - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Lemma spec_mul_c : forall x y, [|| mul_c x y ||] = [|x|] * [|y|]. - Proof. - intros; unfold mul_c, zn2z_to_Z. - assert (Z.div_eucl ([|x|]*[|y|]) wB = (([|x|]*[|y|])/wB,([|x|]*[|y|]) mod wB)). - - unfold Z.modulo, Z.div; destruct Z.div_eucl; auto. - - generalize (Z_div_mod ([|x|]*[|y|]) wB wB_pos); destruct Z.div_eucl as (h,l). - destruct 1; injection H as [= ? ?]. - rewrite H0. - assert ([|l|] = l). - + apply Zmod_small; auto. - + assert ([|h|] = h). - * apply Zmod_small. - subst h. - split. - -- apply Z_div_pos; auto with zarith. - -- apply Zdiv_lt_upper_bound. - ++ lia. - ++ apply Z.mul_lt_mono_nonneg; auto with zarith. - * clear H H0 H1 H2. - case_eq (eq0 h); simpl; intros. - -- case_eq (eq0 l); simpl; intros. - ++ rewrite <- H3, <- H4, (spec_eq0 h), (spec_eq0 l); auto. lia. - ++ rewrite H3, H4; auto with zarith. - -- rewrite H3, H4; auto with zarith. - Qed. - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Lemma spec_mul : forall x y, [|mul x y|] = ([|x|] * [|y|]) mod wB. - Proof. - intros; unfold mul, to_Z; apply Zmult_mod. - Qed. - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Lemma spec_square_c : forall x, [|| square_c x||] = [|x|] * [|x|]. - Proof. - intros x; exact (spec_mul_c x x). - Qed. - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Definition div x y := Z.div_eucl [|x|] [|y|]. - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Lemma spec_div : forall a b, 0 < [|b|] -> - let (q,r) := div a b in - [|a|] = [|q|] * [|b|] + [|r|] /\ - 0 <= [|r|] < [|b|]. - Proof. - intros; unfold div. - assert ([|b|]>0) by lia. - assert (Z.div_eucl [|a|] [|b|] = ([|a|]/[|b|], [|a|] mod [|b|])). - { unfold Z.modulo, Z.div; destruct Z.div_eucl; auto. } - generalize (Z_div_mod [|a|] [|b|] H0). - destruct Z.div_eucl as (q,r); destruct 1; intros. - injection H1 as [= ? ?]. - assert ([|r|]=r). { - apply Zmod_small; generalize (Z_mod_lt b wB wB_pos); fold [|b|]; - lia. - } - assert ([|q|]=q). { - apply Zmod_small. - subst q. - split. - - apply Z_div_pos; auto with zarith. - - apply Zdiv_lt_upper_bound; auto with zarith. - apply Z.lt_le_trans with (wB*1). - + rewrite Z.mul_1_r; auto with zarith. - + apply Z.mul_le_mono_nonneg; generalize wB_pos; lia. - } - rewrite H5, H6; rewrite Z.mul_comm; auto with zarith. - Qed. - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Definition div_gt := div. - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Lemma spec_div_gt : forall a b, [|a|] > [|b|] -> 0 < [|b|] -> - let (q,r) := div_gt a b in - [|a|] = [|q|] * [|b|] + [|r|] /\ - 0 <= [|r|] < [|b|]. - Proof. - intros. - apply spec_div; auto. - Qed. - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Definition modulo x y := [|x|] mod [|y|]. - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Definition modulo_gt x y := [|x|] mod [|y|]. - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Lemma spec_modulo : forall a b, 0 < [|b|] -> - [|modulo a b|] = [|a|] mod [|b|]. - Proof. - intros; unfold modulo. - apply Zmod_small. - assert ([|b|]>0) by lia. - generalize (Z_mod_lt [|a|] [|b|] H0) (Z_mod_lt b wB wB_pos). - fold [|b|]; lia. - Qed. - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Lemma spec_modulo_gt : forall a b, [|a|] > [|b|] -> 0 < [|b|] -> - [|modulo_gt a b|] = [|a|] mod [|b|]. - Proof. - intros; apply spec_modulo; auto. - Qed. - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Definition gcd x y := Z.gcd [|x|] [|y|]. - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Definition gcd_gt x y := Z.gcd [|x|] [|y|]. - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Lemma Zgcd_bound : forall a b, 0<=a -> 0<=b -> Z.gcd a b <= Z.max a b. - Proof. - intros. - generalize (Zgcd_is_gcd a b); inversion_clear 1. - destruct H2 as (q,H2); destruct H3 as (q',H3); clear H4. - assert (H4:=Z.gcd_nonneg a b). - destruct (Z.eq_dec (Z.gcd a b) 0) as [->|Hneq]. - - generalize (Zmax_spec a b); lia. - - assert (0 <= q). - { apply Z.mul_le_mono_pos_r with (Z.gcd a b); lia. } - destruct (Z.eq_dec q 0). - - + subst q; simpl in *; subst a; simpl; auto. - generalize (Zmax_spec 0 b) (Zabs_spec b); lia. - - + apply Z.le_trans with a. - * rewrite H2 at 2. - rewrite <- (Z.mul_1_l (Z.gcd a b)) at 1. - apply Z.mul_le_mono_nonneg; lia. - * generalize (Zmax_spec a b); lia. - Qed. - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Lemma spec_gcd : forall a b, Zis_gcd [|a|] [|b|] [|gcd a b|]. - Proof. - intros; unfold gcd. - generalize (Z_mod_lt a wB wB_pos)(Z_mod_lt b wB wB_pos); intros. - fold [|a|] in *; fold [|b|] in *. - replace ([|Z.gcd [|a|] [|b|]|]) with (Z.gcd [|a|] [|b|]). - - apply Zgcd_is_gcd. - - symmetry; apply Zmod_small. - split. - + apply Z.gcd_nonneg. - + apply Z.le_lt_trans with (Z.max [|a|] [|b|]). - * apply Zgcd_bound; auto with zarith. - * generalize (Zmax_spec [|a|] [|b|]); lia. - Qed. - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Lemma spec_gcd_gt : forall a b, [|a|] > [|b|] -> - Zis_gcd [|a|] [|b|] [|gcd_gt a b|]. - Proof. - intros. apply spec_gcd; auto. - Qed. - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Definition div21 a1 a2 b := - Z.div_eucl ([|a1|]*wB+[|a2|]) [|b|]. - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Lemma spec_div21 : forall a1 a2 b, - wB/2 <= [|b|] -> - [|a1|] < [|b|] -> - let (q,r) := div21 a1 a2 b in - [|a1|] *wB+ [|a2|] = [|q|] * [|b|] + [|r|] /\ - 0 <= [|r|] < [|b|]. - Proof. - intros; unfold div21. - generalize (Z_mod_lt a1 wB wB_pos); fold [|a1|]; intros. - generalize (Z_mod_lt a2 wB wB_pos); fold [|a2|]; intros. - assert ([|b|]>0) by lia. - remember ([|a1|]*wB+[|a2|]) as a. - assert (Z.div_eucl a [|b|] = (a/[|b|], a mod [|b|])). - { unfold Z.modulo, Z.div; destruct Z.div_eucl; auto. } - generalize (Z_div_mod a [|b|] H3). - destruct Z.div_eucl as (q,r); destruct 1; intros. - injection H4 as [= ? ?]. - assert ([|r|]=r). { - apply Zmod_small; generalize (Z_mod_lt b wB wB_pos); fold [|b|]; - lia. - } - assert ([|q|]=q). { - apply Zmod_small. - subst q. - split. - - apply Z_div_pos. - + lia. - + subst a. nia. - - apply Zdiv_lt_upper_bound; nia. - } - subst a. - replace (wB*[|b|]) with (([|b|]-1)*wB + wB) by ring. - lia. - Qed. - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Definition add_mul_div p x y := - ([|x|] * (2 ^ [|p|]) + [|y|] / (2 ^ ((Zpos digits) - [|p|]))). - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Lemma spec_add_mul_div : forall x y p, - [|p|] <= Zpos digits -> - [| add_mul_div p x y |] = - ([|x|] * (2 ^ [|p|]) + - [|y|] / (2 ^ ((Zpos digits) - [|p|]))) mod wB. - Proof. - intros; unfold add_mul_div; auto. - Qed. - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Definition pos_mod p w := [|w|] mod (2 ^ [|p|]). - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Lemma spec_pos_mod : forall w p, - [|pos_mod p w|] = [|w|] mod (2 ^ [|p|]). - Proof. - intros; unfold pos_mod. - apply Zmod_small. - generalize (Z_mod_lt [|w|] (2 ^ [|p|])); intros. - split. - - destruct H; auto using Z.lt_gt with zarith. - - apply Z.le_lt_trans with [|w|]; auto with zarith. - apply Zmod_le; auto with zarith. - Qed. - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Definition is_even x := - if Z.eq_dec ([|x|] mod 2) 0 then true else false. - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Lemma spec_is_even : forall x, - if is_even x then [|x|] mod 2 = 0 else [|x|] mod 2 = 1. - Proof. - intros; unfold is_even; destruct Z.eq_dec; auto. - generalize (Z_mod_lt [|x|] 2); lia. - Qed. - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Definition sqrt x := Z.sqrt [|x|]. - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Lemma spec_sqrt : forall x, - [|sqrt x|] ^ 2 <= [|x|] < ([|sqrt x|] + 1) ^ 2. - Proof. - intros. - unfold sqrt. - repeat rewrite Z.pow_2_r. - replace [|Z.sqrt [|x|]|] with (Z.sqrt [|x|]). - - apply Z.sqrt_spec; auto with zarith. - - symmetry; apply Zmod_small. - split. - + apply Z.sqrt_nonneg; auto. - + apply Z.le_lt_trans with [|x|]; auto. - apply Z.sqrt_le_lin; auto. - Qed. - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Definition sqrt2 x y := - let z := [|x|]*wB+[|y|] in - match z with - | Z0 => (0, C0 0) - | Zpos p => - let (s,r) := Z.sqrtrem (Zpos p) in - (s, if Z_lt_le_dec r wB then C0 r else C1 (r-wB)) - | Zneg _ => (0, C0 0) - end. - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Lemma spec_sqrt2 : forall x y, - wB/ 4 <= [|x|] -> - let (s,r) := sqrt2 x y in - [||WW x y||] = [|s|] ^ 2 + [+|r|] /\ - [+|r|] <= 2 * [|s|]. - Proof. - intros; unfold sqrt2. - simpl zn2z_to_Z. - remember ([|x|]*wB+[|y|]) as z. - destruct z. - - auto with zarith. - - generalize (Z.sqrtrem_spec (Zpos p)). - destruct Z.sqrtrem as (s,r); intros [U V]. { lia. } - assert (s < wB). - { - destruct (Z_lt_le_dec s wB); auto. - assert (wB * wB <= Zpos p). { - apply Z.le_trans with (s*s). 2: lia. - apply Z.mul_le_mono_nonneg; generalize wB_pos; lia. - } - assert (Zpos p < wB*wB). { - rewrite Heqz. - replace (wB*wB) with ((wB-1)*wB+wB) by ring. - apply Z.add_le_lt_mono. 2: auto with zarith. - apply Z.mul_le_mono_nonneg. 1, 3-4: auto with zarith. - 1:generalize wB_pos; lia. - generalize (spec_to_Z x); lia. - } - auto with zarith. - } - replace [|s|] with s by (symmetry; apply Zmod_small; lia). - destruct Z_lt_le_dec; unfold interp_carry. - + replace [|r|] with r by (symmetry; apply Zmod_small; lia). - rewrite Z.pow_2_r; lia. - + replace [|r-wB|] with (r-wB) by (symmetry; apply Zmod_small; lia). - rewrite Z.pow_2_r; lia. - - - assert (0<=Zneg p). - { generalize (spec_to_Z x) (spec_to_Z y); nia. } - lia. - Qed. - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Lemma two_p_power2 : forall x, x>=0 -> two_p x = 2 ^ x. - Proof. - intros. - unfold two_p. - destruct x; simpl; auto. - apply two_power_pos_correct. - Qed. - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Definition head0 x := - match [| x |] with - | Z0 => zdigits - | Zneg _ => 0 - | (Zpos _) as p => zdigits - Z.log2 p - 1 - end. - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Lemma spec_head00: forall x, [|x|] = 0 -> [|head0 x|] = Zpos digits. - Proof. unfold head0; intros x ->; apply spec_zdigits. Qed. - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Lemma spec_head0 : forall x, 0 < [|x|] -> - wB/ 2 <= 2 ^ ([|head0 x|]) * [|x|] < wB. - Proof. - intros; unfold head0. - generalize (spec_to_Z x). - destruct [|x|]; try discriminate. - pose proof (Z.log2_nonneg (Zpos p)). - destruct (Z.log2_spec (Zpos p)); auto. - intros. - assert (0 <= zdigits - Z.log2 (Zpos p) - 1 < wB) as Hrange. { - split. - - cut (Z.log2 (Zpos p) < zdigits). - + lia. - + unfold zdigits. - unfold wB, base in *. - apply Z.log2_lt_pow2; intuition. - - apply Z.lt_trans with zdigits. - + lia. - + unfold zdigits, wB, base; apply Zpower2_lt_lin; auto with zarith. - } - - unfold to_Z; rewrite (Zmod_small _ _ Hrange). - split. - - apply Z.le_trans with (2^(zdigits - Z.log2 (Zpos p) - 1)*(2^Z.log2 (Zpos p))). - + apply Zdiv_le_upper_bound; auto with zarith. - rewrite <- Zpower_exp; auto with zarith. - rewrite Z.mul_comm; rewrite <- Z.pow_succ_r; auto with zarith. - replace (Z.succ (zdigits - Z.log2 (Zpos p) -1 + Z.log2 (Zpos p))) with zdigits - by ring. - unfold wB, base, zdigits; auto with zarith. - + apply Z.mul_le_mono_nonneg; auto with zarith. - - - apply Z.lt_le_trans - with (2^(zdigits - Z.log2 (Zpos p) - 1)*(2^(Z.succ (Z.log2 (Zpos p))))). - + apply Z.mul_lt_mono_pos_l; auto with zarith. - + rewrite <- Zpower_exp; auto with zarith. - replace (zdigits - Z.log2 (Zpos p) -1 +Z.succ (Z.log2 (Zpos p))) with zdigits - by ring. - unfold wB, base, zdigits; auto with zarith. - Qed. - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Fixpoint Ptail p := match p with - | xO p => (Ptail p)+1 - | _ => 0 - end. - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Lemma Ptail_pos : forall p, 0 <= Ptail p. - Proof. - induction p; simpl; auto with zarith. - Qed. - #[local] - Hint Resolve Ptail_pos : core. - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Lemma Ptail_bounded : forall p d, Zpos p < 2^(Zpos d) -> Ptail p < Zpos d. - Proof. - induction p; try (compute; auto; fail). - intros; simpl. - assert (d <> xH). { - intro; subst. - compute in H; destruct p; discriminate. - } - assert (Z.succ (Zpos (Pos.pred d)) = Zpos d). { - simpl; f_equal. - rewrite Pos.add_1_r. - destruct (Pos.succ_pred_or d); auto. - rewrite H1 in H0; elim H0; auto. - } - assert (Ptail p < Zpos (Pos.pred d)). { - apply IHp. - apply Z.mul_lt_mono_pos_r with 2; auto with zarith. - rewrite (Z.mul_comm (Zpos p)). - change (2 * Zpos p) with (Zpos p~0). - rewrite Z.mul_comm. - rewrite <- Z.pow_succ_r; auto with zarith. - rewrite H1; auto. - } - rewrite <- H1; lia. - Qed. - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Definition tail0 x := - match [|x|] with - | Z0 => zdigits - | Zpos p => Ptail p - | Zneg _ => 0 - end. - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Lemma spec_tail00: forall x, [|x|] = 0 -> [|tail0 x|] = Zpos digits. - Proof. - unfold tail0; intros. - rewrite H; simpl. - apply spec_zdigits. - Qed. - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Lemma spec_tail0 : forall x, 0 < [|x|] -> - exists y, 0 <= y /\ [|x|] = (2 * y + 1) * (2 ^ [|tail0 x|]). - Proof. - intros; unfold tail0. - generalize (spec_to_Z x). - destruct [|x|]; try discriminate; intros. - assert ([|Ptail p|] = Ptail p). { - apply Zmod_small. - split; auto. - unfold wB, base in *. - apply Z.lt_trans with (Zpos digits). - - apply Ptail_bounded; auto with zarith. - - apply Zpower2_lt_lin; auto with zarith. - } - rewrite H1. - - clear; induction p. - - exists (Zpos p); simpl; rewrite Pos.mul_1_r; auto with zarith. - - destruct IHp as (y & Yp & Ye). - exists y. - split; auto. - change (Zpos p~0) with (2*Zpos p). - rewrite Ye. - change (Ptail p~0) with (Z.succ (Ptail p)). - rewrite Z.pow_succ_r; auto; ring. - - - exists 0; simpl; auto with zarith. - Qed. - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Definition lor := Z.lor. - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Definition land := Z.land. - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Definition lxor := Z.lxor. - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Lemma spec_lor x y : [|lor x y|] = Z.lor [|x|] [|y|]. - Proof. - unfold lor, to_Z. - apply Z.bits_inj'; intros n Hn. rewrite Z.lor_spec. - unfold wB, base. - destruct (Z.le_gt_cases (Z.pos digits) n). - - rewrite !Z.mod_pow2_bits_high; auto with zarith. - - rewrite !Z.mod_pow2_bits_low, Z.lor_spec; auto with zarith. - Qed. - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Lemma spec_land x y : [|land x y|] = Z.land [|x|] [|y|]. - Proof. - unfold land, to_Z. - apply Z.bits_inj'; intros n Hn. rewrite Z.land_spec. - unfold wB, base. - destruct (Z.le_gt_cases (Z.pos digits) n). - - rewrite !Z.mod_pow2_bits_high; auto with zarith. - - rewrite !Z.mod_pow2_bits_low, Z.land_spec; auto with zarith. - Qed. - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Lemma spec_lxor x y : [|lxor x y|] = Z.lxor [|x|] [|y|]. - Proof. - unfold lxor, to_Z. - apply Z.bits_inj'; intros n Hn. rewrite Z.lxor_spec. - unfold wB, base. - destruct (Z.le_gt_cases (Z.pos digits) n). - - rewrite !Z.mod_pow2_bits_high; auto with zarith. - - rewrite !Z.mod_pow2_bits_low, Z.lxor_spec; auto with zarith. - Qed. - - (** Let's now group everything in two records *) - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Definition zmod_ops : ZnZ.Ops Z := ZnZ.MkOps - (digits : positive) - (zdigits: t) - (to_Z : t -> Z) - (of_pos : positive -> N * t) - (head0 : t -> t) - (tail0 : t -> t) - - (zero : t) - (one : t) - (minus_one : t) - - (compare : t -> t -> comparison) - (eq0 : t -> bool) - - (opp_c : t -> carry t) - (opp : t -> t) - (opp_carry : t -> t) - - (succ_c : t -> carry t) - (add_c : t -> t -> carry t) - (add_carry_c : t -> t -> carry t) - (succ : t -> t) - (add : t -> t -> t) - (add_carry : t -> t -> t) - - (pred_c : t -> carry t) - (sub_c : t -> t -> carry t) - (sub_carry_c : t -> t -> carry t) - (pred : t -> t) - (sub : t -> t -> t) - (sub_carry : t -> t -> t) - - (mul_c : t -> t -> zn2z t) - (mul : t -> t -> t) - (square_c : t -> zn2z t) - - (div21 : t -> t -> t -> t*t) - (div_gt : t -> t -> t * t) - (div : t -> t -> t * t) - - (modulo_gt : t -> t -> t) - (modulo : t -> t -> t) - - (gcd_gt : t -> t -> t) - (gcd : t -> t -> t) - (add_mul_div : t -> t -> t -> t) - (pos_mod : t -> t -> t) - - (is_even : t -> bool) - (sqrt2 : t -> t -> t * carry t) - (sqrt : t -> t) - (lor : t -> t -> t) - (land : t -> t -> t) - (lxor : t -> t -> t). - Existing Instance zmod_ops. - - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Definition zmod_specs : ZnZ.Specs zmod_ops := ZnZ.MkSpecs - spec_to_Z - spec_of_pos - spec_zdigits - spec_more_than_1_digit - - spec_0 - spec_1 - spec_Bm1 - - spec_compare - spec_eq0 - - spec_opp_c - spec_opp - spec_opp_carry - - spec_succ_c - spec_add_c - spec_add_carry_c - spec_succ - spec_add - spec_add_carry - - spec_pred_c - spec_sub_c - spec_sub_carry_c - spec_pred - spec_sub - spec_sub_carry - - spec_mul_c - spec_mul - spec_square_c - - spec_div21 - spec_div_gt - spec_div - - spec_modulo_gt - spec_modulo - - spec_gcd_gt - spec_gcd - - spec_head00 - spec_head0 - spec_tail00 - spec_tail0 - - spec_add_mul_div - spec_pos_mod - - spec_is_even - spec_sqrt2 - spec_sqrt - spec_lor - spec_land - spec_lxor. - Existing Instance zmod_specs. - -End ZModulo. - -(** A modular version of the previous construction. *) - -Module Type PositiveNotOne. - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Parameter p : positive. - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Axiom not_one : p <> 1%positive. -End PositiveNotOne. - -Module ZModuloCyclicType (P:PositiveNotOne) <: CyclicType. - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Definition t := Z. -#[global] - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Definition ops : ZnZ.Ops t := zmod_ops P.p. - Existing Instance ops. -#[global] - #[deprecated(note="Cyclic.ZModulo will be moved to the test suite", since="8.17")] - Definition specs : ZnZ.Specs ops := zmod_specs P.not_one. - Existing Instance specs. -End ZModuloCyclicType. diff --git a/stdlib/test-suite/success/add_field_pre_post.v b/stdlib/test-suite/success/add_field_pre_post.v deleted file mode 100644 index ba0942b8adae..000000000000 --- a/stdlib/test-suite/success/add_field_pre_post.v +++ /dev/null @@ -1,75 +0,0 @@ -Require Import Reals. - -Open Scope R_scope. - -Parameter Rpow : R -> R -> R. - -Axiom Rpow_convert_Z : forall x n, - Rpow x (IZR n) = pow x (Z.abs_nat n). - -Lemma Rpow_non_0 x y : x <> 0 -> Rpow x (IZR y) <> 0. -Proof. -now rewrite Rpow_convert_Z; apply pow_nonzero. -Qed. - -Ltac to_pow := - repeat - (match goal with |- context [Rpow ?x (IZR (Z.pos ?n))] => - let nN := constr:(Z.abs_nat (Z.pos n)) in - let v := eval compute in nN in - replace (Rpow x (IZR (Z.pos n))) with (pow x v); - [ | rewrite (Rpow_convert_Z x (Z.pos n)); easy] - end). - -Ltac from_pow := - repeat - (match goal with |- context [pow ?x ?n] => - let nZ := constr:(Z.of_nat n) in - let v := eval compute in nZ in - replace (pow x n) with (Rpow x (IZR v)); - [ | rewrite (Rpow_convert_Z x v); easy] - end). - - -Add Field RField_w_Rpow : Rfield - (completeness Zeq_bool_IZR, morphism R_rm, constants [IZR_tac], - preprocess [to_pow], - postprocess [from_pow], power_tac R_power_theory [Rpow_tac]). - -Example test_ring n : Rpow (n + 1) 2 = 3 * n - n + 1 + Rpow n 2. -Proof. -ring_simplify. -easy. -Qed. - -Example test_field n (np1n0 : Rpow n 2 + 2 * n + 1 <> 0): 1 / (Rpow n 2 + 2 * n + 1) = -Rpow ((n + 1) / Rpow (n + 1) 2) 2. -Proof. -field_simplify. - easy. - assert (it : Rpow n 2 + 2 * n + 1 = Rpow (n + 1) 2) by ring. - rewrite it in np1n0; intros abs; case np1n0; rewrite abs; ring. -assumption. -Qed. - -Example test_field2 n (np1n0 : n + 1 <> 0) : 1 / (1 + 2 * n + Rpow n 2) = - Rpow ((n + 1) / Rpow (1 + n) 2) 2. -Proof. -assert (Rpown0: forall x k, x <> 0 -> Rpow x (IZR k) <> 0). - intros x k; rewrite Rpow_convert_Z. - now apply pow_nonzero. -assert (np12n0 : Rpow n 2 + 2 * n + 1 <> 0). - replace (Rpow n 2 + 2 * n + 1) with (Rpow (n + 1) 2) by ring. - now apply Rpown0. -assert (np14n0 : Rpow n 4 + 4 * Rpow n 3 + 6 * Rpow n 2 + 4 * n + 1 <> 0). - replace (Rpow n 4 + 4 * Rpow n 3 + 6 * Rpow n 2 + 4 * n + 1) with - (Rpow (n + 1) 4) by ring. - now apply Rpown0. -field_simplify (1 + 2 * n + Rpow n 2). -field_simplify ((n + 1) / Rpow (1 + n) 2). -field_simplify. -field_simplify_eq. -easy. -all: auto. -replace (1 + n) with (n + 1) by ring; auto. -Qed. diff --git a/stdlib/test-suite/success/apply.v b/stdlib/test-suite/success/apply.v deleted file mode 100644 index 8b25b2e7dd9c..000000000000 --- a/stdlib/test-suite/success/apply.v +++ /dev/null @@ -1,606 +0,0 @@ -(* Test apply in *) - -Goal (forall x y, x = S y -> y=y) -> 2 = 4 -> 3=3. -intros H H0. -apply H in H0. -assumption. -Qed. - -From Stdlib Require Import ZArith. -Goal (forall x y z, ~ z <= 0 -> x * z < y * z -> x <= y)%Z. -intros; apply Znot_le_gt, Z.gt_lt in H. -apply Zmult_lt_reg_r, Z.lt_le_incl in H0; auto. -Qed. - -(* Test application under tuples *) - -Goal (forall x, x=0 <-> 0=x) -> 1=0 -> 0=1. -intros H H'. -apply H in H'. -exact H'. -Qed. - -(* Test as clause *) - -Goal (forall x, x=0 <-> (0=x /\ True)) -> 1=0 -> True. -intros H H'. -apply H in H' as (_,H'). -exact H'. -Qed. - -(* Test application modulo conversion *) - -Goal (forall x, id x = 0 -> 0 = x) -> 1 = id 0 -> 0 = 1. -intros H H'. -apply H in H'. -exact H'. -Qed. - -(* Check apply/eapply distinction in presence of open terms *) - -Parameter h : forall x y z : nat, x = z -> x = y. -Arguments h {x y}. -Goal 1 = 0 -> True. -intro H. -apply h in H || exact I. -Qed. - -Goal False -> 1 = 0. -intro H. -apply h || contradiction. -Qed. - -(* Check if it unfolds when there are not enough premises *) - -Goal forall n, n = S n -> False. -intros. -apply n_Sn in H. -assumption. -Qed. - -(* Check naming in with bindings: do not rename *) - -Notation S':=S (only parsing). -Goal (forall S, S = S' S) -> (forall S, S = S' S). -intros. -apply H with (S := S). -Qed. - -(* Check inference of implicit arguments in bindings *) - -Goal exists y : nat -> Type, y 0 = y 0. -exists (fun x => True). -trivial. -Qed. - -(* Check universe handling in typed unificationn *) - -Definition E := Type. -Goal exists y : E, y = y. -exists Prop. -trivial. -Qed. - -Parameter Eq : Prop = (Prop -> Prop) :> E. -Goal Prop. -rewrite Eq. -Abort. - -(* Check insertion of coercions in bindings *) - -Coercion eq_true : bool >-> Sortclass. -Goal exists A:Prop, A = A. -exists true. -trivial. -Qed. - -(* Check use of unification of bindings types in specialize *) - -Module Type Test. -Parameter P : nat -> Prop. -Parameter L : forall (l : nat), P l -> P l. -Goal P 0 -> True. -intros. -specialize L with (1:=H). -Abort. -End Test. - -(* Two examples that show that hnf_constr is used when unifying types - of bindings (a simplification of a script from Field_Theory) *) - -From Stdlib Require Import List. -Open Scope list_scope. -Fixpoint P (l : list nat) : Prop := - match l with - | nil => True - | e1 :: nil => e1 = e1 - | e1 :: l1 => e1 = e1 /\ P l1 - end. -Parameter L : forall n l, P (n::l) -> P l. - -Goal forall (x:nat) l, P (x::l) -> P l. -intros. -apply L with (1:=H). -Qed. - -Goal forall (x:nat) l, match l with nil => x=x | _::_ => x=x /\ P l end -> P l. -intros. -apply L with (1:=H). -Qed. - -(* The following call to auto fails if the type of the clause - associated to the H is not beta-reduced [but apply H works] - (a simplification of a script from FSetAVL) *) - -Definition apply (f:nat->Prop) := forall x, f x. -Goal apply (fun n => n=0) -> 1=0. -intro H. -auto. -Qed. - -(* The following fails if the coercion Zpos is not introduced around p - before trying a subterm that matches the left-hand-side of the equality - (a simplication of an example taken from Nijmegen/QArith) *) - -From Stdlib Require Import ZArith. -Coercion Zpos : positive >-> Z. -Parameter f : Z -> Z -> Z. -Parameter g : forall q1 q2 p : Z, f (f q1 p) (f q2 p) = Z0. -Goal forall p q1 q2, f (f q1 (Zpos p)) (f q2 (Zpos p)) = Z0. -intros; rewrite g with (p:=p). -reflexivity. -Qed. - -(* A funny example where the behavior differs depending on which of a - multiple solution to a unification problem is chosen (an instance - of this case can be found in the proof of Buchberger.BuchRed.nf_divp) *) - -Definition succ x := S x. -Goal forall (I : nat -> Set) (P : nat -> Prop) (Q : forall n:nat, I n -> Prop), - (forall x y, P x -> Q x y) -> - (forall x, P (S x)) -> forall y: I (S 0), Q (succ 0) y. -intros. -apply H with (y:=y). -(* [x] had two possible instances: [S 0], coming from unifying the - type of [y] with [I ?n] and [succ 0] coming from the unification with - the goal; only the first one allows the next apply (which - does not work modulo delta) work *) -apply H0. -Qed. - -(* A similar example with a arbitrary long conversion between the two - possible instances *) - -Fixpoint compute_succ x := - match x with O => S 0 | S n => S (compute_succ n) end. - -Goal forall (I : nat -> Set) (P : nat -> Prop) (Q : forall n:nat, I n -> Prop), - (forall x y, P x -> Q x y) -> - (forall x, P (S x)) -> forall y: I (S 100), Q (compute_succ 100) y. -intros. -apply H with (y:=y). -apply H0. -Qed. - -(* Another example with multiple convertible solutions to the same - metavariable (extracted from Algebra.Hom_module.Hom_module, 10th - subgoal which precisely fails) *) - -Definition ID (A:Type) := A. -Goal forall f:Type -> Type, - forall (P : forall A:Type, A -> Prop), - (forall (B:Type) x, P (f B) x -> P (f B) x) -> - (forall (A:Type) x, P (f (f A)) x) -> - forall (A:Type) (x:f (f A)), P (f (ID (f A))) x. -intros. -apply H. -(* The parameter [B] had two possible instances: [ID (f A)] by direct - unification and [f A] by unification of the type of [x]; only the - first choice makes the next command fail, as it was - (unfortunately?) in Hom_module *) -try apply H. -unfold ID; apply H0. -Qed. - -(* Test hyp in "apply -> ... in hyp" is correctly instantiated by Ltac *) - -Goal (True <-> False) -> True -> False. -intros Heq H. -match goal with [ H : True |- _ ] => apply -> Heq in H end. -Abort. - -(* Test coercion below product and on non meta-free terms in with bindings *) -(* Cf wishes #1408 from E. Makarov *) - -Parameter bool_Prop :> bool -> Prop. -Parameter r : bool -> bool -> bool. -Axiom ax : forall (A : Set) (R : A -> A -> Prop) (x y : A), R x y. - -Theorem t : r true false. -apply ax with (R := r). -Qed. - -(* Check verification of type at unification (submitted by StĆ©phane Lengrand): - without verification, the first "apply" works what leads to the incorrect - instantiation of x by Prop *) - -Theorem u : ~(forall x:Prop, ~x). -unfold not. -intro. -eapply H. -apply (forall B:Prop,B->B) || (instantiate (1:=True); exact I). -Defined. - -(* Fine-tuning coercion insertion in presence of unfolding (bug #1883) *) - -Parameter name : Set. -Definition atom := name. - -Inductive exp : Set := - | var : atom -> exp. - -Coercion var : atom >-> exp. - -Axiom silly_axiom : forall v : exp, v = v -> False. - -Lemma silly_lemma : forall x : atom, False. -intros x. -apply silly_axiom with (v := x). (* fails *) -reflexivity. -Qed. - -(* Check that unification does not commit too early to a representative - of an eta-equivalence class that would be incompatible with other - unification constraints *) - -Lemma eta : forall f : (forall P, P 1), - (forall P, f P = f P) -> - forall Q, f (fun x => Q x) = f (fun x => Q x). -intros. -apply H. -Qed. - -(* Test propagation of evars from subgoal to brother subgoals *) - - (* This works because unfold calls clos_norm_flags which calls nf_evar *) - -Lemma eapply_evar_unfold : let x:=O in O=x -> 0=O. -intros x H; eapply eq_trans; -[apply H | unfold x;match goal with |- ?x = ?x => reflexivity end]. -Qed. - -(* Test non-regression of (temporary) bug 1981 *) - -Goal exists n : nat, True. -eapply ex_intro. -exact O. -trivial. -Qed. - -(* Check pattern-unification on evars in apply unification *) - -Lemma evar : exists f : nat -> nat, forall x, f x = 0 -> x = 0. -Proof. -eexists; intros x H. -apply H. -Qed. - -(* Check that "as" clause applies to main premise only and leave the - side conditions away *) - -Lemma side_condition : - forall (A:Type) (B:Prop) x, (True -> B -> x=0) -> B -> x=x. -Proof. -intros. -apply H in H0 as ->. -reflexivity. -exact I. -Qed. - -(* Check that "apply" is chained on the last subgoal of each lemma and - that side conditions come first (as it is the case since 8.2) *) - -Lemma chaining : - forall A B C : Prop, - (1=1 -> (2=2 -> A -> B) /\ True) -> - (3=3 -> (True /\ (4=4 -> C -> A))) -> C -> B. -Proof. -intros. -apply H, H0. -exact (refl_equal 1). -exact (refl_equal 2). -exact (refl_equal 3). -exact (refl_equal 4). -assumption. -Qed. - -(* Check that the side conditions of "apply in", even when chained and - used through conjunctions, come last (as it is the case for single - calls to "apply in" w/o destruction of conjunction since 8.2) *) - -Lemma chaining_in : - forall A B C : Prop, - (1=1 -> True /\ (B -> 2=2 -> 5=0)) -> - (3=3 -> (A -> 4=4 -> B) /\ True) -> A -> 0=5. -Proof. -intros. -apply H0, H in H1 as ->. -exact (refl_equal 0). -exact (refl_equal 1). -exact (refl_equal 2). -exact (refl_equal 3). -exact (refl_equal 4). -Qed. - -(* From 12612, Dec 2009, descent in conjunctions is more powerful *) -(* The following, which was failing badly in bug 1980, is now - properly rejected, as descend in conjunctions builds an - ill-formed elimination from Prop to the domain of ex which is in Type. *) - -Goal True. -Fail eapply ex_intro. -exact I. -Qed. - -Goal True. -Fail eapply (ex_intro _). -exact I. -Qed. - -(* No failure here, because the domain of ex is in Prop *) - -Goal True. -eapply (ex_intro (fun _ => 0=0) I). -reflexivity. -Qed. - -Goal True. -eapply (ex_intro (fun _ => 0=0) I _). -Unshelve. (* In 8.4: Grab Existential Variables. *) -reflexivity. -Qed. - -Goal True. -eapply (fun (A:Prop) (x:A) => conj I x). -Unshelve. (* In 8.4: the goal ?A was there *) -exact I. -Qed. - -(* The following was not accepted from r12612 to r12657 *) - -Record sig0 := { p1 : nat; p2 : p1 = 0 }. - -Goal forall x : sig0, p1 x = 0. -intro x; -apply x. -Qed. - -(* The following worked in 8.2 but was not accepted from r12229 to - r12926 because "simple apply" started to use pattern unification of - evars. Evars pattern unification for simple (e)apply was disabled - in 12927 but "simple eapply" below worked from 12898 to 12926 - because pattern-unification also started supporting abstraction - over Metas. However it did not find the "simple" solution and hence - the subsequent "assumption" failed. *) - -Goal exists f:nat->nat, forall x y, x = y -> f x = f y. -intros; eexists; intros. -simple eapply (@f_equal nat). -assumption. -Unshelve. -exact (fun x => x). -Qed. - -(* The following worked in 8.2 but was not accepted from r12229 to - r12897 for the same reason because eauto uses "simple apply". It - worked from 12898 to 12926 because eauto uses eassumption and not - assumption. *) - -Goal exists f:nat->nat, forall x y, x = y -> f x = f y. -intros; eexists; intros. -eauto. -Unshelve. -exact (fun x => x). -Qed. - -(* The following was accepted before r12612 but is still not accepted in r12658 - -Goal forall x : { x:nat | x = 0}, proj1_sig x = 0. -intro x; -apply x. - -*) - -Section A. - -Variable map : forall (T1 T2 : Type) (f : T1 -> T2) (t11 t12 : T1), - identity (f t11) (f t12). - -Variable mapfuncomp : forall (X Y Z : Type) (f : X -> Y) (g : Y -> Z) (x x' : X), - identity (map Y Z g (f x) (f x')) (map X Z (fun x0 : X => g (f x0)) x x'). - -Goal forall X:Type, forall Y:Type, forall f:X->Y, forall x : X, forall x' : X, - forall g : Y -> X, - let gf := (fun x : X => g (f x)) : X -> X in - identity (map Y X g (f x) (f x')) (map X X gf x x'). -intros. -apply mapfuncomp. -Abort. - -End A. - -(* Check "with" clauses refer to names as they are printed *) - -Definition hide p := forall n:nat, p = n. - -Goal forall n, (forall n, n=0) -> hide n -> n=0. -unfold hide. -intros n H H'. -(* H is displayed as (forall n, n=0) *) -apply H with (n:=n). -Undo. -(* H' is displayed as (forall n0, n=n0) *) -apply H' with (n:=0). -Qed. - -(* Check that evars originally present in goal do not prevent apply in to work*) - -Goal (forall x, x <= 0 -> x = 0) -> exists x, x <= 0 -> 0 = 0. -intros. -eexists. -intros. -apply H in H0. -Abort. - -(* Check correct failure of apply in when hypothesis is dependent *) - -Goal forall H:0=0, H = H. -intros. -Fail apply eq_sym in H. -Abort. - -(* Check that unresolved evars not originally present in goal prevent - apply in to work*) - -Goal (forall x y, x <= 0 -> x + y = 0) -> exists x, x <= 0 -> 0 = 0. -intros. -eexists. -intros. -Fail apply H in H0. -Abort. - -(* Check naming pattern in apply in *) - -Goal ((False /\ (True -> True))) -> True -> True. -intros F H. -apply F in H as H0. (* Check that H0 is not used internally *) -exact H0. -Qed. - -Goal ((False /\ (True -> True/\True))) -> True -> True/\True. -intros F H. -apply F in H as (?,?). -split. -exact H. (* Check that generated names are H and H0 *) -exact H0. -Qed. - -(* This failed at some time in between 18 August 2014 and 2 September 2014 *) - -Goal forall A B C: Prop, (True -> A -> B /\ C) -> A -> B. -intros * H. -apply H. -Abort. - -(* This failed between 2 and 3 September 2014 *) - -Goal forall A B C D:Prop, (A<->B)/\(C<->D) -> A -> B. -intros. -apply H in H0. -pose proof I as H1. (* Test that H1 does not exist *) -Abort. - -Goal forall A B C D:Prop, (A<->B)/\(C<->D) -> A. -intros. -apply H. -pose proof I as H0. (* Test that H0 does not exist *) -Abort. - -(* The first example below failed at some time in between 18 August - 2014 and 2 September 2014 *) - -Goal forall x, 2=0 -> x+1=2 -> (forall x, S x = 0) -> True. -intros x H H0 H1. -eapply eq_trans in H. 2:apply H0. -rewrite H1 in H. -change (x+0=0) in H. (* Check the result in H1 *) -Abort. - -Goal forall x, 2=x+1 -> (forall x, S x = 0) -> 2 = 0. -intros x H H0. -eapply eq_trans. apply H. -rewrite H0. -change (x+0=0). -Abort. - -Goal (forall x y, x <= y -> y + x = 0 /\ True) -> exists x y, (x <= 0 -> y <= 1 -> 0 = 0 /\ 1 = 0). -intros. -do 2 eexists. -intros. -eapply H in H0 as (H0,_), H1 as (H1,_). -split. -- exact H0. -- exact H1. -Qed. - -(* 2nd order apply used to have delta on local definitions even though - it does not have delta on global definitions; keep it by - compatibility while finding a more uniform way to proceed. *) - -Goal forall f:nat->nat, (forall P x, P (f x)) -> let x:=f 0 in x = 0. -intros f H x. -apply H. -Qed. - -(* Test that occur-check is not too restrictive (see comments of #3141) *) -Lemma bar (X: nat -> nat -> Prop) (foo:forall x, X x x) (a: unit) (H: tt = a): - exists x, exists y, X x y. -Proof. -intros; eexists; eexists ?[y]; case H. -apply (foo ?y). -Unshelve. -exact 0. -Qed. - -(* Test position of new hypotheses when using "apply ... in ... as ..." *) -Goal (True -> 0=0 /\ True) -> True -> False -> True/\0=0. -intros H H0 H1. -apply H in H0 as (a,b). -(* clear H1:False *) match goal with H:_ |- _ => clear H end. -split. -- (* use b:True *) match goal with H:_ |- _ => exact H end. -- (* clear b:True *) match goal with H:_ |- _ => clear H end. - (* use a:0=0 *) match goal with H:_ |- _ => exact H end. -Qed. - -(* Test choice of most dependent solution *) -Goal forall n, n = 0 -> exists p, p = n /\ p = 0. -intros. eexists ?[p]. split. rewrite H. -reflexivity. (* Compatibility tells [?p:=n] rather than [?p:=0] *) -exact H. (* this checks that the goal is [n=0], not [0=0] *) -Qed. - -(* Check insensitivity to alphabetic order of names*) -(* In both cases, the last name is conventionally chosen *) -(* Before 8.9, the name coming first in alphabetic order *) -(* was chosen. *) -Goal forall m n, m = n -> n = 0 -> exists p, p = n /\ p = 0. -intros. eexists ?[p]. split. rewrite H. -reflexivity. -exact H0. -Qed. - -Goal forall n m, n = m -> m = 0 -> exists p, p = m /\ p = 0. -intros. eexists ?[p]. split. rewrite H. -reflexivity. -exact H0. -Qed. - -(* apply and side conditions: we check that apply in iterates only on - the main subgoals *) - -Goal (forall x, x=0 -> x>=0 -> x<=0 \/ x<=1) -> 0>=0 -> 1>=0 -> 1=0 -> True. -intros f H H0 H1. -apply f in H as [], H0 as []. -1-3: change (0 <= 0) in H. -4-6: change (0 <= 1) in H. -1: change (1 <= 0) in H0. -4: change (1 <= 0) in H0. -2: change (1 <= 1) in H0. -5: change (1 <= 1) in H0. -1-2,4-5: exact I. -1,2: exact H1. -change (0 >= 0) in H. -change (1 >= 0) in H0. -exact (eq_refl 0). -Qed. diff --git a/stdlib/test-suite/success/btauto.v b/stdlib/test-suite/success/btauto.v deleted file mode 100644 index 7f21a91318b4..000000000000 --- a/stdlib/test-suite/success/btauto.v +++ /dev/null @@ -1,9 +0,0 @@ -From Stdlib Require Import Btauto. - -Open Scope bool_scope. - -Lemma test_orb a b : (if a || b then negb (negb b && negb a) else negb a && negb b) = true. -Proof. btauto. Qed. - -Lemma test_xorb a : xorb a a = false. -Proof. btauto. Qed. diff --git a/stdlib/test-suite/success/conv_pbs.v b/stdlib/test-suite/success/conv_pbs.v deleted file mode 100644 index f24b25635a86..000000000000 --- a/stdlib/test-suite/success/conv_pbs.v +++ /dev/null @@ -1,228 +0,0 @@ -(* A bit complex but realistic example whose last fixpoint definition - used to fail in 8.1 because of wrong environment in conversion - problems (see revision 9664) *) - -From Stdlib Require Import List. -From Stdlib Require Import Arith. - -Parameter predicate : Set. -Parameter function : Set. -Definition variable := nat. -Definition x0 := 0. -Definition var_eq_dec := eq_nat_dec. - -Inductive term : Set := - | App : function -> term -> term - | Var : variable -> term. - -Definition atom := (predicate * term)%type. - -Inductive formula : Set := - | Atom : atom -> formula - | Imply : formula -> formula -> formula - | Forall : variable -> formula -> formula. - -Notation "A --> B" := (Imply A B) (at level 40). - -Definition substitution range := list (variable * range). - -Fixpoint remove_assoc (A:Set)(x:variable)(rho: substitution A){struct rho} - : substitution A := - match rho with - | nil => rho - | (y,t) :: rho => if var_eq_dec x y then remove_assoc A x rho - else (y,t) :: remove_assoc A x rho - end. - -Fixpoint assoc (A:Set)(x:variable)(rho:substitution A){struct rho} - : option A := - match rho with - | nil => None - | (y,t) :: rho => if var_eq_dec x y then Some t - else assoc A x rho - end. - -Fixpoint subst_term (rho:substitution term)(t:term){struct t} : term := - match t with - | Var x => match assoc _ x rho with - | Some a => a - | None => Var x - end - | App f t' => App f (subst_term rho t') - end. - -Fixpoint subst_formula (rho:substitution term)(A:formula){struct A}:formula := - match A with - | Atom (p,t) => Atom (p, subst_term rho t) - | A --> B => subst_formula rho A --> subst_formula rho B - | Forall y A => Forall y (subst_formula (remove_assoc _ y rho) A) - (* assume t closed *) - end. - -Definition subst A x t := subst_formula ((x,t):: nil) A. - -Record Kripke : Type := { - worlds: Set; - wle : worlds -> worlds -> Type; - wle_refl : forall w, wle w w ; - wle_trans : forall w w' w'', wle w w' -> wle w' w'' -> wle w w''; - domain : Set; - vars : variable -> domain; - funs : function -> domain -> domain; - atoms : worlds -> predicate * domain -> Type; - atoms_mon : forall w w', wle w w' -> forall P, atoms w P -> atoms w' P -}. - -Section Sem. - -Variable K : Kripke. - -Fixpoint sem (rho: substitution (domain K))(t:term){struct t} : domain K := - match t with - | Var x => match assoc _ x rho with - | Some a => a - | None => vars K x - end - | App f t' => funs K f (sem rho t') - end. - -End Sem. - -Notation "w <= w'" := (wle _ w w'). - -Set Implicit Arguments. - -Reserved Notation "w ||- A" (at level 70). - -Definition context := list formula. - -Parameter fresh : variable -> context -> Prop. - -Parameter fresh_out : context -> variable. - -Axiom fresh_out_spec : forall Gamma, fresh (fresh_out Gamma) Gamma. - -Axiom fresh_peel : forall x A Gamma, fresh x (A::Gamma) -> fresh x Gamma. - -Fixpoint force (K:Kripke)(rho: substitution (domain K))(w:worlds K)(A:formula) - {struct A} : Type := - match A with - | Atom (p,t) => atoms K w (p, sem K rho t) - | A --> B => forall w', w <= w' -> force K rho w' A -> force K rho w' B - | Forall x A => forall w', w <= w' -> forall t, force K ((x,t)::remove_assoc _ x rho) w' A - end. - -Notation "w ||- A" := (force _ nil w A). - -Reserved Notation "Gamma |- A" (at level 70). -Reserved Notation "Gamma ; A |- C" (at level 70, A at next level). - -Inductive context_prefix (Gamma:context) : context -> Type := - | CtxPrefixRefl : context_prefix Gamma Gamma - | CtxPrefixTrans : forall A Gamma', context_prefix Gamma Gamma' -> context_prefix Gamma (cons A Gamma'). - -Inductive in_context (A:formula) : list formula -> Prop := - | InAxiom : forall Gamma, in_context A (cons A Gamma) - | OmWeak : forall Gamma B, in_context A Gamma -> in_context A (cons B Gamma). - -Inductive prove : list formula -> formula -> Type := - | ProofImplyR : forall A B Gamma, prove (cons A Gamma) B - -> prove Gamma (A --> B) - | ProofForallR : forall x A Gamma, (forall y, fresh y (A::Gamma) - -> prove Gamma (subst A x (Var y))) -> prove Gamma (Forall x A) - | ProofCont : forall A Gamma Gamma' C, context_prefix (A::Gamma) Gamma' - -> (prove_stoup Gamma' A C) -> (Gamma' |- C) - -where "Gamma |- A" := (prove Gamma A) - - with prove_stoup : list formula -> formula -> formula -> Type := - | ProofAxiom Gamma C: Gamma ; C |- C - | ProofImplyL Gamma C : forall A B, (Gamma |- A) - -> (prove_stoup Gamma B C) -> (prove_stoup Gamma (A --> B) C) - | ProofForallL Gamma C : forall x t A, (prove_stoup Gamma (subst A x t) C) - -> (prove_stoup Gamma (Forall x A) C) - -where " Gamma ; B |- A " := (prove_stoup Gamma B A). - -Axiom context_prefix_trans : - forall Gamma Gamma' Gamma'', - context_prefix Gamma Gamma' - -> context_prefix Gamma' Gamma'' - -> context_prefix Gamma Gamma''. - -Axiom Weakening : - forall Gamma Gamma' A, - context_prefix Gamma Gamma' -> Gamma |- A -> Gamma' |- A. - -Axiom universal_weakening : - forall Gamma Gamma', context_prefix Gamma Gamma' - -> forall P, Gamma |- Atom P -> Gamma' |- Atom P. - -Canonical Structure Universal := Build_Kripke - context - context_prefix - CtxPrefixRefl - context_prefix_trans - term - Var - App - (fun Gamma P => Gamma |- Atom P) - universal_weakening. - -Axiom subst_commute : - forall A rho x t, - subst_formula ((x,t)::rho) A = subst (subst_formula rho A) x t. - -Axiom subst_formula_atom : - forall rho p t, - Atom (p, sem _ rho t) = subst_formula rho (Atom (p,t)). - -Fixpoint universal_completeness (Gamma:context)(A:formula){struct A} - : forall rho:substitution term, - force _ rho Gamma A -> Gamma |- subst_formula rho A - := - match A - return forall rho, force _ rho Gamma A - -> Gamma |- subst_formula rho A - with - | Atom (p,t) => fun rho H => eq_rect _ (fun A => Gamma |- A) H _ (subst_formula_atom rho p t) - | A --> B => fun rho HImplyAB => - let A' := subst_formula rho A in - ProofImplyR (universal_completeness (A'::Gamma) B rho - (HImplyAB (A'::Gamma)(CtxPrefixTrans A' (CtxPrefixRefl Gamma)) - (universal_completeness_stoup A rho (fun C Gamma' Hle p - => ProofCont Hle p)))) - | Forall x A => fun rho HForallA - => ProofForallR x (fun y Hfresh - => eq_rect _ _ (universal_completeness Gamma A _ - (HForallA Gamma (CtxPrefixRefl Gamma)(Var y))) _ (subst_commute _ _ _ _ )) - end -with universal_completeness_stoup (Gamma:context)(A:formula){struct A} - : forall rho, (forall C Gamma', context_prefix Gamma Gamma' - -> Gamma' ; subst_formula rho A |- C -> Gamma' |- C) - -> force _ rho Gamma A - := - match A return forall rho, - (forall C Gamma', context_prefix Gamma Gamma' - -> Gamma' ; subst_formula rho A |- C - -> Gamma' |- C) - -> force _ rho Gamma A - with - | Atom (p,t) as C => fun rho H - => H _ Gamma (CtxPrefixRefl Gamma)(ProofAxiom _ _) - | A --> B => fun rho H => fun Gamma' Hle HA - => universal_completeness_stoup B rho (fun C Gamma'' Hle' p - => H C Gamma'' (context_prefix_trans Hle Hle') - (ProofImplyL (Weakening Hle' (universal_completeness Gamma' A rho HA)) p)) - | Forall x A => fun rho H => fun Gamma' Hle t - => (universal_completeness_stoup A ((x,t)::remove_assoc _ x rho) - (fun C Gamma'' Hle' p => - H C Gamma'' (context_prefix_trans Hle Hle') - (ProofForallL x t (subst_formula (remove_assoc _ x rho) A) - (eq_rect _ (fun D => Gamma'' ; D |- C) p _ (subst_commute _ _ _ _))))) - end. - - -(* A simple example that raised an uncaught exception at some point *) - -Fail Check fun x => @eq_refl x <: true = true. diff --git a/stdlib/test-suite/success/dependentind.v b/stdlib/test-suite/success/dependentind.v deleted file mode 100644 index 50490e6b45f0..000000000000 --- a/stdlib/test-suite/success/dependentind.v +++ /dev/null @@ -1,162 +0,0 @@ -From Stdlib Require Import Program Equality. - -Goal forall (H: forall n m : nat, n = m -> n = 0) x, x = tt. -intros. -dependent destruction x. -reflexivity. -Qed. - -Parameter A : Set. - -Inductive vector : nat -> Type := vnil : vector 0 | vcons : A -> forall {n}, vector n -> vector (S n). - -Goal forall n, forall v : vector (S n), vector n. -Proof. - intros n H. - dependent destruction H. - assumption. -Qed. - -From Stdlib Require Import ProofIrrelevance. - -Goal forall n, forall v : vector (S n), exists v' : vector n, exists a : A, v = vcons a v'. -Proof. - intros n v. - dependent destruction v. - exists v ; exists a. - reflexivity. -Qed. - -(* Extraction Unnamed_thm. *) - -Inductive type : Type := -| base : type -| arrow : type -> type -> type. - -Notation " t --> t' " := (arrow t t') (at level 20, t' at next level). - -Inductive ctx : Type := -| empty : ctx -| snoc : ctx -> type -> ctx. - -Bind Scope context_scope with ctx. -Delimit Scope context_scope with ctx. - -Arguments snoc _%_context_scope. - -Notation " Ī“ , Ļ„ " := (snoc Ī“ Ļ„) (at level 25, Ļ„ at next level, left associativity) : context_scope. - -Fixpoint conc (Ī” Ī“ : ctx) : ctx := - match Ī” with - | empty => Ī“ - | snoc Ī”' x => snoc (conc Ī”' Ī“) x - end. - -Notation " Ī“ ; Ī” " := (conc Ī” Ī“) (at level 25, left associativity) : context_scope. - -Reserved Notation " Ī“ āŠ¢ Ļ„ " (at level 30, no associativity). - -Generalizable All Variables. - -Inductive term : ctx -> type -> Type := -| ax : `(Ī“, Ļ„ āŠ¢ Ļ„) -| weak : `{Ī“ āŠ¢ Ļ„ -> Ī“, Ļ„' āŠ¢ Ļ„} -| abs : `{Ī“, Ļ„ āŠ¢ Ļ„' -> Ī“ āŠ¢ Ļ„ --> Ļ„'} -| app : `{Ī“ āŠ¢ Ļ„ --> Ļ„' -> Ī“ āŠ¢ Ļ„ -> Ī“ āŠ¢ Ļ„'} - -where " Ī“ āŠ¢ Ļ„ " := (term Ī“ Ļ„) : type_scope. - -#[export] Hint Constructors term : lambda. - -Local Open Scope context_scope. - -Ltac eqns := subst ; reverse ; simplify_dep_elim ; simplify_IH_hyps. - -Lemma weakening : forall Ī“ Ī” Ļ„, Ī“ ; Ī” āŠ¢ Ļ„ -> - forall Ļ„', Ī“ , Ļ„' ; Ī” āŠ¢ Ļ„. -Proof with simpl in * ; eqns ; eauto with lambda. - intros Ī“ Ī” Ļ„ H. - - dependent induction H. - - destruct Ī” as [|Ī” Ļ„'']... - - destruct Ī” as [|Ī” Ļ„'']... - - destruct Ī” as [|Ī” Ļ„'']... - apply abs. - specialize (IHterm Ī“ (Ī”, Ļ„'', Ļ„))... - - intro. eapply app... -Defined. - -Lemma weakening_ctx : forall Ī“ Ī” Ļ„, Ī“ ; Ī” āŠ¢ Ļ„ -> - forall Ī”', Ī“ ; Ī”' ; Ī” āŠ¢ Ļ„. -Proof with simpl in * ; eqns ; eauto with lambda. - intros Ī“ Ī” Ļ„ H. - - dependent induction H. - - destruct Ī” as [|Ī” Ļ„'']... - induction Ī”'... - - destruct Ī” as [|Ī” Ļ„'']... - induction Ī”'... - - destruct Ī” as [|Ī” Ļ„'']... - apply abs. - specialize (IHterm Ī“ (empty, Ļ„))... - - apply abs. - specialize (IHterm Ī“ (Ī”, Ļ„'', Ļ„))... - - intro. eapply app... -Defined. - -Lemma exchange : forall Ī“ Ī” Ī± Ī² Ļ„, term (Ī“, Ī±, Ī² ; Ī”) Ļ„ -> term (Ī“, Ī², Ī± ; Ī”) Ļ„. -Proof with simpl in * ; eqns ; eauto. - intros until 1. - dependent induction H. - - destruct Ī” ; eqns. - apply weak ; apply ax. - - apply ax. - - destruct Ī”... - pose (weakening Ī“ (empty, Ī±))... - - apply weak... - - apply abs... - specialize (IHterm Ī“ (Ī”, Ļ„))... - - eapply app... -Defined. - - - -(** Example by Andrew Kenedy, uses simplification of the first component of dependent pairs. *) - -Set Implicit Arguments. - -Inductive Ty := - | Nat : Ty - | Prod : Ty -> Ty -> Ty. - -Inductive Exp : Ty -> Type := -| Const : nat -> Exp Nat -| Pair : forall t1 t2, Exp t1 -> Exp t2 -> Exp (Prod t1 t2) -| Fst : forall t1 t2, Exp (Prod t1 t2) -> Exp t1. - -Inductive Ev : forall t, Exp t -> Exp t -> Prop := -| EvConst : forall n, Ev (Const n) (Const n) -| EvPair : forall t1 t2 (e1:Exp t1) (e2:Exp t2) e1' e2', - Ev e1 e1' -> Ev e2 e2' -> Ev (Pair e1 e2) (Pair e1' e2') -| EvFst : forall t1 t2 (e:Exp (Prod t1 t2)) e1 e2, - Ev e (Pair e1 e2) -> - Ev (Fst e) e1. - -Lemma EvFst_inversion : forall t1 t2 (e:Exp (Prod t1 t2)) e1, Ev (Fst e) e1 -> exists e2, Ev e (Pair e1 e2). -intros t1 t2 e e1 ev. dependent destruction ev. exists e2 ; assumption. -Qed. diff --git a/stdlib/test-suite/success/extraction.v b/stdlib/test-suite/success/extraction.v deleted file mode 100644 index 9fb8b15ed765..000000000000 --- a/stdlib/test-suite/success/extraction.v +++ /dev/null @@ -1,687 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* nat) (x:nat) := f x. -Extraction test2. -(* let test2 f x = f x *) - -Definition test3 (f:nat -> Set -> nat) (x:nat) := f x nat. -Extraction test3. -(* let test3 f x = f x __ *) - -Definition test4 (f:(nat -> nat) -> nat) (x:nat) (g:nat -> nat) := f g. -Extraction test4. -(* let test4 f x g = f g *) - -Definition test5 := (1, 0). -Extraction test5. -(* let test5 = Pair ((S O), O) *) - -Definition cf (x:nat) (_:x <= 0) := S x. -Extraction NoInline cf. -Definition test6 := cf 0 (le_n 0). -Extraction test6. -(* let test6 = cf O *) - -Definition test7 := (fun (X:Set) (x:X) => x) nat. -Extraction test7. -(* let test7 x = x *) - -Definition d (X:Type) := X. -Extraction d. (* type 'x d = 'x *) -Definition d2 := d Set. -Extraction d2. (* type d2 = __ d *) -Definition d3 (x:d Set) := 0. -Extraction d3. (* let d3 _ = O *) -Definition d4 := d nat. -Extraction d4. (* type d4 = nat d *) -Definition d5 := (fun x:d Type => 0) Type. -Extraction d5. (* let d5 = O *) -Definition d6 (x:d Type) := x. -Extraction d6. (* type 'x d6 = 'x *) - -Definition test8 := (fun (X:Type) (x:X) => x) Set nat. -Extraction test8. (* type test8 = nat *) - -Definition test9 := let t := nat in id Set t. -Extraction test9. (* type test9 = nat *) - -Definition test10 := (fun (X:Type) (x:X) => 0) Type Type. -Extraction test10. (* let test10 = O *) - -Definition test11 := let n := 0 in let p := S n in S p. -Extraction test11. (* let test11 = S (S O) *) - -Definition test12 := forall x:forall X:Type, X -> X, x Type Type. -Extraction test12. -(* type test12 = (__ -> __ -> __) -> __ *) - - -Definition test13 := match @left True True I with - | left x => 1 - | right x => 0 - end. -Extraction test13. (* let test13 = S O *) - - -(** example with more arguments that given by the type *) - -Definition test19 := - nat_rec (fun n:nat => nat -> nat) (fun n:nat => 0) - (fun (n:nat) (f:nat -> nat) => f) 0 0. -Extraction test19. -(* let test19 = - let rec f = function - | O -> (fun n0 -> O) - | S n0 -> f n0 - in f O O -*) - - -(** casts *) - -Definition test20 := True:Type. -Extraction test20. -(* type test20 = __ *) - - -(** Simple inductive type and recursor. *) - -Extraction nat. -(* -type nat = - | O - | S of nat -*) - -Extraction sumbool_rect. -(* -let sumbool_rect f f0 = function - | Left -> f __ - | Right -> f0 __ -*) - -(** Less simple inductive type. *) - -Inductive c (x:nat) : nat -> Set := - | refl : c x x - | trans : forall y z:nat, c x y -> y <= z -> c x z. -Extraction c. -(* -type c = - | Refl - | Trans of nat * nat * c -*) - -Definition Ensemble (U:Type) := U -> Prop. -Definition Empty_set (U:Type) (x:U) := False. -Definition Add (U:Type) (A:Ensemble U) (x y:U) := A y \/ x = y. - -Inductive Finite (U:Type) : Ensemble U -> Type := - | Empty_is_finite : Finite U (Empty_set U) - | Union_is_finite : - forall A:Ensemble U, - Finite U A -> forall x:U, ~ A x -> Finite U (Add U A x). -Extraction Finite. -(* -type 'u finite = - | Empty_is_finite - | Union_is_finite of 'u finite * 'u -*) - - -(** Mutual Inductive *) - -Inductive tree : Set := - Node : nat -> forest -> tree -with forest : Set := - | Leaf : nat -> forest - | Cons : tree -> forest -> forest. - -Extraction tree. -(* -type tree = - | Node of nat * forest -and forest = - | Leaf of nat - | Cons of tree * forest -*) - -Fixpoint tree_size (t:tree) : nat := - match t with - | Node a f => S (forest_size f) - end - - with forest_size (f:forest) : nat := - match f with - | Leaf b => 1 - | Cons t f' => tree_size t + forest_size f' - end. - -Extraction tree_size. -(* -let rec tree_size = function - | Node (a, f) -> S (forest_size f) -and forest_size = function - | Leaf b -> S O - | Cons (t, f') -> plus (tree_size t) (forest_size f') -*) - - -(** Eta-expansions of inductive constructor *) - -Inductive titi : Set := - tata : nat -> nat -> nat -> nat -> titi. -Definition test14 := tata 0. -Extraction test14. -(* let test14 x x0 x1 = Tata (O, x, x0, x1) *) -Definition test15 := tata 0 1. -Extraction test15. -(* let test15 x x0 = Tata (O, (S O), x, x0) *) - -Inductive eta : Type := - eta_c : nat -> Prop -> nat -> Prop -> eta. -Extraction eta_c. -(* -type eta = - | Eta_c of nat * nat -*) -Definition test16 := eta_c 0. -Extraction test16. -(* let test16 x = Eta_c (O, x) *) -Definition test17 := eta_c 0 True. -Extraction test17. -(* let test17 x = Eta_c (O, x) *) -Definition test18 := eta_c 0 True 0. -Extraction test18. -(* let test18 _ = Eta_c (O, O) *) - - -(** Example of singleton inductive type *) - -Inductive bidon (A:Prop) (B:Type) : Type := - tb : forall (x:A) (y:B), bidon A B. -Definition fbidon (A B:Type) (f:A -> B -> bidon True nat) - (x:A) (y:B) := f x y. -Extraction bidon. -(* type 'b bidon = 'b *) -Extraction tb. -(* tb : singleton inductive constructor *) -Extraction fbidon. -(* let fbidon f x y = - f x y -*) - -Definition fbidon2 := fbidon True nat (tb True nat). -Extraction fbidon2. (* let fbidon2 y = y *) -Extraction NoInline fbidon. -Extraction fbidon2. -(* let fbidon2 y = fbidon (fun _ x -> x) __ y *) - -(* NB: first argument of fbidon2 has type [True], so it disappears. *) - -(** mutual inductive on many sorts *) - -Inductive test_0 : Prop := - ctest0 : test_0 -with test_1 : Set := - ctest1 : test_0 -> test_1. -Extraction test_0. -(* test0 : logical inductive *) -Extraction test_1. -(* -type test1 = - | Ctest1 -*) - -(** logical singleton *) - -Extraction eq. -(* eq : logical inductive *) -Extraction eq_rect. -(* let eq_rect x f y = - f -*) - -(** No more propagation of type parameters. Obj.t instead. *) - -Inductive tp1 : Type := - T : forall (C:Set) (c:C), tp2 -> tp1 -with tp2 : Type := - T' : tp1 -> tp2. -Extraction tp1. -(* -type tp1 = - | T of __ * tp2 -and tp2 = - | T' of tp1 -*) - -Inductive tp1bis : Type := - Tbis : tp2bis -> tp1bis -with tp2bis : Type := - T'bis : forall (C:Set) (c:C), tp1bis -> tp2bis. -Extraction tp1bis. -(* -type tp1bis = - | Tbis of tp2bis -and tp2bis = - | T'bis of __ * tp1bis -*) - - -(** Strange inductive type. *) - -Inductive Truc : Set -> Type := - | chose : forall A:Set, Truc A - | machin : forall A:Set, A -> Truc bool -> Truc A. -Extraction Truc. -(* -type 'x truc = - | Chose - | Machin of 'x * bool truc -*) - - -(** Dependant type over Type *) - -Definition test24 := sigT (fun a:Set => option a). -Extraction test24. -(* type test24 = (__, __ option) sigT *) - - -(** Coq term non strongly-normalizable after extraction *) - -Definition loop (Ax:Acc gt 0) := - (fix F (a:nat) (b:Acc gt a) {struct b} : nat := - F (S a) (Acc_inv b (S a) (Nat.lt_succ_diag_r a))) 0 Ax. -Extraction loop. -(* let loop _ = - let rec f a = - f (S a) - in f O -*) - -(*** EXAMPLES NEEDING OBJ.MAGIC *) - -(** False conversion of type: *) - -Lemma oups : forall H:nat = list nat, nat -> nat. -intros. -generalize H0; intros. -rewrite H in H1. -case H1. -exact H0. -intros. -exact n. -Defined. -Extraction oups. -(* -let oups h0 = - match Obj.magic h0 with - | Nil -> h0 - | Cons0 (n, l) -> n -*) - - -(** hybrids *) - -Definition horibilis (b:bool) := - if b as b return (if b then Type else nat) then Set else 0. -Extraction horibilis. -(* -let horibilis = function - | True -> Obj.magic __ - | False -> Obj.magic O -*) - -Definition PropSet (b:bool) := if b then Prop else Set. -Extraction PropSet. (* type propSet = __ *) - -Definition natbool (b:bool) := if b then nat else bool. -Extraction natbool. (* type natbool = __ *) - -Definition zerotrue (b:bool) := if b as x return natbool x then 0 else true. -Extraction zerotrue. -(* -let zerotrue = function - | True -> Obj.magic O - | False -> Obj.magic True -*) - -Definition natProp (b:bool) := if b return Type then nat else Prop. - -Definition natTrue (b:bool) := if b return Type then nat else True. - -Definition zeroTrue (b:bool) := if b as x return natProp x then 0 else True. -Extraction zeroTrue. -(* -let zeroTrue = function - | True -> Obj.magic O - | False -> Obj.magic __ -*) - -Definition natTrue2 (b:bool) := if b return Type then nat else True. - -Definition zeroprop (b:bool) := if b as x return natTrue x then 0 else I. -Extraction zeroprop. -(* -let zeroprop = function - | True -> Obj.magic O - | False -> Obj.magic __ -*) - -(** polymorphic f applied several times *) - -Definition test21 := (id nat 0, id bool true). -Extraction test21. -(* let test21 = Pair ((id O), (id True)) *) - -(** ok *) - -Definition test22 := - (fun f:forall X:Type, X -> X => (f nat 0, f bool true)) - (fun (X:Type) (x:X) => x). -Extraction test22. -(* let test22 = - let f = fun x -> x in Pair ((f O), (f True)) *) - -(* still ok via optim beta -> let *) - -Definition test23 (f:forall X:Type, X -> X) := (f nat 0, f bool true). -Extraction test23. -(* let test23 f = Pair ((Obj.magic f __ O), (Obj.magic f __ True)) *) - -(* problem: fun f -> (f 0, f true) not legal in ocaml *) -(* solution: magic ... *) - - -(** Dummy constant __ can be applied.... *) - -Definition f (X:Type) (x:nat -> X) (y:X -> bool) : bool := y (x 0). -Extraction f. -(* let f x y = - y (x O) -*) - -Definition f_prop := f (0 = 0) (fun _ => refl_equal 0) (fun _ => true). -Extraction NoInline f. -Extraction f_prop. -(* let f_prop = - f (Obj.magic __) (fun _ -> True) -*) - -Definition f_arity := f Set (fun _:nat => nat) (fun _:Set => true). -Extraction f_arity. -(* let f_arity = - f (Obj.magic __) (fun _ -> True) -*) - -Definition f_normal := - f nat (fun x => x) (fun x => match x with - | O => true - | _ => false - end). -Extraction f_normal. -(* let f_normal = - f (fun x -> x) (fun x -> match x with - | O -> True - | S n -> False) -*) - - -(* inductive with magic needed *) - -Inductive Boite : Set := - boite : forall b:bool, (if b then nat else (nat * nat)%type) -> Boite. -Extraction Boite. -(* -type boite = - | Boite of bool * __ -*) - - -Definition boite1 := boite true 0. -Extraction boite1. -(* let boite1 = Boite (True, (Obj.magic O)) *) - -Definition boite2 := boite false (0, 0). -Extraction boite2. -(* let boite2 = Boite (False, (Obj.magic (Pair (O, O)))) *) - -Definition test_boite (B:Boite) := - match B return nat with - | boite true n => n - | boite false n => fst n + snd n - end. -Extraction test_boite. -(* -let test_boite = function - | Boite (b0, n) -> - (match b0 with - | True -> Obj.magic n - | False -> plus (fst (Obj.magic n)) (snd (Obj.magic n))) -*) - -(* singleton inductive with magic needed *) - -Inductive Box : Type := - box : forall A:Set, A -> Box. -Extraction Box. -(* type box = __ *) - -Definition box1 := box nat 0. -Extraction box1. (* let box1 = Obj.magic O *) - -(* applied constant, magic needed *) - -Definition idzarb (b:bool) (x:if b then nat else bool) := x. -Definition zarb := idzarb true 0. -Extraction NoInline idzarb. -Extraction zarb. -(* let zarb = Obj.magic idzarb True (Obj.magic O) *) - -(** function of variable arity. *) -(** Fun n = nat -> nat -> ... -> nat *) - -Fixpoint Fun (n:nat) : Set := - match n with - | O => nat - | S n => nat -> Fun n - end. - -Fixpoint Const (k n:nat) {struct n} : Fun n := - match n as x return Fun x with - | O => k - | S n => fun p:nat => Const k n - end. - -Fixpoint proj (k n:nat) {struct n} : Fun n := - match n as x return Fun x with - | O => 0 (* ou assert false ....*) - | S n => - match k with - | O => fun x => Const x n - | S k => fun x => proj k n - end - end. - -Definition test_proj := proj 2 4 0 1 2 3. - -Eval compute in test_proj. - -Recursive Extraction test_proj. - - - -(*** TO SUM UP: ***) - -Module Everything. - Definition idnat := idnat. - Definition id := id. - Definition id' := id'. - Definition test2 := test2. - Definition test3 := test3. - Definition test4 := test4. - Definition test5 := test5. - Definition test6 := test6. - Definition test7 := test7. - Definition d := d. - Definition d2 := d2. - Definition d3 := d3. - Definition d4 := d4. - Definition d5 := d5. - Definition d6 := d6. - Definition test8 := test8. - Definition test9 := test9. - Definition test10 := test10. - Definition test11 := test11. - Definition test12 := test12. - Definition test13 := test13. - Definition test19 := test19. - Definition test20 := test20. - Definition nat := nat. - Definition sumbool_rect := sumbool_rect. - Definition c := c. - Definition Finite := Finite. - Definition tree := tree. - Definition tree_size := tree_size. - Definition test14 := test14. - Definition test15 := test15. - Definition eta_c := eta_c. - Definition test16 := test16. - Definition test17 := test17. - Definition test18 := test18. - Definition bidon := bidon. - Definition tb := tb. - Definition fbidon := fbidon. - Definition fbidon2 := fbidon2. - Definition test_0 := test_0. - Definition test_1 := test_1. - Definition eq_rect := eq_rect. - Definition tp1 := tp1. - Definition tp1bis := tp1bis. - Definition Truc := Truc. - Definition oups := oups. - Definition test24 := test24. - Definition loop := loop. - Definition horibilis := horibilis. - Definition PropSet := PropSet. - Definition natbool := natbool. - Definition zerotrue := zerotrue. - Definition zeroTrue := zeroTrue. - Definition zeroprop := zeroprop. - Definition test21 := test21. - Definition test22 := test22. - Definition test23 := test23. - Definition f := f. - Definition f_prop := f_prop. - Definition f_arity := f_arity. - Definition f_normal := f_normal. - Definition Boite := Boite. - Definition boite1 := boite1. - Definition boite2 := boite2. - Definition test_boite := test_boite. - Definition Box := Box. - Definition box1 := box1. - Definition zarb := zarb. - Definition test_proj := test_proj. -End Everything. - -(* Extraction "test_extraction.ml" Everything. *) -Recursive Extraction Everything. -(* Check that the previous OCaml code is compilable *) -Extraction TestCompile Everything. - -Extraction Language Haskell. -(* Extraction "Test_extraction.hs" Everything. *) -Recursive Extraction Everything. - -Extraction Language Scheme. -(* Extraction "test_extraction.scm" Everything. *) -Recursive Extraction Everything. - - -(*** Finally, a test more focused on everyday's life situations ***) - -From Stdlib Require Import ZArith. - -Extraction Language OCaml. - -From Stdlib Require Import String. - -Definition string_test1 := string_dec "foo" "bar". - -Definition string_test2 (x: string) : unit := - match x with - | EmptyString => tt - | _ => tt - end. - -Definition string_test3 (x : string) : string := - String.string_of_list_ascii (String.list_ascii_of_string x). - -Definition string_test4 (x : string) : string := - String.string_of_list_byte (String.list_byte_of_string x). - -Definition string_test := - (string_test1, string_test2, string_test3, string_test4). - -(* Raw extraction of strings *) -Extraction TestCompile string_test. - -(* Extraction to char list *) -From Stdlib Require Import ExtrOcamlString. -Extraction TestCompile string_test. - -(* Extraction to native strings *) -From Stdlib Require Import ExtrOcamlNativeString. -Extraction TestCompile string_test compare. - -Recursive Extraction Z_modulo_2 Zdiv_eucl_exist. -Extraction TestCompile Z_modulo_2 Zdiv_eucl_exist. - -From Stdlib Require Import ExtrOcamlZBigInt. -Recursive Extraction N.pred N.sub N.div N.modulo N.compare - Z.add Z.mul Z.compare Z.of_N Z.abs_N Z.div Z.modulo - Pos.add Pos.pred Pos.sub Pos.mul Pos.compare. -Extraction TestCompile N.pred N.sub N.div N.modulo N.compare - Z.add Z.mul Z.compare Z.of_N Z.abs_N Z.div Z.modulo - Pos.add Pos.pred Pos.sub Pos.mul Pos.compare. - -From Stdlib Require Import Euclid ExtrOcamlNatBigInt. -Definition test n m (H:m>0) := - let (q,r,_,_) := eucl_dev m H n in - Nat.compare n (q*m+r). -Recursive Extraction test fact pred minus max min Nat.div2. -Extraction TestCompile test fact pred minus max min Nat.div2. diff --git a/stdlib/test-suite/success/extraction_bigint.v b/stdlib/test-suite/success/extraction_bigint.v deleted file mode 100644 index 6396f0fbdefd..000000000000 --- a/stdlib/test-suite/success/extraction_bigint.v +++ /dev/null @@ -1,108 +0,0 @@ -(** Test extraction of big integers using zarith *) - -From Stdlib Require Extraction ExtrOcamlZBigInt. -From Stdlib Require Import Bool Arith ZArith List. -Import ListNotations. - -Definition from_sumbool {P Q} (p : {P} + {Q}) : bool := - match p with - | left _ => true - | right _ => false - end. - -Definition tests_Pos : list bool := - [ 1 =? 1 - ; Pos.succ 3 =? 4 - ; Pos.pred 3 =? 2 - ; 1 + 2 =? 3 - ; 6 - 2 =? 4 - ; 3 - 3 =? 1 - ; 3 - 6 =? 1 - ; 3 * 4 =? 12 - ; Pos.min 2 3 =? 2 - ; Pos.max 2 3 =? 3 - ; Pos.eqb 1 1 - ; Pos.shiftl 2 3 =? 16 - ; Pos.shiftr 4 2 =? 1 - ; from_sumbool (Pos.eq_dec 1 1) - ; negb (from_sumbool (Pos.eq_dec 1 2)) - ]%positive. - -Definition test_positive : { b | b = true } := exist _ (forallb (fun x => x) tests_Pos) eq_refl. - -Definition eq_N2 (x y : N * N) : bool := - ((fst x =? fst y) && (snd x =? snd y))%N. - -Definition tests_N : list bool := - [ 0 =? 0 - ; N.succ 3 =? 4 - ; N.pred 3 =? 2 - ; 1 + 2 =? 3 - ; 6 - 2 =? 4 - ; 3 - 4 =? 0 - ; 3 * 4 =? 12 - ; N.min 2 3 =? 2 - ; N.max 2 3 =? 3 - ; N.eqb 1 1 - ; 11 / 2 =? 5 - ; 11 mod 3 =? 2 - ; N.shiftl 2 3 =? 16 - ; N.shiftr 4 2 =? 1 - ; negb (N.eqb 0 1) - ; from_sumbool (N.eq_dec 0 0) - ; negb (from_sumbool (N.eq_dec 0 1)) - ; Z.to_N 3 =? 3 - ; eq_N2 (N.div_eucl 11 0) (0, 11) - ; eq_N2 (N.div_eucl 11 3) (3, 2) - ]%N. - -Definition test_N : { b | b = true } := exist _ (forallb (fun x => x) tests_N) eq_refl. - -Definition eq_Z2 (x y : Z * Z) : bool := - ((fst x =? fst y) && (snd x =? snd y))%Z. - -Definition tests_Z : list bool := - [ 0 =? 0 - ; Z.succ 3 =? 4 - ; Z.pred 3 =? 2 - ; 1 + 2 =? 3 - ; 1 + (-4) =? -3 - ; 3 - 4 =? -1 - ; 3 - (-4) =? 7 - ; (-3) * (-4) =? 12 - ; (-3) * 4 =? -12 - ; Z.opp 3 =? -3 - ; Z.opp (-3) =? 3 - ; Z.abs 3 =? 3 - ; Z.abs (-3) =? 3 - ; Z.min (-3) 3 =? -3 - ; Z.max (-3) 3 =? 3 - ; Z.eqb 1 1 - ; 11 / 0 =? 0 - ; 11 / 2 =? 5 - ; (-11) / 2 =? -6 - ; 11 / (-2) =? -6 - ; (-11) / (-2) =? 5 - ; 11 mod 0 =? 11 - ; 11 mod 3 =? 2 - ; (-11) mod 3 =? 1 - ; 11 mod (-3) =? -1 - ; (-11) mod (-3) =? -2 - ; Z.shiftl 2 3 =? 16 - ; Z.shiftl 2 (-1) =? 1 - ; Z.shiftr 4 2 =? 1 - ; Z.shiftr 4 (-3) =? 32 - ; negb (Z.eqb 0 1) - ; from_sumbool (Z.eq_dec 0 0) - ; negb (from_sumbool (Z.eq_dec 0 1)) - ; Z.of_N 3 =? 3 - ; eq_Z2 (Z.div_eucl 11 0) (0, 11) - ; eq_Z2 (Z.div_eucl 11 3) (3, 2) - ; eq_Z2 (Z.div_eucl (-11) 3) (-4, 1) - ; eq_Z2 (Z.div_eucl 11 (-3)) (-4, -1) - ; eq_Z2 (Z.div_eucl (-11) (-3)) (3, -2) - ]%Z. - -Definition test_Z : { b | b = true } := exist _ (forallb (fun x => x) tests_Z) eq_refl. - -Extraction TestCompile test_positive test_Z test_N. diff --git a/stdlib/test-suite/success/fix.v b/stdlib/test-suite/success/fix.v deleted file mode 100644 index f0edf19669c1..000000000000 --- a/stdlib/test-suite/success/fix.v +++ /dev/null @@ -1,119 +0,0 @@ -(* Ancien bug signale par Laurent Thery sur la condition de garde *) - -From Stdlib Require Import Bool. -From Stdlib Require Import ZArith. - -Definition rNat := positive. - -Inductive rBoolOp : Set := - | rAnd : rBoolOp - | rEq : rBoolOp. - -Definition rlt (a b : rNat) : Prop := Pos.compare_cont Eq a b = Lt. - -Definition rltDec : forall m n : rNat, {rlt m n} + {rlt n m \/ m = n}. -Proof. -intros n m; generalize (nat_of_P_lt_Lt_compare_morphism n m); - generalize (nat_of_P_gt_Gt_compare_morphism n m); - generalize (Pcompare_Eq_eq n m); case (Pos.compare_cont Eq n m). -intros H' H'0 H'1; right; right; auto. -intros H' H'0 H'1; left; unfold rlt. -apply nat_of_P_lt_Lt_compare_complement_morphism; auto. -intros H' H'0 H'1; right; left; unfold rlt. -apply nat_of_P_lt_Lt_compare_complement_morphism; auto. -apply H'0; auto. -Defined. - - -Definition rmax : rNat -> rNat -> rNat. -Proof. -intros n m; case (rltDec n m); intros Rlt0. -exact m. -exact n. -Defined. - -Inductive rExpr : Set := - | rV : rNat -> rExpr - | rN : rExpr -> rExpr - | rNode : rBoolOp -> rExpr -> rExpr -> rExpr. - -Fixpoint maxVar (e : rExpr) : rNat := - match e with - | rV n => n - | rN p => maxVar p - | rNode n p q => rmax (maxVar p) (maxVar q) - end. - -(* Check bug #1491 *) - -From Stdlib Require Import Streams. - -Definition decomp (s:Stream nat) : Stream nat := - match s with Cons _ s => s end. - -CoFixpoint bx0 : Stream nat := Cons 0 bx1 -with bx1 : Stream nat := Cons 1 bx0. - -Lemma bx0bx : decomp bx0 = bx1. -simpl. (* used to return bx0 in V8.1 and before instead of bx1 *) -reflexivity. -Qed. - -(* Check mutually inductive statements *) - -From Stdlib Require Import ZArith_base Lia. -Open Scope Z_scope. - -Inductive even: Z -> Prop := -| even_base: even 0 -| even_succ: forall n, odd (n - 1) -> even n -with odd: Z -> Prop := -| odd_succ: forall n, even (n - 1) -> odd n. - -Lemma even_pos_odd_pos: forall n, even n -> n >= 0 -with odd_pos_even_pos : forall n, odd n -> n >= 1. -Proof. - intros. - destruct H. - lia. - apply odd_pos_even_pos in H. - lia. - intros. - destruct H. - apply even_pos_odd_pos in H. - lia. -Qed. - -CoInductive a : Prop := acons : b -> a -with b : Prop := bcons : a -> b. - -Lemma a1 : a -with b1 : b. -Proof. -apply acons. -assumption. - -apply bcons. -assumption. -Qed. - -From Stdlib Require Import List. - -(** Extracted from coq_performance_tests *) - -Module InnerMatch. - -Fixpoint take_uniform_n' {T} (ls : list T) (len : nat) (n : nat) : list T - := match n, ls, List.rev ls with - | 0%nat, _, _ => nil - | _, nil, _ => nil - | _, _, nil => nil - | 1%nat, cons x _, _ => cons x nil - | 2%nat, cons x nil, _ => cons x nil - | 2%nat, cons x _, cons y _ => cons x (cons y nil) - | S n', cons x xs, _ - => let skip := (Nat.div len n + 1)%nat in - cons x (take_uniform_n' (skipn skip xs) (len - 1 - skip) n') - end. - -End InnerMatch. diff --git a/stdlib/test-suite/success/import_lib.v b/stdlib/test-suite/success/import_lib.v deleted file mode 100644 index 4f3320d47bd8..000000000000 --- a/stdlib/test-suite/success/import_lib.v +++ /dev/null @@ -1,203 +0,0 @@ -Definition le_trans := 0. - - -Module Test_Read. - Module M. -From Stdlib Require PeanoNat. (* Reading without importing *) - - Check PeanoNat.Nat.le_trans. - - Lemma th0 : le_trans = 0. - reflexivity. - Qed. - End M. - - Check PeanoNat.Nat.le_trans. - - Lemma th0 : le_trans = 0. - reflexivity. - Qed. - - Import M. - - Lemma th1 : le_trans = 0. - reflexivity. - Qed. -End Test_Read. - - -(****************************************************************) - -(* Arith.Compare containes Require Export Wf_nat. *) -Definition le_decide := 1. (* from Arith/Compare *) -Definition lt_wf := 0. (* from Arith/Wf_nat *) - -Module Test_Require. - - Module M. -From Stdlib Require Import Compare. (* Imports Compare_dec as well *) - - Lemma th1 n : le_decide n = le_decide n. - reflexivity. - Qed. - - Lemma th2 n : lt_wf n = lt_wf n. - reflexivity. - Qed. - - End M. - - (* Checks that Compare and Wf_nat are loaded *) - Check Compare.le_decide. - Check Wf_nat.lt_wf. - - - (* Checks that Compare and Wf_nat are _not_ imported *) - Lemma th1 : le_decide = 1. - reflexivity. - Qed. - - Lemma th2 : lt_wf = 0. - reflexivity. - Qed. - - (* It should still be the case after Import M *) - Import M. - - Lemma th3 : le_decide = 1. - reflexivity. - Qed. - - Lemma th4 : lt_wf = 0. - reflexivity. - Qed. - -End Test_Require. - -(****************************************************************) - -Module Test_Import. - Module M. - Import Compare. (* Imports Wf_nat as well *) - - Lemma th1 n : le_decide n = le_decide n. - reflexivity. - Qed. - - Lemma th2 n : lt_wf n = lt_wf n. - reflexivity. - Qed. - - End M. - - (* Checks that Compare and Wf_nat are loaded *) - Check Compare.le_decide. - Check Wf_nat.lt_wf. - - - (* Checks that Compare and Wf_nat are _not_ imported *) - Lemma th1 : le_decide = 1. - reflexivity. - Qed. - - Lemma th2 : lt_wf = 0. - reflexivity. - Qed. - - (* It should still be the case after Import M *) - Import M. - - Lemma th3 : le_decide = 1. - reflexivity. - Qed. - - Lemma th4 : lt_wf = 0. - reflexivity. - Qed. -End Test_Import. - -(************************************************************************) - -Module Test_Export. - Module M. - Export Compare. (* Exports Wf_nat as well *) - - Lemma th1 n : le_decide n = le_decide n. - reflexivity. - Qed. - - Lemma th2 n : lt_wf n = lt_wf n. - reflexivity. - Qed. - - End M. - - - (* Checks that Compare and Wf_nat are _not_ imported *) - Lemma th1 : le_decide = 1. - reflexivity. - Qed. - - Lemma th2 : lt_wf = 0. - reflexivity. - Qed. - - - (* After Import M they should be imported as well *) - - Import M. - - Lemma th3 n : le_decide n = le_decide n. - reflexivity. - Qed. - - Lemma th4 n : lt_wf n = lt_wf n. - reflexivity. - Qed. -End Test_Export. - - -(************************************************************************) - -Module Test_Require_Export. - - Definition le_decide := 1. (* from Arith/Compare *) - Definition lt_wf := 0. (* from Arith/Wf_nat *) - - Module M. -From Stdlib Require Export Compare. (* Exports Wf_nat as well *) - - Lemma th1 n : le_decide n = le_decide n. - reflexivity. - Qed. - - Lemma th2 n : lt_wf n = lt_wf n. - reflexivity. - Qed. - - End M. - - - (* Checks that Compare and Wf_nat are _not_ imported *) - Lemma th1 : le_decide = 1. - reflexivity. - Qed. - - Lemma th2 : lt_wf = 0. - reflexivity. - Qed. - - - (* After Import M they should be imported as well *) - - Import M. - - Lemma th3 n : le_decide n = le_decide n. - reflexivity. - Qed. - - Lemma th4 n : lt_wf n = lt_wf n. - reflexivity. - Qed. - -End Test_Require_Export. diff --git a/stdlib/test-suite/success/programequality.v b/stdlib/test-suite/success/programequality.v deleted file mode 100644 index 11bfe9c5653e..000000000000 --- a/stdlib/test-suite/success/programequality.v +++ /dev/null @@ -1,13 +0,0 @@ -From Stdlib Require Import Program. - -Axiom t : nat -> Set. - -Goal forall (x y : nat) (e : x = y) (e' : x = y) (P : t y -> x = y -> Type) - (a : t x), - P (eq_rect _ _ a _ e) e'. -Proof. - intros. - pi_eq_proofs. clear e. - destruct e'. simpl. - change (P a eq_refl). -Abort. diff --git a/stdlib/test-suite/success/rewrite_Proper_map.v b/stdlib/test-suite/success/rewrite_Proper_map.v deleted file mode 100644 index 39f08c5adc7f..000000000000 --- a/stdlib/test-suite/success/rewrite_Proper_map.v +++ /dev/null @@ -1,183 +0,0 @@ -Require Import List Permutation Morphisms ZArith Lia. -Import ListNotations. - -Module Import List. -Notation map_snoc := map_last. - -Lemma seq_mul_r s n c : - seq s (n*c) = concat (map (fun i => seq (s + i*c) c) (seq O n)). -Proof. - revert s; induction n; intros; rewrite ?flat_map_nil_l, ?Nat.add_0_r; trivial. - cbn [Nat.mul]; rewrite Nat.add_comm, seq_app. - rewrite seq_S, map_app, concat_app, IHn; cbn [concat map]; rewrite app_nil_r; trivial. -Qed. - -Lemma seq_0_mul n c : - seq O (n*c) = concat (map (fun i => seq (i*c) c) (seq O n)). -Proof. apply seq_mul_r. Qed. - -Lemma map_const {A B} x l : @map A B (fun _ => x) l = repeat x (length l). -Proof. induction l; cbn; congruence. Qed. - -Lemma map_add_seq a s l : map (Nat.add a) (seq s l) = seq (a+s) l. -Proof. - revert s; induction l; intros; cbn [seq map]; rewrite ?IHl, ?Nat.add_succ_r; trivial. -Qed. - -Lemma seq_as_seq0 s l : seq s l = map (Nat.add s) (seq 0 l). -Proof. rewrite map_add_seq, Nat.add_0_r; trivial. Qed. - -Notation map_concat := concat_map. - -Lemma concat_map_map_const_r {A B C} (f : A -> B -> C) l l' : - concat (map (fun x => map (f x) l) l') = map (uncurry f) (list_prod l' l). -Proof. - induction l'; cbn [concat map list_prod]; trivial. - rewrite IHl', map_app, map_map; trivial. -Qed. - -Lemma list_prod_nil_r {A B} l : @list_prod A B l [] = []. -Proof. induction l; cbn; auto. Qed. -End List. - -Module Import Permutation. -Lemma Permutation_list_prod_cons_r {A B} a (l : list A) (l' : list B) : - Permutation (list_prod l (a :: l')) - (map (fun x : A => (x, a)) l ++ list_prod l l'). -Proof. - revert l'; revert a; induction l; cbn; constructor. - etransitivity. eapply Permutation_app. 2: eapply IHl. reflexivity. - rewrite !app_assoc. eapply Permutation_app; trivial. - eapply Permutation_app_comm. -Qed. - -Lemma Permutation_flip_list_prod {A B} (l : list A) (l' : list B) : - Permutation (map (fun p => (snd p, fst p)) (list_prod l' l)) (list_prod l l'). -Proof. - induction l'; cbn; rewrite ?list_prod_nil_r; trivial. - rewrite map_app, map_map, IHl'; cbn [fst snd]. - eapply symmetry, Permutation_list_prod_cons_r. -Qed. -End Permutation. - -Module Import Nat. - Local Open Scope nat_scope. - Definition sum := (fold_right Nat.add 0%nat). - Lemma sum_app l l' : sum (l ++ l') = sum l + sum l'. - Proof. - induction l; cbn [app sum fold_right]; - rewrite ?Nat.add_0_l, ?IHl, ?Nat.add_assoc; trivial. - Qed. - Lemma sum_snoc l n : sum (l ++ [n]) = sum l + n. - Proof. rewrite sum_app; cbn [sum fold_right]; rewrite ?Nat.add_0_r; trivial. Qed. -End Nat. - -Module Import Z. - Local Open Scope Z_scope. - Definition sum := (fold_right Z.add 0). - Lemma sum_repeat x n : sum (repeat x n) = x * Z.of_nat n. - Proof. induction n; cbn [sum fold_right repeat]; lia. Qed. - - Lemma sum_repeat_0 n : sum (repeat 0 n) = 0. - Proof. rewrite sum_repeat; trivial. Qed. - - Lemma sum_app l l' : sum (l ++ l') = sum l + sum l'. - Proof. - induction l; cbn [app sum fold_right]; - rewrite ?Z.add_0_l, ?IHl, ?Z.add_assoc; trivial. - Qed. - - Lemma sum_snoc l z : sum (l ++ [z]) = sum l + z. - Proof. rewrite sum_app; cbn [sum fold_right]; rewrite ?Z.add_0_r; trivial. Qed. - - Lemma sum_map_mul z l : sum (map (Z.mul z) l) = z * sum l. - Proof. induction l; cbn [map sum fold_right]; lia. Qed. - - Lemma sum_concat l : sum (concat l) = sum (map Z.sum l). - Proof. induction l; cbn [map sum fold_right concat]; rewrite ?sum_app; lia. Qed. - - Global Instance Proper_sum_Permutation : Proper (@Permutation Z ==> eq) sum. - Proof. induction 1; cbn [sum fold_right]; lia. Qed. - - Lemma sum_map_swap_indep {A B} (f : A -> B -> Z) l l' : - Z.sum (map (fun x => Z.sum (map (fun y => f x y) l)) l') = - Z.sum (map (fun y => Z.sum (map (fun x => f x y) l')) l). - Proof. - erewrite <-map_map, <-sum_concat; symmetry. - erewrite <-map_map, <-sum_concat; symmetry. - eapply Proper_sum_Permutation. - rewrite 2 concat_map_map_const_r. - rewrite <-Permutation_flip_list_prod. - erewrite map_map, map_ext; try intros []; trivial. - Qed. -End Z. - -Local Notation "[ e | x <- 'rev' ( s ..+ l ) ]" := - (map (fun x : nat => e) (List.rev (seq s%nat l%nat))) - (format "[ e '[hv' | x <- 'rev' ( s ..+ l ) ']' ]", x name). -Local Notation "[ e | x <- s ..+ l ]" := - (map (fun x : nat => e) (seq s%nat l%nat)) - (format "[ e '[hv' | x <- s ..+ l ']' ]", x name). -Local Notation "āˆ‘ l" := (Z.sum l%Z) (format "āˆ‘ l", at level 10) : Z_scope. -Local Notation "āˆ‘ l" := (Nat.sum l%nat) (format "āˆ‘ l", at level 10) : nat_scope. - -Section __. (* https://www.shiftleft.org/papers/fff/fff.pdf section 3.3 *) -Context (n : nat) (s t : nat -> nat) (d : nat -> Z) s_max (Hs_max : forall j, s j <= s_max). -Implicit Types i j k : nat. -Local Coercion Z.of_nat : nat >-> Z. -Definition o j : nat := āˆ‘ [s j * t j | j<-0..+j]. Definition D := o n. -Definition spec : Z := āˆ‘ [ 2^i * d i | i<-0..+D]. -Definition C j k : Z := āˆ‘ [d (o j + s j * i + k) * 2^(o j + s j * i) | i<-0..+t j]. -Definition impl := - fold_left (fun r t => 2*r +t)%Z - [ āˆ‘[ if (k _) as f; change (fun k => 2^k*_)%Z with (fun k => 2^k*f k)%Z. - rewrite <-Z.add_0_r; rewrite <-(Z.mul_0_l (2^s_max)) at 2. - generalize 0%Z as r; clear Hs_max. induction s_max as [|? IH]; intros. - { symmetry. apply Z.mul_1_r. } - rewrite seq_S, rev_unit, map_snoc, Z.sum_snoc, Nat.add_0_l; cbn [map fold_left]. - rewrite IH; rewrite <-?Z.add_assoc, ?Nat2Z.inj_succ, ?Z.pow_succ_r; lia. } - transitivity (āˆ‘[āˆ‘[if (k if _. { - cbv [D o]; induction n as [|? IH]; trivial. - rewrite ?seq_S, ?map_snoc, ?concat_app; cbn [concat]; rewrite ?app_nil_r, <-IH. - rewrite Nat.sum_snoc, (seq_app (Nat.sum _)); trivial. } - setoid_rewrite concat_map; setoid_rewrite map_map. setoid_rewrite (Z.mul_comm (_^_)). - setoid_rewrite seq_as_seq0 at 3; setoid_rewrite map_map. - rewrite sum_concat, map_map. setoid_rewrite Nat2Z.inj_add. trivial. -Qed. -End __. diff --git a/stdlib/test-suite/success/rewrite_dep.v b/stdlib/test-suite/success/rewrite_dep.v deleted file mode 100644 index f85beee039ea..000000000000 --- a/stdlib/test-suite/success/rewrite_dep.v +++ /dev/null @@ -1,34 +0,0 @@ -Require Import TestSuite.admit. -From Stdlib Require Import Setoid. -From Stdlib Require Import Morphisms. -From Stdlib Require Vector. -Notation vector := Vector.t. -Notation Vcons n t := (@Vector.cons _ n _ t). - -Class Equiv A := equiv : A -> A -> Prop. -Class Setoid A `{Equiv A} := setoid_equiv :: Equivalence (equiv). - -#[export] Instance vecequiv A `{Equiv A} n : Equiv (vector A n). -admit. -Qed. - -Global Instance vcons_proper A `{Equiv A} `{!Setoid A} : - Proper (equiv ==> forall_relation (fun k => equiv ==> equiv)) - (@Vector.cons A). -Proof. Admitted. - -#[export] Instance vecseotid A `{Setoid A} n : Setoid (vector A n). -Proof. Admitted. - -(* Instance equiv_setoid A {e : Equiv A} {s : @Setoid A e} : Equivalence e. *) -(* apply setoid_equiv. *) -(* Qed. *) -(* Typeclasses Transparent Equiv. *) - -Goal forall A `{Equiv A} `{!Setoid A} (f : A -> A) (a b : A) (H : equiv a b) n (v : vector A n), - equiv (Vcons a v) (Vcons b v). -Proof. - intros. - rewrite H0. - reflexivity. -Qed. diff --git a/stdlib/test-suite/success/search_lia.v b/stdlib/test-suite/success/search_lia.v deleted file mode 100644 index 4873b6baba83..000000000000 --- a/stdlib/test-suite/success/search_lia.v +++ /dev/null @@ -1,7 +0,0 @@ -(** 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 Lia. diff --git a/stdlib/test-suite/success/setoid_ring_module.v b/stdlib/test-suite/success/setoid_ring_module.v deleted file mode 100644 index 82d122f8c3a4..000000000000 --- a/stdlib/test-suite/success/setoid_ring_module.v +++ /dev/null @@ -1,40 +0,0 @@ -From Stdlib Require Import Setoid Ring Ring_theory. - -Module abs_ring. - -Parameters (Coef:Set)(c0 c1 : Coef) -(cadd cmul csub: Coef -> Coef -> Coef) -(copp : Coef -> Coef) -(ceq : Coef -> Coef -> Prop) -(ceq_sym : forall x y, ceq x y -> ceq y x) -(ceq_trans : forall x y z, ceq x y -> ceq y z -> ceq x z) -(ceq_refl : forall x, ceq x x). - - -Add Relation Coef ceq - reflexivity proved by ceq_refl symmetry proved by ceq_sym - transitivity proved by ceq_trans - as ceq_relation. - -Add Morphism cadd with signature ceq ==> ceq ==> ceq as cadd_Morphism. -Admitted. - -Add Morphism cmul with signature ceq ==> ceq ==> ceq as cmul_Morphism. -Admitted. - -Add Morphism copp with signature ceq ==> ceq as copp_Morphism. -Admitted. - -Definition cRth : ring_theory c0 c1 cadd cmul csub copp ceq. -Admitted. - -Add Ring CoefRing : cRth. - -End abs_ring. -Import abs_ring. - -Theorem check_setoid_ring_modules : - forall a b, ceq (cadd a b) (cadd b a). -intros. -ring. -Qed. diff --git a/stdlib/test-suite/success/strong_and_binary_induction.v b/stdlib/test-suite/success/strong_and_binary_induction.v deleted file mode 100644 index 2bf1966c32d0..000000000000 --- a/stdlib/test-suite/success/strong_and_binary_induction.v +++ /dev/null @@ -1,64 +0,0 @@ -(** This file is meant to test that the induction lemmas introduced in - #18628: - - [binary_induction] and [strong_induction_le] in PeanoNat - - [strong_induction_le] in BinNat - work with the [induction] tactic. *) - -From Stdlib.Arith Require Import PeanoNat. -From Stdlib.NArith Require Import BinNat. - -Open Scope nat_scope. - -Lemma land_diag_binary_induction_test n : Nat.land n n = n. -Proof. - induction n as [| n IH | n IH] using Nat.binary_induction. - - rewrite Nat.land_0_l; reflexivity. - - rewrite Nat.land_even_l, Nat.div2_even, IH; reflexivity. - - rewrite Nat.land_odd_l, Nat.odd_odd, Nat.div2_odd', IH; reflexivity. -Qed. - -Lemma land_diag_strong_induction_test n : Nat.land n n = n. -Proof. - induction n as [| n IH] using Nat.strong_induction_le. - - rewrite Nat.land_0_l; reflexivity. - - destruct (Nat.Even_or_Odd n) as [[k ->] | [k ->]]. - + rewrite <-Nat.add_1_r, Nat.land_odd_l, Nat.div2_odd', IH, Nat.odd_odd; - [reflexivity |]. - apply Nat.le_mul_l; discriminate. - + replace (S (2 * k + 1)) with (2 * (k + 1)); cycle 1. { - rewrite Nat.mul_add_distr_l, <-Nat.add_succ_r, Nat.mul_1_r; reflexivity. - } - rewrite Nat.land_even_l, Nat.div2_even, IH; [reflexivity |]. - apply Nat.add_le_mono; [| exact (Nat.le_refl _)]. - apply Nat.le_mul_l; discriminate. -Qed. - -Close Scope nat_scope. -Open Scope N_scope. - -(* Of course, this example is articifial in N. However, this shows that the - previous proof with almost no modifications. *) -Lemma land_diag_strong_induction_test_N n : N.land n n = n. -Proof. - induction n as [| n IH] using N.strong_induction_le. - - rewrite N.land_0_l; reflexivity. - - destruct (N.Even_or_Odd n) as [[k ->] | [k ->]]. - + rewrite <-N.add_1_r, N.land_odd_l, N.div2_odd', IH, N.odd_odd; - [reflexivity |]. - apply N.le_mul_l; discriminate. - + replace (N.succ (2 * k + 1)) with (2 * (k + 1)); cycle 1. { - rewrite N.mul_add_distr_l, <-N.add_succ_r, N.mul_1_r; reflexivity. - } - rewrite N.land_even_l, N.div2_even, IH; [reflexivity |]. - apply N.add_le_mono; [| exact (N.le_refl _)]. - apply N.le_mul_l; discriminate. -Qed. - -(* [binary_induction] is also available for [N] *) -Lemma land_diag_binary_induction_test_N n : N.land n n = n. -Proof. - induction n as [| n IH | n IH] using N.binary_induction. - - rewrite N.land_0_l; reflexivity. - - rewrite N.land_even_l, N.div2_even, IH; reflexivity. - - rewrite N.land_odd_l, N.odd_odd, N.div2_odd', IH; reflexivity. -Qed. diff --git a/stdlib/test-suite/success/unicode_utf8.v b/stdlib/test-suite/success/unicode_utf8.v deleted file mode 100644 index 4b560f9679d3..000000000000 --- a/stdlib/test-suite/success/unicode_utf8.v +++ /dev/null @@ -1,102 +0,0 @@ -(** PARSER TESTS *) - -(** Check correct separation of identifiers followed by unicode symbols *) -Notation "x āŠ• w" := (plus x w) (at level 30). -Check fun x => xāŠ•x. - -(** Check Greek letters *) -Definition test_greek : nat -> nat := fun Ī” => Ī”. -Parameter ā„ : Set. -Parameter Ļ€ : ā„. - -(** Check indices *) -Definition test_indices : nat -> nat := fun xā‚ => xā‚. -Definition Ļ€ā‚‚ := @snd. - -(** More unicode in identifiers *) -Definition Ī±Ī²_ƔƠ_אב := 0. - -Notation "C 'įµ’įµ–'" := C (at level 30). - -(** UNICODE IN STRINGS *) - -From Stdlib Require Import List Ascii String. -Open Scope string_scope. - -Definition test_string := "azertyĪ±Ī²āˆ€Ć©Ć©Ć©". -Eval compute in length test_string. - (** last six "chars" are unicode, hence represented by 2 bytes, - except the forall which is 3 bytes *) - -Fixpoint string_to_list s := - match s with - | EmptyString => nil - | String c s => c :: string_to_list s - end. - -Eval compute in (string_to_list test_string). - (** for instance, Ī± is \206\177 whereas āˆ€ is \226\136\128 *) -Close Scope string_scope. - - - -(** INTERFACE TESTS *) - -From Stdlib Require Import Utf8. - -(** Printing of unicode notation, in *goals* *) -Lemma test : forall A:Prop, A -> A. -Proof. -auto. -Qed. - -(** Parsing of unicode notation, in *goals* *) -Lemma test2 : āˆ€A:Prop, A ā†’ A. -Proof. -intro. -intro. -auto. -Qed. - -(** Printing of unicode notation, in *response* *) -Check fun (X:Type)(x:X) => x. - -(** Parsing of unicode notation, in *response* *) -Check āˆ€Ī”, Ī” ā†’ Ī”. -Check āˆ€x, x=0 āˆØ x=0 ā†’ x=0. - - -(** ISSUES: *) - -Notation "x ā‰  y" := (x<>y) (at level 70). - -Notation "x ā‰¤ y" := (x<=y) (at level 70, no associativity). - -(** First Issue : ā‰¤ is attached to "le" of nat, not to notation <= *) - -From Stdlib Require Import ZArith. -Open Scope Z_scope. -Locate "ā‰¤". (* still le, not Z.le *) -Notation "x ā‰¤ y" := (x<=y) (at level 70, no associativity). -Locate "ā‰¤". -Close Scope Z_scope. - -(** ==> How to proceed modularly ? *) - - -(** Second Issue : notation for -> generates useless parenthesis - if followed by a binder *) - -Check 0ā‰ 0 ā†’ āˆ€x:nat,x=x. - -(** Example of real situation : *) - -Definition pred : āˆ€x, xā‰ 0 ā†’ āˆƒy, x = S y. -Proof. -destruct x. -destruct 1; auto. -intros _. -exists x; auto. -Defined. - -Print pred. diff --git a/stdlib/test-suite/success/unification_delta.v b/stdlib/test-suite/success/unification_delta.v deleted file mode 100644 index 53e93a46bc4f..000000000000 --- a/stdlib/test-suite/success/unification_delta.v +++ /dev/null @@ -1,47 +0,0 @@ -From Stdlib Require Import Equivalence. -From Stdlib Require Import Program. -Import Relation_Definitions. -Import Morphisms. -From Stdlib Require Setoid. - -Obligation Tactic := program_simpl ; simpl_relation. -Generalizable Variables A eqA. - -Lemma bla : forall `{ ! @Equivalence A (eqA : relation A) } x y, eqA x y -> eqA y x. -Proof. - intros. - rewrite H0. - reflexivity. -Defined. - -Lemma bla' : forall `{ ! @Equivalence A (eqA : relation A) } x y, eqA x y -> eqA y x. -Proof. - intros. - (* Need delta on [relation] to unify with the right lemmas. *) - rewrite <- H0. - reflexivity. -Qed. - -Axiom euclid : nat -> { x : nat | x > 0 } -> nat. - -Definition eq_proj {A} {s : A -> Prop} : relation (sig s) := - fun x y => `x = `y. - -#[export] Program Instance foo {A : Type} {s : A -> Prop} : @Equivalence (sig s) eq_proj. - -Next Obligation. -Proof. - cbv in *;congruence. -Qed. - -#[export] Instance bar : Proper (eq ==> eq_proj ==> eq) euclid. -Proof. -Admitted. - -Goal forall (x : nat) (y : nat | y > 0) (z : nat | z > 0), eq_proj y z -> euclid x y = euclid x z. -Proof. - intros. - (* Breaks if too much delta in unification *) - rewrite H. - reflexivity. -Qed. diff --git a/stdlib/theories/Arith/Arith.v b/stdlib/theories/Arith/Arith.v deleted file mode 100644 index 0e21b61d1776..000000000000 --- a/stdlib/theories/Arith/Arith.v +++ /dev/null @@ -1,12 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* eq_sym (proj1 (Nat.le_0_r n) Hle). -Opaque le_n_0_eq_stt. -Add Search Blacklist "Coq.Arith.Arith_base.le_n_0_eq_stt". -#[global] -Hint Immediate le_n_0_eq_stt Nat.lt_le_incl Peano.le_S_n : arith. (* Le.le_n_0_eq Le.le_Sn_le Le.le_S_n *) -#[global] -Hint Resolve Nat.le_pred_l: arith. (* Le.le_pred_n *) -#[global] -Hint Resolve Nat.lt_irrefl: arith. (* Lt.lt_irrefl *) -#[local] -Definition lt_le_S_stt := fun n m => (proj2 (Nat.le_succ_l n m)). -Opaque lt_le_S_stt. -Add Search Blacklist "Coq.Arith.Arith_base.lt_le_S_stt". -#[global] -Hint Immediate lt_le_S_stt: arith. (* Lt.lt_le_S *) -#[local] -Definition lt_n_Sm_le_stt := fun n m => (proj1 (Nat.lt_succ_r n m)). -Opaque lt_n_Sm_le_stt. -Add Search Blacklist "Coq.Arith.Arith_base.lt_n_Sm_le_stt". -#[global] -Hint Immediate lt_n_Sm_le_stt: arith. (* Lt.lt_n_Sm_le *) -#[local] -Definition le_lt_n_Sm_stt := fun n m => (proj2 (Nat.lt_succ_r n m)). -Opaque le_lt_n_Sm_stt. -Add Search Blacklist "Coq.Arith.Arith_base.le_lt_n_Sm_stt". -#[global] -Hint Immediate le_lt_n_Sm_stt: arith. (* Lt.le_lt_n_Sm *) -#[local] -Definition le_not_lt_stt := fun n m => (proj1 (Nat.le_ngt n m)). -Opaque le_not_lt_stt. -Add Search Blacklist "Coq.Arith.Arith_base.le_not_lt_stt". -#[global] -Hint Immediate le_not_lt_stt: arith. (* Lt.le_not_lt *) -#[local] -Definition lt_not_le_stt := fun n m => (proj1 (Nat.lt_nge n m)). -Opaque lt_not_le_stt. -Add Search Blacklist "Coq.Arith.Arith_base.lt_not_le_stt". -#[global] -Hint Immediate lt_not_le_stt: arith. (* Lt.lt_not_le *) -#[global] -Hint Resolve Nat.lt_0_succ Nat.nlt_0_r: arith. (* Lt.lt_0_Sn Lt.lt_n_0 *) -#[local] -Definition neq_0_lt_stt := fun n Hn => proj1 (Nat.neq_0_lt_0 n) (Nat.neq_sym 0 n Hn). -Opaque neq_0_lt_stt. -Add Search Blacklist "Coq.Arith.Arith_base.neq_0_lt_stt". -#[local] -Definition lt_0_neq_stt := fun n Hlt => Nat.neq_sym n 0 (proj2 (Nat.neq_0_lt_0 n) Hlt). -Opaque lt_0_neq_stt. -Add Search Blacklist "Coq.Arith.Arith_base.lt_0_neq_stt". -#[global] -Hint Immediate neq_0_lt_stt lt_0_neq_stt: arith. (* Lt.neq_0_lt Lt.lt_0_neq *) -#[global] -Hint Resolve Nat.lt_succ_diag_r Nat.lt_lt_succ_r: arith. (* Lt.lt_n_Sn Lt.lt_S *) -#[local] -Definition lt_n_S_stt := fun n m => (proj1 (Nat.succ_lt_mono n m)). -Opaque lt_n_S_stt. -Add Search Blacklist "Coq.Arith.Arith_base.lt_n_S_stt". -#[global] -Hint Resolve lt_n_S_stt: arith. (* Lt.lt_n_S *) -#[local] -Definition lt_S_n_stt := fun n m => (proj2 (Nat.succ_lt_mono n m)). -Opaque lt_S_n_stt. -Add Search Blacklist "Coq.Arith.Arith_base.lt_S_n_stt". -#[global] -Hint Immediate lt_S_n_stt: arith. (* Lt.lt_S_n *) -#[local] -Definition lt_pred_stt := fun n m => proj1 (Nat.lt_succ_lt_pred n m). -Opaque lt_pred_stt. -Add Search Blacklist "Coq.Arith.Arith_base.lt_pred_stt". -#[global] -Hint Immediate lt_pred_stt: arith. (* Lt.lt_pred *) -#[local] -Definition lt_pred_n_n_stt := fun n Hlt => Nat.lt_pred_l n (proj2 (Nat.neq_0_lt_0 n) Hlt). -Opaque lt_pred_n_n_stt. -Add Search Blacklist "Coq.Arith.Arith_base.lt_pred_n_n_stt". -#[global] -Hint Resolve lt_pred_n_n_stt: arith. (* Lt.lt_pred_n_n *) -#[global] -Hint Resolve Nat.lt_trans Nat.lt_le_trans Nat.le_lt_trans: arith. (* Lt.lt_trans Lt.lt_le_trans Lt.le_lt_trans *) -#[global] -Hint Immediate Nat.lt_le_incl: arith. (* Lt.lt_le_weak *) -#[local] -Definition gt_Sn_O_stt : forall n, S n > 0 := Nat.lt_0_succ. -Opaque gt_Sn_O_stt. -Add Search Blacklist "Coq.Arith.Arith_base.gt_Sn_O_stt". -#[global] -Hint Resolve gt_Sn_O_stt: arith. (* Gt.gt_Sn_O *) -#[local] -Definition gt_Sn_n_stt : forall n, S n > n := Nat.lt_succ_diag_r. -Opaque gt_Sn_n_stt. -Add Search Blacklist "Coq.Arith.Arith_base.gt_Sn_n_stt". -#[global] -Hint Resolve gt_Sn_n_stt: arith. (* Gt.gt_Sn_n *) -#[local] -Definition gt_n_S_stt : forall n m, n > m -> S n > S m := fun n m Hgt => proj1 (Nat.succ_lt_mono m n) Hgt. -Opaque gt_n_S_stt. -Add Search Blacklist "Coq.Arith.Arith_base.gt_n_S_stt". -#[global] -Hint Resolve gt_n_S_stt: arith. (* Gt.gt_n_S *) -#[local] -Definition gt_S_n_stt : forall n m, S m > S n -> m > n := fun n m Hgt => proj2 (Nat.succ_lt_mono n m) Hgt. -Opaque gt_S_n_stt. -Add Search Blacklist "Coq.Arith.Arith_base.gt_S_n_stt". -#[global] -Hint Immediate gt_S_n_stt: arith. (* Gt.gt_S_n *) -#[local] -Definition gt_pred_stt : forall n m, m > S n -> pred m > n := fun n m Hgt => proj1 (Nat.lt_succ_lt_pred n m) Hgt. -Opaque gt_pred_stt. -Add Search Blacklist "Coq.Arith.Arith_base.gt_pred_stt". -#[global] -Hint Immediate gt_pred_stt: arith. (* Gt.gt_pred *) -#[local] -Definition gt_irrefl_stt : forall n, ~ n > n := Nat.lt_irrefl. -Opaque gt_irrefl_stt. -Add Search Blacklist "Coq.Arith.Arith_base.gt_irrefl_stt". -#[global] -Hint Resolve gt_irrefl_stt: arith. (* Gt.gt_irrefl *) -#[local] -Definition gt_asym_stt : forall n m, n > m -> ~ m > n := fun n m => Nat.lt_asymm m n. -Opaque gt_asym_stt. -Add Search Blacklist "Coq.Arith.Arith_base.gt_asym_stt". -#[global] -Hint Resolve gt_asym_stt: arith. (* Gt.gt_asym *) -#[local] -Definition le_not_gt_stt : forall n m, n <= m -> ~ n > m := fun n m => proj1 (Nat.le_ngt n m). -Opaque le_not_gt_stt. -Add Search Blacklist "Coq.Arith.Arith_base.le_not_gt_stt". -#[global] -Hint Resolve le_not_gt_stt: arith. (* Gt.le_not_gt *) -#[local] -Definition gt_not_le_stt: forall n m, n > m -> ~ n <= m := fun n m => proj1 (Nat.lt_nge m n). -Opaque gt_not_le_stt. -Add Search Blacklist "Coq.Arith.Arith_base.gt_not_le_stt". -#[global] -Hint Resolve gt_not_le_stt: arith. (* Gt.gt_not_le *) -#[local] -Definition le_S_gt_stt: forall n m, S n <= m -> m > n := fun n m => proj1 (Nat.le_succ_l n m). -Opaque le_S_gt_stt. -Add Search Blacklist "Coq.Arith.Arith_base.le_S_gt_stt". -#[global] -Hint Immediate le_S_gt_stt:arith. (* Gt.le_S_gt *) -#[local] -Definition gt_S_le_stt : forall n m, S m > n -> n <= m := fun n m => proj2 (Nat.succ_le_mono n m). -Opaque gt_S_le_stt. -Add Search Blacklist "Coq.Arith.Arith_base.gt_S_le_stt". -#[global] -Hint Immediate gt_S_le_stt:arith. (* Gt.gt_S_le *) -#[local] -Definition gt_le_S_stt : forall n m, m > n -> S n <= m := fun n m => proj2 (Nat.le_succ_l n m). -Opaque gt_le_S_stt. -Add Search Blacklist "Coq.Arith.Arith_base.gt_le_S_stt". -#[global] -Hint Resolve gt_le_S_stt:arith. (* Gt.gt_le_S *) -#[local] -Definition le_gt_S_stt : forall n m, n <= m -> S m > n := fun n m => proj1 (Nat.succ_le_mono n m). -Opaque le_gt_S_stt. -Add Search Blacklist "Coq.Arith.Arith_base.le_gt_S_stt". -#[global] -Hint Resolve le_gt_S_stt:arith. (* Gt.le_gt_S *) -#[local] -Definition gt_trans_S_stt : forall n m p, S n > m -> m > p -> n > p - := fun n m p Hgt1 Hgt2 => Nat.lt_le_trans p m n Hgt2 (proj2 (Nat.succ_le_mono _ _) Hgt1). -Opaque gt_trans_S_stt. -Add Search Blacklist "Coq.Arith.Arith_base.gt_trans_S_stt". -#[global] -Hint Resolve gt_trans_S_stt:arith. (* Gt.gt_trans_S *) -#[local] -Definition le_gt_trans_stt : forall n m p, m <= n -> m > p -> n > p - := fun n m p Hle Hgt => Nat.lt_le_trans p m n Hgt Hle. -Opaque le_gt_trans_stt. -Add Search Blacklist "Coq.Arith.Arith_base.le_gt_trans_stt". -#[global] -Hint Resolve le_gt_trans_stt:arith. (* Gt.le_gt_trans *) -#[local] -Definition gt_le_trans_stt : forall n m p, n > m -> p <= m -> n > p - := fun n m p Hgt Hle => Nat.le_lt_trans p m n Hle Hgt. -Opaque gt_le_trans_stt. -Add Search Blacklist "Coq.Arith.Arith_base.gt_le_trans_stt". -#[global] -Hint Resolve gt_le_trans_stt:arith. (* Gt.gt_le_trans *) -#[local] -Definition plus_gt_compat_l_stt : forall n m p, n > m -> p + n > p + m - := fun n m p Hgt => proj1 (Nat.add_lt_mono_l m n p) Hgt. -Opaque plus_gt_compat_l_stt. -Add Search Blacklist "Coq.Arith.Arith_base.plus_gt_compat_l_stt". -#[global] -Hint Resolve plus_gt_compat_l_stt:arith. (* Gt.plus_gt_compat_l *) - -(* ** [add] *) -#[global] -Hint Immediate Nat.add_comm : arith. (* Plus.plus_comm *) -#[global] -Hint Resolve Nat.add_assoc : arith. (* Plus.plus_assoc *) -#[local] -Definition plus_assoc_reverse_stt := fun n m p => eq_sym (Nat.add_assoc n m p). -Opaque plus_assoc_reverse_stt. -Add Search Blacklist "Coq.Arith.Arith_base.plus_assoc_reverse_stt". -#[global] -Hint Resolve plus_assoc_reverse_stt : arith. (* Plus.plus_assoc_reverse *) -#[global] -Hint Resolve -> Nat.add_le_mono_l : arith. (* Plus.plus_le_compat_l *) -#[global] -Hint Resolve -> Nat.add_le_mono_r : arith. (* Plus.plus_le_compat_r *) -#[local] -Definition le_plus_r_stt := (fun n m => Nat.le_add_l m n). -#[local] -Definition le_plus_trans_stt := (fun n m p Hle => Nat.le_trans n _ _ Hle (Nat.le_add_r m p)). -Opaque le_plus_r_stt le_plus_trans_stt. -Add Search Blacklist "Coq.Arith.Arith_base.le_plus_r_stt". -Add Search Blacklist "Coq.Arith.Arith_base.le_plus_trans_stt". -#[global] -Hint Resolve Nat.le_add_r le_plus_r_stt le_plus_trans_stt : arith. (* Plus.le_plus_l Plus.le_plus_r_stt Plus.le_plus_trans_stt *) -#[local] -Definition lt_plus_trans_stt := (fun n m p Hlt => Nat.lt_le_trans n _ _ Hlt (Nat.le_add_r m p)). -Opaque lt_plus_trans_stt. -Add Search Blacklist "Coq.Arith.Arith_base.lt_plus_trans_stt". -#[global] -Hint Immediate lt_plus_trans_stt : arith. (* Plus.lt_plus_trans_stt *) -#[global] -Hint Resolve -> Nat.add_lt_mono_l : arith. (* Plus_lt_compat_l *) -#[global] -Hint Resolve -> Nat.add_lt_mono_r : arith. (* Plus_lt_compat_r *) - - -(* ** [sub] *) -#[local] -Definition minus_n_O_stt := fun n => eq_sym (Nat.sub_0_r n). -Opaque minus_n_O_stt. -Add Search Blacklist "Coq.Arith.Arith_base.minus_n_O_stt". -#[global] -Hint Resolve minus_n_O_stt: arith. (* Minus.minus_n_O *) -#[local] -Definition minus_Sn_m_stt := fun n m Hle => eq_sym (Nat.sub_succ_l m n Hle). -Opaque minus_Sn_m_stt. -Add Search Blacklist "Coq.Arith.Arith_base.minus_Sn_m_stt". -#[global] -Hint Resolve minus_Sn_m_stt: arith. (* Minus.minus_Sn_m *) -#[local] -Definition minus_diag_reverse_stt := fun n => eq_sym (Nat.sub_diag n). -Opaque minus_diag_reverse_stt. -Add Search Blacklist "Coq.Arith.Arith_base.minus_diag_reverse_stt". -#[global] -Hint Resolve minus_diag_reverse_stt: arith. (* Minus.minus_diag_reverse *) -#[local] -Lemma minus_plus_simpl_l_reverse_stt n m p : n - m = p + n - (p + m). -Proof. - now rewrite Nat.sub_add_distr, Nat.add_comm, Nat.add_sub. -Qed. -Add Search Blacklist "Coq.Arith.Arith_base.minus_plus_simpl_l_reverse_stt". -#[global] -Hint Resolve minus_plus_simpl_l_reverse_stt: arith. (* Minus.minus_plus_simpl_l_reverse *) -#[local] -Definition plus_minus_stt := fun n m p Heq => eq_sym (Nat.add_sub_eq_l n m p (eq_sym Heq)). -Opaque plus_minus_stt. -Add Search Blacklist "Coq.Arith.Arith_base.plus_minus_stt". -#[global] -Hint Immediate plus_minus_stt: arith. (* Minus.plus_minus *) -#[local] -Definition minus_plus_stt := (fun n m => eq_ind _ (fun x => x - n = m) (Nat.add_sub m n) _ (Nat.add_comm _ _)). -Opaque minus_plus_stt. -Add Search Blacklist "Coq.Arith.Arith_base.minus_plus_stt". -#[global] -Hint Resolve minus_plus_stt: arith. (* Minus.minus_plus *) -#[local] -Definition le_plus_minus_stt := fun n m Hle => eq_sym (eq_trans (Nat.add_comm _ _) (Nat.sub_add n m Hle)). -Opaque le_plus_minus_stt. -Add Search Blacklist "Coq.Arith.Arith_base.le_plus_minus_stt". -#[global] -Hint Resolve le_plus_minus_stt: arith. (* Minus.le_plus_minus *) -#[local] -Definition le_plus_minus_r_stt := fun n m Hle => eq_trans (Nat.add_comm _ _) (Nat.sub_add n m Hle). -Opaque le_plus_minus_r_stt. -Add Search Blacklist "Coq.Arith.Arith_base.le_plus_minus_r_stt". -#[global] -Hint Resolve le_plus_minus_r_stt: arith. (* Minus.le_plus_minus_r *) -#[global] -Hint Resolve Nat.sub_lt: arith. (* Minus.lt_minus *) -#[local] -Definition lt_O_minus_lt_stt : forall n m, 0 < n - m -> m < n - := fun n m => proj2 (Nat.lt_add_lt_sub_r 0 n m). -Opaque lt_O_minus_lt_stt. -Add Search Blacklist "Coq.Arith.Arith_base.lt_O_minus_lt_stt". -#[global] -Hint Immediate lt_O_minus_lt_stt: arith. (* Minus.lt_O_minus_lt *) - -(* ** [mul] *) -#[global] -Hint Resolve Nat.mul_1_l Nat.mul_1_r: arith. (* Mult.mult_1_l Mult.mult_1_r *) -#[global] -Hint Resolve Nat.mul_comm: arith. (* Mult.mult_comm *) -#[global] -Hint Resolve Nat.mul_add_distr_r: arith. (* Mult.mult_plus_distr_r *) -#[global] -Hint Resolve Nat.mul_sub_distr_r: arith. (* Mult.mult_minus_distr_r *) -#[global] -Hint Resolve Nat.mul_sub_distr_l: arith. (* Mult.mult_minus_distr_l *) -#[local] -Definition mult_assoc_reverse_stt := fun n m p => eq_sym (Nat.mul_assoc n m p). -Opaque mult_assoc_reverse_stt. -Add Search Blacklist "Coq.Arith.Arith_base.mult_assoc_reverse_stt". -#[global] -Hint Resolve mult_assoc_reverse_stt Nat.mul_assoc: arith. (* Mult.mult_assoc_reverse Mult.mult_assoc *) -#[local] -Lemma mult_O_le_stt n m : m = 0 \/ n <= m * n. -Proof. - destruct m; [left|right]; simpl; trivial using Nat.le_add_r. -Qed. -Add Search Blacklist "Coq.Arith.Arith_base.mult_O_le_stt". -#[global] -Hint Resolve mult_O_le_stt: arith. (* Mult.mult_O_le *) -#[global] -Hint Resolve Nat.mul_le_mono_l: arith. (* Mult.mult_le_compat_l *) -#[local] -Definition mult_S_lt_compat_l_stt := (fun n m p Hlt => proj1 (Nat.mul_lt_mono_pos_l (S n) m p (Nat.lt_0_succ n)) Hlt). -Opaque mult_S_lt_compat_l_stt. -Add Search Blacklist "Coq.Arith.Arith_base.mult_S_lt_compat_l_stt". -#[global] -Hint Resolve mult_S_lt_compat_l_stt: arith. (* Mult.mult_S_lt_compat_l *) - -(* ** [min] and [max] *) -#[global] -Hint Resolve Nat.max_l Nat.max_r Nat.le_max_l Nat.le_max_r: arith. -#[global] -Hint Resolve Nat.min_l Nat.min_r Nat.le_min_l Nat.le_min_r: arith. - -(* ** [Even_alt] and [Odd_alt] *) -#[global] -Hint Constructors Nat.Even_alt: arith. -#[global] -Hint Constructors Nat.Odd_alt: arith. diff --git a/stdlib/theories/Arith/Between.v b/stdlib/theories/Arith/Between.v deleted file mode 100644 index 9a714b564e17..000000000000 --- a/stdlib/theories/Arith/Between.v +++ /dev/null @@ -1,212 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* Prop. - - (** The [between] type expresses the concept - [forall i: nat, k <= i < l -> P i.]. *) - Inductive between k : nat -> Prop := - | bet_emp : between k k - | bet_S : forall l, between k l -> P l -> between k (S l). - - #[local] - Hint Constructors between: core. - - Lemma bet_eq : forall k l, l = k -> between k l. - Proof. - intros * ->; constructor. - Qed. - - #[local] - Hint Resolve bet_eq: core. - - Lemma between_le : forall k l, between k l -> k <= l. - Proof. - induction 1; auto. - Qed. - #[local] - Hint Immediate between_le: core. - - Lemma between_Sk_l : forall k l, between k l -> S k <= l -> between (S k) l. - Proof. - induction 1 as [|* [|]]; auto. - - intros Hle; exfalso; apply (Nat.nle_succ_diag_l _ Hle). - - intros Hle; inversion Hle; constructor; auto. - Qed. - #[local] - Hint Resolve between_Sk_l: core. - - Lemma between_restr : - forall k l (m:nat), k <= l -> l <= m -> between k m -> between l m. - Proof. - induction 1; auto. - intros; auto. - apply between_Sk_l; auto. - apply IHle; auto. - transitivity (S m0); auto. - Qed. - - (** The [exists_between] type expresses the concept - [exists i: nat, k <= i < l /\ Q i]. *) - Inductive exists_between k : nat -> Prop := - | exists_S : forall l, exists_between k l -> exists_between k (S l) - | exists_le : forall l, k <= l -> Q l -> exists_between k (S l). - - #[local] - Hint Constructors exists_between: core. - - Lemma exists_le_S : forall k l, exists_between k l -> S k <= l. - Proof. - induction 1; auto. - apply -> Nat.succ_le_mono; assumption. - Qed. - - Lemma exists_lt : forall k l, exists_between k l -> k < l. - Proof exists_le_S. - #[local] - Hint Immediate exists_le_S exists_lt: core. - - Lemma exists_S_le : forall k l, exists_between k (S l) -> k <= l. - Proof. - intros; apply le_S_n; auto. - Qed. - #[local] - Hint Immediate exists_S_le: core. - - Definition in_int p q r := p <= r /\ r < q. - - Lemma in_int_intro : forall p q r, p <= r -> r < q -> in_int p q r. - Proof. - split; assumption. - Qed. - #[local] - Hint Resolve in_int_intro: core. - - Lemma in_int_lt : forall p q r, in_int p q r -> p < q. - Proof. - intros * []. - eapply Nat.le_lt_trans; eassumption. - Qed. - - Lemma in_int_p_Sq : - forall p q r, in_int p (S q) r -> in_int p q r \/ r = q. - Proof. - intros p q r []. - destruct (proj1 (Nat.lt_eq_cases r q)); auto. - apply Nat.lt_succ_r; assumption. - Qed. - - Lemma in_int_S : forall p q r, in_int p q r -> in_int p (S q) r. - Proof. - intros * []; auto. - Qed. - #[local] - Hint Resolve in_int_S: core. - - Lemma in_int_Sp_q : forall p q r, in_int (S p) q r -> in_int p q r. - Proof. - intros * []; auto. - apply in_int_intro; auto. - transitivity (S p); auto. - Qed. - #[local] - Hint Immediate in_int_Sp_q: core. - - Lemma between_in_int : - forall k l, between k l -> forall r, in_int k l r -> P r. - Proof. - intro k; induction 1 as [|l]; intros r ?. - - absurd (k < k). { apply Nat.lt_irrefl. } - eapply in_int_lt; eassumption. - - destruct (in_int_p_Sq k l r) as [| ->]; auto. - Qed. - - Lemma in_int_between : - forall k l, k <= l -> (forall r, in_int k l r -> P r) -> between k l. - Proof. - induction 1; auto. - Qed. - - Lemma exists_in_int : - forall k l, exists_between k l -> exists2 m : nat, in_int k l m & Q m. - Proof. - induction 1 as [* ? (p, ?, ?)|l]. - - exists p; auto. - - exists l; auto. - Qed. - - Lemma in_int_exists : forall k l r, in_int k l r -> Q r -> exists_between k l. - Proof. - intros * (?, lt_r_l) ?. - induction lt_r_l; auto. - Qed. - - Lemma between_or_exists : - forall k l, - k <= l -> - (forall n:nat, in_int k l n -> P n \/ Q n) -> - between k l \/ exists_between k l. - Proof. - induction 1 as [|m ? IHle]. - - auto. - - intros P_or_Q. - destruct IHle; auto. - destruct (P_or_Q m); auto. - Qed. - - Lemma between_not_exists : - forall k l, - between k l -> - (forall n:nat, in_int k l n -> P n -> ~ Q n) -> ~ exists_between k l. - Proof. - intro k; induction 1 as [|l]; red; intros. - - absurd (k < k). { apply Nat.lt_irrefl. } auto. - - absurd (Q l). { auto. } - destruct (exists_in_int k (S l)) as (l',[],?). - + auto. - + replace l with l'. { trivial. } - destruct (proj1 (Nat.lt_eq_cases l' l)); auto. - * apply Nat.lt_succ_r; assumption. - * absurd (exists_between k l). { auto. } - apply in_int_exists with l'; auto. - Qed. - - Inductive P_nth (init:nat) : nat -> nat -> Prop := - | nth_O : P_nth init init 0 - | nth_S : - forall k l (n:nat), - P_nth init k n -> between (S k) l -> Q l -> P_nth init l (S n). - - Lemma nth_le : forall (init:nat) l (n:nat), P_nth init l n -> init <= l. - Proof. - induction 1 as [|a b c H0 H1 H2 H3]. - - auto. - - eapply Nat.le_trans; eauto. - apply between_le in H2. - transitivity (S a); auto. - Qed. - - Definition eventually (n:nat) := exists2 k : nat, k <= n & Q k. - - Lemma event_O : eventually 0 -> Q 0. - Proof. - intros (x, ?, ?). - replace 0 with x; auto. - apply Nat.le_0_r; assumption. - Qed. - -End Between. diff --git a/stdlib/theories/Arith/Bool_nat.v b/stdlib/theories/Arith/Bool_nat.v deleted file mode 100644 index c8d4fe307522..000000000000 --- a/stdlib/theories/Arith/Bool_nat.v +++ /dev/null @@ -1,56 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* = y} := - fun n m => sumbool_not _ _ (le_lt_dec m n). - -#[deprecated(since="8.20", note="Use PeanoNat.Nat.ltb instead")] -Definition nat_lt_ge_bool x y := bool_of_sumbool (lt_ge_dec x y). - -#[deprecated(since="8.20", note="Use PeanoNat.Nat.leb instead")] -Definition nat_ge_lt_bool x y := - bool_of_sumbool (sumbool_not _ _ (lt_ge_dec x y)). - -#[deprecated(since="8.20", note="Use PeanoNat.Nat.leb instead")] -Definition nat_le_gt_bool x y := bool_of_sumbool (le_gt_dec x y). - -#[deprecated(since="8.20", note="Use PeanoNat.Nat.ltb instead")] -Definition nat_gt_le_bool x y := - bool_of_sumbool (sumbool_not _ _ (le_gt_dec x y)). - -#[deprecated(since="8.20", note="Use PeanoNat.Nat.eqb instead")] -Definition nat_eq_bool x y := bool_of_sumbool (eq_nat_dec x y). - -#[deprecated(since="8.20", note="Use PeanoNat.Nat.eqb instead")] -Definition nat_noteq_bool x y := - bool_of_sumbool (sumbool_not _ _ (eq_nat_dec x y)). - -#[deprecated(since="8.20", note="Use Coq.Arith.Compare_dec.zerop instead")] -Definition zerop_bool x := bool_of_sumbool (zerop x). - -#[deprecated(since="8.20", note="Use Coq.Arith.Compare_dec.zerop instead")] -Definition notzerop_bool x := bool_of_sumbool (notzerop x). diff --git a/stdlib/theories/Arith/Cantor.v b/stdlib/theories/Arith/Cantor.v deleted file mode 100644 index 850f822f9bd7..000000000000 --- a/stdlib/theories/Arith/Cantor.v +++ /dev/null @@ -1,88 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* (S i) + m) (y + x)). - -(** Cantor pairing inverse [of_nat] *) - -Definition of_nat (n : nat) : nat * nat := - nat_rec _ (0, 0) (fun _ '(x, y) => - match x with | S x => (x, S y) | _ => (S y, 0) end) n. - -(** [of_nat] is the left inverse for [to_nat] *) - -Lemma cancel_of_to p : of_nat (to_nat p) = p. -Proof. - enough (H : forall n p, to_nat p = n -> of_nat n = p) by now apply H. - intro n. induction n as [|n IHn]. - - now intros [[|?] [|?]]. - - intros [x [|y]]. - + destruct x as [|x]; [discriminate|]. - intros [=H]. cbn. fold (of_nat n). - rewrite (IHn (0, x)); [reflexivity|]. - rewrite <- H. cbn. now rewrite PeanoNat.Nat.add_0_r. - + intros [=H]. cbn. fold (of_nat n). - rewrite (IHn (S x, y)); [reflexivity|]. - rewrite <- H. cbn. now rewrite Nat.add_succ_r. -Qed. - -(** [to_nat] is injective *) - -Corollary to_nat_inj p q : to_nat p = to_nat q -> p = q. -Proof. - intros H %(f_equal of_nat). now rewrite ?cancel_of_to in H. -Qed. - -(** [to_nat] is the left inverse for [of_nat] *) - -Lemma cancel_to_of n : to_nat (of_nat n) = n. -Proof. - induction n as [|n IHn]; [reflexivity|]. - cbn. fold (of_nat n). destruct (of_nat n) as [[|x] y]. - - rewrite <- IHn. cbn. now rewrite PeanoNat.Nat.add_0_r. - - rewrite <- IHn. cbn. now rewrite (Nat.add_succ_r y x). -Qed. - -(** [of_nat] is injective *) - -Corollary of_nat_inj n m : of_nat n = of_nat m -> n = m. -Proof. - intros H %(f_equal to_nat). now rewrite ?cancel_to_of in H. -Qed. - -(** Polynomial specifications of [to_nat] *) - -Lemma to_nat_spec x y : - to_nat (x, y) * 2 = y * 2 + (y + x) * S (y + x). -Proof. - cbn. induction (y + x) as [|n IHn]; cbn; lia. -Qed. - -Lemma to_nat_spec2 x y : - to_nat (x, y) = y + (y + x) * S (y + x) / 2. -Proof. - now rewrite <- Nat.div_add_l, <- to_nat_spec, Nat.div_mul. -Qed. - -(** [to_nat] is non-decreasing in (the sum of) pair components *) - -Lemma to_nat_non_decreasing x y : y + x <= to_nat (x, y). -Proof. - pose proof (to_nat_spec x y). nia. -Qed. diff --git a/stdlib/theories/Arith/Compare.v b/stdlib/theories/Arith/Compare.v deleted file mode 100644 index baeac36acccc..000000000000 --- a/stdlib/theories/Arith/Compare.v +++ /dev/null @@ -1,58 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* n} + {n = m}. - -Lemma le_decide : forall n m, n <= m -> lt_or_eq n m. -Proof le_lt_eq_dec. - -Lemma le_le_S_eq : forall n m, n <= m -> S n <= m \/ n = m. -Proof (fun n m Hle => proj1 (Nat.lt_eq_cases n m) Hle). - -(* By special request of G. Kahn - Used in Group Theory *) -Lemma discrete_nat : - forall n m, n < m -> S n = m \/ (exists r : nat, m = S (S (n + r))). -Proof. - intros m n H. - lapply (proj1 (Nat.le_succ_l m n)); auto. - intro H'; lapply (proj1 (Nat.lt_eq_cases (S m) n)); auto. - induction 1; auto. - right; exists (n - S (S m)); simpl. - rewrite (Nat.add_comm m (n - S (S m))). - rewrite (plus_n_Sm (n - S (S m)) m). - rewrite (plus_n_Sm (n - S (S m)) (S m)). - rewrite (Nat.add_comm (n - S (S m)) (S (S m))). - rewrite Nat.add_sub_assoc; [ | assumption ]. - rewrite Nat.add_comm. - rewrite <- Nat.add_sub_assoc; [ | reflexivity ]. - rewrite Nat.sub_diag. - symmetry; apply Nat.add_0_r. -Qed. - -Require Export Wf_nat. diff --git a/stdlib/theories/Arith/Compare_dec.v b/stdlib/theories/Arith/Compare_dec.v deleted file mode 100644 index 5ffb34f64fd4..000000000000 --- a/stdlib/theories/Arith/Compare_dec.v +++ /dev/null @@ -1,252 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* n} + {n = m} + {n > m}. -Proof. - now apply lt_eq_lt_dec. -Defined. - -Definition le_lt_dec n m : {n <= m} + {m < n}. -Proof. - induction n as [|n IHn] in m |- *. - - left; apply Nat.le_0_l. - - destruct m as [|m]. - + right; apply Nat.lt_0_succ. - + elim (IHn m); intros H; [left|right]. - * now apply Nat.succ_le_mono in H. - * now apply Nat.succ_lt_mono in H. -Defined. - -Definition le_le_S_dec n m : {n <= m} + {S m <= n}. -Proof. - exact (le_lt_dec n m). -Defined. - -Definition le_ge_dec n m : {n <= m} + {n >= m}. -Proof. - elim (le_lt_dec n m); auto. - intros Hlt; right; apply Nat.lt_le_incl; assumption. -Defined. - -Definition le_gt_dec n m : {n <= m} + {n > m}. -Proof. - exact (le_lt_dec n m). -Defined. - -Definition le_lt_eq_dec n m : n <= m -> {n < m} + {n = m}. -Proof. - intros; destruct (lt_eq_lt_dec n m); auto. - exfalso. - apply (Nat.lt_irrefl n), (Nat.le_lt_trans n m); assumption. -Defined. - -Theorem le_dec n m : {n <= m} + {~ n <= m}. -Proof. - destruct (le_gt_dec n m). - - now left. - - right; intros Hle. - apply (Nat.lt_irrefl n), (Nat.le_lt_trans n m); assumption. -Defined. - -Theorem lt_dec n m : {n < m} + {~ n < m}. -Proof. - apply le_dec. -Defined. - -Theorem gt_dec n m : {n > m} + {~ n > m}. -Proof. - apply lt_dec. -Defined. - -Theorem ge_dec n m : {n >= m} + {~ n >= m}. -Proof. - apply le_dec. -Defined. - -Register le_gt_dec as num.nat.le_gt_dec. - -(** Proofs of decidability *) - -Theorem dec_le n m : decidable (n <= m). -Proof. - apply Nat.le_decidable. -Qed. - -Theorem dec_lt n m : decidable (n < m). -Proof. - apply Nat.lt_decidable. -Qed. - -Theorem dec_gt n m : decidable (n > m). -Proof. - apply Nat.lt_decidable. -Qed. - -Theorem dec_ge n m : decidable (n >= m). -Proof. - apply Nat.le_decidable. -Qed. - -Theorem not_eq n m : n <> m -> n < m \/ m < n. -Proof. - apply Nat.lt_gt_cases. -Qed. - -Theorem not_le n m : ~ n <= m -> n > m. -Proof. - apply Nat.nle_gt. -Qed. - -Theorem not_gt n m : ~ n > m -> n <= m. -Proof. - apply Nat.nlt_ge. -Qed. - -Theorem not_ge n m : ~ n >= m -> n < m. -Proof. - apply Nat.nle_gt. -Qed. - -Theorem not_lt n m : ~ n < m -> n >= m. -Proof. - apply Nat.nlt_ge. -Qed. - -Register dec_le as num.nat.dec_le. -Register dec_lt as num.nat.dec_lt. -Register dec_ge as num.nat.dec_ge. -Register dec_gt as num.nat.dec_gt. -Register not_eq as num.nat.not_eq. -Register not_le as num.nat.not_le. -Register not_lt as num.nat.not_lt. -Register not_ge as num.nat.not_ge. -Register not_gt as num.nat.not_gt. - - -(** A ternary comparison function in the spirit of [Z.compare]. - See now [Nat.compare] and its properties. - In scope [nat_scope], the notation for [Nat.compare] is "?=" *) - -Notation nat_compare_S := Nat.compare_succ (only parsing). - -Lemma nat_compare_lt n m : n (n ?= m) = Lt. -Proof. - symmetry. apply Nat.compare_lt_iff. -Qed. - -Lemma nat_compare_gt n m : n>m <-> (n ?= m) = Gt. -Proof. - symmetry. apply Nat.compare_gt_iff. -Qed. - -Lemma nat_compare_le n m : n<=m <-> (n ?= m) <> Gt. -Proof. - symmetry. apply Nat.compare_le_iff. -Qed. - -Lemma nat_compare_ge n m : n>=m <-> (n ?= m) <> Lt. -Proof. - symmetry. apply Nat.compare_ge_iff. -Qed. - -(** Some projections of the above equivalences. *) - -Lemma nat_compare_eq n m : (n ?= m) = Eq -> n = m. -Proof. - apply Nat.compare_eq_iff. -Qed. - -Lemma nat_compare_Lt_lt n m : (n ?= m) = Lt -> n n>m. -Proof. - apply Nat.compare_gt_iff. -Qed. - -(** A previous definition of [nat_compare] in terms of [lt_eq_lt_dec]. - The new version avoids the creation of proof parts. *) - -Definition nat_compare_alt (n m:nat) := - match lt_eq_lt_dec n m with - | inleft (left _) => Lt - | inleft (right _) => Eq - | inright _ => Gt - end. - -Lemma nat_compare_equiv n m : (n ?= m) = nat_compare_alt n m. -Proof. - unfold nat_compare_alt; destruct lt_eq_lt_dec as [[|]|]. - - now apply Nat.compare_lt_iff. - - now apply Nat.compare_eq_iff. - - now apply Nat.compare_gt_iff. -Qed. - -(** A boolean version of [le] over [nat]. - See now [Nat.leb] and its properties. - In scope [nat_scope], the notation for [Nat.leb] is "<=?" *) - -Notation leb := Nat.leb (only parsing). - -Notation leb_iff := Nat.leb_le (only parsing). - -Lemma leb_iff_conv m n : (n <=? m) = false <-> m < n. -Proof. - rewrite Nat.leb_nle. apply Nat.nle_gt. -Qed. - -Lemma leb_correct m n : m <= n -> (m <=? n) = true. -Proof. - apply Nat.leb_le. -Qed. - -Lemma leb_complete m n : (m <=? n) = true -> m <= n. -Proof. - apply Nat.leb_le. -Qed. - -Lemma leb_correct_conv m n : m < n -> (n <=? m) = false. -Proof. - apply leb_iff_conv. -Qed. - -Lemma leb_complete_conv m n : (n <=? m) = false -> m < n. -Proof. - apply leb_iff_conv. -Qed. - -Lemma leb_compare n m : (n <=? m) = true <-> (n ?= m) <> Gt. -Proof. - rewrite Nat.compare_le_iff. apply Nat.leb_le. -Qed. diff --git a/stdlib/theories/Arith/EqNat.v b/stdlib/theories/Arith/EqNat.v deleted file mode 100644 index 90d14d96412e..000000000000 --- a/stdlib/theories/Arith/EqNat.v +++ /dev/null @@ -1,63 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* True - | O, S _ => False - | S _, O => False - | S n1, S m1 => eq_nat n1 m1 - end. - -Theorem eq_nat_refl n : eq_nat n n. -Proof. - induction n; simpl; auto. -Qed. - -(** [eq] restricted to [nat] and [eq_nat] are equivalent *) - -Theorem eq_nat_is_eq n m : eq_nat n m <-> n = m. -Proof. - split. - - revert m; induction n; intro m; destruct m; simpl; contradiction || auto. - - intros <-; apply eq_nat_refl. -Qed. - -Lemma eq_eq_nat n m : n = m -> eq_nat n m. -Proof. - apply eq_nat_is_eq. -Qed. - -Lemma eq_nat_eq n m : eq_nat n m -> n = m. -Proof. - apply eq_nat_is_eq. -Qed. - -Theorem eq_nat_elim : - forall n (P:nat -> Prop), P n -> forall m, eq_nat n m -> P m. -Proof. - intros n P ? m ?; replace m with n; [ | apply eq_nat_eq ]; assumption. -Qed. - -Theorem eq_nat_decide : forall n m, {eq_nat n m} + {~ eq_nat n m}. -Proof. - intro n; induction n as [|n IHn]; intro m; destruct m; simpl. - - left; trivial. - - right; intro; trivial. - - right; intro; trivial. - - apply IHn. -Defined. diff --git a/stdlib/theories/Arith/Euclid.v b/stdlib/theories/Arith/Euclid.v deleted file mode 100644 index 4ca69e555082..000000000000 --- a/stdlib/theories/Arith/Euclid.v +++ /dev/null @@ -1,56 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* r -> a = q * b + r -> diveucl a b. - -Lemma eucl_dev : forall n, n > 0 -> forall m:nat, diveucl m n. -Proof. - intros n H m; induction m as (m,H0) using gt_wf_rec. - destruct (le_gt_dec n m) as [Hlebn|Hgtbn]. - - destruct (H0 (m - n)) as (q,r,Hge0,Heq); [ apply Nat.sub_lt; auto | ]. - apply divex with (S q) r; trivial. - simpl; rewrite <- Nat.add_assoc, <- Heq, Nat.add_comm, Nat.sub_add; trivial. - - apply divex with 0 m; simpl; trivial. -Defined. - -Lemma quotient : - forall n, - n > 0 -> - forall m:nat, {q : nat | exists r : nat, m = q * n + r /\ n > r}. -Proof. - intros n H m; induction m as (m,H0) using gt_wf_rec. - destruct (le_gt_dec n m) as [Hlebn|Hgtbn]. - - destruct (H0 (m - n)) as (q & Hq); [ apply Nat.sub_lt; auto | ]. - exists (S q); destruct Hq as (r & Heq & Hgt); exists r; split; trivial. - simpl; rewrite <- Nat.add_assoc, <- Heq, Nat.add_comm, Nat.sub_add; trivial. - - exists 0; exists m; simpl; auto. -Defined. - -Lemma modulo : - forall n, - n > 0 -> - forall m:nat, {r : nat | exists q : nat, m = q * n + r /\ n > r}. -Proof. - intros n H m; induction m as (m,H0) using gt_wf_rec. - destruct (le_gt_dec n m) as [Hlebn|Hgtbn]. - - destruct (H0 (m - n)) as (r & Hr); [ apply Nat.sub_lt; auto | ]. - exists r; destruct Hr as (q & Heq & Hgt); exists (S q); split; trivial. - simpl; rewrite <- Nat.add_assoc, <- Heq, Nat.add_comm, Nat.sub_add; trivial. - - exists m; exists 0; simpl; auto. -Defined. diff --git a/stdlib/theories/Arith/Factorial.v b/stdlib/theories/Arith/Factorial.v deleted file mode 100644 index c8ea17ca7947..000000000000 --- a/stdlib/theories/Arith/Factorial.v +++ /dev/null @@ -1,42 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* 1 - | S n => S n * fact n - end. - -Arguments fact n%_nat. - -Lemma lt_O_fact n : 0 < fact n. -Proof. - induction n; simpl; auto. - apply Nat.lt_lt_add_r; assumption. -Qed. - -Lemma fact_neq_0 n : fact n <> 0. -Proof. - apply Nat.neq_0_lt_0, lt_O_fact. -Qed. - -Lemma fact_le n m : n <= m -> fact n <= fact m. -Proof. - induction 1 as [|m ?]. - - apply le_n. - - simpl. transitivity (fact m). - + trivial. - + apply Nat.le_add_r. -Qed. diff --git a/stdlib/theories/Arith/PeanoNat.v b/stdlib/theories/Arith/PeanoNat.v deleted file mode 100644 index 556ae52d5eb3..000000000000 --- a/stdlib/theories/Arith/PeanoNat.v +++ /dev/null @@ -1,1367 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* eq) S. -#[global] Program Instance pred_wd : Proper (eq==>eq) pred. -#[global] Program Instance add_wd : Proper (eq==>eq==>eq) plus. -#[global] Program Instance sub_wd : Proper (eq==>eq==>eq) minus. -#[global] Program Instance mul_wd : Proper (eq==>eq==>eq) mult. -#[global] Program Instance pow_wd : Proper (eq==>eq==>eq) pow. -#[global] Program Instance div_wd : Proper (eq==>eq==>eq) div. -#[global] Program Instance mod_wd : Proper (eq==>eq==>eq) modulo. -#[global] Program Instance lt_wd : Proper (eq==>eq==>iff) lt. -#[global] Program Instance testbit_wd : Proper (eq==>eq==>eq) testbit. - -(** Bi-directional induction. *) - -Theorem bi_induction : - forall A : nat -> Prop, Proper (eq==>iff) A -> - A 0 -> (forall n : nat, A n <-> A (S n)) -> forall n : nat, A n. -Proof. - intros A A_wd A0 AS; apply nat_ind. - - assumption. - - intros; now apply -> AS. -Qed. - -(** Recursion function *) - -Definition recursion {A} : A -> (nat -> A -> A) -> nat -> A := - nat_rect (fun _ => A). - -#[global] Instance recursion_wd {A} (Aeq : relation A) : - Proper (Aeq ==> (eq==>Aeq==>Aeq) ==> eq ==> Aeq) recursion. -Proof. - intros a a' Ha f f' Hf n n' <-. - induction n; simpl; auto. - apply Hf; auto. -Qed. - -Theorem recursion_0 : - forall {A} (a : A) (f : nat -> A -> A), recursion a f 0 = a. -Proof. reflexivity. Qed. - -Theorem recursion_succ : - forall {A} (Aeq : relation A) (a : A) (f : nat -> A -> A), - Aeq a a -> Proper (eq==>Aeq==>Aeq) f -> - forall n : nat, Aeq (recursion a f (S n)) (f n (recursion a f n)). -Proof. - unfold Proper, respectful in *. - intros A Aeq a f ? ? n. - induction n; simpl; auto. -Qed. - -(** ** Remaining constants not defined in Stdlib.Init.Nat *) - -(** NB: Aliasing [le] is mandatory, since only a Definition can implement - an interface Parameter... *) - -Definition eq := @Logic.eq nat. -Definition le := Peano.le. -Definition lt := Peano.lt. - -(** ** Basic specifications : pred add sub mul *) - -Lemma pred_succ n : pred (S n) = n. -Proof. reflexivity. Qed. - -Lemma pred_0 : pred 0 = 0. -Proof. reflexivity. Qed. - -Lemma one_succ : 1 = S 0. -Proof. reflexivity. Qed. - -Lemma two_succ : 2 = S 1. -Proof. reflexivity. Qed. - -Lemma add_0_l n : 0 + n = n. -Proof. reflexivity. Qed. - -Lemma add_succ_l n m : (S n) + m = S (n + m). -Proof. reflexivity. Qed. - -Lemma sub_0_r n : n - 0 = n. -Proof. now destruct n. Qed. - -Lemma sub_succ_r n m : n - (S m) = pred (n - m). -Proof. - revert m; induction n; intro m; destruct m; simpl; auto. - apply sub_0_r. -Qed. - -Lemma mul_0_l n : 0 * n = 0. -Proof. reflexivity. Qed. - -Lemma mul_succ_l n m : S n * m = n * m + m. -Proof. - assert (succ_r : forall x y, x+S y = S(x+y)) by now intro x; induction x. - assert (comm : forall x y, x+y = y+x). - { intro x; induction x; simpl; auto. - intros; rewrite succ_r; now f_equal. } - now rewrite comm. -Qed. - -Lemma lt_succ_r n m : n < S m <-> n <= m. -Proof. - split. - - apply Peano.le_S_n. - - induction 1; auto. -Qed. - -(** ** Boolean comparisons *) - -Lemma eqb_eq n m : eqb n m = true <-> n = m. -Proof. - revert m. - induction n as [|n IHn]; intro m; destruct m; simpl; rewrite ?IHn; split; try easy. - - now intros ->. - - now injection 1. -Qed. - -#[global] -Instance Decidable_eq_nat : forall (x y : nat), Decidable (eq x y) := { - Decidable_spec := Nat.eqb_eq x y -}. - -Lemma leb_le n m : (n <=? m) = true <-> n <= m. -Proof. - revert m. - induction n as [|n IHn]; intro m; destruct m; simpl. - - now split. - - split; trivial. - intros; apply Peano.le_0_n. - - now split. - - rewrite IHn; split. - + apply Peano.le_n_S. - + apply Peano.le_S_n. -Qed. - -#[global] -Instance Decidable_le_nat : forall (x y : nat), Decidable (x <= y) := { - Decidable_spec := Nat.leb_le x y -}. - -Lemma ltb_lt n m : (n n < m. -Proof. apply leb_le. Qed. - -(* Note: Decidable_lt_nat, Decidable_ge_nat, Decidable_gt_nat are not required, - because lt, ge and gt are defined based on le in a way which type class - resolution seems to understand. *) - -(** ** Decidability of equality over [nat]. *) - -Lemma eq_dec : forall n m : nat, {n = m} + {n <> m}. -Proof. - intro n; induction n as [|n IHn]; intro m; destruct m as [|m]. - - now left. - - now right. - - now right. - - destruct (IHn m); [left|right]; auto. -Defined. - -(** ** Ternary comparison *) - -(** With [nat], it would be easier to prove first [compare_spec], - then the properties below. But then we wouldn't be able to - benefit from functor [BoolOrderFacts] *) - -Lemma compare_eq_iff n m : (n ?= m) = Eq <-> n = m. -Proof. - revert m; induction n as [|n IHn]; intro m; destruct m; - simpl; rewrite ?IHn; split; auto; easy. -Qed. - -Lemma compare_lt_iff n m : (n ?= m) = Lt <-> n < m. -Proof. - revert m; induction n as [|n IHn]; intro m; destruct m; - simpl; rewrite ?IHn; split; try easy. - - intros _; apply Peano.le_n_S, Peano.le_0_n. - - apply Peano.le_n_S. - - apply Peano.le_S_n. -Qed. - -Lemma compare_le_iff n m : (n ?= m) <> Gt <-> n <= m. -Proof. - revert m; induction n as [|n IHn]; intro m; destruct m; simpl; rewrite ?IHn. - - now split. - - split; intros. - + apply Peano.le_0_n. - + easy. - - split. - + now destruct 1. - + inversion 1. - - split; intros. - + now apply Peano.le_n_S. - + now apply Peano.le_S_n. -Qed. - -Lemma compare_antisym n m : (m ?= n) = CompOpp (n ?= m). -Proof. revert m; induction n; intro m; destruct m; simpl; trivial. Qed. - -Lemma compare_succ n m : (S n ?= S m) = (n ?= m). -Proof. reflexivity. Qed. - - -(** ** Minimum, maximum *) - -Lemma max_l : forall n m, m <= n -> max n m = n. -Proof. exact Peano.max_l. Qed. - -Lemma max_r : forall n m, n <= m -> max n m = m. -Proof. exact Peano.max_r. Qed. - -Lemma min_l : forall n m, n <= m -> min n m = n. -Proof. exact Peano.min_l. Qed. - -Lemma min_r : forall n m, m <= n -> min n m = m. -Proof. exact Peano.min_r. Qed. - -(** Some more advanced properties of comparison and orders, - including [compare_spec] and [lt_irrefl] and [lt_eq_cases]. *) - -Include BoolOrderFacts. - -(** We can now derive all properties of basic functions and orders, - and use these properties for proving the specs of more advanced - functions. *) - -Include NBasicProp <+ UsualMinMaxLogicalProperties <+ UsualMinMaxDecProperties. - -Lemma strong_induction_le (A : nat -> Prop) : - A 0 -> (forall n, (forall m, m <= n -> A m) -> A (S n)) -> forall n, A n. -Proof. apply Private_strong_induction_le; intros x y ->; reflexivity. Qed. - -(** ** Power *) - -Lemma pow_neg_r a b : b<0 -> a^b = 0. -Proof. inversion 1. Qed. - -Lemma pow_0_r a : a^0 = 1. -Proof. reflexivity. Qed. - -Lemma pow_succ_r a b : 0<=b -> a^(S b) = a * a^b. -Proof. reflexivity. Qed. - -(** ** Square *) - -Lemma square_spec n : square n = n * n. -Proof. reflexivity. Qed. - -(** ** Parity *) - -Definition Even n := exists m, n = 2*m. -Definition Odd n := exists m, n = 2*m+1. - -Module Private_Parity. - -Lemma Even_0 : Even 0. -Proof. exists 0; reflexivity. Qed. - -Lemma Even_1 : ~ Even 1. -Proof. - intros ([|], H); try discriminate. - simpl in H. - now rewrite <- plus_n_Sm in H. -Qed. - -Lemma Even_2 n : Even n <-> Even (S (S n)). -Proof. - split; intros (m,H). - - exists (S m). - rewrite H; simpl. - now rewrite plus_n_Sm. - - destruct m as [|m]; try discriminate. - exists m. - simpl in H; rewrite <- plus_n_Sm in H. - now inversion H. -Qed. - -Lemma Odd_0 : ~ Odd 0. -Proof. now intros ([|], H). Qed. - -Lemma Odd_1 : Odd 1. -Proof. exists 0; reflexivity. Qed. - -Lemma Odd_2 n : Odd n <-> Odd (S (S n)). -Proof. - split; intros (m,H). - - exists (S m). - rewrite H. simpl. - now rewrite <- (plus_n_Sm m). - - destruct m as [|m]; try discriminate. - exists m. - simpl in H; rewrite <- plus_n_Sm in H. - inversion H; simpl. - now rewrite <- !plus_n_Sm, <- !plus_n_O. -Qed. - -End Private_Parity. -Import Private_Parity. - -Lemma even_spec : forall n, even n = true <-> Even n. -Proof. - fix even_spec 1. - intro n; destruct n as [|[|n]]; simpl. - - split; [ intros; apply Even_0 | trivial ]. - - split; [ discriminate | intro H; elim (Even_1 H) ]. - - rewrite even_spec. - apply Even_2. -Qed. - -Lemma odd_spec : forall n, odd n = true <-> Odd n. -Proof. - unfold odd. - fix odd_spec 1. - intro n; destruct n as [|[|n]]; simpl. - - split; [ discriminate | intro H; elim (Odd_0 H) ]. - - split; [ intros; apply Odd_1 | trivial ]. - - rewrite odd_spec. - apply Odd_2. -Qed. - -(** ** Division *) - -Lemma divmod_spec : forall x y q u, u <= y -> - let (q',u') := divmod x y q u in - x + (S y)*q + (y-u) = (S y)*q' + (y-u') /\ u' <= y. -Proof. - intro x; induction x as [|x IHx]. - - simpl; intuition. - - intros y q u H. - destruct u as [|u]; simpl divmod. - + generalize (IHx y (S q) y (le_n y)). - destruct divmod as (q',u'). - intros (EQ,LE); split; trivial. - rewrite <- EQ, sub_0_r, sub_diag, add_0_r. - now rewrite !add_succ_l, <- add_succ_r, <- add_assoc, mul_succ_r. - + assert (H' : u <= y). - { apply le_trans with (S u); trivial. - do 2 constructor. } - generalize (IHx y q u H'). - destruct divmod as (q',u'). - intros (EQ,LE); split; trivial. - rewrite <- EQ, !add_succ_l, <- add_succ_r; f_equal. - now rewrite <- sub_succ_l. -Qed. - -Lemma div_mod_eq x y : x = y*(x/y) + x mod y. -Proof. - destruct y as [|y]; [reflexivity | ]. - unfold div, modulo. - generalize (divmod_spec x y 0 y (le_n y)). - destruct divmod as (q,u). - intros (U,V). - simpl in *. - now rewrite mul_0_r, sub_diag, !add_0_r in U. -Qed. - -(** The [y <> 0] hypothesis is needed to fit in [NAxiomsSig]. *) -Lemma div_mod x y : y <> 0 -> x = y*(x/y) + x mod y. -Proof. - intros _; apply div_mod_eq. -Qed. - -Lemma mod_bound_pos x y : 0<=x -> 0 0 <= x mod y < y. -Proof. - intros Hx Hy. - split. - - apply le_0_l. - - destruct y; [ now elim Hy | clear Hy ]. - unfold modulo. - apply lt_succ_r, le_sub_l. -Qed. - -(** ** Square root *) - -Lemma sqrt_iter_spec : forall k p q r, - q = p+p -> r<=q -> - let s := sqrt_iter k p q r in - s*s <= k + p*p + (q - r) < (S s)*(S s). -Proof. - intro k; induction k as [|k IHk]. - - (* k = 0 *) - simpl; intros p q r Hq Hr. - split. - + apply le_add_r. - + apply lt_succ_r. - rewrite mul_succ_r, add_assoc, (add_comm p), <- add_assoc. - apply add_le_mono_l. - rewrite <- Hq. - apply le_sub_l. - - (* k = S k' *) - intros p q r; destruct r as [|r]. - + (* r = 0 *) - intros Hq _. - replace (S k + p*p + (q-0)) with (k + (S p)*(S p) + (S (S q) - S (S q))). - 2:{ rewrite sub_diag, sub_0_r, add_0_r. simpl. - rewrite add_succ_r; f_equal. rewrite <- add_assoc; f_equal. - rewrite mul_succ_r, (add_comm p), <- add_assoc. now f_equal. } - apply IHk; simpl. - * now rewrite add_succ_r, Hq. - * apply le_n. - + (* r = S r' *) - intros Hq Hr. - replace (S k + p*p + (q-S r)) with (k + p*p + (q - r)) - by (simpl; rewrite <- add_succ_r; f_equal; rewrite <- sub_succ_l; trivial). - apply IHk; trivial. - apply le_trans with (S r); trivial. - do 2 constructor. -Qed. - -Lemma sqrt_specif n : (sqrt n)*(sqrt n) <= n < S (sqrt n) * S (sqrt n). -Proof. - set (s:=sqrt n). - replace n with (n + 0*0 + (0-0)). - - apply sqrt_iter_spec; auto. - - simpl. - now rewrite !add_0_r. -Qed. - -Definition sqrt_spec a (Ha:0<=a) := sqrt_specif a. - -Lemma sqrt_neg a : a<0 -> sqrt a = 0. -Proof. inversion 1. Qed. - -(** ** Logarithm *) - -Lemma log2_iter_spec : forall k p q r, - 2^(S p) = q + S r -> r < 2^p -> - let s := log2_iter k p q r in - 2^s <= k + q < 2^(S s). -Proof. - intro k; induction k as [|k IHk]. - - (* k = 0 *) - intros p q r EQ LT. - simpl log2_iter; cbv zeta. - split. - + rewrite add_0_l, (add_le_mono_l _ _ (2^p)). - simpl pow in EQ. - rewrite add_0_r in EQ; rewrite EQ, add_comm. - apply add_le_mono_r, LT. - + rewrite EQ, add_comm. - apply add_lt_mono_l. - apply lt_succ_r, le_0_l. - - (* k = S k' *) - intros p q r EQ LT. - destruct r as [|r]. - + (* r = 0 *) - rewrite add_succ_r, add_0_r in EQ. - rewrite add_succ_l, <- add_succ_r. - apply IHk. - * rewrite <- EQ. - remember (S p) as p'; simpl. - now rewrite add_0_r. - * rewrite EQ; constructor. - + (* r = S r' *) - rewrite add_succ_l, <- add_succ_r. - apply IHk. - * now rewrite add_succ_l, <- add_succ_r. - * apply le_lt_trans with (S r); trivial. - do 2 constructor. -Qed. - -Lemma log2_spec n : 0 - 2^(log2 n) <= n < 2^(S (log2 n)). -Proof. - intros. - set (s:=log2 n). - replace n with (pred n + 1). - - apply log2_iter_spec; auto. - - rewrite add_1_r. - apply succ_pred. - now apply neq_sym, lt_neq. -Qed. - -Lemma log2_nonpos n : n<=0 -> log2 n = 0. -Proof. inversion 1; now subst. Qed. - -(** ** Properties of [iter] *) - -Lemma iter_swap_gen A B (f:A -> B) (g:A -> A) (h:B -> B) : - (forall a, f (g a) = h (f a)) -> forall n a, - f (iter n g a) = iter n h (f a). -Proof. - intros H n a. - induction n as [|n Hn]. - - reflexivity. - - simpl. rewrite H, Hn. reflexivity. -Qed. - -Lemma iter_swap : - forall n (A:Type) (f:A -> A) (x:A), - iter n f (f x) = f (iter n f x). -Proof. - intros. symmetry. now apply iter_swap_gen. -Qed. - -Lemma iter_succ : - forall n (A:Type) (f:A -> A) (x:A), - iter (S n) f x = f (iter n f x). -Proof. - reflexivity. -Qed. - -Lemma iter_succ_r : - forall n (A:Type) (f:A -> A) (x:A), - iter (S n) f x = iter n f (f x). -Proof. - intros; now rewrite iter_succ, iter_swap. -Qed. - -Lemma iter_add : - forall p q (A:Type) (f:A -> A) (x:A), - iter (p+q) f x = iter p f (iter q f x). -Proof. - intro p. induction p as [|p IHp]. - - reflexivity. - - intros q A f x. simpl. now rewrite IHp. -Qed. - -Lemma iter_ind (A:Type) (f:A -> A) (a:A) (P:nat -> A -> Prop) : - P 0 a -> - (forall n a', P n a' -> P (S n) (f a')) -> - forall n, P n (iter n f a). -Proof. - intros H0 HS n. induction n as [|n Hn]. - - exact H0. - - apply HS. exact Hn. -Qed. - -Lemma iter_rect (A:Type) (f:A -> A) (a:A) (P:nat -> A -> Type) : - P 0 a -> - (forall n a', P n a' -> P (S n) (f a')) -> - forall n, P n (iter n f a). -Proof. - intros H0 HS n. induction n as [|n Hn]. - - exact H0. - - apply HS. exact Hn. -Defined. - -Lemma iter_invariant : - forall (n:nat) (A:Type) (f:A -> A) (Inv:A -> Prop), - (forall x:A, Inv x -> Inv (f x)) -> - forall x:A, Inv x -> Inv (iter n f x). -Proof. - intros; apply iter_ind; trivial. -Qed. - -(** ** Gcd *) - -Definition divide x y := exists z, y=z*x. -Notation "( x | y )" := (divide x y) (at level 0) : nat_scope. - -Lemma gcd_divide : forall a b, (gcd a b | a) /\ (gcd a b | b). -Proof. - fix gcd_divide 1. - intros [|a] b; simpl. - - split. - + now exists 0. - + exists 1; simpl. - now rewrite <- plus_n_O. - - fold (b mod (S a)). - destruct (gcd_divide (b mod (S a)) (S a)) as (H,H'). - set (a':=S a) in *. - split; auto. - rewrite (div_mod_eq b a') at 2. - destruct H as (u,Hu), H' as (v,Hv). - rewrite mul_comm. - exists ((b/a')*v + u). - rewrite mul_add_distr_r. - now rewrite <- mul_assoc, <- Hv, <- Hu. -Qed. - -Lemma gcd_divide_l : forall a b, (gcd a b | a). -Proof. apply gcd_divide. Qed. - -Lemma gcd_divide_r : forall a b, (gcd a b | b). -Proof. apply gcd_divide. Qed. - -Lemma gcd_greatest : forall a b c, (c|a) -> (c|b) -> (c|gcd a b). -Proof. - fix gcd_greatest 1. - intros [|a] b; simpl; auto. - fold (b mod (S a)). - intros c H H'. - apply gcd_greatest; auto. - set (a':=S a) in *. - rewrite (div_mod_eq b a') in H'. - destruct H as (u,Hu), H' as (v,Hv). - exists (v - (b/a')*u). - rewrite mul_comm in Hv. - rewrite mul_sub_distr_r, <- Hv, <- mul_assoc, <-Hu. - now rewrite add_comm, add_sub. -Qed. - -Lemma gcd_nonneg a b : 0<=gcd a b. -Proof. apply le_0_l. Qed. - - -(** ** Bitwise operations *) - -Definition double_S : forall n, double (S n) = S (S (double n)) - := fun n => add_succ_r (S n) n. - -Definition double_add : forall n m, double (n + m) = double n + double m - := fun n m => add_shuffle1 n m n m. - -Lemma double_twice : forall n, double n = 2*n. -Proof. simpl; intros; now rewrite add_0_r. Qed. - -(* We use a Module Type to hide intermediate lemmas we will get from Natural - anyway. *) -Module Type PrivateBitwiseSpec. - (* needed to implement Numbers.NatInt.NZBitsSpec *) - Parameter testbit_odd_0 : forall a : nat, testbit (add (mul 2 a) 1) 0 = true. - Parameter testbit_even_0 : forall a : nat, testbit (mul 2 a) 0 = false. - Parameter testbit_odd_succ : forall a n : nat, le 0 n -> - testbit (add (mul 2 a) 1) (succ n) = testbit a n. - Parameter testbit_even_succ : forall a n : nat, le 0 n -> - testbit (mul 2 a) (succ n) = testbit a n. - Parameter testbit_neg_r : forall a n : nat, lt n 0 -> testbit a n = false. - Parameter shiftr_spec : forall a n m : nat, le 0 m -> - testbit (shiftr a n) m = testbit a (add m n). - Parameter shiftl_spec_high : - forall a n m : nat, le 0 m -> - le n m -> testbit (shiftl a n) m = testbit a (sub m n). - Parameter shiftl_spec_low : - forall a n m : nat, lt m n -> testbit (shiftl a n) m = false. - Parameter land_spec : - forall a b n : nat, testbit (land a b) n = testbit a n && testbit b n. - Parameter lor_spec : - forall a b n : nat, testbit (lor a b) n = testbit a n || testbit b n. - Parameter ldiff_spec : - forall a b n : nat, - testbit (ldiff a b) n = testbit a n && negb (testbit b n). - Parameter lxor_spec : - forall a b n : nat, testbit (lxor a b) n = xorb (testbit a n) (testbit b n). - Parameter div2_spec : - forall a : nat, eq (div2 a) (shiftr a 1). - (* not yet generalized to Numbers.Natural.Abstract *) - Parameter div2_double : forall n, div2 (2*n) = n. - Parameter div2_succ_double : forall n, div2 (S (2*n)) = n. - Parameter div2_bitwise : forall op n a b, - div2 (bitwise op (S n) a b) = bitwise op n (div2 a) (div2 b). - Parameter odd_bitwise : forall op n a b, - odd (bitwise op (S n) a b) = op (odd a) (odd b). - Parameter testbit_bitwise_1 : forall op, (forall b, op false b = false) -> - forall n m a b, a<=n -> - testbit (bitwise op n a b) m = op (testbit a m) (testbit b m). - Parameter testbit_bitwise_2 : forall op, op false false = false -> - forall n m a b, a<=n -> b<=n -> - testbit (bitwise op n a b) m = op (testbit a m) (testbit b m). -End PrivateBitwiseSpec. - -(* The following module has to be included (it semmes that importing it is not - enough to implement NZBitsSpec), therefore it has to be "Private", otherwise, - its lemmas will appear twice in [Search]es *) - -Module PrivateImplementsBitwiseSpec : PrivateBitwiseSpec. - -Lemma div2_double n : div2 (2*n) = n. -Proof. - induction n; trivial. - simpl mul. - rewrite add_succ_r; simpl. - now f_equal. -Qed. - -Lemma div2_succ_double n : div2 (S (2*n)) = n. -Proof. - induction n; trivial. - simpl; f_equal. - now rewrite add_succ_r. -Qed. - -Lemma le_div2 n : div2 (S n) <= n. -Proof. - revert n. - fix le_div2 1. - intro n; destruct n as [|n]; simpl; trivial. - apply lt_succ_r. - destruct n; [simpl|]; trivial. - now constructor. -Qed. - -Lemma lt_div2 n : 0 < n -> div2 n < n. -Proof. - destruct n. - - inversion 1. - - intros _; apply lt_succ_r, le_div2. -Qed. - -Lemma div2_decr a n : a <= S n -> div2 a <= n. -Proof. - destruct a as [|a]; intros H. - - simpl; apply le_0_l. - - apply succ_le_mono in H. - apply le_trans with a; [ apply le_div2 | trivial ]. -Qed. - -(* needed to implement Stdlib.Numbers.NatInt.NZBitsSpec *) -Lemma testbit_0_l : forall n, testbit 0 n = false. -Proof. now intro n; induction n. Qed. - -(* needed to implement Stdlib.Numbers.NatInt.NZBitsSpec *) -Lemma testbit_odd_0 a : testbit (2*a+1) 0 = true. -Proof. unfold testbit; rewrite odd_spec; now exists a. Qed. - -(* needed to implement Stdlib.Numbers.NatInt.NZBitsSpec *) -Lemma testbit_even_0 a : testbit (2*a) 0 = false. -Proof. - unfold testbit, odd. - rewrite (proj2 (even_spec _)); trivial. - now exists a. -Qed. - -Lemma testbit_odd_succ' a n : testbit (2*a+1) (S n) = testbit a n. -Proof. - unfold testbit; fold testbit. - rewrite add_1_r; f_equal. - apply div2_succ_double. -Qed. - -Lemma testbit_even_succ' a n : testbit (2*a) (S n) = testbit a n. -Proof. unfold testbit; fold testbit; f_equal; apply div2_double. Qed. - -Lemma shiftr_specif : forall a n m, - testbit (shiftr a n) m = testbit a (m+n). -Proof. - intros a n; induction n as [|n IHn]; intros m. - - now rewrite add_0_r. - - now rewrite add_succ_r, <- add_succ_l, <- IHn. -Qed. - -Lemma shiftl_specif_high : forall a n m, n<=m -> - testbit (shiftl a n) m = testbit a (m-n). -Proof. - intros a n; induction n as [|n IHn]; intros m H; [ trivial | ]. - - now rewrite sub_0_r. - - destruct m; [ inversion H | ]. - simpl; apply succ_le_mono in H. - change (shiftl a (S n)) with (double (shiftl a n)). - rewrite double_twice, div2_double. - now apply IHn. -Qed. - -(* needed to implement Stdlib.Numbers.NatInt.NZBitsSpec *) -Lemma shiftl_spec_low : forall a n m, m - testbit (shiftl a n) m = false. -Proof. - intros a n; induction n as [|n IHn]; intros m H; [ inversion H | ]. - change (shiftl a (S n)) with (double (shiftl a n)). - destruct m; simpl. - - unfold odd; apply negb_false_iff. - apply even_spec. - exists (shiftl a n). - apply double_twice. - - rewrite double_twice, div2_double. - apply IHn. - now apply succ_le_mono. -Qed. - -(* not yet generalized, part of the interface at this point *) -Lemma div2_bitwise : forall op n a b, - div2 (bitwise op (S n) a b) = bitwise op n (div2 a) (div2 b). -Proof. - intros op n a b; unfold bitwise; fold bitwise. - destruct (op (odd a) (odd b)). - - now rewrite div2_succ_double. - - now rewrite add_0_l, div2_double. -Qed. - -(* not yet generalized, part of the interface at this point *) -Lemma odd_bitwise : forall op n a b, - odd (bitwise op (S n) a b) = op (odd a) (odd b). -Proof. - intros op n a b; unfold bitwise; fold bitwise. - destruct (op (odd a) (odd b)). - - apply odd_spec. - rewrite add_comm; eexists; eauto. - - unfold odd; apply negb_false_iff. - apply even_spec. - rewrite add_0_l; eexists; eauto. -Qed. - -(* not yet generalized, part of the interface at this point *) -Lemma testbit_bitwise_1 : forall op, (forall b, op false b = false) -> - forall n m a b, a<=n -> - testbit (bitwise op n a b) m = op (testbit a m) (testbit b m). -Proof. - intros op Hop. - intro n; induction n as [|n IHn]; intros m a b Ha. - - simpl; inversion Ha; subst. - now rewrite testbit_0_l. - - destruct m. - + apply odd_bitwise. - + unfold testbit; fold testbit; rewrite div2_bitwise. - apply IHn; now apply div2_decr. -Qed. - -(* not yet generalized, part of the interface at this point *) -Lemma testbit_bitwise_2 : forall op, op false false = false -> - forall n m a b, a<=n -> b<=n -> - testbit (bitwise op n a b) m = op (testbit a m) (testbit b m). -Proof. - intros op Hop. - intro n; induction n as [|n IHn]; intros m a b Ha Hb. - - simpl; inversion Ha; inversion Hb; subst. - now rewrite testbit_0_l. - - destruct m. - + apply odd_bitwise. - + unfold testbit; fold testbit; rewrite div2_bitwise. - apply IHn; now apply div2_decr. -Qed. - -(* needed to implement Stdlib.Numbers.NatInt.NZBitsSpec *) -Lemma land_spec a b n : - testbit (land a b) n = testbit a n && testbit b n. -Proof. unfold land; apply testbit_bitwise_1; trivial. Qed. - -(* needed to implement Stdlib.Numbers.NatInt.NZBitsSpec *) -Lemma ldiff_spec a b n : - testbit (ldiff a b) n = testbit a n && negb (testbit b n). -Proof. unfold ldiff; apply testbit_bitwise_1; trivial. Qed. - -(* needed to implement Stdlib.Numbers.NatInt.NZBitsSpec *) -Lemma lor_spec a b n : - testbit (lor a b) n = testbit a n || testbit b n. -Proof. - unfold lor; apply testbit_bitwise_2. - - trivial. - - destruct (compare_spec a b) as [H|H|H]. - + rewrite max_l; subst; trivial. - + now apply lt_le_incl in H; rewrite max_r. - + now apply lt_le_incl in H; rewrite max_l. - - destruct (compare_spec a b) as [H|H|H]. - + rewrite max_r; subst; trivial. - + now apply lt_le_incl in H; rewrite max_r. - + now apply lt_le_incl in H; rewrite max_l. -Qed. - -(* needed to implement Stdlib.Numbers.NatInt.NZBitsSpec *) -Lemma lxor_spec a b n : - testbit (lxor a b) n = xorb (testbit a n) (testbit b n). -Proof. - unfold lxor; apply testbit_bitwise_2. - - trivial. - - destruct (compare_spec a b) as [H|H|H]. - + rewrite max_l; subst; trivial. - + now apply lt_le_incl in H; rewrite max_r. - + now apply lt_le_incl in H; rewrite max_l. - - destruct (compare_spec a b) as [H|H|H]. - + rewrite max_r; subst; trivial. - + now apply lt_le_incl in H; rewrite max_r. - + now apply lt_le_incl in H; rewrite max_l. -Qed. - -(* needed to implement Stdlib.Numbers.NatInt.NZBitsSpec *) -Lemma div2_spec a : div2 a = shiftr a 1. -Proof. reflexivity. Qed. - -(** Aliases with extra dummy hypothesis, to fulfil the interface *) - -(* needed to implement Stdlib.Numbers.NatInt.NZBitsSpec *) -Definition testbit_odd_succ a n (_:0<=n) := testbit_odd_succ' a n. - -(* needed to implement Stdlib.Numbers.NatInt.NZBitsSpec *) -Definition testbit_even_succ a n (_:0<=n) := testbit_even_succ' a n. - -(* needed to implement Stdlib.Numbers.NatInt.NZBitsSpec *) -Lemma testbit_neg_r a n (H:n<0) : testbit a n = false. -Proof. inversion H. Qed. - -(* needed to implement Stdlib.Numbers.NatInt.NZBitsSpec *) -Definition shiftl_spec_high a n m (_:0<=m) := shiftl_specif_high a n m. - -(* needed to implement Stdlib.Numbers.NatInt.NZBitsSpec *) -Definition shiftr_spec a n m (_:0<=m) := shiftr_specif a n m. -End PrivateImplementsBitwiseSpec. -Include PrivateImplementsBitwiseSpec. - -Lemma div_0_r a : a / 0 = 0. -Proof. reflexivity. Qed. - -Lemma mod_0_r a : a mod 0 = a. -Proof. reflexivity. Qed. - -(** Properties of advanced functions (pow, sqrt, log2, ...) *) - -Include NExtraPreProp <+ NExtraProp0. - -Lemma binary_induction (A : nat -> Prop) : - A 0 -> (forall n, A n -> A (2 * n)) -> (forall n, A n -> A (2 * n + 1)) - -> forall n, A n. -Proof. apply Private_binary_induction; intros x y ->; reflexivity. Qed. - -(** Properties of tail-recursive addition and multiplication *) - -Lemma tail_add_spec n m : tail_add n m = n + m. -Proof. - revert m; induction n as [|n IH]; simpl; trivial; intros. - now rewrite IH, add_succ_r. -Qed. - -Lemma tail_addmul_spec r n m : tail_addmul r n m = r + n * m. -Proof. - revert m r; induction n as [| n IH]; simpl; trivial; intros. - rewrite IH, tail_add_spec. - rewrite add_assoc. - f_equal; apply add_comm. -Qed. - -Lemma tail_mul_spec n m : tail_mul n m = n * m. -Proof. unfold tail_mul; now rewrite tail_addmul_spec. Qed. - -(** Additional results about [Even] and [Odd] *) - -Definition Even_Odd_dec n : {Even n} + {Odd n}. -Proof. - induction n as [|n IHn]. - - left; apply Even_0. - - elim IHn; intros. - + right; apply Even_succ, Even_succ_succ; assumption. - + left; apply Odd_succ, Odd_succ_succ; assumption. -Defined. - -Lemma Even_add_split n m : - Even (n + m) -> Even n /\ Even m \/ Odd n /\ Odd m. -Proof. - rewrite <- ? even_spec, <- ? odd_spec, even_add; unfold odd; do 2 destruct even; auto. -Qed. - -Lemma Odd_add_split n m : - Odd (n + m) -> Odd n /\ Even m \/ Even n /\ Odd m. -Proof. - rewrite <- ? even_spec, <- ? odd_spec, odd_add; unfold odd; do 2 destruct even; auto. -Qed. - -Lemma Even_Even_add n m: Even n -> Even m -> Even (n + m). -Proof. rewrite <- ? even_spec, even_add; do 2 destruct even; auto. Qed. - -Lemma Odd_add_l n m : Odd n -> Even m -> Odd (n + m). -Proof. - rewrite <- ? even_spec, <- ? odd_spec, odd_add; unfold odd; do 2 destruct even; auto. -Qed. - -Lemma Odd_add_r n m : Even n -> Odd m -> Odd (n + m). -Proof. - rewrite <- ? even_spec, <- ? odd_spec, odd_add; unfold odd; do 2 destruct even; auto. -Qed. - -Lemma Odd_Odd_add n m : Odd n -> Odd m -> Even (n + m). -Proof. - rewrite <- ? even_spec, <- ? odd_spec, even_add; unfold odd; do 2 destruct even; auto. -Qed. - -Lemma Even_add_aux n m : - (Odd (n + m) <-> Odd n /\ Even m \/ Even n /\ Odd m) /\ - (Even (n + m) <-> Even n /\ Even m \/ Odd n /\ Odd m). -Proof. - split; split. - - apply Odd_add_split. - - intros [[HO HE]|[HE HO]]; [ apply Odd_add_l | apply Odd_add_r ]; assumption. - - apply Even_add_split. - - intros [[HO HE]|[HE HO]]; [ apply Even_Even_add | apply Odd_Odd_add ]; assumption. -Qed. - -Lemma Even_add_Even_inv_r n m : Even (n + m) -> Even n -> Even m. -Proof. rewrite <- ? even_spec, even_add; do 2 destruct even; auto. Qed. - -Lemma Even_add_Even_inv_l n m : Even (n + m) -> Even m -> Even n. -Proof. rewrite <- ? even_spec, even_add; do 2 destruct even; auto. Qed. - -Lemma Even_add_Odd_inv_r n m : Even (n + m) -> Odd n -> Odd m. -Proof. - rewrite <- ? even_spec, <- ? odd_spec, even_add; unfold odd; do 2 destruct even; auto. -Qed. - -Lemma Even_add_Odd_inv_l n m : Even (n + m) -> Odd m -> Odd n. -Proof. - rewrite <- ? even_spec, <- ? odd_spec, even_add; unfold odd; do 2 destruct even; auto. -Qed. - -Lemma Odd_add_Even_inv_l n m : Odd (n + m) -> Odd m -> Even n. -Proof. - rewrite <- ? even_spec, <- ? odd_spec, odd_add; unfold odd; do 2 destruct even; auto. -Qed. - -Lemma Odd_add_Even_inv_r n m : Odd (n + m) -> Odd n -> Even m. -Proof. - rewrite <- ? even_spec, <- ? odd_spec, odd_add; unfold odd; do 2 destruct even; auto. -Qed. - -Lemma Odd_add_Odd_inv_l n m : Odd (n + m) -> Even m -> Odd n. -Proof. - rewrite <- ? even_spec, <- ? odd_spec, odd_add; unfold odd; do 2 destruct even; auto. -Qed. - -Lemma Odd_add_Odd_inv_r n m : Odd (n + m) -> Even n -> Odd m. -Proof. - rewrite <- ? even_spec, <- ? odd_spec, odd_add; unfold odd; do 2 destruct even; auto. -Qed. - -Lemma Even_mul_aux n m : - (Odd (n * m) <-> Odd n /\ Odd m) /\ (Even (n * m) <-> Even n \/ Even m). -Proof. - rewrite <- ? even_spec, <- ? odd_spec, odd_mul, even_mul; unfold odd; do 2 destruct even; tauto. -Qed. - -Lemma Even_mul_l n m : Even n -> Even (n * m). -Proof. rewrite <- ? even_spec, even_mul; do 2 destruct even; auto. Qed. - -Lemma Even_mul_r n m : Even m -> Even (n * m). -Proof. rewrite <- ? even_spec, even_mul; do 2 destruct even; auto. Qed. - -Lemma Even_mul_inv_r n m : Even (n * m) -> Odd n -> Even m. -Proof. - rewrite <- ? even_spec, <- ? odd_spec, even_mul; unfold odd; do 2 destruct even; auto. -Qed. - -Lemma Even_mul_inv_l n m : Even (n * m) -> Odd m -> Even n. -Proof. - rewrite <- ? even_spec, <- ? odd_spec, even_mul; unfold odd; do 2 destruct even; auto. -Qed. - -Lemma Odd_mul n m : Odd n -> Odd m -> Odd (n * m). -Proof. rewrite <- ? odd_spec, odd_mul; unfold odd; do 2 destruct even; auto. Qed. - -Lemma Odd_mul_inv_l n m : Odd (n * m) -> Odd n. -Proof. rewrite <- ? odd_spec, odd_mul; unfold odd; do 2 destruct even; auto. Qed. - -Lemma Odd_mul_inv_r n m : Odd (n * m) -> Odd m. -Proof. rewrite <- ? odd_spec, odd_mul; unfold odd; do 2 destruct even; auto. Qed. - -Lemma Even_div2 n : Even n -> div2 n = div2 (S n). -Proof. intros [p ->]; rewrite div2_succ_double; apply div2_double. Qed. - -Lemma Odd_div2 n : Odd n -> S (div2 n) = div2 (S n). -Proof. - intros [p ->]; rewrite add_1_r, div2_succ_double; cbn. - f_equal; symmetry; apply div2_double. -Qed. - -Lemma div2_Even n : div2 n = div2 (S n) -> Even n. -Proof. - destruct (Even_or_Odd n) as [Ev|Od]; trivial. - apply Odd_div2 in Od; rewrite <- Od. - intro Od'; destruct (neq_succ_diag_r _ Od'). -Qed. - -Lemma div2_Odd n : S (div2 n) = div2 (S n) -> Odd n. -Proof. - destruct (Even_or_Odd n) as [Ev|Od]; trivial. - apply Even_div2 in Ev; rewrite <- Ev. - intro Ev'; symmetry in Ev'; destruct (neq_succ_diag_r _ Ev'). -Qed. - -Lemma Even_Odd_div2 n : - (Even n <-> div2 n = div2 (S n)) /\ (Odd n <-> S (div2 n) = div2 (S n)). -Proof. - split; split; [ apply Even_div2 | apply div2_Even | apply Odd_div2 | apply div2_Odd ]. -Qed. - -Lemma Even_Odd_double n : - (Even n <-> n = double (div2 n)) /\ (Odd n <-> n = S (double (div2 n))). -Proof. - revert n. - fix Even_Odd_double 1. - intros n; destruct n as [|[|n]]. - - (* n = 0 *) - split; split; intros H; [ reflexivity | apply Even_0 | apply Odd_0 in H as [] | inversion H ]. - - (* n = 1 *) - split; split; intros H; [ apply Even_1 in H as [] | inversion H | reflexivity | apply Odd_1 ]. - - (* n = (S (S n')) *) - destruct (Even_Odd_double n) as ((Ev,Ev'),(Od,Od')). - split; split; simpl div2; rewrite ? double_S, ? Even_succ_succ, ? Odd_succ_succ. - + intros; do 2 f_equal; auto. - + injection 1; auto. - + intros; do 2 f_equal; auto. - + injection 1; auto. -Qed. - -Lemma Even_double n : Even n -> n = double (div2 n). -Proof proj1 (proj1 (Even_Odd_double n)). - -Lemma double_Even n : n = double (div2 n) -> Even n. -Proof proj2 (proj1 (Even_Odd_double n)). - -Lemma Odd_double n : Odd n -> n = S (double (div2 n)). -Proof proj1 (proj2 (Even_Odd_double n)). - -Lemma double_Odd n : n = S (double (div2 n)) -> Odd n. -Proof proj2 (proj2 (Even_Odd_double n)). - -(** Inductive definition of even and odd *) -Inductive Even_alt : nat -> Prop := -| Even_alt_O : Even_alt 0 -| Even_alt_S : forall n, Odd_alt n -> Even_alt (S n) -with Odd_alt : nat -> Prop := -| Odd_alt_S : forall n, Even_alt n -> Odd_alt (S n). - -Lemma Even_alt_Even : forall n, Even_alt n <-> Even n. -Proof. - fix Even_alt_Even 1. - intros n; destruct n as [|[|n]]; simpl. - - split; [now exists 0 | constructor]. - - split. - + inversion_clear 1 as [|? H0]. - inversion_clear H0. - + now rewrite <- Nat.even_spec. - - rewrite Nat.Even_succ_succ, <- Even_alt_Even. - split. - + inversion_clear 1 as [|? H0]. - now inversion_clear H0. - + now do 2 constructor. -Qed. - -Lemma Odd_alt_Odd : forall n, Odd_alt n <-> Odd n. -Proof. - fix Odd_alt_Odd 1. - intros n; destruct n as [|[|n]]; simpl. - - split. - + inversion_clear 1. - + now rewrite <- Nat.odd_spec. - - split; [ now exists 0 | do 2 constructor ]. - - rewrite Nat.Odd_succ_succ, <- Odd_alt_Odd. - split. - + inversion_clear 1 as [? H0]. - now inversion_clear H0. - + now do 2 constructor. -Qed. - -Scheme Odd_alt_Even_alt_ind := Minimality for Odd_alt Sort Prop -with Even_alt_Odd_alt_ind := Minimality for Even_alt Sort Prop. - -Lemma Odd_Even_ind (P Q : nat -> Prop) : - (forall n, Even n -> Q n -> P (S n)) -> - Q 0 -> (forall n, Odd n -> P n -> Q (S n)) -> forall n, Odd n -> P n. -Proof. - intros HSE H0 HSO n HO%Odd_alt_Odd. - apply Odd_alt_Even_alt_ind with Q; try assumption. - - intros m HSE'%Even_alt_Even; auto. - - intros m HSO'%Odd_alt_Odd; auto. -Qed. - -Lemma Even_Odd_ind (P Q : nat -> Prop) : - (forall n, Even n -> Q n -> P (S n)) -> - Q 0 -> (forall n, Odd n -> P n -> Q (S n)) -> forall n, Even n -> Q n. -Proof. - intros HSE H0 HSO n HE%Even_alt_Even. - apply Even_alt_Odd_alt_ind with P; try assumption. - - intros m HSE'%Even_alt_Even; auto. - - intros m HSO'%Odd_alt_Odd; auto. -Qed. - -(* Anomaly see Issue #15413 -Combined Scheme Even_Odd_mutind from Even_Odd_ind, Odd_Even_ind. -*) - -Scheme Odd_alt_Even_alt_sind := Minimality for Odd_alt Sort SProp -with Even_alt_Odd_alt_sind := Minimality for Even_alt Sort SProp. - -Lemma Odd_Even_sind (P Q : nat -> SProp) : - (forall n, Even n -> Q n -> P (S n)) -> - Q 0 -> (forall n, Odd n -> P n -> Q (S n)) -> forall n, Odd n -> P n. -Proof. - intros HSE H0 HSO n HO%Odd_alt_Odd. - apply Odd_alt_Even_alt_sind with Q; try assumption. - - intros m HSE'%Even_alt_Even; auto. - - intros m HSO'%Odd_alt_Odd; auto. -Qed. - -Lemma Even_Odd_sind (P Q : nat -> SProp) : - (forall n, Even n -> Q n -> P (S n)) -> - Q 0 -> (forall n, Odd n -> P n -> Q (S n)) -> forall n, Even n -> Q n. -Proof. - intros HSE H0 HSO n HE%Even_alt_Even. - apply Even_alt_Odd_alt_sind with P; try assumption. - - intros m HSE'%Even_alt_Even; auto. - - intros m HSO'%Odd_alt_Odd; auto. -Qed. - -(* Anomaly see Issue #15413 -Combined Scheme Even_Odd_mutsind from Even_Odd_sind, Odd_Even_sind. -*) - -(** additional versions of parity predicates in [Type] - useful for eliminating into [Type], but still with opaque proofs *) - -Definition EvenT n := { m | n = 2 * m }. -Definition OddT n := { m | n = 2 * m + 1 }. - -Lemma EvenT_0 : EvenT 0. -Proof. exists 0; reflexivity. Qed. - -Lemma EvenT_2 n : EvenT n -> EvenT (S (S n)). -Proof. - intros [m H]; exists (S m); rewrite H. - cbn; rewrite add_succ_r; reflexivity. -Qed. - -Lemma OddT_1 : OddT 1. -Proof. exists 0; reflexivity. Qed. - -Lemma OddT_2 n : OddT n -> OddT (S (S n)). -Proof. - intros [m H]; exists (S m). - rewrite H, ? mul_succ_r, <- ? add_1_r, add_assoc; reflexivity. -Qed. - -Lemma EvenT_S_OddT n : EvenT (S n) -> OddT n. -Proof. - intros [[|k] HE]; inversion HE. - exists k; rewrite add_succ_r, add_1_r; reflexivity. -Qed. - -Lemma OddT_S_EvenT n : OddT (S n) -> EvenT n. -Proof. - intros [k HO]; rewrite add_1_r in HO; injection HO; intros ->. - exists k; reflexivity. -Qed. - -Lemma even_EvenT : forall n, even n = true -> EvenT n. -Proof. - fix even_specT 1. - intro n; destruct n as [|[|n]]; simpl. - - intros; apply EvenT_0. - - intros H; discriminate. - - intros He%even_specT; apply EvenT_2; assumption. -Qed. - -Lemma odd_OddT : forall n, odd n = true -> OddT n. -Proof. - unfold odd. - fix odd_specT 1. - intro n; destruct n as [|[|n]]; simpl. - - intro H; discriminate. - - intros; apply OddT_1. - - intros He%odd_specT; apply OddT_2; assumption. -Qed. - -Lemma EvenT_Even n : EvenT n -> Even n. -Proof. intros [k ?]; exists k; assumption. Qed. - -Lemma OddT_Odd n : OddT n -> Odd n. -Proof. intros [k ?]; exists k; assumption. Qed. - -Lemma Even_EvenT n : Even n -> EvenT n. -Proof. intros; apply even_EvenT, even_spec; assumption. Qed. - -Lemma Odd_OddT n : Odd n -> OddT n. -Proof. intros; apply odd_OddT, odd_spec; assumption. Qed. - -Lemma EvenT_even n : EvenT n -> even n = true. -Proof. intros; apply even_spec, EvenT_Even; assumption. Qed. - -Lemma OddT_odd n : OddT n -> odd n = true. -Proof. intros; apply odd_spec, OddT_Odd; assumption. Qed. - -Lemma EvenT_OddT_dec n : EvenT n + OddT n. -Proof. - case_eq (even n); intros Hp. - - left; apply even_EvenT; assumption. - - right; apply odd_OddT. - unfold odd; rewrite Hp; reflexivity. -Qed. - -Lemma OddT_EvenT_rect (P Q : nat -> Type) : - (forall n, EvenT n -> Q n -> P (S n)) -> - Q 0 -> (forall n, OddT n -> P n -> Q (S n)) -> forall n, OddT n -> P n. -Proof. - intros HQP HQ0 HPQ. - fix OddT_EvenT_rect 1. - intros [|[|n]]. - - intros [[|k] H0]; inversion H0. - - intros _; apply (HQP _ EvenT_0 HQ0). - - intros HOSS. - assert (EvenT (S n)) as HES by apply (OddT_S_EvenT _ HOSS). - assert (OddT n) as HO by apply (EvenT_S_OddT _ HES). - apply (HQP _ HES (HPQ _ HO (OddT_EvenT_rect _ HO))). -Qed. - -Lemma EvenT_OddT_rect (P Q : nat -> Type) : - (forall n, EvenT n -> Q n -> P (S n)) -> - Q 0 -> (forall n, OddT n -> P n -> Q (S n)) -> forall n, EvenT n -> Q n. -Proof. - intros HQP HQ0 HPQ [|n] HES; [ assumption | ]. - assert (OddT n) as HO by apply (EvenT_S_OddT _ HES). - apply HPQ, (OddT_EvenT_rect P Q); assumption. -Qed. - -(* Anomaly see Issue #15413 -Combined Scheme EvenT_OddT_mutrect from EvenT_OddT_rect, OddT_EvenT_rect. -*) -End Nat. - -(** Re-export notations that should be available even when - the [Nat] module is not imported. *) - -Bind Scope nat_scope with Nat.t nat. - -Infix "^" := Nat.pow : nat_scope. -Infix "=?" := Nat.eqb (at level 70) : nat_scope. -Infix "<=?" := Nat.leb (at level 70) : nat_scope. -Infix " (proj1 (Nat.lt_succ_r n m))). -Register lt_n_Sm_le as num.nat.lt_n_Sm_le. -#[local] -Definition le_lt_n_Sm := (fun n m => (proj2 (Nat.lt_succ_r n m))). -Register le_lt_n_Sm as num.nat.le_lt_n_Sm. -#[local] -Definition lt_S_n := (fun n m => (proj2 (Nat.succ_lt_mono n m))). -Register lt_S_n as num.nat.lt_S_n. -Register Nat.le_lt_trans as num.nat.le_lt_trans. -#[local] -Definition pred_of_minus := (fun n => eq_sym (Nat.sub_1_r n)). -Register pred_of_minus as num.nat.pred_of_minus. -Register Nat.le_trans as num.nat.le_trans. -Register Nat.nlt_0_r as num.nat.nlt_0_r. - -(** [Nat] contains an [order] tactic for natural numbers *) - -(** Note that [Nat.order] is domain-agnostic: it will not prove - [1<=2] or [x<=x+x], but rather things like [x<=y -> y<=x -> x=y]. *) - -Section TestOrder. - Let test : forall x y, x<=y -> y<=x -> x=y. - Proof. Nat.order. Defined. -End TestOrder. diff --git a/stdlib/theories/Arith/Peano_dec.v b/stdlib/theories/Arith/Peano_dec.v deleted file mode 100644 index 893e6b8af396..000000000000 --- a/stdlib/theories/Arith/Peano_dec.v +++ /dev/null @@ -1,62 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* ]. - rewrite (UIP_nat _ _ def_n0 eq_refl); simpl. - assert (H : le_mn1 = le_mn2). - * now apply IHn0. - * now rewrite H. -Qed. diff --git a/stdlib/theories/Arith/Wf_nat.v b/stdlib/theories/Arith/Wf_nat.v deleted file mode 100644 index 5701f9584659..000000000000 --- a/stdlib/theories/Arith/Wf_nat.v +++ /dev/null @@ -1,273 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* nat. -Definition ltof (a b:A) := f a < f b. -Definition gtof (a b:A) := f b > f a. - -Theorem well_founded_ltof : well_founded ltof. -Proof. - assert (H : forall n (a:A), f a < n -> Acc ltof a). - { intro n; induction n as [|n IHn]. - - intros a Ha; absurd (f a < 0); auto. apply Nat.nlt_0_r. - - intros a Ha. apply Acc_intro. unfold ltof at 1. intros b Hb. - apply IHn. apply Nat.lt_le_trans with (f a); auto. now apply Nat.succ_le_mono. } - intros a. apply (H (S (f a))). apply Nat.lt_succ_diag_r. -Defined. - -Register well_founded_ltof as num.nat.well_founded_ltof. - -Theorem well_founded_gtof : well_founded gtof. -Proof. - exact well_founded_ltof. -Defined. - -(** It is possible to directly prove the induction principle going - back to primitive recursion on natural numbers ([induction_ltof1]) - or to use the previous lemmas to extract a program with a fixpoint - ([induction_ltof2]) - -the ML-like program for [induction_ltof1] is : -[[ -let induction_ltof1 f F a = - let rec indrec n k = - match n with - | O -> error - | S m -> F k (indrec m) - in indrec (f a + 1) a -]] - -the ML-like program for [induction_ltof2] is : -[[ - let induction_ltof2 F a = indrec a - where rec indrec a = F a indrec;; -]] -*) - -Theorem induction_ltof1 : - forall P:A -> Type, - (forall x:A, (forall y:A, ltof y x -> P y) -> P x) -> forall a:A, P a. -Proof. - intros P F. - assert (H : forall n (a:A), f a < n -> P a). - { intro n; induction n as [|n IHn]. - - intros a Ha; absurd (f a < 0); auto. apply Nat.nlt_0_r. - - intros a Ha. apply F. unfold ltof. intros b Hb. - apply IHn. apply Nat.lt_le_trans with (f a); auto. now apply Nat.succ_le_mono. } - intros a. apply (H (S (f a))). apply Nat.lt_succ_diag_r. -Defined. - -Theorem induction_gtof1 : - forall P:A -> Type, - (forall x:A, (forall y:A, gtof y x -> P y) -> P x) -> forall a:A, P a. -Proof. - exact induction_ltof1. -Defined. - -Theorem induction_ltof2 : - forall P:A -> Type, - (forall x:A, (forall y:A, ltof y x -> P y) -> P x) -> forall a:A, P a. -Proof. - exact (well_founded_induction_type well_founded_ltof). -Defined. - -Theorem induction_gtof2 : - forall P:A -> Type, - (forall x:A, (forall y:A, gtof y x -> P y) -> P x) -> forall a:A, P a. -Proof. - exact induction_ltof2. -Defined. - -(** If a relation [R] is compatible with [lt] i.e. if [x R y => f(x) < f(y)] - then [R] is well-founded. *) - -Variable R : A -> A -> Prop. - -Hypothesis H_compat : forall x y:A, R x y -> f x < f y. - -Theorem well_founded_lt_compat : well_founded R. -Proof. - assert (H : forall n (a:A), f a < n -> Acc R a). - { intro n; induction n as [|n IHn]. - - intros a Ha; absurd (f a < 0); auto. apply Nat.nlt_0_r. - - intros a Ha. apply Acc_intro. intros b Hb. - apply IHn. apply Nat.lt_le_trans with (f a); auto. now apply Nat.succ_le_mono. } - intros a. apply (H (S (f a))). apply Nat.lt_succ_diag_r. -Defined. - -End Well_founded_Nat. - -Lemma lt_wf : well_founded lt. -Proof. - exact (well_founded_ltof nat (fun m => m)). -Defined. - -Lemma lt_wf_rect1 : - forall n (P:nat -> Type), (forall n, (forall m, m < n -> P m) -> P n) -> P n. -Proof. - exact (fun p P F => induction_ltof1 nat (fun m => m) P F p). -Defined. - -Lemma lt_wf_rect : - forall n (P:nat -> Type), (forall n, (forall m, m < n -> P m) -> P n) -> P n. -Proof. - exact (fun p P F => induction_ltof2 nat (fun m => m) P F p). -Defined. - -Lemma lt_wf_rec1 : - forall n (P:nat -> Set), (forall n, (forall m, m < n -> P m) -> P n) -> P n. -Proof. - exact (fun p P F => induction_ltof1 nat (fun m => m) P F p). -Defined. - -Lemma lt_wf_rec : - forall n (P:nat -> Set), (forall n, (forall m, m < n -> P m) -> P n) -> P n. -Proof. - exact (fun p P F => induction_ltof2 nat (fun m => m) P F p). -Defined. - -Lemma lt_wf_ind : - forall n (P:nat -> Prop), (forall n, (forall m, m < n -> P m) -> P n) -> P n. -Proof. - intro p; intros; elim (lt_wf p); auto. -Qed. - -Lemma gt_wf_rect : - forall n (P:nat -> Type), (forall n, (forall m, n > m -> P m) -> P n) -> P n. -Proof. - exact lt_wf_rect. -Defined. - -Lemma gt_wf_rec : - forall n (P:nat -> Set), (forall n, (forall m, n > m -> P m) -> P n) -> P n. -Proof. - exact lt_wf_rec. -Defined. - -Lemma gt_wf_ind : - forall n (P:nat -> Prop), (forall n, (forall m, n > m -> P m) -> P n) -> P n. -Proof lt_wf_ind. - -Lemma lt_wf_double_rect : - forall P:nat -> nat -> Type, - (forall n m, - (forall p q, p < n -> P p q) -> - (forall p, p < m -> P n p) -> P n m) -> forall n m, P n m. -Proof. - intros P Hrec p; pattern p; apply lt_wf_rect. - intros n H q; pattern q; apply lt_wf_rect; auto. -Defined. - -Lemma lt_wf_double_rec : - forall P:nat -> nat -> Set, - (forall n m, - (forall p q, p < n -> P p q) -> - (forall p, p < m -> P n p) -> P n m) -> forall n m, P n m. -Proof. - intros P Hrec p; pattern p; apply lt_wf_rec. - intros n H q; pattern q; apply lt_wf_rec; auto. -Defined. - -Lemma lt_wf_double_ind : - forall P:nat -> nat -> Prop, - (forall n m, - (forall p (q:nat), p < n -> P p q) -> - (forall p, p < m -> P n p) -> P n m) -> forall n m, P n m. -Proof. - intros P Hrec p; pattern p; apply lt_wf_ind. - intros n H q; pattern q; apply lt_wf_ind; auto. -Qed. - -#[global] -Hint Resolve lt_wf: arith. -#[global] -Hint Resolve well_founded_lt_compat: arith. - -Section LT_WF_REL. - Variable A : Set. - Variable R : A -> A -> Prop. - - (* Relational form of inversion *) - Variable F : A -> nat -> Prop. - Definition inv_lt_rel x y := exists2 n, F x n & (forall m, F y m -> n < m). - - Hypothesis F_compat : forall x y:A, R x y -> inv_lt_rel x y. - Remark acc_lt_rel : forall x:A, (exists n, F x n) -> Acc R x. - Proof. - intros x [n fxn]; generalize dependent x. - pattern n; apply lt_wf_ind; intros n0 H x fxn. - constructor; intros y H0. - destruct (F_compat y x) as (x0,H1,H2); trivial. - apply (H x0); auto. - Qed. - - Theorem well_founded_inv_lt_rel_compat : well_founded R. - Proof. - intro a; constructor; intros y H. - case (F_compat y a); trivial; intros x **. - apply acc_lt_rel; trivial. - exists x; trivial. - Qed. - -End LT_WF_REL. - -Lemma well_founded_inv_rel_inv_lt_rel (A:Set) (F:A -> nat -> Prop) : - well_founded (inv_lt_rel A F). -Proof. - apply (well_founded_inv_lt_rel_compat A (inv_lt_rel A F) F); trivial. -Qed. - -(** A constructive proof that any non empty decidable subset of - natural numbers has a least element *) - -Set Implicit Arguments. - -Require Import Compare_dec. -Require Import Decidable. - -Definition has_unique_least_element (A:Type) (R:A->A->Prop) (P:A->Prop) := - exists! x, P x /\ forall x', P x' -> R x x'. - -Lemma dec_inh_nat_subset_has_unique_least_element : - forall P:nat->Prop, (forall n, P n \/ ~ P n) -> - (exists n, P n) -> has_unique_least_element le P. -Proof. - intros P Pdec (n0,HPn0). - assert - (forall n, (exists n', n' n'<=n'') - \/ (forall n', P n' -> n<=n')) as H. - { intro n; induction n as [|n IHn]. - - right. intros. apply Nat.le_0_l. - - destruct IHn as [(n' & IH1 & IH2)|IH]. - + left. exists n'; auto. - + destruct (Pdec n) as [HP|HP]. - * left. exists n; auto. - * right. intros n' Hn'. - apply Nat.le_neq; split; auto. intros <-. auto. } - destruct (H n0) as [(n & H1 & H2 & H3)|H0]; [exists n | exists n0]; - repeat split; trivial; - intros n' (HPn',Hn'); apply Nat.le_antisymm; auto. -Qed. - -Unset Implicit Arguments. - -Notation iter_nat n A f x := (nat_rect (fun _ => A) x (fun _ => f) n) (only parsing). diff --git a/stdlib/theories/Array/ArrayAxioms.v b/stdlib/theories/Array/ArrayAxioms.v deleted file mode 100644 index e37a3d0924e1..000000000000 --- a/stdlib/theories/Array/ArrayAxioms.v +++ /dev/null @@ -1 +0,0 @@ -From Corelib Require Export ArrayAxioms. diff --git a/stdlib/theories/Array/PArray.v b/stdlib/theories/Array/PArray.v deleted file mode 100644 index c419aa380ca2..000000000000 --- a/stdlib/theories/Array/PArray.v +++ /dev/null @@ -1,67 +0,0 @@ -From Stdlib Require Import Uint63. -From Stdlib Require Export PrimArray ArrayAxioms. - -Local Open Scope uint63_scope. -Local Open Scope array_scope. - -Notation array := PrimArray.array (only parsing). -Notation make := PrimArray.make (only parsing). -Notation get := PrimArray.get (only parsing). -Notation default := PrimArray.default (only parsing). -Notation set := PrimArray.set (only parsing). -Notation length := PrimArray.length (only parsing). -Notation copy := PrimArray.copy (only parsing). - -Notation max_length := PrimArray.max_length (only parsing). - -Notation get_out_of_bounds := ArrayAxioms.get_out_of_bounds (only parsing). -Notation get_set_same := ArrayAxioms.get_set_same (only parsing). -Notation get_set_other := ArrayAxioms.get_set_other (only parsing). -Notation default_set := ArrayAxioms.default_set (only parsing). -Notation get_make := ArrayAxioms.get_make (only parsing). -Notation leb_length := ArrayAxioms.leb_length (only parsing). -Notation length_make := ArrayAxioms.length_make (only parsing). -Notation length_set := ArrayAxioms.length_set (only parsing). -Notation get_copy := ArrayAxioms.get_copy (only parsing). -Notation length_copy := ArrayAxioms.length_copy (only parsing). -Notation array_ext := ArrayAxioms.array_ext (only parsing). - -(* Lemmas *) - -Lemma default_copy A (t:array A) : default (copy t) = default t. -Proof. - assert (irr_lt : length t default t -> (x True - | false => False - end. - -(*******************) -(** * Decidability *) -(*******************) - -Lemma bool_dec : forall b1 b2 : bool, {b1 = b2} + {b1 <> b2}. -Proof. - decide equality. -Defined. - -(*********************) -(** * Discrimination *) -(*********************) - -Lemma diff_true_false : true <> false. -Proof. - discriminate. -Qed. -#[global] -Hint Resolve diff_true_false : bool. - -Lemma diff_false_true : false <> true. -Proof. - discriminate. -Qed. -#[global] -Hint Resolve diff_false_true : bool. -#[global] -Hint Extern 1 (false <> true) => exact diff_false_true : core. - -Lemma eq_true_false_abs : forall b:bool, b = true -> b = false -> False. -Proof. - destr_bool. -Qed. - -Lemma not_true_is_false : forall b:bool, b <> true -> b = false. -Proof. - destr_bool; intuition. -Qed. - -Lemma not_false_is_true : forall b:bool, b <> false -> b = true. -Proof. - destr_bool; intuition. -Qed. - -Lemma not_true_iff_false : forall b, b <> true <-> b = false. -Proof. - destr_bool; intuition. -Qed. - -Lemma not_false_iff_true : forall b, b <> false <-> b = true. -Proof. - destr_bool; intuition. -Qed. - -(************************) -(** * Order on booleans *) -(************************) - -#[ local ] Definition le (b1 b2:bool) := - match b1 with - | true => b2 = true - | false => True - end. -#[global] -Hint Unfold le: bool. - -Lemma le_implb : forall b1 b2, le b1 b2 <-> implb b1 b2 = true. -Proof. - destr_bool; intuition. -Qed. - -#[ local ] Definition lt (b1 b2:bool) := - match b1 with - | true => False - | false => b2 = true - end. -#[global] -Hint Unfold lt: bool. - -#[ local ] Definition compare (b1 b2 : bool) := - match b1, b2 with - | false, true => Lt - | true, false => Gt - | _, _ => Eq - end. - -Lemma compare_spec : forall b1 b2, - CompareSpec (b1 = b2) (lt b1 b2) (lt b2 b1) (compare b1 b2). -Proof. destr_bool; auto. Qed. - - -(***************) -(** * Equality *) -(***************) - -Definition eqb (b1 b2:bool) : bool := - match b1, b2 with - | true, true => true - | true, false => false - | false, true => false - | false, false => true - end. - -Register eqb as core.bool.eqb. - -Lemma eqb_subst : - forall (P:bool -> Prop) (b1 b2:bool), eqb b1 b2 = true -> P b1 -> P b2. -Proof. - destr_bool. -Qed. - -Lemma eqb_reflx : forall b:bool, eqb b b = true. -Proof. - destr_bool. -Qed. - -Lemma eqb_prop : forall a b:bool, eqb a b = true -> a = b. -Proof. - destr_bool. -Qed. - -Lemma eqb_true_iff : forall a b:bool, eqb a b = true <-> a = b. -Proof. - destr_bool; intuition. -Qed. - -#[global] -Instance Decidable_eq_bool : forall (x y : bool), Decidable (eq x y) := { - Decidable_spec := eqb_true_iff x y -}. - -Lemma eqb_false_iff : forall a b:bool, eqb a b = false <-> a <> b. -Proof. - destr_bool; intuition. -Qed. - -(**********************************) -(** * A synonym of [if] on [bool] *) -(**********************************) - -Definition ifb (b1 b2 b3:bool) : bool := - match b1 with - | true => b2 - | false => b3 - end. - -Open Scope bool_scope. - -(*********************) -(** * De Morgan laws *) -(*********************) - -Lemma negb_orb : forall b1 b2:bool, negb (b1 || b2) = negb b1 && negb b2. -Proof. - destr_bool. -Qed. - -Lemma negb_andb : forall b1 b2:bool, negb (b1 && b2) = negb b1 || negb b2. -Proof. - destr_bool. -Qed. - -(***************************) -(** * Properties of [negb] *) -(***************************) - -Lemma negb_involutive : forall b:bool, negb (negb b) = b. -Proof. - destr_bool. -Qed. - -Lemma negb_involutive_reverse : forall b:bool, b = negb (negb b). -Proof. - destr_bool. -Qed. - -Notation negb_elim := negb_involutive (only parsing). -Notation negb_intro := negb_involutive_reverse (only parsing). - -Lemma negb_sym : forall b b':bool, b' = negb b -> b = negb b'. -Proof. - destr_bool. -Qed. - -Lemma no_fixpoint_negb : forall b:bool, negb b <> b. -Proof. - destr_bool. -Qed. - -Lemma eqb_negb1 : forall b:bool, eqb (negb b) b = false. -Proof. - destr_bool. -Qed. - -Lemma eqb_negb2 : forall b:bool, eqb b (negb b) = false. -Proof. - destr_bool. -Qed. - -Lemma if_negb : - forall (A:Type) (b:bool) (x y:A), - (if negb b then x else y) = (if b then y else x). -Proof. - destr_bool. -Qed. - -Lemma negb_true_iff : forall b, negb b = true <-> b = false. -Proof. - destr_bool; intuition. -Qed. - -Lemma negb_false_iff : forall b, negb b = false <-> b = true. -Proof. - destr_bool; intuition. -Qed. - - -(**************************) -(** * Properties of [orb] *) -(**************************) - -Lemma orb_true_iff : - forall b1 b2, b1 || b2 = true <-> b1 = true \/ b2 = true. -Proof. - destr_bool; intuition. -Qed. - -Lemma orb_false_iff : - forall b1 b2, b1 || b2 = false <-> b1 = false /\ b2 = false. -Proof. - destr_bool; intuition. -Qed. - -Lemma orb_true_elim : - forall b1 b2:bool, b1 || b2 = true -> {b1 = true} + {b2 = true}. -Proof. - intro b1; destruct b1; simpl; auto. -Defined. - -Lemma orb_prop : forall a b:bool, a || b = true -> a = true \/ b = true. -Proof. - intros; apply orb_true_iff; trivial. -Qed. - -Lemma orb_true_intro : - forall b1 b2:bool, b1 = true \/ b2 = true -> b1 || b2 = true. -Proof. - intros; apply orb_true_iff; trivial. -Qed. -#[global] -Hint Resolve orb_true_intro: bool. - -Lemma orb_false_intro : - forall b1 b2:bool, b1 = false -> b2 = false -> b1 || b2 = false. -Proof. - intros. subst. reflexivity. -Qed. -#[global] -Hint Resolve orb_false_intro: bool. - -Lemma orb_false_elim : - forall b1 b2:bool, b1 || b2 = false -> b1 = false /\ b2 = false. -Proof. - intros. apply orb_false_iff; trivial. -Qed. - -Lemma orb_diag : forall b, b || b = b. -Proof. - destr_bool. -Qed. - -(** [true] is a zero for [orb] *) - -Lemma orb_true_r : forall b:bool, b || true = true. -Proof. - destr_bool. -Qed. -#[global] -Hint Resolve orb_true_r: bool. - -Lemma orb_true_l : forall b:bool, true || b = true. -Proof. - reflexivity. -Qed. - -Notation orb_b_true := orb_true_r (only parsing). -Notation orb_true_b := orb_true_l (only parsing). - -(** [false] is neutral for [orb] *) - -Lemma orb_false_r : forall b:bool, b || false = b. -Proof. - destr_bool. -Qed. -#[global] -Hint Resolve orb_false_r: bool. - -Lemma orb_false_l : forall b:bool, false || b = b. -Proof. - destr_bool. -Qed. -#[global] -Hint Resolve orb_false_l: bool. - -Notation orb_b_false := orb_false_r (only parsing). -Notation orb_false_b := orb_false_l (only parsing). - -(** Complementation *) - -Lemma orb_negb_r : forall b:bool, b || negb b = true. -Proof. - destr_bool. -Qed. -#[global] -Hint Resolve orb_negb_r: bool. - -Lemma orb_negb_l : forall b:bool, negb b || b = true. -Proof. - destr_bool. -Qed. - -Notation orb_neg_b := orb_negb_r (only parsing). - -(** Commutativity *) - -Lemma orb_comm : forall b1 b2:bool, b1 || b2 = b2 || b1. -Proof. - destr_bool. -Qed. - -(** Associativity *) - -Lemma orb_assoc : forall b1 b2 b3:bool, b1 || (b2 || b3) = b1 || b2 || b3. -Proof. - destr_bool. -Qed. -#[global] -Hint Resolve orb_comm orb_assoc: bool. - -(***************************) -(** * Properties of [andb] *) -(***************************) - -Lemma andb_true_iff : - forall b1 b2:bool, b1 && b2 = true <-> b1 = true /\ b2 = true. -Proof. - destr_bool; intuition. -Qed. - -Lemma andb_false_iff : - forall b1 b2:bool, b1 && b2 = false <-> b1 = false \/ b2 = false. -Proof. - destr_bool; intuition. -Qed. - -Lemma andb_true_eq : - forall a b:bool, true = a && b -> true = a /\ true = b. -Proof. - destr_bool. auto. -Defined. - -Lemma andb_false_intro1 : forall b1 b2:bool, b1 = false -> b1 && b2 = false. -Proof. - intros. apply andb_false_iff. auto. -Qed. - -Lemma andb_false_intro2 : forall b1 b2:bool, b2 = false -> b1 && b2 = false. -Proof. - intros. apply andb_false_iff. auto. -Qed. - -(** [false] is a zero for [andb] *) - -Lemma andb_false_r : forall b:bool, b && false = false. -Proof. - destr_bool. -Qed. - -Lemma andb_false_l : forall b:bool, false && b = false. -Proof. - reflexivity. -Qed. - -Notation andb_b_false := andb_false_r (only parsing). -Notation andb_false_b := andb_false_l (only parsing). - -Lemma andb_diag : forall b, b && b = b. -Proof. - destr_bool. -Qed. - -(** [true] is neutral for [andb] *) - -Lemma andb_true_r : forall b:bool, b && true = b. -Proof. - destr_bool. -Qed. - -Lemma andb_true_l : forall b:bool, true && b = b. -Proof. - reflexivity. -Qed. - -Notation andb_b_true := andb_true_r (only parsing). -Notation andb_true_b := andb_true_l (only parsing). - -Lemma andb_false_elim : - forall b1 b2:bool, b1 && b2 = false -> {b1 = false} + {b2 = false}. -Proof. - intro b1; destruct b1; simpl; auto. -Defined. -#[global] -Hint Resolve andb_false_elim: bool. - -(** Complementation *) - -Lemma andb_negb_r : forall b:bool, b && negb b = false. -Proof. - destr_bool. -Qed. -#[global] -Hint Resolve andb_negb_r: bool. - -Lemma andb_negb_l : forall b:bool, negb b && b = false. -Proof. - destr_bool. -Qed. - -Notation andb_neg_b := andb_negb_r (only parsing). - -(** Commutativity *) - -Lemma andb_comm : forall b1 b2:bool, b1 && b2 = b2 && b1. -Proof. - destr_bool. -Qed. - -(** Associativity *) - -Lemma andb_assoc : forall b1 b2 b3:bool, b1 && (b2 && b3) = b1 && b2 && b3. -Proof. - destr_bool. -Qed. - -#[global] -Hint Resolve andb_comm andb_assoc: bool. - -(*****************************************) -(** * Properties mixing [andb] and [orb] *) -(*****************************************) - -(** Distributivity *) - -Lemma andb_orb_distrib_r : - forall b1 b2 b3:bool, b1 && (b2 || b3) = b1 && b2 || b1 && b3. -Proof. - destr_bool. -Qed. - -Lemma andb_orb_distrib_l : - forall b1 b2 b3:bool, (b1 || b2) && b3 = b1 && b3 || b2 && b3. -Proof. - destr_bool. -Qed. - -Lemma orb_andb_distrib_r : - forall b1 b2 b3:bool, b1 || b2 && b3 = (b1 || b2) && (b1 || b3). -Proof. - destr_bool. -Qed. - -Lemma orb_andb_distrib_l : - forall b1 b2 b3:bool, b1 && b2 || b3 = (b1 || b3) && (b2 || b3). -Proof. - destr_bool. -Qed. - -(* Compatibility *) -Notation demorgan1 := andb_orb_distrib_r (only parsing). -Notation demorgan2 := andb_orb_distrib_l (only parsing). -Notation demorgan3 := orb_andb_distrib_r (only parsing). -Notation demorgan4 := orb_andb_distrib_l (only parsing). - -(** Absorption *) - -Lemma absorption_andb : forall b1 b2:bool, b1 && (b1 || b2) = b1. -Proof. - destr_bool. -Qed. - -Lemma absorption_orb : forall b1 b2:bool, b1 || b1 && b2 = b1. -Proof. - destr_bool. -Qed. - -(* begin hide *) -(* Compatibility *) -Notation absoption_andb := absorption_andb (only parsing). -Notation absoption_orb := absorption_orb (only parsing). -(* end hide *) - -(****************************) -(** * Properties of [implb] *) -(****************************) - -Lemma implb_true_iff : forall b1 b2:bool, implb b1 b2 = true <-> (b1 = true -> b2 = true). -Proof. - destr_bool; intuition. -Qed. - -Lemma implb_false_iff : forall b1 b2:bool, implb b1 b2 = false <-> (b1 = true /\ b2 = false). -Proof. - destr_bool; intuition. -Qed. - -Lemma implb_orb : forall b1 b2:bool, implb b1 b2 = negb b1 || b2. -Proof. - destr_bool. -Qed. - -Lemma implb_negb_orb : forall b1 b2:bool, implb (negb b1) b2 = b1 || b2. -Proof. - destr_bool. -Qed. - -Lemma implb_true_r : forall b:bool, implb b true = true. -Proof. - destr_bool. -Qed. - -Lemma implb_false_r : forall b:bool, implb b false = negb b. -Proof. - destr_bool. -Qed. - -Lemma implb_true_l : forall b:bool, implb true b = b. -Proof. - destr_bool. -Qed. - -Lemma implb_false_l : forall b:bool, implb false b = true. -Proof. - destr_bool. -Qed. - -Lemma implb_same : forall b:bool, implb b b = true. -Proof. - destr_bool. -Qed. - -Lemma implb_contrapositive : forall b1 b2:bool, implb (negb b1) (negb b2) = implb b2 b1. -Proof. - destr_bool. -Qed. - -Lemma implb_negb : forall b1 b2:bool, implb (negb b1) b2 = implb (negb b2) b1. -Proof. - destr_bool. -Qed. - -Lemma implb_curry : forall b1 b2 b3:bool, implb (b1 && b2) b3 = implb b1 (implb b2 b3). -Proof. - destr_bool. -Qed. - -Lemma implb_andb_distrib_r : forall b1 b2 b3:bool, implb b1 (b2 && b3) = implb b1 b2 && implb b1 b3. -Proof. - destr_bool. -Qed. - -Lemma implb_orb_distrib_r : forall b1 b2 b3:bool, implb b1 (b2 || b3) = implb b1 b2 || implb b1 b3. -Proof. - destr_bool. -Qed. - -Lemma implb_orb_distrib_l : forall b1 b2 b3:bool, implb (b1 || b2) b3 = implb b1 b3 && implb b2 b3. -Proof. - destr_bool. -Qed. - -(***************************) -(** * Properties of [xorb] *) -(***************************) - -(** [false] is neutral for [xorb] *) - -Lemma xorb_false_r : forall b:bool, xorb b false = b. -Proof. - destr_bool. -Qed. - -Lemma xorb_false_l : forall b:bool, xorb false b = b. -Proof. - destr_bool. -Qed. - -Notation xorb_false := xorb_false_r (only parsing). -Notation false_xorb := xorb_false_l (only parsing). - -(** [true] is "complementing" for [xorb] *) - -Lemma xorb_true_r : forall b:bool, xorb b true = negb b. -Proof. - reflexivity. -Qed. - -Lemma xorb_true_l : forall b:bool, xorb true b = negb b. -Proof. - reflexivity. -Qed. - -Notation xorb_true := xorb_true_r (only parsing). -Notation true_xorb := xorb_true_l (only parsing). - -(** Nilpotency (alternatively: identity is a inverse for [xorb]) *) - -Lemma xorb_nilpotent : forall b:bool, xorb b b = false. -Proof. - destr_bool. -Qed. - -(** Commutativity *) - -Lemma xorb_comm : forall b b':bool, xorb b b' = xorb b' b. -Proof. - destr_bool. -Qed. - -(** Associativity *) - -Lemma xorb_assoc_reverse : - forall b b' b'':bool, xorb (xorb b b') b'' = xorb b (xorb b' b''). -Proof. - destr_bool. -Qed. - -Notation xorb_assoc := xorb_assoc_reverse (only parsing). (* Compatibility *) - -Lemma xorb_eq : forall b b':bool, xorb b b' = false -> b = b'. -Proof. - destr_bool. -Qed. - -Lemma xorb_move_l_r_1 : - forall b b' b'':bool, xorb b b' = b'' -> b' = xorb b b''. -Proof. - destr_bool. -Qed. - -Lemma xorb_move_l_r_2 : - forall b b' b'':bool, xorb b b' = b'' -> b = xorb b'' b'. -Proof. - destr_bool. -Qed. - -Lemma xorb_move_r_l_1 : - forall b b' b'':bool, b = xorb b' b'' -> xorb b' b = b''. -Proof. - destr_bool. -Qed. - -Lemma xorb_move_r_l_2 : - forall b b' b'':bool, b = xorb b' b'' -> xorb b b'' = b'. -Proof. - destr_bool. -Qed. - -Lemma negb_xorb a b : negb (xorb a b) = Bool.eqb a b. -Proof. - destruct a, b; trivial. -Qed. - -Lemma negb_xorb_l : forall b b', negb (xorb b b') = xorb (negb b) b'. -Proof. - intros b b'; destruct b,b'; trivial. -Qed. - -Lemma negb_xorb_r : forall b b', negb (xorb b b') = xorb b (negb b'). -Proof. - intros b b'; destruct b,b'; trivial. -Qed. - -Lemma xorb_negb_negb : forall b b', xorb (negb b) (negb b') = xorb b b'. -Proof. - intros b b'; destruct b,b'; trivial. -Qed. - -(** Lemmas about the [b = true] embedding of [bool] to [Prop] *) - -Lemma eq_iff_eq_true : forall b1 b2, b1 = b2 <-> (b1 = true <-> b2 = true). -Proof. - destr_bool; intuition. -Qed. - -Lemma eq_true_iff_eq : forall b1 b2, (b1 = true <-> b2 = true) -> b1 = b2. -Proof. - apply eq_iff_eq_true. -Qed. - -Notation bool_1 := eq_true_iff_eq (only parsing). (* Compatibility *) - -Lemma eq_true_negb_classical : forall b:bool, negb b <> true -> b = true. -Proof. - destr_bool; intuition. -Qed. - -Notation bool_3 := eq_true_negb_classical (only parsing). (* Compatibility *) - -Lemma eq_true_negb_classical_iff : forall b:bool, negb b <> true <-> b = true. -Proof. - destr_bool; intuition. -Qed. - -Lemma eq_true_not_negb : forall b:bool, b <> true -> negb b = true. -Proof. - destr_bool; intuition. -Qed. - -Lemma eq_true_not_negb_iff : forall b:bool, b <> true <-> negb b = true. -Proof. - destr_bool; intuition. -Qed. - -Notation bool_6 := eq_true_not_negb (only parsing). (* Compatibility *) - -#[global] -Hint Resolve eq_true_not_negb : bool. - -(* An interesting lemma for auto but too strong to keep compatibility *) - -Lemma absurd_eq_bool : forall b b':bool, False -> b = b'. -Proof. - contradiction. -Qed. - -(* A more specific one that preserves compatibility with old hint bool_3 *) - -Lemma absurd_eq_true : forall b, False -> b = true. -Proof. - contradiction. -Qed. -#[global] -Hint Resolve absurd_eq_true : core. - -(* A specific instance of eq_trans that preserves compatibility with - old hint bool_2 *) - -Lemma trans_eq_bool : forall x y z:bool, x = y -> y = z -> x = z. -Proof. - apply eq_trans. -Qed. -#[global] -Hint Resolve trans_eq_bool : core. - -(***************************************) -(** * Reflection of [bool] into [Prop] *) -(***************************************) - -(** [Is_true] and equality *) - -#[global] -Hint Unfold Is_true: bool. - -Lemma Is_true_eq_true : forall x:bool, Is_true x -> x = true. -Proof. - destr_bool; tauto. -Qed. - -Lemma Is_true_eq_left : forall x:bool, x = true -> Is_true x. -Proof. - intros; subst; auto with bool. -Qed. - -Lemma Is_true_eq_right : forall x:bool, true = x -> Is_true x. -Proof. - intros; subst; auto with bool. -Qed. - -Notation Is_true_eq_true2 := Is_true_eq_right (only parsing). - -#[global] -Hint Immediate Is_true_eq_right Is_true_eq_left: bool. - -Lemma eqb_refl : forall x:bool, Is_true (eqb x x). -Proof. - destr_bool. -Qed. - -Lemma eqb_eq : forall x y:bool, Is_true (eqb x y) -> x = y. -Proof. - destr_bool; tauto. -Qed. - -(** [Is_true] and connectives *) - -Lemma orb_prop_elim : - forall a b:bool, Is_true (a || b) -> Is_true a \/ Is_true b. -Proof. - destr_bool; tauto. -Qed. - -Notation orb_prop2 := orb_prop_elim (only parsing). - -Lemma orb_prop_intro : - forall a b:bool, Is_true a \/ Is_true b -> Is_true (a || b). -Proof. - destr_bool; tauto. -Qed. - -Lemma andb_prop_intro : - forall b1 b2:bool, Is_true b1 /\ Is_true b2 -> Is_true (b1 && b2). -Proof. - destr_bool; tauto. -Qed. -#[global] -Hint Resolve andb_prop_intro: bool. - -Notation andb_true_intro2 := - (fun b1 b2 H1 H2 => andb_prop_intro b1 b2 (conj H1 H2)) - (only parsing). - -Lemma andb_prop_elim : - forall a b:bool, Is_true (a && b) -> Is_true a /\ Is_true b. -Proof. - destr_bool; auto. -Qed. -#[global] -Hint Resolve andb_prop_elim: bool. - -Notation andb_prop2 := andb_prop_elim (only parsing). - -Lemma eq_bool_prop_intro : - forall b1 b2, (Is_true b1 <-> Is_true b2) -> b1 = b2. -Proof. - destr_bool; tauto. -Qed. - -Lemma eq_bool_prop_elim : forall b1 b2, b1 = b2 -> (Is_true b1 <-> Is_true b2). -Proof. - destr_bool; tauto. -Qed. - -Lemma negb_prop_elim : forall b, Is_true (negb b) -> ~ Is_true b. -Proof. - destr_bool; tauto. -Qed. - -Lemma negb_prop_intro : forall b, ~ Is_true b -> Is_true (negb b). -Proof. - destr_bool; tauto. -Qed. - -Lemma negb_prop_classical : forall b, ~ Is_true (negb b) -> Is_true b. -Proof. - destr_bool; tauto. -Qed. - -Lemma negb_prop_involutive : forall b, Is_true b -> ~ Is_true (negb b). -Proof. - destr_bool; tauto. -Qed. - -(** Rewrite rules about andb, orb and if (used in romega) *) - -Lemma andb_if : forall (A:Type)(a a':A)(b b' : bool), - (if b && b' then a else a') = - (if b then if b' then a else a' else a'). -Proof. - destr_bool. -Qed. - -Lemma negb_if : forall (A:Type)(a a':A)(b:bool), - (if negb b then a else a') = - (if b then a' else a). -Proof. - destr_bool. -Qed. - -(***********************************************) -(** * Alternative versions of [andb] and [orb] - with lazy behavior (for vm_compute) *) -(***********************************************) - -Declare Scope lazy_bool_scope. - -Notation "a &&& b" := (if a then b else false) - (at level 40, left associativity) : lazy_bool_scope. -Notation "a ||| b" := (if a then true else b) - (at level 50, left associativity) : lazy_bool_scope. - -Local Open Scope lazy_bool_scope. - -Lemma andb_lazy_alt : forall a b : bool, a && b = a &&& b. -Proof. - reflexivity. -Qed. - -Lemma orb_lazy_alt : forall a b : bool, a || b = a ||| b. -Proof. - reflexivity. -Qed. - -(************************************************) -(** * Reflect: a specialized inductive type for - relating propositions and booleans, - as popularized by the Ssreflect library. *) -(************************************************) - -Notation reflect := Datatypes.reflect (only parsing). -Notation ReflectT := Datatypes.ReflectT (only parsing). -Notation ReflectF := Datatypes.ReflectF (only parsing). - -(** Interest: a case on a reflect lemma or hyp performs clever - unification, and leave the goal in a convenient shape - (a bit like case_eq). *) - -(** Relation with iff : *) - -Lemma reflect_iff : forall P b, reflect P b -> (P<->b=true). -Proof. - destruct 1; intuition; discriminate. -Qed. - -Lemma iff_reflect : forall P b, (P<->b=true) -> reflect P b. -Proof. - destr_bool; intuition. -Defined. - -(** It would be nice to join [reflect_iff] and [iff_reflect] - in a unique [iff] statement, but this isn't allowed since - [iff] is in Prop. *) - -(** Reflect implies decidability of the proposition *) - -Lemma reflect_dec : forall P b, reflect P b -> {P}+{~P}. -Proof. - destruct 1; auto. -Defined. - -(** Reciprocally, from a decidability, we could state a - [reflect] as soon as we have a [bool_of_sumbool]. *) - -(** For instance, we could state the correctness of [Bool.eqb] via [reflect]: *) - -Lemma eqb_spec (b b' : bool) : reflect (b = b') (eqb b b'). -Proof. - destruct b, b'; now constructor. -Defined. - -(** Notations *) -Module BoolNotations. -Infix "<=" := le : bool_scope. -Infix "<" := lt : bool_scope. -Infix "?=" := compare (at level 70) : bool_scope. -Infix "=?" := eqb (at level 70) : bool_scope. -End BoolNotations. diff --git a/stdlib/theories/Bool/BoolEq.v b/stdlib/theories/Bool/BoolEq.v deleted file mode 100644 index f2d654d7495b..000000000000 --- a/stdlib/theories/Bool/BoolEq.v +++ /dev/null @@ -1,74 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* A -> bool. - - Variable beq_refl : forall x:A, true = beq x x. - - Variable beq_eq : forall x y:A, true = beq x y -> x = y. - - Definition beq_eq_true : forall x y:A, x = y -> true = beq x y. - Proof. - intros x y H. - case H. - apply beq_refl. - Defined. - - Definition beq_eq_not_false : forall x y:A, x = y -> false <> beq x y. - Proof. - intros x y e. - rewrite <- beq_eq_true; trivial; discriminate. - Defined. - - Definition beq_false_not_eq : forall x y:A, false = beq x y -> x <> y. - Proof. - exact - (fun (x y:A) (H:false = beq x y) (e:x = y) => beq_eq_not_false x y e H). - Defined. - - Definition exists_beq_eq : forall x y:A, {b : bool | b = beq x y}. - Proof. - intros x y. - exists (beq x y). - constructor. - Defined. - - Definition not_eq_false_beq : forall x y:A, x <> y -> false = beq x y. - Proof. - intros x y H. - symmetry . - apply not_true_is_false. - intro. - apply H. - apply beq_eq. - symmetry . - assumption. - Defined. - - Definition eq_dec : forall x y:A, {x = y} + {x <> y}. - Proof. - intros x y; case (exists_beq_eq x y). - intros b; case b; intro H. - - left; apply beq_eq; assumption. - - right; apply beq_false_not_eq; assumption. - Defined. - -End Bool_eq_dec. diff --git a/stdlib/theories/Bool/BoolOrder.v b/stdlib/theories/Bool/BoolOrder.v deleted file mode 100644 index 6c7b0f3ce553..000000000000 --- a/stdlib/theories/Bool/BoolOrder.v +++ /dev/null @@ -1,106 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* b2 <= b3 -> b1 <= b3. -Proof. destr_bool. Qed. - -Lemma le_true : forall b, b <= true. -Proof. destr_bool. Qed. - -Lemma false_le : forall b, false <= b. -Proof. intros; constructor. Qed. - -#[global] -Instance le_compat : Proper (eq ==> eq ==> iff) Bool.le. -Proof. intuition. Qed. - -(** * Strict order [lt] *) - -Lemma lt_irrefl : forall b, ~ b < b. -Proof. destr_bool; auto. Qed. - -Lemma lt_trans : forall b1 b2 b3, - b1 < b2 -> b2 < b3 -> b1 < b3. -Proof. destr_bool; auto. Qed. - -#[global] -Instance lt_compat : Proper (eq ==> eq ==> iff) Bool.lt. -Proof. intuition. Qed. - -Lemma lt_trichotomy : forall b1 b2, { b1 < b2 } + { b1 = b2 } + { b2 < b1 }. -Proof. destr_bool; auto. Qed. - -Lemma lt_total : forall b1 b2, b1 < b2 \/ b1 = b2 \/ b2 < b1. -Proof. destr_bool; auto. Qed. - -Lemma lt_le_incl : forall b1 b2, b1 < b2 -> b1 <= b2. -Proof. destr_bool; auto. Qed. - -Lemma le_lteq_dec : forall b1 b2, b1 <= b2 -> { b1 < b2 } + { b1 = b2 }. -Proof. destr_bool; auto. Qed. - -Lemma le_lteq : forall b1 b2, b1 <= b2 <-> b1 < b2 \/ b1 = b2. -Proof. destr_bool; intuition. Qed. - - -(** * Order structures *) - -(* Class structure *) -#[global] -Instance le_preorder : PreOrder Bool.le. -Proof. -split. -- intros b; apply le_refl. -- intros b1 b2 b3; apply le_trans. -Qed. - -#[global] -Instance lt_strorder : StrictOrder Bool.lt. -Proof. -split. -- intros b; apply lt_irrefl. -- intros b1 b2 b3; apply lt_trans. -Qed. - -(* Module structure *) -Module BoolOrd <: UsualDecidableTypeFull <: OrderedTypeFull <: TotalOrder. - Definition t := bool. - Definition eq := @eq bool. - Definition eq_equiv := @eq_equivalence bool. - Definition lt := Bool.lt. - Definition lt_strorder := lt_strorder. - Definition lt_compat := lt_compat. - Definition le := Bool.le. - Definition le_lteq := le_lteq. - Definition lt_total := lt_total. - Definition compare := Bool.compare. - Definition compare_spec := compare_spec. - Definition eq_dec := bool_dec. - Definition eq_refl := @eq_Reflexive bool. - Definition eq_sym := @eq_Symmetric bool. - Definition eq_trans := @eq_Transitive bool. - Definition eqb := eqb. - Definition eqb_eq := eqb_true_iff. -End BoolOrd. diff --git a/stdlib/theories/Bool/Bvector.v b/stdlib/theories/Bool/Bvector.v deleted file mode 100644 index faae5ce7b5cd..000000000000 --- a/stdlib/theories/Bool/Bvector.v +++ /dev/null @@ -1,142 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* . *) -Attributes deprecated(since="8.20", note="Consider [list bool] instead. See for details. Please open an issue if you would like to keep using Bvector."). -Local Set Warnings "-deprecated". - -(** Bit vectors. Contribution by Jean Duprat (ENS Lyon). *) - -Require Export Bool Sumbool. -#[local] Set Warnings "-stdlib-vector". -Require Vector. -Export Vector.VectorNotations. - -Local Open Scope nat_scope. - -(** -We build bit vectors in the spirit of List.v. -The size of the vector is a parameter which is too important -to be accessible only via function "length". -The first idea is to build a record with both the list and the length. -Unfortunately, this a posteriori verification leads to -numerous lemmas for handling lengths. -The second idea is to use a dependent type in which the length -is a building parameter. This leads to structural induction that -are slightly more complex and in some cases we will use a proof-term -as definition, since the type inference mechanism for pattern-matching -is sometimes weaker that the one implemented for elimination tactiques. -*) - -Section BOOLEAN_VECTORS. - -(** -A bit vector is a vector over booleans. -Notice that the LEAST significant bit comes first (little-endian representation). -We extract the least significant bit (head) and the rest of the vector (tail). -We compute bitwise operation on vector: negation, and, or, xor. -We compute size-preserving shifts: to the left (towards most significant bits, -we hence use Vshiftout) and to the right (towards least significant bits, -we use Vshiftin) by inserting a 'carry' bit (logical shift) or by repeating -the most significant bit (arithmetical shift). -NOTA BENE: all shift operations expect predecessor of size as parameter -(they only work on non-empty vectors). -*) - -#[deprecated(since="8.20", note="Consider [list bool] instead. Please open an issue if you would like to keep using Bvector.")] -Definition Bvector := Vector.t bool. - -#[deprecated(since="8.20", note="Consider [list bool] instead. See for details. Please open an issue if you would like to keep using Bvector.")] -Definition Bnil := @Vector.nil bool. - -#[deprecated(since="8.20", note="Consider [list bool] instead. See for details. Please open an issue if you would like to keep using Bvector.")] -Definition Bcons := @Vector.cons bool. - -#[deprecated(since="8.20", note="Consider [list bool] instead. See for details. Please open an issue if you would like to keep using Bvector.")] -Definition Bvect_true := Vector.const true. - -#[deprecated(since="8.20", note="Consider [list bool] instead. See for details. Please open an issue if you would like to keep using Bvector.")] -Definition Bvect_false := Vector.const false. - -#[deprecated(since="8.20", note="Consider [list bool] instead. See for details. Please open an issue if you would like to keep using Bvector.")] -Definition Blow := @Vector.hd bool. - -#[deprecated(since="8.20", note="Consider [list bool] instead. See for details. Please open an issue if you would like to keep using Bvector.")] -Definition Bhigh := @Vector.tl bool. - -#[deprecated(since="8.20", note="Consider [list bool] instead. See for details. Please open an issue if you would like to keep using Bvector.")] -Definition Bsign := @Vector.last bool. - -#[deprecated(since="8.20", note="Consider [list bool] instead. See for details. Please open an issue if you would like to keep using Bvector.")] -Definition Bneg := @Vector.map _ _ negb. - -#[deprecated(since="8.20", note="Consider [list bool] instead. See for details. Please open an issue if you would like to keep using Bvector.")] -Definition BVand := @Vector.map2 _ _ _ andb. - -#[deprecated(since="8.20", note="Consider [list bool] instead. See for details. Please open an issue if you would like to keep using Bvector.")] -Definition BVor := @Vector.map2 _ _ _ orb. - -#[deprecated(since="8.20", note="Consider [list bool] instead. See for details. Please open an issue if you would like to keep using Bvector.")] -Definition BVxor := @Vector.map2 _ _ _ xorb. - -#[deprecated(since="8.20", note="Consider [list bool] instead. See for details. Please open an issue if you would like to keep using Bvector.")] -Definition BVeq m n := @Vector.eqb bool eqb m n. - -#[deprecated(since="8.20", note="Consider [list bool] instead. See for details. Please open an issue if you would like to keep using Bvector.")] -Definition BshiftL (n:nat) (bv:Bvector (S n)) (carry:bool) := - Bcons carry n (Vector.shiftout bv). - -#[deprecated(since="8.20", note="Consider [list bool] instead. See for details. Please open an issue if you would like to keep using Bvector.")] -Definition BshiftRl (n:nat) (bv:Bvector (S n)) (carry:bool) := - Bhigh (S n) (Vector.shiftin carry bv). - -#[deprecated(since="8.20", note="Consider [list bool] instead. See for details. Please open an issue if you would like to keep using Bvector.")] -Definition BshiftRa (n:nat) (bv:Bvector (S n)) := - Bhigh (S n) (Vector.shiftrepeat bv). - -#[deprecated(since="8.20", note="Consider [list bool] instead. See for details. Please open an issue if you would like to keep using Bvector.")] -Fixpoint BshiftL_iter (n:nat) (bv:Bvector (S n)) (p:nat) : Bvector (S n) := - match p with - | O => bv - | S p' => BshiftL n (BshiftL_iter n bv p') false - end. - -#[deprecated(since="8.20", note="Consider [list bool] instead. See for details. Please open an issue if you would like to keep using Bvector.")] -Fixpoint BshiftRl_iter (n:nat) (bv:Bvector (S n)) (p:nat) : Bvector (S n) := - match p with - | O => bv - | S p' => BshiftRl n (BshiftRl_iter n bv p') false - end. - -#[deprecated(since="8.20", note="Consider [list bool] instead. See for details. Please open an issue if you would like to keep using Bvector.")] -Fixpoint BshiftRa_iter (n:nat) (bv:Bvector (S n)) (p:nat) : Bvector (S n) := - match p with - | O => bv - | S p' => BshiftRa n (BshiftRa_iter n bv p') - end. - -End BOOLEAN_VECTORS. - -Module BvectorNotations. -Declare Scope Bvector_scope. -Delimit Scope Bvector_scope with Bvector. -#[deprecated(since="8.20", note="Consider [list bool] instead. See for details. Please open an issue if you would like to keep using Bvector.")] -Notation "^~ x" := (Bneg _ x) (at level 35, right associativity) : Bvector_scope. -#[deprecated(since="8.20", note="Consider [list bool] instead. See for details. Please open an issue if you would like to keep using Bvector.")] -Infix "^&" := (BVand _) (at level 40, left associativity) : Bvector_scope. -#[deprecated(since="8.20", note="Consider [list bool] instead. See for details. Please open an issue if you would like to keep using Bvector.")] -Infix "^āŠ•" := (BVxor _) (at level 45, left associativity) : Bvector_scope. -#[deprecated(since="8.20", note="Consider [list bool] instead. See for details. Please open an issue if you would like to keep using Bvector.")] -Infix "^|" := (BVor _) (at level 50, left associativity) : Bvector_scope. -#[deprecated(since="8.20", note="Consider [list bool] instead. See for details. Please open an issue if you would like to keep using Bvector.")] -Infix "=?" := (BVeq _ _) (at level 70, no associativity) : Bvector_scope. -Open Scope Bvector_scope. -End BvectorNotations. diff --git a/stdlib/theories/Bool/DecBool.v b/stdlib/theories/Bool/DecBool.v deleted file mode 100644 index 9b34687cc741..000000000000 --- a/stdlib/theories/Bool/DecBool.v +++ /dev/null @@ -1,33 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* forall x y:C, ifdec H x y = x. -Proof. - intros A B C H **; case H; auto. - intro; absurd B; trivial. -Qed. - -Theorem ifdec_right : - forall (A B:Prop) (C:Set) (H:{A} + {B}), - ~ A -> forall x y:C, ifdec H x y = y. -Proof. - intros A B C H **; case H; auto. - intro; absurd A; trivial. -Qed. - -Unset Implicit Arguments. diff --git a/stdlib/theories/Bool/IfProp.v b/stdlib/theories/Bool/IfProp.v deleted file mode 100644 index b4149538adc3..000000000000 --- a/stdlib/theories/Bool/IfProp.v +++ /dev/null @@ -1,51 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* Prop := - | Iftrue : A -> IfProp A B true - | Iffalse : B -> IfProp A B false. - -#[global] -Hint Resolve Iftrue Iffalse: bool. - -Lemma Iftrue_inv : forall (A B:Prop) (b:bool), IfProp A B b -> b = true -> A. -destruct 1; intros; auto with bool. -case diff_true_false; auto with bool. -Qed. - -Lemma Iffalse_inv : - forall (A B:Prop) (b:bool), IfProp A B b -> b = false -> B. -destruct 1; intros; auto with bool. -case diff_true_false; trivial with bool. -Qed. - -Lemma IfProp_true : forall A B:Prop, IfProp A B true -> A. -intros A B H. -inversion H. -assumption. -Qed. - -Lemma IfProp_false : forall A B:Prop, IfProp A B false -> B. -intros A B H. -inversion H. -assumption. -Qed. - -Lemma IfProp_or : forall (A B:Prop) (b:bool), IfProp A B b -> A \/ B. -destruct 1; auto with bool. -Qed. - -Lemma IfProp_sum : forall (A B:Prop) (b:bool), IfProp A B b -> {A} + {B}. -intros A B b; destruct b; intro H. -- left; inversion H; auto with bool. -- right; inversion H; auto with bool. -Qed. diff --git a/stdlib/theories/Bool/Zerob.v b/stdlib/theories/Bool/Zerob.v deleted file mode 100644 index c11822e0d3dc..000000000000 --- a/stdlib/theories/Bool/Zerob.v +++ /dev/null @@ -1,44 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* true - | S _ => false - end. - -Lemma zerob_true_intro (n : nat) : n = 0 -> zerob n = true. -Proof. - destruct n; [ trivial with bool | inversion 1 ]. -Qed. -#[global] -Hint Resolve zerob_true_intro: bool. - -Lemma zerob_true_elim (n : nat) : zerob n = true -> n = 0. -Proof. - destruct n; [ trivial with bool | inversion 1 ]. -Qed. - -Lemma zerob_false_intro (n : nat) : n <> 0 -> zerob n = false. -Proof. - destruct n; [ destruct 1; auto with bool | trivial with bool ]. -Qed. -#[global] -Hint Resolve zerob_false_intro: bool. - -Lemma zerob_false_elim (n : nat) : zerob n = false -> n <> 0. -Proof. - destruct n; [ inversion 1 | auto with bool ]. -Qed. diff --git a/stdlib/theories/Classes/CEquivalence.v b/stdlib/theories/Classes/CEquivalence.v deleted file mode 100644 index 6d815610fda6..000000000000 --- a/stdlib/theories/Classes/CEquivalence.v +++ /dev/null @@ -1,153 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* substitute H ; clear H x - end. - -Ltac setoid_subst_nofail := - match goal with - | [ H : ?x === ?y |- _ ] => setoid_subst H ; setoid_subst_nofail - | _ => idtac - end. - -(** [subst*] will try its best at substituting every equality in the goal. *) - -Tactic Notation "subst" "*" := subst_no_fail ; setoid_subst_nofail. - -(** Simplify the goal w.r.t. equivalence. *) - -Ltac equiv_simplify_one := - match goal with - | [ H : ?x === ?x |- _ ] => clear H - | [ H : ?x === ?y |- _ ] => setoid_subst H - | [ |- ?x =/= ?y ] => let name:=fresh "Hneq" in intro name - | [ |- ~ ?x === ?y ] => let name:=fresh "Hneq" in intro name - end. - -Ltac equiv_simplify := repeat equiv_simplify_one. - -(** "reify" relations which are equivalences to applications of the overloaded [equiv] method - for easy recognition in tactics. *) - -Ltac equivify_tac := - match goal with - | [ s : Equivalence ?A ?R, H : ?R ?x ?y |- _ ] => change R with (@equiv A R s) in H - | [ s : Equivalence ?A ?R |- context C [ ?R ?x ?y ] ] => change (R x y) with (@equiv A R s x y) - end. - -Ltac equivify := repeat equivify_tac. - -Section Respecting. - - (** Here we build an equivalence instance for functions which relates respectful ones only, - we do not export it. *) - - Definition respecting `(eqa : Equivalence A (R : crelation A), - eqb : Equivalence B (R' : crelation B)) : Type := - { morph : A -> B & respectful R R' morph morph }. - - Program Instance respecting_equiv `(eqa : Equivalence A R, eqb : Equivalence B R') : - Equivalence (fun (f g : respecting eqa eqb) => - forall (x y : A), R x y -> R' (projT1 f x) (projT1 g y)). - - Solve Obligations with unfold respecting in * ; simpl_crelation ; program_simpl. - - Next Obligation. - Proof. - intros. intros f g h H H' x y Rxy. - unfold respecting in *. program_simpl. transitivity (g y); auto. firstorder. - Qed. - -End Respecting. - -(** The default equivalence on function spaces, with higher-priority than [eq]. *) - -#[global] -Instance pointwise_reflexive {A} `(reflb : Reflexive B eqB) : - Reflexive (pointwise_relation A eqB) | 9. -Proof. firstorder. Qed. -#[global] -Instance pointwise_symmetric {A} `(symb : Symmetric B eqB) : - Symmetric (pointwise_relation A eqB) | 9. -Proof. firstorder. Qed. -#[global] -Instance pointwise_transitive {A} `(transb : Transitive B eqB) : - Transitive (pointwise_relation A eqB) | 9. -Proof. firstorder. Qed. -#[global] -Instance pointwise_equivalence {A} `(eqb : Equivalence B eqB) : - Equivalence (pointwise_relation A eqB) | 9. -Proof. split; apply _. Qed. diff --git a/stdlib/theories/Classes/CMorphisms.v b/stdlib/theories/Classes/CMorphisms.v deleted file mode 100644 index 7b285ab2b58a..000000000000 --- a/stdlib/theories/Classes/CMorphisms.v +++ /dev/null @@ -1 +0,0 @@ -From Corelib Require Export CMorphisms. diff --git a/stdlib/theories/Classes/CRelationClasses.v b/stdlib/theories/Classes/CRelationClasses.v deleted file mode 100644 index 09be8b926659..000000000000 --- a/stdlib/theories/Classes/CRelationClasses.v +++ /dev/null @@ -1 +0,0 @@ -From Corelib Require Export CRelationClasses. diff --git a/stdlib/theories/Classes/DecidableClass.v b/stdlib/theories/Classes/DecidableClass.v deleted file mode 100644 index 786c5c675d7a..000000000000 --- a/stdlib/theories/Classes/DecidableClass.v +++ /dev/null @@ -1,72 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* P -}. - -(** Alternative ways of specifying the reflection property. *) - -Lemma Decidable_sound : forall P (H : Decidable P), - Decidable_witness = true -> P. -Proof. -intros P H Hp; apply -> Decidable_spec; assumption. -Qed. - -Lemma Decidable_complete : forall P (H : Decidable P), - P -> Decidable_witness = true. -Proof. -intros P H Hp; apply <- Decidable_spec; assumption. -Qed. - -Lemma Decidable_sound_alt : forall P (H : Decidable P), - ~ P -> Decidable_witness = false. -Proof. -intros P [wit spec] Hd; simpl; destruct wit; tauto. -Qed. - -Lemma Decidable_complete_alt : forall P (H : Decidable P), - Decidable_witness = false -> ~ P. -Proof. -intros P [wit spec] Hd Hc; simpl in *; intuition congruence. -Qed. - -(** The generic function that should be used to program, together with some - useful tactics. *) - -Definition decide P {H : Decidable P} := @Decidable_witness _ H. - -Ltac _decide_ P H := - let b := fresh "b" in - set (b := decide P) in *; - assert (H : decide P = b) by reflexivity; - clearbody b; - destruct b; [apply Decidable_sound in H|apply Decidable_complete_alt in H]. - -Tactic Notation "decide" constr(P) "as" ident(H) := - _decide_ P H. - -Tactic Notation "decide" constr(P) := - let H := fresh "H" in _decide_ P H. - -(** Some usual instances. *) - -#[global,refine] -Instance Decidable_not {P} `{Decidable P} : Decidable (~ P) := { - Decidable_witness := negb Decidable_witness -}. -Proof. - abstract (specialize Decidable_spec; case Decidable_witness; intuition discriminate). -Defined. diff --git a/stdlib/theories/Classes/EquivDec.v b/stdlib/theories/Classes/EquivDec.v deleted file mode 100644 index bd8ae905aa08..000000000000 --- a/stdlib/theories/Classes/EquivDec.v +++ /dev/null @@ -1,178 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* @right _ _ H - | right H => @left _ _ H - end. - -Local Open Scope program_scope. - -(** Invert the branches. *) - -Program Definition nequiv_dec `{EqDec A} (x y : A) : { x =/= y } + { x === y } := - swap_sumbool (x == y). - - -(** Overloaded notation for inequality. *) - -Infix "<>" := nequiv_dec (no associativity, at level 70) : equiv_scope. - -(** Define boolean versions, losing the logical information. *) - -Definition equiv_decb `{EqDec A} (x y : A) : bool := - if x == y then true else false. - -Definition nequiv_decb `{EqDec A} (x y : A) : bool := - negb (equiv_decb x y). - -Infix "==b" := equiv_decb (no associativity, at level 70). -Infix "<>b" := nequiv_decb (no associativity, at level 70). - -(** Decidable leibniz equality instances. *) - -(** The equiv is buried inside the setoid, but we can recover it by specifying - which setoid we're talking about. *) - -#[global] -Program Instance nat_eq_eqdec : EqDec nat eq := eq_nat_dec. - -#[global] -Program Instance bool_eqdec : EqDec bool eq := bool_dec. - -#[global] -Program Instance unit_eqdec : EqDec unit eq := fun x y => in_left. - - Next Obligation. - Proof. - do 2 match goal with [ x : () |- _ ] => destruct x end. - reflexivity. - Qed. - -#[global] Obligation Tactic := unfold complement, equiv ; program_simpl. -#[export] Obligation Tactic := unfold complement, equiv ; program_simpl. - -#[global] -Program Instance prod_eqdec `(EqDec A eq, EqDec B eq) : - EqDec (prod A B) eq := - { equiv_dec x y := - let '(x1, x2) := x in - let '(y1, y2) := y in - if x1 == y1 then - if x2 == y2 then in_left - else in_right - else in_right }. - -#[global] -Program Instance sum_eqdec `(EqDec A eq, EqDec B eq) : - EqDec (sum A B) eq := { - equiv_dec x y := - match x, y with - | inl a, inl b => if a == b then in_left else in_right - | inr a, inr b => if a == b then in_left else in_right - | inl _, inr _ | inr _, inl _ => in_right - end }. - -(** Objects of function spaces with countable domains like bool have decidable - equality. Proving the reflection requires functional extensionality though. *) - -#[global] -Program Instance bool_function_eqdec `(EqDec A eq) : EqDec (bool -> A) eq := - { equiv_dec f g := - if f true == g true then - if f false == g false then in_left - else in_right - else in_right }. - - Next Obligation. - Proof. - extensionality x. - destruct x ; auto. - Qed. - -Require Import List. - -#[global] -Program Instance list_eqdec `(eqa : EqDec A eq) : EqDec (list A) eq := - { equiv_dec := - fix aux (x y : list A) := - match x, y with - | nil, nil => in_left - | cons hd tl, cons hd' tl' => - if hd == hd' then - if aux tl tl' then in_left else in_right - else in_right - | _, _ => in_right - end }. - - Next Obligation. - match goal with y : list _ |- _ => destruct y end ; - unfold not in *; eauto. - Defined. - - Solve Obligations with unfold equiv, complement in * ; - program_simpl ; intuition (discriminate || eauto). - -#[export] -Program Instance option_eqdec `(eqa : EqDec A eq) : EqDec (option A) eq := - { equiv_dec (x y : option A) := - match x, y with - | None, None => in_left - | Some s, Some s' => - if s == s' then in_left else in_right - | _, _ => in_right - end - }. - - Next Obligation. - match goal with y : option _ |- _ => destruct y end ; - unfold not in *; eauto. - Defined. - - Solve Obligations with unfold equiv, complement in * ; - program_simpl; intuition (discriminate || eauto). diff --git a/stdlib/theories/Classes/Equivalence.v b/stdlib/theories/Classes/Equivalence.v deleted file mode 100644 index 1283fd2ba531..000000000000 --- a/stdlib/theories/Classes/Equivalence.v +++ /dev/null @@ -1 +0,0 @@ -From Corelib Require Export Equivalence. diff --git a/stdlib/theories/Classes/Init.v b/stdlib/theories/Classes/Init.v deleted file mode 100644 index 3d1b4f90c3b0..000000000000 --- a/stdlib/theories/Classes/Init.v +++ /dev/null @@ -1 +0,0 @@ -From Corelib Require Export Init. diff --git a/stdlib/theories/Classes/Morphisms.v b/stdlib/theories/Classes/Morphisms.v deleted file mode 100644 index 57a6ad7d603f..000000000000 --- a/stdlib/theories/Classes/Morphisms.v +++ /dev/null @@ -1 +0,0 @@ -From Corelib Require Export Morphisms. diff --git a/stdlib/theories/Classes/Morphisms_Prop.v b/stdlib/theories/Classes/Morphisms_Prop.v deleted file mode 100644 index 0ef02fe1fd0b..000000000000 --- a/stdlib/theories/Classes/Morphisms_Prop.v +++ /dev/null @@ -1 +0,0 @@ -From Corelib Require Export Morphisms_Prop. diff --git a/stdlib/theories/Classes/Morphisms_Relations.v b/stdlib/theories/Classes/Morphisms_Relations.v deleted file mode 100644 index c38d34cefb9f..000000000000 --- a/stdlib/theories/Classes/Morphisms_Relations.v +++ /dev/null @@ -1,61 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* - relation_equivalence ==> relation_equivalence) relation_conjunction. - Proof. firstorder. Qed. - -#[global] -Instance relation_disjunction_morphism {A} : Proper (relation_equivalence (A:=A) ==> - relation_equivalence ==> relation_equivalence) relation_disjunction. - Proof. firstorder. Qed. - -(* Predicate equivalence is exactly the same as the pointwise lifting of [iff]. *) - -Lemma predicate_equivalence_pointwise (l : Tlist) : - Proper (@predicate_equivalence l ==> pointwise_lifting iff l) id. -Proof. do 2 red. unfold predicate_equivalence. auto. Qed. - -Lemma predicate_implication_pointwise (l : Tlist) : - Proper (@predicate_implication l ==> pointwise_lifting impl l) id. -Proof. do 2 red. unfold predicate_implication. auto. Qed. - -(** The instantiation at relation allows rewriting applications of relations - [R x y] to [R' x y] when [R] and [R'] are in [relation_equivalence]. *) - -#[global] -Instance relation_equivalence_pointwise {A} : - Proper (relation_equivalence ==> pointwise_relation A (pointwise_relation A iff)) id. -Proof. intro. apply (predicate_equivalence_pointwise (Tcons A (Tcons A Tnil))). Qed. - -#[global] -Instance subrelation_pointwise {A} : - Proper (subrelation ==> pointwise_relation A (pointwise_relation A impl)) id. -Proof. intro. apply (predicate_implication_pointwise (Tcons A (Tcons A Tnil))). Qed. - - -Lemma flip_pointwise_relation A (R : relation A) : - relation_equivalence (pointwise_relation A (flip R)) (flip (pointwise_relation A R)). -Proof. intros. split; firstorder. Qed. diff --git a/stdlib/theories/Classes/RelationClasses.v b/stdlib/theories/Classes/RelationClasses.v deleted file mode 100644 index afca87709585..000000000000 --- a/stdlib/theories/Classes/RelationClasses.v +++ /dev/null @@ -1 +0,0 @@ -From Corelib Require Export RelationClasses. diff --git a/stdlib/theories/Classes/RelationPairs.v b/stdlib/theories/Classes/RelationPairs.v deleted file mode 100644 index cd0b778c6177..000000000000 --- a/stdlib/theories/Classes/RelationPairs.v +++ /dev/null @@ -1,191 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* B) : relation A := - fun a a' => R (f a) (f a'). - -(** Instances on RelCompFun must match syntactically *) -Global Typeclasses Opaque RelCompFun. - -Infix "@@" := RelCompFun (at level 30, right associativity) : signature_scope. - -Notation "R @@1" := (R @@ Fst)%signature (at level 30) : signature_scope. -Notation "R @@2" := (R @@ Snd)%signature (at level 30) : signature_scope. - -(** We declare measures to the system using the [Measure] class. - Otherwise the instances would easily introduce loops, - never instantiating the [f] function. *) - -Class Measure {A B} (f : A -> B). - -(** Standard measures. *) - -#[global] -Instance fst_measure {A B} : @Measure (A * B) A Fst := {}. - -#[global] -Instance snd_measure {A B} : @Measure (A * B) B Snd := {}. - -(** We define a product relation over [A*B]: each components should - satisfy the corresponding initial relation. *) - -Definition RelProd {A : Type} {B : Type} (RA:relation A)(RB:relation B) : relation (A*B) := - relation_conjunction (@RelCompFun (A * B) A RA fst) (RB @@2). - -Global Typeclasses Opaque RelProd. - -Infix "*" := RelProd : signature_scope. - -Section RelCompFun_Instances. - Context {A : Type} {B : Type} (R : relation B). - - Global Instance RelCompFun_Reflexive - `(Measure A B f, Reflexive _ R) : Reflexive (R@@f). - Proof. firstorder. Qed. - - Global Instance RelCompFun_Symmetric - `(Measure A B f, Symmetric _ R) : Symmetric (R@@f). - Proof. firstorder. Qed. - - Global Instance RelCompFun_Transitive - `(Measure A B f, Transitive _ R) : Transitive (R@@f). - Proof. firstorder. Qed. - - Global Instance RelCompFun_Irreflexive - `(Measure A B f, Irreflexive _ R) : Irreflexive (R@@f). - Proof. firstorder. Qed. - - Global Instance RelCompFun_Equivalence - `(Measure A B f, Equivalence _ R) : Equivalence (R@@f) := {}. - - Global Instance RelCompFun_StrictOrder - `(Measure A B f, StrictOrder _ R) : StrictOrder (R@@f) := {}. - -End RelCompFun_Instances. - -Section RelProd_Instances. - - Context {A : Type} {B : Type} (RA : relation A) (RB : relation B). - - Global Instance RelProd_Reflexive `(Reflexive _ RA, Reflexive _ RB) : Reflexive (RA*RB). - Proof. firstorder. Qed. - - Global Instance RelProd_Symmetric `(Symmetric _ RA, Symmetric _ RB) - : Symmetric (RA*RB). - Proof. firstorder. Qed. - - Global Instance RelProd_Transitive - `(Transitive _ RA, Transitive _ RB) : Transitive (RA*RB). - Proof. firstorder. Qed. - - Global Program Instance RelProd_Equivalence - `(Equivalence _ RA, Equivalence _ RB) : Equivalence (RA*RB). - - Lemma FstRel_ProdRel : - relation_equivalence (RA @@1) (RA*(fun _ _ : B => True)). - Proof. firstorder. Qed. - - Lemma SndRel_ProdRel : - relation_equivalence (RB @@2) ((fun _ _ : A =>True) * RB). - Proof. firstorder. Qed. - - Global Instance FstRel_sub : - subrelation (RA*RB) (RA @@1). - Proof. firstorder. Qed. - - Global Instance SndRel_sub : - subrelation (RA*RB) (RB @@2). - Proof. firstorder. Qed. - - Global Instance pair_compat : - Proper (RA==>RB==> RA*RB) (@pair _ _). - Proof. firstorder. Qed. - - Global Instance fst_compat : - Proper (RA*RB ==> RA) Fst. - Proof. - intros (x,y) (x',y') (Hx,Hy); compute in *; auto. - Qed. - - Global Instance snd_compat : - Proper (RA*RB ==> RB) Snd. - Proof. - intros (x,y) (x',y') (Hx,Hy); compute in *; auto. - Qed. - - Global Instance RelCompFun_compat (f:A->B) - `(Proper _ (Ri==>Ri==>Ro) RB) : - Proper (Ri@@f==>Ri@@f==>Ro) (RB@@f)%signature. - Proof. unfold RelCompFun; firstorder. Qed. -End RelProd_Instances. - -#[global] -Hint Unfold RelProd RelCompFun : core. -#[global] -Hint Extern 2 (RelProd _ _ _ _) => split : core. - -#[export] Instance Proper_RelProd_flip_impl: forall A B RA1 RA2 RB1 RB2 (RA : relation A) (RB : relation B), - Proper (RA1 ==> RA2 ==> Basics.flip Basics.impl) RA - -> Proper (RB1 ==> RB2 ==> Basics.flip Basics.impl) RB - -> Proper (RA1 * RB1 ==> RA2 * RB2 ==> Basics.flip Basics.impl) (RA * RB)%signature. -Proof. cbv; intuition eauto. Qed. - -#[export] Instance Proper_RelProd_impl: forall A B RA1 RA2 RB1 RB2 (RA : relation A) (RB : relation B), - Proper (RA1 ==> RA2 ==> Basics.impl) RA - -> Proper (RB1 ==> RB2 ==> Basics.impl) RB - -> Proper (RA1 * RB1 ==> RA2 * RB2 ==> Basics.impl) (RA * RB)%signature. -Proof. cbv; intuition eauto. Qed. - -#[export] Instance Proper_RelProd_iff: forall A B RA1 RA2 RB1 RB2 (RA : relation A) (RB : relation B), - Proper (RA1 ==> RA2 ==> iff) RA - -> Proper (RB1 ==> RB2 ==> iff) RB - -> Proper (RA1 * RB1 ==> RA2 * RB2 ==> iff) (RA * RB)%signature. -Proof. - intros A B RA1 RA2 RB1 RB2 RA RB H H0. cbv in *. - intros x y H1 x0 y0 H2. intuition eauto; - destruct x as [a b], y as [a0 b0], x0 as [a1 b1], y0 as [a2 b2]; - destruct H with a a0 a1 a2; - destruct H0 with b b0 b1 b2; - eauto. -Qed. diff --git a/stdlib/theories/Classes/SetoidClass.v b/stdlib/theories/Classes/SetoidClass.v deleted file mode 100644 index b17be647264b..000000000000 --- a/stdlib/theories/Classes/SetoidClass.v +++ /dev/null @@ -1,147 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* *) -(* equivalence_setoid : Setoid A := *) -(* equiv := eqA ; setoid_equiv := eqa. *) - -(** Shortcuts to make proof search easier. *) - -Lemma setoid_refl `(sa : Setoid A) : Reflexive equiv. -Proof. typeclasses eauto. Qed. - -Lemma setoid_sym `(sa : Setoid A) : Symmetric equiv. -Proof. typeclasses eauto. Qed. - -Lemma setoid_trans `(sa : Setoid A) : Transitive equiv. -Proof. typeclasses eauto. Qed. - -#[global] -Existing Instance setoid_refl. -#[global] -Existing Instance setoid_sym. -#[global] -Existing Instance setoid_trans. - -(** Standard setoids. *) - -(* Program Instance eq_setoid : Setoid A := *) -(* equiv := eq ; setoid_equiv := eq_equivalence. *) - -#[global] -Program Instance iff_setoid : Setoid Prop := - { equiv := iff ; setoid_equiv := iff_equivalence }. - -(** Overloaded notations for setoid equivalence and inequivalence. Not to be confused with [eq] and [=]. *) - -(** Subset objects should be first coerced to their underlying type, but that notation doesn't work in the standard case then. *) -(* Notation " x == y " := (equiv (x :>) (y :>)) (at level 70, no associativity) : type_scope. *) - -Notation " x == y " := (equiv x y) (at level 70, no associativity) : type_scope. - -Notation " x =/= y " := (complement equiv x y) (at level 70, no associativity) : type_scope. - -(** Use the [clsubstitute] command which substitutes an equality in every hypothesis. *) - -Ltac clsubst H := - lazymatch type of H with - ?x == ?y => substitute H ; clear H x - end. - -Ltac clsubst_nofail := - match goal with - | [ H : ?x == ?y |- _ ] => clsubst H ; clsubst_nofail - | _ => idtac - end. - -(** [subst*] will try its best at substituting every equality in the goal. *) - -Tactic Notation "clsubst" "*" := clsubst_nofail. - -Lemma nequiv_equiv_trans : forall `{Setoid A} (x y z : A), x =/= y -> y == z -> x =/= z. -Proof with auto. - intros A ? x y z H H0 H1. - assert(z == y) by (symmetry ; auto). - assert(x == y) by (transitivity z ; eauto). - contradiction. -Qed. - -Lemma equiv_nequiv_trans : forall `{Setoid A} (x y z : A), x == y -> y =/= z -> x =/= z. -Proof. - intros A ? x y z **; intro. - assert(y == x) by (symmetry ; auto). - assert(y == z) by (transitivity x ; eauto). - contradiction. -Qed. - -Ltac setoid_simplify_one := - match goal with - | [ H : (?x == ?x)%type |- _ ] => clear H - | [ H : (?x == ?y)%type |- _ ] => clsubst H - | [ |- (?x =/= ?y)%type ] => let name:=fresh "Hneq" in intro name - end. - -Ltac setoid_simplify := repeat setoid_simplify_one. - -Ltac setoidify_tac := - match goal with - | [ s : Setoid ?A, H : ?R ?x ?y |- _ ] => change R with (@equiv A R s) in H - | [ s : Setoid ?A |- context C [ ?R ?x ?y ] ] => change (R x y) with (@equiv A R s x y) - end. - -Ltac setoidify := repeat setoidify_tac. - -(** Every setoid relation gives rise to a morphism, in fact every partial setoid does. *) - -#[global] -Program Instance setoid_morphism `(sa : Setoid A) : Proper (equiv ++> equiv ++> iff) equiv := - proper_prf. - -#[global] -Program Instance setoid_partial_app_morphism `(sa : Setoid A) (x : A) : Proper (equiv ++> iff) (equiv x) := - proper_prf. - -(** Partial setoids don't require reflexivity so we can build a partial setoid on the function space. *) - -Class PartialSetoid (A : Type) := - { pequiv : relation A ; #[global] pequiv_prf :: PER pequiv }. - -(** Overloaded notation for partial setoid equivalence. *) - -Infix "=~=" := pequiv (at level 70, no associativity) : type_scope. - -(** Reset the default Program tactic. *) - -#[global] Obligation Tactic := program_simpl. -#[export] Obligation Tactic := program_simpl. diff --git a/stdlib/theories/Classes/SetoidDec.v b/stdlib/theories/Classes/SetoidDec.v deleted file mode 100644 index 7e6d9282d002..000000000000 --- a/stdlib/theories/Classes/SetoidDec.v +++ /dev/null @@ -1,138 +0,0 @@ -(* -*- coding: utf-8 -*- *) -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* @right _ _ H - | right H => @left _ _ H - end. - -Require Import Stdlib.Program.Program. - -Local Open Scope program_scope. - -(** Invert the branches. *) - -Program Definition nequiv_dec `{EqDec A} (x y : A) : { x =/= y } + { x == y } := swap_sumbool (x == y). - -(** Overloaded notation for inequality. *) - -Infix "=/=" := nequiv_dec (no associativity, at level 70). - -(** Define boolean versions, losing the logical information. *) - -Definition equiv_decb `{EqDec A} (x y : A) : bool := - if x == y then true else false. - -Definition nequiv_decb `{EqDec A} (x y : A) : bool := - negb (equiv_decb x y). - -Infix "==b" := equiv_decb (no associativity, at level 70). -Infix "<>b" := nequiv_decb (no associativity, at level 70). - -(** Decidable leibniz equality instances. *) - -Require Import Stdlib.Arith.Arith. - -(** The equiv is buried inside the setoid, but we can recover - it by specifying which setoid we're talking about. *) - -#[global] -Program Instance eq_setoid A : Setoid A | 10 := - { equiv := eq ; setoid_equiv := eq_equivalence }. - -#[global] -Program Instance nat_eq_eqdec : EqDec (eq_setoid nat) := - eq_nat_dec. - -Require Import Stdlib.Bool.Bool. - -#[global] -Program Instance bool_eqdec : EqDec (eq_setoid bool) := - bool_dec. - -#[global] -Program Instance unit_eqdec : EqDec (eq_setoid unit) := - fun x y => in_left. - - Next Obligation. - Proof. - do 2 match goal with x : () |- _ => destruct x end. - reflexivity. - Qed. - -#[global] -Program Instance prod_eqdec `(! EqDec (eq_setoid A), ! EqDec (eq_setoid B)) - : EqDec (eq_setoid (prod A B)) := - fun x y => - let '(x1, x2) := x in - let '(y1, y2) := y in - if x1 == y1 then - if x2 == y2 then in_left - else in_right - else in_right. - - Solve Obligations with unfold complement ; program_simpl. - -(** Objects of function spaces with countable domains like bool - have decidable equality. *) - -#[global] -Program Instance bool_function_eqdec `(! EqDec (eq_setoid A)) - : EqDec (eq_setoid (bool -> A)) := - fun f g => - if f true == g true then - if f false == g false then in_left - else in_right - else in_right. - - Solve Obligations with try red ; unfold complement ; program_simpl. - - Next Obligation. - Proof. - extensionality x. - destruct x ; auto. - Qed. diff --git a/stdlib/theories/Classes/SetoidTactics.v b/stdlib/theories/Classes/SetoidTactics.v deleted file mode 100644 index 0bd2069a6339..000000000000 --- a/stdlib/theories/Classes/SetoidTactics.v +++ /dev/null @@ -1 +0,0 @@ -From Corelib Require Export SetoidTactics. diff --git a/stdlib/theories/Compat/AdmitAxiom.v b/stdlib/theories/Compat/AdmitAxiom.v deleted file mode 100644 index 9d7f7aa3a976..000000000000 --- a/stdlib/theories/Compat/AdmitAxiom.v +++ /dev/null @@ -1,17 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* _ |- _ ] => specialize (H eq_refl) - | [ H : ?x <> ?x -> _ |- _ ] => clear H - | [ H : ?x < ?x -> _ |- _ ] => clear H - | [ H : ?T -> _, H' : ?T |- _ ] => specialize (H H') - | [ H : ?T -> _, H' : ~?T |- _ ] => clear H - | [ H : ~?T -> _, H' : ?T |- _ ] => clear H - | [ H : ?A -> ?x = ?x -> _ |- _ ] => specialize (fun a => H a eq_refl) - | [ H : ?A -> ?x <> ?x -> _ |- _ ] => clear H - | [ H : ?A -> ?x < ?x -> _ |- _ ] => clear H - | [ H : ?A -> ?B -> _, H' : ?B |- _ ] => specialize (fun a => H a H') - | [ H : ?A -> ?B -> _, H' : ~?B |- _ ] => clear H - | [ H : ?A -> ~?B -> _, H' : ?B |- _ ] => clear H - | [ H : 0 < ?x -> _, H' : ?x < 0 |- _ ] => clear H - | [ H : ?x < 0 -> _, H' : 0 < ?x |- _ ] => clear H - | [ H : ?A -> 0 < ?x -> _, H' : ?x < 0 |- _ ] => clear H - | [ H : ?A -> ?x < 0 -> _, H' : 0 < ?x |- _ ] => clear H - | [ H : 0 <= ?x -> _, H' : ?x < 0 |- _ ] => clear H - | [ H : ?x <= 0 -> _, H' : 0 < ?x |- _ ] => clear H - | [ H : ?A -> 0 <= ?x -> _, H' : ?x < 0 |- _ ] => clear H - | [ H : ?A -> ?x <= 0 -> _, H' : 0 < ?x |- _ ] => clear H - | [ H : 0 < ?x -> _, H' : ?x <= 0 |- _ ] => clear H - | [ H : ?x < 0 -> _, H' : 0 <= ?x |- _ ] => clear H - | [ H : ?A -> 0 < ?x -> _, H' : ?x <= 0 |- _ ] => clear H - | [ H : ?A -> ?x < 0 -> _, H' : 0 <= ?x |- _ ] => clear H - | [ H : 0 <= ?x -> _, H' : ?x <= 0 |- _ ] => specialize (fun pf => H (@Z.eq_le_incl 0 x (eq_sym pf))) - | [ H : ?A -> 0 <= ?x -> _, H' : ?x <= 0 |- _ ] => specialize (fun a pf => H a (@Z.eq_le_incl 0 x (eq_sym pf))) - | [ H : ?x <= 0 -> _, H' : 0 <= ?x |- _ ] => specialize (fun pf => H (@Z.eq_le_incl 0 x pf)) - | [ H : ?A -> ?x <= 0 -> _, H' : 0 <= ?x |- _ ] => specialize (fun a pf => H a (@Z.eq_le_incl x 0 pf)) - | [ H : ?x < ?y -> _, H' : ?x = ?y |- _ ] => clear H - | [ H : ?x < ?y -> _, H' : ?y = ?x |- _ ] => clear H - | [ H : ?A -> ?x < ?y -> _, H' : ?x = ?y |- _ ] => clear H - | [ H : ?A -> ?x < ?y -> _, H' : ?y = ?x |- _ ] => clear H - | [ H : ?x = ?y -> _, H' : ?x < ?y |- _ ] => clear H - | [ H : ?x = ?y -> _, H' : ?y < ?x |- _ ] => clear H - | [ H : ?A -> ?x = ?y -> _, H' : ?x < ?y |- _ ] => clear H - | [ H : ?A -> ?x = ?y -> _, H' : ?y < ?x |- _ ] => clear H - end. diff --git a/stdlib/theories/FSets/FMapAVL.v b/stdlib/theories/FSets/FMapAVL.v deleted file mode 100644 index 9c9da35a9f5e..000000000000 --- a/stdlib/theories/FSets/FMapAVL.v +++ /dev/null @@ -1,2516 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* key -> elt -> tree -> int -> tree. -Arguments tree : clear implicits. - -Section Elt. - -Variable elt : Type. - -Notation t := (tree elt). - -Implicit Types m : t. - -(** * Basic functions on trees: height and cardinal *) - -Definition height (m : t) : int := - match m with - | Leaf => 0 - | Node _ _ _ _ h => h - end. - -Fixpoint cardinal (m : t) : nat := - match m with - | Leaf => 0%nat - | Node l _ _ r _ => S (cardinal l + cardinal r) - end. - -(** * Empty Map *) - -Definition empty : t := Leaf. - -(** * Emptyness test *) - -Definition is_empty m := match m with Leaf => true | _ => false end. - -(** * Membership *) - -(** The [mem] function is deciding membership. It exploits the [bst] property - to achieve logarithmic complexity. *) - -Fixpoint mem x m : bool := - match m with - | Leaf => false - | Node l y _ r _ => match X.compare x y with - | LT _ => mem x l - | EQ _ => true - | GT _ => mem x r - end - end. - -Fixpoint find x m : option elt := - match m with - | Leaf => None - | Node l y d r _ => match X.compare x y with - | LT _ => find x l - | EQ _ => Some d - | GT _ => find x r - end - end. - -(** * Helper functions *) - -(** [create l x r] creates a node, assuming [l] and [r] - to be balanced and [|height l - height r| <= 2]. *) - -Definition create l x e r := - Node l x e r (max (height l) (height r) + 1). - -(** [bal l x e r] acts as [create], but performs one step of - rebalancing if necessary, i.e. assumes [|height l - height r| <= 3]. *) - -Definition assert_false := create. - -Definition bal l x d r := - let hl := height l in - let hr := height r in - if gt_le_dec hl (hr+2) then - match l with - | Leaf => assert_false l x d r - | Node ll lx ld lr _ => - if ge_lt_dec (height ll) (height lr) then - create ll lx ld (create lr x d r) - else - match lr with - | Leaf => assert_false l x d r - | Node lrl lrx lrd lrr _ => - create (create ll lx ld lrl) lrx lrd (create lrr x d r) - end - end - else - if gt_le_dec hr (hl+2) then - match r with - | Leaf => assert_false l x d r - | Node rl rx rd rr _ => - if ge_lt_dec (height rr) (height rl) then - create (create l x d rl) rx rd rr - else - match rl with - | Leaf => assert_false l x d r - | Node rll rlx rld rlr _ => - create (create l x d rll) rlx rld (create rlr rx rd rr) - end - end - else - create l x d r. - -(** * Insertion *) - -Fixpoint add x d m := - match m with - | Leaf => Node Leaf x d Leaf 1 - | Node l y d' r h => - match X.compare x y with - | LT _ => bal (add x d l) y d' r - | EQ _ => Node l y d r h - | GT _ => bal l y d' (add x d r) - end - end. - -(** * Extraction of minimum binding - - Morally, [remove_min] is to be applied to a non-empty tree - [t = Node l x e r h]. Since we can't deal here with [assert false] - for [t=Leaf], we pre-unpack [t] (and forget about [h]). -*) - -Fixpoint remove_min l x d r : t*(key*elt) := - match l with - | Leaf => (r,(x,d)) - | Node ll lx ld lr lh => - let (l',m) := remove_min ll lx ld lr in - (bal l' x d r, m) - end. - -(** * Merging two trees - - [merge t1 t2] builds the union of [t1] and [t2] assuming all elements - of [t1] to be smaller than all elements of [t2], and - [|height t1 - height t2| <= 2]. -*) - -Definition merge s1 s2 := match s1,s2 with - | Leaf, _ => s2 - | _, Leaf => s1 - | _, Node l2 x2 d2 r2 h2 => - match remove_min l2 x2 d2 r2 with - (s2',(x,d)) => bal s1 x d s2' - end -end. - -(** * Deletion *) - -Fixpoint remove x m := match m with - | Leaf => Leaf - | Node l y d r h => - match X.compare x y with - | LT _ => bal (remove x l) y d r - | EQ _ => merge l r - | GT _ => bal l y d (remove x r) - end - end. - -(** * join - - Same as [bal] but does not assume anything regarding heights of [l] - and [r]. -*) - -Fixpoint join l : key -> elt -> t -> t := - match l with - | Leaf => add - | Node ll lx ld lr lh => fun x d => - fix join_aux (r:t) : t := match r with - | Leaf => add x d l - | Node rl rx rd rr rh => - if gt_le_dec lh (rh+2) then bal ll lx ld (join lr x d r) - else if gt_le_dec rh (lh+2) then bal (join_aux rl) rx rd rr - else create l x d r - end - end. - -(** * Splitting - - [split x m] returns a triple [(l, o, r)] where - - [l] is the set of elements of [m] that are [< x] - - [r] is the set of elements of [m] that are [> x] - - [o] is the result of [find x m]. -*) - -Record triple := mktriple { t_left:t; t_opt:option elt; t_right:t }. -Notation "<< l , b , r >>" := (mktriple l b r) (at level 9). - -Fixpoint split x m : triple := match m with - | Leaf => << Leaf, None, Leaf >> - | Node l y d r h => - match X.compare x y with - | LT _ => let (ll,o,rl) := split x l in << ll, o, join rl y d r >> - | EQ _ => << l, Some d, r >> - | GT _ => let (rl,o,rr) := split x r in << join l y d rl, o, rr >> - end - end. - -(** * Concatenation - - Same as [merge] but does not assume anything about heights. -*) - -Definition concat m1 m2 := - match m1, m2 with - | Leaf, _ => m2 - | _ , Leaf => m1 - | _, Node l2 x2 d2 r2 _ => - let (m2',xd) := remove_min l2 x2 d2 r2 in - join m1 xd#1 xd#2 m2' - end. - -(** * Elements *) - -(** [elements_tree_aux acc t] catenates the elements of [t] in infix - order to the list [acc] *) - -Fixpoint elements_aux (acc : list (key*elt)) m : list (key*elt) := - match m with - | Leaf => acc - | Node l x d r _ => elements_aux ((x,d) :: elements_aux acc r) l - end. - -(** then [elements] is an instantiation with an empty [acc] *) - -Definition elements := elements_aux nil. - -(** * Fold *) - -Fixpoint fold (A : Type) (f : key -> elt -> A -> A) (m : t) : A -> A := - fun a => match m with - | Leaf => a - | Node l x d r _ => fold f r (f x d (fold f l a)) - end. - -(** * Comparison *) - -Variable cmp : elt->elt->bool. - -(** ** Enumeration of the elements of a tree *) - -Inductive enumeration := - | End : enumeration - | More : key -> elt -> t -> enumeration -> enumeration. - -(** [cons m e] adds the elements of tree [m] on the head of - enumeration [e]. *) - -Fixpoint cons m e : enumeration := - match m with - | Leaf => e - | Node l x d r h => cons l (More x d r e) - end. - -(** One step of comparison of elements *) - -Definition equal_more x1 d1 (cont:enumeration->bool) e2 := - match e2 with - | End => false - | More x2 d2 r2 e2 => - match X.compare x1 x2 with - | EQ _ => cmp d1 d2 &&& cont (cons r2 e2) - | _ => false - end - end. - -(** Comparison of left tree, middle element, then right tree *) - -Fixpoint equal_cont m1 (cont:enumeration->bool) e2 := - match m1 with - | Leaf => cont e2 - | Node l1 x1 d1 r1 _ => - equal_cont l1 (equal_more x1 d1 (equal_cont r1 cont)) e2 - end. - -(** Initial continuation *) - -Definition equal_end e2 := match e2 with End => true | _ => false end. - -(** The complete comparison *) - -Definition equal m1 m2 := equal_cont m1 equal_end (cons m2 End). - -End Elt. -Notation t := tree. -Arguments Leaf : clear implicits. -Arguments Node [elt]. - -Notation "<< l , b , r >>" := (mktriple l b r) (at level 9). -Notation "t #l" := (t_left t) (at level 9, format "t '#l'"). -Notation "t #o" := (t_opt t) (at level 9, format "t '#o'"). -Notation "t #r" := (t_right t) (at level 9, format "t '#r'"). - - -(** * Map *) - -Fixpoint map (elt elt' : Type)(f : elt -> elt')(m : t elt) : t elt' := - match m with - | Leaf _ => Leaf _ - | Node l x d r h => Node (map f l) x (f d) (map f r) h - end. - -(* * Mapi *) - -Fixpoint mapi (elt elt' : Type)(f : key -> elt -> elt')(m : t elt) : t elt' := - match m with - | Leaf _ => Leaf _ - | Node l x d r h => Node (mapi f l) x (f x d) (mapi f r) h - end. - -(** * Map with removal *) - -Fixpoint map_option (elt elt' : Type)(f : key -> elt -> option elt')(m : t elt) - : t elt' := - match m with - | Leaf _ => Leaf _ - | Node l x d r h => - match f x d with - | Some d' => join (map_option f l) x d' (map_option f r) - | None => concat (map_option f l) (map_option f r) - end - end. - -(** * Optimized map2 - - Suggestion by B. Gregoire: a [map2] function with specialized - arguments that allows bypassing some tree traversal. Instead of one - [f0] of type [key -> option elt -> option elt' -> option elt''], - we ask here for: - - [f] which is a specialisation of [f0] when first option isn't [None] - - [mapl] treats a [tree elt] with [f0] when second option is [None] - - [mapr] treats a [tree elt'] with [f0] when first option is [None] - - The idea is that [mapl] and [mapr] can be instantaneous (e.g. - the identity or some constant function). -*) - -Section Map2_opt. -Variable elt elt' elt'' : Type. -Variable f : key -> elt -> option elt' -> option elt''. -Variable mapl : t elt -> t elt''. -Variable mapr : t elt' -> t elt''. - -Fixpoint map2_opt m1 m2 := - match m1, m2 with - | Leaf _, _ => mapr m2 - | _, Leaf _ => mapl m1 - | Node l1 x1 d1 r1 h1, _ => - let (l2',o2,r2') := split x1 m2 in - match f x1 d1 o2 with - | Some e => join (map2_opt l1 l2') x1 e (map2_opt r1 r2') - | None => concat (map2_opt l1 l2') (map2_opt r1 r2') - end - end. - -End Map2_opt. - -(** * Map2 - - The [map2] function of the Map interface can be implemented - via [map2_opt] and [map_option]. -*) - -Section Map2. -Variable elt elt' elt'' : Type. -Variable f : option elt -> option elt' -> option elt''. - -Definition map2 : t elt -> t elt' -> t elt'' := - map2_opt - (fun _ d o => f (Some d) o) - (map_option (fun _ d => f (Some d) None)) - (map_option (fun _ d' => f None (Some d'))). - -End Map2. - - - -(** * Invariants *) - -Section Invariants. -Variable elt : Type. - -(** ** Occurrence in a tree *) - -Inductive MapsTo (x : key)(e : elt) : t elt -> Prop := - | MapsRoot : forall l r h y, - X.eq x y -> MapsTo x e (Node l y e r h) - | MapsLeft : forall l r h y e', - MapsTo x e l -> MapsTo x e (Node l y e' r h) - | MapsRight : forall l r h y e', - MapsTo x e r -> MapsTo x e (Node l y e' r h). - -Inductive In (x : key) : t elt -> Prop := - | InRoot : forall l r h y e, - X.eq x y -> In x (Node l y e r h) - | InLeft : forall l r h y e', - In x l -> In x (Node l y e' r h) - | InRight : forall l r h y e', - In x r -> In x (Node l y e' r h). - -Definition In0 k m := exists e:elt, MapsTo k e m. - -(** ** Binary search trees *) - -(** [lt_tree x s]: all elements in [s] are smaller than [x] - (resp. greater for [gt_tree]) *) - -Definition lt_tree x m := forall y, In y m -> X.lt y x. -Definition gt_tree x m := forall y, In y m -> X.lt x y. - -(** [bst t] : [t] is a binary search tree *) - -Inductive bst : t elt -> Prop := - | BSLeaf : bst (Leaf _) - | BSNode : forall x e l r h, bst l -> bst r -> - lt_tree x l -> gt_tree x r -> bst (Node l x e r h). - -End Invariants. - - -(** * Correctness proofs, isolated in a sub-module *) - -Module Proofs. - Module MX := OrderedTypeFacts X. - Module PX := KeyOrderedType X. - Module L := FMapList.Raw X. - -#[local] Ltac caseq := -match goal with [ |- context [match ?t with _ => _ end] ] => - let cmp := fresh in - let H := fresh in - remember t as cmp eqn:H; symmetry in H; destruct cmp -end. - -Lemma mem_ind [elt : Type] [x : X.t] [P : t elt -> bool -> Prop] : - (forall m : t elt, m = Leaf elt -> P (Leaf elt) false) -> - (forall (m l : t elt) (y : key) (_x : elt) (r : t elt) (_x0 : int), - m = Node l y _x r _x0 -> - forall _x1 : X.lt x y, - X.compare x y = LT _x1 -> P l (mem x l) -> P (Node l y _x r _x0) (mem x l)) -> - (forall (m l : t elt) (y : key) (_x : elt) (r : t elt) (_x0 : int), - m = Node l y _x r _x0 -> - forall _x1 : X.eq x y, X.compare x y = EQ _x1 -> P (Node l y _x r _x0) true) -> - (forall (m l : t elt) (y : key) (_x : elt) (r : t elt) (_x0 : int), - m = Node l y _x r _x0 -> - forall _x1 : X.lt y x, - X.compare x y = GT _x1 -> P r (mem x r) -> P (Node l y _x r _x0) (mem x r)) -> - forall m : t elt, P m (mem x m). -Proof. -intros; induction m; cbn; repeat caseq; eauto. -Qed. - -Lemma find_ind [elt : Type] [x : X.t] [P : t elt -> option elt -> Prop] : - (forall m : t elt, m = Leaf elt -> P (Leaf elt) None) -> - (forall (m l : t elt) (y : key) (d : elt) (r : t elt) (_x : int), - m = Node l y d r _x -> - forall _x0 : X.lt x y, - X.compare x y = LT _x0 -> P l (find x l) -> P (Node l y d r _x) (find x l)) -> - (forall (m l : t elt) (y : key) (d : elt) (r : t elt) (_x : int), - m = Node l y d r _x -> - forall _x0 : X.eq x y, X.compare x y = EQ _x0 -> P (Node l y d r _x) (Some d)) -> - (forall (m l : t elt) (y : key) (d : elt) (r : t elt) (_x : int), - m = Node l y d r _x -> - forall _x0 : X.lt y x, - X.compare x y = GT _x0 -> P r (find x r) -> P (Node l y d r _x) (find x r)) -> - forall m : t elt, P m (find x m). -Proof. -intros; induction m; cbn; repeat caseq; eauto. -Qed. - -Lemma bal_ind [elt : Type] [P : t elt -> key -> elt -> t elt -> t elt -> Prop] : - (forall (l : t elt) (x : key) (d : elt) (r : t elt), - let hl := height l in - let hr := height r in - forall _x : hl > hr + 2, - gt_le_dec hl (hr + 2) = left _x -> l = Leaf elt -> P (Leaf elt) x d r (assert_false l x d r)) -> - (forall (l : t elt) (x : key) (d : elt) (r : t elt), - let hl := height l in - let hr := height r in - forall _x : hl > hr + 2, - gt_le_dec hl (hr + 2) = left _x -> - forall (ll : t elt) (lx : key) (ld : elt) (lr : t elt) (_x0 : int), - l = Node ll lx ld lr _x0 -> - forall _x1 : height ll >= height lr, - ge_lt_dec (height ll) (height lr) = left _x1 -> - P (Node ll lx ld lr _x0) x d r (create ll lx ld (create lr x d r))) -> - (forall (l : t elt) (x : key) (d : elt) (r : t elt), - let hl := height l in - let hr := height r in - forall _x : hl > hr + 2, - gt_le_dec hl (hr + 2) = left _x -> - forall (ll : t elt) (lx : key) (ld : elt) (lr : t elt) (_x0 : int), - l = Node ll lx ld lr _x0 -> - forall _x1 : height ll < height lr, - ge_lt_dec (height ll) (height lr) = right _x1 -> - lr = Leaf elt -> P (Node ll lx ld (Leaf elt) _x0) x d r (assert_false l x d r)) -> - (forall (l : t elt) (x : key) (d : elt) (r : t elt), - let hl := height l in - let hr := height r in - forall _x : hl > hr + 2, - gt_le_dec hl (hr + 2) = left _x -> - forall (ll : t elt) (lx : key) (ld : elt) (lr : t elt) (_x0 : int), - l = Node ll lx ld lr _x0 -> - forall _x1 : height ll < height lr, - ge_lt_dec (height ll) (height lr) = right _x1 -> - forall (lrl : t elt) (lrx : key) (lrd : elt) (lrr : t elt) (_x2 : int), - lr = Node lrl lrx lrd lrr _x2 -> - P (Node ll lx ld (Node lrl lrx lrd lrr _x2) _x0) x d r - (create (create ll lx ld lrl) lrx lrd (create lrr x d r))) -> - (forall (l : t elt) (x : key) (d : elt) (r : t elt), - let hl := height l in - let hr := height r in - forall _x : hl <= hr + 2, - gt_le_dec hl (hr + 2) = right _x -> - forall _x0 : hr > hl + 2, - gt_le_dec hr (hl + 2) = left _x0 -> r = Leaf elt -> P l x d (Leaf elt) (assert_false l x d r)) -> - (forall (l : t elt) (x : key) (d : elt) (r : t elt), - let hl := height l in - let hr := height r in - forall _x : hl <= hr + 2, - gt_le_dec hl (hr + 2) = right _x -> - forall _x0 : hr > hl + 2, - gt_le_dec hr (hl + 2) = left _x0 -> - forall (rl : t elt) (rx : key) (rd : elt) (rr : t elt) (_x1 : int), - r = Node rl rx rd rr _x1 -> - forall _x2 : height rr >= height rl, - ge_lt_dec (height rr) (height rl) = left _x2 -> - P l x d (Node rl rx rd rr _x1) (create (create l x d rl) rx rd rr)) -> - (forall (l : t elt) (x : key) (d : elt) (r : t elt), - let hl := height l in - let hr := height r in - forall _x : hl <= hr + 2, - gt_le_dec hl (hr + 2) = right _x -> - forall _x0 : hr > hl + 2, - gt_le_dec hr (hl + 2) = left _x0 -> - forall (rl : t elt) (rx : key) (rd : elt) (rr : t elt) (_x1 : int), - r = Node rl rx rd rr _x1 -> - forall _x2 : height rr < height rl, - ge_lt_dec (height rr) (height rl) = right _x2 -> - rl = Leaf elt -> P l x d (Node (Leaf elt) rx rd rr _x1) (assert_false l x d r)) -> - (forall (l : t elt) (x : key) (d : elt) (r : t elt), - let hl := height l in - let hr := height r in - forall _x : hl <= hr + 2, - gt_le_dec hl (hr + 2) = right _x -> - forall _x0 : hr > hl + 2, - gt_le_dec hr (hl + 2) = left _x0 -> - forall (rl : t elt) (rx : key) (rd : elt) (rr : t elt) (_x1 : int), - r = Node rl rx rd rr _x1 -> - forall _x2 : height rr < height rl, - ge_lt_dec (height rr) (height rl) = right _x2 -> - forall (rll : t elt) (rlx : key) (rld : elt) (rlr : t elt) (_x3 : int), - rl = Node rll rlx rld rlr _x3 -> - P l x d (Node (Node rll rlx rld rlr _x3) rx rd rr _x1) - (create (create l x d rll) rlx rld (create rlr rx rd rr))) -> - (forall (l : t elt) (x : key) (d : elt) (r : t elt), - let hl := height l in - let hr := height r in - forall _x : hl <= hr + 2, - gt_le_dec hl (hr + 2) = right _x -> - forall _x0 : hr <= hl + 2, gt_le_dec hr (hl + 2) = right _x0 -> P l x d r (create l x d r)) -> - forall (l : t elt) (x : key) (d : elt) (r : t elt), P l x d r (bal l x d r). -Proof. -intros; unfold bal; repeat caseq; eauto. -Qed. - -Lemma add_ind [elt : Type] [x : key] [d : elt] [P : t elt -> t elt -> Prop] : - (forall m : t elt, m = Leaf elt -> P (Leaf elt) (Node (Leaf elt) x d (Leaf elt) 1)) -> - (forall (m l : t elt) (y : key) (d' : elt) (r : t elt) (h : int), - m = Node l y d' r h -> - forall _x : X.lt x y, - X.compare x y = LT _x -> P l (add x d l) -> P (Node l y d' r h) (bal (add x d l) y d' r)) -> - (forall (m l : t elt) (y : key) (d' : elt) (r : t elt) (h : int), - m = Node l y d' r h -> - forall _x : X.eq x y, X.compare x y = EQ _x -> P (Node l y d' r h) (Node l y d r h)) -> - (forall (m l : t elt) (y : key) (d' : elt) (r : t elt) (h : int), - m = Node l y d' r h -> - forall _x : X.lt y x, - X.compare x y = GT _x -> P r (add x d r) -> P (Node l y d' r h) (bal l y d' (add x d r))) -> - forall m : t elt, P m (add x d m). -Proof. -intros; induction m; cbn; repeat caseq; eauto. -Qed. - -Lemma remove_min_ind [elt : Type] [P : t elt -> key -> elt -> t elt -> t elt * (key * elt) -> Prop] : - (forall (l : t elt) (x : key) (d : elt) (r : t elt), - l = Leaf elt -> P (Leaf elt) x d r (r, (x, d))) -> - (forall (l : t elt) (x : key) (d : elt) (r ll : t elt) (lx : key) - (ld : elt) (lr : t elt) (_x : int), - l = Node ll lx ld lr _x -> - P ll lx ld lr (remove_min ll lx ld lr) -> - forall (l' : t elt) (m : key * elt), - remove_min ll lx ld lr = (l', m) -> P (Node ll lx ld lr _x) x d r (bal l' x d r, m)) -> - forall (l : t elt) (x : key) (d : elt) (r : t elt), P l x d r (remove_min l x d r). -Proof. -induction l; cbn; repeat caseq; eauto. -Qed. - -Lemma merge_ind [elt : Type] [P : t elt -> t elt -> t elt -> Prop] : - (forall s1 s2 : t elt, s1 = Leaf elt -> P (Leaf elt) s2 s2) -> - (forall (s1 s2 _x : t elt) (_x0 : key) (_x1 : elt) (_x2 : t elt) (_x3 : int), - s1 = Node _x _x0 _x1 _x2 _x3 -> s2 = Leaf elt -> P (Node _x _x0 _x1 _x2 _x3) (Leaf elt) s1) -> - (forall (s1 s2 _x : t elt) (_x0 : key) (_x1 : elt) (_x2 : t elt) (_x3 : int), - s1 = Node _x _x0 _x1 _x2 _x3 -> - forall (l2 : t elt) (x2 : key) (d2 : elt) (r2 : t elt) (_x4 : int), - s2 = Node l2 x2 d2 r2 _x4 -> - forall (s2' : t elt) (p : key * elt), - remove_min l2 x2 d2 r2 = (s2', p) -> - forall (x : key) (d : elt), - p = (x, d) -> P (Node _x _x0 _x1 _x2 _x3) (Node l2 x2 d2 r2 _x4) (bal s1 x d s2')) -> - forall s1 s2 : t elt, P s1 s2 (merge s1 s2). -Proof. -intros; induction s1; cbn; repeat caseq; eauto. -Qed. - -Lemma remove_ind [elt : Type] [x : X.t] [P : t elt -> t elt -> Prop] : - (forall m : t elt, m = Leaf elt -> P (Leaf elt) (Leaf elt)) -> - (forall (m l : t elt) (y : key) (d : elt) (r : t elt) (_x : int), - m = Node l y d r _x -> - forall _x0 : X.lt x y, - X.compare x y = LT _x0 -> P l (remove x l) -> P (Node l y d r _x) (bal (remove x l) y d r)) -> - (forall (m l : t elt) (y : key) (d : elt) (r : t elt) (_x : int), - m = Node l y d r _x -> - forall _x0 : X.eq x y, X.compare x y = EQ _x0 -> P (Node l y d r _x) (merge l r)) -> - (forall (m l : t elt) (y : key) (d : elt) (r : t elt) (_x : int), - m = Node l y d r _x -> - forall _x0 : X.lt y x, - X.compare x y = GT _x0 -> P r (remove x r) -> P (Node l y d r _x) (bal l y d (remove x r))) -> - forall m : t elt, P m (remove x m). -Proof. -intros; induction m; cbn; repeat caseq; eauto. -Qed. - -Lemma concat_ind [elt : Type] [P : t elt -> t elt -> t elt -> Prop] : - (forall m1 m2 : t elt, m1 = Leaf elt -> P (Leaf elt) m2 m2) -> - (forall (m1 m2 _x : t elt) (_x0 : key) (_x1 : elt) (_x2 : t elt) (_x3 : int), - m1 = Node _x _x0 _x1 _x2 _x3 -> m2 = Leaf elt -> P (Node _x _x0 _x1 _x2 _x3) (Leaf elt) m1) -> - (forall (m1 m2 _x : t elt) (_x0 : key) (_x1 : elt) (_x2 : t elt) (_x3 : int), - m1 = Node _x _x0 _x1 _x2 _x3 -> - forall (l2 : t elt) (x2 : key) (d2 : elt) (r2 : t elt) (_x4 : int), - m2 = Node l2 x2 d2 r2 _x4 -> - forall (m2' : t elt) (xd : key * elt), - remove_min l2 x2 d2 r2 = (m2', xd) -> - P (Node _x _x0 _x1 _x2 _x3) (Node l2 x2 d2 r2 _x4) (join m1 xd#1 xd#2 m2')) -> - forall m1 m2 : t elt, P m1 m2 (concat m1 m2). -Proof. -intros; unfold concat; cbn; repeat caseq; eauto. -Qed. - -Lemma split_ind [elt : Type] [x : X.t] [P : t elt -> triple elt -> Prop] : - (forall m : t elt, m = Leaf elt -> P (Leaf elt) << Leaf elt, None, Leaf elt >>) -> - (forall (m l : t elt) (y : key) (d : elt) (r : t elt) (_x : int), - m = Node l y d r _x -> - forall _x0 : X.lt x y, - X.compare x y = LT _x0 -> - P l (split x l) -> - forall (ll : t elt) (o : option elt) (rl : t elt), - split x l = << ll, o, rl >> -> P (Node l y d r _x) << ll, o, join rl y d r >>) -> - (forall (m l : t elt) (y : key) (d : elt) (r : t elt) (_x : int), - m = Node l y d r _x -> - forall _x0 : X.eq x y, X.compare x y = EQ _x0 -> P (Node l y d r _x) << l, Some d, r >>) -> - (forall (m l : t elt) (y : key) (d : elt) (r : t elt) (_x : int), - m = Node l y d r _x -> - forall _x0 : X.lt y x, - X.compare x y = GT _x0 -> - P r (split x r) -> - forall (rl : t elt) (o : option elt) (rr : t elt), - split x r = << rl, o, rr >> -> P (Node l y d r _x) << join l y d rl, o, rr >>) -> - forall m : t elt, P m (split x m). -Proof. -intros; induction m; cbn; repeat caseq; eauto. -+ eapply H0; eauto; congruence. -+ eapply H2; eauto; congruence. -Qed. - -Lemma map_option_ind [elt elt' : Type] [f : key -> elt -> option elt'] [P : t elt -> t elt' -> Prop] : - (forall m : t elt, m = Leaf elt -> P (Leaf elt) (Leaf elt')) -> - (forall (m l : t elt) (x : key) (d : elt) (r : t elt) (_x : int), - m = Node l x d r _x -> - forall d' : elt', - f x d = Some d' -> - P l (map_option f l) -> - P r (map_option f r) -> P (Node l x d r _x) (join (map_option f l) x d' (map_option f r))) -> - (forall (m l : t elt) (x : key) (d : elt) (r : t elt) (_x : int), - m = Node l x d r _x -> - f x d = None -> - P l (map_option f l) -> - P r (map_option f r) -> P (Node l x d r _x) (concat (map_option f l) (map_option f r))) -> - forall m : t elt, P m (map_option f m). -Proof. -intros; induction m; cbn; repeat caseq; eauto. -Qed. - -Lemma map2_opt_ind [elt elt' elt'' : Type] [f : key -> elt -> option elt' -> option elt''] - [mapl : t elt -> t elt''] [mapr : t elt' -> t elt''] - [P : t elt -> t elt' -> t elt'' -> Prop] : - (forall (m1 : t elt) (m2 : t elt'), m1 = Leaf elt -> P (Leaf elt) m2 (mapr m2)) -> - (forall (m1 : t elt) (m2 : t elt') (l1 : t elt) (x1 : key) (d1 : elt) (r1 : t elt) (_x : int), - m1 = Node l1 x1 d1 r1 _x -> m2 = Leaf elt' -> P (Node l1 x1 d1 r1 _x) (Leaf elt') (mapl m1)) -> - (forall (m1 : t elt) (m2 : t elt') (l1 : t elt) (x1 : key) (d1 : elt) (r1 : t elt) (_x : int), - m1 = Node l1 x1 d1 r1 _x -> - forall (_x0 : t elt') (_x1 : key) (_x2 : elt') (_x3 : t elt') (_x4 : int), - m2 = Node _x0 _x1 _x2 _x3 _x4 -> - forall (l2' : t elt') (o2 : option elt') (r2' : t elt'), - split x1 m2 = << l2', o2, r2' >> -> - forall e : elt'', - f x1 d1 o2 = Some e -> - P l1 l2' (map2_opt f mapl mapr l1 l2') -> - P r1 r2' (map2_opt f mapl mapr r1 r2') -> - P (Node l1 x1 d1 r1 _x) (Node _x0 _x1 _x2 _x3 _x4) - (join (map2_opt f mapl mapr l1 l2') x1 e (map2_opt f mapl mapr r1 r2'))) -> - (forall (m1 : t elt) (m2 : t elt') (l1 : t elt) (x1 : key) (d1 : elt) (r1 : t elt) (_x : int), - m1 = Node l1 x1 d1 r1 _x -> - forall (_x0 : t elt') (_x1 : key) (_x2 : elt') (_x3 : t elt') (_x4 : int), - m2 = Node _x0 _x1 _x2 _x3 _x4 -> - forall (l2' : t elt') (o2 : option elt') (r2' : t elt'), - split x1 m2 = << l2', o2, r2' >> -> - f x1 d1 o2 = None -> - P l1 l2' (map2_opt f mapl mapr l1 l2') -> - P r1 r2' (map2_opt f mapl mapr r1 r2') -> - P (Node l1 x1 d1 r1 _x) (Node _x0 _x1 _x2 _x3 _x4) - (concat (map2_opt f mapl mapr l1 l2') (map2_opt f mapl mapr r1 r2'))) -> - forall (m1 : t elt) (m2 : t elt'), P m1 m2 (map2_opt f mapl mapr m1 m2). -Proof. -induction m1; intros; cbn; repeat caseq; eauto. -Qed. - -(** * Automation and dedicated tactics. *) - -#[global] -Hint Constructors tree MapsTo In bst : core. -#[global] -Hint Unfold lt_tree gt_tree : core. - -Tactic Notation "factornode" ident(l) ident(x) ident(d) ident(r) ident(h) - "as" ident(s) := - set (s:=Node l x d r h) in *; clearbody s; clear l x d r h. - -(** A tactic for cleaning hypothesis after use of functional induction. *) - -Ltac clearf := - match goal with - | H := _ |- _ => subst; subst H; clearf - | H : (@Logic.eq (Compare _ _ _ _) _ _) |- _ => clear H; clearf - | H : (@Logic.eq (sumbool _ _) _ _) |- _ => clear H; clearf - | _ => idtac - end. - -(** A tactic to repeat [inversion_clear] on all hyps of the - form [(f (Node ...))] *) - -Ltac inv f := - match goal with - | H:f (Leaf _) |- _ => inversion_clear H; inv f - | H:f _ (Leaf _) |- _ => inversion_clear H; inv f - | H:f _ _ (Leaf _) |- _ => inversion_clear H; inv f - | H:f _ _ _ (Leaf _) |- _ => inversion_clear H; inv f - | H:f (Node _ _ _ _ _) |- _ => inversion_clear H; inv f - | H:f _ (Node _ _ _ _ _) |- _ => inversion_clear H; inv f - | H:f _ _ (Node _ _ _ _ _) |- _ => inversion_clear H; inv f - | H:f _ _ _ (Node _ _ _ _ _) |- _ => inversion_clear H; inv f - | _ => idtac - end. - -Ltac inv_all f := - match goal with - | H: f _ |- _ => inversion_clear H; inv f - | H: f _ _ |- _ => inversion_clear H; inv f - | H: f _ _ _ |- _ => inversion_clear H; inv f - | H: f _ _ _ _ |- _ => inversion_clear H; inv f - | _ => idtac - end. - -(** Helper tactic concerning order of elements. *) - -Ltac order := match goal with - | U: lt_tree _ ?s, V: In _ ?s |- _ => generalize (U _ V); clear U; order - | U: gt_tree _ ?s, V: In _ ?s |- _ => generalize (U _ V); clear U; order - | _ => MX.order -end. - -Ltac intuition_in := repeat (intuition auto; inv In; inv MapsTo). - -(* Function/Functional Scheme can't deal with internal fix. - Let's do its job by hand: *) - -Ltac join_tac := - intros ?l; induction l as [| ?ll _ ?lx ?ld ?lr ?Hlr ?lh]; - [ | intros ?x ?d ?r; induction r as [| ?rl ?Hrl ?rx ?rd ?rr _ ?rh]; unfold join; - [ | destruct (gt_le_dec lh (rh+2)) as [?GT|?LE]; - [ match goal with |- context [ bal ?u ?v ?w ?z ] => - replace (bal u v w z) - with (bal ll lx ld (join lr x d (Node rl rx rd rr rh))); [ | auto] - end - | destruct (gt_le_dec rh (lh+2)) as [?GT'|?LE']; - [ match goal with |- context [ bal ?u ?v ?w ?z ] => - replace (bal u v w z) - with (bal (join (Node ll lx ld lr lh) x d rl) rx rd rr); [ | auto] - end - | ] ] ] ]; intros. - -Section Elt. -Variable elt:Type. -Implicit Types m r : t elt. - -(** * Basic results about [MapsTo], [In], [lt_tree], [gt_tree], [height] *) - -(** Facts about [MapsTo] and [In]. *) - -Lemma MapsTo_In : forall k e m, MapsTo k e m -> In k m. -Proof. - induction 1; auto. -Qed. -#[local] -Hint Resolve MapsTo_In : core. - -Lemma In_MapsTo : forall k m, In k m -> exists e, MapsTo k e m. -Proof. - induction 1; try destruct IHIn as (e,He); exists e; auto. -Qed. - -Lemma In_alt : forall k m, In0 k m <-> In k m. -Proof. - split. - - intros (e,H); eauto. - - unfold In0; apply In_MapsTo; auto. -Qed. - -Lemma MapsTo_1 : - forall m x y e, X.eq x y -> MapsTo x e m -> MapsTo y e m. -Proof. - induction m; simpl; intuition_in; eauto with ordered_type. -Qed. -#[local] -Hint Immediate MapsTo_1 : core. - -Lemma In_1 : - forall m x y, X.eq x y -> In x m -> In y m. -Proof. - intros m x y; induction m; simpl; intuition_in; eauto with ordered_type. -Qed. - -Lemma In_node_iff : - forall l x e r h y, - In y (Node l x e r h) <-> In y l \/ X.eq y x \/ In y r. -Proof. - intuition_in. -Qed. - -(** Results about [lt_tree] and [gt_tree] *) - -Lemma lt_leaf : forall x, lt_tree x (Leaf elt). -Proof. - unfold lt_tree; intros; intuition_in. -Qed. - -Lemma gt_leaf : forall x, gt_tree x (Leaf elt). -Proof. - unfold gt_tree; intros; intuition_in. -Qed. - -Lemma lt_tree_node : forall x y l r e h, - lt_tree x l -> lt_tree x r -> X.lt y x -> lt_tree x (Node l y e r h). -Proof. - unfold lt_tree in *; intuition_in; order. -Qed. - -Lemma gt_tree_node : forall x y l r e h, - gt_tree x l -> gt_tree x r -> X.lt x y -> gt_tree x (Node l y e r h). -Proof. - unfold gt_tree in *; intuition_in; order. -Qed. - -#[local] -Hint Resolve lt_leaf gt_leaf lt_tree_node gt_tree_node : core. - -Lemma lt_left : forall x y l r e h, - lt_tree x (Node l y e r h) -> lt_tree x l. -Proof. - intuition_in. -Qed. - -Lemma lt_right : forall x y l r e h, - lt_tree x (Node l y e r h) -> lt_tree x r. -Proof. - intuition_in. -Qed. - -Lemma gt_left : forall x y l r e h, - gt_tree x (Node l y e r h) -> gt_tree x l. -Proof. - intuition_in. -Qed. - -Lemma gt_right : forall x y l r e h, - gt_tree x (Node l y e r h) -> gt_tree x r. -Proof. - intuition_in. -Qed. - -#[local] -Hint Resolve lt_left lt_right gt_left gt_right : core. - -Lemma lt_tree_not_in : - forall x m, lt_tree x m -> ~ In x m. -Proof. - intros; intro; generalize (H _ H0); order. -Qed. - -Lemma lt_tree_trans : - forall x y, X.lt x y -> forall m, lt_tree x m -> lt_tree y m. -Proof. - eauto with ordered_type. -Qed. - -Lemma gt_tree_not_in : - forall x m, gt_tree x m -> ~ In x m. -Proof. - intros; intro; generalize (H _ H0); order. -Qed. - -Lemma gt_tree_trans : - forall x y, X.lt y x -> forall m, gt_tree x m -> gt_tree y m. -Proof. - eauto with ordered_type. -Qed. - -#[local] -Hint Resolve lt_tree_not_in lt_tree_trans gt_tree_not_in gt_tree_trans : core. - -(** * Empty map *) - -Definition Empty m := forall (a:key)(e:elt) , ~ MapsTo a e m. - -Lemma empty_bst : bst (empty elt). -Proof. - unfold empty; auto. -Qed. - -Lemma empty_1 : Empty (empty elt). -Proof. - unfold empty, Empty; intuition_in. -Qed. - -(** * Emptyness test *) - -Lemma is_empty_1 : forall m, Empty m -> is_empty m = true. -Proof. - destruct m as [|r x e l h]; simpl; auto. - intro H; elim (H x e); auto with ordered_type. -Qed. - -Lemma is_empty_2 : forall m, is_empty m = true -> Empty m. -Proof. - destruct m; simpl; intros; try discriminate; red; intuition_in. -Qed. - -(** * Membership *) - -Lemma mem_1 : forall m x, bst m -> In x m -> mem x m = true. -Proof. -intros m x; induction elt, x, m, (mem x m) using mem_ind; auto; intros; clearf; -inv bst; intuition_in; order. -Qed. - -Lemma mem_2 : forall m x, mem x m = true -> In x m. -Proof. - intros m x; induction elt, x, m, (mem x m) using mem_ind; auto; intros; discriminate. -Qed. - -Lemma find_1 : forall m x e, bst m -> MapsTo x e m -> find x m = Some e. -Proof. - intros m x; induction elt, x, m, (find x m) using find_ind; auto; intros; clearf; - inv bst; intuition_in; simpl; auto; - try solve [order | absurd (X.lt x y); eauto with ordered_type | absurd (X.lt y x); eauto with ordered_type]. -Qed. - -Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m. -Proof. - intros m x; induction elt, x, m, (find x m) using find_ind; subst; intros; clearf; - try discriminate. - - constructor 2; auto. - - inversion H; auto. - - constructor 3; auto. -Qed. - -Lemma find_iff : forall m x e, bst m -> - (find x m = Some e <-> MapsTo x e m). -Proof. - split; auto using find_1, find_2. -Qed. - -Lemma find_in : forall m x, find x m <> None -> In x m. -Proof. - intros. - case_eq (find x m); [intros|congruence]. - apply MapsTo_In with e; apply find_2; auto. -Qed. - -Lemma in_find : forall m x, bst m -> In x m -> find x m <> None. -Proof. - intros. - destruct (In_MapsTo H0) as (d,Hd). - rewrite (find_1 H Hd); discriminate. -Qed. - -Lemma find_in_iff : forall m x, bst m -> - (find x m <> None <-> In x m). -Proof. - split; auto using find_in, in_find. -Qed. - -Lemma not_find_iff : forall m x, bst m -> - (find x m = None <-> ~In x m). -Proof. - split; intros. - - red; intros. - elim (in_find H H1 H0). - - case_eq (find x m); [ intros | auto ]. - elim H0; apply find_in; congruence. -Qed. - -Lemma find_find : forall m m' x, - find x m = find x m' <-> - (forall d, find x m = Some d <-> find x m' = Some d). -Proof. - intros; destruct (find x m); destruct (find x m'); split; intros; - try split; try congruence. - - rewrite H; auto. - - symmetry; rewrite <- H; auto. - - rewrite H; auto. -Qed. - -Lemma find_mapsto_equiv : forall m m' x, bst m -> bst m' -> - (find x m = find x m' <-> - (forall d, MapsTo x d m <-> MapsTo x d m')). -Proof. - intros m m' x Hm Hm'. - rewrite find_find. - split; intros H d; specialize H with d. - - rewrite <- 2 find_iff; auto. - - rewrite 2 find_iff; auto. -Qed. - -Lemma find_in_equiv : forall m m' x, bst m -> bst m' -> - find x m = find x m' -> - (In x m <-> In x m'). -Proof. - split; intros; apply find_in; [ rewrite <- H1 | rewrite H1 ]; - apply in_find; auto. -Qed. - -(** * Helper functions *) - -Lemma create_bst : - forall l x e r, bst l -> bst r -> lt_tree x l -> gt_tree x r -> - bst (create l x e r). -Proof. - unfold create; auto. -Qed. -#[local] -Hint Resolve create_bst : core. - -Lemma create_in : - forall l x e r y, - In y (create l x e r) <-> X.eq y x \/ In y l \/ In y r. -Proof. - unfold create; split; [ inversion_clear 1 | ]; intuition. -Qed. - -Lemma bal_bst : forall l x e r, bst l -> bst r -> - lt_tree x l -> gt_tree x r -> bst (bal l x e r). -Proof. - intros l x e r; induction elt, l, x, e, r, (bal l x e r) using bal_ind; subst; intros; clearf; - inv bst; repeat apply create_bst; auto; unfold create; try constructor; - (apply lt_tree_node || apply gt_tree_node); auto with ordered_type; - (eapply lt_tree_trans || eapply gt_tree_trans); eauto with ordered_type. -Qed. -#[local] -Hint Resolve bal_bst : core. - -Lemma bal_in : forall l x e r y, - In y (bal l x e r) <-> X.eq y x \/ In y l \/ In y r. -Proof. - intros l x e r; induction elt, l, x, e, r, (bal l x e r) using bal_ind; subst; intros; clearf; - rewrite !create_in; intuition_in. -Qed. - -Lemma bal_mapsto : forall l x e r y e', - MapsTo y e' (bal l x e r) <-> MapsTo y e' (create l x e r). -Proof. - intros l x e r; induction elt, l, x, e, r, (bal l x e r) using bal_ind; subst; intros; clearf; - unfold assert_false, create; intuition_in. -Qed. - -Lemma bal_find : forall l x e r y, - bst l -> bst r -> lt_tree x l -> gt_tree x r -> - find y (bal l x e r) = find y (create l x e r). -Proof. - intros; rewrite find_mapsto_equiv; auto; intros; apply bal_mapsto. -Qed. - -(** * Insertion *) - -Lemma add_in : forall m x y e, - In y (add x e m) <-> X.eq y x \/ In y m. -Proof. - intros m x y e; induction elt, x, e, m, (add x e m) using add_ind; clearf; auto; intros; - try (rewrite bal_in, IHt); intuition_in. - apply In_1 with x; auto with ordered_type. -Qed. - -Lemma add_bst : forall m x e, bst m -> bst (add x e m). -Proof. - intros m x e; induction elt, x, e, m, (add x e m) using add_ind; clearf; intros; - inv bst; try apply bal_bst; auto; - intro z; rewrite add_in; intuition. - - apply MX.eq_lt with x; auto. - - apply MX.lt_eq with x; auto with ordered_type. -Qed. -#[local] -Hint Resolve add_bst : core. - -Lemma add_1 : forall m x y e, X.eq x y -> MapsTo y e (add x e m). -Proof. - intros m x y e; induction elt, x, e, m, (add x e m) using add_ind; clearf; - intros; inv bst; try rewrite bal_mapsto; unfold create; eauto with ordered_type. -Qed. - -Lemma add_2 : forall m x y e e', ~X.eq x y -> - MapsTo y e m -> MapsTo y e (add x e' m). -Proof. - intros m x y e e'; induction m; simpl; auto. - destruct (X.compare x k); - intros; inv bst; try rewrite bal_mapsto; unfold create; auto; - inv MapsTo; auto; order. -Qed. - -Lemma add_3 : forall m x y e e', ~X.eq x y -> - MapsTo y e (add x e' m) -> MapsTo y e m. -Proof. - intros m x y e e'; induction m; simpl; auto. - - intros; inv MapsTo; auto; order. - - destruct (X.compare x k); intro; - try rewrite bal_mapsto; auto; unfold create; intros; inv MapsTo; auto; - order. -Qed. - -Lemma add_find : forall m x y e, bst m -> - find y (add x e m) = - match X.compare y x with EQ _ => Some e | _ => find y m end. -Proof. - intros. - assert (~X.eq x y -> find y (add x e m) = find y m). - - intros; rewrite find_mapsto_equiv; auto. - split; eauto using add_2, add_3. - - destruct X.compare; try (apply H0; order). - auto using find_1, add_1 with ordered_type. -Qed. - -(** * Extraction of minimum binding *) - -Lemma remove_min_in : forall l x e r h y, - In y (Node l x e r h) <-> - X.eq y (remove_min l x e r)#2#1 \/ In y (remove_min l x e r)#1. -Proof. - intros l x e r; induction elt, l, x, e, r, (remove_min l x e r) using remove_min_ind; clearf; simpl in *; intros. - - intuition_in. - - rewrite H0 in *; simpl; intros. - rewrite bal_in, In_node_iff, IHp; intuition. -Qed. - -Lemma remove_min_mapsto : forall l x e r h y e', - MapsTo y e' (Node l x e r h) <-> - ((X.eq y (remove_min l x e r)#2#1) /\ e' = (remove_min l x e r)#2#2) - \/ MapsTo y e' (remove_min l x e r)#1. -Proof. - intros l x e r; induction elt, l, x, e, r, (remove_min l x e r) using remove_min_ind; clearf; simpl in *; intros. - - intuition_in; subst; auto. - - rewrite H0 in *; simpl; intros. - rewrite bal_mapsto; auto; unfold create. - simpl in *;destruct (IHp _x y e'). - intuition. - + inversion_clear H2; intuition. - + inversion_clear H4; intuition. -Qed. - -Lemma remove_min_bst : forall l x e r h, - bst (Node l x e r h) -> bst (remove_min l x e r)#1. -Proof. - intros l x e r; induction elt, l, x, e, r, (remove_min l x e r) using remove_min_ind; clearf; simpl in *; intros. - - inv bst; auto. - - inversion_clear H; inversion_clear H1. - apply bal_bst; auto. - + rewrite H0 in *; simpl in *; apply (IHp _x); auto. - + intro; intros. - generalize (remove_min_in ll lx ld lr _x y). - rewrite H0; simpl in *. - destruct 1. - apply H3; intuition. -Qed. -#[local] -Hint Resolve remove_min_bst : core. - -Lemma remove_min_gt_tree : forall l x e r h, - bst (Node l x e r h) -> - gt_tree (remove_min l x e r)#2#1 (remove_min l x e r)#1. -Proof. - intros l x e r; induction elt, l, x, e, r, (remove_min l x e r) using remove_min_ind; clearf; simpl in *; intros. - - inv bst; auto. - - inversion_clear H. - intro; intro. - rewrite H0 in *;simpl in *. - generalize (IHp _x H1). - generalize (remove_min_in ll lx ld lr _x m#1). - rewrite H0; simpl; intros. - rewrite (bal_in l' x d r y) in H. - assert (In m#1 (Node ll lx ld lr _x)) by (rewrite H5; auto with ordered_type); clear H5. - assert (X.lt m#1 x) by order. - decompose [or] H; order. -Qed. -#[local] -Hint Resolve remove_min_gt_tree : core. - -Lemma remove_min_find : forall l x e r h y, - bst (Node l x e r h) -> - find y (Node l x e r h) = - match X.compare y (remove_min l x e r)#2#1 with - | LT _ => None - | EQ _ => Some (remove_min l x e r)#2#2 - | GT _ => find y (remove_min l x e r)#1 - end. -Proof. - intros. - destruct X.compare. - - rewrite not_find_iff; auto. - rewrite remove_min_in; red; destruct 1 as [H'|H']; [ order | ]. - generalize (remove_min_gt_tree H H'); order. - - apply find_1; auto. - rewrite remove_min_mapsto; auto. - - rewrite find_mapsto_equiv; eauto; intros. - rewrite remove_min_mapsto; intuition; order. -Qed. - -(** * Merging two trees *) - -Lemma merge_in : forall m1 m2 y, bst m1 -> bst m2 -> - (In y (merge m1 m2) <-> In y m1 \/ In y m2). -Proof. - intros m1 m2; induction elt, m1, m2, (merge m1 m2) using merge_ind; clearf; intros; - try factornode _x _x0 _x1 _x2 _x3 as m1. - - intuition_in. - - intuition_in. - - rewrite bal_in, remove_min_in, H1; simpl; intuition. -Qed. - -Lemma merge_mapsto : forall m1 m2 y e, bst m1 -> bst m2 -> - (MapsTo y e (merge m1 m2) <-> MapsTo y e m1 \/ MapsTo y e m2). -Proof. - intros m1 m2; induction elt, m1, m2, (merge m1 m2) using merge_ind; clearf; intros; - try factornode _x _x0 _x1 _x2 _x3 as m1. - - intuition_in. - - intuition_in. - - rewrite bal_mapsto, remove_min_mapsto, H1; simpl; auto. - unfold create. - intuition; subst; auto. - inversion_clear H2; intuition. -Qed. - -Lemma merge_bst : forall m1 m2, bst m1 -> bst m2 -> - (forall y1 y2 : key, In y1 m1 -> In y2 m2 -> X.lt y1 y2) -> - bst (merge m1 m2). -Proof. - intros m1 m2; induction elt, m1, m2, (merge m1 m2) using merge_ind; clearf; intros; auto; - try factornode _x _x0 _x1 _x2 _x3 as m1. - apply bal_bst; auto. - - generalize (remove_min_bst H0); rewrite H1; simpl in *; auto. - - intro; intro. - apply H2; auto. - generalize (remove_min_in l2 x2 d2 r2 _x4 x); rewrite H1; simpl; intuition auto with relations. - - generalize (remove_min_gt_tree H0); rewrite H1; simpl; auto. -Qed. - -(** * Deletion *) - -Lemma remove_in : forall m x y, bst m -> - (In y (remove x m) <-> ~ X.eq y x /\ In y m). -Proof. - intros m x; induction elt, x, m, (remove x m) using remove_ind; subst T; simpl; intros. - - intuition_in. - - (* LT *) - inv bst; clear H0. - rewrite bal_in; auto. - generalize (IHt y0 H2); intuition; [ order | order | intuition_in ]. - - (* EQ *) - inv bst; clear H0. - rewrite merge_in; intuition; [ order | order | intuition_in ]. - elim H1; eauto with ordered_type. - - (* GT *) - inv bst; clear H0. - rewrite bal_in; auto. - generalize (IHt y0 H3); intuition; [ order | order | intuition_in ]. -Qed. - -Lemma remove_bst : forall m x, bst m -> bst (remove x m). -Proof. - intros m x; induction elt, x, m, (remove x m) using remove_ind; subst T; simpl; intros. - - auto. - - (* LT *) - inv bst. - apply bal_bst; auto. - intro; intro. - rewrite (remove_in x y0 H2) in H1; auto. - destruct H1; eauto. - - (* EQ *) - inv bst. - apply merge_bst; eauto with ordered_type. - - (* GT *) - inv bst. - apply bal_bst; auto. - intro; intro. - rewrite (remove_in x y0 H3) in H1; auto. - destruct H1; eauto. -Qed. - -Lemma remove_1 : forall m x y, bst m -> X.eq x y -> ~ In y (remove x m). -Proof. - intros; rewrite remove_in; intuition auto with relations. -Qed. - -Lemma remove_2 : forall m x y e, bst m -> ~X.eq x y -> - MapsTo y e m -> MapsTo y e (remove x m). -Proof. - intros m x y e; induction m; simpl; auto. - destruct (X.compare x k); - intros; inv bst; try rewrite bal_mapsto; unfold create; auto; - try solve [inv MapsTo; auto]. - rewrite merge_mapsto; auto. - inv MapsTo; auto; order. -Qed. - -Lemma remove_3 : forall m x y e, bst m -> - MapsTo y e (remove x m) -> MapsTo y e m. -Proof. - intros m x y e; induction m; simpl; auto. - destruct (X.compare x k); intros Bs; inv bst; - try rewrite bal_mapsto; auto; unfold create. - - intros; inv MapsTo; auto. - - rewrite merge_mapsto; intuition. - - intros; inv MapsTo; auto. -Qed. - -(** * join *) - -Lemma join_in : forall l x d r y, - In y (join l x d r) <-> X.eq y x \/ In y l \/ In y r. -Proof. - join_tac. - - simpl. - rewrite add_in; intuition_in. - - rewrite add_in; intuition_in. - - rewrite bal_in, Hlr; clear Hlr Hrl; intuition_in. - - rewrite bal_in, Hrl; clear Hlr Hrl; intuition_in. - - apply create_in. -Qed. - -Lemma join_bst : forall l x d r, bst l -> bst r -> - lt_tree x l -> gt_tree x r -> bst (join l x d r). -Proof. - join_tac; auto; try (simpl; auto; fail); inv bst; apply bal_bst; auto; - clear Hrl Hlr; intro; intros; rewrite join_in in *. - - intuition; [ apply MX.lt_eq with x | ]; eauto with ordered_type. - - intuition; [ apply MX.eq_lt with x | ]; eauto with ordered_type. -Qed. -#[local] -Hint Resolve join_bst : core. - -Lemma join_find : forall l x d r y, - bst l -> bst r -> lt_tree x l -> gt_tree x r -> - find y (join l x d r) = find y (create l x d r). -Proof. - join_tac; auto; inv bst; - simpl (join (Leaf elt)); - try (assert (X.lt lx x) by auto with ordered_type); - try (assert (X.lt x rx) by auto with ordered_type); - rewrite ?add_find, ?bal_find; auto. - - - simpl; destruct X.compare; auto. - rewrite not_find_iff; auto; intro; order. - - - simpl; repeat (destruct X.compare; auto); try (order; fail). - rewrite not_find_iff by auto; intro. - assert (X.lt y x) by auto; order. - - - simpl; rewrite Hlr; simpl; auto. - repeat (destruct X.compare; auto); order. - - intros u Hu; rewrite join_in in Hu. - destruct Hu as [Hu|[Hu|Hu]]; try generalize (H2 _ Hu); order. - - - simpl; rewrite Hrl; simpl; auto. - repeat (destruct X.compare; auto); order. - - intros u Hu; rewrite join_in in Hu. - destruct Hu as [Hu|[Hu|Hu]]; order. -Qed. - -(** * split *) - -Lemma split_in_1 : forall m x, bst m -> forall y, - (In y (split x m)#l <-> In y m /\ X.lt y x). -Proof. - intros m x; induction elt, x, m, (split x m) using split_ind; clearf; simpl; intros; - inv bst; try clear e0. - - intuition_in. - - rewrite H1 in IHt; simpl in IHt; rewrite IHt; intuition_in; order. - - intuition_in; order. - - rewrite join_in. - rewrite H1 in IHt; simpl in IHt; rewrite IHt; intuition_in; order. -Qed. - -Lemma split_in_2 : forall m x, bst m -> forall y, - (In y (split x m)#r <-> In y m /\ X.lt x y). -Proof. - intros m x; induction elt, x, m, (split x m) using split_ind; clearf; subst; simpl; intros; - inv bst; try clear e0. - - intuition_in. - - rewrite join_in. - rewrite H1 in IHt; simpl in IHt; rewrite IHt; intuition_in; order. - - intuition_in; order. - - rewrite H1 in IHt; simpl in IHt; rewrite IHt; intuition_in; order. -Qed. - -Lemma split_in_3 : forall m x, bst m -> - (split x m)#o = find x m. -Proof. - intros m x; induction elt, x, m, (split x m) using split_ind; clearf; subst; simpl; auto; - intros; inv bst; try clear e0; - destruct X.compare; try order; trivial; rewrite <- IHt, H1; auto. -Qed. - -Lemma split_bst : forall m x, bst m -> - bst (split x m)#l /\ bst (split x m)#r. -Proof. - intros m x; induction elt, x, m, (split x m) using split_ind; clearf; subst; simpl; intros; - inv bst; try clear e0; try rewrite H1 in *; simpl in *; intuition; - apply join_bst; auto. - - intros y0. - generalize (split_in_2 x H0 y0); rewrite H1; simpl; intuition. - - intros y0. - generalize (split_in_1 x H2 y0); rewrite H1; simpl; intuition. -Qed. - -Lemma split_lt_tree : forall m x, bst m -> lt_tree x (split x m)#l. -Proof. - intros m x B y Hy; rewrite split_in_1 in Hy; intuition. -Qed. - -Lemma split_gt_tree : forall m x, bst m -> gt_tree x (split x m)#r. -Proof. - intros m x B y Hy; rewrite split_in_2 in Hy; intuition. -Qed. - -Lemma split_find : forall m x y, bst m -> - find y m = match X.compare y x with - | LT _ => find y (split x m)#l - | EQ _ => (split x m)#o - | GT _ => find y (split x m)#r - end. -Proof. - intros m x; induction elt, x, m, (split x m) using split_ind; clearf; subst; simpl; intros; - inv bst; try clear e0; try rewrite H1 in *; simpl in *; - [ destruct X.compare; auto | .. ]; - try match goal with E:split ?x ?t = _, B:bst ?t |- _ => - generalize (split_in_1 x B)(split_in_2 x B)(split_bst x B); - rewrite E; simpl; destruct 3 end. - - - rewrite join_find, IHt; auto; clear IHt; simpl. - + repeat (destruct X.compare; auto); order. - + intro y1; rewrite H5; intuition. - - - repeat (destruct X.compare; auto); order. - - - rewrite join_find, IHt; auto; clear IHt; simpl. - + repeat (destruct X.compare; auto); order. - + intros y1; rewrite H; intuition. -Qed. - -(** * Concatenation *) - -Lemma concat_in : forall m1 m2 y, - In y (concat m1 m2) <-> In y m1 \/ In y m2. -Proof. - intros m1 m2; induction elt, m1, m2, (concat m1 m2) using concat_ind; clearf; intros; - try factornode _x _x0 _x1 _x2 _x3 as m1. - - intuition_in. - - intuition_in. - - rewrite join_in, remove_min_in, H1; simpl; intuition. -Qed. - -Lemma concat_bst : forall m1 m2, bst m1 -> bst m2 -> - (forall y1 y2, In y1 m1 -> In y2 m2 -> X.lt y1 y2) -> - bst (concat m1 m2). -Proof. - intros m1 m2; induction elt, m1, m2, (concat m1 m2) using concat_ind; clearf; intros; auto; - try factornode _x _x0 _x1 _x2 _x3 as m1. - apply join_bst; auto. - - change (bst (m2',xd)#1). rewrite <- H1; eauto. - - intros y Hy. - apply H2; auto. - rewrite remove_min_in, H1; simpl; auto with ordered_type. - - change (gt_tree (m2',xd)#2#1 (m2',xd)#1). rewrite <- H1; eauto. -Qed. -#[local] -Hint Resolve concat_bst : core. - -Lemma concat_find : forall m1 m2 y, bst m1 -> bst m2 -> - (forall y1 y2, In y1 m1 -> In y2 m2 -> X.lt y1 y2) -> - find y (concat m1 m2) = - match find y m2 with Some d => Some d | None => find y m1 end. -Proof. - intros m1 m2; induction elt, m1, m2, (concat m1 m2) using concat_ind; clearf; intros; auto; - try factornode _x _x0 _x1 _x2 _x3 as m1. - - simpl; destruct (find y m2); auto. - - - generalize (remove_min_find y H0)(remove_min_in l2 x2 d2 r2 _x4) - (remove_min_bst H0)(remove_min_gt_tree H0); - rewrite H1; simpl fst; simpl snd; intros. - - inv bst. - rewrite H3, join_find; auto; clear H3. - + simpl; destruct X.compare as [Hlt| |Hlt]; simpl; auto. - destruct (find y m2'); auto. - symmetry; rewrite not_find_iff; auto; intro. - apply (MX.lt_not_gt Hlt); apply H2; auto; rewrite H4; auto with ordered_type. - - + intros z Hz; apply H2; auto; rewrite H4; auto with ordered_type. -Qed. - - -(** * Elements *) - -Notation eqk := (PX.eqk (elt:= elt)). -Notation eqke := (PX.eqke (elt:= elt)). -Notation ltk := (PX.ltk (elt:= elt)). - -Lemma elements_aux_mapsto : forall (s:t elt) acc x e, - InA eqke (x,e) (elements_aux acc s) <-> MapsTo x e s \/ InA eqke (x,e) acc. -Proof. - induction s as [ | l Hl x e r Hr h ]; simpl; auto. - - intuition. - inversion H0. - - intros. - rewrite Hl. - destruct (Hr acc x0 e0); clear Hl Hr. - intuition; inversion_clear H3; intuition auto with ordered_type. - destruct H0; simpl in *; subst; intuition. -Qed. - -Lemma elements_mapsto : forall (s:t elt) x e, InA eqke (x,e) (elements s) <-> MapsTo x e s. -Proof. - intros; generalize (elements_aux_mapsto s nil x e); intuition. - inversion_clear H0. -Qed. - -Lemma elements_in : forall (s:t elt) x, L.PX.In x (elements s) <-> In x s. -Proof. - intros. - unfold L.PX.In. - rewrite <- In_alt; unfold In0. - firstorder. - - exists x0. - rewrite <- elements_mapsto; auto. - - exists x0. - unfold L.PX.MapsTo; rewrite elements_mapsto; auto. -Qed. - -Lemma elements_aux_sort : forall (s:t elt) acc, bst s -> sort ltk acc -> - (forall x e y, InA eqke (x,e) acc -> In y s -> X.lt y x) -> - sort ltk (elements_aux acc s). -Proof. - induction s as [ | l Hl y e r Hr h]; simpl; intuition. - inv bst. - apply Hl; auto. - - constructor. - + apply Hr; eauto. - + 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. - - intros x e0 y0 H H6. - inversion_clear H. - + destruct H7; simpl in *. - order. - + destruct (elements_aux_mapsto r acc x e0); intuition eauto with ordered_type. -Qed. - -Lemma elements_sort : forall s : t elt, bst s -> sort ltk (elements s). -Proof. - intros; unfold elements; apply elements_aux_sort; auto. - intros; inversion H0. -Qed. -#[local] -Hint Resolve elements_sort : core. - -Lemma elements_nodup : forall s : t elt, bst s -> NoDupA eqk (elements s). -Proof. - intros; apply PX.Sort_NoDupA; auto. -Qed. - -Lemma elements_aux_cardinal : - forall (m:t elt) acc, (length acc + cardinal m)%nat = length (elements_aux acc m). -Proof. - simple induction m; simpl; intuition. - rewrite <- H; simpl. - rewrite <- H0, Nat.add_succ_r, (Nat.add_comm (cardinal t)), Nat.add_assoc. - reflexivity. -Qed. - -Lemma elements_cardinal : forall (m:t elt), cardinal m = length (elements m). -Proof. - exact (fun m => elements_aux_cardinal m nil). -Qed. - -Lemma elements_app : - forall (s:t elt) acc, elements_aux acc s = elements s ++ acc. -Proof. - induction s; simpl; intros; auto. - rewrite IHs1, IHs2. - unfold elements; simpl. - rewrite 2 IHs1, IHs2, !app_nil_r, <- !app_assoc; auto. -Qed. - -Lemma elements_node : - forall (t1 t2:t elt) x e z l, - elements t1 ++ (x,e) :: elements t2 ++ l = - elements (Node t1 x e t2 z) ++ l. -Proof. - unfold elements; simpl; intros. - rewrite !elements_app, !app_nil_r, <- !app_assoc; auto. -Qed. - -(** * Fold *) - -Definition fold' (A : Type) (f : key -> elt -> A -> A)(s : t elt) := - L.fold f (elements s). - -Lemma fold_equiv_aux : - forall (A : Type) (s : t elt) (f : key -> elt -> A -> A) (a : A) acc, - L.fold f (elements_aux acc s) a = L.fold f acc (fold f s a). -Proof. - simple induction s. - - simpl; intuition. - - simpl; intros. - rewrite H. - simpl. - apply H0. -Qed. - -Lemma fold_equiv : - forall (A : Type) (s : t elt) (f : key -> elt -> A -> A) (a : A), - fold f s a = fold' f s a. -Proof. - unfold fold', elements. - simple induction s; simpl; auto; intros. - rewrite fold_equiv_aux. - rewrite H0. - simpl; auto. -Qed. - -Lemma fold_1 : - forall (s:t elt)(Hs:bst s)(A : Type)(i:A)(f : key -> elt -> A -> A), - fold f s i = fold_left (fun a p => f p#1 p#2 a) (elements s) i. -Proof. - intros. - rewrite fold_equiv. - unfold fold'. - rewrite L.fold_1. - unfold L.elements; auto. -Qed. - -(** * Comparison *) - -(** [flatten_e e] returns the list of elements of the enumeration [e] - i.e. the list of elements actually compared *) - -Fixpoint flatten_e (e : enumeration elt) : list (key*elt) := match e with - | End _ => nil - | More x e t r => (x,e) :: elements t ++ flatten_e r - end. - -Lemma flatten_e_elements : - forall (l:t elt) r x d z e, - elements l ++ flatten_e (More x d r e) = - elements (Node l x d r z) ++ flatten_e e. -Proof. - intros; apply elements_node. -Qed. - -Lemma cons_1 : forall (s:t elt) e, - flatten_e (cons s e) = elements s ++ flatten_e e. -Proof. - induction s; auto; intros. - simpl flatten_e; rewrite IHs1; apply flatten_e_elements; auto. -Qed. - -(** Proof of correction for the comparison *) - -Variable cmp : elt->elt->bool. - -Definition IfEq b l1 l2 := L.equal cmp l1 l2 = b. - -Lemma cons_IfEq : forall b x1 x2 d1 d2 l1 l2, - X.eq x1 x2 -> cmp d1 d2 = true -> - IfEq b l1 l2 -> - IfEq b ((x1,d1)::l1) ((x2,d2)::l2). -Proof. - unfold IfEq; destruct b; simpl; intros; destruct X.compare; simpl; - try rewrite H0; auto; order. -Qed. - -Lemma equal_end_IfEq : forall e2, - IfEq (equal_end e2) nil (flatten_e e2). -Proof. - destruct e2; red; auto. -Qed. - -Lemma equal_more_IfEq : - forall x1 d1 (cont:enumeration elt -> bool) x2 d2 r2 e2 l, - IfEq (cont (cons r2 e2)) l (elements r2 ++ flatten_e e2) -> - IfEq (equal_more cmp x1 d1 cont (More x2 d2 r2 e2)) ((x1,d1)::l) - (flatten_e (More x2 d2 r2 e2)). -Proof. - unfold IfEq; simpl; intros; destruct X.compare; simpl; auto. - rewrite <-andb_lazy_alt; f_equal; auto. -Qed. - -Lemma equal_cont_IfEq : forall m1 cont e2 l, - (forall e, IfEq (cont e) l (flatten_e e)) -> - IfEq (equal_cont cmp m1 cont e2) (elements m1 ++ l) (flatten_e e2). -Proof. - induction m1 as [|l1 Hl1 x1 d1 r1 Hr1 h1]; intros; auto. - rewrite <- elements_node; simpl. - apply Hl1; auto. - clear e2; intros [|x2 d2 r2 e2]. - - simpl; red; auto. - - apply equal_more_IfEq. - rewrite <- cons_1; auto. -Qed. - -Lemma equal_IfEq : forall (m1 m2:t elt), - IfEq (equal cmp m1 m2) (elements m1) (elements m2). -Proof. - intros; unfold equal. - rewrite <- (app_nil_r (elements m1)). - replace (elements m2) with (flatten_e (cons m2 (End _))) - by (rewrite cons_1; simpl; rewrite app_nil_r; auto). - apply equal_cont_IfEq. - intros. - apply equal_end_IfEq; auto. -Qed. - -Definition Equivb m m' := - (forall k, In k m <-> In k m') /\ - (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true). - -Lemma Equivb_elements : forall s s', - Equivb s s' <-> L.Equivb cmp (elements s) (elements s'). -Proof. -unfold Equivb, L.Equivb; split; split; intros. -- do 2 rewrite elements_in; firstorder. -- destruct H. - apply (H2 k); rewrite <- elements_mapsto; auto. -- do 2 rewrite <- elements_in; firstorder. -- destruct H. - apply (H2 k); unfold L.PX.MapsTo; rewrite elements_mapsto; auto. -Qed. - -Lemma equal_Equivb : forall (s s': t elt), bst s -> bst s' -> - (equal cmp s s' = true <-> Equivb s s'). -Proof. - intros s s' B B'. - rewrite Equivb_elements, <- equal_IfEq. - split; [apply L.equal_2|apply L.equal_1]; auto. -Qed. - -End Elt. - -Section Map. -Variable elt elt' : Type. -Variable f : elt -> elt'. - -Lemma map_1 : forall (m: t elt)(x:key)(e:elt), - MapsTo x e m -> MapsTo x (f e) (map f m). -Proof. -induction m; simpl; inversion_clear 1; auto. -Qed. - -Lemma map_2 : forall (m: t elt)(x:key), - In x (map f m) -> In x m. -Proof. -induction m; simpl; inversion_clear 1; auto. -Qed. - -Lemma map_bst : forall m, bst m -> bst (map f m). -Proof. -induction m; simpl; auto. -inversion_clear 1; constructor; auto; - red; auto using map_2. -Qed. - -End Map. -Section Mapi. -Variable elt elt' : Type. -Variable f : key -> elt -> elt'. - -Lemma mapi_1 : forall (m: tree elt)(x:key)(e:elt), - MapsTo x e m -> exists y, X.eq y x /\ MapsTo x (f y e) (mapi f m). -Proof. -induction m; simpl; inversion_clear 1; auto. -- exists k; auto with ordered_type. -- destruct (IHm1 _ _ H0). - exists x0; intuition. -- destruct (IHm2 _ _ H0). - exists x0; intuition. -Qed. - -Lemma mapi_2 : forall (m: t elt)(x:key), - In x (mapi f m) -> In x m. -Proof. -induction m; simpl; inversion_clear 1; auto. -Qed. - -Lemma mapi_bst : forall m, bst m -> bst (mapi f m). -Proof. -induction m; simpl; auto. -inversion_clear 1; constructor; auto; - red; auto using mapi_2. -Qed. - -End Mapi. - -Section Map_option. -Variable elt elt' : Type. -Variable f : key -> elt -> option elt'. -Hypothesis f_compat : forall x x' d, X.eq x x' -> f x d = f x' d. - -Lemma map_option_2 : forall (m:t elt)(x:key), - In x (map_option f m) -> exists d, MapsTo x d m /\ f x d <> None. -Proof. -intros m; induction elt, elt', f, m, (map_option f m) using map_option_ind; clearf; simpl; auto; intros. -- inversion H. -- rewrite join_in in H; destruct H as [H|[H|H]]. - + exists d; split; auto; rewrite (f_compat d H), H0; discriminate. - + destruct (IHt _ H) as (d0 & ? & ?); exists d0; auto. - + destruct (IHt0 _ H) as (d0 & ? & ?); exists d0; auto. -- rewrite concat_in in H; destruct H as [H|H]. - + destruct (IHt _ H) as (d0 & ? & ?); exists d0; auto. - + destruct (IHt0 _ H) as (d0 & ? & ?); exists d0; auto. -Qed. - -Lemma map_option_bst : forall m, bst m -> bst (map_option f m). -Proof. -intros m; induction elt, elt', f, m, (map_option f m) using map_option_ind; clearf; simpl; auto; intros; - inv bst. -- apply join_bst; auto; intros y H; - destruct (map_option_2 H) as (d0 & ? & ?); eauto using MapsTo_In. -- apply concat_bst; auto; intros y y' H H'. - destruct (map_option_2 H) as (d0 & ? & ?). - destruct (map_option_2 H') as (d0' & ? & ?). - eapply X.lt_trans with x; eauto using MapsTo_In. -Qed. -#[local] -Hint Resolve map_option_bst : core. - -Ltac nonify e := - replace e with (@None elt) by - (symmetry; rewrite not_find_iff; auto; intro; order). - -Lemma map_option_find : forall (m:t elt)(x:key), - bst m -> - find x (map_option f m) = - match (find x m) with Some d => f x d | None => None end. -Proof. -intros m; induction elt, elt', f, m, (map_option f m) using map_option_ind; clearf; simpl; auto; intros; - inv bst; rewrite join_find || rewrite concat_find; auto; simpl; - try destruct X.compare as [Hlt|Heq|Hlt]; simpl; auto. -- rewrite (f_compat d Heq); auto. -- intros y H; - destruct (map_option_2 H) as (? & ? & ?); eauto using MapsTo_In. -- intros y H; - destruct (map_option_2 H) as (? & ? & ?); eauto using MapsTo_In. - -- rewrite <- IHt, IHt0; auto; nonify (find x0 r); auto. -- rewrite IHt, IHt0; auto; nonify (find x0 r); nonify (find x0 l); auto. - rewrite (f_compat d Heq); auto. -- rewrite <- IHt0, IHt; auto; nonify (find x0 l); auto. - destruct (find x0 (map_option f r)); auto. - -- intros y y' H H'. - destruct (map_option_2 H) as (? & ? & ?). - destruct (map_option_2 H') as (? & ? & ?). - eapply X.lt_trans with x; eauto using MapsTo_In. -Qed. - -End Map_option. - -Section Map2_opt. -Variable elt elt' elt'' : Type. -Variable f0 : key -> option elt -> option elt' -> option elt''. -Variable f : key -> elt -> option elt' -> option elt''. -Variable mapl : t elt -> t elt''. -Variable mapr : t elt' -> t elt''. -Hypothesis f0_f : forall x d o, f x d o = f0 x (Some d) o. -Hypothesis mapl_bst : forall m, bst m -> bst (mapl m). -Hypothesis mapr_bst : forall m', bst m' -> bst (mapr m'). -Hypothesis mapl_f0 : forall x m, bst m -> - find x (mapl m) = - match find x m with Some d => f0 x (Some d) None | None => None end. -Hypothesis mapr_f0 : forall x m', bst m' -> - find x (mapr m') = - match find x m' with Some d' => f0 x None (Some d') | None => None end. -Hypothesis f0_compat : forall x x' o o', X.eq x x' -> f0 x o o' = f0 x' o o'. - -Notation map2_opt := (map2_opt f mapl mapr). - -Lemma map2_opt_2 : forall m m' y, bst m -> bst m' -> - In y (map2_opt m m') -> In y m \/ In y m'. -Proof. -intros m m'; induction elt, elt', elt'', f, mapl, mapr, m, m', (map2_opt m m') using map2_opt_ind; clearf; intros; - auto; try factornode _x0 _x1 _x2 _x3 _x4 as m2; - try (generalize (split_in_1 x1 H0 y)(split_in_2 x1 H0 y) - (split_bst x1 H0); rewrite H1; simpl; destruct 3; inv bst). - -- right; apply find_in. - generalize (in_find (mapr_bst H0) H1); rewrite mapr_f0; auto. - destruct (find y m2); auto; intros; discriminate. - -- factornode l1 x1 d1 r1 _x as m1. - left; apply find_in. - generalize (in_find (mapl_bst H) H1); rewrite mapl_f0; auto. - destruct (find y m1); auto; intros; discriminate. - -- rewrite join_in in H3; destruct H3 as [H'|[H'|H']]; auto. - + destruct (IHt1 y H8 H6 H'); intuition. - + destruct (IHt0 y H9 H7 H'); intuition. - -- rewrite concat_in in H3; destruct H3 as [H'|H']; auto. - + destruct (IHt1 y H8 H6 H'); intuition. - + destruct (IHt0 y H9 H7 H'); intuition. -Qed. - -Lemma map2_opt_bst : forall m m', bst m -> bst m' -> - bst (map2_opt m m'). -Proof. -intros m m'; induction elt, elt', elt'', f, mapl, mapr, m, m', (map2_opt m m') using map2_opt_ind; clearf; intros; - auto; try factornode _x0 _x1 _x2 _x3 _x4 as m2; inv bst; - generalize (split_in_1 x1 H0)(split_in_2 x1 H0)(split_bst x1 H0); - rewrite H1; simpl in *; destruct 3. - -- apply join_bst; auto. - + intros y Hy; specialize H with y. - destruct (map2_opt_2 H3 H8 Hy); intuition. - + intros y Hy; specialize H7 with y. - destruct (map2_opt_2 H4 H9 Hy); intuition. - -- apply concat_bst; auto. - intros y y' Hy Hy'; specialize H with y; specialize H7 with y'. - apply X.lt_trans with x1. - + destruct (map2_opt_2 H3 H8 Hy); intuition. - + destruct (map2_opt_2 H4 H9 Hy'); intuition. -Qed. -#[local] -Hint Resolve map2_opt_bst : core. - -Ltac map2_aux := - match goal with - | H : In ?x _ \/ In ?x ?m, - H' : find ?x ?m = find ?x ?m', B:bst ?m, B':bst ?m' |- _ => - destruct H; [ intuition_in; order | - rewrite <-(find_in_equiv B B' H'); auto ] - end. - -Ltac nonify t := - match t with (find ?y (map2_opt ?m ?m')) => - replace t with (@None elt''); - [ | symmetry; rewrite not_find_iff; auto; intro; - destruct (@map2_opt_2 m m' y); auto; order ] - end. - -Lemma map2_opt_1 : forall m m' y, bst m -> bst m' -> - In y m \/ In y m' -> - find y (map2_opt m m') = f0 y (find y m) (find y m'). -Proof. -intros m m'; induction elt, elt', elt'', f, mapl, mapr, m, m', (map2_opt m m') using map2_opt_ind; clearf; intros; - auto; try factornode _x0 _x1 _x2 _x3 _x4 as m2; - try (generalize (split_in_1 x1 H0)(split_in_2 x1 H0) - (split_in_3 x1 H0)(split_bst x1 H0)(split_find x1 y H0) - (split_lt_tree (x:=x1) H0)(split_gt_tree (x:=x1) H0); - rewrite H1; simpl in *; destruct 4; intros; inv bst; - subst o2; rewrite H9, ?join_find, ?concat_find; auto). - -- simpl; destruct H1; [ inversion_clear H1 | ]. - rewrite mapr_f0; auto. - generalize (in_find H0 H1); destruct (find y m2); intuition. - -- factornode l1 x1 d1 r1 _x as m1. - destruct H1; [ | inversion_clear H1 ]. - rewrite mapl_f0; auto. - generalize (in_find H H1); destruct (find y m1); intuition. - -- simpl; destruct X.compare; auto. - + apply IHt1; auto; map2_aux. - + rewrite (@f0_compat y x1), <- f0_f; auto. - + apply IHt0; auto; map2_aux. -- intros z Hz; destruct (@map2_opt_2 l1 l2' z); auto. -- intros z Hz; destruct (@map2_opt_2 r1 r2' z); auto. - -- destruct X.compare. - + nonify (find y (map2_opt r1 r2')). - apply IHt1; auto; map2_aux. - + nonify (find y (map2_opt r1 r2')). - nonify (find y (map2_opt l1 l2')). - rewrite (@f0_compat y x1), <- f0_f; auto. - + nonify (find y (map2_opt l1 l2')). - rewrite IHt0; auto; [ | map2_aux ]. - destruct (f0 y (find y r1) (find y r2')); auto. -- intros y1 y2 Hy1 Hy2; apply X.lt_trans with x1. - + destruct (@map2_opt_2 l1 l2' y1); auto. - + destruct (@map2_opt_2 r1 r2' y2); auto. -Qed. - -End Map2_opt. - -Section Map2. -Variable elt elt' elt'' : Type. -Variable f : option elt -> option elt' -> option elt''. - -Lemma map2_bst : forall m m', bst m -> bst m' -> bst (map2 f m m'). -Proof. -unfold map2; intros. -apply map2_opt_bst with (fun _ => f); auto using map_option_bst; - intros; rewrite map_option_find; auto. -Qed. - -Lemma map2_1 : forall m m' y, bst m -> bst m' -> - In y m \/ In y m' -> find y (map2 f m m') = f (find y m) (find y m'). -Proof. -unfold map2; intros. -rewrite (map2_opt_1 (f0:=fun _ => f)); - auto using map_option_bst; intros; rewrite map_option_find; auto. -Qed. - -Lemma map2_2 : forall m m' y, bst m -> bst m' -> - In y (map2 f m m') -> In y m \/ In y m'. -Proof. -unfold map2; intros. -eapply map2_opt_2 with (f0:=fun _ => f); try eassumption; trivial; intros. -- apply map_option_bst; auto. -- apply map_option_bst; auto. -- rewrite map_option_find; auto. -- rewrite map_option_find; auto. -Qed. - -End Map2. -End Proofs. -End Raw. - -(** * Encapsulation - - Now, in order to really provide a functor implementing [S], we - need to encapsulate everything into a type of balanced binary search trees. *) - -Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. - - Module E := X. - Module Raw := Raw I X. - Import Raw.Proofs. - - #[universes(template)] - Record bst (elt:Type) := - Bst {this :> Raw.tree elt; is_bst : Raw.bst this}. - - Definition t := bst. - Definition key := E.t. - - Section Elt. - Variable elt elt' elt'': Type. - - Implicit Types m : t elt. - Implicit Types x y : key. - Implicit Types e : elt. - - Definition empty : t elt := Bst (empty_bst elt). - Definition is_empty m : bool := Raw.is_empty (this m). - Definition add x e m : t elt := Bst (add_bst x e (is_bst m)). - Definition remove x m : t elt := Bst (remove_bst x (is_bst m)). - Definition mem x m : bool := Raw.mem x (this m). - Definition find x m : option elt := Raw.find x (this m). - Definition map f m : t elt' := Bst (map_bst f (is_bst m)). - Definition mapi (f:key->elt->elt') m : t elt' := - Bst (mapi_bst f (is_bst m)). - Definition map2 f m (m':t elt') : t elt'' := - Bst (map2_bst f (is_bst m) (is_bst m')). - Definition elements m : list (key*elt) := Raw.elements (this m). - Definition cardinal m := Raw.cardinal (this m). - Definition fold (A:Type) (f:key->elt->A->A) m i := Raw.fold (A:=A) f (this m) i. - Definition equal cmp m m' : bool := Raw.equal cmp (this m) (this m'). - - Definition MapsTo x e m : Prop := Raw.MapsTo x e (this m). - Definition In x m : Prop := Raw.In0 x (this m). - Definition Empty m : Prop := Empty (this m). - - Definition eq_key : (key*elt) -> (key*elt) -> Prop := @PX.eqk elt. - Definition eq_key_elt : (key*elt) -> (key*elt) -> Prop := @PX.eqke elt. - Definition lt_key : (key*elt) -> (key*elt) -> Prop := @PX.ltk elt. - - Lemma MapsTo_1 : forall m x y e, E.eq x y -> MapsTo x e m -> MapsTo y e m. - Proof. intros m; exact (@MapsTo_1 _ (this m)). Qed. - - Lemma mem_1 : forall m x, In x m -> mem x m = true. - Proof. - unfold In, mem; intros m x; rewrite In_alt; simpl; apply mem_1; auto. - apply (is_bst m). - Qed. - - Lemma mem_2 : forall m x, mem x m = true -> In x m. - Proof. - unfold In, mem; intros m x; rewrite In_alt; simpl; apply mem_2; auto. - Qed. - - Lemma empty_1 : Empty empty. - Proof. exact (@empty_1 elt). Qed. - - Lemma is_empty_1 : forall m, Empty m -> is_empty m = true. - Proof. intros m; exact (@is_empty_1 _ (this m)). Qed. - Lemma is_empty_2 : forall m, is_empty m = true -> Empty m. - Proof. intros m; exact (@is_empty_2 _ (this m)). Qed. - - Lemma add_1 : forall m x y e, E.eq x y -> MapsTo y e (add x e m). - Proof. intros m x y e; exact (@add_1 elt _ x y e). Qed. - Lemma add_2 : forall m x y e e', ~ E.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m). - Proof. intros m x y e e'; exact (@add_2 elt _ x y e e'). Qed. - Lemma add_3 : forall m x y e e', ~ E.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m. - Proof. intros m x y e e'; exact (@add_3 elt _ x y e e'). Qed. - - Lemma remove_1 : forall m x y, E.eq x y -> ~ In y (remove x m). - Proof. - unfold In, remove; intros m x y; rewrite In_alt; simpl; apply remove_1; auto. - apply (is_bst m). - Qed. - Lemma remove_2 : forall m x y e, ~ E.eq x y -> MapsTo y e m -> MapsTo y e (remove x m). - Proof. intros m x y e; exact (@remove_2 elt _ x y e (is_bst m)). Qed. - Lemma remove_3 : forall m x y e, MapsTo y e (remove x m) -> MapsTo y e m. - Proof. intros m x y e; exact (@remove_3 elt _ x y e (is_bst m)). Qed. - - - Lemma find_1 : forall m x e, MapsTo x e m -> find x m = Some e. - Proof. intros m x e; exact (@find_1 elt _ x e (is_bst m)). Qed. - Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m. - Proof. intros m; exact (@find_2 elt (this m)). Qed. - - Lemma fold_1 : forall m (A : Type) (i : A) (f : key -> elt -> A -> A), - fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i. - Proof. intros m; exact (@fold_1 elt (this m) (is_bst m)). Qed. - - Lemma elements_1 : forall m x e, - MapsTo x e m -> InA eq_key_elt (x,e) (elements m). - Proof. - intros; unfold elements, MapsTo, eq_key_elt; rewrite elements_mapsto; auto. - Qed. - - Lemma elements_2 : forall m x e, - InA eq_key_elt (x,e) (elements m) -> MapsTo x e m. - Proof. - intros; unfold elements, MapsTo, eq_key_elt; rewrite <- elements_mapsto; auto. - Qed. - - Lemma elements_3 : forall m, sort lt_key (elements m). - Proof. intros m; exact (@elements_sort elt (this m) (is_bst m)). Qed. - - Lemma elements_3w : forall m, NoDupA eq_key (elements m). - Proof. intros m; exact (@elements_nodup elt (this m) (is_bst m)). Qed. - - Lemma cardinal_1 : forall m, cardinal m = length (elements m). - Proof. intro m; exact (@elements_cardinal elt (this m)). Qed. - - Definition Equal m m' := forall y, find y m = find y m'. - Definition Equiv (eq_elt:elt->elt->Prop) m m' := - (forall k, In k m <-> In k m') /\ - (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e'). - Definition Equivb cmp := Equiv (Cmp cmp). - - Lemma Equivb_Equivb : forall cmp m m', - Equivb cmp m m' <-> Raw.Proofs.Equivb cmp m m'. - Proof. - intros; unfold Equivb, Equiv, Raw.Proofs.Equivb, In. intuition. - - generalize (H0 k); do 2 rewrite In_alt; intuition. - - generalize (H0 k); do 2 rewrite In_alt; intuition. - - generalize (H0 k); do 2 rewrite <- In_alt; intuition. - - generalize (H0 k); do 2 rewrite <- In_alt; intuition. - Qed. - - Lemma equal_1 : forall m m' cmp, - Equivb cmp m m' -> equal cmp m m' = true. - Proof. - unfold equal; intros (m,b) (m',b') cmp; rewrite Equivb_Equivb; - intros; simpl in *; rewrite equal_Equivb; auto. - Qed. - - Lemma equal_2 : forall m m' cmp, - equal cmp m m' = true -> Equivb cmp m m'. - Proof. - unfold equal; intros (m,b) (m',b') cmp; rewrite Equivb_Equivb; - intros; simpl in *; rewrite <-equal_Equivb; auto. - Qed. - - End Elt. - - Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'), - MapsTo x e m -> MapsTo x (f e) (map f m). - Proof. intros elt elt' m x e f; exact (@map_1 elt elt' f (this m) x e). Qed. - - Lemma map_2 : forall (elt elt':Type)(m:t elt)(x:key)(f:elt->elt'), In x (map f m) -> In x m. - Proof. - intros elt elt' m x f; do 2 unfold In in *; do 2 rewrite In_alt; simpl. - apply map_2; auto. - Qed. - - Lemma mapi_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt) - (f:key->elt->elt'), MapsTo x e m -> - exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m). - Proof. intros elt elt' m x e f; exact (@mapi_1 elt elt' f (this m) x e). Qed. - Lemma mapi_2 : forall (elt elt':Type)(m: t elt)(x:key) - (f:key->elt->elt'), In x (mapi f m) -> In x m. - Proof. - intros elt elt' m x f; unfold In in *; do 2 rewrite In_alt; simpl; apply mapi_2; auto. - Qed. - - Lemma map2_1 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') - (x:key)(f:option elt->option elt'->option elt''), - In x m \/ In x m' -> - find x (map2 f m m') = f (find x m) (find x m'). - Proof. - unfold find, map2, In; intros elt elt' elt'' m m' x f. - do 2 rewrite In_alt; intros; simpl; apply map2_1; auto. - - apply (is_bst m). - - apply (is_bst m'). - Qed. - - Lemma map2_2 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') - (x:key)(f:option elt->option elt'->option elt''), - In x (map2 f m m') -> In x m \/ In x m'. - Proof. - unfold In, map2; intros elt elt' elt'' m m' x f. - do 3 rewrite In_alt; intros; simpl in *; eapply map2_2; eauto. - - apply (is_bst m). - - apply (is_bst m'). - Qed. - - -End IntMake. - - -Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: - Sord with Module Data := D - with Module MapS.E := X. - - Module Data := D. - Module Import MapS := IntMake(I)(X). - Module LO := FMapList.Make_ord(X)(D). - Module R := Raw. - Module P := Raw.Proofs. - - Definition t := MapS.t D.t. - - Definition cmp e e' := - match D.compare e e' with EQ _ => true | _ => false end. - - (** One step of comparison of elements *) - - Definition compare_more x1 d1 (cont:R.enumeration D.t -> comparison) e2 := - match e2 with - | R.End _ => Gt - | R.More x2 d2 r2 e2 => - match X.compare x1 x2 with - | EQ _ => match D.compare d1 d2 with - | EQ _ => cont (R.cons r2 e2) - | LT _ => Lt - | GT _ => Gt - end - | LT _ => Lt - | GT _ => Gt - end - end. - - (** Comparison of left tree, middle element, then right tree *) - - Fixpoint compare_cont s1 (cont:R.enumeration D.t -> comparison) e2 := - match s1 with - | R.Leaf _ => cont e2 - | R.Node l1 x1 d1 r1 _ => - compare_cont l1 (compare_more x1 d1 (compare_cont r1 cont)) e2 - end. - - (** Initial continuation *) - - Definition compare_end (e2:R.enumeration D.t) := - match e2 with R.End _ => Eq | _ => Lt end. - - (** The complete comparison *) - - Definition compare_pure s1 s2 := - compare_cont s1 compare_end (R.cons s2 (Raw.End _)). - - (** Correctness of this comparison *) - - Definition Cmp c := - match c with - | Eq => LO.eq_list - | Lt => LO.lt_list - | Gt => (fun l1 l2 => LO.lt_list l2 l1) - end. - - Lemma cons_Cmp : forall c x1 x2 d1 d2 l1 l2, - X.eq x1 x2 -> D.eq d1 d2 -> - Cmp c l1 l2 -> Cmp c ((x1,d1)::l1) ((x2,d2)::l2). - Proof. - destruct c; simpl; intros; P.MX.elim_comp; auto with ordered_type. - Qed. - #[global] - Hint Resolve cons_Cmp : core. - - Lemma compare_end_Cmp : - forall e2, Cmp (compare_end e2) nil (P.flatten_e e2). - Proof. - destruct e2; simpl; auto. - Qed. - - Lemma compare_more_Cmp : forall x1 d1 cont x2 d2 r2 e2 l, - Cmp (cont (R.cons r2 e2)) l (R.elements r2 ++ P.flatten_e e2) -> - Cmp (compare_more x1 d1 cont (R.More x2 d2 r2 e2)) ((x1,d1)::l) - (P.flatten_e (R.More x2 d2 r2 e2)). - Proof. - simpl; intros; destruct X.compare; simpl; - try destruct D.compare; simpl; auto; P.MX.elim_comp; auto. - Qed. - - Lemma compare_cont_Cmp : forall s1 cont e2 l, - (forall e, Cmp (cont e) l (P.flatten_e e)) -> - Cmp (compare_cont s1 cont e2) (R.elements s1 ++ l) (P.flatten_e e2). - Proof. - induction s1 as [|l1 Hl1 x1 d1 r1 Hr1 h1]; intros; auto. - rewrite <- P.elements_node; simpl. - apply Hl1; auto. clear e2. intros [|x2 d2 r2 e2]. - - simpl; auto. - - apply compare_more_Cmp. - rewrite <- P.cons_1; auto. - Qed. - - Lemma compare_Cmp : forall s1 s2, - Cmp (compare_pure s1 s2) (R.elements s1) (R.elements s2). - Proof. - intros; unfold compare_pure. - rewrite <- (app_nil_r (R.elements s1)). - replace (R.elements s2) with (P.flatten_e (R.cons s2 (R.End _))) by - (rewrite P.cons_1; simpl; rewrite app_nil_r; auto). - auto using compare_cont_Cmp, compare_end_Cmp. - Qed. - - (** The dependent-style [compare] *) - - Definition eq (m1 m2 : t) := LO.eq_list (elements m1) (elements m2). - Definition lt (m1 m2 : t) := LO.lt_list (elements m1) (elements m2). - - Definition compare (s s':t) : Compare lt eq s s'. - Proof. - destruct s as (s,b), s' as (s',b'). - generalize (compare_Cmp s s'). - destruct compare_pure; intros; [apply EQ|apply LT|apply GT]; red; auto. - Defined. - - (* Proofs about [eq] and [lt] *) - - Definition selements (m1 : t) := - LO.MapS.Build_slist (P.elements_sort (is_bst m1)). - - Definition seq (m1 m2 : t) := LO.eq (selements m1) (selements m2). - Definition slt (m1 m2 : t) := LO.lt (selements m1) (selements m2). - - Lemma eq_seq : forall m1 m2, eq m1 m2 <-> seq m1 m2. - Proof. - unfold eq, seq, selements, elements, LO.eq; intuition. - Qed. - - Lemma lt_slt : forall m1 m2, lt m1 m2 <-> slt m1 m2. - Proof. - unfold lt, slt, selements, elements, LO.lt; intuition. - Qed. - - Lemma eq_1 : forall (m m' : t), Equivb cmp m m' -> eq m m'. - Proof. - intros m m'. - rewrite eq_seq; unfold seq. - rewrite Equivb_Equivb. - rewrite P.Equivb_elements. - auto using LO.eq_1. - Qed. - - Lemma eq_2 : forall m m', eq m m' -> Equivb cmp m m'. - Proof. - intros m m'. - rewrite eq_seq; unfold seq. - rewrite Equivb_Equivb. - rewrite P.Equivb_elements. - intros. - generalize (LO.eq_2 H). - auto. - Qed. - - Lemma eq_refl : forall m : t, eq m m. - Proof. - intros; rewrite eq_seq; unfold seq; intros; apply LO.eq_refl. - Qed. - - Lemma eq_sym : forall m1 m2 : t, eq m1 m2 -> eq m2 m1. - Proof. - intros m1 m2; rewrite 2 eq_seq; unfold seq; intros; apply LO.eq_sym; auto. - Qed. - - Lemma eq_trans : forall m1 m2 m3 : t, eq m1 m2 -> eq m2 m3 -> eq m1 m3. - Proof. - intros m1 m2 M3; rewrite 3 eq_seq; unfold seq. - intros; eapply LO.eq_trans; eauto. - Qed. - - Lemma lt_trans : forall m1 m2 m3 : t, lt m1 m2 -> lt m2 m3 -> lt m1 m3. - Proof. - intros m1 m2 m3; rewrite 3 lt_slt; unfold slt; - intros; eapply LO.lt_trans; eauto. - Qed. - - Lemma lt_not_eq : forall m1 m2 : t, lt m1 m2 -> ~ eq m1 m2. - Proof. - intros m1 m2; rewrite lt_slt, eq_seq; unfold slt, seq; - intros; apply LO.lt_not_eq; auto. - Qed. - -End IntMake_ord. - -(* For concrete use inside Coq, we propose an instantiation of [Int] by [Z]. *) - -Module Make (X: OrderedType) <: S with Module E := X - :=IntMake(Z_as_Int)(X). - -Module Make_ord (X: OrderedType)(D: OrderedType) - <: Sord with Module Data := D - with Module MapS.E := X - :=IntMake_ord(Z_as_Int)(X)(D). diff --git a/stdlib/theories/FSets/FMapFacts.v b/stdlib/theories/FSets/FMapFacts.v deleted file mode 100644 index 931f3d9f4e88..000000000000 --- a/stdlib/theories/FSets/FMapFacts.v +++ /dev/null @@ -1,2297 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* constructor; congruence : core. - -(** * Facts about weak maps *) - -Module WFacts_fun (E:DecidableType)(Import M:WSfun E). - -Notation eq_dec := E.eq_dec. -Definition eqb x y := if eq_dec x y then true else false. - -Lemma eq_bool_alt : forall b b', b=b' <-> (b=true <-> b'=true). -Proof. - destruct b; destruct b'; intuition. -Qed. - -Lemma eq_option_alt : forall (elt:Type)(o o':option elt), - o=o' <-> (forall e, o=Some e <-> o'=Some e). -Proof. -split; intros. -- subst; split; auto. -- destruct o; destruct o'; try rewrite H; auto. - symmetry; rewrite <- H; auto. -Qed. - -Lemma MapsTo_fun : forall (elt:Type) m x (e e':elt), - MapsTo x e m -> MapsTo x e' m -> e=e'. -Proof. -intros. -generalize (find_1 H) (find_1 H0); clear H H0. -intros; rewrite H in H0; injection H0; auto. -Qed. - -(** ** Specifications written using equivalences *) - -Section IffSpec. -Variable elt elt' elt'': Type. -Implicit Type m: t elt. -Implicit Type x y z: key. -Implicit Type e: elt. - -Lemma In_iff : forall m x y, E.eq x y -> (In x m <-> In y m). -Proof. -unfold In. -split; intros (e0,H0); exists e0. -- apply (MapsTo_1 H H0); auto. -- apply (MapsTo_1 (E.eq_sym H) H0); auto. -Qed. - -Lemma MapsTo_iff : forall m x y e, E.eq x y -> (MapsTo x e m <-> MapsTo y e m). -Proof. -split; apply MapsTo_1; auto. -Qed. - -Lemma mem_in_iff : forall m x, In x m <-> mem x m = true. -Proof. -split; [apply mem_1|apply mem_2]. -Qed. - -Lemma not_mem_in_iff : forall m x, ~In x m <-> mem x m = false. -Proof. -intros; rewrite mem_in_iff; destruct (mem x m); intuition. -Qed. - -Lemma In_dec : forall m x, { In x m } + { ~ In x m }. -Proof. - intros. - generalize (mem_in_iff m x). - destruct (mem x m); [left|right]; intuition. -Qed. - -Lemma find_mapsto_iff : forall m x e, MapsTo x e m <-> find x m = Some e. -Proof. -split; [apply find_1|apply find_2]. -Qed. - -Lemma not_find_in_iff : forall m x, ~In x m <-> find x m = None. -Proof. -split; intros. -- rewrite eq_option_alt. intro e. rewrite <- find_mapsto_iff. - split; try discriminate. intro H'; elim H; exists e; auto. -- intros (e,He); rewrite find_mapsto_iff,H in He; discriminate. -Qed. - -Lemma in_find_iff : forall m x, In x m <-> find x m <> None. -Proof. -intros; rewrite <- not_find_in_iff, mem_in_iff. -destruct mem; intuition. -Qed. - -Lemma equal_iff : forall m m' cmp, Equivb cmp m m' <-> equal cmp m m' = true. -Proof. -split; [apply equal_1|apply equal_2]. -Qed. - -Lemma empty_mapsto_iff : forall x e, MapsTo x e (empty elt) <-> False. -Proof. -intuition; apply (empty_1 H). -Qed. - -Lemma empty_in_iff : forall x, In x (empty elt) <-> False. -Proof. -unfold In. -split; [intros (e,H); rewrite empty_mapsto_iff in H|]; intuition. -Qed. - -Lemma is_empty_iff : forall m, Empty m <-> is_empty m = true. -Proof. -split; [apply is_empty_1|apply is_empty_2]. -Qed. - -Lemma add_mapsto_iff : forall m x y e e', - MapsTo y e' (add x e m) <-> - (E.eq x y /\ e=e') \/ - (~E.eq x y /\ MapsTo y e' m). -Proof. -intros. -intuition. -- destruct (eq_dec x y); [left|right]. - + split; auto. - symmetry; apply (MapsTo_fun (e':=e) H); auto with map. - + split; auto; apply add_3 with x e; auto. -- subst; auto with map. -Qed. - -Lemma add_in_iff : forall m x y e, In y (add x e m) <-> E.eq x y \/ In y m. -Proof. -unfold In; split. -- intros (e',H). - destruct (eq_dec x y) as [E|E]; auto. - right; exists e'; auto. - apply (add_3 E H). -- destruct (eq_dec x y) as [E|E]; auto. - + intros. - exists e; apply add_1; auto. - + intros [H|(e',H)]. - * destruct E; auto. - * exists e'; apply add_2; auto. -Qed. - -Lemma add_neq_mapsto_iff : forall m x y e e', - ~ E.eq x y -> (MapsTo y e' (add x e m) <-> MapsTo y e' m). -Proof. -split; [apply add_3|apply add_2]; auto. -Qed. - -Lemma add_neq_in_iff : forall m x y e, - ~ E.eq x y -> (In y (add x e m) <-> In y m). -Proof. -split; intros (e',H0); exists e'. -- apply (add_3 H H0). -- apply add_2; auto. -Qed. - -Lemma remove_mapsto_iff : forall m x y e, - MapsTo y e (remove x m) <-> ~E.eq x y /\ MapsTo y e m. -Proof. -intros. -split; intros. -- split. - + assert (In y (remove x m)) by (exists e; auto). - intro H1; apply (remove_1 H1 H0). - + apply remove_3 with x; auto. -- apply remove_2; intuition. -Qed. - -Lemma remove_in_iff : forall m x y, In y (remove x m) <-> ~E.eq x y /\ In y m. -Proof. -unfold In; split. -- intros (e,H). - split. - + assert (In y (remove x m)) by (exists e; auto). - intro H1; apply (remove_1 H1 H0). - + exists e; apply remove_3 with x; auto. -- intros (H,(e,H0)); exists e; apply remove_2; auto. -Qed. - -Lemma remove_neq_mapsto_iff : forall m x y e, - ~ E.eq x y -> (MapsTo y e (remove x m) <-> MapsTo y e m). -Proof. -split; [apply remove_3|apply remove_2]; auto. -Qed. - -Lemma remove_neq_in_iff : forall m x y, - ~ E.eq x y -> (In y (remove x m) <-> In y m). -Proof. -split; intros (e',H0); exists e'. -- apply (remove_3 H0). -- apply remove_2; auto. -Qed. - -Lemma elements_mapsto_iff : forall m x e, - MapsTo x e m <-> InA (@eq_key_elt _) (x,e) (elements m). -Proof. -split; [apply elements_1 | apply elements_2]. -Qed. - -Lemma elements_in_iff : forall m x, - In x m <-> exists e, InA (@eq_key_elt _) (x,e) (elements m). -Proof. -unfold In; split; intros (e,H); exists e; [apply elements_1 | apply elements_2]; auto. -Qed. - -Lemma map_mapsto_iff : forall m x b (f : elt -> elt'), - MapsTo x b (map f m) <-> exists a, b = f a /\ MapsTo x a m. -Proof. -split. -- case_eq (find x m); intros. - + exists e. - split. - * apply (MapsTo_fun (m:=map f m) (x:=x)); auto with map. - * apply find_2; auto with map. - + assert (In x (map f m)) by (exists b; auto). - destruct (map_2 H1) as (a,H2). - rewrite (find_1 H2) in H; discriminate. -- intros (a,(H,H0)). - subst b; auto with map. -Qed. - -Lemma map_in_iff : forall m x (f : elt -> elt'), - In x (map f m) <-> In x m. -Proof. -split; intros; eauto with map. -destruct H as (a,H). -exists (f a); auto with map. -Qed. - -Lemma mapi_in_iff : forall m x (f:key->elt->elt'), - In x (mapi f m) <-> In x m. -Proof. -split; intros; eauto with map. -destruct H as (a,H). -destruct (mapi_1 f H) as (y,(H0,H1)). -exists (f y a); auto. -Qed. - -(** Unfortunately, we don't have simple equivalences for [mapi] - and [MapsTo]. The only correct one needs compatibility of [f]. *) - -Lemma mapi_inv : forall m x b (f : key -> elt -> elt'), - MapsTo x b (mapi f m) -> - exists a y, E.eq y x /\ b = f y a /\ MapsTo x a m. -Proof. -intros; case_eq (find x m); intros. -- exists e. - destruct (@mapi_1 _ _ m x e f) as (y,(H1,H2)). - + apply find_2; auto with map. - + exists y; repeat split; auto with map. - apply (MapsTo_fun (m:=mapi f m) (x:=x)); auto with map. -- assert (In x (mapi f m)) by (exists b; auto). - destruct (mapi_2 H1) as (a,H2). - rewrite (find_1 H2) in H0; discriminate. -Qed. - -Lemma mapi_1bis : forall m x e (f:key->elt->elt'), - (forall x y e, E.eq x y -> f x e = f y e) -> - MapsTo x e m -> MapsTo x (f x e) (mapi f m). -Proof. -intros. -destruct (mapi_1 f H0) as (y,(H1,H2)). -replace (f x e) with (f y e) by auto. -auto. -Qed. - -Lemma mapi_mapsto_iff : forall m x b (f:key->elt->elt'), - (forall x y e, E.eq x y -> f x e = f y e) -> - (MapsTo x b (mapi f m) <-> exists a, b = f x a /\ MapsTo x a m). -Proof. -split. -- intros. - destruct (mapi_inv H0) as (a,(y,(H1,(H2,H3)))). - exists a; split; auto. - subst b; auto. -- intros (a,(H0,H1)). - subst b. - apply mapi_1bis; auto. -Qed. - -(** Things are even worse for [map2] : we don't try to state any - equivalence, see instead boolean results below. *) - -End IffSpec. - -(** Useful tactic for simplifying expressions like [In y (add x e (remove z m))] *) - -Ltac map_iff := - repeat (progress ( - rewrite add_mapsto_iff || rewrite add_in_iff || - rewrite remove_mapsto_iff || rewrite remove_in_iff || - rewrite empty_mapsto_iff || rewrite empty_in_iff || - rewrite map_mapsto_iff || rewrite map_in_iff || - rewrite mapi_in_iff)). - -(** ** Specifications written using boolean predicates *) - -Section BoolSpec. - -Lemma mem_find_b : forall (elt:Type)(m:t elt)(x:key), mem x m = if find x m then true else false. -Proof. -intros. -generalize (find_mapsto_iff m x)(mem_in_iff m x); unfold In. -destruct (find x m); destruct (mem x m); auto. -- intros. - rewrite <- H0; exists e; rewrite H; auto. -- intuition. - destruct H0 as (e,H0). - destruct (H e); intuition discriminate. -Qed. - -Variable elt elt' elt'' : Type. -Implicit Types m : t elt. -Implicit Types x y z : key. -Implicit Types e : elt. - -Lemma mem_b : forall m x y, E.eq x y -> mem x m = mem y m. -Proof. -intros. -generalize (mem_in_iff m x) (mem_in_iff m y)(In_iff m H). -destruct (mem x m); destruct (mem y m); intuition. -Qed. - -Lemma find_o : forall m x y, E.eq x y -> find x m = find y m. -Proof. -intros. rewrite eq_option_alt. intro e. rewrite <- 2 find_mapsto_iff. -apply MapsTo_iff; auto. -Qed. - -Lemma empty_o : forall x, find x (empty elt) = None. -Proof. -intros. rewrite eq_option_alt. intro e. -rewrite <- find_mapsto_iff, empty_mapsto_iff; now intuition. -Qed. - -Lemma empty_a : forall x, mem x (empty elt) = false. -Proof. -intros. -case_eq (mem x (empty elt)); intros; auto. -generalize (mem_2 H). -rewrite empty_in_iff; intuition. -Qed. - -Lemma add_eq_o : forall m x y e, - E.eq x y -> find y (add x e m) = Some e. -Proof. -auto with map. -Qed. - -Lemma add_neq_o : forall m x y e, - ~ E.eq x y -> find y (add x e m) = find y m. -Proof. -intros. rewrite eq_option_alt. intro e'. rewrite <- 2 find_mapsto_iff. -apply add_neq_mapsto_iff; auto. -Qed. -#[local] -Hint Resolve add_neq_o : map. - -Lemma add_o : forall m x y e, - find y (add x e m) = if eq_dec x y then Some e else find y m. -Proof. -intros; destruct (eq_dec x y); auto with map. -Qed. - -Lemma add_eq_b : forall m x y e, - E.eq x y -> mem y (add x e m) = true. -Proof. -intros; rewrite mem_find_b; rewrite add_eq_o; auto. -Qed. - -Lemma add_neq_b : forall m x y e, - ~E.eq x y -> mem y (add x e m) = mem y m. -Proof. -intros; do 2 rewrite mem_find_b; rewrite add_neq_o; auto. -Qed. - -Lemma add_b : forall m x y e, - mem y (add x e m) = eqb x y || mem y m. -Proof. -intros; do 2 rewrite mem_find_b; rewrite add_o; unfold eqb. -destruct (eq_dec x y); simpl; auto. -Qed. - -Lemma remove_eq_o : forall m x y, - E.eq x y -> find y (remove x m) = None. -Proof. -intros. rewrite eq_option_alt. intro e. -rewrite <- find_mapsto_iff, remove_mapsto_iff; now intuition. -Qed. -#[local] -Hint Resolve remove_eq_o : map. - -Lemma remove_neq_o : forall m x y, - ~ E.eq x y -> find y (remove x m) = find y m. -Proof. -intros. rewrite eq_option_alt. intro e. -rewrite <- find_mapsto_iff, remove_neq_mapsto_iff; now intuition. -Qed. -#[local] -Hint Resolve remove_neq_o : map. - -Lemma remove_o : forall m x y, - find y (remove x m) = if eq_dec x y then None else find y m. -Proof. -intros; destruct (eq_dec x y); auto with map. -Qed. - -Lemma remove_eq_b : forall m x y, - E.eq x y -> mem y (remove x m) = false. -Proof. -intros; rewrite mem_find_b; rewrite remove_eq_o; auto. -Qed. - -Lemma remove_neq_b : forall m x y, - ~ E.eq x y -> mem y (remove x m) = mem y m. -Proof. -intros; do 2 rewrite mem_find_b; rewrite remove_neq_o; auto. -Qed. - -Lemma remove_b : forall m x y, - mem y (remove x m) = negb (eqb x y) && mem y m. -Proof. -intros; do 2 rewrite mem_find_b; rewrite remove_o; unfold eqb. -destruct (eq_dec x y); auto. -Qed. - -Lemma map_o : forall m x (f:elt->elt'), - find x (map f m) = Datatypes.option_map f (find x m). -Proof. -intros. -generalize (find_mapsto_iff (map f m) x) (find_mapsto_iff m x) - (fun b => map_mapsto_iff m x b f). -destruct (find x (map f m)); destruct (find x m); simpl; auto; intros. -- rewrite <- H; rewrite H1; exists e0; rewrite H0; auto. -- destruct (H e) as [_ H2]. - rewrite H1 in H2. - destruct H2 as (a,(_,H2)); auto. - rewrite H0 in H2; discriminate. -- rewrite <- H; rewrite H1; exists e; rewrite H0; auto. -Qed. - -Lemma map_b : forall m x (f:elt->elt'), - mem x (map f m) = mem x m. -Proof. -intros; do 2 rewrite mem_find_b; rewrite map_o. -destruct (find x m); simpl; auto. -Qed. - -Lemma mapi_b : forall m x (f:key->elt->elt'), - mem x (mapi f m) = mem x m. -Proof. -intros. -generalize (mem_in_iff (mapi f m) x) (mem_in_iff m x) (mapi_in_iff m x f). -destruct (mem x (mapi f m)); destruct (mem x m); simpl; auto; intros. -- symmetry; rewrite <- H0; rewrite <- H1; rewrite H; auto. -- rewrite <- H; rewrite H1; rewrite H0; auto. -Qed. - -Lemma mapi_o : forall m x (f:key->elt->elt'), - (forall x y e, E.eq x y -> f x e = f y e) -> - find x (mapi f m) = Datatypes.option_map (f x) (find x m). -Proof. -intros. -generalize (find_mapsto_iff (mapi f m) x) (find_mapsto_iff m x) - (fun b => mapi_mapsto_iff m x b H). -destruct (find x (mapi f m)); destruct (find x m); simpl; auto; intros. -- rewrite <- H0; rewrite H2; exists e0; rewrite H1; auto. -- destruct (H0 e) as [_ H3]. - rewrite H2 in H3. - destruct H3 as (a,(_,H3)); auto. - rewrite H1 in H3; discriminate. -- rewrite <- H0; rewrite H2; exists e; rewrite H1; auto. -Qed. - -Lemma map2_1bis : forall (m: t elt)(m': t elt') x - (f:option elt->option elt'->option elt''), - f None None = None -> - find x (map2 f m m') = f (find x m) (find x m'). -Proof. -intros. -case_eq (find x m); intros. -- rewrite <- H0. - apply map2_1; auto with map. - left; exists e; auto with map. -- case_eq (find x m'); intros. - + rewrite <- H0; rewrite <- H1. - apply map2_1; auto. - right; exists e; auto with map. - + rewrite H. - case_eq (find x (map2 f m m')); intros; auto with map. - assert (In x (map2 f m m')) by (exists e; auto with map). - destruct (map2_2 H3) as [(e0,H4)|(e0,H4)]. - * rewrite (find_1 H4) in H0; discriminate. - * rewrite (find_1 H4) in H1; discriminate. -Qed. - -Lemma elements_o : forall m x, - find x m = findA (eqb x) (elements m). -Proof. -intros. rewrite eq_option_alt. intro e. -rewrite <- find_mapsto_iff, elements_mapsto_iff. -unfold eqb. -rewrite <- findA_NoDupA; dintuition; try apply elements_3w; eauto. -Qed. - -Lemma elements_b : forall m x, - mem x m = existsb (fun p => eqb x (fst p)) (elements m). -Proof. -intros. -generalize (mem_in_iff m x)(elements_in_iff m x) - (existsb_exists (fun p => eqb x (fst p)) (elements m)). -destruct (mem x m); destruct (existsb (fun p => eqb x (fst p)) (elements m)); auto; intros. -- symmetry; rewrite H1. - destruct H0 as (H0,_). - destruct H0 as (e,He); [ intuition |]. - rewrite InA_alt in He. - destruct He as ((y,e'),(Ha1,Ha2)). - compute in Ha1; destruct Ha1; subst e'. - exists (y,e); split; simpl; auto. - unfold eqb; destruct (eq_dec x y); intuition. -- rewrite <- H; rewrite H0. - destruct H1 as (H1,_). - destruct H1 as ((y,e),(Ha1,Ha2)); [intuition|]. - simpl in Ha2. - unfold eqb in *; destruct (eq_dec x y); auto; try discriminate. - exists e; rewrite InA_alt. - exists (y,e); intuition. - compute; auto. -Qed. - -End BoolSpec. - -Section Equalities. - -Variable elt:Type. - - (** Another characterisation of [Equal] *) - -Lemma Equal_mapsto_iff : forall m1 m2 : t elt, - Equal m1 m2 <-> (forall k e, MapsTo k e m1 <-> MapsTo k e m2). -Proof. -intros m1 m2. split; [intros Heq k e|intros Hiff]. -- rewrite 2 find_mapsto_iff, Heq. split; auto. -- intro k. rewrite eq_option_alt. intro e. - rewrite <- 2 find_mapsto_iff; auto. -Qed. - -(** * Relations between [Equal], [Equiv] and [Equivb]. *) - -(** First, [Equal] is [Equiv] with Leibniz on elements. *) - -Lemma Equal_Equiv : forall (m m' : t elt), - Equal m m' <-> Equiv Logic.eq m m'. -Proof. -intros. rewrite Equal_mapsto_iff. split; intros. -- split. - + split; intros (e,Hin); exists e; [rewrite <- H|rewrite H]; auto. - + intros; apply MapsTo_fun with m k; auto; rewrite H; auto. -- split; intros H'. - + destruct H. - assert (Hin : In k m') by (rewrite <- H; exists e; auto). - destruct Hin as (e',He'). - rewrite (H0 k e e'); auto. - + destruct H. - assert (Hin : In k m) by (rewrite H; exists e; auto). - destruct Hin as (e',He'). - rewrite <- (H0 k e' e); auto. -Qed. - -(** [Equivb] and [Equiv] and equivalent when [eq_elt] and [cmp] - are related. *) - -Section Cmp. -Variable eq_elt : elt->elt->Prop. -Variable cmp : elt->elt->bool. - -Definition compat_cmp := - forall e e', cmp e e' = true <-> eq_elt e e'. - -Lemma Equiv_Equivb : compat_cmp -> - forall m m', Equiv eq_elt m m' <-> Equivb cmp m m'. -Proof. - unfold Equivb, Equiv, Cmp; intuition. - - red in H; rewrite H; eauto. - - red in H; rewrite <-H; eauto. -Qed. -End Cmp. - -(** Composition of the two last results: relation between [Equal] - and [Equivb]. *) - -Lemma Equal_Equivb : forall cmp, - (forall e e', cmp e e' = true <-> e = e') -> - forall (m m':t elt), Equal m m' <-> Equivb cmp m m'. -Proof. - intros; rewrite Equal_Equiv. - apply Equiv_Equivb; auto. -Qed. - -Lemma Equal_Equivb_eqdec : - forall eq_elt_dec : (forall e e', { e = e' } + { e <> e' }), - let cmp := fun e e' => if eq_elt_dec e e' then true else false in - forall (m m':t elt), Equal m m' <-> Equivb cmp m m'. -Proof. -intros; apply Equal_Equivb. -unfold cmp; clear cmp; intros. -destruct eq_elt_dec; now intuition. -Qed. - -End Equalities. - -(** * [Equal] is a setoid equality. *) - -Lemma Equal_refl : forall (elt:Type)(m : t elt), Equal m m. -Proof. red; reflexivity. Qed. - -Lemma Equal_sym : forall (elt:Type)(m m' : t elt), - Equal m m' -> Equal m' m. -Proof. unfold Equal; auto. Qed. - -Lemma Equal_trans : forall (elt:Type)(m m' m'' : t elt), - Equal m m' -> Equal m' m'' -> Equal m m''. -Proof. unfold Equal; congruence. Qed. - -Lemma Equal_ST : forall elt:Type, Equivalence (@Equal elt). -Proof. -constructor; red; [apply Equal_refl | apply Equal_sym | apply Equal_trans]. -Qed. - -Add Relation key E.eq - reflexivity proved by E.eq_refl - symmetry proved by E.eq_sym - transitivity proved by E.eq_trans - as KeySetoid. - -Arguments Equal {elt} m m'. - -Add Parametric Relation (elt : Type) : (t elt) Equal - reflexivity proved by (@Equal_refl elt) - symmetry proved by (@Equal_sym elt) - transitivity proved by (@Equal_trans elt) - as EqualSetoid. - -Add Parametric Morphism elt : (@In elt) - with signature E.eq ==> Equal ==> iff as In_m. -Proof. -unfold Equal; intros k k' Hk m m' Hm. -rewrite (In_iff m Hk), in_find_iff, in_find_iff, Hm; intuition. -Qed. - -Add Parametric Morphism elt : (@MapsTo elt) - with signature E.eq ==> eq ==> Equal ==> iff as MapsTo_m. -Proof. -unfold Equal; intros k k' Hk e m m' Hm. -rewrite (MapsTo_iff m e Hk), find_mapsto_iff, find_mapsto_iff, Hm; - intuition. -Qed. - -Add Parametric Morphism elt : (@Empty elt) - with signature Equal ==> iff as Empty_m. -Proof. -unfold Empty; intros m m' Hm. split; intros; intro. -- rewrite <-Hm in H0; eapply H, H0. -- rewrite Hm in H0; eapply H, H0. -Qed. - -Add Parametric Morphism elt : (@is_empty elt) - with signature Equal ==> eq as is_empty_m. -Proof. -intros m m' Hm. -rewrite eq_bool_alt, <-is_empty_iff, <-is_empty_iff, Hm; intuition. -Qed. - -Add Parametric Morphism elt : (@mem elt) - with signature E.eq ==> Equal ==> eq as mem_m. -Proof. -intros k k' Hk m m' Hm. -rewrite eq_bool_alt, <- mem_in_iff, <-mem_in_iff, Hk, Hm; intuition. -Qed. - -Add Parametric Morphism elt : (@find elt) - with signature E.eq ==> Equal ==> eq as find_m. -Proof. -intros k k' Hk m m' Hm. rewrite eq_option_alt. intro e. -rewrite <- 2 find_mapsto_iff, Hk, Hm. split; auto. -Qed. - -Add Parametric Morphism elt : (@add elt) - with signature E.eq ==> eq ==> Equal ==> Equal as add_m. -Proof. -intros k k' Hk e m m' Hm y. -rewrite add_o, add_o; do 2 destruct eq_dec as [|?Hnot]; auto. -- elim Hnot; rewrite <-Hk; auto. -- elim Hnot; rewrite Hk; auto. -Qed. - -Add Parametric Morphism elt : (@remove elt) - with signature E.eq ==> Equal ==> Equal as remove_m. -Proof. -intros k k' Hk m m' Hm y. -rewrite remove_o, remove_o; do 2 destruct eq_dec as [|?Hnot]; auto. -- elim Hnot; rewrite <-Hk; auto. -- elim Hnot; rewrite Hk; auto. -Qed. - -Add Parametric Morphism elt elt' : (@map elt elt') - with signature eq ==> Equal ==> Equal as map_m. -Proof. -intros f m m' Hm y. -rewrite map_o, map_o, Hm; auto. -Qed. - -(* Later: Add Morphism cardinal *) - -(* old name: *) -Notation not_find_mapsto_iff := not_find_in_iff. - -End WFacts_fun. - -(** * Same facts for self-contained weak sets and for full maps *) - -Module WFacts (M:WS) := WFacts_fun M.E M. -Module Facts := WFacts. - -(** * Additional Properties for weak maps - - Results about [fold], [elements], induction principles... -*) - -Module WProperties_fun (E:DecidableType)(M:WSfun E). - Module Import F:=WFacts_fun E M. - Import M. - - Section Elt. - Variable elt:Type. - - Definition Add x (e:elt) m m' := forall y, find y m' = find y (add x e m). - - Lemma Add_transpose_neqkey : forall k1 k2 e1 e2 m1 m2 m3, - ~ E.eq k1 k2 -> Add k1 e1 m1 m2 -> Add k2 e2 m2 m3 -> - { m | Add k2 e2 m1 m /\ Add k1 e1 m m3 }. - Proof. - intros. - exists (add k2 e2 m1). - split. - - { easy. } - - unfold Add; intros. - rewrite H1. - destruct (E.eq_dec k1 y). - - assert (~ E.eq k2 y). - + contradict H. - apply E.eq_trans with (y:=y); auto. - + now rewrite add_neq_o, add_eq_o, H0, add_eq_o by assumption. - - destruct (E.eq_dec k2 y). - + now rewrite add_eq_o, add_neq_o, add_eq_o by assumption. - + now rewrite add_neq_o, H0, add_neq_o, add_neq_o, add_neq_o by assumption. - Qed. - - Notation eqke := (@eq_key_elt elt). - Notation eqk := (@eq_key elt). - - Instance eqk_equiv : Equivalence eqk. - Proof. unfold eq_key; split; eauto. Qed. - - Instance eqke_equiv : Equivalence eqke. - Proof. - unfold eq_key_elt; split; repeat red; firstorder. - - eauto. - - congruence. - Qed. - - (** Complements about InA, NoDupA and findA *) - - Lemma InA_eqke_eqk : forall k1 k2 e1 e2 l, - E.eq k1 k2 -> InA eqke (k1,e1) l -> InA eqk (k2,e2) l. - Proof. - intros k1 k2 e1 e2 l Hk. rewrite 2 InA_alt. - intros ((k',e') & (Hk',He') & H); simpl in *. - exists (k',e'); split; auto. - red; simpl; eauto. - Qed. - - Lemma NoDupA_eqk_eqke : forall l, NoDupA eqk l -> NoDupA eqke l. - Proof. - induction 1; auto. - constructor; auto. - destruct x as (k,e). - eauto using InA_eqke_eqk. - Qed. - - Lemma findA_rev : forall l k, NoDupA eqk l -> - findA (eqb k) l = findA (eqb k) (rev l). - Proof. - intros. - case_eq (findA (eqb k) l). - - intros. symmetry. - unfold eqb. - rewrite <- findA_NoDupA, InA_rev, findA_NoDupA - by (eauto using NoDupA_rev with *); eauto. - - case_eq (findA (eqb k) (rev l)); auto. - intros e. - unfold eqb. - rewrite <- findA_NoDupA, InA_rev, findA_NoDupA - by (eauto using NoDupA_rev with *). - intro Eq; rewrite Eq; auto. - Qed. - - (** * Elements *) - - Lemma elements_Empty : forall m:t elt, Empty m <-> elements m = nil. - Proof. - intros. - unfold Empty. - split; intros. - - assert (forall a, ~ List.In a (elements m)). { - red; intros. - apply (H (fst a) (snd a)). - rewrite elements_mapsto_iff. - rewrite InA_alt; exists a; auto. - split; auto; split; auto. - } - destruct (elements m); auto. - elim (H0 p); simpl; auto. - - red; intros. - rewrite elements_mapsto_iff in H0. - rewrite InA_alt in H0; destruct H0. - rewrite H in H0; destruct H0 as (_,H0); inversion H0. - Qed. - - Lemma elements_empty : elements (@empty elt) = nil. - Proof. - rewrite <-elements_Empty; apply empty_1. - Qed. - - (** * Conversions between maps and association lists. *) - - Definition uncurry {U V W : Type} (f : U -> V -> W) : U*V -> W := - fun p => f (fst p) (snd p). - - Definition of_list := - List.fold_right (uncurry (@add _)) (empty elt). - - Definition to_list := elements. - - Lemma of_list_1 : forall l k e, - NoDupA eqk l -> - (MapsTo k e (of_list l) <-> InA eqke (k,e) l). - Proof. - induction l as [|(k',e') l IH]; simpl; intros k e Hnodup. - - rewrite empty_mapsto_iff, InA_nil; intuition. - - unfold uncurry; simpl. - inversion_clear Hnodup as [| ? ? Hnotin Hnodup']. - specialize (IH k e Hnodup'); clear Hnodup'. - rewrite add_mapsto_iff, InA_cons, <- IH. - unfold eq_key_elt at 1; simpl. - split; destruct 1 as [H|H]; try (intuition;fail). - destruct (eq_dec k k'); [left|right]; split; auto. - contradict Hnotin. - apply InA_eqke_eqk with k e; intuition. - Qed. - - Lemma of_list_1b : forall l k, - NoDupA eqk l -> - find k (of_list l) = findA (eqb k) l. - Proof. - induction l as [|(k',e') l IH]; simpl; intros k Hnodup. - - apply empty_o. - - unfold uncurry; simpl. - inversion_clear Hnodup as [| ? ? Hnotin Hnodup']. - specialize (IH k Hnodup'); clear Hnodup'. - rewrite add_o, IH. - unfold eqb; do 2 destruct eq_dec as [|?Hnot]; auto; elim Hnot; eauto. - Qed. - - Lemma of_list_2 : forall l, NoDupA eqk l -> - equivlistA eqke l (to_list (of_list l)). - Proof. - intros l Hnodup (k,e). - rewrite <- elements_mapsto_iff, of_list_1; intuition. - Qed. - - Lemma of_list_3 : forall s, Equal (of_list (to_list s)) s. - Proof. - intros s k. - rewrite of_list_1b, elements_o; auto. - apply elements_3w. - Qed. - - (** * Fold *) - - (** Alternative specification via [fold_right] *) - - Lemma fold_spec_right m (A:Type)(i:A)(f : key -> elt -> A -> A) : - fold f m i = List.fold_right (uncurry f) i (rev (elements m)). - Proof. - rewrite fold_1. symmetry. apply fold_left_rev_right. - Qed. - - (** ** Induction principles about fold contributed by S. Lescuyer *) - - (** In the following lemma, the step hypothesis is deliberately restricted - to the precise map m we are considering. *) - - Lemma fold_rec : - forall (A:Type)(P : t elt -> A -> Type)(f : key -> elt -> A -> A), - forall (i:A)(m:t elt), - (forall m, Empty m -> P m i) -> - (forall k e a m' m'', MapsTo k e m -> ~In k m' -> - Add k e m' m'' -> P m' a -> P m'' (f k e a)) -> - P m (fold f m i). - Proof. - intros A P f i m Hempty Hstep. - rewrite fold_spec_right. - set (F:=uncurry f). - set (l:=rev (elements m)). - 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. - } - assert (Hdup : NoDupA eqk l). { - 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. - apply elements_3w. - } - clearbody l. clearbody F. clear Hstep f. revert m Hsame. induction l. - - (* empty *) - intros m Hsame; simpl. - apply Hempty. intros k e. - rewrite find_mapsto_iff, Hsame; simpl; discriminate. - - (* step *) - intros m Hsame; destruct a as (k,e); simpl. - apply Hstep' with (of_list l); auto. - + rewrite InA_cons; left; red; auto. - + inversion_clear Hdup. contradict H. destruct H as (e',He'). - apply InA_eqke_eqk with k e'; auto. - rewrite <- of_list_1; auto. - + intro k'. rewrite Hsame, add_o, of_list_1b. - * simpl. - unfold eqb. do 2 destruct eq_dec as [|?Hnot]; auto; elim Hnot; eauto. - * inversion_clear Hdup; auto. - + apply IHl. - * intros; eapply Hstep'; eauto. - * inversion_clear Hdup; auto. - * intros; apply of_list_1b. inversion_clear Hdup; auto. - Qed. - - (** Same, with [empty] and [add] instead of [Empty] and [Add]. In this - case, [P] must be compatible with equality of sets *) - - Theorem fold_rec_bis : - forall (A:Type)(P : t elt -> A -> Type)(f : key -> elt -> A -> A), - forall (i:A)(m:t elt), - (forall m m' a, Equal m m' -> P m a -> P m' a) -> - (P (empty _) i) -> - (forall k e a m', MapsTo k e m -> ~In k m' -> - P m' a -> P (add k e m') (f k e a)) -> - P m (fold f m i). - Proof. - intros A P f i m Pmorphism Pempty Pstep. - apply fold_rec; intros. - - apply Pmorphism with (empty _); auto. intro k. rewrite empty_o. - case_eq (find k m0); auto; intros e'; rewrite <- find_mapsto_iff. - intro H'; elim (H k e'); auto. - - apply Pmorphism with (add k e m'); try intro; auto. - Qed. - - Lemma fold_rec_nodep : - forall (A:Type)(P : A -> Type)(f : key -> elt -> A -> A)(i:A)(m:t elt), - P i -> (forall k e a, MapsTo k e m -> P a -> P (f k e a)) -> - P (fold f m i). - Proof. - intros; apply fold_rec_bis with (P:=fun _ => P); auto. - Qed. - - (** [fold_rec_weak] is a weaker principle than [fold_rec_bis] : - the step hypothesis must here be applicable anywhere. - At the same time, it looks more like an induction principle, - and hence can be easier to use. *) - - Lemma fold_rec_weak : - forall (A:Type)(P : t elt -> A -> Type)(f : key -> elt -> A -> A)(i:A), - (forall m m' a, Equal m m' -> P m a -> P m' a) -> - P (empty _) i -> - (forall k e a m, ~In k m -> P m a -> P (add k e m) (f k e a)) -> - forall m, P m (fold f m i). - Proof. - intros; apply fold_rec_bis; auto. - Qed. - - Lemma fold_rel : - forall (A B:Type)(R : A -> B -> Type) - (f : key -> elt -> A -> A)(g : key -> elt -> B -> B)(i : A)(j : B) - (m : t elt), - R i j -> - (forall k e a b, MapsTo k e m -> R a b -> R (f k e a) (g k e b)) -> - R (fold f m i) (fold g m j). - Proof. - intros A B R f g i j m Rempty Rstep. - 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; assumption). - clearbody l; clear Rstep m. - induction l; simpl; auto. - apply Rstep'; auto. - destruct a; simpl; rewrite InA_cons; left; red; auto. - Qed. - - (** From the induction principle on [fold], we can deduce some general - induction principles on maps. *) - - Lemma map_induction : - forall P : t elt -> Type, - (forall m, Empty m -> P m) -> - (forall m m', P m -> forall x e, ~In x m -> Add x e m m' -> P m') -> - forall m, P m. - Proof. - intros. apply (@fold_rec _ (fun s _ => P s) (fun _ _ _ => tt) tt m); eauto. - Qed. - - Lemma map_induction_bis : - forall P : t elt -> Type, - (forall m m', Equal m m' -> P m -> P m') -> - P (empty _) -> - (forall x e m, ~In x m -> P m -> P (add x e m)) -> - forall m, P m. - Proof. - intros. - apply (@fold_rec_bis _ (fun s _ => P s) (fun _ _ _ => tt) tt m); eauto. - Qed. - - (** [fold] can be used to reconstruct the same initial set. *) - - Lemma fold_identity : forall m : t elt, Equal (fold (@add _) m (empty _)) m. - Proof. - intros. - apply fold_rec with (P:=fun m acc => Equal acc m); auto with map. - - intros m' Heq k'. - rewrite empty_o. - case_eq (find k' m'); auto; intros e'; rewrite <- find_mapsto_iff. - intro; elim (Heq k' e'); auto. - - intros k e a m' m'' _ _ Hadd Heq k'. - red in Heq. rewrite Hadd, 2 add_o, Heq; auto. - Qed. - - Section Fold_More. - - (** ** Additional properties of fold *) - - (** When a function [f] is compatible and allows transpositions, we can - compute [fold f] in any order. *) - - Variables (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA)(f:key->elt->A->A). - - (** This is more convenient than a [compat_op eqke ...]. - In fact, every [compat_op], [compat_bool], etc, should - become a [Proper] someday. *) - Hypothesis Comp : Proper (E.eq==>eq==>eqA==>eqA) f. - - Lemma fold_init : - forall m i i', eqA i i' -> eqA (fold f m i) (fold f m i'). - Proof. - intros. apply fold_rel with (R:=eqA); auto. - intros. apply Comp; auto. - Qed. - - Lemma fold_Empty : - forall m i, Empty m -> eqA (fold f m i) i. - Proof. - intros. apply fold_rec_nodep with (P:=fun a => eqA a i). - - reflexivity. - - intros. elim (H k e); auto. - Qed. - - (** As noticed by P. Casteran, asking for the general [SetoidList.transpose] - here is too restrictive. Think for instance of [f] being [M.add] : - in general, [M.add k e (M.add k e' m)] is not equivalent to - [M.add k e' (M.add k e m)]. Fortunately, we will never encounter this - situation during a real [fold], since the keys received by this [fold] - are unique. Hence we can ask the transposition property to hold only - for non-equal keys. - - This idea could be push slightly further, by asking the transposition - property to hold only for (non-equal) keys living in the map given to - [fold]. Please contact us if you need such a version. - - FSets could also benefit from a restricted [transpose], but for this - case the gain is unclear. *) - - Definition transpose_neqkey := - forall k k' e e' a, ~E.eq k k' -> - eqA (f k e (f k' e' a)) (f k' e' (f k e a)). - - Hypothesis Tra : transpose_neqkey. - - Lemma fold_commutes : forall i m k e, ~In k m -> - eqA (fold f m (f k e i)) (f k e (fold f m i)). - Proof. - intros i m k e Hnotin. - apply fold_rel with (R:= fun a b => eqA a (f k e b)); auto. - - reflexivity. - - intros. - transitivity (f k0 e0 (f k e b)). - + apply Comp; auto. - + apply Tra; auto. - contradict Hnotin; rewrite <- Hnotin; exists e0; auto. - Qed. - - #[local] - Hint Resolve NoDupA_eqk_eqke NoDupA_rev elements_3w : map. - - Lemma fold_Equal : forall m1 m2 i, Equal m1 m2 -> - eqA (fold f m1 i) (fold f m2 i). - Proof. - intros. - rewrite 2 fold_spec_right. - 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). - 1:auto with typeclass_instances. - 1: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 crelations. - Qed. - - Lemma fold_Equal2 : forall m1 m2 i j, Equal m1 m2 -> eqA i j -> - eqA (fold f m1 i) (fold f m2 j). - Proof. - intros. - rewrite 2 fold_spec_right. - 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). - 1: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. - rewrite h'. - auto. - - rewrite <- NoDupA_altdef; auto. - - intros (k,e). - rewrite 2 InA_rev, <- 2 elements_mapsto_iff, 2 find_mapsto_iff, H. - auto with crelations. - Qed. - - - Lemma fold_Add : forall m1 m2 k e i, ~In k m1 -> Add k e m1 m2 -> - eqA (fold f m2 i) (f k e (fold f m1 i)). - Proof. - intros. - rewrite 2 fold_spec_right. - 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 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). - 1:auto with typeclass_instances. - 1: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. firstorder. - - intros (a,b). - rewrite InA_cons, 2 InA_rev, <- 2 elements_mapsto_iff, - 2 find_mapsto_iff. - unfold eq_key_elt; simpl. - rewrite H0. - rewrite add_o. - destruct (eq_dec k a) as [EQ|NEQ]; split; auto. - + intros EQ'; inversion EQ'; auto. - + intuition; subst; auto. - elim H. exists b; rewrite EQ; auto with map. - + intuition. - elim NEQ; auto. - Qed. - - Lemma fold_add : forall m k e i, ~In k m -> - eqA (fold f (add k e m) i) (f k e (fold f m i)). - Proof. - intros. apply fold_Add; try red; auto. - Qed. - - End Fold_More. - - (** * Cardinal *) - - Lemma cardinal_fold : forall m : t elt, - cardinal m = fold (fun _ _ => S) m 0. - Proof. - intros; rewrite cardinal_1, fold_1. - symmetry; apply fold_left_S_0; auto. - Qed. - - Lemma cardinal_Empty : forall m : t elt, - Empty m <-> cardinal m = 0. - Proof. - intros. - rewrite cardinal_1, elements_Empty. - destruct (elements m); intuition; discriminate. - Qed. - - Lemma Equal_cardinal : forall m m' : t elt, - Equal m m' -> cardinal m = cardinal m'. - Proof. - intros; do 2 rewrite cardinal_fold. - apply fold_Equal with (eqA:=eq); compute; auto. - Qed. - - Lemma cardinal_1 : forall m : t elt, Empty m -> cardinal m = 0. - Proof. - intros; rewrite <- cardinal_Empty; auto. - Qed. - - Lemma cardinal_2 : - forall m m' x e, ~ In x m -> Add x e m m' -> cardinal m' = S (cardinal m). - Proof. - intros; do 2 rewrite cardinal_fold. - change S with ((fun _ _ => S) x e). - apply fold_Add with (eqA:=eq); compute; auto. - Qed. - - Lemma cardinal_Add_In: - forall m m' x e, In x m -> Add x e m m' -> cardinal m' = cardinal m. - Proof. - assert (forall k e m, MapsTo k e m -> Add k e (remove k m) m) as remove_In_Add. - { intros. unfold Add. - intros. - rewrite F.add_o. - destruct (F.eq_dec k y). - - apply find_1. rewrite <-MapsTo_m; [exact H|assumption|reflexivity|reflexivity]. - - rewrite F.remove_neq_o by assumption. reflexivity. - } - intros. - assert (Equal (remove x m) (remove x m')). - { intros y. rewrite 2!F.remove_o. - destruct (F.eq_dec x y). - - reflexivity. - - unfold Add in H0. rewrite H0. - rewrite F.add_neq_o by assumption. reflexivity. - } - apply Equal_cardinal in H1. - rewrite 2!cardinal_fold. - destruct H as (e' & H). - rewrite fold_Add with (eqA:=eq) (m1:=remove x m) (m2:=m) (k:=x) (e:=e'); - try now (compute; auto). - 2:apply remove_1; reflexivity. - 2:apply remove_In_Add; assumption. - rewrite fold_Add with (eqA:=eq) (m1:=remove x m') (m2:=m') (k:=x) (e:=e); - try now (compute; auto). - - rewrite <- 2!cardinal_fold. congruence. - - apply remove_1. reflexivity. - - apply remove_In_Add. - apply find_2. unfold Add in H0. rewrite H0. - rewrite F.add_eq_o; reflexivity. - Qed. - - Lemma cardinal_inv_1 : forall m : t elt, - cardinal m = 0 -> Empty m. - Proof. - intros; rewrite cardinal_Empty; auto. - Qed. - #[local] - Hint Resolve cardinal_inv_1 : map. - - Lemma cardinal_inv_2 : - forall m n, cardinal m = S n -> { p : key*elt | MapsTo (fst p) (snd p) m }. - Proof. - intros; rewrite M.cardinal_1 in *. - generalize (elements_mapsto_iff m). - destruct (elements m); try discriminate. - exists p; auto. - rewrite H0; destruct p; simpl; auto. - constructor; red; auto. - Qed. - - Lemma cardinal_inv_2b : - forall m, cardinal m <> 0 -> { p : key*elt | MapsTo (fst p) (snd p) m }. - Proof. - intros. - generalize (@cardinal_inv_2 m); destruct cardinal. - - elim H;auto. - - eauto. - Qed. - - (** * Additional notions over maps *) - - Definition Disjoint (m m' : t elt) := - forall k, ~(In k m /\ In k m'). - - Definition Partition (m m1 m2 : t elt) := - Disjoint m1 m2 /\ - (forall k e, MapsTo k e m <-> MapsTo k e m1 \/ MapsTo k e m2). - - (** * Emulation of some functions lacking in the interface *) - - Definition filter (f : key -> elt -> bool)(m : t elt) := - fold (fun k e m => if f k e then add k e m else m) m (empty _). - - Definition for_all (f : key -> elt -> bool)(m : t elt) := - fold (fun k e b => if f k e then b else false) m true. - - Definition exists_ (f : key -> elt -> bool)(m : t elt) := - fold (fun k e b => if f k e then true else b) m false. - - Definition partition (f : key -> elt -> bool)(m : t elt) := - (filter f m, filter (fun k e => negb (f k e)) m). - - (** [update] adds to [m1] all the bindings of [m2]. It can be seen as - an [union] operator which gives priority to its 2nd argument - in case of binding conflit. *) - - Definition update (m1 m2 : t elt) := fold (@add _) m2 m1. - - (** [restrict] keeps from [m1] only the bindings whose key is in [m2]. - It can be seen as an [inter] operator, with priority to its 1st argument - in case of binding conflit. *) - - Definition restrict (m1 m2 : t elt) := filter (fun k _ => mem k m2) m1. - - (** [diff] erases from [m1] all bindings whose key is in [m2]. *) - - Definition diff (m1 m2 : t elt) := filter (fun k _ => negb (mem k m2)) m1. - - Section Specs. - Variable f : key -> elt -> bool. - Hypothesis Hf : Proper (E.eq==>eq==>eq) f. - - Lemma filter_iff : forall m k e, - MapsTo k e (filter f m) <-> MapsTo k e m /\ f k e = true. - Proof. - unfold filter. - set (f':=fun k e m => if f k e then add k e m else m). - intro m. pattern m, (fold f' m (empty _)). apply fold_rec. - - - intros m' Hm' k e. rewrite empty_mapsto_iff. intuition. - elim (Hm' k e); auto. - - - intros k e acc m1 m2 Hke Hn Hadd IH k' e'. - change (Equal m2 (add k e m1)) in Hadd; rewrite Hadd. - unfold f'; simpl. - case_eq (f k e); intros Hfke; simpl; - rewrite !add_mapsto_iff, IH; clear IH; intuition. - + rewrite <- Hfke; apply Hf; auto. - + destruct (eq_dec k k') as [Hk|Hk]; [left|right]; auto. - elim Hn; exists e'; rewrite Hk; auto. - + assert (f k e = f k' e') by (apply Hf; auto). congruence. - Qed. - - Lemma for_all_iff : forall m, - for_all f m = true <-> (forall k e, MapsTo k e m -> f k e = true). - Proof. - unfold for_all. - set (f':=fun k e b => if f k e then b else false). - intro m. pattern m, (fold f' m true). apply fold_rec. - - - intros m' Hm'. split; auto. intros _ k e Hke. elim (Hm' k e); auto. - - - intros k e b m1 m2 _ Hn Hadd IH. clear m. - change (Equal m2 (add k e m1)) in Hadd. - unfold f'; simpl. case_eq (f k e); intros Hfke. - (* f k e = true *) - + rewrite IH. clear IH. split; intros Hmapsto k' e' Hke'. - * rewrite Hadd, add_mapsto_iff in Hke'. - destruct Hke' as [(?,?)|(?,?)]; auto. - rewrite <- Hfke; apply Hf; auto. - * apply Hmapsto. rewrite Hadd, add_mapsto_iff; right; split; auto. - contradict Hn; exists e'; rewrite Hn; auto. - (* f k e = false *) - + split; try discriminate. - intros Hmapsto. rewrite <- Hfke. apply Hmapsto. - rewrite Hadd, add_mapsto_iff; auto. - Qed. - - Lemma exists_iff : forall m, - exists_ f m = true <-> - (exists p, MapsTo (fst p) (snd p) m /\ f (fst p) (snd p) = true). - Proof. - unfold exists_. - set (f':=fun k e b => if f k e then true else b). - intro m. pattern m, (fold f' m false). apply fold_rec. - - - intros m' Hm'. split; try discriminate. - intros ((k,e),(Hke,_)); simpl in *. elim (Hm' k e); auto. - - - intros k e b m1 m2 _ Hn Hadd IH. clear m. - change (Equal m2 (add k e m1)) in Hadd. - unfold f'; simpl. case_eq (f k e); intros Hfke. - (* f k e = true *) - + split; [intros _|auto]. - exists (k,e); simpl; split; auto. - rewrite Hadd, add_mapsto_iff; auto. - (* f k e = false *) - + rewrite IH. clear IH. split; intros ((k',e'),(Hke1,Hke2)); simpl in *. - * exists (k',e'); simpl; split; auto. - rewrite Hadd, add_mapsto_iff; right; split; auto. - contradict Hn. exists e'; rewrite Hn; auto. - * rewrite Hadd, add_mapsto_iff in Hke1. destruct Hke1 as [(?,?)|(?,?)]. - -- assert (f k' e' = f k e) by (apply Hf; auto). congruence. - -- exists (k',e'); auto. - Qed. - - End Specs. - - Lemma Disjoint_alt : forall m m', - Disjoint m m' <-> - (forall k e e', MapsTo k e m -> MapsTo k e' m' -> False). - Proof. - unfold Disjoint; split. - - intros H k v v' H1 H2. - apply H with k; split. - + exists v; trivial. - + exists v'; trivial. - - intros H k ((v,Hv),(v',Hv')). - eapply H; eauto. - Qed. - - Section Partition. - Variable f : key -> elt -> bool. - Hypothesis Hf : Proper (E.eq==>eq==>eq) f. - - Lemma partition_iff_1 : forall m m1 k e, - m1 = fst (partition f m) -> - (MapsTo k e m1 <-> MapsTo k e m /\ f k e = true). - Proof. - unfold partition; simpl; intros. subst m1. - apply filter_iff; auto. - Qed. - - Lemma partition_iff_2 : forall m m2 k e, - m2 = snd (partition f m) -> - (MapsTo k e m2 <-> MapsTo k e m /\ f k e = false). - Proof. - unfold partition; simpl; intros. subst m2. - rewrite filter_iff. - - split; intros (H,H'); split; auto. - + destruct (f k e); simpl in *; auto. - + rewrite H'; auto. - - repeat red; intros. f_equal. apply Hf; auto. - Qed. - - Lemma partition_Partition : forall m m1 m2, - partition f m = (m1,m2) -> Partition m m1 m2. - Proof. - intros. split. - - rewrite Disjoint_alt. intros k e e'. - rewrite (@partition_iff_1 m m1), (@partition_iff_2 m m2) - by (rewrite H; auto). - intros (U,V) (W,Z). rewrite <- (MapsTo_fun U W) in Z; congruence. - - intros k e. - rewrite (@partition_iff_1 m m1), (@partition_iff_2 m m2) - by (rewrite H; auto). - destruct (f k e); intuition. - Qed. - - End Partition. - - Lemma Partition_In : forall m m1 m2 k, - Partition m m1 m2 -> In k m -> {In k m1}+{In k m2}. - Proof. - intros m m1 m2 k Hm Hk. - destruct (In_dec m1 k) as [H|H]; [left|right]; auto. - destruct Hm as (Hm,Hm'). - destruct Hk as (e,He); rewrite Hm' in He; destruct He. - - elim H; exists e; auto. - - exists e; auto. - Defined. - - Lemma Disjoint_sym : forall m1 m2, Disjoint m1 m2 -> Disjoint m2 m1. - Proof. - intros m1 m2 H k (H1,H2). elim (H k); auto. - Qed. - - Lemma Partition_sym : forall m m1 m2, - Partition m m1 m2 -> Partition m m2 m1. - Proof. - intros m m1 m2 (H,H'); split. - - apply Disjoint_sym; auto. - - intros; rewrite H'; intuition. - Qed. - - Lemma Partition_Empty : forall m m1 m2, Partition m m1 m2 -> - (Empty m <-> (Empty m1 /\ Empty m2)). - Proof. - intros m m1 m2 (Hdisj,Heq). split. - - intro He. - split; intros k e Hke; elim (He k e); rewrite Heq; auto. - - intros (He1,He2) k e Hke. rewrite Heq in Hke. destruct Hke. - + elim (He1 k e); auto. - + elim (He2 k e); auto. - Qed. - - Lemma Partition_Add : - forall m m' x e , ~In x m -> Add x e m m' -> - forall m1 m2, Partition m' m1 m2 -> - exists m3, (Add x e m3 m1 /\ Partition m m3 m2 \/ - Add x e m3 m2 /\ Partition m m1 m3). - Proof. - unfold Partition. intros m m' x e Hn Hadd m1 m2 (Hdisj,Hor). - assert (Heq : Equal m (remove x m')). { - change (Equal m' (add x e m)) in Hadd. rewrite Hadd. - intro k. rewrite remove_o, add_o. - destruct eq_dec as [He|Hne]; auto. - rewrite <- He, <- not_find_in_iff; auto. - } - assert (H : MapsTo x e m'). { - change (Equal m' (add x e m)) in Hadd; rewrite Hadd. - apply add_1; auto. - } - rewrite Hor in H; destruct H. - - - (* first case : x in m1 *) - exists (remove x m1); left. split; [|split]. - + (* add *) - change (Equal m1 (add x e (remove x m1))). - intro k. - rewrite add_o, remove_o. - destruct eq_dec as [He|Hne]; auto. - rewrite <- He; apply find_1; auto. - + (* disjoint *) - intros k (H1,H2). elim (Hdisj k). split; auto. - rewrite remove_in_iff in H1; destruct H1; auto. - + (* mapsto *) - intros k' e'. - rewrite Heq, 2 remove_mapsto_iff, Hor. - intuition. - elim (Hdisj x); split; [exists e|exists e']; auto. - apply MapsTo_1 with k'; auto. - - - (* second case : x in m2 *) - exists (remove x m2); right. split; [|split]. - + (* add *) - change (Equal m2 (add x e (remove x m2))). - intro k. - rewrite add_o, remove_o. - destruct eq_dec as [He|Hne]; auto. - rewrite <- He; apply find_1; auto. - + (* disjoint *) - intros k (H1,H2). elim (Hdisj k). split; auto. - rewrite remove_in_iff in H2; destruct H2; auto. - + (* mapsto *) - intros k' e'. - rewrite Heq, 2 remove_mapsto_iff, Hor. - intuition. - elim (Hdisj x); split; [exists e'|exists e]; auto. - apply MapsTo_1 with k'; auto. - Qed. - - Lemma Partition_fold : - forall (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA)(f:key->elt->A->A), - Proper (E.eq==>eq==>eqA==>eqA) f -> - transpose_neqkey eqA f -> - forall m m1 m2 i, - Partition m m1 m2 -> - eqA (fold f m i) (fold f m1 (fold f m2 i)). - Proof. - intros A eqA st f Comp Tra. - induction m as [m Hm|m m' IH k e Hn Hadd] using map_induction. - - - intros m1 m2 i Hp. rewrite (fold_Empty (eqA:=eqA)); auto. - rewrite (Partition_Empty Hp) in Hm. destruct Hm. - rewrite 2 (fold_Empty (eqA:=eqA)); auto. reflexivity. - - - intros m1 m2 i Hp. - destruct (Partition_Add Hn Hadd Hp) as (m3,[(Hadd',Hp')|(Hadd',Hp')]). - + (* fst case: m3 is (k,e)::m1 *) - assert (~In k m3). { - contradict Hn. destruct Hn as (e',He'). - destruct Hp' as (Hp1,Hp2). exists e'. rewrite Hp2; auto. - } - transitivity (f k e (fold f m i)). - * apply fold_Add with (eqA:=eqA); auto. - * symmetry. - transitivity (f k e (fold f m3 (fold f m2 i))). - -- apply fold_Add with (eqA:=eqA); auto. - -- apply Comp; auto. - symmetry; apply IH; auto. - + (* snd case: m3 is (k,e)::m2 *) - assert (~In k m3). { - contradict Hn. destruct Hn as (e',He'). - destruct Hp' as (Hp1,Hp2). exists e'. rewrite Hp2; auto. - } - assert (~In k m1). { - contradict Hn. destruct Hn as (e',He'). - destruct Hp' as (Hp1,Hp2). exists e'. rewrite Hp2; auto. - } - transitivity (f k e (fold f m i)). - * apply fold_Add with (eqA:=eqA); auto. - * transitivity (f k e (fold f m1 (fold f m3 i))). - -- apply Comp; auto using IH. - -- transitivity (fold f m1 (f k e (fold f m3 i))). - ++ symmetry. - apply fold_commutes with (eqA:=eqA); auto. - ++ apply fold_init with (eqA:=eqA); auto. - symmetry. - apply fold_Add with (eqA:=eqA); auto. - Qed. - - Lemma Partition_cardinal : forall m m1 m2, Partition m m1 m2 -> - cardinal m = cardinal m1 + cardinal m2. - Proof. - intros. - rewrite (cardinal_fold m), (cardinal_fold m1). - set (f:=fun (_:key)(_:elt)=>S). - setoid_replace (fold f m 0) with (fold f m1 (fold f m2 0)). - - rewrite <- cardinal_fold. - apply fold_rel with (R:=fun u v => u = v + cardinal m2); simpl; auto. - - apply Partition_fold with (eqA:=eq); repeat red; auto. - Qed. - - Lemma Partition_partition : forall m m1 m2, Partition m m1 m2 -> - let f := fun k (_:elt) => mem k m1 in - Equal m1 (fst (partition f m)) /\ Equal m2 (snd (partition f m)). - Proof. - intros m m1 m2 Hm f. - assert (Hf : Proper (E.eq==>eq==>eq) f). - { intros k k' Hk e e' _; unfold f; rewrite Hk; auto. } - set (m1':= fst (partition f m)). - set (m2':= snd (partition f m)). - split; rewrite Equal_mapsto_iff; intros k e. - - rewrite (@partition_iff_1 f Hf m m1') by auto. - unfold f. - rewrite <- mem_in_iff. - destruct Hm as (Hm,Hm'). - rewrite Hm'. - intuition. - + exists e; auto. - + elim (Hm k); split; auto; exists e; auto. - - rewrite (@partition_iff_2 f Hf m m2') by auto. - unfold f. - rewrite <- not_mem_in_iff. - destruct Hm as (Hm,Hm'). - rewrite Hm'. - intuition. - + elim (Hm k); split; auto; exists e; auto. - + elim H1; exists e; auto. - Qed. - - Lemma update_mapsto_iff : forall m m' k e, - MapsTo k e (update m m') <-> - (MapsTo k e m' \/ (MapsTo k e m /\ ~In k m')). - Proof. - unfold update. - intros m m'. - pattern m', (fold (@add _) m' m). apply fold_rec. - - - intros m0 Hm0 k e. - assert (~In k m0) by (intros (e0,He0); apply (Hm0 k e0); auto). - intuition. - elim (Hm0 k e); auto. - - - intros k e m0 m1 m2 _ Hn Hadd IH k' e'. - change (Equal m2 (add k e m1)) in Hadd. - rewrite Hadd, 2 add_mapsto_iff, IH, add_in_iff. clear IH. intuition. - Qed. - - Lemma update_dec : forall m m' k e, MapsTo k e (update m m') -> - { MapsTo k e m' } + { MapsTo k e m /\ ~In k m'}. - Proof. - intros m m' k e H. rewrite update_mapsto_iff in H. - destruct (In_dec m' k) as [H'|H']; [left|right]; intuition. - elim H'; exists e; auto. - Defined. - - Lemma update_in_iff : forall m m' k, - In k (update m m') <-> In k m \/ In k m'. - Proof. - intros m m' k. split. - - intros (e,H); rewrite update_mapsto_iff in H. - destruct H; [right|left]; exists e; intuition. - - destruct (In_dec m' k) as [H|H]. - + destruct H as (e,H). intros _; exists e. - rewrite update_mapsto_iff; left; auto. - + destruct 1 as [H'|H']; [|elim H; auto]. - destruct H' as (e,H'). exists e. - rewrite update_mapsto_iff; right; auto. - Qed. - - Lemma diff_mapsto_iff : forall m m' k e, - MapsTo k e (diff m m') <-> MapsTo k e m /\ ~In k m'. - Proof. - intros m m' k e. - unfold diff. - rewrite filter_iff. - - intuition. - rewrite mem_1 in *; auto; discriminate. - - intros ? ? Hk _ _ _; rewrite Hk; auto. - Qed. - - Lemma diff_in_iff : forall m m' k, - In k (diff m m') <-> In k m /\ ~In k m'. - Proof. - intros m m' k. split. - - intros (e,H); rewrite diff_mapsto_iff in H. - destruct H; split; auto. exists e; auto. - - intros ((e,H),H'); exists e; rewrite diff_mapsto_iff; auto. - Qed. - - Lemma restrict_mapsto_iff : forall m m' k e, - MapsTo k e (restrict m m') <-> MapsTo k e m /\ In k m'. - Proof. - intros m m' k e. - unfold restrict. - rewrite filter_iff. - - intuition. - - intros ? ? Hk _ _ _; rewrite Hk; auto. - Qed. - - Lemma restrict_in_iff : forall m m' k, - In k (restrict m m') <-> In k m /\ In k m'. - Proof. - intros m m' k. split. - - intros (e,H); rewrite restrict_mapsto_iff in H. - destruct H; split; auto. exists e; auto. - - intros ((e,H),H'); exists e; rewrite restrict_mapsto_iff; auto. - Qed. - - (** specialized versions analyzing only keys (resp. elements) *) - - Definition filter_dom (f : key -> bool) := filter (fun k _ => f k). - Definition filter_range (f : elt -> bool) := filter (fun _ => f). - Definition for_all_dom (f : key -> bool) := for_all (fun k _ => f k). - Definition for_all_range (f : elt -> bool) := for_all (fun _ => f). - Definition exists_dom (f : key -> bool) := exists_ (fun k _ => f k). - Definition exists_range (f : elt -> bool) := exists_ (fun _ => f). - Definition partition_dom (f : key -> bool) := partition (fun k _ => f k). - Definition partition_range (f : elt -> bool) := partition (fun _ => f). - - End Elt. - - Add Parametric Morphism elt : (@cardinal elt) - with signature Equal ==> eq as cardinal_m. - Proof. intros; apply Equal_cardinal; auto. Qed. - - Add Parametric Morphism elt : (@Disjoint elt) - with signature Equal ==> Equal ==> iff as Disjoint_m. - Proof. - intros m1 m1' Hm1 m2 m2' Hm2. unfold Disjoint. split; intros. - - rewrite <- Hm1, <- Hm2; auto. - - rewrite Hm1, Hm2; auto. - Qed. - - Add Parametric Morphism elt : (@Partition elt) - with signature Equal ==> Equal ==> Equal ==> iff as Partition_m. - Proof. - intros m1 m1' Hm1 m2 m2' Hm2 m3 m3' Hm3. unfold Partition. - rewrite <- Hm2, <- Hm3. - split; intros (H,H'); split; auto; intros. - - rewrite <- Hm1, <- Hm2, <- Hm3; auto. - - rewrite Hm1, Hm2, Hm3; auto. - Qed. - - Add Parametric Morphism elt : (@update elt) - with signature Equal ==> Equal ==> Equal as update_m. - Proof. - intros m1 m1' Hm1 m2 m2' Hm2. - setoid_replace (update m1 m2) with (update m1' m2); unfold update. - - apply fold_Equal with (eqA:=Equal); auto. - + intros k k' Hk e e' He m m' Hm; rewrite Hk,He,Hm; red; auto. - + intros k k' e e' i Hneq x. - rewrite !add_o; do 2 destruct eq_dec; auto. elim Hneq; eauto. - - apply fold_init with (eqA:=Equal); auto. - intros k k' Hk e e' He m m' Hm; rewrite Hk,He,Hm; red; auto. - Qed. - - Add Parametric Morphism elt : (@restrict elt) - with signature Equal ==> Equal ==> Equal as restrict_m. - Proof. - intros m1 m1' Hm1 m2 m2' Hm2. - setoid_replace (restrict m1 m2) with (restrict m1' m2); - unfold restrict, filter. - - apply fold_rel with (R:=Equal); try red; auto. - intros k e i i' H Hii' x. - pattern (mem k m2); rewrite Hm2. (* UGLY, see with Matthieu *) - destruct mem; rewrite Hii'; auto. - - apply fold_Equal with (eqA:=Equal); auto. - + intros k k' Hk e e' He m m' Hm; simpl in *. - pattern (mem k m2); rewrite Hk. (* idem *) - destruct mem; rewrite ?Hk,?He,Hm; red; auto. - + intros k k' e e' i Hneq x. - case_eq (mem k m2); case_eq (mem k' m2); intros; auto. - rewrite !add_o; do 2 destruct eq_dec; auto. elim Hneq; eauto. - Qed. - - Add Parametric Morphism elt : (@diff elt) - with signature Equal ==> Equal ==> Equal as diff_m. - Proof. - intros m1 m1' Hm1 m2 m2' Hm2. - setoid_replace (diff m1 m2) with (diff m1' m2); - unfold diff, filter. - - apply fold_rel with (R:=Equal); try red; auto. - intros k e i i' H Hii' x. - pattern (mem k m2); rewrite Hm2. (* idem *) - destruct mem; simpl; rewrite Hii'; auto. - - apply fold_Equal with (eqA:=Equal); auto. - + intros k k' Hk e e' He m m' Hm; simpl in *. - pattern (mem k m2); rewrite Hk. (* idem *) - destruct mem; simpl; rewrite ?Hk,?He,Hm; red; auto. - + intros k k' e e' i Hneq x. - case_eq (mem k m2); case_eq (mem k' m2); intros; simpl; auto. - rewrite !add_o; do 2 destruct eq_dec; auto. elim Hneq; eauto. - Qed. - -End WProperties_fun. - -(** * Same Properties for self-contained weak maps and for full maps *) - -Module WProperties (M:WS) := WProperties_fun M.E M. -Module Properties := WProperties. - -(** * Properties specific to maps with ordered keys *) - -Module OrdProperties (M:S). - Module Import ME := OrderedTypeFacts M.E. - Module Import O:=KeyOrderedType M.E. - Module Import P:=Properties M. - Import F. - Import M. - - Section Elt. - Variable elt:Type. - - Notation eqke := (@eqke elt). - Notation eqk := (@eqk elt). - Notation ltk := (@ltk elt). - Notation cardinal := (@cardinal elt). - Notation Equal := (@Equal elt). - Notation Add := (@Add elt). - - Definition Above x (m:t elt) := forall y, In y m -> E.lt y x. - Definition Below x (m:t elt) := forall y, In y m -> E.lt x y. - - Section Elements. - - 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; auto with typeclass_instances. - Qed. - - Ltac clean_eauto := unfold O.eqke, O.ltk; simpl; intuition; eauto. - - Definition gtb (p p':key*elt) := - match E.compare (fst p) (fst p') with GT _ => true | _ => false end. - Definition leb p := fun p' => negb (gtb p p'). - - Definition elements_lt p m := List.filter (gtb p) (elements m). - Definition elements_ge p m := List.filter (leb p) (elements m). - - Lemma gtb_1 : forall p p', gtb p p' = true <-> ltk p' p. - Proof. - intros (x,e) (y,e'); unfold gtb, O.ltk; simpl. - destruct (E.compare x y); intuition; try discriminate; ME.order. - Qed. - - Lemma leb_1 : forall p p', leb p p' = true <-> ~ltk p' p. - Proof. - intros (x,e) (y,e'); unfold leb, gtb, O.ltk; simpl. - destruct (E.compare x y); intuition; try discriminate; ME.order. - Qed. - - Lemma gtb_compat : forall p, Proper (eqke==>eq) (gtb p). - Proof. - red; intros (x,e) (a,e') (b,e'') H; red in H; simpl in *; destruct H. - generalize (gtb_1 (x,e) (a,e'))(gtb_1 (x,e) (b,e'')); - destruct (gtb (x,e) (a,e')); destruct (gtb (x,e) (b,e'')); auto. - - unfold O.ltk in *; simpl in *; intros. - symmetry; rewrite H2. - apply ME.eq_lt with a; auto with ordered_type. - rewrite <- H1; auto. - - unfold O.ltk in *; simpl in *; intros. - rewrite H1. - apply ME.eq_lt with b; auto. - rewrite <- H2; auto. - Qed. - - Lemma leb_compat : forall p, Proper (eqke==>eq) (leb p). - Proof. - red; intros x a b H. - unfold leb; f_equal; apply gtb_compat; auto. - Qed. - - #[local] - Hint Resolve gtb_compat leb_compat elements_3 : map. - - Lemma elements_split : forall p m, - 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). - 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)). - - unfold gtb, O.ltk in *; simpl in *. - destruct (E.compare k t1); intuition; try discriminate; ME.order. - - unfold O.ltk in *; simpl in *; ME.order. - Qed. - - Lemma elements_Add : forall m m' x e, ~In x m -> Add x e m m' -> - eqlistA eqke (elements m') - (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 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). 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 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. - assert (~E.eq x t0). - ++ contradict H. - exists e0; apply MapsTo_1 with t0; auto with ordered_type. - ++ ME.order. - -- apply (@filter_sort _ eqke). 1-3: auto with typeclass_instances. auto with map. - + intros. - 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 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 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. - + fold (~E.lt t0 x); auto with ordered_type. - Qed. - - Lemma elements_Add_Above : forall m m' x e, - Above x m -> Add x e m m' -> - eqlistA eqke (elements m') (elements m ++ (x,e)::nil). - Proof. - intros. - 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. - rewrite <- elements_mapsto_iff in H1. - unfold O.eqke, O.ltk in *; simpl in *; destruct H3. - apply ME.lt_eq with x; auto with ordered_type. - apply H; firstorder. - * inversion H3. - - 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. - unfold O.eqke; simpl. intuition auto with relations. - destruct (E.eq_dec x t0) as [Heq|Hneq]; auto. - exfalso. - assert (In t0 m). - + exists e0; auto. - + generalize (H t0 H1). - ME.order. - Qed. - - Lemma elements_Add_Below : forall m m' x e, - Below x m -> Add x e m m' -> - eqlistA eqke (elements m') ((x,e)::elements m). - Proof. - intros. - apply sort_equivlistA_eqlistA. - - auto with map. - - change (sort ltk (((x,e)::nil) ++ elements m)). - apply (@SortA_app _ eqke). - + auto with typeclass_instances. - + auto. - + auto with map. - + intros. - inversion_clear H1. - * destruct y; destruct x0. - rewrite <- elements_mapsto_iff in H2. - unfold O.eqke, O.ltk in *; simpl in *; destruct H3. - apply ME.eq_lt with x; auto. - apply H; firstorder. - * inversion H3. - - red; intros a; destruct a. - rewrite InA_cons, <- 2 elements_mapsto_iff, - find_mapsto_iff, (H0 t0), <- find_mapsto_iff, - add_mapsto_iff. - unfold O.eqke; simpl. intuition auto with relations. - destruct (E.eq_dec x t0) as [Heq|Hneq]; auto. - exfalso. - assert (In t0 m) by - (exists e0; auto). - generalize (H t0 H1). - ME.order. - Qed. - - Lemma elements_Equal_eqlistA : forall (m m': t elt), - Equal m m' -> eqlistA eqke (elements m) (elements m'). - Proof. - intros. - 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. - Qed. - - End Elements. - - Section Min_Max_Elt. - - (** We emulate two [max_elt] and [min_elt] functions. *) - - Fixpoint max_elt_aux (l:list (key*elt)) := match l with - | nil => None - | (x,e)::nil => Some (x,e) - | (x,e)::l => max_elt_aux l - end. - Definition max_elt m := max_elt_aux (elements m). - - Lemma max_elt_Above : - forall m x e, max_elt m = Some (x,e) -> Above x (remove x m). - Proof. - red; intros. - rewrite remove_in_iff in H0. - destruct H0. - rewrite elements_in_iff in H1. - destruct H1. - unfold max_elt in *. - generalize (elements_3 m). - revert x e H y x0 H0 H1. - induction (elements m). - - simpl; intros; try discriminate. - - intros. - destruct a; destruct l; simpl in *. - + injection H as [= -> ->]. - inversion_clear H1. - * red in H; simpl in *; intuition. - elim H0; eauto with ordered_type. - * inversion H. - + change (max_elt_aux (p::l) = Some (x,e)) in H. - generalize (IHl x e H); clear IHl; intros IHl. - inversion_clear H1; [ | inversion_clear H2; eauto ]. - red in H3; simpl in H3; destruct H3. - destruct p as (p1,p2). - destruct (E.eq_dec p1 x) as [Heq|Hneq]. - * apply ME.lt_eq with p1; auto. - inversion_clear H2. - inversion_clear H5. - red in H2; simpl in H2; ME.order. - * apply E.lt_trans with p1; auto. - -- inversion_clear H2. - inversion_clear H5. - red in H2; simpl in H2; ME.order. - -- eapply IHl; eauto with ordered_type. - ++ econstructor; eauto. - red; eauto with ordered_type. - ++ inversion H2; auto. - Qed. - - Lemma max_elt_MapsTo : - forall m x e, max_elt m = Some (x,e) -> MapsTo x e m. - Proof. - intros. - unfold max_elt in *. - rewrite elements_mapsto_iff. - induction (elements m). - - simpl; try discriminate. - - destruct a; destruct l; simpl in *. - + injection H; intros; subst; constructor; red; auto with ordered_type. - + constructor 2; auto. - Qed. - - Lemma max_elt_Empty : - forall m, max_elt m = None -> Empty m. - Proof. - intros. - unfold max_elt in *. - rewrite elements_Empty. - induction (elements m); auto. - destruct a; destruct l; simpl in *; try discriminate. - assert (H':=IHl H); discriminate. - Qed. - - Definition min_elt m : option (key*elt) := match elements m with - | nil => None - | (x,e)::_ => Some (x,e) - end. - - Lemma min_elt_Below : - forall m x e, min_elt m = Some (x,e) -> Below x (remove x m). - Proof. - unfold min_elt, Below; intros. - rewrite remove_in_iff in H0; destruct H0. - rewrite elements_in_iff in H1. - destruct H1. - generalize (elements_3 m). - destruct (elements m). - - try discriminate. - - destruct p; injection H as [= -> ->]; intros H4. - 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 by auto with typeclass_instances. - apply (H3 (y,x0)); auto. - Qed. - - Lemma min_elt_MapsTo : - forall m x e, min_elt m = Some (x,e) -> MapsTo x e m. - Proof. - intros. - unfold min_elt in *. - rewrite elements_mapsto_iff. - destruct (elements m). - - simpl; try discriminate. - - destruct p; simpl in *. - injection H; intros; subst; constructor; red; auto with ordered_type. - Qed. - - Lemma min_elt_Empty : - forall m, min_elt m = None -> Empty m. - Proof. - intros. - unfold min_elt in *. - rewrite elements_Empty. - destruct (elements m); auto. - destruct p; simpl in *; discriminate. - Qed. - - End Min_Max_Elt. - - Section Induction_Principles. - - Lemma map_induction_max : - forall P : t elt -> Type, - (forall m, Empty m -> P m) -> - (forall m m', P m -> forall x e, Above x m -> Add x e m m' -> P m') -> - forall m, P m. - Proof. - intros; remember (cardinal m) as n; revert m Heqn; induction n; intros. - - apply X; apply cardinal_inv_1; auto. - - - case_eq (max_elt m); intros. - + destruct p. - assert (Add k e (remove k m) m). - * red; intros. - rewrite add_o; rewrite remove_o; destruct (eq_dec k y); eauto. - apply find_1; apply MapsTo_1 with k; auto. - apply max_elt_MapsTo; auto. - * apply X0 with (remove k m) k e; auto with map. - -- apply IHn. - assert (S n = S (cardinal (remove k m))). - ++ rewrite Heqn. - eapply cardinal_2; eauto with map ordered_type. - ++ inversion H1; auto. - -- eapply max_elt_Above; eauto. - - + apply X; apply max_elt_Empty; auto. - Qed. - - Lemma map_induction_min : - forall P : t elt -> Type, - (forall m, Empty m -> P m) -> - (forall m m', P m -> forall x e, Below x m -> Add x e m m' -> P m') -> - forall m, P m. - Proof. - intros; remember (cardinal m) as n; revert m Heqn; induction n; intros. - - apply X; apply cardinal_inv_1; auto. - - - case_eq (min_elt m); intros. - + destruct p. - assert (Add k e (remove k m) m). - * red; intros. - rewrite add_o; rewrite remove_o; destruct (eq_dec k y); eauto. - apply find_1; apply MapsTo_1 with k; auto. - apply min_elt_MapsTo; auto. - * apply X0 with (remove k m) k e; auto. - -- apply IHn. - assert (S n = S (cardinal (remove k m))). - ++ rewrite Heqn. - eapply cardinal_2; eauto with map ordered_type. - ++ inversion H1; auto. - -- eapply min_elt_Below; eauto. - - + apply X; apply min_elt_Empty; auto. - Qed. - - End Induction_Principles. - - Section Fold_properties. - - (** The following lemma has already been proved on Weak Maps, - but with one additional hypothesis (some [transpose] fact). *) - - Lemma fold_Equal : forall m1 m2 (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA) - (f:key->elt->A->A)(i:A), - Proper (E.eq==>eq==>eqA==>eqA) f -> - Equal m1 m2 -> - eqA (fold f m1 i) (fold f m2 i). - Proof. - intros m1 m2 A eqA st f i Hf Heq. - rewrite 2 fold_spec_right. - apply fold_right_eqlistA with (eqA:=eqke) (eqB:=eqA); auto. - - intros (k,e) (k',e') (Hk,He) a a' Ha; simpl in *; apply Hf; auto. - - apply eqlistA_rev. apply elements_Equal_eqlistA. auto. - Qed. - - Lemma fold_Add_Above : forall m1 m2 x e (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA) - (f:key->elt->A->A)(i:A) (P:Proper (E.eq==>eq==>eqA==>eqA) f), - Above x m1 -> Add x e m1 m2 -> - eqA (fold f m2 i) (f x e (fold f m1 i)). - Proof. - intros. rewrite 2 fold_spec_right. set (f':=uncurry f). - transitivity (fold_right f' i (rev (elements m1 ++ (x,e)::nil))). - - apply fold_right_eqlistA with (eqA:=eqke) (eqB:=eqA); auto. - + intros (k1,e1) (k2,e2) (Hk,He) a1 a2 Ha; unfold f'; simpl in *. apply P; auto. - + apply eqlistA_rev. - apply elements_Add_Above; auto. - - rewrite distr_rev; simpl. - reflexivity. - Qed. - - Lemma fold_Add_Below : forall m1 m2 x e (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA) - (f:key->elt->A->A)(i:A) (P:Proper (E.eq==>eq==>eqA==>eqA) f), - Below x m1 -> Add x e m1 m2 -> - eqA (fold f m2 i) (fold f m1 (f x e i)). - Proof. - intros. rewrite 2 fold_spec_right. set (f':=uncurry f). - transitivity (fold_right f' i (rev (((x,e)::nil)++elements m1))). - - apply fold_right_eqlistA with (eqA:=eqke) (eqB:=eqA); auto. - + intros (k1,e1) (k2,e2) (Hk,He) a1 a2 Ha; unfold f'; simpl in *; apply P; auto. - + apply eqlistA_rev. - simpl; apply elements_Add_Below; auto. - - rewrite distr_rev; simpl. - rewrite fold_right_app. - reflexivity. - Qed. - - End Fold_properties. - - End Elt. - -End OrdProperties. diff --git a/stdlib/theories/FSets/FMapFullAVL.v b/stdlib/theories/FSets/FMapFullAVL.v deleted file mode 100644 index cdb098c2ea2c..000000000000 --- a/stdlib/theories/FSets/FMapFullAVL.v +++ /dev/null @@ -1,852 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* Prop := - | RBLeaf : avl (Leaf _) - | RBNode : forall x e l r h, - avl l -> - avl r -> - -(2) <= height l - height r <= 2 -> - h = max (height l) (height r) + 1 -> - avl (Node l x e r h). - - -(** * Automation and dedicated tactics about [avl]. *) - -#[local] -Hint Constructors avl : core. - -Lemma height_non_negative : forall (s : t elt), avl s -> - height s >= 0. -Proof. - induction s; simpl; intros. - - now apply Z.le_ge. - - inv avl; intuition; omega_max. -Qed. - -Ltac avl_nn_hyp H := - let nz := fresh "nz" in assert (nz := height_non_negative H). - -Ltac avl_nn h := - let t := type of h in - match type of t with - | Prop => avl_nn_hyp h - | _ => match goal with H : avl h |- _ => avl_nn_hyp H end - end. - -(* Repeat the previous tactic. - Drawback: need to clear the [avl _] hyps ... Thank you Ltac *) - -Ltac avl_nns := - match goal with - | H:avl _ |- _ => avl_nn_hyp H; clear H; avl_nns - | _ => idtac - end. - - -(** * Basic results about [avl], [height] *) - -Lemma avl_node : forall x e l r, avl l -> avl r -> - -(2) <= height l - height r <= 2 -> - avl (Node l x e r (max (height l) (height r) + 1)). -Proof. - intros; auto. -Qed. -#[local] -Hint Resolve avl_node : core. - -(** Results about [height] *) - -Lemma height_0 : forall l, avl l -> height l = 0 -> - l = Leaf _. -Proof. - destruct 1; intuition; simpl in *. - avl_nns; simpl in *; exfalso; omega_max. -Qed. - - -(** * Empty map *) - -Lemma empty_avl : avl (empty elt). -Proof. - unfold empty; auto. -Qed. - - -(** * Helper functions *) - -Lemma create_avl : - forall l x e r, avl l -> avl r -> -(2) <= height l - height r <= 2 -> - avl (create l x e r). -Proof. - unfold create; auto. -Qed. - -Lemma create_height : - forall l x e r, avl l -> avl r -> -(2) <= height l - height r <= 2 -> - height (create l x e r) = max (height l) (height r) + 1. -Proof. - unfold create; intros; auto. -Qed. - -Lemma bal_avl : forall l x e r, avl l -> avl r -> - -(3) <= height l - height r <= 3 -> avl (bal l x e r). -Proof. - intros l x e r; induction elt, l, x, e, r, (bal l x e r) using bal_ind; intros; clearf; - inv avl; simpl in *; - match goal with |- avl (assert_false _ _ _ _) => avl_nns - | _ => repeat apply create_avl; simpl in *; auto - end; omega_max. -Qed. - -Lemma bal_height_1 : forall l x e r, avl l -> avl r -> - -(3) <= height l - height r <= 3 -> - 0 <= height (bal l x e r) - max (height l) (height r) <= 1. -Proof. - intros l x e r; induction elt, l, x, e, r, (bal l x e r) using bal_ind; intros; clearf; - inv avl; avl_nns; simpl in *; omega_max. -Qed. - -Lemma bal_height_2 : - forall l x e r, avl l -> avl r -> -(2) <= height l - height r <= 2 -> - height (bal l x e r) == max (height l) (height r) +1. -Proof. - intros l x e r; induction elt, l, x, e, r, (bal l x e r) using bal_ind; intros; clearf; - inv avl; avl_nns; simpl in *; omega_max. -Qed. - -Ltac omega_bal := match goal with - | H:avl ?l, H':avl ?r |- context [ bal ?l ?x ?e ?r ] => - generalize (bal_height_1 x e H H') (bal_height_2 x e H H'); - omega_max - end. - -(** * Insertion *) - -Lemma add_avl_1 : forall m x e, avl m -> - avl (add x e m) /\ 0 <= height (add x e m) - height m <= 1. -Proof. - intros m x e; induction elt, x, e, m, (add x e m) using add_ind; clearf; intros; inv avl; simpl in *. - - intuition; try constructor; simpl; auto; try omega_max. - - (* LT *) - destruct IHt; auto. - split. - + apply bal_avl; auto; omega_max. - + omega_bal. - - (* EQ *) - intuition; omega_max. - - (* GT *) - destruct IHt; auto. - split. - + apply bal_avl; auto; omega_max. - + omega_bal. -Qed. - -Lemma add_avl : forall m x e, avl m -> avl (add x e m). -Proof. - intros; generalize (add_avl_1 x e H); intuition. -Qed. -#[local] -Hint Resolve add_avl : core. - -(** * Extraction of minimum binding *) - -Lemma remove_min_avl_1 : forall l x e r h, avl (Node l x e r h) -> - avl (remove_min l x e r)#1 /\ - 0 <= height (Node l x e r h) - height (remove_min l x e r)#1 <= 1. -Proof. - intros l x e r; induction elt, l, x, e, r, (remove_min l x e r) using remove_min_ind; clearf; simpl in *; intros. - - inv avl; simpl in *; split; auto. - avl_nns; omega_max. - - inversion_clear H. - rewrite H0 in IHp;simpl in IHp;destruct (IHp _x); auto. - split; simpl in *. - + apply bal_avl; auto; omega_max. - + omega_bal. -Qed. - -Lemma remove_min_avl : forall l x e r h, avl (Node l x e r h) -> - avl (remove_min l x e r)#1. -Proof. - intros; generalize (remove_min_avl_1 H); intuition. -Qed. - -(** * Merging two trees *) - -Lemma merge_avl_1 : forall m1 m2, avl m1 -> avl m2 -> - -(2) <= height m1 - height m2 <= 2 -> - avl (merge m1 m2) /\ - 0<= height (merge m1 m2) - max (height m1) (height m2) <=1. -Proof. - intros m1 m2; induction elt, m1, m2, (merge m1 m2) using merge_ind; clearf; intros; - try factornode _x _x0 _x1 _x2 _x3 as m1. - - simpl; split; auto; avl_nns; omega_max. - - simpl; split; auto; avl_nns; omega_max. - - generalize (remove_min_avl_1 H0). - rewrite H1; destruct 1. - split. - + apply bal_avl; auto. - omega_max. - + omega_bal. -Qed. - -Lemma merge_avl : forall m1 m2, avl m1 -> avl m2 -> - -(2) <= height m1 - height m2 <= 2 -> avl (merge m1 m2). -Proof. - intros; generalize (merge_avl_1 H H0 H1); intuition. -Qed. - - -(** * Deletion *) - -Lemma remove_avl_1 : forall m x, avl m -> - avl (remove x m) /\ 0 <= height m - height (remove x m) <= 1. -Proof. - intros m x; induction elt, x, m, (remove x m) using remove_ind; clearf; intros. - - split; auto; omega_max. - - (* LT *) - inv avl. - destruct (IHt H0). - split. - + apply bal_avl; auto. - omega_max. - + omega_bal. - - (* EQ *) - inv avl. - generalize (merge_avl_1 H0 H1 H2). - intuition omega_max. - - (* GT *) - inv avl. - destruct (IHt H1). - split. - + apply bal_avl; auto. - omega_max. - + omega_bal. -Qed. - -Lemma remove_avl : forall m x, avl m -> avl (remove x m). -Proof. - intros; generalize (remove_avl_1 x H); intuition. -Qed. -#[local] -Hint Resolve remove_avl : core. - - -(** * Join *) - -Lemma join_avl_1 : forall l x d r, avl l -> avl r -> - avl (join l x d r) /\ - 0<= height (join l x d r) - max (height l) (height r) <= 1. -Proof. - join_tac. - - - split; simpl; auto. - destruct (add_avl_1 x d H0). - avl_nns; omega_max. - - set (l:=Node ll lx ld lr lh) in *. - split; auto. - destruct (add_avl_1 x d H). - simpl (height (Leaf elt)). - avl_nns; omega_max. - - - inversion_clear H. - assert (height (Node rl rx rd rr rh) = rh); auto. - set (r := Node rl rx rd rr rh) in *; clearbody r. - destruct (Hlr x d r H2 H0); clear Hrl Hlr. - set (j := join lr x d r) in *; clearbody j. - simpl. - assert (-(3) <= height ll - height j <= 3) by omega_max. - split. - + apply bal_avl; auto. - + omega_bal. - - - inversion_clear H0. - assert (height (Node ll lx ld lr lh) = lh); auto. - set (l := Node ll lx ld lr lh) in *; clearbody l. - destruct (Hrl H H1); clear Hrl Hlr. - set (j := join l x d rl) in *; clearbody j. - simpl. - assert (-(3) <= height j - height rr <= 3) by omega_max. - split. - + apply bal_avl; auto. - + omega_bal. - - - clear Hrl Hlr. - assert (height (Node ll lx ld lr lh) = lh); auto. - assert (height (Node rl rx rd rr rh) = rh); auto. - set (l := Node ll lx ld lr lh) in *; clearbody l. - set (r := Node rl rx rd rr rh) in *; clearbody r. - assert (-(2) <= height l - height r <= 2) by omega_max. - split. - + apply create_avl; auto. - + rewrite create_height; auto; omega_max. -Qed. - -Lemma join_avl : forall l x d r, avl l -> avl r -> avl (join l x d r). -Proof. - intros; destruct (join_avl_1 x d H H0); auto. -Qed. -#[local] -Hint Resolve join_avl : core. - -(** concat *) - -Lemma concat_avl : forall m1 m2, avl m1 -> avl m2 -> avl (concat m1 m2). -Proof. - intros m1 m2; induction elt, m1, m2, (concat m1 m2) using concat_ind; clearf; auto. - intros; apply join_avl; auto. - generalize (remove_min_avl H0); rewrite H1; simpl; auto. -Qed. -#[local] -Hint Resolve concat_avl : core. - -(** split *) - -Lemma split_avl : forall m x, avl m -> - avl (split x m)#l /\ avl (split x m)#r. -Proof. - intros m x; induction elt, x, m, (split x m) using split_ind; clearf; simpl; auto. - - rewrite H1 in IHt;simpl in IHt;inversion_clear 1; intuition. - - simpl; inversion_clear 1; auto. - - rewrite H1 in IHt;simpl in IHt;inversion_clear 1; intuition. -Qed. - -End Elt. -#[global] -Hint Constructors avl : core. - -Section Map. -Variable elt elt' : Type. -Variable f : elt -> elt'. - -Lemma map_height : forall m, height (map f m) = height m. -Proof. -destruct m; simpl; auto. -Qed. - -Lemma map_avl : forall m, avl m -> avl (map f m). -Proof. -induction m; simpl; auto. -inversion_clear 1; constructor; auto; do 2 rewrite map_height; auto. -Qed. - -End Map. - -Section Mapi. -Variable elt elt' : Type. -Variable f : key -> elt -> elt'. - -Lemma mapi_height : forall m, height (mapi f m) = height m. -Proof. -destruct m; simpl; auto. -Qed. - -Lemma mapi_avl : forall m, avl m -> avl (mapi f m). -Proof. -induction m; simpl; auto. -inversion_clear 1; constructor; auto; do 2 rewrite mapi_height; auto. -Qed. - -End Mapi. - -Section Map_option. -Variable elt elt' : Type. -Variable f : key -> elt -> option elt'. - -Lemma map_option_avl : forall m, avl m -> avl (map_option f m). -Proof. -induction m; simpl; auto; intros. -inv avl; destruct (f k e); auto using join_avl, concat_avl. -Qed. - -End Map_option. - -Section Map2_opt. -Variable elt elt' elt'' : Type. -Variable f : key -> elt -> option elt' -> option elt''. -Variable mapl : t elt -> t elt''. -Variable mapr : t elt' -> t elt''. -Hypothesis mapl_avl : forall m, avl m -> avl (mapl m). -Hypothesis mapr_avl : forall m', avl m' -> avl (mapr m'). - -Notation map2_opt := (map2_opt f mapl mapr). - -Lemma map2_opt_avl : forall m1 m2, avl m1 -> avl m2 -> - avl (map2_opt m1 m2). -Proof. -intros m1 m2; induction elt, elt', elt'', f, mapl, mapr, m1, m2, (map2_opt m1 m2) using map2_opt_ind; clearf; auto; -factornode _x0 _x1 _x2 _x3 _x4 as r2; intros; -destruct (split_avl x1 H0); rewrite H1 in *; simpl in *; inv avl; -auto using join_avl, concat_avl. -Qed. - -End Map2_opt. - -Section Map2. -Variable elt elt' elt'' : Type. -Variable f : option elt -> option elt' -> option elt''. - -Lemma map2_avl : forall m1 m2, avl m1 -> avl m2 -> avl (map2 f m1 m2). -Proof. -unfold map2; auto using map2_opt_avl, map_option_avl. -Qed. - -End Map2. -End AvlProofs. - -(** * Encapsulation - - We can implement [S] with balanced binary search trees. - When compared to [FMapAVL], we maintain here two invariants - (bst and avl) instead of only bst, which is enough for fulfilling - the FMap interface. -*) - -Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. - - Module E := X. - Module Import AvlProofs := AvlProofs I X. - Import Raw. - Import Raw.Proofs. - - #[universes(template)] - Record bbst (elt:Type) := - Bbst {this :> tree elt; is_bst : bst this; is_avl: avl this}. - - Definition t := bbst. - Definition key := E.t. - - Section Elt. - Variable elt elt' elt'': Type. - - Implicit Types m : t elt. - Implicit Types x y : key. - Implicit Types e : elt. - - Definition empty : t elt := Bbst (empty_bst elt) (empty_avl elt). - Definition is_empty m : bool := is_empty (this m). - Definition add x e m : t elt := - Bbst (add_bst x e (is_bst m)) (add_avl x e (is_avl m)). - Definition remove x m : t elt := - Bbst (remove_bst x (is_bst m)) (remove_avl x (is_avl m)). - Definition mem x m : bool := mem x (this m). - Definition find x m : option elt := find x (this m). - Definition map f m : t elt' := - Bbst (map_bst f (is_bst m)) (map_avl f (is_avl m)). - Definition mapi (f:key->elt->elt') m : t elt' := - Bbst (mapi_bst f (is_bst m)) (mapi_avl f (is_avl m)). - Definition map2 f m (m':t elt') : t elt'' := - Bbst (map2_bst f (is_bst m) (is_bst m')) (map2_avl f (is_avl m) (is_avl m')). - Definition elements m : list (key*elt) := elements (this m). - Definition cardinal m := cardinal (this m). - Definition fold (A:Type) (f:key->elt->A->A) m i := fold (A:=A) f (this m) i. - Definition equal cmp m m' : bool := equal cmp (this m) (this m'). - - Definition MapsTo x e m : Prop := MapsTo x e (this m). - Definition In x m : Prop := In0 x (this m). - Definition Empty m : Prop := Empty (this m). - - Definition eq_key : (key*elt) -> (key*elt) -> Prop := @PX.eqk elt. - Definition eq_key_elt : (key*elt) -> (key*elt) -> Prop := @PX.eqke elt. - Definition lt_key : (key*elt) -> (key*elt) -> Prop := @PX.ltk elt. - - Lemma MapsTo_1 : forall m x y e, E.eq x y -> MapsTo x e m -> MapsTo y e m. - Proof. intros m; exact (@MapsTo_1 _ (this m)). Qed. - - Lemma mem_1 : forall m x, In x m -> mem x m = true. - Proof. - unfold In, mem; intros m x; rewrite In_alt; simpl; apply mem_1; auto. - apply (is_bst m). - Qed. - - Lemma mem_2 : forall m x, mem x m = true -> In x m. - Proof. - unfold In, mem; intros m x; rewrite In_alt; simpl; apply mem_2; auto. - Qed. - - Lemma empty_1 : Empty empty. - Proof. exact (@empty_1 elt). Qed. - - Lemma is_empty_1 : forall m, Empty m -> is_empty m = true. - Proof. intros m; exact (@is_empty_1 _ (this m)). Qed. - Lemma is_empty_2 : forall m, is_empty m = true -> Empty m. - Proof. intros m; exact (@is_empty_2 _ (this m)). Qed. - - Lemma add_1 : forall m x y e, E.eq x y -> MapsTo y e (add x e m). - Proof. intros m x y e; exact (@add_1 elt _ x y e). Qed. - Lemma add_2 : forall m x y e e', ~ E.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m). - Proof. intros m x y e e'; exact (@add_2 elt _ x y e e'). Qed. - Lemma add_3 : forall m x y e e', ~ E.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m. - Proof. intros m x y e e'; exact (@add_3 elt _ x y e e'). Qed. - - Lemma remove_1 : forall m x y, E.eq x y -> ~ In y (remove x m). - Proof. - unfold In, remove; intros m x y; rewrite In_alt; simpl; apply remove_1; auto. - apply (is_bst m). - Qed. - Lemma remove_2 : forall m x y e, ~ E.eq x y -> MapsTo y e m -> MapsTo y e (remove x m). - Proof. intros m x y e; exact (@remove_2 elt _ x y e (is_bst m)). Qed. - Lemma remove_3 : forall m x y e, MapsTo y e (remove x m) -> MapsTo y e m. - Proof. intros m x y e; exact (@remove_3 elt _ x y e (is_bst m)). Qed. - - - Lemma find_1 : forall m x e, MapsTo x e m -> find x m = Some e. - Proof. intros m x e; exact (@find_1 elt _ x e (is_bst m)). Qed. - Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m. - Proof. intros m; exact (@find_2 elt (this m)). Qed. - - Lemma fold_1 : forall m (A : Type) (i : A) (f : key -> elt -> A -> A), - fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i. - Proof. intros m; exact (@fold_1 elt (this m) (is_bst m)). Qed. - - Lemma elements_1 : forall m x e, - MapsTo x e m -> InA eq_key_elt (x,e) (elements m). - Proof. - intros; unfold elements, MapsTo, eq_key_elt; rewrite elements_mapsto; auto. - Qed. - - Lemma elements_2 : forall m x e, - InA eq_key_elt (x,e) (elements m) -> MapsTo x e m. - Proof. - intros; unfold elements, MapsTo, eq_key_elt; rewrite <- elements_mapsto; auto. - Qed. - - Lemma elements_3 : forall m, sort lt_key (elements m). - Proof. intros m; exact (@elements_sort elt (this m) (is_bst m)). Qed. - - Lemma elements_3w : forall m, NoDupA eq_key (elements m). - Proof. intros m; exact (@elements_nodup elt (this m) (is_bst m)). Qed. - - Lemma cardinal_1 : forall m, cardinal m = length (elements m). - Proof. intro m; exact (@elements_cardinal elt (this m)). Qed. - - Definition Equal m m' := forall y, find y m = find y m'. - Definition Equiv (eq_elt:elt->elt->Prop) m m' := - (forall k, In k m <-> In k m') /\ - (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e'). - Definition Equivb cmp := Equiv (Cmp cmp). - - Lemma Equivb_Equivb : forall cmp m m', - Equivb cmp m m' <-> Raw.Proofs.Equivb cmp m m'. - Proof. - intros; unfold Equivb, Equiv, Raw.Proofs.Equivb, In; intuition. - - generalize (H0 k); do 2 rewrite In_alt; intuition. - - generalize (H0 k); do 2 rewrite In_alt; intuition. - - generalize (H0 k); do 2 rewrite <- In_alt; intuition. - - generalize (H0 k); do 2 rewrite <- In_alt; intuition. - Qed. - - Lemma equal_1 : forall m m' cmp, - Equivb cmp m m' -> equal cmp m m' = true. - Proof. - unfold equal; intros (m,b,a) (m',b',a') cmp; rewrite Equivb_Equivb; - intros; simpl in *; rewrite equal_Equivb; auto. - Qed. - - Lemma equal_2 : forall m m' cmp, - equal cmp m m' = true -> Equivb cmp m m'. - Proof. - unfold equal; intros (m,b,a) (m',b',a') cmp; rewrite Equivb_Equivb; - intros; simpl in *; rewrite <-equal_Equivb; auto. - Qed. - - End Elt. - - Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'), - MapsTo x e m -> MapsTo x (f e) (map f m). - Proof. intros elt elt' m x e f; exact (@map_1 elt elt' f (this m) x e). Qed. - - Lemma map_2 : forall (elt elt':Type)(m:t elt)(x:key)(f:elt->elt'), In x (map f m) -> In x m. - Proof. - intros elt elt' m x f; do 2 unfold In in *; do 2 rewrite In_alt; simpl. - apply map_2; auto. - Qed. - - Lemma mapi_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt) - (f:key->elt->elt'), MapsTo x e m -> - exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m). - Proof. intros elt elt' m x e f; exact (@mapi_1 elt elt' f (this m) x e). Qed. - Lemma mapi_2 : forall (elt elt':Type)(m: t elt)(x:key) - (f:key->elt->elt'), In x (mapi f m) -> In x m. - Proof. - intros elt elt' m x f; unfold In in *; do 2 rewrite In_alt; simpl; apply mapi_2; auto. - Qed. - - Lemma map2_1 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') - (x:key)(f:option elt->option elt'->option elt''), - In x m \/ In x m' -> - find x (map2 f m m') = f (find x m) (find x m'). - Proof. - unfold find, map2, In; intros elt elt' elt'' m m' x f. - do 2 rewrite In_alt; intros; simpl; apply map2_1; auto. - - apply (is_bst m). - - apply (is_bst m'). - Qed. - - Lemma map2_2 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') - (x:key)(f:option elt->option elt'->option elt''), - In x (map2 f m m') -> In x m \/ In x m'. - Proof. - unfold In, map2; intros elt elt' elt'' m m' x f. - do 3 rewrite In_alt; intros; simpl in *; eapply map2_2; eauto. - - apply (is_bst m). - - apply (is_bst m'). - Qed. - -End IntMake. - - -Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: - Sord with Module Data := D - with Module MapS.E := X. - - Module Data := D. - Module Import MapS := IntMake(I)(X). - Import AvlProofs. - Import Raw.Proofs. - Module Import MD := OrderedTypeFacts(D). - Module LO := FMapList.Make_ord(X)(D). - - Definition t := MapS.t D.t. - - Definition cmp e e' := - match D.compare e e' with EQ _ => true | _ => false end. - - Definition elements (m:t) := - LO.MapS.Build_slist (Raw.Proofs.elements_sort (is_bst m)). - - (** * As comparison function, we propose here a non-structural - version faithful to the code of Ocaml's Map library, instead of - the structural version of FMapAVL *) - - Fixpoint cardinal_e (e:Raw.enumeration D.t) := - match e with - | Raw.End _ => 0%nat - | Raw.More _ _ r e => S (Raw.cardinal r + cardinal_e e) - end. - - Lemma cons_cardinal_e : forall m e, - cardinal_e (Raw.cons m e) = (Raw.cardinal m + cardinal_e e)%nat. - Proof. - induction m; simpl; intros; auto. - rewrite IHm1; simpl; rewrite <- plus_n_Sm; auto with arith. - Qed. - - Definition cardinal_e_2 ee := - (cardinal_e (fst ee) + cardinal_e (snd ee))%nat. - - Local Unset Keyed Unification. - - Program Fixpoint compare_aux (ee:Raw.enumeration D.t * Raw.enumeration D.t) - { measure (cardinal_e_2 ee) } : comparison := - match ee with - | (Raw.End _, Raw.End _) => Eq - | (Raw.End _, Raw.More _ _ _ _) => Lt - | (Raw.More _ _ _ _, Raw.End _) => Gt - | (Raw.More x1 d1 r1 e1, Raw.More x2 d2 r2 e2) => - match X.compare x1 x2 with - | EQ _ => match D.compare d1 d2 with - | EQ _ => compare_aux (Raw.cons r1 e1, Raw.cons r2 e2) - | LT _ => Lt - | GT _ => Gt - end - | LT _ => Lt - | GT _ => Gt - end - end. - Next Obligation. - intros; unfold cardinal_e_2; simpl; - abstract (do 2 rewrite cons_cardinal_e; lia ). - Defined. - - Definition Cmp c := - match c with - | Eq => LO.eq_list - | Lt => LO.lt_list - | Gt => (fun l1 l2 => LO.lt_list l2 l1) - end. - - Lemma cons_Cmp : forall c x1 x2 d1 d2 l1 l2, - X.eq x1 x2 -> D.eq d1 d2 -> - Cmp c l1 l2 -> Cmp c ((x1,d1)::l1) ((x2,d2)::l2). - Proof. - destruct c; simpl; intros; MX.elim_comp; auto with ordered_type. - Qed. - #[global] - Hint Resolve cons_Cmp : core. - - #[local] Ltac caseq := - match goal with [ |- context [match ?t with _ => _ end] ] => - let cmp := fresh in - let H := fresh in - remember t as cmp eqn:H; symmetry in H; destruct cmp - end. - - Lemma compare_aux_Cmp : forall e, - Cmp (compare_aux e) (flatten_e (fst e)) (flatten_e (snd e)). - Proof. - intros e; unfold compare_aux. - match goal with [ |- context[Wf.Fix_sub _ _ _ _ ?f] ] => set (rec := f) end. - apply Wf.Fix_sub_rect. - + intros [[] []] g h Heq; simpl; try reflexivity. - repeat caseq; try reflexivity. - now apply Heq. - + intros [] IH wf; simpl. - repeat caseq; simpl; try MX.elim_comp; auto. - apply cons_Cmp; eauto. - rewrite <- !cons_1; apply IH. - unfold Wf.MR, cardinal_e_2; cbn. - rewrite !cons_cardinal_e; lia. - Qed. - - Lemma compare_Cmp : forall m1 m2, - Cmp (compare_aux (Raw.cons m1 (Raw.End _), Raw.cons m2 (Raw.End _))) - (Raw.elements m1) (Raw.elements m2). - Proof. - intros. - assert (H1:=cons_1 m1 (Raw.End _)). - assert (H2:=cons_1 m2 (Raw.End _)). - simpl in *; rewrite app_nil_r in *; rewrite <-H1,<-H2. - apply (@compare_aux_Cmp (Raw.cons m1 (Raw.End _), - Raw.cons m2 (Raw.End _))). - Qed. - - Definition eq (m1 m2 : t) := LO.eq_list (Raw.elements m1) (Raw.elements m2). - Definition lt (m1 m2 : t) := LO.lt_list (Raw.elements m1) (Raw.elements m2). - - Definition compare (s s':t) : Compare lt eq s s'. - Proof. - destruct s as (s,b,a), s' as (s',b',a'). - generalize (compare_Cmp s s'). - destruct compare_aux; intros; [apply EQ|apply LT|apply GT]; red; auto. - Defined. - - - (* Proofs about [eq] and [lt] *) - - Definition selements (m1 : t) := - LO.MapS.Build_slist (elements_sort (is_bst m1)). - - Definition seq (m1 m2 : t) := LO.eq (selements m1) (selements m2). - Definition slt (m1 m2 : t) := LO.lt (selements m1) (selements m2). - - Lemma eq_seq : forall m1 m2, eq m1 m2 <-> seq m1 m2. - Proof. - unfold eq, seq, selements, elements, LO.eq; intuition. - Qed. - - Lemma lt_slt : forall m1 m2, lt m1 m2 <-> slt m1 m2. - Proof. - unfold lt, slt, selements, elements, LO.lt; intuition. - Qed. - - Lemma eq_1 : forall (m m' : t), MapS.Equivb cmp m m' -> eq m m'. - Proof. - intros m m'. - rewrite eq_seq; unfold seq. - rewrite Equivb_Equivb. - rewrite Equivb_elements. - auto using LO.eq_1. - Qed. - - Lemma eq_2 : forall m m', eq m m' -> MapS.Equivb cmp m m'. - Proof. - intros m m'. - rewrite eq_seq; unfold seq. - rewrite Equivb_Equivb. - rewrite Equivb_elements. - intros. - generalize (LO.eq_2 H). - auto. - Qed. - - Lemma eq_refl : forall m : t, eq m m. - Proof. - intros; rewrite eq_seq; unfold seq; intros; apply LO.eq_refl. - Qed. - - Lemma eq_sym : forall m1 m2 : t, eq m1 m2 -> eq m2 m1. - Proof. - intros m1 m2; rewrite 2 eq_seq; unfold seq; intros; apply LO.eq_sym; auto. - Qed. - - Lemma eq_trans : forall m1 m2 m3 : t, eq m1 m2 -> eq m2 m3 -> eq m1 m3. - Proof. - intros m1 m2 M3; rewrite 3 eq_seq; unfold seq. - intros; eapply LO.eq_trans; eauto. - Qed. - - Lemma lt_trans : forall m1 m2 m3 : t, lt m1 m2 -> lt m2 m3 -> lt m1 m3. - Proof. - intros m1 m2 m3; rewrite 3 lt_slt; unfold slt; - intros; eapply LO.lt_trans; eauto. - Qed. - - Lemma lt_not_eq : forall m1 m2 : t, lt m1 m2 -> ~ eq m1 m2. - Proof. - intros m1 m2; rewrite lt_slt, eq_seq; unfold slt, seq; - intros; apply LO.lt_not_eq; auto. - Qed. - -End IntMake_ord. - -(* For concrete use inside Coq, we propose an instantiation of [Int] by [Z]. *) - -Module Make (X: OrderedType) <: S with Module E := X - :=IntMake(Z_as_Int)(X). - -Module Make_ord (X: OrderedType)(D: OrderedType) - <: Sord with Module Data := D - with Module MapS.E := X - :=IntMake_ord(Z_as_Int)(X)(D). diff --git a/stdlib/theories/FSets/FMapInterface.v b/stdlib/theories/FSets/FMapInterface.v deleted file mode 100644 index 0f57414bc141..000000000000 --- a/stdlib/theories/FSets/FMapInterface.v +++ /dev/null @@ -1,324 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* elt->bool) e1 e2 := cmp e1 e2 = true. - -(** ** Weak signature for maps - - No requirements for an ordering on keys nor elements, only decidability - of equality on keys. First, a functorial signature: *) - -Module Type WSfun (E : DecidableType). - - Definition key := E.t. - #[global] - Hint Transparent key : core. - - Parameter t : Type -> Type. - (** the abstract type of maps *) - - Section Types. - - Variable elt:Type. - - Parameter empty : t elt. - (** The empty map. *) - - Parameter is_empty : t elt -> bool. - (** Test whether a map is empty or not. *) - - Parameter add : key -> elt -> t elt -> t elt. - (** [add x y m] returns a map containing the same bindings as [m], - plus a binding of [x] to [y]. If [x] was already bound in [m], - its previous binding disappears. *) - - Parameter find : key -> t elt -> option elt. - (** [find x m] returns the current binding of [x] in [m], - or [None] if no such binding exists. *) - - Parameter remove : key -> t elt -> t elt. - (** [remove x m] returns a map containing the same bindings as [m], - except for [x] which is unbound in the returned map. *) - - Parameter mem : key -> t elt -> bool. - (** [mem x m] returns [true] if [m] contains a binding for [x], - and [false] otherwise. *) - - Variable elt' elt'' : Type. - - Parameter map : (elt -> elt') -> t elt -> t elt'. - (** [map f m] returns a map with same domain as [m], where the associated - value a of all bindings of [m] has been replaced by the result of the - application of [f] to [a]. Since Coq is purely functional, the order - in which the bindings are passed to [f] is irrelevant. *) - - Parameter mapi : (key -> elt -> elt') -> t elt -> t elt'. - (** Same as [map], but the function receives as arguments both the - key and the associated value for each binding of the map. *) - - Parameter map2 : - (option elt -> option elt' -> option elt'') -> t elt -> t elt' -> t elt''. - (** [map2 f m m'] creates a new map whose bindings belong to the ones - of either [m] or [m']. The presence and value for a key [k] is - determined by [f e e'] where [e] and [e'] are the (optional) bindings - of [k] in [m] and [m']. *) - - Parameter elements : t elt -> list (key*elt). - (** [elements m] returns an assoc list corresponding to the bindings - of [m], in any order. *) - - Parameter cardinal : t elt -> nat. - (** [cardinal m] returns the number of bindings in [m]. *) - - Parameter fold : forall A: Type, (key -> elt -> A -> A) -> t elt -> A -> A. - (** [fold f m a] computes [(f kN dN ... (f k1 d1 a)...)], - where [k1] ... [kN] are the keys of all bindings in [m] - (in any order), and [d1] ... [dN] are the associated data. *) - - Parameter equal : (elt -> elt -> bool) -> t elt -> t elt -> bool. - (** [equal cmp m1 m2] tests whether the maps [m1] and [m2] are equal, - that is, contain equal keys and associate them with equal data. - [cmp] is the equality predicate used to compare the data associated - with the keys. *) - - Section Spec. - - Variable m m' m'' : t elt. - Variable x y z : key. - Variable e e' : elt. - - Parameter MapsTo : key -> elt -> t elt -> Prop. - - Definition In (k:key)(m: t elt) : Prop := exists e:elt, MapsTo k e m. - - Definition Empty m := forall (a : key)(e:elt) , ~ MapsTo a e m. - - Definition eq_key (p p':key*elt) := E.eq (fst p) (fst p'). - - Definition eq_key_elt (p p':key*elt) := - E.eq (fst p) (fst p') /\ (snd p) = (snd p'). - - (** Specification of [MapsTo] *) - Parameter MapsTo_1 : E.eq x y -> MapsTo x e m -> MapsTo y e m. - - (** Specification of [mem] *) - Parameter mem_1 : In x m -> mem x m = true. - Parameter mem_2 : mem x m = true -> In x m. - - (** Specification of [empty] *) - Parameter empty_1 : Empty empty. - - (** Specification of [is_empty] *) - Parameter is_empty_1 : Empty m -> is_empty m = true. - Parameter is_empty_2 : is_empty m = true -> Empty m. - - (** Specification of [add] *) - Parameter add_1 : E.eq x y -> MapsTo y e (add x e m). - Parameter add_2 : ~ E.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m). - Parameter add_3 : ~ E.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m. - - (** Specification of [remove] *) - Parameter remove_1 : E.eq x y -> ~ In y (remove x m). - Parameter remove_2 : ~ E.eq x y -> MapsTo y e m -> MapsTo y e (remove x m). - Parameter remove_3 : MapsTo y e (remove x m) -> MapsTo y e m. - - (** Specification of [find] *) - Parameter find_1 : MapsTo x e m -> find x m = Some e. - Parameter find_2 : find x m = Some e -> MapsTo x e m. - - (** Specification of [elements] *) - Parameter elements_1 : - MapsTo x e m -> InA eq_key_elt (x,e) (elements m). - Parameter elements_2 : - InA eq_key_elt (x,e) (elements m) -> MapsTo x e m. - (** When compared with ordered maps, here comes the only - property that is really weaker: *) - Parameter elements_3w : NoDupA eq_key (elements m). - - (** Specification of [cardinal] *) - Parameter cardinal_1 : cardinal m = length (elements m). - - (** Specification of [fold] *) - Parameter fold_1 : - forall (A : Type) (i : A) (f : key -> elt -> A -> A), - fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i. - - (** Equality of maps *) - - (** Caveat: there are at least three distinct equality predicates on maps. - - The simplest (and maybe most natural) way is to consider keys up to - their equivalence [E.eq], but elements up to Leibniz equality, in - the spirit of [eq_key_elt] above. This leads to predicate [Equal]. - - Unfortunately, this [Equal] predicate can't be used to describe - the [equal] function, since this function (for compatibility with - ocaml) expects a boolean comparison [cmp] that may identify more - elements than Leibniz. So logical specification of [equal] is done - via another predicate [Equivb] - - This predicate [Equivb] is quite ad-hoc with its boolean [cmp], - it can be generalized in a [Equiv] expecting a more general - (possibly non-decidable) equality predicate on elements *) - - Definition Equal m m' := forall y, find y m = find y m'. - Definition Equiv (eq_elt:elt->elt->Prop) m m' := - (forall k, In k m <-> In k m') /\ - (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e'). - Definition Equivb (cmp: elt->elt->bool) := Equiv (Cmp cmp). - - (** Specification of [equal] *) - - Variable cmp : elt -> elt -> bool. - - Parameter equal_1 : Equivb cmp m m' -> equal cmp m m' = true. - Parameter equal_2 : equal cmp m m' = true -> Equivb cmp m m'. - - End Spec. - End Types. - - (** Specification of [map] *) - Parameter map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'), - MapsTo x e m -> MapsTo x (f e) (map f m). - Parameter map_2 : forall (elt elt':Type)(m: t elt)(x:key)(f:elt->elt'), - In x (map f m) -> In x m. - - (** Specification of [mapi] *) - Parameter mapi_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt) - (f:key->elt->elt'), MapsTo x e m -> - exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m). - Parameter mapi_2 : forall (elt elt':Type)(m: t elt)(x:key) - (f:key->elt->elt'), In x (mapi f m) -> In x m. - - (** Specification of [map2] *) - Parameter map2_1 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') - (x:key)(f:option elt->option elt'->option elt''), - In x m \/ In x m' -> - find x (map2 f m m') = f (find x m) (find x m'). - - Parameter map2_2 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') - (x:key)(f:option elt->option elt'->option elt''), - In x (map2 f m m') -> In x m \/ In x m'. - - #[global] - Hint Immediate MapsTo_1 mem_2 is_empty_2 - map_2 mapi_2 add_3 remove_3 find_2 - : map. - #[global] - Hint Resolve mem_1 is_empty_1 is_empty_2 add_1 add_2 remove_1 - remove_2 find_1 fold_1 map_1 mapi_1 mapi_2 - : map. - -End WSfun. - - -(** ** Static signature for Weak Maps - - Similar to [WSfun] but expressed in a self-contained way. *) - -Module Type WS. - Declare Module E : DecidableType. - Include WSfun E. -End WS. - - - -(** ** Maps on ordered keys, functorial signature *) - -Module Type Sfun (E : OrderedType). - Include WSfun E. - Section elt. - Variable elt:Type. - Definition lt_key (p p':key*elt) := E.lt (fst p) (fst p'). - (* Additional specification of [elements] *) - Parameter elements_3 : forall m, sort lt_key (elements m). - (** Remark: since [fold] is specified via [elements], this stronger - specification of [elements] has an indirect impact on [fold], - which can now be proved to receive elements in increasing order. *) - End elt. -End Sfun. - - - -(** ** Maps on ordered keys, self-contained signature *) - -Module Type S. - Declare Module E : OrderedType. - Include Sfun E. -End S. - - - -(** ** Maps with ordering both on keys and datas *) - -Module Type Sord. - - Declare Module Data : OrderedType. - Declare Module MapS : S. - Import MapS. - - Definition t := MapS.t Data.t. - - Parameter eq : t -> t -> Prop. - Parameter lt : t -> t -> Prop. - - Axiom eq_refl : forall m : t, eq m m. - Axiom eq_sym : forall m1 m2 : t, eq m1 m2 -> eq m2 m1. - Axiom eq_trans : forall m1 m2 m3 : t, eq m1 m2 -> eq m2 m3 -> eq m1 m3. - Axiom lt_trans : forall m1 m2 m3 : t, lt m1 m2 -> lt m2 m3 -> lt m1 m3. - Axiom lt_not_eq : forall m1 m2 : t, lt m1 m2 -> ~ eq m1 m2. - - Definition cmp e e' := match Data.compare e e' with EQ _ => true | _ => false end. - - Parameter eq_1 : forall m m', Equivb cmp m m' -> eq m m'. - Parameter eq_2 : forall m m', eq m m' -> Equivb cmp m m'. - - Parameter compare : forall m1 m2, Compare lt eq m1 m2. - (** Total ordering between maps. [Data.compare] is a total ordering - used to compare data associated with equal keys in the two maps. *) - -End Sord. diff --git a/stdlib/theories/FSets/FMapList.v b/stdlib/theories/FSets/FMapList.v deleted file mode 100644 index 1122a5987f40..000000000000 --- a/stdlib/theories/FSets/FMapList.v +++ /dev/null @@ -1,1299 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* is_empty m = true. -Proof. - unfold Empty, PX.MapsTo. - intros m. - case m;auto. - intros (k,e) l inlist. - absurd (InA eqke (k, e) ((k, e) :: l)); auto with ordered_type. -Qed. - -Lemma is_empty_2 : forall m, is_empty m = true -> Empty m. -Proof. - intros m. - case m;auto. - intros p l abs. - inversion abs. -Qed. - -(** * [mem] *) - -Fixpoint mem (k : key) (s : t elt) {struct s} : bool := - match s with - | nil => false - | (k',_) :: l => - match X.compare k k' with - | LT _ => false - | EQ _ => true - | GT _ => mem k l - end - end. - -Lemma mem_1 : forall m (Hm:Sort m) x, In x m -> mem x m = true. -Proof. - intros m Hm; induction m as [|[a m]]; intros x H; simpl in *. - - destruct H as [? H]; inversion H. - - apply In_inv in H; destruct H as [H|H]. - + destruct (elim_compare_eq H) as [? Hr]; rewrite Hr; reflexivity. - + destruct (X.compare x a); [|reflexivity|apply IHm; inversion_clear Hm; auto]. - absurd (In x ((a, m) :: m0)); [|destruct H as [y v]; exists y; constructor 2; auto]. - apply Sort_Inf_NotIn with m; [inversion_clear Hm; auto|]. - constructor; apply l. -Qed. - -Lemma mem_2 : forall m (Hm:Sort m) x, mem x m = true -> In x m. -Proof. - intros m Hm; induction m as [|[a m]]; intros x H; simpl in *. - - discriminate. - - destruct X.compare; [discriminate| |]. - + exists m; apply InA_cons_hd; split; auto. - + inversion_clear Hm; destruct IHm with x as [e He]; auto. - exists e; apply InA_cons_tl; auto. -Qed. - -(** * [find] *) - -Fixpoint find (k:key) (s: t elt) {struct s} : option elt := - match s with - | nil => None - | (k',x)::s' => - match X.compare k k' with - | LT _ => None - | EQ _ => Some x - | GT _ => find k s' - end - end. - -Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m. -Proof. - induction m as [|[a m]]; intros x e H; simpl in *; [congruence|]. - destruct X.compare; [congruence| |]. - - apply InA_cons_hd; split; compute; congruence. - - apply InA_cons_tl; apply IHm; auto. -Qed. - -Lemma find_1 : forall m (Hm:Sort m) x e, MapsTo x e m -> find x m = Some e. -Proof. -intros m Hm; induction Hm as [|[a m] l Hm IHHm Hr]; intros x e H; simpl in *. -- inversion H. -- apply InA_cons in H; destruct H as [H|H]. - * unfold eqke in H; simpl in H. - destruct elim_compare_eq with x a as [H' r]; [tauto|]. - rewrite r; f_equal; symmetry; tauto. - * destruct elim_compare_gt with x a as [H' r]; [|rewrite r; apply IHHm, H]. - apply InA_eqke_eqk in H. - apply (Sort_Inf_In Hm Hr H). -Qed. - -(** * [add] *) - -Fixpoint add (k : key) (x : elt) (s : t elt) {struct s} : t elt := - match s with - | nil => (k,x) :: nil - | (k',y) :: l => - match X.compare k k' with - | LT _ => (k,x)::s - | EQ _ => (k,x)::l - | GT _ => (k',y) :: add k x l - end - end. - -Lemma add_1 : forall m x y e, X.eq x y -> MapsTo y e (add x e m). -Proof. -intros m x y e; generalize y; clear y. -unfold PX.MapsTo. -induction m as [|[y e'] m IHm]; simpl. -- auto with ordered_type. -- intros; destruct X.compare; auto with ordered_type. -Qed. - -Lemma add_2 : forall m x y e e', - ~ X.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m). -Proof. -intros m x y e e' He H; unfold PX.MapsTo in *. -induction m as [|[z e''] m IHm]; simpl. -- auto. -- destruct X.compare as [Hlt|Heq|Hgt]; simpl. - + auto with ordered_type. - + apply InA_cons_tl; apply InA_cons in H; destruct H; [|assumption]. - compute in H; intuition order. - + apply InA_cons in H; destruct H; [now auto with ordered_type|]. - apply InA_cons_tl; apply IHm, H. -Qed. - -Lemma add_3 : forall m x y e e', - ~ X.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m. -Proof. -intros m x y e e' He H; unfold PX.MapsTo in *. -induction m as [|[z e''] m IHm]; simpl in *. -- apply (In_inv_3 H); auto with ordered_type. -- destruct X.compare as [Hlt|Heq|Hgt]; simpl. - + apply (In_inv_3 H); auto with ordered_type. - + constructor 2; apply (In_inv_3 H); auto with ordered_type. - + inversion_clear H; auto. -Qed. - -Lemma add_Inf : forall (m:t elt)(x x':key)(e e':elt), - Inf (x',e') m -> ltk (x',e') (x,e) -> Inf (x',e') (add x e m). -Proof. - induction m. - - simpl; intuition. - - intros. - destruct a as (x'',e''). - inversion_clear H. - compute in H0,H1. - simpl; case (X.compare x x''); intuition. -Qed. -#[local] -Hint Resolve add_Inf : core. - -Lemma add_sorted : forall m (Hm:Sort m) x e, Sort (add x e m). -Proof. - induction m. - - simpl; intuition. - - intros. - destruct a as (x',e'). - simpl; case (X.compare x x'); intuition; inversion_clear Hm; auto. - constructor; auto. - apply Inf_eq with (x',e'); auto. -Qed. - -(** * [remove] *) - -Fixpoint remove (k : key) (s : t elt) {struct s} : t elt := - match s with - | nil => nil - | (k',x) :: l => - match X.compare k k' with - | LT _ => s - | EQ _ => l - | GT _ => (k',x) :: remove k l - end - end. - -Lemma remove_1 : forall m (Hm:Sort m) x y, X.eq x y -> ~ In y (remove x m). -Proof. -intros m Hm x y He [e H]; revert e H. -induction Hm as [|[a m] l Hm IHHm Hr]; simpl in *; intros e H. -- now inversion H. -- destruct X.compare as [Hlt|Heq|Hgt]. - + apply InA_cons in H; destruct H; [compute in H; destruct H; order|]. - apply InA_eqke_eqk in H; apply (Sort_Inf_In Hm Hr) in H. - compute in H; order. - + apply InA_eqke_eqk in H; apply (Sort_Inf_In Hm Hr) in H. - compute in H; order. - + apply InA_cons in H; destruct H; [compute in H; destruct H; order|]. - apply (IHHm e), H. -Qed. - -Lemma remove_2 : forall m (Hm:Sort m) x y e, - ~ X.eq x y -> MapsTo y e m -> MapsTo y e (remove x m). -Proof. -intros m Hm x y e He H. -induction Hm as [|[a m] l Hm IHHm Hr]; simpl in *. -- now inversion H. -- destruct X.compare as [Hlt|Heq|Hgt]. - + assumption. - + apply InA_cons in H; destruct H; [compute in H; destruct H; order|]. - apply H. - + apply InA_cons in H; destruct H. - * apply InA_cons_hd; assumption. - * apply InA_cons_tl, IHHm, H. -Qed. - -Lemma remove_3 : forall m (Hm:Sort m) x y e, - MapsTo y e (remove x m) -> MapsTo y e m. -Proof. -intros m Hm x y e H. -induction Hm as [|[a m] l Hm IHHm Hr]; simpl in *. -- now inversion H. -- destruct X.compare as [Hlt|Heq|Hgt]. - + assumption. - + apply InA_cons_tl, H. - + apply InA_cons in H; destruct H. - * apply InA_cons_hd; assumption. - * apply InA_cons_tl, IHHm, H. -Qed. - -Lemma remove_Inf : forall (m:t elt)(Hm : Sort m)(x x':key)(e':elt), - Inf (x',e') m -> Inf (x',e') (remove x m). -Proof. - induction m. - - simpl; intuition. - - intros. - destruct a as (x'',e''). - inversion_clear H. - compute in H0. - simpl; case (X.compare x x''); intuition. - inversion_clear Hm. - apply Inf_lt with (x'',e''); auto. -Qed. -#[local] -Hint Resolve remove_Inf : core. - -Lemma remove_sorted : forall m (Hm:Sort m) x, Sort (remove x m). -Proof. - induction m. - - simpl; intuition. - - intros. - destruct a as (x',e'). - simpl; case (X.compare x x'); intuition; inversion_clear Hm; auto. -Qed. - -(** * [elements] *) - -Definition elements (m: t elt) := m. - -Lemma elements_1 : forall m x e, - MapsTo x e m -> InA eqke (x,e) (elements m). -Proof. - auto. -Qed. - -Lemma elements_2 : forall m x e, - InA eqke (x,e) (elements m) -> MapsTo x e m. -Proof. - auto. -Qed. - -Lemma elements_3 : forall m (Hm:Sort m), sort ltk (elements m). -Proof. - auto. -Qed. - -Lemma elements_3w : forall m (Hm:Sort m), NoDupA eqk (elements m). -Proof. - intros. - apply Sort_NoDupA. - apply elements_3; auto. -Qed. - -(** * [fold] *) - -Fixpoint fold (A:Type)(f:key->elt->A->A)(m:t elt) (acc:A) {struct m} : A := - match m with - | nil => acc - | (k,e)::m' => fold f m' (f k e acc) - end. - -Lemma fold_1 : forall m (A:Type)(i:A)(f:key->elt->A->A), - fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i. -Proof. -induction m as [|[k e] m]; simpl; auto. -Qed. - -(** * [equal] *) - -Fixpoint equal (cmp:elt->elt->bool)(m m' : t elt) {struct m} : bool := - match m, m' with - | nil, nil => true - | (x,e)::l, (x',e')::l' => - match X.compare x x' with - | EQ _ => cmp e e' && equal cmp l l' - | _ => false - end - | _, _ => false - end. - -Definition Equivb cmp m m' := - (forall k, In k m <-> In k m') /\ - (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true). - -Lemma equal_1 : forall m (Hm:Sort m) m' (Hm': Sort m') cmp, - Equivb cmp m m' -> equal cmp m m' = true. -Proof. -intros m Hm m' Hm' cmp; revert m' Hm'. -induction Hm as [|[a e] m Hm IHHm Hr]; simpl in *; intros [|[a' e'] m'] Hm' H. -+ reflexivity. -+ destruct H as [H _]; specialize (H a') as [_ H]. - destruct H; [exists e'; constructor; reflexivity|inversion H]. -+ destruct H as [H _]; specialize (H a) as [H _]. - destruct H; [exists e; constructor; reflexivity|inversion H]. -+ apply Sorted_inv in Hm'; destruct Hm' as [Hm' Hr']. - destruct (X.compare a a') as [Hlt|Heq|Hgt]; [exfalso| |exfalso]. - - destruct H as [H _]; specialize (H a) as [H _]. - destruct H as [e'' H]; [eexists; constructor; reflexivity|]. - apply InA_cons in H; destruct H as [H|H]. - * apply (gt_not_eq Hlt); symmetry; apply H. - * apply InA_eqke_eqk, (Sort_Inf_In Hm' Hr') in H. - compute in H; order. - - apply andb_true_iff; split. - * destruct H as [_ H]; apply H with a. - { apply InA_cons_hd; reflexivity. } - { apply InA_cons_hd; auto with ordered_type. } - * apply IHHm; [assumption|]; split. - { intros k; destruct H as [H _]; specialize (H k). - split; intros [e'' Hk]. - + destruct H as [H _]; destruct H as [e''' H]. - - exists e''; apply InA_cons_tl; apply Hk. - - apply InA_cons in H; destruct H as [[H _]|H]. - * assert (Hs := Sort_Inf_In Hm Hr (InA_eqke_eqk Hk)). - elim (gt_not_eq Hs); simpl; etransitivity; [eassumption|symmetry; assumption]. - * exists e'''; assumption. - + destruct H as [_ H]; destruct H as [e''' H]. - - exists e''; apply InA_cons_tl; apply Hk. - - apply InA_cons in H; destruct H as [[H _]|H]. - * assert (Hs := Sort_Inf_In Hm' Hr' (InA_eqke_eqk Hk)). - elim (gt_not_eq Hs); simpl; etransitivity; eassumption. - * exists e'''; assumption. - } - { intros; destruct H as [_ H]; apply H with k; apply InA_cons_tl; assumption. } - - destruct H as [H _]; specialize (H a') as [_ H]. - destruct H as [e'' H]; [eexists; constructor; reflexivity|]. - apply InA_cons in H; destruct H as [H|H]. - * apply (gt_not_eq Hgt); symmetry; apply H. - * apply InA_eqke_eqk, (Sort_Inf_In Hm Hr) in H. - compute in H; order. -Qed. - -Lemma equal_2 : forall m (Hm:Sort m) m' (Hm:Sort m') cmp, - equal cmp m m' = true -> Equivb cmp m m'. -Proof with auto with ordered_type. -intros m Hm m' Hm' cmp; revert m' Hm'. -induction Hm as [|[a e] m Hm IHHm Hr]; simpl in *; intros [|[a' e'] m'] Hm' H; try congruence. -+ split; [tauto|inversion 1]. -+ destruct X.compare as [?|Heq|?]; try congruence. - apply Sorted_inv in Hm'; destruct Hm' as [Hm' Hr']. - apply andb_true_iff in H; destruct H as [Hc He]; split. - - intros k; split; intros [v Hk]; apply InA_cons in Hk; destruct Hk as [Hk|Hk]. - * exists e'; apply InA_cons_hd; split; [|reflexivity]. - transitivity a; [apply Hk|apply Heq]. - * assert (Hi : In k m'). - { apply (IHHm m' Hm' He); exists v; apply Hk. } - destruct Hi as [w Hw]; exists w; apply InA_cons_tl, Hw. - * exists e; apply InA_cons_hd; split; [|reflexivity]. - transitivity a'; [apply Hk|symmetry; apply Heq]. - * assert (Hi : In k m). - { apply (IHHm m' Hm' He); exists v; apply Hk. } - destruct Hi as [w Hw]; exists w; apply InA_cons_tl, Hw. - - intros k e1 e2 He1 He2. - apply InA_cons in He1, He2. - destruct He1 as [He1|He1]; destruct He2 as [He2|He2]. - * replace e1 with e by (symmetry; apply He1). - replace e2 with e' by (symmetry; apply He2). - apply Hc. - * assert (Hi : In k m). - { apply (IHHm m' Hm' He); exists e2; apply He2. } - destruct Hi as [w Hw]. - apply InA_eqke_eqk, (Sort_Inf_In Hm Hr) in Hw. - destruct He1 as [He1 _]. - elim (eq_not_gt He1); apply Hw. - * assert (Hi : In k m'). - { apply (IHHm m' Hm' He); exists e1; apply He1. } - destruct Hi as [w Hw]. - apply InA_eqke_eqk, (Sort_Inf_In Hm' Hr') in Hw. - destruct He2 as [He2 _]. - elim (eq_not_gt He2); apply Hw. - * destruct (IHHm m' Hm' He) as [_ IH]. - apply (IH k e1 e2 He1 He2). -Qed. - -(** This lemma isn't part of the spec of [Equivb], but is used in [FMapAVL] *) - -Lemma equal_cons : forall cmp l1 l2 x y, Sort (x::l1) -> Sort (y::l2) -> - eqk x y -> cmp (snd x) (snd y) = true -> - (Equivb cmp l1 l2 <-> Equivb cmp (x :: l1) (y :: l2)). -Proof. - intros. - inversion H; subst. - inversion H0; subst. - destruct x; destruct y; compute in H1, H2. - split; intros. - - apply equal_2; auto. - simpl. - elim_comp. - rewrite H2; simpl. - apply equal_1; auto. - - apply equal_2; auto. - generalize (equal_1 H H0 H3). - simpl. - elim_comp. - rewrite H2; simpl; auto. -Qed. - -Variable elt':Type. - -(** * [map] and [mapi] *) - -Fixpoint map (f:elt -> elt') (m:t elt) : t elt' := - match m with - | nil => nil - | (k,e)::m' => (k,f e) :: map f m' - end. - -Fixpoint mapi (f: key -> elt -> elt') (m:t elt) : t elt' := - match m with - | nil => nil - | (k,e)::m' => (k,f k e) :: mapi f m' - end. - -End Elt. -Section Elt2. -(* A new section is necessary for previous definitions to work - with different [elt], especially [MapsTo]... *) - -Variable elt elt' : Type. - -(** Specification of [map] *) - -Lemma map_1 : forall (m:t elt)(x:key)(e:elt)(f:elt->elt'), - MapsTo x e m -> MapsTo x (f e) (map f m). -Proof. - intros m x e f. - induction m. - - inversion 1. - - - destruct a as (x',e'). - simpl. - inversion_clear 1. - + constructor 1. - unfold eqke in *; simpl in *; intuition congruence. - + unfold MapsTo in *; auto. -Qed. - -Lemma map_2 : forall (m:t elt)(x:key)(f:elt->elt'), - In x (map f m) -> In x m. -Proof. - intros m x f. - induction m; simpl. - - intros (e,abs). - inversion abs. - - - destruct a as (x',e). - intros hyp. - inversion hyp. clear hyp. - inversion H; subst; rename x0 into e'. - + exists e; constructor. - unfold eqke in *; simpl in *; intuition. - + destruct IHm as (e'',hyp). - * exists e'; auto. - * exists e''. - constructor 2; auto. -Qed. - -Lemma map_lelistA : forall (m: t elt)(x:key)(e:elt)(e':elt')(f:elt->elt'), - lelistA (@ltk elt) (x,e) m -> - lelistA (@ltk elt') (x,e') (map f m). -Proof. - induction m; simpl; auto. - intros. - destruct a as (x0,e0). - inversion_clear H; auto. -Qed. - -#[local] -Hint Resolve map_lelistA : core. - -Lemma map_sorted : forall (m: t elt)(Hm : sort (@ltk elt) m)(f:elt -> elt'), - sort (@ltk elt') (map f m). -Proof. - induction m; simpl; auto. - intros. - destruct a as (x',e'). - inversion_clear Hm. - constructor; auto. - exact (map_lelistA _ _ H0). -Qed. - -(** Specification of [mapi] *) - -Lemma mapi_1 : forall (m:t elt)(x:key)(e:elt)(f:key->elt->elt'), - MapsTo x e m -> - exists y, X.eq y x /\ MapsTo x (f y e) (mapi f m). -Proof. - intros m x e f. - induction m. - - inversion 1. - - - destruct a as (x',e'). - simpl. - inversion_clear 1. - + exists x'. - destruct H0; simpl in *. - split. - * auto with ordered_type. - * constructor 1. - unfold eqke in *; simpl in *; intuition congruence. - + destruct IHm as (y, hyp); auto. - exists y; intuition auto with ordered_type. -Qed. - - -Lemma mapi_2 : forall (m:t elt)(x:key)(f:key->elt->elt'), - In x (mapi f m) -> In x m. -Proof. - intros m x f. - induction m; simpl. - - intros (e,abs). - inversion abs. - - - destruct a as (x',e). - intros hyp. - inversion hyp. clear hyp. - inversion H; subst; rename x0 into e'. - + exists e; constructor. - unfold eqke in *; simpl in *; intuition. - + destruct IHm as (e'',hyp). - * exists e'; auto. - * exists e''. - constructor 2; auto. -Qed. - -Lemma mapi_lelistA : forall (m: t elt)(x:key)(e:elt)(f:key->elt->elt'), - lelistA (@ltk elt) (x,e) m -> - lelistA (@ltk elt') (x,f x e) (mapi f m). -Proof. - induction m; simpl; auto. - intros. - destruct a as (x',e'). - inversion_clear H; auto. -Qed. - -#[local] -Hint Resolve mapi_lelistA : core. - -Lemma mapi_sorted : forall m (Hm : sort (@ltk elt) m)(f: key ->elt -> elt'), - sort (@ltk elt') (mapi f m). -Proof. - induction m; simpl; auto. - intros. - destruct a as (x',e'). - inversion_clear Hm; auto. -Qed. - -End Elt2. -Section Elt3. - -(** * [map2] *) - -Variable elt elt' elt'' : Type. -Variable f : option elt -> option elt' -> option elt''. - -Definition option_cons (A:Type)(k:key)(o:option A)(l:list (key*A)) := - match o with - | Some e => (k,e)::l - | None => l - end. - -Fixpoint map2_l (m : t elt) : t elt'' := - match m with - | nil => nil - | (k,e)::l => option_cons k (f (Some e) None) (map2_l l) - end. - -Fixpoint map2_r (m' : t elt') : t elt'' := - match m' with - | nil => nil - | (k,e')::l' => option_cons k (f None (Some e')) (map2_r l') - end. - -Fixpoint map2 (m : t elt) : t elt' -> t elt'' := - match m with - | nil => map2_r - | (k,e) :: l => - fix map2_aux (m' : t elt') : t elt'' := - match m' with - | nil => map2_l m - | (k',e') :: l' => - match X.compare k k' with - | LT _ => option_cons k (f (Some e) None) (map2 l m') - | EQ _ => option_cons k (f (Some e) (Some e')) (map2 l l') - | GT _ => option_cons k' (f None (Some e')) (map2_aux l') - end - end - end. - -Notation oee' := (option elt * option elt')%type. - -Fixpoint combine (m : t elt) : t elt' -> t oee' := - match m with - | nil => map (fun e' => (None,Some e')) - | (k,e) :: l => - fix combine_aux (m':t elt') : list (key * oee') := - match m' with - | nil => map (fun e => (Some e,None)) m - | (k',e') :: l' => - match X.compare k k' with - | LT _ => (k,(Some e, None))::combine l m' - | EQ _ => (k,(Some e, Some e'))::combine l l' - | GT _ => (k',(None,Some e'))::combine_aux l' - end - end - end. - -Definition fold_right_pair (A B C:Type)(f: A->B->C->C)(l:list (A*B))(i:C) := - List.fold_right (fun p => f (fst p) (snd p)) i l. - -Definition map2_alt m m' := - let m0 : t oee' := combine m m' in - let m1 : t (option elt'') := map (fun p => f (fst p) (snd p)) m0 in - fold_right_pair (option_cons (A:=elt'')) m1 nil. - -Lemma map2_alt_equiv : forall m m', map2_alt m m' = map2 m m'. -Proof. - unfold map2_alt. - induction m. - - simpl; auto; intros. - (* map2_r *) - induction m'; try destruct a; simpl; auto. - rewrite IHm'; auto. - (* fin map2_r *) - - induction m'; destruct a. - + simpl; f_equal. - (* map2_l *) - clear IHm. - induction m; try destruct a; simpl; auto. - rewrite IHm; auto. - (* fin map2_l *) - + destruct a0. - simpl. - destruct (X.compare t0 t1); simpl; f_equal. - * apply IHm. - * apply IHm. - * apply IHm'. -Qed. - -Lemma combine_lelistA : - forall m m' (x:key)(e:elt)(e':elt')(e'':oee'), - lelistA (@ltk elt) (x,e) m -> - lelistA (@ltk elt') (x,e') m' -> - lelistA (@ltk oee') (x,e'') (combine m m'). -Proof. - induction m. - - intros. - simpl. - exact (map_lelistA _ _ H0). - - induction m'. - + intros. - destruct a. - replace (combine ((t0, e0) :: m) nil) with - (map (fun e => (Some e,None (A:=elt'))) ((t0,e0)::m)); auto. - exact (map_lelistA _ _ H). - + intros. - simpl. - destruct a as (k,e0); destruct a0 as (k',e0'). - destruct (X.compare k k'). - * inversion_clear H; auto. - * inversion_clear H; auto. - * inversion_clear H0; auto. -Qed. -#[local] -Hint Resolve combine_lelistA : core. - -Lemma combine_sorted : - forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m'), - sort (@ltk oee') (combine m m'). -Proof. - induction m. - - intros; clear Hm. - simpl. - apply map_sorted; auto. - - induction m'. - + intros; clear Hm'. - destruct a. - replace (combine ((t0, e) :: m) nil) with - (map (fun e => (Some e,None (A:=elt'))) ((t0,e)::m)); auto. - apply map_sorted; auto. - + intros. - simpl. - destruct a as (k,e); destruct a0 as (k',e'). - destruct (X.compare k k') as [Hlt|Heq|Hlt]. - * inversion_clear Hm. - constructor; auto. - assert (lelistA (ltk (elt:=elt')) (k, e') ((k',e')::m')) by auto. - exact (combine_lelistA _ H0 H1). - * inversion_clear Hm; inversion_clear Hm'. - constructor; auto. - assert (lelistA (ltk (elt:=elt')) (k, e') m') by (apply Inf_eq with (k',e'); auto). - exact (combine_lelistA _ H0 H3). - * inversion_clear Hm; inversion_clear Hm'. - constructor; auto. - change (lelistA (ltk (elt:=oee')) (k', (None, Some e')) - (combine ((k,e)::m) m')). - assert (lelistA (ltk (elt:=elt)) (k', e) ((k,e)::m)) by auto. - exact (combine_lelistA _ H3 H2). -Qed. - -Lemma map2_sorted : - forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m'), - sort (@ltk elt'') (map2 m m'). -Proof. - intros. - rewrite <- map2_alt_equiv. - unfold map2_alt. - assert (H0:=combine_sorted Hm Hm'). - set (l0:=combine m m') in *; clearbody l0. - set (f':= fun p : oee' => f (fst p) (snd p)). - assert (H1:=map_sorted (elt' := option elt'') H0 f'). - set (l1:=map f' l0) in *; clearbody l1. - clear f' f H0 l0 Hm Hm' m m'. - induction l1. - - simpl; auto. - - inversion_clear H1. - destruct a; destruct o; auto. - simpl. - constructor; auto. - clear IHl1. - induction l1. - + simpl; auto. - + destruct a; destruct o; simpl; auto. - * inversion_clear H0; auto. - * inversion_clear H0. - red in H1; simpl in H1. - inversion_clear H. - apply IHl1; auto. - apply Inf_lt with (t1, None (A:=elt'')); auto. -Qed. - -Definition at_least_one (o:option elt)(o':option elt') := - match o, o' with - | None, None => None - | _, _ => Some (o,o') - end. - -Lemma combine_1 : - forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m') (x:key), - find x (combine m m') = at_least_one (find x m) (find x m'). -Proof. - induction m. - - intros. - simpl. - induction m'. - + intros; simpl; auto. - + simpl; destruct a. - simpl; destruct (X.compare x t0); simpl; auto. - inversion_clear Hm'; auto. - - induction m'. - + (* m' = nil *) - intros; destruct a; simpl. - destruct (X.compare x t0) as [Hlt| |Hlt]; simpl; auto. - inversion_clear Hm; clear H0 Hlt Hm' IHm t0. - induction m; simpl; auto. - inversion_clear H. - destruct a. - simpl; destruct (X.compare x t0); simpl; auto. - + (* m' <> nil *) - intros. - destruct a as (k,e); destruct a0 as (k',e'); simpl. - inversion Hm; inversion Hm'; subst. - destruct (X.compare k k'); simpl; - destruct (X.compare x k); - elim_comp || destruct (X.compare x k'); simpl; auto. - * rewrite IHm; auto; simpl; elim_comp; auto. - * rewrite IHm; auto; simpl; elim_comp; auto. - * rewrite IHm; auto; simpl; elim_comp; auto. - * change (find x (combine ((k, e) :: m) m') = at_least_one None (find x m')). - rewrite IHm'; auto. - simpl find; elim_comp; auto. - * change (find x (combine ((k, e) :: m) m') = Some (Some e, find x m')). - rewrite IHm'; auto. - simpl find; elim_comp; auto. - * change (find x (combine ((k, e) :: m) m') = - at_least_one (find x m) (find x m')). - rewrite IHm'; auto. - simpl find; elim_comp; auto. -Qed. - -Definition at_least_one_then_f (o:option elt)(o':option elt') := - match o, o' with - | None, None => None - | _, _ => f o o' - end. - -Lemma map2_0 : - forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m') (x:key), - find x (map2 m m') = at_least_one_then_f (find x m) (find x m'). -Proof. - intros. - rewrite <- map2_alt_equiv. - unfold map2_alt. - assert (H:=combine_1 Hm Hm' x). - assert (H2:=combine_sorted Hm Hm'). - set (f':= fun p : oee' => f (fst p) (snd p)). - set (m0 := combine m m') in *; clearbody m0. - set (o:=find x m) in *; clearbody o. - set (o':=find x m') in *; clearbody o'. - clear Hm Hm' m m'. - generalize H; clear H. - match goal with |- ?m=?n -> ?p=?q => - assert ((m=n->p=q)/\(m=None -> p=None)); [|intuition] end. - induction m0; simpl in *; intuition. - - destruct o; destruct o'; simpl in *; try discriminate; auto. - - destruct a as (k,(oo,oo')); simpl in *. - inversion_clear H2. - destruct (X.compare x k) as [Hlt|Heq|Hlt]; simpl in *. - + (* x < k *) - destruct (f' (oo,oo')); simpl. - * elim_comp. - destruct o; destruct o'; simpl in *; try discriminate; auto. - * destruct (IHm0 H0) as (H2,_); apply H2; auto. - rewrite <- H. - case_eq (find x m0); intros; auto. - assert (ltk (elt:=oee') (x,(oo,oo')) (k,(oo,oo'))). - -- red; auto. - -- destruct (Sort_Inf_NotIn H0 (Inf_lt H4 H1)). - exists p; apply find_2; auto. - + (* x = k *) - assert (at_least_one_then_f o o' = f oo oo'). - * destruct o; destruct o'; simpl in *; inversion_clear H; auto. - * rewrite H2. - unfold f'; simpl. - destruct (f oo oo'); simpl. - -- elim_comp; auto. - -- destruct (IHm0 H0) as (_,H4); apply H4; auto. - case_eq (find x m0); intros; auto. - assert (eqk (elt:=oee') (k,(oo,oo')) (x,(oo,oo'))). - ++ red; auto with ordered_type. - ++ destruct (Sort_Inf_NotIn H0 (Inf_eq (eqk_sym H5) H1)). - exists p; apply find_2; auto. - + (* k < x *) - unfold f'; simpl. - destruct (f oo oo'); simpl. - * elim_comp; auto. - destruct (IHm0 H0) as (H3,_); apply H3; auto. - * destruct (IHm0 H0) as (H3,_); apply H3; auto. - - - (* None -> None *) - destruct a as (k,(oo,oo')). - simpl. - inversion_clear H2. - destruct (X.compare x k) as [Hlt|Heq|Hlt]. - + (* x < k *) - unfold f'; simpl. - destruct (f oo oo'); simpl. - * elim_comp; auto. - * destruct (IHm0 H0) as (_,H4); apply H4; auto. - case_eq (find x m0); intros; auto. - assert (ltk (elt:=oee') (x,(oo,oo')) (k,(oo,oo'))). - -- red; auto. - -- destruct (Sort_Inf_NotIn H0 (Inf_lt H3 H1)). - exists p; apply find_2; auto. - + (* x = k *) - discriminate. - + (* k < x *) - unfold f'; simpl. - destruct (f oo oo'); simpl. - * elim_comp; auto. - destruct (IHm0 H0) as (_,H4); apply H4; auto. - * destruct (IHm0 H0) as (_,H4); apply H4; auto. -Qed. - -(** Specification of [map2] *) - -Lemma map2_1 : - forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m')(x:key), - In x m \/ In x m' -> - find x (map2 m m') = f (find x m) (find x m'). -Proof. - intros. - rewrite map2_0; auto. - destruct H as [(e,H)|(e,H)]. - - rewrite (find_1 Hm H). - destruct (find x m'); simpl; auto. - - rewrite (find_1 Hm' H). - destruct (find x m); simpl; auto. -Qed. - -Lemma map2_2 : - forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m')(x:key), - In x (map2 m m') -> In x m \/ In x m'. -Proof. - intros. - destruct H as (e,H). - generalize (map2_0 Hm Hm' x). - rewrite (find_1 (map2_sorted Hm Hm') H). - generalize (@find_2 _ m x). - generalize (@find_2 _ m' x). - destruct (find x m); - destruct (find x m'); simpl; intros. - - left; exists e0; auto. - - left; exists e0; auto. - - right; exists e0; auto. - - discriminate. -Qed. - -End Elt3. -End Raw. - -Module Make (X: OrderedType) <: S with Module E := X. -Module Raw := Raw X. -Module E := X. - -Definition key := E.t. - -Record slist (elt:Type) := - {this :> Raw.t elt; sorted : sort (@Raw.PX.ltk elt) this}. -Definition t (elt:Type) : Type := slist elt. - -Section Elt. - Variable elt elt' elt'':Type. - - Implicit Types m : t elt. - Implicit Types x y : key. - Implicit Types e : elt. - - Definition empty : t elt := Build_slist (Raw.empty_sorted elt). - Definition is_empty m : bool := Raw.is_empty (this m). - Definition add x e m : t elt := Build_slist (Raw.add_sorted (sorted m) x e). - Definition find x m : option elt := Raw.find x (this m). - Definition remove x m : t elt := Build_slist (Raw.remove_sorted (sorted m) x). - Definition mem x m : bool := Raw.mem x (this m). - Definition map f m : t elt' := Build_slist (Raw.map_sorted (sorted m) f). - Definition mapi (f:key->elt->elt') m : t elt' := Build_slist (Raw.mapi_sorted (sorted m) f). - Definition map2 f m (m':t elt') : t elt'' := - Build_slist (Raw.map2_sorted f (sorted m) (sorted m')). - Definition elements m : list (key*elt) := @Raw.elements elt (this m). - Definition cardinal m := length (this m). - Definition fold (A:Type)(f:key->elt->A->A) m (i:A) : A := @Raw.fold elt A f (this m) i. - Definition equal cmp m m' : bool := @Raw.equal elt cmp (this m) (this m'). - - Definition MapsTo x e m : Prop := Raw.PX.MapsTo x e (this m). - Definition In x m : Prop := Raw.PX.In x (this m). - Definition Empty m : Prop := Raw.Empty (this m). - - Definition Equal m m' := forall y, find y m = find y m'. - Definition Equiv (eq_elt:elt->elt->Prop) m m' := - (forall k, In k m <-> In k m') /\ - (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e'). - Definition Equivb cmp m m' : Prop := @Raw.Equivb elt cmp (this m) (this m'). - - Definition eq_key : (key*elt) -> (key*elt) -> Prop := @Raw.PX.eqk elt. - Definition eq_key_elt : (key*elt) -> (key*elt) -> Prop:= @Raw.PX.eqke elt. - Definition lt_key : (key*elt) -> (key*elt) -> Prop := @Raw.PX.ltk elt. - - Lemma MapsTo_1 : forall m x y e, E.eq x y -> MapsTo x e m -> MapsTo y e m. - Proof. intros m; exact (@Raw.PX.MapsTo_eq elt (this m)). Qed. - - Lemma mem_1 : forall m x, In x m -> mem x m = true. - Proof. intros m; exact (@Raw.mem_1 elt (this m) (sorted m)). Qed. - Lemma mem_2 : forall m x, mem x m = true -> In x m. - Proof. intros m; exact (@Raw.mem_2 elt (this m) (sorted m)). Qed. - - Lemma empty_1 : Empty empty. - Proof. exact (@Raw.empty_1 elt). Qed. - - Lemma is_empty_1 : forall m, Empty m -> is_empty m = true. - Proof. intros m; exact (@Raw.is_empty_1 elt (this m)). Qed. - Lemma is_empty_2 : forall m, is_empty m = true -> Empty m. - Proof. intros m; exact (@Raw.is_empty_2 elt (this m)). Qed. - - Lemma add_1 : forall m x y e, E.eq x y -> MapsTo y e (add x e m). - Proof. intros m; exact (@Raw.add_1 elt (this m)). Qed. - Lemma add_2 : forall m x y e e', ~ E.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m). - Proof. intros m; exact (@Raw.add_2 elt (this m)). Qed. - Lemma add_3 : forall m x y e e', ~ E.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m. - Proof. intros m; exact (@Raw.add_3 elt (this m)). Qed. - - Lemma remove_1 : forall m x y, E.eq x y -> ~ In y (remove x m). - Proof. intros m; exact (@Raw.remove_1 elt (this m) (sorted m)). Qed. - Lemma remove_2 : forall m x y e, ~ E.eq x y -> MapsTo y e m -> MapsTo y e (remove x m). - Proof. intros m; exact (@Raw.remove_2 elt (this m) (sorted m)). Qed. - Lemma remove_3 : forall m x y e, MapsTo y e (remove x m) -> MapsTo y e m. - Proof. intros m; exact (@Raw.remove_3 elt (this m) (sorted m)). Qed. - - Lemma find_1 : forall m x e, MapsTo x e m -> find x m = Some e. - Proof. intros m; exact (@Raw.find_1 elt (this m) (sorted m)). Qed. - Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m. - Proof. intros m; exact (@Raw.find_2 elt (this m)). Qed. - - Lemma elements_1 : forall m x e, MapsTo x e m -> InA eq_key_elt (x,e) (elements m). - Proof. intros m; exact (@Raw.elements_1 elt (this m)). Qed. - Lemma elements_2 : forall m x e, InA eq_key_elt (x,e) (elements m) -> MapsTo x e m. - Proof. intros m; exact (@Raw.elements_2 elt (this m)). Qed. - Lemma elements_3 : forall m, sort lt_key (elements m). - Proof. intros m; exact (@Raw.elements_3 elt (this m) (sorted m)). Qed. - Lemma elements_3w : forall m, NoDupA eq_key (elements m). - Proof. intros m; exact (@Raw.elements_3w elt (this m) (sorted m)). Qed. - - Lemma cardinal_1 : forall m, cardinal m = length (elements m). - Proof. intros; reflexivity. Qed. - - Lemma fold_1 : forall m (A : Type) (i : A) (f : key -> elt -> A -> A), - fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i. - Proof. intros m; exact (@Raw.fold_1 elt (this m)). Qed. - - Lemma equal_1 : forall m m' cmp, Equivb cmp m m' -> equal cmp m m' = true. - Proof. intros m m'; exact (@Raw.equal_1 elt (this m) (sorted m) (this m') (sorted m')). Qed. - Lemma equal_2 : forall m m' cmp, equal cmp m m' = true -> Equivb cmp m m'. - Proof. intros m m'; exact (@Raw.equal_2 elt (this m) (sorted m) (this m') (sorted m')). Qed. - - End Elt. - - Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'), - MapsTo x e m -> MapsTo x (f e) (map f m). - Proof. intros elt elt' m; exact (@Raw.map_1 elt elt' (this m)). Qed. - Lemma map_2 : forall (elt elt':Type)(m: t elt)(x:key)(f:elt->elt'), - In x (map f m) -> In x m. - Proof. intros elt elt' m; exact (@Raw.map_2 elt elt' (this m)). Qed. - - Lemma mapi_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt) - (f:key->elt->elt'), MapsTo x e m -> - exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m). - Proof. intros elt elt' m; exact (@Raw.mapi_1 elt elt' (this m)). Qed. - Lemma mapi_2 : forall (elt elt':Type)(m: t elt)(x:key) - (f:key->elt->elt'), In x (mapi f m) -> In x m. - Proof. intros elt elt' m; exact (@Raw.mapi_2 elt elt' (this m)). Qed. - - Lemma map2_1 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') - (x:key)(f:option elt->option elt'->option elt''), - In x m \/ In x m' -> - find x (map2 f m m') = f (find x m) (find x m'). - Proof. - intros elt elt' elt'' m m' x f; - exact (@Raw.map2_1 elt elt' elt'' f (this m) (sorted m) (this m') (sorted m') x). - Qed. - Lemma map2_2 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') - (x:key)(f:option elt->option elt'->option elt''), - In x (map2 f m m') -> In x m \/ In x m'. - Proof. - intros elt elt' elt'' m m' x f; - exact (@Raw.map2_2 elt elt' elt'' f (this m) (sorted m) (this m') (sorted m') x). - Qed. - -End Make. - -Module Make_ord (X: OrderedType)(D : OrderedType) <: -Sord with Module Data := D - with Module MapS.E := X. - -Module Data := D. -Module MapS := Make(X). -Import MapS. - -Module MD := OrderedTypeFacts(D). -Import MD. - -Definition t := MapS.t D.t. - -Definition cmp e e' := match D.compare e e' with EQ _ => true | _ => false end. - -Fixpoint eq_list (m m' : list (X.t * D.t)) : Prop := - match m, m' with - | nil, nil => True - | (x,e)::l, (x',e')::l' => - match X.compare x x' with - | EQ _ => D.eq e e' /\ eq_list l l' - | _ => False - end - | _, _ => False - end. - -Definition eq m m' := eq_list (this m) (this m'). - -Fixpoint lt_list (m m' : list (X.t * D.t)) : Prop := - match m, m' with - | nil, nil => False - | nil, _ => True - | _, nil => False - | (x,e)::l, (x',e')::l' => - match X.compare x x' with - | LT _ => True - | GT _ => False - | EQ _ => D.lt e e' \/ (D.eq e e' /\ lt_list l l') - end - end. - -Definition lt m m' := lt_list (this m) (this m'). - -Lemma eq_equal : forall m m', eq m m' <-> equal cmp m m' = true. -Proof. - intros (l,Hl); induction l. - - intros (l',Hl'); unfold eq; simpl. - destruct l'; unfold equal; simpl; intuition auto with bool. - - intros (l',Hl'); unfold eq. - destruct l'. - + destruct a; unfold equal; simpl; intuition auto with bool. - + destruct a as (x,e). - destruct p as (x',e'). - unfold equal; simpl. - destruct (X.compare x x') as [Hlt|Heq|Hlt]; simpl; intuition auto with bool. - * unfold cmp at 1. - MD.elim_comp; clear H; simpl. - inversion_clear Hl. - inversion_clear Hl'. - destruct (IHl H (Build_slist H3)). - unfold equal, eq in H5; simpl in H5; auto. - * destruct (andb_prop _ _ H); clear H. - generalize H0; unfold cmp. - MD.elim_comp; auto; intro; discriminate. - * destruct (andb_prop _ _ H); clear H. - inversion_clear Hl. - inversion_clear Hl'. - destruct (IHl H (Build_slist H3)). - unfold equal, eq in H6; simpl in H6; auto. -Qed. - -Lemma eq_1 : forall m m', Equivb cmp m m' -> eq m m'. -Proof. - intros. - generalize (@equal_1 D.t m m' cmp). - generalize (@eq_equal m m'). - intuition. -Qed. - -Lemma eq_2 : forall m m', eq m m' -> Equivb cmp m m'. -Proof. - intros. - generalize (@equal_2 D.t m m' cmp). - generalize (@eq_equal m m'). - intuition. -Qed. - -Lemma eq_refl : forall m : t, eq m m. -Proof. - intros (m,Hm); induction m; unfold eq; simpl; auto. - destruct a. - destruct (X.compare t0 t0) as [Hlt|Heq|Hlt]; auto. - - apply (MapS.Raw.MX.lt_antirefl Hlt); auto. - - split. - + apply D.eq_refl. - + inversion_clear Hm. - apply (IHm H). - - apply (MapS.Raw.MX.lt_antirefl Hlt); auto. -Qed. - -Lemma eq_sym : forall m1 m2 : t, eq m1 m2 -> eq m2 m1. -Proof. - intros (m,Hm); induction m; - intros (m', Hm'); destruct m'; unfold eq; simpl; - try destruct a as (x,e); try destruct p as (x',e'); auto. - destruct (X.compare x x') as [Hlt|Heq|Hlt]; MapS.Raw.MX.elim_comp; intuition auto with ordered_type. - inversion_clear Hm; inversion_clear Hm'. - apply (IHm H0 (Build_slist H4)); auto. -Qed. - -Lemma eq_trans : forall m1 m2 m3 : t, eq m1 m2 -> eq m2 m3 -> eq m1 m3. -Proof. - intros (m1,Hm1); induction m1; - intros (m2, Hm2); destruct m2; - intros (m3, Hm3); destruct m3; unfold eq; simpl; - try destruct a as (x,e); - try destruct p as (x',e'); - try destruct p0 as (x'',e''); try contradiction; auto. - destruct (X.compare x x') as [Hlt|Heq|Hlt]; - destruct (X.compare x' x'') as [Hlt'|Heq'|Hlt']; - MapS.Raw.MX.elim_comp; intuition. - - apply D.eq_trans with e'; auto. - - inversion_clear Hm1; inversion_clear Hm2; inversion_clear Hm3. - apply (IHm1 H1 (Build_slist H6) (Build_slist H8)); intuition. -Qed. - -Lemma lt_trans : forall m1 m2 m3 : t, lt m1 m2 -> lt m2 m3 -> lt m1 m3. -Proof. - intros (m1,Hm1); induction m1; - intros (m2, Hm2); destruct m2; - intros (m3, Hm3); destruct m3; unfold lt; simpl; - try destruct a as (x,e); - try destruct p as (x',e'); - try destruct p0 as (x'',e''); try contradiction; auto. - destruct (X.compare x x') as [Hlt|Heq|Hlt]; - destruct (X.compare x' x'') as [Hlt'|Heq'|Hlt']; - MapS.Raw.MX.elim_comp; intuition. - - left; apply D.lt_trans with e'; auto. - - left; apply lt_eq with e'; auto. - - left; apply eq_lt with e'; auto. - - right. - split. - + apply D.eq_trans with e'; auto. - + inversion_clear Hm1; inversion_clear Hm2; inversion_clear Hm3. - apply (IHm1 H2 (Build_slist H6) (Build_slist H8)); intuition. -Qed. - -Lemma lt_not_eq : forall m1 m2 : t, lt m1 m2 -> ~ eq m1 m2. -Proof. - intros (m1,Hm1); induction m1; - intros (m2, Hm2); destruct m2; unfold eq, lt; simpl; - try destruct a as (x,e); - try destruct p as (x',e'); try contradiction; auto. - destruct (X.compare x x') as [Hlt|Heq|Hlt]; auto. - intuition. - - exact (D.lt_not_eq H0 H1). - - inversion_clear Hm1; inversion_clear Hm2. - apply (IHm1 H0 (Build_slist H5)); intuition. -Qed. - -Ltac cmp_solve := unfold eq, lt; simpl; try Raw.MX.elim_comp; auto with ordered_type. - -Definition compare : forall m1 m2, Compare lt eq m1 m2. -Proof. - intros (m1,Hm1); induction m1; - intros (m2, Hm2); destruct m2; - [ apply EQ | apply LT | apply GT | ]; cmp_solve. - destruct a as (x,e); destruct p as (x',e'). - destruct (X.compare x x'); - [ apply LT | | apply GT ]; cmp_solve. - destruct (D.compare e e'); - [ apply LT | | apply GT ]; cmp_solve. - assert (Hm11 : sort (Raw.PX.ltk (elt:=D.t)) m1). - - inversion_clear Hm1; auto. - - assert (Hm22 : sort (Raw.PX.ltk (elt:=D.t)) m2). - { inversion_clear Hm2; auto. } - destruct (IHm1 Hm11 (Build_slist Hm22)); - [ apply LT | apply EQ | apply GT ]; cmp_solve. -Qed. - -End Make_ord. diff --git a/stdlib/theories/FSets/FMapPositive.v b/stdlib/theories/FSets/FMapPositive.v deleted file mode 100644 index efe38348f045..000000000000 --- a/stdlib/theories/FSets/FMapPositive.v +++ /dev/null @@ -1,1128 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* j - | xI ii => xI (append ii j) - | xO ii => xO (append ii j) - end. - -Lemma append_assoc_0 : - forall (i j : positive), append i (xO j) = append (append i (xO xH)) j. -Proof. - induction i; intros; destruct j; simpl; - try rewrite (IHi (xI j)); - try rewrite (IHi (xO j)); - try rewrite <- (IHi xH); - auto. -Qed. - -Lemma append_assoc_1 : - forall (i j : positive), append i (xI j) = append (append i (xI xH)) j. -Proof. - induction i; intros; destruct j; simpl; - try rewrite (IHi (xI j)); - try rewrite (IHi (xO j)); - try rewrite <- (IHi xH); - auto. -Qed. - -Lemma append_neutral_r : forall (i : positive), append i xH = i. -Proof. - induction i; simpl; congruence. -Qed. - -Lemma append_neutral_l : forall (i : positive), append xH i = i. -Proof. - simpl; auto. -Qed. - - -(** The module of maps over positive keys *) - -Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. - - Module E:=PositiveOrderedTypeBits. - Module ME:=KeyOrderedType E. - - Definition key := positive : Type. - - #[universes(template)] - Inductive tree (A : Type) := - | Leaf : tree A - | Node : tree A -> option A -> tree A -> tree A. - - Scheme tree_ind := Induction for tree Sort Prop. - - Definition t := tree. - - Section A. - Variable A:Type. - - Arguments Leaf {A}. - - Definition empty : t A := Leaf. - - Fixpoint is_empty (m : t A) : bool := - match m with - | Leaf => true - | Node l None r => (is_empty l) && (is_empty r) - | _ => false - end. - - Fixpoint find (i : key) (m : t A) : option A := - match m with - | Leaf => None - | Node l o r => - match i with - | xH => o - | xO ii => find ii l - | xI ii => find ii r - end - end. - - Fixpoint mem (i : key) (m : t A) : bool := - match m with - | Leaf => false - | Node l o r => - match i with - | xH => match o with None => false | _ => true end - | xO ii => mem ii l - | xI ii => mem ii r - end - end. - - Fixpoint add (i : key) (v : A) (m : t A) : t A := - match m with - | Leaf => - match i with - | xH => Node Leaf (Some v) Leaf - | xO ii => Node (add ii v Leaf) None Leaf - | xI ii => Node Leaf None (add ii v Leaf) - end - | Node l o r => - match i with - | xH => Node l (Some v) r - | xO ii => Node (add ii v l) o r - | xI ii => Node l o (add ii v r) - end - end. - - Fixpoint remove (i : key) (m : t A) : t A := - match i with - | xH => - match m with - | Leaf => Leaf - | Node Leaf _ Leaf => Leaf - | Node l _ r => Node l None r - end - | xO ii => - match m with - | Leaf => Leaf - | Node l None Leaf => - match remove ii l with - | Leaf => Leaf - | mm => Node mm None Leaf - end - | Node l o r => Node (remove ii l) o r - end - | xI ii => - match m with - | Leaf => Leaf - | Node Leaf None r => - match remove ii r with - | Leaf => Leaf - | mm => Node Leaf None mm - end - | Node l o r => Node l o (remove ii r) - end - end. - - (** [elements] *) - - Fixpoint xelements (m : t A) (i : key) : list (key * A) := - match m with - | Leaf => nil - | Node l None r => - (xelements l (append i (xO xH))) ++ (xelements r (append i (xI xH))) - | Node l (Some x) r => - (xelements l (append i (xO xH))) - ++ ((i, x) :: xelements r (append i (xI xH))) - end. - - (* Note: function [xelements] above is inefficient. We should apply - deforestation to it, but that makes the proofs even harder. *) - - Definition elements (m : t A) := xelements m xH. - - (** [cardinal] *) - - Fixpoint cardinal (m : t A) : nat := - match m with - | Leaf => 0%nat - | Node l None r => (cardinal l + cardinal r)%nat - | Node l (Some _) r => S (cardinal l + cardinal r) - end. - - Section CompcertSpec. - - Theorem gempty: - forall (i: key), find i empty = None. - Proof. - destruct i; simpl; auto. - Qed. - - Theorem gss: - forall (i: key) (x: A) (m: t A), find i (add i x m) = Some x. - Proof. - induction i; destruct m; simpl; auto. - Qed. - - Lemma gleaf : forall (i : key), find i (Leaf : t A) = None. - Proof. exact gempty. Qed. - - Theorem gso: - forall (i j: key) (x: A) (m: t A), - i <> j -> find i (add j x m) = find i m. - Proof. - induction i; intros; destruct j; destruct m; simpl; - try rewrite <- (gleaf i); auto; try apply IHi; congruence. - Qed. - - Lemma rleaf : forall (i : key), remove i Leaf = Leaf. - Proof. destruct i; simpl; auto. Qed. - - Theorem grs: - forall (i: key) (m: t A), find i (remove i m) = None. - Proof. - induction i; destruct m. - - simpl; auto. - - destruct m1; destruct o; destruct m2 as [ | ll oo rr]; simpl; auto. - + rewrite (rleaf i); auto. - + cut (find i (remove i (Node ll oo rr)) = None). - * destruct (remove i (Node ll oo rr)); auto; apply IHi. - * apply IHi. - - simpl; auto. - - destruct m1 as [ | ll oo rr]; destruct o; destruct m2; simpl; auto. - + rewrite (rleaf i); auto. - + cut (find i (remove i (Node ll oo rr)) = None). - * destruct (remove i (Node ll oo rr)); auto; apply IHi. - * apply IHi. - - simpl; auto. - - destruct m1; destruct m2; simpl; auto. - Qed. - - Theorem gro: - forall (i j: key) (m: t A), - i <> j -> find i (remove j m) = find i m. - Proof. - induction i; intros; destruct j; destruct m; - try rewrite (rleaf (xI j)); - try rewrite (rleaf (xO j)); - try rewrite (rleaf 1); auto; - destruct m1; destruct o; destruct m2; - simpl; - try apply IHi; try congruence; - try rewrite (rleaf j); auto; - try rewrite (gleaf i); auto. - - cut (find i (remove j (Node m2_1 o m2_2)) = find i (Node m2_1 o m2_2)); - [ destruct (remove j (Node m2_1 o m2_2)); try rewrite (gleaf i); auto - | apply IHi; congruence ]. - - destruct (remove j (Node m1_1 o0 m1_2)); simpl; try rewrite (gleaf i); - auto. - - destruct (remove j (Node m2_1 o m2_2)); simpl; try rewrite (gleaf i); - auto. - - cut (find i (remove j (Node m1_1 o0 m1_2)) = find i (Node m1_1 o0 m1_2)); - [ destruct (remove j (Node m1_1 o0 m1_2)); try rewrite (gleaf i); auto - | apply IHi; congruence ]. - - destruct (remove j (Node m2_1 o m2_2)); simpl; try rewrite (gleaf i); - auto. - - destruct (remove j (Node m1_1 o0 m1_2)); simpl; try rewrite (gleaf i); - auto. - Qed. - - Lemma xelements_correct: - forall (m: t A) (i j : key) (v: A), - find i m = Some v -> List.In (append j i, v) (xelements m j). - Proof. - induction m; intros. - - rewrite (gleaf i) in H; discriminate. - - destruct o; destruct i; simpl; simpl in H. - + rewrite append_assoc_1; apply in_or_app; right; apply in_cons; - apply IHm2; auto. - + rewrite append_assoc_0; apply in_or_app; left; apply IHm1; auto. - + rewrite append_neutral_r; apply in_or_app; injection H as [= ->]; - right; apply in_eq. - + rewrite append_assoc_1; apply in_or_app; right; apply IHm2; auto. - + rewrite append_assoc_0; apply in_or_app; left; apply IHm1; auto. - + congruence. - Qed. - - Theorem elements_correct: - forall (m: t A) (i: key) (v: A), - find i m = Some v -> List.In (i, v) (elements m). - Proof. - intros m i v H. - exact (xelements_correct m i xH H). - Qed. - - Fixpoint xfind (i j : key) (m : t A) : option A := - match i, j with - | _, xH => find i m - | xO ii, xO jj => xfind ii jj m - | xI ii, xI jj => xfind ii jj m - | _, _ => None - end. - - Lemma xfind_left : - forall (j i : key) (m1 m2 : t A) (o : option A) (v : A), - xfind i (append j (xO xH)) m1 = Some v -> xfind i j (Node m1 o m2) = Some v. - Proof. - induction j; intros; destruct i; simpl; simpl in H; auto; try congruence. - destruct i; simpl in *; auto. - Qed. - - Lemma xelements_ii : - forall (m: t A) (i j : key) (v: A), - List.In (xI i, v) (xelements m (xI j)) -> List.In (i, v) (xelements m j). - Proof. - induction m. - - simpl; auto. - - intros; destruct o; simpl; simpl in H; destruct (in_app_or _ _ _ H); - apply in_or_app. - + left; apply IHm1; auto. - + right; destruct (in_inv H0). - * injection H1 as [= -> ->]; apply in_eq. - * apply in_cons; apply IHm2; auto. - + left; apply IHm1; auto. - + right; apply IHm2; auto. - Qed. - - Lemma xelements_io : - forall (m: t A) (i j : key) (v: A), - ~List.In (xI i, v) (xelements m (xO j)). - Proof. - induction m. - - simpl; auto. - - intros; destruct o; simpl; intro H; destruct (in_app_or _ _ _ H). - + apply (IHm1 _ _ _ H0). - + destruct (in_inv H0). - * congruence. - * apply (IHm2 _ _ _ H1). - + apply (IHm1 _ _ _ H0). - + apply (IHm2 _ _ _ H0). - Qed. - - Lemma xelements_oo : - forall (m: t A) (i j : key) (v: A), - List.In (xO i, v) (xelements m (xO j)) -> List.In (i, v) (xelements m j). - Proof. - induction m. - - simpl; auto. - - intros; destruct o; simpl; simpl in H; destruct (in_app_or _ _ _ H); - apply in_or_app. - + left; apply IHm1; auto. - + right; destruct (in_inv H0). - * injection H1 as [= -> ->]; apply in_eq. - * apply in_cons; apply IHm2; auto. - + left; apply IHm1; auto. - + right; apply IHm2; auto. - Qed. - - Lemma xelements_oi : - forall (m: t A) (i j : key) (v: A), - ~List.In (xO i, v) (xelements m (xI j)). - Proof. - induction m. - - simpl; auto. - - intros; destruct o; simpl; intro H; destruct (in_app_or _ _ _ H). - + apply (IHm1 _ _ _ H0). - + destruct (in_inv H0). - * congruence. - * apply (IHm2 _ _ _ H1). - + apply (IHm1 _ _ _ H0). - + apply (IHm2 _ _ _ H0). - Qed. - - Lemma xelements_ih : - forall (m1 m2: t A) (o: option A) (i : key) (v: A), - List.In (xI i, v) (xelements (Node m1 o m2) xH) -> List.In (i, v) (xelements m2 xH). - Proof. - destruct o; simpl; intros; destruct (in_app_or _ _ _ H). - - absurd (List.In (xI i, v) (xelements m1 2)); auto; apply xelements_io; auto. - - destruct (in_inv H0). - + congruence. - + apply xelements_ii; auto. - - absurd (List.In (xI i, v) (xelements m1 2)); auto; apply xelements_io; auto. - - apply xelements_ii; auto. - Qed. - - Lemma xelements_oh : - forall (m1 m2: t A) (o: option A) (i : key) (v: A), - List.In (xO i, v) (xelements (Node m1 o m2) xH) -> List.In (i, v) (xelements m1 xH). - Proof. - destruct o; simpl; intros; destruct (in_app_or _ _ _ H). - - apply xelements_oo; auto. - - destruct (in_inv H0). - + congruence. - + absurd (List.In (xO i, v) (xelements m2 3)); auto; apply xelements_oi; auto. - - apply xelements_oo; auto. - - absurd (List.In (xO i, v) (xelements m2 3)); auto; apply xelements_oi; auto. - Qed. - - Lemma xelements_hi : - forall (m: t A) (i : key) (v: A), - ~List.In (xH, v) (xelements m (xI i)). - Proof. - induction m; intros. - - simpl; auto. - - destruct o; simpl; intro H; destruct (in_app_or _ _ _ H). - + generalize H0; apply IHm1; auto. - + destruct (in_inv H0). - * congruence. - * generalize H1; apply IHm2; auto. - + generalize H0; apply IHm1; auto. - + generalize H0; apply IHm2; auto. - Qed. - - Lemma xelements_ho : - forall (m: t A) (i : key) (v: A), - ~List.In (xH, v) (xelements m (xO i)). - Proof. - induction m; intros. - - simpl; auto. - - destruct o; simpl; intro H; destruct (in_app_or _ _ _ H). - + generalize H0; apply IHm1; auto. - + destruct (in_inv H0). - * congruence. - * generalize H1; apply IHm2; auto. - + generalize H0; apply IHm1; auto. - + generalize H0; apply IHm2; auto. - Qed. - - Lemma find_xfind_h : - forall (m: t A) (i: key), find i m = xfind i xH m. - Proof. - destruct i; simpl; auto. - Qed. - - Lemma xelements_complete: - forall (i j : key) (m: t A) (v: A), - List.In (i, v) (xelements m j) -> xfind i j m = Some v. - Proof. - induction i; simpl; intros; destruct j; simpl. - - apply IHi; apply xelements_ii; auto. - - absurd (List.In (xI i, v) (xelements m (xO j))); auto; apply xelements_io. - - destruct m. - + simpl in H; tauto. - + rewrite find_xfind_h. apply IHi. apply (xelements_ih _ _ _ _ _ H). - - absurd (List.In (xO i, v) (xelements m (xI j))); auto; apply xelements_oi. - - apply IHi; apply xelements_oo; auto. - - destruct m. - + simpl in H; tauto. - + rewrite find_xfind_h. apply IHi. apply (xelements_oh _ _ _ _ _ H). - - absurd (List.In (xH, v) (xelements m (xI j))); auto; apply xelements_hi. - - absurd (List.In (xH, v) (xelements m (xO j))); auto; apply xelements_ho. - - destruct m. - + simpl in H; tauto. - + destruct o; simpl in H; destruct (in_app_or _ _ _ H). - * absurd (List.In (xH, v) (xelements m1 (xO xH))); auto; apply xelements_ho. - * destruct (in_inv H0). - -- congruence. - -- absurd (List.In (xH, v) (xelements m2 (xI xH))); auto; apply xelements_hi. - * absurd (List.In (xH, v) (xelements m1 (xO xH))); auto; apply xelements_ho. - * absurd (List.In (xH, v) (xelements m2 (xI xH))); auto; apply xelements_hi. - Qed. - - Theorem elements_complete: - forall (m: t A) (i: key) (v: A), - List.In (i, v) (elements m) -> find i m = Some v. - Proof. - intros m i v H. - unfold elements in H. - rewrite find_xfind_h. - exact (xelements_complete i xH m v H). - Qed. - - Lemma cardinal_1 : - forall (m: t A), cardinal m = length (elements m). - Proof. - unfold elements. - intros m; set (p:=1); clearbody p; revert m p. - induction m; simpl; auto; intros. - rewrite (IHm1 (append p 2)), (IHm2 (append p 3)). - destruct o; rewrite length_app; simpl; auto. - Qed. - - End CompcertSpec. - - Definition MapsTo (i:key)(v:A)(m:t A) := find i m = Some v. - - Definition In (i:key)(m:t A) := exists e:A, MapsTo i e m. - - Definition Empty m := forall (a : key)(e:A) , ~ MapsTo a e m. - - Definition eq_key (p p':key*A) := E.eq (fst p) (fst p'). - - Definition eq_key_elt (p p':key*A) := - E.eq (fst p) (fst p') /\ (snd p) = (snd p'). - - Definition lt_key (p p':key*A) := E.lt (fst p) (fst p'). - - Global Instance eqk_equiv : Equivalence eq_key := _. - Global Instance eqke_equiv : Equivalence eq_key_elt := _. - Global Instance ltk_strorder : StrictOrder lt_key := _. - - Lemma mem_find : - forall m x, mem x m = match find x m with None => false | _ => true end. - Proof. - induction m; destruct x; simpl; auto. - Qed. - - Lemma Empty_alt : forall m, Empty m <-> forall a, find a m = None. - Proof. - unfold Empty, MapsTo. - intuition. - - generalize (H a). - destruct (find a m); intuition. - elim (H0 a0); auto. - - rewrite H in H0; discriminate. - Qed. - - Lemma Empty_Node : forall l o r, Empty (Node l o r) <-> o=None /\ Empty l /\ Empty r. - Proof. - intros l o r. - split. - - rewrite Empty_alt. - split. - + destruct o; auto. - generalize (H 1); simpl; auto. - + split; rewrite Empty_alt; intros. - * generalize (H (xO a)); auto. - * generalize (H (xI a)); auto. - - intros (H,(H0,H1)). - subst. - rewrite Empty_alt; intros. - destruct a; auto. - + simpl; generalize H1; rewrite Empty_alt; auto. - + simpl; generalize H0; rewrite Empty_alt; auto. - Qed. - - Section FMapSpec. - - Lemma mem_1 : forall m x, In x m -> mem x m = true. - Proof. - unfold In, MapsTo; intros m x; rewrite mem_find. - destruct 1 as (e0,H0); rewrite H0; auto. - Qed. - - Lemma mem_2 : forall m x, mem x m = true -> In x m. - Proof. - unfold In, MapsTo; intros m x; rewrite mem_find. - destruct (find x m). - - exists a; auto. - - intros; discriminate. - Qed. - - Variable m m' m'' : t A. - Variable x y z : key. - Variable e e' : A. - - Lemma MapsTo_1 : E.eq x y -> MapsTo x e m -> MapsTo y e m. - Proof. intros; rewrite <- H; auto. Qed. - - Lemma find_1 : MapsTo x e m -> find x m = Some e. - Proof. unfold MapsTo; auto. Qed. - - Lemma find_2 : find x m = Some e -> MapsTo x e m. - Proof. red; auto. Qed. - - Lemma empty_1 : Empty empty. - Proof. - rewrite Empty_alt; apply gempty. - Qed. - - Lemma is_empty_1 : Empty m -> is_empty m = true. - Proof. - induction m; simpl; auto. - rewrite Empty_Node. - intros (H,(H0,H1)). - subst; simpl. - rewrite IHt0_1; simpl; auto. - Qed. - - Lemma is_empty_2 : is_empty m = true -> Empty m. - Proof. - induction m; simpl; auto. - - rewrite Empty_alt. - intros _; exact gempty. - - rewrite Empty_Node. - destruct o. - + intros; discriminate. - + intro H; destruct (andb_prop _ _ H); intuition. - Qed. - - Lemma add_1 : E.eq x y -> MapsTo y e (add x e m). - Proof. - unfold MapsTo. - intro H; rewrite H; clear H. - apply gss. - Qed. - - Lemma add_2 : ~ E.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m). - Proof. - unfold MapsTo. - intros; rewrite gso; auto. - Qed. - - Lemma add_3 : ~ E.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m. - Proof. - unfold MapsTo. - intro H; rewrite gso; auto. - Qed. - - Lemma remove_1 : E.eq x y -> ~ In y (remove x m). - Proof. - intros; intro. - generalize (mem_1 H0). - rewrite mem_find. - red in H. - rewrite H. - rewrite grs. - intros; discriminate. - Qed. - - Lemma remove_2 : ~ E.eq x y -> MapsTo y e m -> MapsTo y e (remove x m). - Proof. - unfold MapsTo. - intro H; rewrite gro; auto. - Qed. - - Lemma remove_3 : MapsTo y e (remove x m) -> MapsTo y e m. - Proof. - unfold MapsTo. - destruct (E.eq_dec x y). - - subst. - rewrite grs; intros; discriminate. - - rewrite gro; auto. - Qed. - - Lemma elements_1 : - MapsTo x e m -> InA eq_key_elt (x,e) (elements m). - Proof. - unfold MapsTo. - rewrite InA_alt. - intro H. - exists (x,e). - split. - - red; simpl; unfold E.eq; auto. - - apply elements_correct; auto. - Qed. - - Lemma elements_2 : - InA eq_key_elt (x,e) (elements m) -> MapsTo x e m. - Proof. - unfold MapsTo. - rewrite InA_alt. - intros ((e0,a),(H,H0)). - red in H; simpl in H; unfold E.eq in H; destruct H; subst. - apply elements_complete; auto. - Qed. - - Lemma xelements_bits_lt_1 : forall p p0 q m v, - List.In (p0,v) (xelements m (append p (xO q))) -> E.bits_lt p0 p. - Proof using. - intros. - generalize (xelements_complete _ _ _ _ H); clear H; intros. - revert p0 H. - induction p; destruct p0; simpl; intros; eauto; try discriminate. - Qed. - - Lemma xelements_bits_lt_2 : forall p p0 q m v, - List.In (p0,v) (xelements m (append p (xI q))) -> E.bits_lt p p0. - Proof using. - intros. - generalize (xelements_complete _ _ _ _ H); clear H; intros. - revert p0 H. - induction p; destruct p0; simpl; intros; eauto; try discriminate. - Qed. - - Lemma xelements_sort : forall p, sort lt_key (xelements m p). - Proof. - induction m. - - simpl; auto. - - destruct o; simpl; intros. - + (* Some *) - apply (SortA_app (eqA:=eq_key_elt)). 1-2: auto with typeclass_instances. - * constructor; auto. - apply In_InfA; intros. - destruct y0. - red; red; simpl. - eapply xelements_bits_lt_2; eauto. - * intros x0 y0. - do 2 rewrite InA_alt. - intros (y1,(Hy1,H)) (y2,(Hy2,H0)). - destruct y1; destruct x0; compute in Hy1; destruct Hy1; subst. - destruct y2; destruct y0; compute in Hy2; destruct Hy2; subst. - red; red; simpl. - destruct H0. - -- injection H0 as [= H0 _]; subst. - eapply xelements_bits_lt_1; eauto. - -- apply E.bits_lt_trans with p. - ++ eapply xelements_bits_lt_1; eauto. - ++ eapply xelements_bits_lt_2; eauto. - + (* None *) - 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)). - destruct y1; destruct x0; compute in Hy1; destruct Hy1; subst. - destruct y2; destruct y0; compute in Hy2; destruct Hy2; subst. - red; red; simpl. - apply E.bits_lt_trans with p. - * eapply xelements_bits_lt_1; eauto. - * eapply xelements_bits_lt_2; eauto. - Qed. - - Lemma elements_3 : sort lt_key (elements m). - Proof. - unfold elements. - apply xelements_sort; auto. - Qed. - - Lemma elements_3w : NoDupA eq_key (elements m). - Proof. - apply ME.Sort_NoDupA. - apply elements_3. - Qed. - - End FMapSpec. - - (** [map] and [mapi] *) - - Variable B : Type. - - Section Mapi. - - Variable f : key -> A -> B. - - Fixpoint xmapi (m : t A) (i : key) : t B := - match m with - | Leaf => @Leaf B - | Node l o r => Node (xmapi l (append i (xO xH))) - (option_map (f i) o) - (xmapi r (append i (xI xH))) - end. - - Definition mapi m := xmapi m xH. - - End Mapi. - - Definition map (f : A -> B) m := mapi (fun _ => f) m. - - End A. - - Lemma xgmapi: - forall (A B: Type) (f: key -> A -> B) (i j : key) (m: t A), - find i (xmapi f m j) = option_map (f (append j i)) (find i m). - Proof. - induction i; intros; destruct m; simpl; auto. - - rewrite (append_assoc_1 j i); apply IHi. - - rewrite (append_assoc_0 j i); apply IHi. - - rewrite (append_neutral_r j); auto. - Qed. - - Theorem gmapi: - forall (A B: Type) (f: key -> A -> B) (i: key) (m: t A), - find i (mapi f m) = option_map (f i) (find i m). - Proof. - intros. - unfold mapi. - replace (f i) with (f (append xH i)). - - apply xgmapi. - - rewrite append_neutral_l; auto. - Qed. - - Lemma mapi_1 : - forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:key->elt->elt'), - MapsTo x e m -> - exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m). - Proof. - intros. - exists x. - split; [red; auto|]. - apply find_2. - generalize (find_1 H); clear H; intros. - rewrite gmapi. - rewrite H. - simpl; auto. - Qed. - - Lemma mapi_2 : - forall (elt elt':Type)(m: t elt)(x:key)(f:key->elt->elt'), - In x (mapi f m) -> In x m. - Proof. - intros. - apply mem_2. - rewrite mem_find. - destruct H as (v,H). - generalize (find_1 H); clear H; intros. - rewrite gmapi in H. - destruct (find x m); auto. - simpl in *; discriminate. - Qed. - - Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'), - MapsTo x e m -> MapsTo x (f e) (map f m). - Proof. - intros; unfold map. - destruct (mapi_1 (fun _ => f) H); intuition. - Qed. - - Lemma map_2 : forall (elt elt':Type)(m: t elt)(x:key)(f:elt->elt'), - In x (map f m) -> In x m. - Proof. - intros; unfold map in *; eapply mapi_2; eauto. - Qed. - - Section map2. - Variable A B C : Type. - Variable f : option A -> option B -> option C. - - Arguments Leaf {A}. - - Fixpoint xmap2_l (m : t A) : t C := - match m with - | Leaf => Leaf - | Node l o r => Node (xmap2_l l) (f o None) (xmap2_l r) - end. - - Lemma xgmap2_l : forall (i : key) (m : t A), - f None None = None -> find i (xmap2_l m) = f (find i m) None. - Proof. - induction i; intros; destruct m; simpl; auto. - Qed. - - Fixpoint xmap2_r (m : t B) : t C := - match m with - | Leaf => Leaf - | Node l o r => Node (xmap2_r l) (f None o) (xmap2_r r) - end. - - Lemma xgmap2_r : forall (i : key) (m : t B), - f None None = None -> find i (xmap2_r m) = f None (find i m). - Proof. - induction i; intros; destruct m; simpl; auto. - Qed. - - Fixpoint _map2 (m1 : t A)(m2 : t B) : t C := - match m1 with - | Leaf => xmap2_r m2 - | Node l1 o1 r1 => - match m2 with - | Leaf => xmap2_l m1 - | Node l2 o2 r2 => Node (_map2 l1 l2) (f o1 o2) (_map2 r1 r2) - end - end. - - Lemma gmap2: forall (i: key)(m1:t A)(m2: t B), - f None None = None -> - find i (_map2 m1 m2) = f (find i m1) (find i m2). - Proof. - induction i; intros; destruct m1; destruct m2; simpl; auto; - try apply xgmap2_r; try apply xgmap2_l; auto. - Qed. - - End map2. - - Definition map2 (elt elt' elt'':Type)(f:option elt->option elt'->option elt'') := - _map2 (fun o1 o2 => match o1,o2 with None,None => None | _, _ => f o1 o2 end). - - Lemma map2_1 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') - (x:key)(f:option elt->option elt'->option elt''), - In x m \/ In x m' -> - find x (map2 f m m') = f (find x m) (find x m'). - Proof. - intros. - unfold map2. - rewrite gmap2; auto. - generalize (@mem_1 _ m x) (@mem_1 _ m' x). - do 2 rewrite mem_find. - destruct (find x m); simpl; auto. - destruct (find x m'); simpl; auto. - intros. - destruct H; intuition; try discriminate. - Qed. - - Lemma map2_2 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') - (x:key)(f:option elt->option elt'->option elt''), - In x (map2 f m m') -> In x m \/ In x m'. - Proof. - intros. - generalize (mem_1 H); clear H; intros. - rewrite mem_find in H. - unfold map2 in H. - rewrite gmap2 in H; auto. - generalize (@mem_2 _ m x) (@mem_2 _ m' x). - do 2 rewrite mem_find. - destruct (find x m); simpl in *; auto. - destruct (find x m'); simpl in *; auto. - Qed. - - - Section Fold. - - Variables A B : Type. - Variable f : key -> A -> B -> B. - - Fixpoint xfoldi (m : t A) (v : B) (i : key) := - match m with - | Leaf _ => v - | Node l (Some x) r => - xfoldi r (f i x (xfoldi l v (append i 2))) (append i 3) - | Node l None r => - xfoldi r (xfoldi l v (append i 2)) (append i 3) - end. - - Lemma xfoldi_1 : - forall m v i, - xfoldi m v i = fold_left (fun a p => f (fst p) (snd p) a) (xelements m i) v. - Proof. - set (F := fun a p => f (fst p) (snd p) a). - induction m; intros; simpl; auto. - destruct o. - - rewrite fold_left_app; simpl. - rewrite <- IHm1. - rewrite <- IHm2. - unfold F; simpl; reflexivity. - - rewrite fold_left_app; simpl. - rewrite <- IHm1. - rewrite <- IHm2. - reflexivity. - Qed. - - Definition fold m i := xfoldi m i 1. - - End Fold. - - Lemma fold_1 : - forall (A:Type)(m:t A)(B:Type)(i : B) (f : key -> A -> B -> B), - fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i. - Proof. - intros; unfold fold, elements. - rewrite xfoldi_1; reflexivity. - Qed. - - Fixpoint equal (A:Type)(cmp : A -> A -> bool)(m1 m2 : t A) : bool := - match m1, m2 with - | Leaf _, _ => is_empty m2 - | _, Leaf _ => is_empty m1 - | Node l1 o1 r1, Node l2 o2 r2 => - (match o1, o2 with - | None, None => true - | Some v1, Some v2 => cmp v1 v2 - | _, _ => false - end) - && equal cmp l1 l2 && equal cmp r1 r2 - end. - - Definition Equal (A:Type)(m m':t A) := - forall y, find y m = find y m'. - Definition Equiv (A:Type)(eq_elt:A->A->Prop) m m' := - (forall k, In k m <-> In k m') /\ - (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e'). - Definition Equivb (A:Type)(cmp: A->A->bool) := Equiv (Cmp cmp). - - Lemma equal_1 : forall (A:Type)(m m':t A)(cmp:A->A->bool), - Equivb cmp m m' -> equal cmp m m' = true. - Proof. - induction m. - - (* m = Leaf *) - destruct 1. - simpl. - apply is_empty_1. - red; red; intros. - assert (In a (Leaf A)). - + rewrite H. - exists e; auto. - + destruct H2; red in H2. - destruct a; simpl in *; discriminate. - - (* m = Node *) - destruct m'. - + (* m' = Leaf *) - destruct 1. - simpl. - destruct o. - * assert (In xH (Leaf A)). - { rewrite <- H. - exists a; red; auto. } - destruct H1; red in H1; simpl in H1; discriminate. - * apply andb_true_intro; split; apply is_empty_1; red; red; intros. - -- assert (In (xO a) (Leaf A)). { - rewrite <- H. - exists e; auto. - } - destruct H2; red in H2; simpl in H2; discriminate. - -- assert (In (xI a) (Leaf A)). { - rewrite <- H. - exists e; auto. - } - destruct H2; red in H2; simpl in H2; discriminate. - + (* m' = Node *) - destruct 1. - assert (Equivb cmp m1 m'1). { - split. - - intros k; generalize (H (xO k)); unfold In, MapsTo; simpl; auto. - - intros k e e'; generalize (H0 (xO k) e e'); unfold In, MapsTo; simpl; auto. - } - assert (Equivb cmp m2 m'2). { - split. - - intros k; generalize (H (xI k)); unfold In, MapsTo; simpl; auto. - - intros k e e'; generalize (H0 (xI k) e e'); unfold In, MapsTo; simpl; auto. - } - simpl. - destruct o; destruct o0; simpl. - * repeat (apply andb_true_intro; split); auto. - apply (H0 xH); red; auto. - * generalize (H xH); unfold In, MapsTo; simpl; intuition. - destruct H4; try discriminate; eauto. - * generalize (H xH); unfold In, MapsTo; simpl; intuition. - destruct H5; try discriminate; eauto. - * apply andb_true_intro; split; auto. - Qed. - - Lemma equal_2 : forall (A:Type)(m m':t A)(cmp:A->A->bool), - equal cmp m m' = true -> Equivb cmp m m'. - Proof. - induction m. - - (* m = Leaf *) - simpl. - split; intros. - + split. - * destruct 1; red in H0; destruct k; discriminate. - * destruct 1; elim (is_empty_2 H H0). - + red in H0; destruct k; discriminate. - - (* m = Node *) - destruct m'. - + (* m' = Leaf *) - simpl. - destruct o; intros; try discriminate. - destruct (andb_prop _ _ H); clear H. - split; intros. - * split; unfold In, MapsTo; destruct 1. - -- destruct k; simpl in *; try discriminate. - ++ destruct (is_empty_2 H1 (find_2 _ _ H)). - ++ destruct (is_empty_2 H0 (find_2 _ _ H)). - -- destruct k; simpl in *; discriminate. - * unfold In, MapsTo; destruct k; simpl in *; discriminate. - + (* m' = Node *) - destruct o; destruct o0; simpl; intros; try discriminate. - * destruct (andb_prop _ _ H); clear H. - destruct (andb_prop _ _ H0); clear H0. - destruct (IHm1 _ _ H2); clear H2 IHm1. - destruct (IHm2 _ _ H1); clear H1 IHm2. - split; intros. - -- destruct k; unfold In, MapsTo in *; simpl; auto. - split; eauto. - -- destruct k; unfold In, MapsTo in *; simpl in *. - ++ eapply H4; eauto. - ++ eapply H3; eauto. - ++ congruence. - * destruct (andb_prop _ _ H); clear H. - destruct (IHm1 _ _ H0); clear H0 IHm1. - destruct (IHm2 _ _ H1); clear H1 IHm2. - split; intros. - -- destruct k; unfold In, MapsTo in *; simpl; auto. - split; eauto. - -- destruct k; unfold In, MapsTo in *; simpl in *. - ++ eapply H3; eauto. - ++ eapply H2; eauto. - ++ try discriminate. - Qed. - -End PositiveMap. - -(** Here come some additional facts about this implementation. - Most are facts that cannot be derivable from the general interface. *) - - -Module PositiveMapAdditionalFacts. - Import PositiveMap. - - (* Derivable from the Map interface *) - Theorem gsspec: - forall (A:Type)(i j: key) (x: A) (m: t A), - find i (add j x m) = if E.eq_dec i j then Some x else find i m. - Proof. - intros. - destruct (E.eq_dec i j) as [ ->|]; [ apply gss | apply gso; auto ]. - Qed. - - (* Not derivable from the Map interface *) - Theorem gsident: - forall (A:Type)(i: key) (m: t A) (v: A), - find i m = Some v -> add i v m = m. - Proof. - induction i; intros; destruct m; simpl; simpl in H; try congruence. - - rewrite (IHi m2 v H); congruence. - - rewrite (IHi m1 v H); congruence. - Qed. - - Lemma xmap2_lr : - forall (A B : Type)(f g: option A -> option A -> option B)(m : t A), - (forall (i j : option A), f i j = g j i) -> - xmap2_l f m = xmap2_r g m. - Proof. - induction m; intros; simpl; auto. - rewrite IHm1; auto. - rewrite IHm2; auto. - rewrite H; auto. - Qed. - - Theorem map2_commut: - forall (A B: Type) (f g: option A -> option A -> option B), - (forall (i j: option A), f i j = g j i) -> - forall (m1 m2: t A), - _map2 f m1 m2 = _map2 g m2 m1. - Proof. - intros A B f g Eq1. - assert (Eq2: forall (i j: option A), g i j = f j i). - { intros; auto. } - induction m1; intros; destruct m2; simpl; - try rewrite Eq1; - repeat rewrite (xmap2_lr f g); - repeat rewrite (xmap2_lr g f); - auto. - rewrite IHm1_1. - rewrite IHm1_2. - auto. - Qed. - -End PositiveMapAdditionalFacts. diff --git a/stdlib/theories/FSets/FMapWeakList.v b/stdlib/theories/FSets/FMapWeakList.v deleted file mode 100644 index 49f80f8c18ab..000000000000 --- a/stdlib/theories/FSets/FMapWeakList.v +++ /dev/null @@ -1,1008 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* is_empty m = true. -Proof. - unfold Empty, PX.MapsTo. - intros m. - case m;auto. - intros p l inlist. - destruct p. - absurd (InA eqke (t0, e) ((t0, e) :: l));auto. -Qed. - -Lemma is_empty_2 : forall m, is_empty m = true -> Empty m. -Proof. - intros m. - case m;auto. - intros p l abs. - inversion abs. -Qed. - -(** * [mem] *) - -Fixpoint mem (k : key) (s : t elt) {struct s} : bool := - match s with - | nil => false - | (k',_) :: l => if X.eq_dec k k' then true else mem k l - end. - -Lemma mem_1 : forall m (Hm:NoDupA m) x, In x m -> mem x m = true. -Proof. - intros m Hm x; generalize Hm; clear Hm. - induction m; simpl; intros NoDup belong1. - - inversion belong1. inversion H. - - destruct a; destruct X.eq_dec; [reflexivity|]; apply IHm. - + inversion_clear NoDup; assumption. - + inversion_clear belong1; inversion_clear H; [elim n; apply H0|exists x0; auto]. -Qed. - -Lemma mem_2 : forall m (Hm:NoDupA m) x, mem x m = true -> In x m. -Proof. - intros m Hm x; generalize Hm; clear Hm; unfold PX.In,PX.MapsTo. - induction m; intros NoDup hyp; try discriminate; simpl in *. - destruct a, X.eq_dec. - + exists e; constructor; split; [assumption|reflexivity]. - + destruct IHm as [e' He']. - - inversion_clear NoDup; assumption. - - assumption. - - exists e'; auto. -Qed. - -(** * [find] *) - -Fixpoint find (k:key) (s: t elt) {struct s} : option elt := - match s with - | nil => None - | (k',x)::s' => if X.eq_dec k k' then Some x else find k s' - end. - -Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m. -Proof. - intros m x. unfold PX.MapsTo. - induction m; simpl;intros e' eqfind; inversion eqfind; auto. - destruct a, X.eq_dec. - + constructor; split; simpl; congruence. - + constructor 2; apply IHm; assumption. -Qed. - -Lemma find_1 : forall m (Hm:NoDupA m) x e, - MapsTo x e m -> find x m = Some e. -Proof. - intros m; induction m as [|[a e]]; simpl; intros Hdup x e' Hm. - - inversion Hm. - - inversion_clear Hdup. - inversion_clear Hm; destruct X.eq_dec. - + destruct H1; simpl in *; congruence. - + elim n; apply H1. - + elim H; apply InA_eqk with (x,e'); auto. - + apply IHm; auto. -Qed. - -(* Not part of the exported specifications, used later for [combine]. *) - -Lemma find_eq : forall m (Hm:NoDupA m) x x', - X.eq x x' -> find x m = find x' m. -Proof. - induction m; simpl; auto; destruct a; intros. - inversion_clear Hm. - rewrite (IHm H1 x x'); auto. - destruct (X.eq_dec x t0) as [|Hneq]; destruct (X.eq_dec x' t0) as [|?Hneq']; - trivial. - - elim Hneq'; apply X.eq_trans with x; auto. - - elim Hneq; apply X.eq_trans with x'; auto. -Qed. - -(** * [add] *) - -Fixpoint add (k : key) (x : elt) (s : t elt) {struct s} : t elt := - match s with - | nil => (k,x) :: nil - | (k',y) :: l => if X.eq_dec k k' then (k,x)::l else (k',y)::add k x l - end. - -Lemma add_1 : forall m x y e, X.eq x y -> MapsTo y e (add x e m). -Proof. - induction m as [|[a m]]; intros x y e He; simpl in *; auto. - destruct X.eq_dec; [now auto|]. - apply InA_cons_tl, IHm, He. -Qed. - -Lemma add_2 : forall m x y e e', - ~ X.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m). -Proof. - induction m as [|[a m]]; intros x y e e' H Hm; simpl in *. - - inversion_clear Hm. - - inversion_clear Hm; destruct X.eq_dec. - + elim H; apply X.eq_trans with a; [auto|apply X.eq_sym; apply H0]. - + apply InA_cons_hd; apply H0. - + apply InA_cons_tl; assumption. - + apply InA_cons_tl; apply IHm; auto. -Qed. - -Lemma add_3 : forall m x y e e', - ~ X.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m. -Proof. - induction m as [|[a m]]; intros x y e e' H Hm. - - exfalso; inversion_clear Hm. - + elim H; apply X.eq_sym; apply H0. - + inversion_clear H0. - - simpl in Hm; destruct X.eq_dec. - + apply InA_cons_tl; apply InA_cons in Hm; destruct Hm; [|now auto]. - elim H; apply X.eq_sym; apply H0. - + apply InA_cons in Hm; destruct Hm. - * apply InA_cons_hd; auto. - * apply InA_cons_tl; eapply IHm; eauto. -Qed. - -Lemma add_3' : forall m x y e e', - ~ X.eq x y -> InA eqk (y,e) (add x e' m) -> InA eqk (y,e) m. -Proof. - induction m as [|[a m]]; intros x y e e' H Hm; simpl in *. - - inversion_clear Hm; [|now auto]. - compute in H0; elim H; auto. - - destruct X.eq_dec; simpl in *. - + apply InA_cons in Hm; destruct Hm; [elim H; apply X.eq_sym; apply H0|]. - apply InA_cons_tl; auto. - + apply InA_cons in Hm; destruct Hm; [apply InA_cons_hd; auto|]. - apply InA_cons_tl; eapply IHm; eauto. -Qed. - -Lemma add_NoDup : forall m (Hm:NoDupA m) x e, NoDupA (add x e m). -Proof. - induction m. - - simpl; constructor; auto; red; inversion 1. - - intros. - destruct a as (x',e'). - simpl; case (X.eq_dec x x'); inversion_clear Hm; auto. - + constructor; auto. - contradict H. - apply InA_eqk with (x,e); auto. - + constructor; auto. - contradict H; apply add_3' with x e; auto. -Qed. - -(* Not part of the exported specifications, used later for [combine]. *) - -Lemma add_eq : forall m (Hm:NoDupA m) x a e, - X.eq x a -> find x (add a e m) = Some e. -Proof. - intros. - apply find_1; auto. - - apply add_NoDup; auto. - - apply add_1; auto. -Qed. - -Lemma add_not_eq : forall m (Hm:NoDupA m) x a e, - ~X.eq x a -> find x (add a e m) = find x m. -Proof. - intros. - case_eq (find x m); intros. - - apply find_1; auto. - + apply add_NoDup; auto. - + apply add_2; auto. - apply find_2; auto. - - case_eq (find x (add a e m)); intros; auto. - rewrite <- H0; symmetry. - apply find_1; auto. - apply add_3 with a e; auto. - apply find_2; auto. -Qed. - - -(** * [remove] *) - -Fixpoint remove (k : key) (s : t elt) {struct s} : t elt := - match s with - | nil => nil - | (k',x) :: l => if X.eq_dec k k' then l else (k',x) :: remove k l - end. - -Lemma remove_1 : forall m (Hm:NoDupA m) x y, X.eq x y -> ~ In y (remove x m). -Proof. - induction m as [|[a m]]; intros Hm x y H; simpl in *. - - - inversion 1; inversion H1. - - - inversion_clear Hm. - destruct X.eq_dec. - + intros [e' ?]; elim H0. - apply InA_eqk with (y, e'). - * apply X.eq_trans with x; [|auto]. - apply X.eq_sym; auto. - * apply InA_eqke_eqk; auto. - + intros [e' H2]; apply InA_cons in H2; destruct H2. - * elim n; apply X.eq_trans with y; [auto|apply H2]. - * elim IHm with x y; auto. - exists e'; auto. -Qed. - -Lemma remove_2 : forall m (Hm:NoDupA m) x y e, - ~ X.eq x y -> MapsTo y e m -> MapsTo y e (remove x m). -Proof. - induction m as [|[a m]]; intros Hm x y e H He; simpl in *. - + inversion_clear He. - + apply InA_cons in He; destruct He, X.eq_dec. - - elim H; apply X.eq_trans with a; [auto|]; apply X.eq_sym; apply H0. - - inversion_clear Hm; apply InA_cons_hd; assumption. - - apply H0. - - inversion_clear Hm. - apply InA_cons; destruct (X.eq_dec y a). - * elim H1; apply InA_eqk with (y, e); [assumption|]; apply InA_eqke_eqk; auto. - * right; apply IHm; auto. -Qed. - -Lemma remove_3 : forall m (Hm:NoDupA m) x y e, - MapsTo y e (remove x m) -> MapsTo y e m. -Proof. - induction m as [|[a m]]; intros Hm x y e H; unfold PX.MapsTo; simpl in *; auto. - destruct X.eq_dec. - - apply InA_cons_tl; apply H. - - inversion_clear Hm; apply InA_cons in H; destruct H; [apply InA_cons_hd; auto|]. - apply InA_cons_tl; apply IHm with x; auto. -Qed. - -Lemma remove_3' : forall m (Hm:NoDupA m) x y e, - InA eqk (y,e) (remove x m) -> InA eqk (y,e) m. -Proof. - induction m as [|[a m]]; intros Hm x y e H; unfold PX.MapsTo; simpl in *. - - inversion_clear H. - - destruct X.eq_dec. - + apply InA_cons_tl; auto. - + apply InA_cons in H; destruct H; [apply InA_cons_hd; auto|]. - inversion_clear Hm; apply InA_cons_tl; apply IHm with x; auto. -Qed. - -Lemma remove_NoDup : forall m (Hm:NoDupA m) x, NoDupA (remove x m). -Proof. - induction m. - - simpl; intuition. - - intros. - inversion_clear Hm. - destruct a as (x',e'). - simpl; case (X.eq_dec x x'); auto. - constructor; auto. - contradict H; apply remove_3' with x; auto. -Qed. - -(** * [elements] *) - -Definition elements (m: t elt) := m. - -Lemma elements_1 : forall m x e, MapsTo x e m -> InA eqke (x,e) (elements m). -Proof. - auto. -Qed. - -Lemma elements_2 : forall m x e, InA eqke (x,e) (elements m) -> MapsTo x e m. -Proof. -auto. -Qed. - -Lemma elements_3w : forall m (Hm:NoDupA m), NoDupA (elements m). -Proof. - auto. -Qed. - -(** * [fold] *) - -Fixpoint fold (A:Type)(f:key->elt->A->A)(m:t elt) (acc : A) {struct m} : A := - match m with - | nil => acc - | (k,e)::m' => fold f m' (f k e acc) - end. - -Lemma fold_1 : forall m (A:Type)(i:A)(f:key->elt->A->A), - fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i. -Proof. - induction m as [|[a m]]; intros A i f; simpl; auto. -Qed. - -(** * [equal] *) - -Definition check (cmp : elt -> elt -> bool)(k:key)(e:elt)(m': t elt) := - match find k m' with - | None => false - | Some e' => cmp e e' - end. - -Definition submap (cmp : elt -> elt -> bool)(m m' : t elt) : bool := - fold (fun k e b => andb (check cmp k e m') b) m true. - -Definition equal (cmp : elt -> elt -> bool)(m m' : t elt) : bool := - andb (submap cmp m m') (submap (fun e' e => cmp e e') m' m). - -Definition Submap cmp m m' := - (forall k, In k m -> In k m') /\ - (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true). - -Definition Equivb cmp m m' := - (forall k, In k m <-> In k m') /\ - (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true). - -Lemma submap_1 : forall m (Hm:NoDupA m) m' (Hm': NoDupA m') cmp, - Submap cmp m m' -> submap cmp m m' = true. -Proof. - unfold Submap, submap. - induction m. - - simpl; auto. - - destruct a; simpl; intros. - destruct H. - inversion_clear Hm. - assert (H3 : In t0 m'). - + apply H; exists e; auto. - + destruct H3 as (e', H3). - unfold check at 2; rewrite (find_1 Hm' H3). - rewrite (H0 t0); simpl; auto. - eapply IHm; auto. - split; intuition. - * apply H. - destruct H5 as (e'',H5); exists e''; auto. - * apply H0 with k; auto. -Qed. - -Lemma submap_2 : forall m (Hm:NoDupA m) m' (Hm': NoDupA m') cmp, - submap cmp m m' = true -> Submap cmp m m'. -Proof. - unfold Submap, submap. - induction m. - - simpl; auto. - intuition. - + destruct H0; inversion H0. - + inversion H0. - - - destruct a; simpl; intros. - inversion_clear Hm. - rewrite andb_b_true in H. - assert (check cmp t0 e m' = true). - + clear H1 H0 Hm' IHm. - set (b:=check cmp t0 e m') in *. - generalize H; clear H; generalize b; clear b. - induction m; simpl; auto; intros. - destruct a; simpl in *. - destruct (andb_prop _ _ (IHm _ H)); auto. - + rewrite H2 in H. - destruct (IHm H1 m' Hm' cmp H); auto. - unfold check in H2. - case_eq (find t0 m'); [intros e' H5 | intros H5]; - rewrite H5 in H2; try discriminate. - split; intros. - * destruct H6 as (e0,H6); inversion_clear H6. - -- compute in H7; destruct H7; subst. - exists e'. - apply PX.MapsTo_eq with t0; auto. - apply find_2; auto. - -- apply H3. - exists e0; auto. - * inversion_clear H6. - -- compute in H8; destruct H8; subst. - rewrite (find_1 Hm' (PX.MapsTo_eq H6 H7)) in H5; congruence. - -- apply H4 with k; auto. -Qed. - -(** Specification of [equal] *) - -Lemma equal_1 : forall m (Hm:NoDupA m) m' (Hm': NoDupA m') cmp, - Equivb cmp m m' -> equal cmp m m' = true. -Proof. - unfold Equivb, equal. - intuition. - apply andb_true_intro; split; apply submap_1; unfold Submap; firstorder. -Qed. - -Lemma equal_2 : forall m (Hm:NoDupA m) m' (Hm':NoDupA m') cmp, - equal cmp m m' = true -> Equivb cmp m m'. -Proof. - unfold Equivb, equal. - intros. - destruct (andb_prop _ _ H); clear H. - generalize (submap_2 Hm Hm' H0). - generalize (submap_2 Hm' Hm H1). - firstorder. -Qed. - -Variable elt':Type. - -(** * [map] and [mapi] *) - -Fixpoint map (f:elt -> elt') (m:t elt) : t elt' := - match m with - | nil => nil - | (k,e)::m' => (k,f e) :: map f m' - end. - -Fixpoint mapi (f: key -> elt -> elt') (m:t elt) : t elt' := - match m with - | nil => nil - | (k,e)::m' => (k,f k e) :: mapi f m' - end. - -End Elt. -Section Elt2. -(* A new section is necessary for previous definitions to work - with different [elt], especially [MapsTo]... *) - -Variable elt elt' : Type. - -(** Specification of [map] *) - -Lemma map_1 : forall (m:t elt)(x:key)(e:elt)(f:elt->elt'), - MapsTo x e m -> MapsTo x (f e) (map f m). -Proof. - intros m x e f. - (* functional induction map elt elt' f m. *) (* Marche pas ??? *) - induction m. - - inversion 1. - - - destruct a as (x',e'). - simpl. - inversion_clear 1. - + constructor 1. - unfold eqke in *; simpl in *; intuition congruence. - + constructor 2. - unfold MapsTo in *; auto. -Qed. - -Lemma map_2 : forall (m:t elt)(x:key)(f:elt->elt'), - In x (map f m) -> In x m. -Proof. - intros m x f. - (* functional induction map elt elt' f m. *) (* Marche pas ??? *) - induction m; simpl. - - intros (e,abs). - inversion abs. - - - destruct a as (x',e). - intros hyp. - inversion hyp. clear hyp. - inversion H; subst; rename x0 into e'. - + exists e; constructor. - unfold eqke in *; simpl in *; intuition. - + destruct IHm as (e'',hyp). - * exists e'; auto. - * exists e''. - constructor 2; auto. -Qed. - -Lemma map_NoDup : forall m (Hm : NoDupA (@eqk elt) m)(f:elt->elt'), - NoDupA (@eqk elt') (map f m). -Proof. - induction m; simpl; auto. - intros. - destruct a as (x',e'). - inversion_clear Hm. - constructor; auto. - contradict H. - (* il faut un map_1 avec eqk au lieu de eqke *) - clear IHm H0. - induction m; simpl in *; auto. - - inversion H. - - destruct a; inversion H; auto. -Qed. - -(** Specification of [mapi] *) - -Lemma mapi_1 : forall (m:t elt)(x:key)(e:elt)(f:key->elt->elt'), - MapsTo x e m -> - exists y, X.eq y x /\ MapsTo x (f y e) (mapi f m). -Proof. - intros m x e f. - (* functional induction mapi elt elt' f m. *) (* Marche pas ??? *) - induction m. - - inversion 1. - - - destruct a as (x',e'). - simpl. - inversion_clear 1. - + exists x'. - destruct H0; simpl in *. - split; auto. - constructor 1. - unfold eqke in *; simpl in *; intuition congruence. - + destruct IHm as (y, hyp); auto. - exists y; intuition. -Qed. - -Lemma mapi_2 : forall (m:t elt)(x:key)(f:key->elt->elt'), - In x (mapi f m) -> In x m. -Proof. - intros m x f. - (* functional induction mapi elt elt' f m. *) (* Marche pas ??? *) - induction m; simpl. - - intros (e,abs). - inversion abs. - - - destruct a as (x',e). - intros hyp. - inversion hyp. clear hyp. - inversion H; subst; rename x0 into e'. - + exists e; constructor. - unfold eqke in *; simpl in *; intuition. - + destruct IHm as (e'',hyp). - * exists e'; auto. - * exists e''. - constructor 2; auto. -Qed. - -Lemma mapi_NoDup : forall m (Hm : NoDupA (@eqk elt) m)(f: key->elt->elt'), - NoDupA (@eqk elt') (mapi f m). -Proof. - induction m; simpl; auto. - intros. - destruct a as (x',e'). - inversion_clear Hm; auto. - constructor; auto. - contradict H. - clear IHm H0. - induction m; simpl in *; auto. - - inversion_clear H. - - destruct a; inversion_clear H; auto. -Qed. - -End Elt2. -Section Elt3. - -Variable elt elt' elt'' : Type. - -Notation oee' := (option elt * option elt')%type. - -Definition combine_l (m:t elt)(m':t elt') : t oee' := - mapi (fun k e => (Some e, find k m')) m. - -Definition combine_r (m:t elt)(m':t elt') : t oee' := - mapi (fun k e' => (find k m, Some e')) m'. - -Definition fold_right_pair (A B C:Type)(f:A->B->C->C) := - List.fold_right (fun p => f (fst p) (snd p)). - -Definition combine (m:t elt)(m':t elt') : t oee' := - let l := combine_l m m' in - let r := combine_r m m' in - fold_right_pair (add (elt:=oee')) r l. - -Lemma fold_right_pair_NoDup : - forall l r (Hl: NoDupA (eqk (elt:=oee')) l) - (Hl: NoDupA (eqk (elt:=oee')) r), - NoDupA (eqk (elt:=oee')) (fold_right_pair (add (elt:=oee')) r l). -Proof. - induction l; simpl; auto. - destruct a; simpl; auto. - inversion_clear 1. - intros; apply add_NoDup; auto. -Qed. -#[local] -Hint Resolve fold_right_pair_NoDup : core. - -Lemma combine_NoDup : - forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m'), - NoDupA (@eqk oee') (combine m m'). -Proof. - unfold combine, combine_r, combine_l. - intros. - set (f1 := fun (k : key) (e : elt) => (Some e, find k m')). - set (f2 := fun (k : key) (e' : elt') => (find k m, Some e')). - generalize (mapi_NoDup Hm f1). - generalize (mapi_NoDup Hm' f2). - set (l := mapi f1 m); clearbody l. - set (r := mapi f2 m'); clearbody r. - auto. -Qed. - -Definition at_least_left (o:option elt)(o':option elt') := - match o with - | None => None - | _ => Some (o,o') - end. - -Definition at_least_right (o:option elt)(o':option elt') := - match o' with - | None => None - | _ => Some (o,o') - end. - -Lemma combine_l_1 : - forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key), - find x (combine_l m m') = at_least_left (find x m) (find x m'). -Proof. - unfold combine_l. - intros. - case_eq (find x m); intros. - - simpl. - apply find_1. - + apply mapi_NoDup; auto. - + destruct (mapi_1 (fun k e => (Some e, find k m')) (find_2 H)) as (y,(H0,H1)). - rewrite (find_eq Hm' (X.eq_sym H0)); auto. - - simpl. - case_eq (find x (mapi (fun k e => (Some e, find k m')) m)); intros; auto. - destruct (@mapi_2 _ _ m x (fun k e => (Some e, find k m'))). - + exists p; apply find_2; auto. - + rewrite (find_1 Hm H1) in H; discriminate. -Qed. - -Lemma combine_r_1 : - forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key), - find x (combine_r m m') = at_least_right (find x m) (find x m'). -Proof. - unfold combine_r. - intros. - case_eq (find x m'); intros. - - simpl. - apply find_1. - + apply mapi_NoDup; auto. - + destruct (mapi_1 (fun k e => (find k m, Some e)) (find_2 H)) as (y,(H0,H1)). - rewrite (find_eq Hm (X.eq_sym H0)); auto. - - simpl. - case_eq (find x (mapi (fun k e' => (find k m, Some e')) m')); intros; auto. - destruct (@mapi_2 _ _ m' x (fun k e' => (find k m, Some e'))). - + exists p; apply find_2; auto. - + rewrite (find_1 Hm' H1) in H; discriminate. -Qed. - -Definition at_least_one (o:option elt)(o':option elt') := - match o, o' with - | None, None => None - | _, _ => Some (o,o') - end. - -Lemma combine_1 : - forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key), - find x (combine m m') = at_least_one (find x m) (find x m'). -Proof. - unfold combine. - intros. - generalize (combine_r_1 Hm Hm' x). - generalize (combine_l_1 Hm Hm' x). - assert (NoDupA (eqk (elt:=oee')) (combine_l m m')). { - unfold combine_l; apply mapi_NoDup; auto. - } - assert (NoDupA (eqk (elt:=oee')) (combine_r m m')). { - unfold combine_r; apply mapi_NoDup; auto. - } - set (l := combine_l m m') in *; clearbody l. - set (r := combine_r m m') in *; clearbody r. - set (o := find x m); clearbody o. - set (o' := find x m'); clearbody o'. - clear Hm' Hm m m'. - induction l. - - destruct o; destruct o'; simpl; intros; discriminate || auto. - - destruct a; simpl in *; intros. - destruct (X.eq_dec x t0); simpl in *. - + unfold at_least_left in H1. - destruct o; simpl in *; try discriminate. - inversion H1; subst. - apply add_eq; auto. - inversion_clear H; auto. - + inversion_clear H. - rewrite <- IHl; auto. - apply add_not_eq; auto. -Qed. - -Variable f : option elt -> option elt' -> option elt''. - -Definition option_cons (A:Type)(k:key)(o:option A)(l:list (key*A)) := - match o with - | Some e => (k,e)::l - | None => l - end. - -Definition map2 m m' := - let m0 : t oee' := combine m m' in - let m1 : t (option elt'') := map (fun p => f (fst p) (snd p)) m0 in - fold_right_pair (option_cons (A:=elt'')) nil m1. - -Lemma map2_NoDup : - forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m'), - NoDupA (@eqk elt'') (map2 m m'). -Proof. - intros. - unfold map2. - assert (H0:=combine_NoDup Hm Hm'). - set (l0:=combine m m') in *; clearbody l0. - set (f':= fun p : oee' => f (fst p) (snd p)). - assert (H1:=map_NoDup (elt' := option elt'') H0 f'). - set (l1:=map f' l0) in *; clearbody l1. - clear f' f H0 l0 Hm Hm' m m'. - induction l1. - - simpl; auto. - - inversion_clear H1. - destruct a; destruct o; simpl; auto. - constructor; auto. - contradict H. - clear IHl1. - induction l1. - + inversion H. - + inversion_clear H0. - destruct a; destruct o; simpl in *; auto. - inversion_clear H; auto. -Qed. - -Definition at_least_one_then_f (o:option elt)(o':option elt') := - match o, o' with - | None, None => None - | _, _ => f o o' - end. - -Lemma map2_0 : - forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key), - find x (map2 m m') = at_least_one_then_f (find x m) (find x m'). -Proof. - intros. - unfold map2. - assert (H:=combine_1 Hm Hm' x). - assert (H2:=combine_NoDup Hm Hm'). - set (f':= fun p : oee' => f (fst p) (snd p)). - set (m0 := combine m m') in *; clearbody m0. - set (o:=find x m) in *; clearbody o. - set (o':=find x m') in *; clearbody o'. - clear Hm Hm' m m'. - generalize H; clear H. - match goal with |- ?m=?n -> ?p=?q => - assert ((m=n->p=q)/\(m=None -> p=None)); [|intuition] end. - induction m0; simpl in *; intuition. - - destruct o; destruct o'; simpl in *; try discriminate; auto. - - destruct a as (k,(oo,oo')); simpl in *. - inversion_clear H2. - destruct (X.eq_dec x k) as [|Hneq]; simpl in *. - + (* x = k *) - assert (at_least_one_then_f o o' = f oo oo'). - * destruct o; destruct o'; simpl in *; inversion_clear H; auto. - * rewrite H2. - unfold f'; simpl. - destruct (f oo oo'); simpl. - -- destruct (X.eq_dec x k) as [|Hneq]; try contradict Hneq; auto. - -- destruct (IHm0 H1) as (_,H4); apply H4; auto. - case_eq (find x m0); intros; auto. - elim H0. - apply InA_eqk with (x,p); auto. - apply InA_eqke_eqk. - exact (find_2 H3). - + (* k < x *) - unfold f'; simpl. - destruct (f oo oo'); simpl. - * destruct (X.eq_dec x k); [ contradict Hneq; auto | auto]. - destruct (IHm0 H1) as (H3,_); apply H3; auto. - * destruct (IHm0 H1) as (H3,_); apply H3; auto. - - - (* None -> None *) - destruct a as (k,(oo,oo')). - simpl. - inversion_clear H2. - destruct (X.eq_dec x k) as [|Hneq]. - + (* x = k *) - discriminate. - + (* k < x *) - unfold f'; simpl. - destruct (f oo oo'); simpl. - * destruct (X.eq_dec x k); [ contradict Hneq; auto | auto]. - destruct (IHm0 H1) as (_,H4); apply H4; auto. - * destruct (IHm0 H1) as (_,H4); apply H4; auto. -Qed. - -(** Specification of [map2] *) -Lemma map2_1 : - forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key), - In x m \/ In x m' -> - find x (map2 m m') = f (find x m) (find x m'). -Proof. - intros. - rewrite map2_0; auto. - destruct H as [(e,H)|(e,H)]. - - rewrite (find_1 Hm H). - destruct (find x m'); simpl; auto. - - rewrite (find_1 Hm' H). - destruct (find x m); simpl; auto. -Qed. - -Lemma map2_2 : - forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key), - In x (map2 m m') -> In x m \/ In x m'. -Proof. - intros. - destruct H as (e,H). - generalize (map2_0 Hm Hm' x). - rewrite (find_1 (map2_NoDup Hm Hm') H). - generalize (@find_2 _ m x). - generalize (@find_2 _ m' x). - destruct (find x m); - destruct (find x m'); simpl; intros. - - left; exists e0; auto. - - left; exists e0; auto. - - right; exists e0; auto. - - discriminate. -Qed. - -End Elt3. -End Raw. - - -Module Make (X: DecidableType) <: WS with Module E:=X. - Module Raw := Raw X. - - Module E := X. - Definition key := E.t. - Record slist (elt:Type) := - {this :> Raw.t elt; NoDup : NoDupA (@Raw.PX.eqk elt) this}. - Definition t (elt:Type) := slist elt. - -Section Elt. - Variable elt elt' elt'':Type. - - Implicit Types m : t elt. - Implicit Types x y : key. - Implicit Types e : elt. - - Definition empty : t elt := Build_slist (Raw.empty_NoDup elt). - Definition is_empty m : bool := Raw.is_empty (this m). - Definition add x e m : t elt := Build_slist (Raw.add_NoDup (NoDup m) x e). - Definition find x m : option elt := Raw.find x (this m). - Definition remove x m : t elt := Build_slist (Raw.remove_NoDup (NoDup m) x). - Definition mem x m : bool := Raw.mem x (this m). - Definition map f m : t elt' := Build_slist (Raw.map_NoDup (NoDup m) f). - Definition mapi (f:key->elt->elt') m : t elt' := Build_slist (Raw.mapi_NoDup (NoDup m) f). - Definition map2 f m (m':t elt') : t elt'' := - Build_slist (Raw.map2_NoDup f (NoDup m) (NoDup m')). - Definition elements m : list (key*elt) := @Raw.elements elt (this m). - Definition cardinal m := length (this m). - Definition fold (A:Type)(f:key->elt->A->A) m (i:A) : A := @Raw.fold elt A f (this m) i. - Definition equal cmp m m' : bool := @Raw.equal elt cmp (this m) (this m'). - Definition MapsTo x e m : Prop := Raw.PX.MapsTo x e (this m). - Definition In x m : Prop := Raw.PX.In x (this m). - Definition Empty m : Prop := Raw.Empty (this m). - - Definition Equal m m' := forall y, find y m = find y m'. - Definition Equiv (eq_elt:elt->elt->Prop) m m' := - (forall k, In k m <-> In k m') /\ - (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e'). - Definition Equivb cmp m m' : Prop := @Raw.Equivb elt cmp (this m) (this m'). - - Definition eq_key : (key*elt) -> (key*elt) -> Prop := @Raw.PX.eqk elt. - Definition eq_key_elt : (key*elt) -> (key*elt) -> Prop:= @Raw.PX.eqke elt. - - Lemma MapsTo_1 : forall m x y e, E.eq x y -> MapsTo x e m -> MapsTo y e m. - Proof. intros m; exact (@Raw.PX.MapsTo_eq elt (this m)). Qed. - - Lemma mem_1 : forall m x, In x m -> mem x m = true. - Proof. intros m; exact (@Raw.mem_1 elt (this m) (NoDup m)). Qed. - Lemma mem_2 : forall m x, mem x m = true -> In x m. - Proof. intros m; exact (@Raw.mem_2 elt (this m) (NoDup m)). Qed. - - Lemma empty_1 : Empty empty. - Proof. exact (@Raw.empty_1 elt). Qed. - - Lemma is_empty_1 : forall m, Empty m -> is_empty m = true. - Proof. intros m; exact (@Raw.is_empty_1 elt (this m)). Qed. - Lemma is_empty_2 : forall m, is_empty m = true -> Empty m. - Proof. intros m; exact (@Raw.is_empty_2 elt (this m)). Qed. - - Lemma add_1 : forall m x y e, E.eq x y -> MapsTo y e (add x e m). - Proof. intros m; exact (@Raw.add_1 elt (this m)). Qed. - Lemma add_2 : forall m x y e e', ~ E.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m). - Proof. intros m; exact (@Raw.add_2 elt (this m)). Qed. - Lemma add_3 : forall m x y e e', ~ E.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m. - Proof. intros m; exact (@Raw.add_3 elt (this m)). Qed. - - Lemma remove_1 : forall m x y, E.eq x y -> ~ In y (remove x m). - Proof. intros m; exact (@Raw.remove_1 elt (this m) (NoDup m)). Qed. - Lemma remove_2 : forall m x y e, ~ E.eq x y -> MapsTo y e m -> MapsTo y e (remove x m). - Proof. intros m; exact (@Raw.remove_2 elt (this m) (NoDup m)). Qed. - Lemma remove_3 : forall m x y e, MapsTo y e (remove x m) -> MapsTo y e m. - Proof. intros m; exact (@Raw.remove_3 elt (this m) (NoDup m)). Qed. - - Lemma find_1 : forall m x e, MapsTo x e m -> find x m = Some e. - Proof. intros m; exact (@Raw.find_1 elt (this m) (NoDup m)). Qed. - Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m. - Proof. intros m; exact (@Raw.find_2 elt (this m)). Qed. - - Lemma elements_1 : forall m x e, MapsTo x e m -> InA eq_key_elt (x,e) (elements m). - Proof. intros m; exact (@Raw.elements_1 elt (this m)). Qed. - Lemma elements_2 : forall m x e, InA eq_key_elt (x,e) (elements m) -> MapsTo x e m. - Proof. intros m; exact (@Raw.elements_2 elt (this m)). Qed. - Lemma elements_3w : forall m, NoDupA eq_key (elements m). - Proof. intros m; exact (@Raw.elements_3w elt (this m) (NoDup m)). Qed. - - Lemma cardinal_1 : forall m, cardinal m = length (elements m). - Proof. intros; reflexivity. Qed. - - Lemma fold_1 : forall m (A : Type) (i : A) (f : key -> elt -> A -> A), - fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i. - Proof. intros m; exact (@Raw.fold_1 elt (this m)). Qed. - - Lemma equal_1 : forall m m' cmp, Equivb cmp m m' -> equal cmp m m' = true. - Proof. intros m m'; exact (@Raw.equal_1 elt (this m) (NoDup m) (this m') (NoDup m')). Qed. - Lemma equal_2 : forall m m' cmp, equal cmp m m' = true -> Equivb cmp m m'. - Proof. intros m m'; exact (@Raw.equal_2 elt (this m) (NoDup m) (this m') (NoDup m')). Qed. - - End Elt. - - Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'), - MapsTo x e m -> MapsTo x (f e) (map f m). - Proof. intros elt elt' m; exact (@Raw.map_1 elt elt' (this m)). Qed. - Lemma map_2 : forall (elt elt':Type)(m: t elt)(x:key)(f:elt->elt'), - In x (map f m) -> In x m. - Proof. intros elt elt' m; exact (@Raw.map_2 elt elt' (this m)). Qed. - - Lemma mapi_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt) - (f:key->elt->elt'), MapsTo x e m -> - exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m). - Proof. intros elt elt' m; exact (@Raw.mapi_1 elt elt' (this m)). Qed. - Lemma mapi_2 : forall (elt elt':Type)(m: t elt)(x:key) - (f:key->elt->elt'), In x (mapi f m) -> In x m. - Proof. intros elt elt' m; exact (@Raw.mapi_2 elt elt' (this m)). Qed. - - Lemma map2_1 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') - (x:key)(f:option elt->option elt'->option elt''), - In x m \/ In x m' -> - find x (map2 f m m') = f (find x m) (find x m'). - Proof. - intros elt elt' elt'' m m' x f; - exact (@Raw.map2_1 elt elt' elt'' f (this m) (NoDup m) (this m') (NoDup m') x). - Qed. - Lemma map2_2 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') - (x:key)(f:option elt->option elt'->option elt''), - In x (map2 f m m') -> In x m \/ In x m'. - Proof. - intros elt elt' elt'' m m' x f; - exact (@Raw.map2_2 elt elt' elt'' f (this m) (NoDup m) (this m') (NoDup m') x). - Qed. - -End Make. diff --git a/stdlib/theories/FSets/FMaps.v b/stdlib/theories/FSets/FMaps.v deleted file mode 100644 index 96a12e05fdb0..000000000000 --- a/stdlib/theories/FSets/FMaps.v +++ /dev/null @@ -1,18 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* E.eq x y \/ In y s. - - Definition add : forall (x : elt) (s : t), {s' : t | Add x s s'}. - Proof. - intros; exists (add x s); auto. - unfold Add; intuition. - elim (E.eq_dec x y); auto. - intros; right. - eapply add_3; eauto. - Qed. - - Definition singleton : - forall x : elt, {s : t | forall y : elt, In y s <-> E.eq x y}. - Proof. - intros; exists (singleton x); intuition. - Qed. - - Definition remove : - forall (x : elt) (s : t), - {s' : t | forall y : elt, In y s' <-> ~ E.eq x y /\ In y s}. - Proof. - intros; exists (remove x s); intuition. - - absurd (In x (remove x s)); auto with set ordered_type. - apply In_1 with y; auto with ordered_type. - - elim (E.eq_dec x y); intros; auto. - + absurd (In x (remove x s)); auto with set ordered_type. - apply In_1 with y; auto with ordered_type. - + eauto with set. - Qed. - - Definition union : - forall s s' : t, {s'' : t | forall x : elt, In x s'' <-> In x s \/ In x s'}. - Proof. - intros; exists (union s s'); intuition. - Qed. - - Definition inter : - forall s s' : t, {s'' : t | forall x : elt, In x s'' <-> In x s /\ In x s'}. - Proof. - intros; exists (inter s s'); intuition; eauto with set. - Qed. - - Definition diff : - forall s s' : t, {s'' : t | forall x : elt, In x s'' <-> In x s /\ ~ In x s'}. - Proof. - intros; exists (diff s s'); intuition; eauto with set. - absurd (In x s'); eauto with set. - Qed. - - Definition equal : forall s s' : t, {Equal s s'} + {~ Equal s s'}. - Proof. - intros. - generalize (equal_1 (s:=s) (s':=s')) (equal_2 (s:=s) (s':=s')). - case (equal s s'); intuition. - Qed. - - Definition subset : forall s s' : t, {Subset s s'} + {~Subset s s'}. - Proof. - intros. - generalize (subset_1 (s:=s) (s':=s')) (subset_2 (s:=s) (s':=s')). - case (subset s s'); intuition. - Qed. - - Definition elements : - forall s : t, - {l : list elt | sort E.lt l /\ (forall x : elt, In x s <-> InA E.eq x l)}. - Proof. - intros; exists (elements s); intuition. - Defined. - - Definition fold : - forall (A : Type) (f : elt -> A -> A) (s : t) (i : A), - {r : A | let (l,_) := elements s in - r = fold_left (fun a e => f e a) l i}. - Proof. - intros; exists (fold (A:=A) f s i); exact (fold_1 s i f). - Qed. - - Definition cardinal : - forall s : t, - {r : nat | let (l,_) := elements s in r = length l }. - Proof. - intros; exists (cardinal s); exact (cardinal_1 s). - Qed. - - Definition fdec (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}) - (x : elt) := if Pdec x then true else false. - - Lemma compat_P_aux : - forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}), - compat_P E.eq P -> compat_bool E.eq (fdec Pdec). - Proof. - unfold compat_P, compat_bool, Proper, respectful, fdec; intros. - generalize (E.eq_sym H0); case (Pdec x); case (Pdec y); firstorder. - Qed. - - #[global] - Hint Resolve compat_P_aux : core. - - Definition filter : - forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}) (s : t), - {s' : t | compat_P E.eq P -> forall x : elt, In x s' <-> In x s /\ P x}. - Proof. - intros. - exists (filter (fdec Pdec) s). - intro H; assert (compat_bool E.eq (fdec Pdec)); auto. - intuition. - - eauto with set. - - generalize (filter_2 H0 H1). - unfold fdec. - case (Pdec x); intuition. - inversion H2. - - apply filter_3; auto. - unfold fdec; simpl. - case (Pdec x); intuition. - Qed. - - Definition for_all : - forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}) (s : t), - {compat_P E.eq P -> For_all P s} + {compat_P E.eq P -> ~ For_all P s}. - Proof. - intros. - generalize (for_all_1 (s:=s) (f:=fdec Pdec)) - (for_all_2 (s:=s) (f:=fdec Pdec)). - case (for_all (fdec Pdec) s); unfold For_all; [ left | right ]; - intros. - - assert (compat_bool E.eq (fdec Pdec)); auto. - generalize (H0 H3 Logic.eq_refl _ H2). - unfold fdec. - case (Pdec x); intuition. - inversion H4. - - intuition. - absurd (false = true); [ auto with bool | apply H; auto ]. - intro. - unfold fdec. - case (Pdec x); intuition. - Qed. - - Definition exists_ : - forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}) (s : t), - {compat_P E.eq P -> Exists P s} + {compat_P E.eq P -> ~ Exists P s}. - Proof. - intros. - generalize (exists_1 (s:=s) (f:=fdec Pdec)) - (exists_2 (s:=s) (f:=fdec Pdec)). - case (exists_ (fdec Pdec) s); unfold Exists; [ left | right ]; - intros. - - elim H0; auto; intros. - exists x; intuition. - generalize H4. - unfold fdec. - case (Pdec x); intuition. - inversion H2. - - intuition. - elim H2; intros. - absurd (false = true); [ auto with bool | apply H; auto ]. - exists x; intuition. - unfold fdec. - case (Pdec x); intuition. - Qed. - - Definition partition : - forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}) (s : t), - {partition : t * t | - let (s1, s2) := partition in - compat_P E.eq P -> - For_all P s1 /\ - For_all (fun x => ~ P x) s2 /\ - (forall x : elt, In x s <-> In x s1 \/ In x s2)}. - Proof. - intros. - exists (partition (fdec Pdec) s). - generalize (partition_1 s (f:=fdec Pdec)) (partition_2 s (f:=fdec Pdec)). - case (partition (fdec Pdec) s). - intros s1 s2; simpl. - intros; assert (compat_bool E.eq (fdec Pdec)); auto. - intros; assert (compat_bool E.eq (fun x => negb (fdec Pdec x))). { - generalize H2; unfold compat_bool, Proper, respectful; intuition; - apply (f_equal negb); auto. - } - intuition. - - generalize H4; unfold For_all, Equal; intuition. - elim (H0 x); intros. - assert (fdec Pdec x = true). - { eapply filter_2; eauto with set. } - generalize H8; unfold fdec; case (Pdec x); intuition. - inversion H9. - - generalize H; unfold For_all, Equal; intuition. - elim (H0 x); intros. - cut ((fun x => negb (fdec Pdec x)) x = true). - { unfold fdec; case (Pdec x); intuition. } - change ((fun x => negb (fdec Pdec x)) x = true). - apply (filter_2 (s:=s) (x:=x)); auto. - - set (b := fdec Pdec x) in *; generalize (Logic.eq_refl b); - pattern b at -1; case b; unfold b; - [ left | right ]. - + elim (H4 x); intros _ B; apply B; auto with set. - + elim (H x); intros _ B; apply B; auto with set. - apply filter_3; auto. - rewrite H5; auto. - - eapply (filter_1 (s:=s) (x:=x) H2); elim (H4 x); intros B _; apply B; - auto. - - eapply (filter_1 (s:=s) (x:=x) H3); elim (H x); intros B _; apply B; auto. - Qed. - - Definition choose_aux: forall s : t, - { x : elt | M.choose s = Some x } + { M.choose s = None }. - Proof. - intros. - destruct (M.choose s); [left | right]; auto. - exists e; auto. - Qed. - - Definition choose : forall s : t, {x : elt | In x s} + {Empty s}. - Proof. - intros; destruct (choose_aux s) as [(x,Hx)|H]. - - left; exists x; apply choose_1; auto. - - right; apply choose_2; auto. - Defined. - - Lemma choose_ok1 : - forall s x, M.choose s = Some x <-> exists H:In x s, - choose s = inleft _ (exist (fun x => In x s) x H). - Proof. - intros s x. - unfold choose; split; intros. - - destruct (choose_aux s) as [(y,Hy)|H']; try congruence. - replace x with y in * by congruence. - exists (choose_1 Hy); auto. - - destruct H. - destruct (choose_aux s) as [(y,Hy)|H']; congruence. - Qed. - - Lemma choose_ok2 : - forall s, M.choose s = None <-> exists H:Empty s, - choose s = inright _ H. - Proof. - intros s. - unfold choose; split; intros. - - destruct (choose_aux s) as [(y,Hy)|H']; try congruence. - exists (choose_2 H'); auto. - - destruct H. - destruct (choose_aux s) as [(y,Hy)|H']; congruence. - Qed. - - Lemma choose_equal : forall s s', Equal s s' -> - match choose s, choose s' with - | inleft (exist _ x _), inleft (exist _ x' _) => E.eq x x' - | inright _, inright _ => True - | _, _ => False - end. - Proof. - intros. - generalize (@M.choose_1 s)(@M.choose_2 s) - (@M.choose_1 s')(@M.choose_2 s')(@M.choose_3 s s') - (choose_ok1 s)(choose_ok2 s)(choose_ok1 s')(choose_ok2 s'). - destruct (choose s) as [(x,Hx)|Hx]; destruct (choose s') as [(x',Hx')|Hx']; auto; intros. - - apply H4; auto. - + rewrite H5; exists Hx; auto. - + rewrite H7; exists Hx'; auto. - - apply Hx' with x; unfold Equal in H; rewrite <-H; auto. - - apply Hx with x'; unfold Equal in H; rewrite H; auto. - Qed. - - Definition min_elt : - forall s : t, - {x : elt | In x s /\ For_all (fun y => ~ E.lt y x) s} + {Empty s}. - Proof. - intros; - generalize (min_elt_1 (s:=s)) (min_elt_2 (s:=s)) (min_elt_3 (s:=s)). - case (min_elt s); [ left | right ]; auto. - exists e; unfold For_all; eauto. - Qed. - - Definition max_elt : - forall s : t, - {x : elt | In x s /\ For_all (fun y => ~ E.lt x y) s} + {Empty s}. - Proof. - intros; - generalize (max_elt_1 (s:=s)) (max_elt_2 (s:=s)) (max_elt_3 (s:=s)). - case (max_elt s); [ left | right ]; auto. - exists e; unfold For_all; eauto. - Qed. - - Definition elt := elt. - Definition t := t. - - Definition In := In. - Definition Equal s s' := forall a : elt, In a s <-> In a s'. - Definition Subset s s' := forall a : elt, In a s -> In a s'. - Definition Empty s := forall a : elt, ~ In a s. - Definition For_all (P : elt -> Prop) (s : t) := - forall x : elt, In x s -> P x. - Definition Exists (P : elt -> Prop) (s : t) := - exists x : elt, In x s /\ P x. - - Definition eq_In := In_1. - - Definition eq := Equal. - Definition lt := lt. - Definition eq_refl := eq_refl. - Definition eq_sym := eq_sym. - Definition eq_trans := eq_trans. - Definition lt_trans := lt_trans. - Definition lt_not_eq := lt_not_eq. - Definition compare := compare. - - Module E := E. - -End DepOfNodep. - - -(** * From dependent signature [Sdep] to non-dependent signature [S]. *) - -Module NodepOfDep (M: Sdep) <: S with Module E := M.E. - Import M. - - Module ME := OrderedTypeFacts E. - - Definition empty : t := let (s, _) := empty in s. - - Lemma empty_1 : Empty empty. - Proof. - unfold empty; case M.empty; auto. - Qed. - - Definition is_empty (s : t) : bool := - if is_empty s then true else false. - - Lemma is_empty_1 : forall s : t, Empty s -> is_empty s = true. - Proof. - intros; unfold is_empty; case (M.is_empty s); auto. - Qed. - - Lemma is_empty_2 : forall s : t, is_empty s = true -> Empty s. - Proof. - intro s; unfold is_empty; case (M.is_empty s); auto. - intros; discriminate H. - Qed. - - Definition mem (x : elt) (s : t) : bool := - if mem x s then true else false. - - Lemma mem_1 : forall (s : t) (x : elt), In x s -> mem x s = true. - Proof. - intros; unfold mem; case (M.mem x s); auto. - Qed. - - Lemma mem_2 : forall (s : t) (x : elt), mem x s = true -> In x s. - Proof. - intros s x; unfold mem; case (M.mem x s); auto. - intros; discriminate H. - Qed. - - Definition eq_dec := equal. - - Definition equal (s s' : t) : bool := - if equal s s' then true else false. - - Lemma equal_1 : forall s s' : t, Equal s s' -> equal s s' = true. - Proof. - intros; unfold equal; case M.equal; intuition. - Qed. - - Lemma equal_2 : forall s s' : t, equal s s' = true -> Equal s s'. - Proof. - intros s s'; unfold equal; case (M.equal s s'); intuition; - inversion H. - Qed. - - Definition subset (s s' : t) : bool := - if subset s s' then true else false. - - Lemma subset_1 : forall s s' : t, Subset s s' -> subset s s' = true. - Proof. - intros; unfold subset; case M.subset; intuition. - Qed. - - Lemma subset_2 : forall s s' : t, subset s s' = true -> Subset s s'. - Proof. - intros s s'; unfold subset; case (M.subset s s'); intuition; - inversion H. - Qed. - - Definition choose (s : t) : option elt := - match choose s with - | inleft (exist _ x _) => Some x - | inright _ => None - end. - - Lemma choose_1 : forall (s : t) (x : elt), choose s = Some x -> In x s. - Proof. - intros s x; unfold choose; case (M.choose s). - - simple destruct s0; intros; injection H; intros; subst; auto. - - intros; discriminate H. - Qed. - - Lemma choose_2 : forall s : t, choose s = None -> Empty s. - Proof. - intro s; unfold choose; case (M.choose s); auto. - simple destruct s0; intros; discriminate H. - Qed. - - Lemma choose_3 : forall s s' x x', - choose s = Some x -> choose s' = Some x' -> Equal s s' -> E.eq x x'. - Proof. - unfold choose; intros. - generalize (M.choose_equal H1); clear H1. - destruct (M.choose s) as [(?,?)|?]; destruct (M.choose s') as [(?,?)|?]; - simpl; auto; congruence. - Qed. - - Definition elements (s : t) : list elt := let (l, _) := elements s in l. - - Lemma elements_1 : forall (s : t) (x : elt), In x s -> InA E.eq x (elements s). - Proof. - intros; unfold elements; case (M.elements s); firstorder. - Qed. - - Lemma elements_2 : forall (s : t) (x : elt), InA E.eq x (elements s) -> In x s. - Proof. - intros s x; unfold elements; case (M.elements s); firstorder. - Qed. - - Lemma elements_3 : forall s : t, sort E.lt (elements s). - Proof. - intros; unfold elements; case (M.elements s); firstorder. - Qed. - #[global] - Hint Resolve elements_3 : core. - - Lemma elements_3w : forall s : t, NoDupA E.eq (elements s). - Proof. auto with ordered_type. Qed. - - Definition min_elt (s : t) : option elt := - match min_elt s with - | inleft (exist _ x _) => Some x - | inright _ => None - end. - - Lemma min_elt_1 : forall (s : t) (x : elt), min_elt s = Some x -> In x s. - Proof. - intros s x; unfold min_elt; case (M.min_elt s). - - simple destruct s0; intros; injection H; intros; subst; intuition. - - intros; discriminate H. - Qed. - - Lemma min_elt_2 : - forall (s : t) (x y : elt), min_elt s = Some x -> In y s -> ~ E.lt y x. - Proof. - intros s x y; unfold min_elt; case (M.min_elt s). - - unfold For_all; simple destruct s0; intros; injection H; intros; - subst; firstorder. - - intros; discriminate H. - Qed. - - Lemma min_elt_3 : forall s : t, min_elt s = None -> Empty s. - Proof. - intros s; unfold min_elt; case (M.min_elt s); auto. - simple destruct s0; intros; discriminate H. - Qed. - - Definition max_elt (s : t) : option elt := - match max_elt s with - | inleft (exist _ x _) => Some x - | inright _ => None - end. - - Lemma max_elt_1 : forall (s : t) (x : elt), max_elt s = Some x -> In x s. - Proof. - intros s x; unfold max_elt; case (M.max_elt s). - - simple destruct s0; intros; injection H; intros; subst; intuition. - - intros; discriminate H. - Qed. - - Lemma max_elt_2 : - forall (s : t) (x y : elt), max_elt s = Some x -> In y s -> ~ E.lt x y. - Proof. - intros s x y; unfold max_elt; case (M.max_elt s). - - unfold For_all; simple destruct s0; intros; injection H; intros; - subst; firstorder. - - intros; discriminate H. - Qed. - - Lemma max_elt_3 : forall s : t, max_elt s = None -> Empty s. - Proof. - intros s; unfold max_elt; case (M.max_elt s); auto. - simple destruct s0; intros; discriminate H. - Qed. - - Definition add (x : elt) (s : t) : t := let (s', _) := add x s in s'. - - Lemma add_1 : forall (s : t) (x y : elt), E.eq x y -> In y (add x s). - Proof. - intros; unfold add; case (M.add x s); unfold Add; - firstorder. - Qed. - - Lemma add_2 : forall (s : t) (x y : elt), In y s -> In y (add x s). - Proof. - intros; unfold add; case (M.add x s); unfold Add; - firstorder. - Qed. - - Lemma add_3 : - forall (s : t) (x y : elt), ~ E.eq x y -> In y (add x s) -> In y s. - Proof. - intros s x y; unfold add; case (M.add x s); unfold Add; - firstorder. - Qed. - - Definition remove (x : elt) (s : t) : t := let (s', _) := remove x s in s'. - - Lemma remove_1 : forall (s : t) (x y : elt), E.eq x y -> ~ In y (remove x s). - Proof. - intros; unfold remove; case (M.remove x s); firstorder. - Qed. - - Lemma remove_2 : - forall (s : t) (x y : elt), ~ E.eq x y -> In y s -> In y (remove x s). - Proof. - intros; unfold remove; case (M.remove x s); firstorder. - Qed. - - Lemma remove_3 : forall (s : t) (x y : elt), In y (remove x s) -> In y s. - Proof. - intros s x y; unfold remove; case (M.remove x s); firstorder. - Qed. - - Definition singleton (x : elt) : t := let (s, _) := singleton x in s. - - Lemma singleton_1 : forall x y : elt, In y (singleton x) -> E.eq x y. - Proof. - intros x y; unfold singleton; case (M.singleton x); firstorder. - Qed. - - Lemma singleton_2 : forall x y : elt, E.eq x y -> In y (singleton x). - Proof. - intros x y; unfold singleton; case (M.singleton x); firstorder. - Qed. - - Definition union (s s' : t) : t := let (s'', _) := union s s' in s''. - - Lemma union_1 : - forall (s s' : t) (x : elt), In x (union s s') -> In x s \/ In x s'. - Proof. - intros s s' x; unfold union; case (M.union s s'); firstorder. - Qed. - - Lemma union_2 : forall (s s' : t) (x : elt), In x s -> In x (union s s'). - Proof. - intros s s' x; unfold union; case (M.union s s'); firstorder. - Qed. - - Lemma union_3 : forall (s s' : t) (x : elt), In x s' -> In x (union s s'). - Proof. - intros s s' x; unfold union; case (M.union s s'); firstorder. - Qed. - - Definition inter (s s' : t) : t := let (s'', _) := inter s s' in s''. - - Lemma inter_1 : forall (s s' : t) (x : elt), In x (inter s s') -> In x s. - Proof. - intros s s' x; unfold inter; case (M.inter s s'); firstorder. - Qed. - - Lemma inter_2 : forall (s s' : t) (x : elt), In x (inter s s') -> In x s'. - Proof. - intros s s' x; unfold inter; case (M.inter s s'); firstorder. - Qed. - - Lemma inter_3 : - forall (s s' : t) (x : elt), In x s -> In x s' -> In x (inter s s'). - Proof. - intros s s' x; unfold inter; case (M.inter s s'); firstorder. - Qed. - - Definition diff (s s' : t) : t := let (s'', _) := diff s s' in s''. - - Lemma diff_1 : forall (s s' : t) (x : elt), In x (diff s s') -> In x s. - Proof. - intros s s' x; unfold diff; case (M.diff s s'); firstorder. - Qed. - - Lemma diff_2 : forall (s s' : t) (x : elt), In x (diff s s') -> ~ In x s'. - Proof. - intros s s' x; unfold diff; case (M.diff s s'); firstorder. - Qed. - - Lemma diff_3 : - forall (s s' : t) (x : elt), In x s -> ~ In x s' -> In x (diff s s'). - Proof. - intros s s' x; unfold diff; case (M.diff s s'); firstorder. - Qed. - - Definition cardinal (s : t) : nat := let (f, _) := cardinal s in f. - - Lemma cardinal_1 : forall s, cardinal s = length (elements s). - Proof. - intros; unfold cardinal; case (M.cardinal s); unfold elements in *; - destruct (M.elements s); auto. - Qed. - - Definition fold (B : Type) (f : elt -> B -> B) (i : t) - (s : B) : B := let (fold, _) := fold f i s in fold. - - Lemma fold_1 : - forall (s : t) (A : Type) (i : A) (f : elt -> A -> A), - fold f s i = fold_left (fun a e => f e a) (elements s) i. - Proof. - intros; unfold fold; case (M.fold f s i); unfold elements in *; - destruct (M.elements s); auto. - Qed. - - Definition f_dec : - forall (f : elt -> bool) (x : elt), {f x = true} + {f x <> true}. - Proof. - intros; case (f x); auto with bool. - Defined. - - Lemma compat_P_aux : - forall f : elt -> bool, - compat_bool E.eq f -> compat_P E.eq (fun x => f x = true). - Proof. - unfold compat_bool, compat_P, Proper, respectful, impl; intros; - rewrite <- H1; firstorder. - Qed. - - #[global] - Hint Resolve compat_P_aux : core. - - Definition filter (f : elt -> bool) (s : t) : t := - let (s', _) := filter (P:=fun x => f x = true) (f_dec f) s in s'. - - Lemma filter_1 : - forall (s : t) (x : elt) (f : elt -> bool), - compat_bool E.eq f -> In x (filter f s) -> In x s. - Proof. - intros s x f; unfold filter; case M.filter as (x0,Hiff); intuition. - generalize (Hiff (compat_P_aux H)); firstorder. - Qed. - - Lemma filter_2 : - forall (s : t) (x : elt) (f : elt -> bool), - compat_bool E.eq f -> In x (filter f s) -> f x = true. - Proof. - intros s x f; unfold filter; case M.filter as (x0,Hiff); intuition. - generalize (Hiff (compat_P_aux H)); firstorder. - Qed. - - Lemma filter_3 : - forall (s : t) (x : elt) (f : elt -> bool), - compat_bool E.eq f -> In x s -> f x = true -> In x (filter f s). - Proof. - intros s x f; unfold filter; case M.filter as (x0,Hiff); intuition. - generalize (Hiff (compat_P_aux H)); firstorder. - Qed. - - Definition for_all (f : elt -> bool) (s : t) : bool := - if for_all (P:=fun x => f x = true) (f_dec f) s - then true - else false. - - Lemma for_all_1 : - forall (s : t) (f : elt -> bool), - compat_bool E.eq f -> - For_all (fun x => f x = true) s -> for_all f s = true. - Proof. - intros s f; unfold for_all; case M.for_all; intuition; elim n; - auto. - Qed. - - Lemma for_all_2 : - forall (s : t) (f : elt -> bool), - compat_bool E.eq f -> - for_all f s = true -> For_all (fun x => f x = true) s. - Proof. - intros s f; unfold for_all; case M.for_all; intuition; - inversion H0. - Qed. - - Definition exists_ (f : elt -> bool) (s : t) : bool := - if exists_ (P:=fun x => f x = true) (f_dec f) s - then true - else false. - - Lemma exists_1 : - forall (s : t) (f : elt -> bool), - compat_bool E.eq f -> Exists (fun x => f x = true) s -> exists_ f s = true. - Proof. - intros s f; unfold exists_; case M.exists_; intuition; elim n; - auto. - Qed. - - Lemma exists_2 : - forall (s : t) (f : elt -> bool), - compat_bool E.eq f -> exists_ f s = true -> Exists (fun x => f x = true) s. - Proof. - intros s f; unfold exists_; case M.exists_; intuition; - inversion H0. - Qed. - - Definition partition (f : elt -> bool) (s : t) : - t * t := - let (p, _) := partition (P:=fun x => f x = true) (f_dec f) s in p. - - Lemma partition_1 : - forall (s : t) (f : elt -> bool), - compat_bool E.eq f -> Equal (fst (partition f s)) (filter f s). - Proof. - intros s f; unfold partition; case M.partition. - intro p; case p; clear p; intros s1 s2 H C. - generalize (H (compat_P_aux C)); clear H; intro H. - simpl; unfold Equal; intuition. - - apply filter_3; firstorder. - - elim (H2 a); intros. - assert (In a s). - + eapply filter_1; eauto. - + elim H3; intros; auto. - absurd (f a = true). - * exact (H a H6). - * eapply filter_2; eauto. - Qed. - - Lemma partition_2 : - forall (s : t) (f : elt -> bool), - compat_bool E.eq f -> Equal (snd (partition f s)) (filter (fun x => negb (f x)) s). - Proof. - intros s f; unfold partition; case M.partition. - intro p; case p; clear p; intros s1 s2 H C. - generalize (H (compat_P_aux C)); clear H; intro H. - assert (D : compat_bool E.eq (fun x => negb (f x))). { - generalize C; unfold compat_bool, Proper, respectful; intros; apply (f_equal negb); - auto. - } - simpl; unfold Equal; intuition. - - apply filter_3; firstorder with bool. - - elim (H2 a); intros. - assert (In a s). - { eapply filter_1; eauto. } - elim H3; intros; auto. - absurd (f a = true). - + intro. - generalize (filter_2 D H1). - rewrite H7; intros H8; inversion H8. - + exact (H0 a H6). - Qed. - - - Definition elt := elt. - Definition t := t. - - Definition In := In. - Definition Equal s s' := forall a : elt, In a s <-> In a s'. - Definition Subset s s' := forall a : elt, In a s -> In a s'. - Definition Add (x : elt) (s s' : t) := - forall y : elt, In y s' <-> E.eq y x \/ In y s. - Definition Empty s := forall a : elt, ~ In a s. - Definition For_all (P : elt -> Prop) (s : t) := - forall x : elt, In x s -> P x. - Definition Exists (P : elt -> Prop) (s : t) := - exists x : elt, In x s /\ P x. - - Definition In_1 := eq_In. - - Definition eq := Equal. - Definition lt := lt. - Definition eq_refl := eq_refl. - Definition eq_sym := eq_sym. - Definition eq_trans := eq_trans. - Definition lt_trans := lt_trans. - Definition lt_not_eq := lt_not_eq. - Definition compare := compare. - - Module E := E. - -End NodepOfDep. diff --git a/stdlib/theories/FSets/FSetCompat.v b/stdlib/theories/FSets/FSetCompat.v deleted file mode 100644 index 77d74ec85b71..000000000000 --- a/stdlib/theories/FSets/FSetCompat.v +++ /dev/null @@ -1,421 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* bool. - - Definition In : elt -> t -> Prop := M.In. - Definition Equal s s' := forall a : elt, In a s <-> In a s'. - Definition Subset s s' := forall a : elt, In a s -> In a s'. - Definition Empty s := forall a : elt, ~ In a s. - Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x. - Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x. - Definition empty : t := M.empty. - Definition is_empty : t -> bool := M.is_empty. - Definition mem : elt -> t -> bool := M.mem. - Definition add : elt -> t -> t := M.add. - Definition singleton : elt -> t := M.singleton. - Definition remove : elt -> t -> t := M.remove. - Definition union : t -> t -> t := M.union. - Definition inter : t -> t -> t := M.inter. - Definition diff : t -> t -> t := M.diff. - Definition eq : t -> t -> Prop := M.eq. - Definition eq_dec : forall s s', {eq s s'}+{~eq s s'}:= M.eq_dec. - Definition equal : t -> t -> bool := M.equal. - Definition subset : t -> t -> bool := M.subset. - Definition fold : forall A : Type, (elt -> A -> A) -> t -> A -> A := M.fold. - Definition for_all : (elt -> bool) -> t -> bool := M.for_all. - Definition exists_ : (elt -> bool) -> t -> bool := M.exists_. - Definition filter : (elt -> bool) -> t -> t := M.filter. - Definition partition : (elt -> bool) -> t -> t * t:= M.partition. - Definition cardinal : t -> nat := M.cardinal. - Definition elements : t -> list elt := M.elements. - Definition choose : t -> option elt := M.choose. - - Module MF := MSetFacts.WFacts M. - - Definition In_1 : forall s x y, E.eq x y -> In x s -> In y s - := MF.In_1. - Definition eq_refl : forall s, eq s s - := @Equivalence_Reflexive _ _ M.eq_equiv. - Definition eq_sym : forall s s', eq s s' -> eq s' s - := @Equivalence_Symmetric _ _ M.eq_equiv. - Definition eq_trans : forall s s' s'', eq s s' -> eq s' s'' -> eq s s'' - := @Equivalence_Transitive _ _ M.eq_equiv. - Definition mem_1 : forall s x, In x s -> mem x s = true - := MF.mem_1. - Definition mem_2 : forall s x, mem x s = true -> In x s - := MF.mem_2. - Definition equal_1 : forall s s', Equal s s' -> equal s s' = true - := MF.equal_1. - Definition equal_2 : forall s s', equal s s' = true -> Equal s s' - := MF.equal_2. - Definition subset_1 : forall s s', Subset s s' -> subset s s' = true - := MF.subset_1. - Definition subset_2 : forall s s', subset s s' = true -> Subset s s' - := MF.subset_2. - Definition empty_1 : Empty empty := MF.empty_1. - Definition is_empty_1 : forall s, Empty s -> is_empty s = true - := MF.is_empty_1. - Definition is_empty_2 : forall s, is_empty s = true -> Empty s - := MF.is_empty_2. - Definition add_1 : forall s x y, E.eq x y -> In y (add x s) - := MF.add_1. - Definition add_2 : forall s x y, In y s -> In y (add x s) - := MF.add_2. - Definition add_3 : forall s x y, ~ E.eq x y -> In y (add x s) -> In y s - := MF.add_3. - Definition remove_1 : forall s x y, E.eq x y -> ~ In y (remove x s) - := MF.remove_1. - Definition remove_2 : forall s x y, ~ E.eq x y -> In y s -> In y (remove x s) - := MF.remove_2. - Definition remove_3 : forall s x y, In y (remove x s) -> In y s - := MF.remove_3. - Definition union_1 : forall s s' x, In x (union s s') -> In x s \/ In x s' - := MF.union_1. - Definition union_2 : forall s s' x, In x s -> In x (union s s') - := MF.union_2. - Definition union_3 : forall s s' x, In x s' -> In x (union s s') - := MF.union_3. - Definition inter_1 : forall s s' x, In x (inter s s') -> In x s - := MF.inter_1. - Definition inter_2 : forall s s' x, In x (inter s s') -> In x s' - := MF.inter_2. - Definition inter_3 : forall s s' x, In x s -> In x s' -> In x (inter s s') - := MF.inter_3. - Definition diff_1 : forall s s' x, In x (diff s s') -> In x s - := MF.diff_1. - Definition diff_2 : forall s s' x, In x (diff s s') -> ~ In x s' - := MF.diff_2. - Definition diff_3 : forall s s' x, In x s -> ~ In x s' -> In x (diff s s') - := MF.diff_3. - Definition singleton_1 : forall x y, In y (singleton x) -> E.eq x y - := MF.singleton_1. - Definition singleton_2 : forall x y, E.eq x y -> In y (singleton x) - := MF.singleton_2. - Definition fold_1 : forall s (A : Type) (i : A) (f : elt -> A -> A), - fold f s i = fold_left (fun a e => f e a) (elements s) i - := MF.fold_1. - Definition cardinal_1 : forall s, cardinal s = length (elements s) - := MF.cardinal_1. - Definition filter_1 : forall s x f, compat_bool E.eq f -> - In x (filter f s) -> In x s - := MF.filter_1. - Definition filter_2 : forall s x f, compat_bool E.eq f -> - In x (filter f s) -> f x = true - := MF.filter_2. - Definition filter_3 : forall s x f, compat_bool E.eq f -> - In x s -> f x = true -> In x (filter f s) - := MF.filter_3. - Definition for_all_1 : forall s f, compat_bool E.eq f -> - For_all (fun x => f x = true) s -> for_all f s = true - := MF.for_all_1. - Definition for_all_2 : forall s f, compat_bool E.eq f -> - for_all f s = true -> For_all (fun x => f x = true) s - := MF.for_all_2. - Definition exists_1 : forall s f, compat_bool E.eq f -> - Exists (fun x => f x = true) s -> exists_ f s = true - := MF.exists_1. - Definition exists_2 : forall s f, compat_bool E.eq f -> - exists_ f s = true -> Exists (fun x => f x = true) s - := MF.exists_2. - Definition partition_1 : forall s f, compat_bool E.eq f -> - Equal (fst (partition f s)) (filter f s) - := MF.partition_1. - Definition partition_2 : forall s f, compat_bool E.eq f -> - Equal (snd (partition f s)) (filter (fun x => negb (f x)) s) - := MF.partition_2. - Definition choose_1 : forall s x, choose s = Some x -> In x s - := MF.choose_1. - Definition choose_2 : forall s, choose s = None -> Empty s - := MF.choose_2. - Definition elements_1 : forall s x, In x s -> InA E.eq x (elements s) - := MF.elements_1. - Definition elements_2 : forall s x, InA E.eq x (elements s) -> In x s - := MF.elements_2. - Definition elements_3w : forall s, NoDupA E.eq (elements s) - := MF.elements_3w. - -End Backport_WSets. - - -(** * From new Sets to new ones *) - -Module Backport_Sets - (O:OrderedType.OrderedType) - (M:MSetInterface.Sets with Definition E.t := O.t - with Definition E.eq := O.eq - with Definition E.lt := O.lt) - <: FSetInterface.S with Module E:=O. - - Include Backport_WSets O M. - - Implicit Type s : t. - Implicit Type x y : elt. - - Definition lt : t -> t -> Prop := M.lt. - Definition min_elt : t -> option elt := M.min_elt. - Definition max_elt : t -> option elt := M.max_elt. - Definition min_elt_1 : forall s x, min_elt s = Some x -> In x s - := M.min_elt_spec1. - Definition min_elt_2 : forall s x y, - min_elt s = Some x -> In y s -> ~ O.lt y x - := M.min_elt_spec2. - Definition min_elt_3 : forall s, min_elt s = None -> Empty s - := M.min_elt_spec3. - Definition max_elt_1 : forall s x, max_elt s = Some x -> In x s - := M.max_elt_spec1. - Definition max_elt_2 : forall s x y, - max_elt s = Some x -> In y s -> ~ O.lt x y - := M.max_elt_spec2. - Definition max_elt_3 : forall s, max_elt s = None -> Empty s - := M.max_elt_spec3. - Definition elements_3 : forall s, sort O.lt (elements s) - := M.elements_spec2. - Definition choose_3 : forall s s' x y, - choose s = Some x -> choose s' = Some y -> Equal s s' -> O.eq x y - := M.choose_spec3. - Definition lt_trans : forall s s' s'', lt s s' -> lt s' s'' -> lt s s'' - := @StrictOrder_Transitive _ _ M.lt_strorder. - Lemma lt_not_eq : forall s s', lt s s' -> ~ eq s s'. - Proof. - unfold lt, eq. intros s s' Hlt Heq. rewrite Heq in Hlt. - apply (StrictOrder_Irreflexive s'); auto. - Qed. - Definition compare : forall s s', Compare lt eq s s'. - Proof. - intros s s'; destruct (CompSpec2Type (M.compare_spec s s')); - [ apply EQ | apply LT | apply GT ]; auto. - Defined. - - Module E := O. - -End Backport_Sets. - - -(** * From old Weak Sets to new ones. *) - -Module Update_WSets - (E:Equalities.DecidableType) - (M:FSetInterface.WS with Definition E.t := E.t - with Definition E.eq := E.eq) - <: MSetInterface.WSetsOn E. - - Definition elt := E.t. - Definition t := M.t. - - Implicit Type s : t. - Implicit Type x y : elt. - Implicit Type f : elt -> bool. - - Definition In : elt -> t -> Prop := M.In. - Definition Equal s s' := forall a : elt, In a s <-> In a s'. - Definition Subset s s' := forall a : elt, In a s -> In a s'. - Definition Empty s := forall a : elt, ~ In a s. - Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x. - Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x. - Definition empty : t := M.empty. - Definition is_empty : t -> bool := M.is_empty. - Definition mem : elt -> t -> bool := M.mem. - Definition add : elt -> t -> t := M.add. - Definition singleton : elt -> t := M.singleton. - Definition remove : elt -> t -> t := M.remove. - Definition union : t -> t -> t := M.union. - Definition inter : t -> t -> t := M.inter. - Definition diff : t -> t -> t := M.diff. - Definition eq : t -> t -> Prop := M.eq. - Definition eq_dec : forall s s', {eq s s'}+{~eq s s'}:= M.eq_dec. - Definition equal : t -> t -> bool := M.equal. - Definition subset : t -> t -> bool := M.subset. - Definition fold : forall A : Type, (elt -> A -> A) -> t -> A -> A := M.fold. - Definition for_all : (elt -> bool) -> t -> bool := M.for_all. - Definition exists_ : (elt -> bool) -> t -> bool := M.exists_. - Definition filter : (elt -> bool) -> t -> t := M.filter. - Definition partition : (elt -> bool) -> t -> t * t:= M.partition. - Definition cardinal : t -> nat := M.cardinal. - Definition elements : t -> list elt := M.elements. - Definition choose : t -> option elt := M.choose. - - Module MF := FSetFacts.WFacts M. - -#[global] - Instance In_compat : Proper (E.eq==>Logic.eq==>iff) In. - Proof. intros x x' Hx s s' Hs. subst. apply MF.In_eq_iff; auto. Qed. - -#[global] - Instance eq_equiv : Equivalence eq := _. - - Section Spec. - Variable s s': t. - Variable x y : elt. - - Lemma mem_spec : mem x s = true <-> In x s. - Proof. intros; symmetry; apply MF.mem_iff. Qed. - - Lemma equal_spec : equal s s' = true <-> Equal s s'. - Proof. intros; symmetry; apply MF.equal_iff. Qed. - - Lemma subset_spec : subset s s' = true <-> Subset s s'. - Proof. intros; symmetry; apply MF.subset_iff. Qed. - - Definition empty_spec : Empty empty := M.empty_1. - - Lemma is_empty_spec : is_empty s = true <-> Empty s. - Proof. intros; symmetry; apply MF.is_empty_iff. Qed. - - Declare Equivalent Keys In M.In. - - Lemma add_spec : In y (add x s) <-> E.eq y x \/ In y s. - Proof. intros. rewrite MF.add_iff. intuition. Qed. - - Lemma remove_spec : In y (remove x s) <-> In y s /\ ~E.eq y x. - Proof. intros. rewrite MF.remove_iff. intuition. Qed. - - Lemma singleton_spec : In y (singleton x) <-> E.eq y x. - Proof. intros; rewrite MF.singleton_iff. intuition. Qed. - - Definition union_spec : In x (union s s') <-> In x s \/ In x s' - := @MF.union_iff s s' x. - Definition inter_spec : In x (inter s s') <-> In x s /\ In x s' - := @MF.inter_iff s s' x. - Definition diff_spec : In x (diff s s') <-> In x s /\ ~In x s' - := @MF.diff_iff s s' x. - Definition fold_spec : forall (A : Type) (i : A) (f : elt -> A -> A), - fold f s i = fold_left (flip f) (elements s) i - := @M.fold_1 s. - Definition cardinal_spec : cardinal s = length (elements s) - := @M.cardinal_1 s. - - Lemma elements_spec1 : InA E.eq x (elements s) <-> In x s. - Proof. intros; symmetry; apply MF.elements_iff. Qed. - - Definition elements_spec2w : NoDupA E.eq (elements s) - := @M.elements_3w s. - Definition choose_spec1 : choose s = Some x -> In x s - := @M.choose_1 s x. - Definition choose_spec2 : choose s = None -> Empty s - := @M.choose_2 s. - Definition filter_spec : forall f, Proper (E.eq==>Logic.eq) f -> - (In x (filter f s) <-> In x s /\ f x = true) - := @MF.filter_iff s x. - Definition partition_spec1 : forall f, Proper (E.eq==>Logic.eq) f -> - Equal (fst (partition f s)) (filter f s) - := @M.partition_1 s. - Definition partition_spec2 : forall f, Proper (E.eq==>Logic.eq) f -> - Equal (snd (partition f s)) (filter (fun x => negb (f x)) s) - := @M.partition_2 s. - - Lemma for_all_spec : forall f, Proper (E.eq==>Logic.eq) f -> - (for_all f s = true <-> For_all (fun x => f x = true) s). - Proof. intros; symmetry; apply MF.for_all_iff; auto. Qed. - - Lemma exists_spec : forall f, Proper (E.eq==>Logic.eq) f -> - (exists_ f s = true <-> Exists (fun x => f x = true) s). - Proof. intros; symmetry; apply MF.exists_iff; auto. Qed. - - End Spec. - -End Update_WSets. - - -(** * From old Sets to new ones. *) - -Module Update_Sets - (O:Orders.OrderedType) - (M:FSetInterface.S with Definition E.t := O.t - with Definition E.eq := O.eq - with Definition E.lt := O.lt) - <: MSetInterface.Sets with Module E:=O. - - Include Update_WSets O M. - - Implicit Type s : t. - Implicit Type x y : elt. - - Definition lt : t -> t -> Prop := M.lt. - Definition min_elt : t -> option elt := M.min_elt. - Definition max_elt : t -> option elt := M.max_elt. - Definition min_elt_spec1 : forall s x, min_elt s = Some x -> In x s - := M.min_elt_1. - Definition min_elt_spec2 : forall s x y, - min_elt s = Some x -> In y s -> ~ O.lt y x - := M.min_elt_2. - Definition min_elt_spec3 : forall s, min_elt s = None -> Empty s - := M.min_elt_3. - Definition max_elt_spec1 : forall s x, max_elt s = Some x -> In x s - := M.max_elt_1. - Definition max_elt_spec2 : forall s x y, - max_elt s = Some x -> In y s -> ~ O.lt x y - := M.max_elt_2. - Definition max_elt_spec3 : forall s, max_elt s = None -> Empty s - := M.max_elt_3. - Definition elements_spec2 : forall s, sort O.lt (elements s) - := M.elements_3. - Definition choose_spec3 : forall s s' x y, - choose s = Some x -> choose s' = Some y -> Equal s s' -> O.eq x y - := M.choose_3. - -#[global] - Instance lt_strorder : StrictOrder lt. - Proof. - split. - - intros x Hx. apply (M.lt_not_eq Hx). auto with crelations. - - exact M.lt_trans. - Qed. - -#[global] - Instance lt_compat : Proper (eq==>eq==>iff) lt. - Proof. - 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. - - 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'. 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' := - match M.compare s s' with - | EQ _ => Eq - | LT _ => Lt - | GT _ => Gt - end. - - Lemma compare_spec : forall s s', CompSpec eq lt s s' (compare s s'). - Proof. intros; unfold compare; destruct M.compare; auto. Qed. - - Module E := O. - -End Update_Sets. diff --git a/stdlib/theories/FSets/FSetDecide.v b/stdlib/theories/FSets/FSetDecide.v deleted file mode 100644 index c8e557f2c62c..000000000000 --- a/stdlib/theories/FSets/FSetDecide.v +++ /dev/null @@ -1,901 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* ... -> Pk -> P ->> - where [P]'s are defined by the grammar: -<< - -P ::= -| Q -| Empty F -| Subset F F' -| Equal F F' - -Q ::= -| E.eq X X' -| In X F -| Q /\ Q' -| Q \/ Q' -| Q -> Q' -| Q <-> Q' -| ~ Q -| True -| False - -F ::= -| S -| empty -| singleton X -| add X F -| remove X F -| union F F' -| inter F F' -| diff F F' - -X ::= x1 | ... | xm -S ::= s1 | ... | sn - ->> - -The tactic will also work on some goals that vary slightly from -the above form: -- The variables and hypotheses may be mixed in any order and may - have already been introduced into the context. Moreover, - there may be additional, unrelated hypotheses mixed in (these - will be ignored). -- A conjunction of hypotheses will be handled as easily as - separate hypotheses, i.e., [P1 /\ P2 -> P] can be solved iff - [P1 -> P2 -> P] can be solved. -- [fsetdec] should solve any goal if the FSet-related hypotheses - are contradictory. -- [fsetdec] will first perform any necessary zeta and beta - reductions and will invoke [subst] to eliminate any Coq - equalities between finite sets or their elements. -- If [E.eq] is convertible with Coq's equality, it will not - matter which one is used in the hypotheses or conclusion. -- The tactic can solve goals where the finite sets or set - elements are expressed by Coq terms that are more complicated - than variables. However, non-local definitions are not - expanded, and Coq equalities between non-variable terms are - not used. For example, this goal will be solved: -<< - forall (f : t -> t), - forall (g : elt -> elt), - forall (s1 s2 : t), - forall (x1 x2 : elt), - Equal s1 (f s2) -> - E.eq x1 (g (g x2)) -> - In x1 s1 -> - In (g (g x2)) (f s2) ->> - This one will not be solved: -<< - forall (f : t -> t), - forall (g : elt -> elt), - forall (s1 s2 : t), - forall (x1 x2 : elt), - Equal s1 (f s2) -> - E.eq x1 (g x2) -> - In x1 s1 -> - g x2 = g (g x2) -> - In (g (g x2)) (f s2) ->> -*) - - (** * Facts and Tactics for Propositional Logic - These lemmas and tactics are in a module so that they do - not affect the namespace if you import the enclosing - module [Decide]. *) - Module FSetLogicalFacts. - Export Decidable. - Export Setoid. - - (** ** Lemmas and Tactics About Decidable Propositions *) - - (** ** Propositional Equivalences Involving Negation - These are all written with the unfolded form of - negation, since I am not sure if setoid rewriting will - always perform conversion. *) - - (** ** Tactics for Negations *) - - Tactic Notation "fold" "any" "not" := - repeat ( - match goal with - | H: context [?P -> False] |- _ => - fold (~ P) in H - | |- context [?P -> False] => - fold (~ P) - end). - - (** [push not using db] will pushes all negations to the - leaves of propositions in the goal, using the lemmas in - [db] to assist in checking the decidability of the - propositions involved. If [using db] is omitted, then - [core] will be used. Additional versions are provided - to manipulate the hypotheses or the hypotheses and goal - together. - - XXX: This tactic and the similar subsequent ones should - have been defined using [autorewrite]. However, dealing - with multiples rewrite sites and side-conditions is - done more cleverly with the following explicit - analysis of goals. *) - - Ltac or_not_l_iff P Q tac := - (rewrite (or_not_l_iff_1 P Q) by tac) || - (rewrite (or_not_l_iff_2 P Q) by tac). - - Ltac or_not_r_iff P Q tac := - (rewrite (or_not_r_iff_1 P Q) by tac) || - (rewrite (or_not_r_iff_2 P Q) by tac). - - Ltac or_not_l_iff_in P Q H tac := - (rewrite (or_not_l_iff_1 P Q) in H by tac) || - (rewrite (or_not_l_iff_2 P Q) in H by tac). - - Ltac or_not_r_iff_in P Q H tac := - (rewrite (or_not_r_iff_1 P Q) in H by tac) || - (rewrite (or_not_r_iff_2 P Q) in H by tac). - - Tactic Notation "push" "not" "using" ident(db) := - let dec := solve_decidable using db in - unfold not, iff; - repeat ( - match goal with - | |- context [True -> False] => rewrite not_true_iff - | |- context [False -> False] => rewrite not_false_iff - | |- context [(?P -> False) -> False] => rewrite (not_not_iff P) by dec - | |- context [(?P -> False) -> (?Q -> False)] => - rewrite (contrapositive P Q) by dec - | |- context [(?P -> False) \/ ?Q] => or_not_l_iff P Q dec - | |- context [?P \/ (?Q -> False)] => or_not_r_iff P Q dec - | |- context [(?P -> False) -> ?Q] => rewrite (imp_not_l P Q) by dec - | |- context [?P \/ ?Q -> False] => rewrite (not_or_iff P Q) - | |- context [?P /\ ?Q -> False] => rewrite (not_and_iff P Q) - | |- context [(?P -> ?Q) -> False] => rewrite (not_imp_iff P Q) by dec - end); - fold any not. - - Tactic Notation "push" "not" := - push not using core. - - Tactic Notation - "push" "not" "in" "*" "|-" "using" ident(db) := - let dec := solve_decidable using db in - unfold not, iff in * |-; - repeat ( - match goal with - | H: context [True -> False] |- _ => rewrite not_true_iff in H - | H: context [False -> False] |- _ => rewrite not_false_iff in H - | H: context [(?P -> False) -> False] |- _ => - rewrite (not_not_iff P) in H by dec - | H: context [(?P -> False) -> (?Q -> False)] |- _ => - rewrite (contrapositive P Q) in H by dec - | H: context [(?P -> False) \/ ?Q] |- _ => or_not_l_iff_in P Q H dec - | H: context [?P \/ (?Q -> False)] |- _ => or_not_r_iff_in P Q H dec - | H: context [(?P -> False) -> ?Q] |- _ => - rewrite (imp_not_l P Q) in H by dec - | H: context [?P \/ ?Q -> False] |- _ => rewrite (not_or_iff P Q) in H - | H: context [?P /\ ?Q -> False] |- _ => rewrite (not_and_iff P Q) in H - | H: context [(?P -> ?Q) -> False] |- _ => - rewrite (not_imp_iff P Q) in H by dec - end); - fold any not. - - Tactic Notation "push" "not" "in" "*" "|-" := - push not in * |- using core. - - Tactic Notation "push" "not" "in" "*" "using" ident(db) := - push not using db; push not in * |- using db. - Tactic Notation "push" "not" "in" "*" := - push not in * using core. - - (** A simple test case to see how this works. *) - Lemma test_push : forall P Q R : Prop, - decidable P -> - decidable Q -> - (~ True) -> - (~ False) -> - (~ ~ P) -> - (~ (P /\ Q) -> ~ R) -> - ((P /\ Q) \/ ~ R) -> - (~ (P /\ Q) \/ R) -> - (R \/ ~ (P /\ Q)) -> - (~ R \/ (P /\ Q)) -> - (~ P -> R) -> - (~ ((R -> P) \/ (Q -> R))) -> - (~ (P /\ R)) -> - (~ (P -> R)) -> - True. - Proof. - intros. push not in *. - (* note that ~(R->P) remains (since R isn't decidable) *) - tauto. - Qed. - - (** [pull not using db] will pull as many negations as - possible toward the top of the propositions in the goal, - using the lemmas in [db] to assist in checking the - decidability of the propositions involved. If [using - db] is omitted, then [core] will be used. Additional - versions are provided to manipulate the hypotheses or - the hypotheses and goal together. *) - - Tactic Notation "pull" "not" "using" ident(db) := - let dec := solve_decidable using db in - unfold not, iff; - repeat ( - match goal with - | |- context [True -> False] => rewrite not_true_iff - | |- context [False -> False] => rewrite not_false_iff - | |- context [(?P -> False) -> False] => rewrite (not_not_iff P) by dec - | |- context [(?P -> False) -> (?Q -> False)] => - rewrite (contrapositive P Q) by dec - | |- context [(?P -> False) \/ ?Q] => or_not_l_iff P Q dec - | |- context [?P \/ (?Q -> False)] => or_not_r_iff P Q dec - | |- context [(?P -> False) -> ?Q] => rewrite (imp_not_l P Q) by dec - | |- context [(?P -> False) /\ (?Q -> False)] => - rewrite <- (not_or_iff P Q) - | |- context [?P -> ?Q -> False] => rewrite <- (not_and_iff P Q) - | |- context [?P /\ (?Q -> False)] => rewrite <- (not_imp_iff P Q) by dec - | |- context [(?Q -> False) /\ ?P] => - rewrite <- (not_imp_rev_iff P Q) by dec - end); - fold any not. - - Tactic Notation "pull" "not" := - pull not using core. - - Tactic Notation - "pull" "not" "in" "*" "|-" "using" ident(db) := - let dec := solve_decidable using db in - unfold not, iff in * |-; - repeat ( - match goal with - | H: context [True -> False] |- _ => rewrite not_true_iff in H - | H: context [False -> False] |- _ => rewrite not_false_iff in H - | H: context [(?P -> False) -> False] |- _ => - rewrite (not_not_iff P) in H by dec - | H: context [(?P -> False) -> (?Q -> False)] |- _ => - rewrite (contrapositive P Q) in H by dec - | H: context [(?P -> False) \/ ?Q] |- _ => or_not_l_iff_in P Q H dec - | H: context [?P \/ (?Q -> False)] |- _ => or_not_r_iff_in P Q H dec - | H: context [(?P -> False) -> ?Q] |- _ => - rewrite (imp_not_l P Q) in H by dec - | H: context [(?P -> False) /\ (?Q -> False)] |- _ => - rewrite <- (not_or_iff P Q) in H - | H: context [?P -> ?Q -> False] |- _ => - rewrite <- (not_and_iff P Q) in H - | H: context [?P /\ (?Q -> False)] |- _ => - rewrite <- (not_imp_iff P Q) in H by dec - | H: context [(?Q -> False) /\ ?P] |- _ => - rewrite <- (not_imp_rev_iff P Q) in H by dec - end); - fold any not. - - Tactic Notation "pull" "not" "in" "*" "|-" := - pull not in * |- using core. - - Tactic Notation "pull" "not" "in" "*" "using" ident(db) := - pull not using db; pull not in * |- using db. - Tactic Notation "pull" "not" "in" "*" := - pull not in * using core. - - (** A simple test case to see how this works. *) - Lemma test_pull : forall P Q R : Prop, - decidable P -> - decidable Q -> - (~ True) -> - (~ False) -> - (~ ~ P) -> - (~ (P /\ Q) -> ~ R) -> - ((P /\ Q) \/ ~ R) -> - (~ (P /\ Q) \/ R) -> - (R \/ ~ (P /\ Q)) -> - (~ R \/ (P /\ Q)) -> - (~ P -> R) -> - (~ (R -> P) /\ ~ (Q -> R)) -> - (~ P \/ ~ R) -> - (P /\ ~ R) -> - (~ R /\ P) -> - True. - Proof. - intros. pull not in *. tauto. - Qed. - - End FSetLogicalFacts. - Import FSetLogicalFacts. - - (** * Auxiliary Tactics - Again, these lemmas and tactics are in a module so that - they do not affect the namespace if you import the - enclosing module [Decide]. *) - Module FSetDecideAuxiliary. - - (** ** Generic Tactics - We begin by defining a few generic, useful tactics. *) - - (** remove logical hypothesis inter-dependencies (fix #2136). *) - - Ltac no_logical_interdep := - match goal with - | H : ?P |- _ => - match type of P with - | Prop => - match goal with H' : context [ H ] |- _ => clear dependent H' end - | _ => fail - end; no_logical_interdep - | _ => idtac - end. - - Ltac abstract_term t := - tryif (is_var t) then fail "no need to abstract a variable" - else (let x := fresh "x" in set (x := t) in *; try clearbody x). - - Ltac abstract_elements := - repeat - (match goal with - | |- context [ singleton ?t ] => abstract_term t - | _ : context [ singleton ?t ] |- _ => abstract_term t - | |- context [ add ?t _ ] => abstract_term t - | _ : context [ add ?t _ ] |- _ => abstract_term t - | |- context [ remove ?t _ ] => abstract_term t - | _ : context [ remove ?t _ ] |- _ => abstract_term t - | |- context [ In ?t _ ] => abstract_term t - | _ : context [ In ?t _ ] |- _ => abstract_term t - end). - - (** [prop P holds by t] succeeds (but does not modify the - goal or context) if the proposition [P] can be proved by - [t] in the current context. Otherwise, the tactic - fails. *) - Tactic Notation "prop" constr(P) "holds" "by" tactic(t) := - let H := fresh in - assert P as H by t; - clear H. - - (** This tactic acts just like [assert ... by ...] but will - fail if the context already contains the proposition. *) - Tactic Notation "assert" "new" constr(e) "by" tactic(t) := - match goal with - | H: e |- _ => fail 1 - | _ => assert e by t - end. - - (** [subst++] is similar to [subst] except that - - it never fails (as [subst] does on recursive - equations), - - it substitutes locally defined variable for their - definitions, - - it performs beta reductions everywhere, which may - arise after substituting a locally defined function - for its definition. - *) - Tactic Notation "subst" "++" := - repeat ( - match goal with - | x : _ |- _ => subst x - end); - cbv zeta beta in *. - - (** [decompose records] calls [decompose record H] on every - relevant hypothesis [H]. *) - Tactic Notation "decompose" "records" := - repeat ( - match goal with - | H: _ |- _ => progress (decompose record H); clear H - end). - - (** ** Discarding Irrelevant Hypotheses - We will want to clear the context of any - non-FSet-related hypotheses in order to increase the - speed of the tactic. To do this, we will need to be - able to decide which are relevant. We do this by making - a simple inductive definition classifying the - propositions of interest. *) - - Inductive FSet_elt_Prop : Prop -> Prop := - | eq_Prop : forall (S : Type) (x y : S), - FSet_elt_Prop (x = y) - | eq_elt_prop : forall x y, - FSet_elt_Prop (E.eq x y) - | In_elt_prop : forall x s, - FSet_elt_Prop (In x s) - | True_elt_prop : - FSet_elt_Prop True - | False_elt_prop : - FSet_elt_Prop False - | conj_elt_prop : forall P Q, - FSet_elt_Prop P -> - FSet_elt_Prop Q -> - FSet_elt_Prop (P /\ Q) - | disj_elt_prop : forall P Q, - FSet_elt_Prop P -> - FSet_elt_Prop Q -> - FSet_elt_Prop (P \/ Q) - | impl_elt_prop : forall P Q, - FSet_elt_Prop P -> - FSet_elt_Prop Q -> - FSet_elt_Prop (P -> Q) - | not_elt_prop : forall P, - FSet_elt_Prop P -> - FSet_elt_Prop (~ P). - - Inductive FSet_Prop : Prop -> Prop := - | elt_FSet_Prop : forall P, - FSet_elt_Prop P -> - FSet_Prop P - | Empty_FSet_Prop : forall s, - FSet_Prop (Empty s) - | Subset_FSet_Prop : forall s1 s2, - FSet_Prop (Subset s1 s2) - | Equal_FSet_Prop : forall s1 s2, - FSet_Prop (Equal s1 s2). - - (** Here is the tactic that will throw away hypotheses that - are not useful (for the intended scope of the [fsetdec] - tactic). *) - #[global] - Hint Constructors FSet_elt_Prop FSet_Prop : FSet_Prop. - Ltac discard_nonFSet := - repeat ( - match goal with - | H : context [ @Logic.eq ?T ?x ?y ] |- _ => - tryif (change T with E.t in H) then fail - else tryif (change T with t in H) then fail - else clear H - | H : ?P |- _ => - tryif prop (FSet_Prop P) holds by - (auto 100 with FSet_Prop) - then fail - else clear H - end). - - (** ** Turning Set Operators into Propositional Connectives - The lemmas from [FSetFacts] will be used to break down - set operations into propositional formulas built over - the predicates [In] and [E.eq] applied only to - variables. We are going to use them with [autorewrite]. - *) - - Global Hint Rewrite - F.empty_iff F.singleton_iff F.add_iff F.remove_iff - F.union_iff F.inter_iff F.diff_iff - : set_simpl. - - Lemma eq_refl_iff (x : E.t) : E.eq x x <-> True. - Proof. - now split. - Qed. - - Global Hint Rewrite eq_refl_iff : set_eq_simpl. - - (** ** Decidability of FSet Propositions *) - - (** [In] is decidable. *) - Lemma dec_In : forall x s, - decidable (In x s). - Proof. - red; intros; generalize (F.mem_iff s x); case (mem x s); intuition auto with bool. - Qed. - - (** [E.eq] is decidable. *) - Lemma dec_eq : forall (x y : E.t), - decidable (E.eq x y). - Proof. - red; intros x y; destruct (E.eq_dec x y); auto. - Qed. - - (** The hint database [FSet_decidability] will be given to - the [push_neg] tactic from the module [Negation]. *) - #[global] - Hint Resolve dec_In dec_eq : FSet_decidability. - - (** ** Normalizing Propositions About Equality - We have to deal with the fact that [E.eq] may be - convertible with Coq's equality. Thus, we will find the - following tactics useful to replace one form with the - other everywhere. *) - - (** The next tactic, [Logic_eq_to_E_eq], mentions the term - [E.t]; thus, we must ensure that [E.t] is used in favor - of any other convertible but syntactically distinct - term. *) - Ltac change_to_E_t := - repeat ( - match goal with - | H : ?T |- _ => - progress (change T with E.t in H); - repeat ( - match goal with - | J : _ |- _ => progress (change T with E.t in J) - | |- _ => progress (change T with E.t) - end ) - | H : forall x : ?T, _ |- _ => - progress (change T with E.t in H); - repeat ( - match goal with - | J : _ |- _ => progress (change T with E.t in J) - | |- _ => progress (change T with E.t) - end ) - end). - - (** These two tactics take us from Coq's built-in equality - to [E.eq] (and vice versa) when possible. *) - - Ltac Logic_eq_to_E_eq := - repeat ( - match goal with - | H: _ |- _ => - progress (change (@Logic.eq E.t) with E.eq in H) - | |- _ => - progress (change (@Logic.eq E.t) with E.eq) - end). - - Ltac E_eq_to_Logic_eq := - repeat ( - match goal with - | H: _ |- _ => - progress (change E.eq with (@Logic.eq E.t) in H) - | |- _ => - progress (change E.eq with (@Logic.eq E.t)) - end). - - (** This tactic works like the built-in tactic [subst], but - at the level of set element equality (which may not be - the convertible with Coq's equality). *) - Ltac substFSet := - repeat ( - match goal with - | H: E.eq ?x ?x |- _ => clear H - | H: E.eq ?x ?y |- _ => rewrite H in *; clear H - end); - autorewrite with set_eq_simpl in *. - - (** ** Considering Decidability of Base Propositions - This tactic adds assertions about the decidability of - [E.eq] and [In] to the context. This is necessary for - the completeness of the [fsetdec] tactic. However, in - order to minimize the cost of proof search, we should be - careful to not add more than we need. Once negations - have been pushed to the leaves of the propositions, we - only need to worry about decidability for those base - propositions that appear in a negated form. *) - Ltac assert_decidability := - (** We actually don't want these rules to fire if the - syntactic context in the patterns below is trivially - empty, but we'll just do some clean-up at the - afterward. *) - repeat ( - match goal with - | H: context [~ E.eq ?x ?y] |- _ => - assert new (E.eq x y \/ ~ E.eq x y) by (apply dec_eq) - | H: context [~ In ?x ?s] |- _ => - assert new (In x s \/ ~ In x s) by (apply dec_In) - | |- context [~ E.eq ?x ?y] => - assert new (E.eq x y \/ ~ E.eq x y) by (apply dec_eq) - | |- context [~ In ?x ?s] => - assert new (In x s \/ ~ In x s) by (apply dec_In) - end); - (** Now we eliminate the useless facts we added (because - they would likely be very harmful to performance). *) - repeat ( - match goal with - | _: ~ ?P, H : ?P \/ ~ ?P |- _ => clear H - end). - - (** ** Handling [Empty], [Subset], and [Equal] - This tactic instantiates universally quantified - hypotheses (which arise from the unfolding of [Empty], - [Subset], and [Equal]) for each of the set element - expressions that is involved in some membership or - equality fact. Then it throws away those hypotheses, - which should no longer be needed. *) - Ltac inst_FSet_hypotheses := - repeat ( - match goal with - | H : forall a : E.t, _, - _ : context [ In ?x _ ] |- _ => - let P := type of (H x) in - assert new P by (exact (H x)) - | H : forall a : E.t, _ - |- context [ In ?x _ ] => - let P := type of (H x) in - assert new P by (exact (H x)) - | H : forall a : E.t, _, - _ : context [ E.eq ?x _ ] |- _ => - let P := type of (H x) in - assert new P by (exact (H x)) - | H : forall a : E.t, _ - |- context [ E.eq ?x _ ] => - let P := type of (H x) in - assert new P by (exact (H x)) - | H : forall a : E.t, _, - _ : context [ E.eq _ ?x ] |- _ => - let P := type of (H x) in - assert new P by (exact (H x)) - | H : forall a : E.t, _ - |- context [ E.eq _ ?x ] => - let P := type of (H x) in - assert new P by (exact (H x)) - end); - repeat ( - match goal with - | H : forall a : E.t, _ |- _ => - clear H - end). - - (** ** The Core [fsetdec] Auxiliary Tactics *) - - (** Here is the crux of the proof search. Recursion through - [intuition]! (This will terminate if I correctly - understand the behavior of [intuition].) *) - Ltac fsetdec_rec := progress substFSet; intuition fsetdec_rec. - - (** If we add [unfold Empty, Subset, Equal in *; intros;] to - the beginning of this tactic, it will satisfy the same - specification as the [fsetdec] tactic; however, it will - be much slower than necessary without the pre-processing - done by the wrapper tactic [fsetdec]. *) - Ltac fsetdec_body := - autorewrite with set_eq_simpl in *; - inst_FSet_hypotheses; - autorewrite with set_simpl set_eq_simpl in *; - push not in * using FSet_decidability; - substFSet; - assert_decidability; - auto; - (intuition fsetdec_rec) || - fail 1 - "because the goal is beyond the scope of this tactic". - - End FSetDecideAuxiliary. - Import FSetDecideAuxiliary. - - (** * The [fsetdec] Tactic - Here is the top-level tactic (the only one intended for - clients of this library). It's specification is given at - the top of the file. *) - Ltac fsetdec := - (** We first unfold any occurrences of [iff]. *) - unfold iff in *; - (** We fold occurrences of [not] because it is better for - [intros] to leave us with a goal of [~ P] than a goal of - [False]. *) - fold any not; intros; - (** We don't care about the value of elements : complex ones are - abstracted as new variables (avoiding potential dependencies, - see bug #2464) *) - abstract_elements; - (** We remove dependencies to logical hypothesis. This way, - later "clear" will work nicely (see bug #2136) *) - no_logical_interdep; - (** Now we decompose conjunctions, which will allow the - [discard_nonFSet] and [assert_decidability] tactics to - do a much better job. *) - decompose records; - discard_nonFSet; - (** We unfold these defined propositions on finite sets. If - our goal was one of them, then have one more item to - introduce now. *) - unfold Empty, Subset, Equal in *; intros; - (** We now want to get rid of all uses of [=] in favor of - [E.eq]. However, the best way to eliminate a [=] is in - the context is with [subst], so we will try that first. - In fact, we may as well convert uses of [E.eq] into [=] - when possible before we do [subst] so that we can even - more mileage out of it. Then we will convert all - remaining uses of [=] back to [E.eq] when possible. We - use [change_to_E_t] to ensure that we have a canonical - name for set elements, so that [Logic_eq_to_E_eq] will - work properly. *) - change_to_E_t; E_eq_to_Logic_eq; subst++; Logic_eq_to_E_eq; - (** The next optimization is to swap a negated goal with a - negated hypothesis when possible. Any swap will improve - performance by eliminating the total number of - negations, but we will get the maximum benefit if we - swap the goal with a hypotheses mentioning the same set - element, so we try that first. If we reach the fourth - branch below, we attempt any swap. However, to maintain - completeness of this tactic, we can only perform such a - swap with a decidable proposition; hence, we first test - whether the hypothesis is an [FSet_elt_Prop], noting - that any [FSet_elt_Prop] is decidable. *) - pull not using FSet_decidability; - unfold not in *; - match goal with - | H: (In ?x ?r) -> False |- (In ?x ?s) -> False => - contradict H; fsetdec_body - | H: (In ?x ?r) -> False |- (E.eq ?x ?y) -> False => - contradict H; fsetdec_body - | H: (In ?x ?r) -> False |- (E.eq ?y ?x) -> False => - contradict H; fsetdec_body - | H: ?P -> False |- ?Q -> False => - tryif prop (FSet_elt_Prop P) holds by - (auto 100 with FSet_Prop) - then (contradict H; fsetdec_body) - else fsetdec_body - | |- _ => - fsetdec_body - end. - - (** * Examples *) - - Module FSetDecideTestCases. - - Lemma test_eq_trans_1 : forall x y z s, - E.eq x y -> - ~ ~ E.eq z y -> - In x s -> - In z s. - Proof. fsetdec. Qed. - - Lemma test_eq_trans_2 : forall x y z r s, - In x (singleton y) -> - ~ In z r -> - ~ ~ In z (add y r) -> - In x s -> - In z s. - Proof. fsetdec. Qed. - - Lemma test_eq_neq_trans_1 : forall w x y z s, - E.eq x w -> - ~ ~ E.eq x y -> - ~ E.eq y z -> - In w s -> - In w (remove z s). - Proof. fsetdec. Qed. - - Lemma test_eq_neq_trans_2 : forall w x y z r1 r2 s, - In x (singleton w) -> - ~ In x r1 -> - In x (add y r1) -> - In y r2 -> - In y (remove z r2) -> - In w s -> - In w (remove z s). - Proof. fsetdec. Qed. - - Lemma test_In_singleton : forall x, - In x (singleton x). - Proof. fsetdec. Qed. - - Lemma test_add_In : forall x y s, - In x (add y s) -> - ~ E.eq x y -> - In x s. - Proof. fsetdec. Qed. - - Lemma test_Subset_add_remove : forall x s, - s [<=] (add x (remove x s)). - Proof. fsetdec. Qed. - - Lemma test_eq_disjunction : forall w x y z, - In w (add x (add y (singleton z))) -> - E.eq w x \/ E.eq w y \/ E.eq w z. - Proof. fsetdec. Qed. - - Lemma test_not_In_disj : forall x y s1 s2 s3 s4, - ~ In x (union s1 (union s2 (union s3 (add y s4)))) -> - ~ (In x s1 \/ In x s4 \/ E.eq y x). - Proof. fsetdec. Qed. - - Lemma test_not_In_conj : forall x y s1 s2 s3 s4, - ~ In x (union s1 (union s2 (union s3 (add y s4)))) -> - ~ In x s1 /\ ~ In x s4 /\ ~ E.eq y x. - Proof. fsetdec. Qed. - - Lemma test_iff_conj : forall a x s s', - (In a s' <-> E.eq x a \/ In a s) -> - (In a s' <-> In a (add x s)). - Proof. fsetdec. Qed. - - Lemma test_set_ops_1 : forall x q r s, - (singleton x) [<=] s -> - Empty (union q r) -> - Empty (inter (diff s q) (diff s r)) -> - ~ In x s. - Proof. fsetdec. Qed. - - Lemma eq_chain_test : forall x1 x2 x3 x4 s1 s2 s3 s4, - Empty s1 -> - In x2 (add x1 s1) -> - In x3 s2 -> - ~ In x3 (remove x2 s2) -> - ~ In x4 s3 -> - In x4 (add x3 s3) -> - In x1 s4 -> - Subset (add x4 s4) s4. - Proof. fsetdec. Qed. - - Lemma test_too_complex : forall x y z r s, - E.eq x y -> - (In x (singleton y) -> r [<=] s) -> - In z r -> - In z s. - Proof. - (** [fsetdec] is not intended to solve this directly. *) - intros until s; intros Heq H Hr; lapply H; fsetdec. - Qed. - - Lemma function_test_1 : - forall (f : t -> t), - forall (g : elt -> elt), - forall (s1 s2 : t), - forall (x1 x2 : elt), - Equal s1 (f s2) -> - E.eq x1 (g (g x2)) -> - In x1 s1 -> - In (g (g x2)) (f s2). - Proof. fsetdec. Qed. - - Lemma function_test_2 : - forall (f : t -> t), - forall (g : elt -> elt), - forall (s1 s2 : t), - forall (x1 x2 : elt), - Equal s1 (f s2) -> - E.eq x1 (g x2) -> - In x1 s1 -> - g x2 = g (g x2) -> - In (g (g x2)) (f s2). - Proof. - (** [fsetdec] is not intended to solve this directly. *) - intros until 3. intros g_eq. rewrite <- g_eq. fsetdec. - Qed. - - Lemma test_baydemir : - forall (f : t -> t), - forall (s : t), - forall (x y : elt), - In x (add y (f s)) -> - ~ E.eq x y -> - In x (f s). - Proof. - fsetdec. - Qed. - - End FSetDecideTestCases. - -End WDecide_fun. - -Require Import FSetInterface. - -(** Now comes variants for self-contained weak sets and for full sets. - For these variants, only one argument is necessary. Thanks to - the subtyping [WS<=S], the [Decide] functor which is meant to be - used on modules [(M:S)] can simply be an alias of [WDecide]. *) - -Module WDecide (M:WS) := !WDecide_fun M.E M. -Module Decide := WDecide. diff --git a/stdlib/theories/FSets/FSetEqProperties.v b/stdlib/theories/FSets/FSetEqProperties.v deleted file mode 100644 index 566bc19db399..000000000000 --- a/stdlib/theories/FSets/FSetEqProperties.v +++ /dev/null @@ -1,958 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* mem x s=mem y s. -Proof. -intro H; rewrite H; auto. -Qed. - -Lemma equal_mem_1: - (forall a, mem a s=mem a s') -> equal s s'=true. -Proof. -intros; apply equal_1; unfold Equal; intros. -do 2 rewrite mem_iff; rewrite H; tauto. -Qed. - -Lemma equal_mem_2: - equal s s'=true -> forall a, mem a s=mem a s'. -Proof. -intros; rewrite (equal_2 H); auto. -Qed. - -Lemma subset_mem_1: - (forall a, mem a s=true->mem a s'=true) -> subset s s'=true. -Proof. -intros; apply subset_1; unfold Subset; intros a. -do 2 rewrite mem_iff; auto. -Qed. - -Lemma subset_mem_2: - subset s s'=true -> forall a, mem a s=true -> mem a s'=true. -Proof. -intros H a; do 2 rewrite <- mem_iff; apply subset_2; auto. -Qed. - -Lemma empty_mem: mem x empty=false. -Proof. -rewrite <- not_mem_iff; auto with set. -Qed. - -Lemma is_empty_equal_empty: is_empty s = equal s empty. -Proof. -apply bool_1; split; intros. -- auto with set. -- rewrite <- is_empty_iff; auto with set. -Qed. - -Lemma choose_mem_1: choose s=Some x -> mem x s=true. -Proof. -auto with set. -Qed. - -Lemma choose_mem_2: choose s=None -> is_empty s=true. -Proof. -auto with set. -Qed. - -Lemma add_mem_1: mem x (add x s)=true. -Proof. -auto with set. -Qed. - -Lemma add_mem_2: ~E.eq x y -> mem y (add x s)=mem y s. -Proof. -apply add_neq_b. -Qed. - -Lemma remove_mem_1: mem x (remove x s)=false. -Proof. -rewrite <- not_mem_iff; auto with set. -Qed. - -Lemma remove_mem_2: ~E.eq x y -> mem y (remove x s)=mem y s. -Proof. -apply remove_neq_b. -Qed. - -Lemma singleton_equal_add: - equal (singleton x) (add x empty)=true. -Proof. -rewrite (singleton_equal_add x); auto with set. -Qed. - -Lemma union_mem: - mem x (union s s')=mem x s || mem x s'. -Proof. -apply union_b. -Qed. - -Lemma inter_mem: - mem x (inter s s')=mem x s && mem x s'. -Proof. -apply inter_b. -Qed. - -Lemma diff_mem: - mem x (diff s s')=mem x s && negb (mem x s'). -Proof. -apply diff_b. -Qed. - -(** properties of [mem] *) - -Lemma mem_3 : ~In x s -> mem x s=false. -Proof. -intros; rewrite <- not_mem_iff; auto. -Qed. - -Lemma mem_4 : mem x s=false -> ~In x s. -Proof. -intros; rewrite not_mem_iff; auto. -Qed. - -(** Properties of [equal] *) - -Lemma equal_refl: equal s s=true. -Proof. -auto with set. -Qed. - -Lemma equal_sym: equal s s'=equal s' s. -Proof. -intros; apply bool_1; do 2 rewrite <- equal_iff; intuition auto with relations. -Qed. - -Lemma equal_trans: - equal s s'=true -> equal s' s''=true -> equal s s''=true. -Proof. -intros; rewrite (equal_2 H); auto. -Qed. - -Lemma equal_equal: - equal s s'=true -> equal s s''=equal s' s''. -Proof. -intros; rewrite (equal_2 H); auto. -Qed. - -Lemma equal_cardinal: - equal s s'=true -> cardinal s=cardinal s'. -Proof. -auto with set fset. -Qed. - -(* Properties of [subset] *) - -Lemma subset_refl: subset s s=true. -Proof. -auto with set. -Qed. - -Lemma subset_antisym: - subset s s'=true -> subset s' s=true -> equal s s'=true. -Proof. -auto with set. -Qed. - -Lemma subset_trans: - subset s s'=true -> subset s' s''=true -> subset s s''=true. -Proof. -do 3 rewrite <- subset_iff; intros. -apply subset_trans with s'; auto. -Qed. - -Lemma subset_equal: - equal s s'=true -> subset s s'=true. -Proof. -auto with set. -Qed. - -(** Properties of [choose] *) - -Lemma choose_mem_3: - is_empty s=false -> {x:elt|choose s=Some x /\ mem x s=true}. -Proof. -intros. -generalize (@choose_1 s) (@choose_2 s). -destruct (choose s);intros. -- exists e;auto with set. -- generalize (H1 Logic.eq_refl); clear H1. - intros; rewrite (is_empty_1 H1) in H; discriminate. -Qed. - -Lemma choose_mem_4: choose empty=None. -Proof. -generalize (@choose_1 empty). -case (@choose empty);intros;auto. -elim (@empty_1 e); auto. -Qed. - -(** Properties of [add] *) - -Lemma add_mem_3: - mem y s=true -> mem y (add x s)=true. -Proof. -auto with set. -Qed. - -Lemma add_equal: - mem x s=true -> equal (add x s) s=true. -Proof. -auto with set. -Qed. - -(** Properties of [remove] *) - -Lemma remove_mem_3: - mem y (remove x s)=true -> mem y s=true. -Proof. -rewrite remove_b; intros H;destruct (andb_prop _ _ H); auto. -Qed. - -Lemma remove_equal: - mem x s=false -> equal (remove x s) s=true. -Proof. -intros; apply equal_1; apply remove_equal. -rewrite not_mem_iff; auto. -Qed. - -Lemma add_remove: - mem x s=true -> equal (add x (remove x s)) s=true. -Proof. -intros; apply equal_1; apply add_remove; auto with set. -Qed. - -Lemma remove_add: - mem x s=false -> equal (remove x (add x s)) s=true. -Proof. -intros; apply equal_1; apply remove_add; auto. -rewrite not_mem_iff; auto. -Qed. - -(** Properties of [is_empty] *) - -Lemma is_empty_cardinal: is_empty s = zerob (cardinal s). -Proof. -intros; apply bool_1; split; intros. -- rewrite MP.cardinal_1; simpl; auto with set. -- assert (cardinal s = 0) by (apply zerob_true_elim; auto). - auto with set fset. -Qed. - -(** Properties of [singleton] *) - -Lemma singleton_mem_1: mem x (singleton x)=true. -Proof. -auto with set. -Qed. - -Lemma singleton_mem_2: ~E.eq x y -> mem y (singleton x)=false. -Proof. -intros; rewrite singleton_b. -unfold eqb; destruct (E.eq_dec x y); intuition. -Qed. - -Lemma singleton_mem_3: mem y (singleton x)=true -> E.eq x y. -Proof. -intros; apply singleton_1; auto with set. -Qed. - -(** Properties of [union] *) - -Lemma union_sym: - equal (union s s') (union s' s)=true. -Proof. -auto with set. -Qed. - -Lemma union_subset_equal: - subset s s'=true -> equal (union s s') s'=true. -Proof. -auto with set. -Qed. - -Lemma union_equal_1: - equal s s'=true-> equal (union s s'') (union s' s'')=true. -Proof. -auto with set. -Qed. - -Lemma union_equal_2: - equal s' s''=true-> equal (union s s') (union s s'')=true. -Proof. -auto with set. -Qed. - -Lemma union_assoc: - equal (union (union s s') s'') (union s (union s' s''))=true. -Proof. -auto with set. -Qed. - -Lemma add_union_singleton: - equal (add x s) (union (singleton x) s)=true. -Proof. -auto with set. -Qed. - -Lemma union_add: - equal (union (add x s) s') (add x (union s s'))=true. -Proof. -auto with set. -Qed. - -(* characterisation of [union] via [subset] *) - -Lemma union_subset_1: subset s (union s s')=true. -Proof. -auto with set. -Qed. - -Lemma union_subset_2: subset s' (union s s')=true. -Proof. -auto with set. -Qed. - -Lemma union_subset_3: - subset s s''=true -> subset s' s''=true -> - subset (union s s') s''=true. -Proof. -intros; apply subset_1; apply union_subset_3; auto with set. -Qed. - -(** Properties of [inter] *) - -Lemma inter_sym: equal (inter s s') (inter s' s)=true. -Proof. -auto with set. -Qed. - -Lemma inter_subset_equal: - subset s s'=true -> equal (inter s s') s=true. -Proof. -auto with set. -Qed. - -Lemma inter_equal_1: - equal s s'=true -> equal (inter s s'') (inter s' s'')=true. -Proof. -auto with set. -Qed. - -Lemma inter_equal_2: - equal s' s''=true -> equal (inter s s') (inter s s'')=true. -Proof. -auto with set. -Qed. - -Lemma inter_assoc: - equal (inter (inter s s') s'') (inter s (inter s' s''))=true. -Proof. -auto with set. -Qed. - -Lemma union_inter_1: - equal (inter (union s s') s'') (union (inter s s'') (inter s' s''))=true. -Proof. -auto with set. -Qed. - -Lemma union_inter_2: - equal (union (inter s s') s'') (inter (union s s'') (union s' s''))=true. -Proof. -auto with set. -Qed. - -Lemma inter_add_1: mem x s'=true -> - equal (inter (add x s) s') (add x (inter s s'))=true. -Proof. -auto with set. -Qed. - -Lemma inter_add_2: mem x s'=false -> - equal (inter (add x s) s') (inter s s')=true. -Proof. -intros; apply equal_1; apply inter_add_2. -rewrite not_mem_iff; auto. -Qed. - -(* characterisation of [union] via [subset] *) - -Lemma inter_subset_1: subset (inter s s') s=true. -Proof. -auto with set. -Qed. - -Lemma inter_subset_2: subset (inter s s') s'=true. -Proof. -auto with set. -Qed. - -Lemma inter_subset_3: - subset s'' s=true -> subset s'' s'=true -> - subset s'' (inter s s')=true. -Proof. -intros; apply subset_1; apply inter_subset_3; auto with set. -Qed. - -(** Properties of [diff] *) - -Lemma diff_subset: subset (diff s s') s=true. -Proof. -auto with set. -Qed. - -Lemma diff_subset_equal: - subset s s'=true -> equal (diff s s') empty=true. -Proof. -auto with set. -Qed. - -Lemma remove_inter_singleton: - equal (remove x s) (diff s (singleton x))=true. -Proof. -auto with set. -Qed. - -Lemma diff_inter_empty: - equal (inter (diff s s') (inter s s')) empty=true. -Proof. -auto with set. -Qed. - -Lemma diff_inter_all: - equal (union (diff s s') (inter s s')) s=true. -Proof. -auto with set. -Qed. - -End BasicProperties. - -#[global] -Hint Immediate empty_mem is_empty_equal_empty add_mem_1 - remove_mem_1 singleton_equal_add union_mem inter_mem - diff_mem equal_sym add_remove remove_add : set. -#[global] -Hint Resolve equal_mem_1 subset_mem_1 choose_mem_1 - choose_mem_2 add_mem_2 remove_mem_2 equal_refl equal_equal - subset_refl subset_equal subset_antisym - add_mem_3 add_equal remove_mem_3 remove_equal : set. - - -(** General recursion principle *) - -Lemma set_rec: forall (P:t->Type), - (forall s s', equal s s'=true -> P s -> P s') -> - (forall s x, mem x s=false -> P s -> P (add x s)) -> - P empty -> forall s, P s. -Proof. -intros. -apply set_induction; auto; intros. -- apply X with empty; auto with set. -- apply X with (add x s0); auto with set. - + apply equal_1; intro a; rewrite add_iff; rewrite (H0 a); tauto. - + apply X0; auto with set; apply mem_3; auto. -Qed. - -(** Properties of [fold] *) - -Lemma exclusive_set : forall s s' x, - ~(In x s/\In x s') <-> mem x s && mem x s'=false. -Proof. -intros; do 2 rewrite mem_iff. -destruct (mem x s); destruct (mem x s'); intuition auto with bool. -Qed. - -Section Fold. -Variables (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA). -Variables (f:elt->A->A)(Comp:compat_op E.eq eqA f)(Ass:transpose eqA f). -Variables (i:A). -Variables (s s':t)(x:elt). - -Lemma fold_empty: (fold f empty i) = i. -Proof. -apply fold_empty; auto. -Qed. - -Lemma fold_equal: - equal s s'=true -> eqA (fold f s i) (fold f s' i). -Proof. -intros; apply fold_equal with (eqA:=eqA); auto with set. -Qed. - -Lemma fold_add: - mem x s=false -> eqA (fold f (add x s) i) (f x (fold f s i)). -Proof. -intros; apply fold_add with (eqA:=eqA); auto. -rewrite not_mem_iff; auto. -Qed. - -Lemma add_fold: - mem x s=true -> eqA (fold f (add x s) i) (fold f s i). -Proof. -intros; apply add_fold with (eqA:=eqA); auto with set. -Qed. - -Lemma remove_fold_1: - mem x s=true -> eqA (f x (fold f (remove x s) i)) (fold f s i). -Proof. -intros; apply remove_fold_1 with (eqA:=eqA); auto with set. -Qed. - -Lemma remove_fold_2: - mem x s=false -> eqA (fold f (remove x s) i) (fold f s i). -Proof. -intros; apply remove_fold_2 with (eqA:=eqA); auto. -rewrite not_mem_iff; auto. -Qed. - -Lemma fold_union: - (forall x, mem x s && mem x s'=false) -> - eqA (fold f (union s s') i) (fold f s (fold f s' i)). -Proof. -intros; apply fold_union with (eqA:=eqA); auto. -intros; rewrite exclusive_set; auto. -Qed. - -End Fold. - -(** Properties of [cardinal] *) - -Lemma add_cardinal_1: - forall s x, mem x s=true -> cardinal (add x s)=cardinal s. -Proof. -auto with set fset. -Qed. - -Lemma add_cardinal_2: - forall s x, mem x s=false -> cardinal (add x s)=S (cardinal s). -Proof. -intros; apply add_cardinal_2; auto. -rewrite not_mem_iff; auto. -Qed. - -Lemma remove_cardinal_1: - forall s x, mem x s=true -> S (cardinal (remove x s))=cardinal s. -Proof. -intros; apply remove_cardinal_1; auto with set. -Qed. - -Lemma remove_cardinal_2: - forall s x, mem x s=false -> cardinal (remove x s)=cardinal s. -Proof. -intros; apply Equal_cardinal; apply equal_2; auto with set. -Qed. - -Lemma union_cardinal: - forall s s', (forall x, mem x s && mem x s'=false) -> - cardinal (union s s')=cardinal s+cardinal s'. -Proof. -intros; apply union_cardinal; auto; intros. -rewrite exclusive_set; auto. -Qed. - -Lemma subset_cardinal: - forall s s', subset s s'=true -> cardinal s<=cardinal s'. -Proof. -intros; apply subset_cardinal; auto with set. -Qed. - -Section Bool. - -(** Properties of [filter] *) - -Variable f:elt->bool. -Variable Comp: Proper (E.eq==>Logic.eq) f. - -Local Definition Comp' : Proper (E.eq==>Logic.eq) (fun x =>negb (f x)). -Proof. -repeat red; intros; f_equal; auto. -Defined. - -Local Hint Resolve Comp' : core. -Local Hint Unfold compat_bool : core. - -Lemma filter_mem: forall s x, mem x (filter f s)=mem x s && f x. -Proof. -intros; apply filter_b; auto. -Qed. - -Lemma for_all_filter: - forall s, for_all f s=is_empty (filter (fun x => negb (f x)) s). -Proof. -intros; apply bool_1; split; intros. -- apply is_empty_1. - unfold Empty; intros. - rewrite filter_iff; auto. - red; destruct 1. - rewrite <- (@for_all_iff s f) in H; auto. - rewrite (H a H0) in H1; discriminate. -- apply for_all_1; auto; red; intros. - revert H; rewrite <- is_empty_iff. - unfold Empty; intro H; generalize (H x); clear H. - rewrite filter_iff; auto. - destruct (f x); auto. -Qed. - -Lemma exists_filter : - forall s, exists_ f s=negb (is_empty (filter f s)). -Proof. -intros; apply bool_1; split; intros. -- destruct (exists_2 Comp H) as (a,(Ha1,Ha2)). - apply bool_6. - red; intros; apply (@is_empty_2 _ H0 a); auto with set. -- generalize (@choose_1 (filter f s)) (@choose_2 (filter f s)). - destruct (choose (filter f s)). - + intros H0 _; apply exists_1; auto. - exists e; generalize (H0 e); rewrite filter_iff; auto. - + intros _ H0. - rewrite (is_empty_1 (H0 Logic.eq_refl)) in H; auto; discriminate. -Qed. - -Lemma partition_filter_1: - forall s, equal (fst (partition f s)) (filter f s)=true. -Proof. -auto with set. -Qed. - -Lemma partition_filter_2: - forall s, equal (snd (partition f s)) (filter (fun x => negb (f x)) s)=true. -Proof. -auto with set. -Qed. - -Lemma filter_add_1 : forall s x, f x = true -> - filter f (add x s) [=] add x (filter f s). -Proof. -red; intros; set_iff; do 2 (rewrite filter_iff; auto); set_iff. -intuition. -rewrite <- H; apply Comp; auto. -Qed. - -Lemma filter_add_2 : forall s x, f x = false -> - filter f (add x s) [=] filter f s. -Proof. -red; intros; do 2 (rewrite filter_iff; auto); set_iff. -intuition. -assert (f x = f a) by (apply Comp; auto). -rewrite H in H1; rewrite H2 in H1; discriminate. -Qed. - -Lemma add_filter_1 : forall s s' x, - f x=true -> (Add x s s') -> (Add x (filter f s) (filter f s')). -Proof. -unfold Add, MP.Add; intros. -repeat rewrite filter_iff; auto. -rewrite H0; clear H0. -assert (E.eq x y -> f y = true) by - (intro H0; rewrite <- (Comp _ _ H0); auto). -tauto. -Qed. - -Lemma add_filter_2 : forall s s' x, - f x=false -> (Add x s s') -> filter f s [=] filter f s'. -Proof. -unfold Add, MP.Add, Equal; intros. -repeat rewrite filter_iff; auto. -rewrite H0; clear H0. -assert (f a = true -> ~E.eq x a). -- intros H0 H1. - rewrite (Comp _ _ H1) in H. - rewrite H in H0; discriminate. -- tauto. -Qed. - -Lemma union_filter: forall f g, (compat_bool E.eq f) -> (compat_bool E.eq g) -> - forall s, union (filter f s) (filter g s) [=] filter (fun x=>orb (f x) (g x)) s. -Proof. -clear Comp f. -intros. -assert (compat_bool E.eq (fun x => orb (f x) (g x))). -- unfold compat_bool, Proper, respectful; intros. - rewrite (H x y H1); rewrite (H0 x y H1); auto. -- unfold Equal; intros; set_iff; repeat rewrite filter_iff; auto. - assert (f a || g a = true <-> f a = true \/ g a = true). - + split; auto with bool. - intro H3; destruct (orb_prop _ _ H3); auto. - + tauto. -Qed. - -Lemma filter_union: forall s s', filter f (union s s') [=] union (filter f s) (filter f s'). -Proof. -unfold Equal; intros; set_iff; repeat rewrite filter_iff; auto; set_iff; tauto. -Qed. - -(** Properties of [for_all] *) - -Lemma for_all_mem_1: forall s, - (forall x, (mem x s)=true->(f x)=true) -> (for_all f s)=true. -Proof. -intros. -rewrite for_all_filter; auto. -rewrite is_empty_equal_empty. -apply equal_mem_1;intros. -rewrite filter_b; auto. -rewrite empty_mem. -generalize (H a); case (mem a s);intros;auto. -rewrite H0;auto. -Qed. - -Lemma for_all_mem_2: forall s, - (for_all f s)=true -> forall x,(mem x s)=true -> (f x)=true. -Proof. -intros. -rewrite for_all_filter in H; auto. -rewrite is_empty_equal_empty in H. -generalize (equal_mem_2 _ _ H x). -rewrite filter_b; auto. -rewrite empty_mem. -rewrite H0; simpl;intros. -rewrite <- negb_false_iff; auto. -Qed. - -Lemma for_all_mem_3: - forall s x,(mem x s)=true -> (f x)=false -> (for_all f s)=false. -Proof. -intros. -apply (bool_eq_ind (for_all f s));intros;auto. -rewrite for_all_filter in H1; auto. -rewrite is_empty_equal_empty in H1. -generalize (equal_mem_2 _ _ H1 x). -rewrite filter_b; auto. -rewrite empty_mem. -rewrite H. -rewrite H0. -simpl;auto. -Qed. - -Lemma for_all_mem_4: - forall s, for_all f s=false -> {x:elt | mem x s=true /\ f x=false}. -Proof. -intros. -rewrite for_all_filter in H; auto. -destruct (choose_mem_3 _ H) as (x,(H0,H1));intros. -exists x. -rewrite filter_b in H1; auto. -elim (andb_prop _ _ H1). -split;auto. -rewrite <- negb_true_iff; auto. -Qed. - -(** Properties of [exists] *) - -Lemma for_all_exists: - forall s, exists_ f s = negb (for_all (fun x =>negb (f x)) s). -Proof. -intros. -rewrite for_all_b; auto. -rewrite exists_b; auto. -induction (elements s); simpl; auto. -destruct (f a); simpl; auto. -Qed. - -End Bool. -Section Bool'. - -Variable f:elt->bool. -Variable Comp: compat_bool E.eq f. - -Hint Resolve Comp' : core. - -Lemma exists_mem_1: - forall s, (forall x, mem x s=true->f x=false) -> exists_ f s=false. -Proof. -intros. -rewrite for_all_exists; auto. -rewrite for_all_mem_1;auto with bool. -intros;generalize (H x H0);intros. -rewrite negb_true_iff; auto. -Qed. - -Lemma exists_mem_2: - forall s, exists_ f s=false -> forall x, mem x s=true -> f x=false. -Proof. -intros. -rewrite for_all_exists in H; auto. -rewrite negb_false_iff in H. -rewrite <- negb_true_iff. -apply for_all_mem_2 with (2:=H); auto. -Qed. - -Lemma exists_mem_3: - forall s x, mem x s=true -> f x=true -> exists_ f s=true. -Proof. -intros. -rewrite for_all_exists; auto. -rewrite negb_true_iff. -apply for_all_mem_3 with x;auto. -rewrite negb_false_iff; auto. -Qed. - -Lemma exists_mem_4: - forall s, exists_ f s=true -> {x:elt | (mem x s)=true /\ (f x)=true}. -Proof. -intros. -rewrite for_all_exists in H; auto. -rewrite negb_true_iff in H. -destruct (for_all_mem_4 (fun x =>negb (f x)) (Comp' f Comp) s) as (x,p); auto. -elim p;intros. -exists x;split;auto. -rewrite <-negb_false_iff; auto. -Qed. - -End Bool'. - -Section Sum. - -(** Adding a valuation function on all elements of a set. *) - -Definition sum (f:elt -> nat)(s:t) := fold (fun x => plus (f x)) s 0. -Notation compat_opL := (compat_op E.eq Logic.eq). -Notation transposeL := (transpose Logic.eq). - -Lemma sum_plus : - forall f g, Proper (E.eq==>Logic.eq) f -> Proper (E.eq==>Logic.eq) g -> - forall s, sum (fun x =>f x+g x) s = sum f s + sum g s. -Proof. -unfold sum. -intros f g Hf Hg. -assert (fc : compat_opL (fun x:elt =>plus (f x))). { red; auto with fset. } -assert (ft : transposeL (fun x:elt =>plus (f x))). { red; intros x y z. - rewrite !PeanoNat.Nat.add_assoc, (PeanoNat.Nat.add_comm (f x) (f y)); reflexivity. } -assert (gc : compat_opL (fun x:elt => plus (g x))). { red; auto with fset. } -assert (gt : transposeL (fun x:elt =>plus (g x))). { red; intros x y z. - rewrite !PeanoNat.Nat.add_assoc, (PeanoNat.Nat.add_comm (g x) (g y)); reflexivity. } -assert (fgc : compat_opL (fun x:elt =>plus ((f x)+(g x)))). { repeat red; auto. } -assert (fgt : transposeL (fun x:elt=>plus ((f x)+(g x)))). { red; intros x y z. - set (u := (f x + g x)); set (v := (f y + g y)). - rewrite !PeanoNat.Nat.add_assoc, (PeanoNat.Nat.add_comm u). - reflexivity. -} -assert (st : Equivalence (@Logic.eq nat)) by (split; congruence). -intros s;pattern s; apply set_rec. -- intros. - rewrite <- (fold_equal _ _ st _ fc ft 0 _ _ H). - rewrite <- (fold_equal _ _ st _ gc gt 0 _ _ H). - rewrite <- (fold_equal _ _ st _ fgc fgt 0 _ _ H); auto. -- intros; do 3 (rewrite (fold_add _ _ st);auto). - rewrite H0;simpl. - rewrite <- !(PeanoNat.Nat.add_assoc (f x)); f_equal. - rewrite !PeanoNat.Nat.add_assoc. f_equal. - apply PeanoNat.Nat.add_comm. -- do 3 rewrite fold_empty;auto. -Qed. - -Lemma sum_filter : forall f, (compat_bool E.eq f) -> - forall s, (sum (fun x => if f x then 1 else 0) s) = (cardinal (filter f s)). -Proof. -unfold sum; intros f Hf. -assert (st : Equivalence (@Logic.eq nat)) by (split; congruence). -assert (cc : compat_opL (fun x => plus (if f x then 1 else 0))). { - repeat red; intros. - rewrite (Hf _ _ H); auto. -} -assert (ct : transposeL (fun x => plus (if f x then 1 else 0))). { - red; intros. - set (a := if f x then _ else _). - rewrite PeanoNat.Nat.add_comm. - rewrite <- !PeanoNat.Nat.add_assoc. f_equal. - apply PeanoNat.Nat.add_comm. -} -intros s;pattern s; apply set_rec. -- intros. - change elt with E.t. - rewrite <- (fold_equal _ _ st _ cc ct 0 _ _ H). - rewrite <- (MP.Equal_cardinal (filter_equal Hf (equal_2 H))); auto. -- intros; rewrite (fold_add _ _ st _ cc ct); auto. - generalize (@add_filter_1 f Hf s0 (add x s0) x) (@add_filter_2 f Hf s0 (add x s0) x) . - assert (~ In x (filter f s0)). - + intro H1; rewrite (mem_1 (filter_1 Hf H1)) in H; discriminate H. - + case (f x); simpl; intros. - * rewrite (MP.cardinal_2 H1 (H2 Logic.eq_refl (MP.Add_add s0 x))); auto. - * rewrite <- (MP.Equal_cardinal (H3 Logic.eq_refl (MP.Add_add s0 x))); auto. -- intros; rewrite fold_empty;auto. - rewrite MP.cardinal_1; auto. - unfold Empty; intros. - rewrite filter_iff; auto; set_iff; tauto. -Qed. - -Lemma fold_compat : - forall (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA) - (f g:elt->A->A), - (compat_op E.eq eqA f) -> (transpose eqA f) -> - (compat_op E.eq eqA g) -> (transpose eqA g) -> - forall (i:A)(s:t),(forall x:elt, (In x s) -> forall y, (eqA (f x y) (g x y))) -> - (eqA (fold f s i) (fold g s i)). -Proof. -intros A eqA st f g fc ft gc gt i. -intro s; pattern s; apply set_rec; intros. -- transitivity (fold f s0 i). - + apply fold_equal with (eqA:=eqA); auto. - rewrite equal_sym; auto. - + transitivity (fold g s0 i). - * apply H0; intros; apply H1; auto with set. - elim (equal_2 H x); auto with set; intros. - * apply fold_equal with (eqA:=eqA); auto with set. -- 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 set. - * symmetry; apply fold_add with (eqA:=eqA); auto. -- do 2 rewrite fold_empty; reflexivity. -Qed. - -Lemma sum_compat : - forall f g, Proper (E.eq==>Logic.eq) f -> Proper (E.eq==>Logic.eq) g -> - forall s, (forall x, In x s -> f x=g x) -> sum f s=sum g s. -intros. -unfold sum; apply (fold_compat _ (@Logic.eq nat)); auto with fset. -- intros x x' Hx y y' Hy. rewrite Hx, Hy; auto. -- intros x y z; rewrite !PeanoNat.Nat.add_assoc; f_equal; apply PeanoNat.Nat.add_comm. -- intros x x' Hx y y' Hy. rewrite Hx, Hy; auto. -- intros x y z; rewrite !PeanoNat.Nat.add_assoc; f_equal; apply PeanoNat.Nat.add_comm. -Qed. - -End Sum. - -End WEqProperties_fun. - -(** Now comes variants for self-contained weak sets and for full sets. - For these variants, only one argument is necessary. Thanks to - the subtyping [WS<=S], the [EqProperties] functor which is meant to be - used on modules [(M:S)] can simply be an alias of [WEqProperties]. *) - -Module WEqProperties (M:WS) := WEqProperties_fun M.E M. -Module EqProperties := WEqProperties. diff --git a/stdlib/theories/FSets/FSetFacts.v b/stdlib/theories/FSets/FSetFacts.v deleted file mode 100644 index 50a77d2947a7..000000000000 --- a/stdlib/theories/FSets/FSetFacts.v +++ /dev/null @@ -1,509 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* (In x s <-> In y s). -Proof. -split; apply In_1; auto. -Qed. - -Lemma mem_iff : In x s <-> mem x s = true. -Proof. -split; [apply mem_1|apply mem_2]. -Qed. - -Lemma not_mem_iff : ~In x s <-> mem x s = false. -Proof. -rewrite mem_iff; destruct (mem x s); intuition auto with bool. -Qed. - -Lemma equal_iff : s[=]s' <-> equal s s' = true. -Proof. -split; [apply equal_1|apply equal_2]. -Qed. - -Lemma subset_iff : s[<=]s' <-> subset s s' = true. -Proof. -split; [apply subset_1|apply subset_2]. -Qed. - -Lemma empty_iff : In x empty <-> False. -Proof. -intuition; apply (empty_1 H). -Qed. - -Lemma is_empty_iff : Empty s <-> is_empty s = true. -Proof. -split; [apply is_empty_1|apply is_empty_2]. -Qed. - -Lemma singleton_iff : In y (singleton x) <-> E.eq x y. -Proof. -split; [apply singleton_1|apply singleton_2]. -Qed. - -Lemma add_iff : In y (add x s) <-> E.eq x y \/ In y s. -Proof. -split; [ | destruct 1; [apply add_1|apply add_2]]; auto. -destruct (eq_dec x y) as [E|E]; auto. -intro H; right; exact (add_3 E H). -Qed. - -Lemma add_neq_iff : ~ E.eq x y -> (In y (add x s) <-> In y s). -Proof. -split; [apply add_3|apply add_2]; auto. -Qed. - -Lemma remove_iff : In y (remove x s) <-> In y s /\ ~E.eq x y. -Proof. -split; [split; [apply remove_3 with x |] | destruct 1; apply remove_2]; auto. -intro. -apply (remove_1 H0 H). -Qed. - -Lemma remove_neq_iff : ~ E.eq x y -> (In y (remove x s) <-> In y s). -Proof. -split; [apply remove_3|apply remove_2]; auto. -Qed. - -Lemma union_iff : In x (union s s') <-> In x s \/ In x s'. -Proof. -split; [apply union_1 | destruct 1; [apply union_2|apply union_3]]; auto. -Qed. - -Lemma inter_iff : In x (inter s s') <-> In x s /\ In x s'. -Proof. -split; [split; [apply inter_1 with s' | apply inter_2 with s] | destruct 1; apply inter_3]; auto. -Qed. - -Lemma diff_iff : In x (diff s s') <-> In x s /\ ~ In x s'. -Proof. -split; [split; [apply diff_1 with s' | apply diff_2 with s] | destruct 1; apply diff_3]; auto. -Qed. - -Variable f : elt->bool. - -Lemma filter_iff : compat_bool E.eq f -> (In x (filter f s) <-> In x s /\ f x = true). -Proof. -split; [split; [apply filter_1 with f | apply filter_2 with s] | destruct 1; apply filter_3]; auto. -Qed. - -Lemma for_all_iff : compat_bool E.eq f -> - (For_all (fun x => f x = true) s <-> for_all f s = true). -Proof. -split; [apply for_all_1 | apply for_all_2]; auto. -Qed. - -Lemma exists_iff : compat_bool E.eq f -> - (Exists (fun x => f x = true) s <-> exists_ f s = true). -Proof. -split; [apply exists_1 | apply exists_2]; auto. -Qed. - -Lemma elements_iff : In x s <-> InA E.eq x (elements s). -Proof. -split; [apply elements_1 | apply elements_2]. -Qed. - -End IffSpec. - -(** Useful tactic for simplifying expressions like [In y (add x (union s s'))] *) - -Ltac set_iff := - repeat (progress ( - rewrite add_iff || rewrite remove_iff || rewrite singleton_iff - || rewrite union_iff || rewrite inter_iff || rewrite diff_iff - || rewrite empty_iff)). - -(** * Specifications written using boolean predicates *) - -Section BoolSpec. -Variable s s' s'' : t. -Variable x y z : elt. - -Lemma mem_b : E.eq x y -> mem x s = mem y s. -Proof. -intros. -generalize (mem_iff s x) (mem_iff s y)(In_eq_iff s H). -destruct (mem x s); destruct (mem y s); intuition. -Qed. - -Lemma empty_b : mem y empty = false. -Proof. -generalize (empty_iff y)(mem_iff empty y). -destruct (mem y empty); intuition. -Qed. - -Lemma add_b : mem y (add x s) = eqb x y || mem y s. -Proof. -generalize (mem_iff (add x s) y)(mem_iff s y)(add_iff s x y); unfold eqb. -destruct (eq_dec x y); destruct (mem y s); destruct (mem y (add x s)); intuition. -Qed. - -Lemma add_neq_b : ~ E.eq x y -> mem y (add x s) = mem y s. -Proof. -intros; generalize (mem_iff (add x s) y)(mem_iff s y)(add_neq_iff s H). -destruct (mem y s); destruct (mem y (add x s)); intuition. -Qed. - -Lemma remove_b : mem y (remove x s) = mem y s && negb (eqb x y). -Proof. -generalize (mem_iff (remove x s) y)(mem_iff s y)(remove_iff s x y); unfold eqb. -destruct (eq_dec x y); destruct (mem y s); destruct (mem y (remove x s)); simpl; intuition. -Qed. - -Lemma remove_neq_b : ~ E.eq x y -> mem y (remove x s) = mem y s. -Proof. -intros; generalize (mem_iff (remove x s) y)(mem_iff s y)(remove_neq_iff s H). -destruct (mem y s); destruct (mem y (remove x s)); intuition. -Qed. - -Lemma singleton_b : mem y (singleton x) = eqb x y. -Proof. -generalize (mem_iff (singleton x) y)(singleton_iff x y); unfold eqb. -destruct (eq_dec x y); destruct (mem y (singleton x)); intuition. -Qed. - -Lemma union_b : mem x (union s s') = mem x s || mem x s'. -Proof. -generalize (mem_iff (union s s') x)(mem_iff s x)(mem_iff s' x)(union_iff s s' x). -destruct (mem x s); destruct (mem x s'); destruct (mem x (union s s')); intuition. -Qed. - -Lemma inter_b : mem x (inter s s') = mem x s && mem x s'. -Proof. -generalize (mem_iff (inter s s') x)(mem_iff s x)(mem_iff s' x)(inter_iff s s' x). -destruct (mem x s); destruct (mem x s'); destruct (mem x (inter s s')); intuition. -Qed. - -Lemma diff_b : mem x (diff s s') = mem x s && negb (mem x s'). -Proof. -generalize (mem_iff (diff s s') x)(mem_iff s x)(mem_iff s' x)(diff_iff s s' x). -destruct (mem x s); destruct (mem x s'); destruct (mem x (diff s s')); simpl; intuition. -Qed. - -Lemma elements_b : mem x s = existsb (eqb x) (elements s). -Proof. -generalize (mem_iff s x)(elements_iff s x)(existsb_exists (eqb x) (elements s)). -rewrite InA_alt. -destruct (mem x s); destruct (existsb (eqb x) (elements s)); auto; intros. -- symmetry. - rewrite H1. - destruct H0 as (H0,_). - destruct H0 as (a,(Ha1,Ha2)); [ intuition |]. - exists a; intuition. - unfold eqb; destruct (eq_dec x a); auto. -- rewrite <- H. - rewrite H0. - destruct H1 as (H1,_). - destruct H1 as (a,(Ha1,Ha2)); [intuition|]. - exists a; intuition. - unfold eqb in *; destruct (eq_dec x a); auto; discriminate. -Qed. - -Variable f : elt->bool. - -Lemma filter_b : compat_bool E.eq f -> mem x (filter f s) = mem x s && f x. -Proof. -intros. -generalize (mem_iff (filter f s) x)(mem_iff s x)(filter_iff s x H). -destruct (mem x s); destruct (mem x (filter f s)); destruct (f x); simpl; intuition. -Qed. - -Lemma for_all_b : compat_bool E.eq f -> - for_all f s = forallb f (elements s). -Proof. -intros. -generalize (forallb_forall f (elements s))(for_all_iff s H)(elements_iff s). -unfold For_all. -destruct (forallb f (elements s)); destruct (for_all f s); auto; intros. -- rewrite <- H1; intros. - destruct H0 as (H0,_). - rewrite (H2 x0) in H3. - rewrite (InA_alt E.eq x0 (elements s)) in H3. - destruct H3 as (a,(Ha1,Ha2)). - rewrite (H _ _ Ha1). - apply H0; auto. -- symmetry. - rewrite H0; intros. - destruct H1 as (_,H1). - apply H1; auto. - rewrite H2. - rewrite InA_alt; eauto. -Qed. - -Lemma exists_b : compat_bool E.eq f -> - exists_ f s = existsb f (elements s). -Proof. -intros. -generalize (existsb_exists f (elements s))(exists_iff s H)(elements_iff s). -unfold Exists. -destruct (existsb f (elements s)); destruct (exists_ f s); auto; intros. -- rewrite <- H1; intros. - destruct H0 as (H0,_). - destruct H0 as (a,(Ha1,Ha2)); auto. - exists a; split; auto. - rewrite H2; rewrite InA_alt; eauto. -- symmetry. - rewrite H0. - destruct H1 as (_,H1). - destruct H1 as (a,(Ha1,Ha2)); auto. - rewrite (H2 a) in Ha1. - rewrite (InA_alt E.eq a (elements s)) in Ha1. - destruct Ha1 as (b,(Hb1,Hb2)). - exists b; auto. - rewrite <- (H _ _ Hb1); auto. -Qed. - -End BoolSpec. - -(** * [E.eq] and [Equal] are setoid equalities *) - -#[global] -Instance E_ST : Equivalence E.eq. -Proof. -constructor ; red; [apply E.eq_refl|apply E.eq_sym|apply E.eq_trans]. -Qed. - -#[global] -Instance Equal_ST : Equivalence Equal. -Proof. -constructor ; red; [apply eq_refl | apply eq_sym | apply eq_trans]. -Qed. - -#[global] -Instance In_m : Proper (E.eq ==> Equal ==> iff) In. -Proof. -unfold Equal; intros x y H s s' H0. -rewrite (In_eq_iff s H); auto. -Qed. - -#[global] -Instance is_empty_m : Proper (Equal==> Logic.eq) is_empty. -Proof. -unfold Equal; intros s s' H. -generalize (is_empty_iff s)(is_empty_iff s'). -destruct (is_empty s); destruct (is_empty s'); - unfold Empty; auto; intros. -- symmetry. - rewrite <- H1; intros a Ha. - rewrite <- (H a) in Ha. - destruct H0 as (_,H0). - exact (H0 Logic.eq_refl _ Ha). -- rewrite <- H0; intros a Ha. - rewrite (H a) in Ha. - destruct H1 as (_,H1). - exact (H1 Logic.eq_refl _ Ha). -Qed. - -#[global] -Instance Empty_m : Proper (Equal ==> iff) Empty. -Proof. -repeat red; intros; do 2 rewrite is_empty_iff; rewrite H; intuition. -Qed. - -#[global] -Instance mem_m : Proper (E.eq ==> Equal ==> Logic.eq) mem. -Proof. -unfold Equal; intros x y H s s' H0. -generalize (H0 x); clear H0; rewrite (In_eq_iff s' H). -generalize (mem_iff s x)(mem_iff s' y). -destruct (mem x s); destruct (mem y s'); intuition. -Qed. - -#[global] -Instance singleton_m : Proper (E.eq ==> Equal) singleton. -Proof. -unfold Equal; intros x y H a. -do 2 rewrite singleton_iff; split; intros. -- apply E.eq_trans with x; auto. -- apply E.eq_trans with y; auto. -Qed. - -#[global] -Instance add_m : Proper (E.eq==>Equal==>Equal) add. -Proof. -unfold Equal; intros x y H s s' H0 a. -do 2 rewrite add_iff; rewrite H; rewrite H0; intuition. -Qed. - -#[global] -Instance remove_m : Proper (E.eq==>Equal==>Equal) remove. -Proof. -unfold Equal; intros x y H s s' H0 a. -do 2 rewrite remove_iff; rewrite H; rewrite H0; intuition. -Qed. - -#[global] -Instance union_m : Proper (Equal==>Equal==>Equal) union. -Proof. -unfold Equal; intros s s' H s'' s''' H0 a. -do 2 rewrite union_iff; rewrite H; rewrite H0; intuition. -Qed. - -#[global] -Instance inter_m : Proper (Equal==>Equal==>Equal) inter. -Proof. -unfold Equal; intros s s' H s'' s''' H0 a. -do 2 rewrite inter_iff; rewrite H; rewrite H0; intuition. -Qed. - -#[global] -Instance diff_m : Proper (Equal==>Equal==>Equal) diff. -Proof. -unfold Equal; intros s s' H s'' s''' H0 a. -do 2 rewrite diff_iff; rewrite H; rewrite H0; intuition. -Qed. - -#[global] -Instance Subset_m : Proper (Equal==>Equal==>iff) Subset. -Proof. -unfold Equal, Subset; firstorder. -Qed. - -#[global] -Instance subset_m : Proper (Equal ==> Equal ==> Logic.eq) subset. -Proof. -intros s s' H s'' s''' H0. -generalize (subset_iff s s'') (subset_iff s' s'''). -destruct (subset s s''); destruct (subset s' s'''); auto; intros. -- rewrite H in H1; rewrite H0 in H1; intuition. -- rewrite H in H1; rewrite H0 in H1; intuition. -Qed. - -#[global] -Instance equal_m : Proper (Equal ==> Equal ==> Logic.eq) equal. -Proof. -intros s s' H s'' s''' H0. -generalize (equal_iff s s'') (equal_iff s' s'''). -destruct (equal s s''); destruct (equal s' s'''); auto; intros. -- rewrite H in H1; rewrite H0 in H1; intuition. -- rewrite H in H1; rewrite H0 in H1; intuition. -Qed. - - -(* [Subset] is a setoid order *) - -Lemma Subset_refl : forall s, s[<=]s. -Proof. red; auto. Qed. - -Lemma Subset_trans : forall s s' s'', s[<=]s'->s'[<=]s''->s[<=]s''. -Proof. unfold Subset; eauto. Qed. - -Add Relation t Subset - reflexivity proved by Subset_refl - transitivity proved by Subset_trans - as SubsetSetoid. - -#[global] -Instance In_s_m : Morphisms.Proper (E.eq ==> Subset ++> Basics.impl) In | 1. -Proof. - simpl_relation. eauto with set. -Qed. - -Add Morphism Empty with signature Subset --> Basics.impl as Empty_s_m. -Proof. -unfold Subset, Empty, Basics.impl; firstorder. -Qed. - -Add Morphism add with signature E.eq ==> Subset ++> Subset as add_s_m. -Proof. -unfold Subset; intros x y H s s' H0 a. -do 2 rewrite add_iff; rewrite H; intuition. -Qed. - -Add Morphism remove with signature E.eq ==> Subset ++> Subset as remove_s_m. -Proof. -unfold Subset; intros x y H s s' H0 a. -do 2 rewrite remove_iff; rewrite H; intuition. -Qed. - -Add Morphism union with signature Subset ++> Subset ++> Subset as union_s_m. -Proof. -unfold Equal; intros s s' H s'' s''' H0 a. -do 2 rewrite union_iff; intuition. -Qed. - -Add Morphism inter with signature Subset ++> Subset ++> Subset as inter_s_m. -Proof. -unfold Equal; intros s s' H s'' s''' H0 a. -do 2 rewrite inter_iff; intuition. -Qed. - -Add Morphism diff with signature Subset ++> Subset --> Subset as diff_s_m. -Proof. -unfold Subset; intros s s' H s'' s''' H0 a. -do 2 rewrite diff_iff; intuition. -Qed. - -(* [fold], [filter], [for_all], [exists_] and [partition] cannot be proved morphism - without additional hypothesis on [f]. For instance: *) - -Lemma filter_equal : forall f, compat_bool E.eq f -> - forall s s', s[=]s' -> filter f s [=] filter f s'. -Proof. -unfold Equal; intros; repeat rewrite filter_iff; auto; rewrite H0; tauto. -Qed. - -Lemma filter_ext : forall f f', compat_bool E.eq f -> (forall x, f x = f' x) -> - forall s s', s[=]s' -> filter f s [=] filter f' s'. -Proof. -intros f f' Hf Hff' s s' Hss' x. do 2 (rewrite filter_iff; auto). -- rewrite Hff', Hss'; intuition. -- repeat red; intros; rewrite <- 2 Hff'; auto. -Qed. - -Lemma filter_subset : forall f, compat_bool E.eq f -> - forall s s', s[<=]s' -> filter f s [<=] filter f s'. -Proof. -unfold Subset; intros; rewrite filter_iff in *; intuition. -Qed. - -(* For [elements], [min_elt], [max_elt] and [choose], we would need setoid - structures on [list elt] and [option elt]. *) - -(* Later: -Add Morphism cardinal ; cardinal_m. -*) - -End WFacts_fun. - -(** Now comes variants for self-contained weak sets and for full sets. - For these variants, only one argument is necessary. Thanks to - the subtyping [WS<=S], the [Facts] functor which is meant to be - used on modules [(M:S)] can simply be an alias of [WFacts]. *) - -Module WFacts (M:WS) := WFacts_fun M.E M. -Module Facts := WFacts. diff --git a/stdlib/theories/FSets/FSetInterface.v b/stdlib/theories/FSets/FSetInterface.v deleted file mode 100644 index 8ed127d0717f..000000000000 --- a/stdlib/theories/FSets/FSetInterface.v +++ /dev/null @@ -1,512 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* t -> Prop. - Definition Equal s s' := forall a : elt, In a s <-> In a s'. - Definition Subset s s' := forall a : elt, In a s -> In a s'. - Definition Empty s := forall a : elt, ~ In a s. - Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x. - Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x. - - Notation "s [=] t" := (Equal s t) (at level 70, no associativity). - Notation "s [<=] t" := (Subset s t) (at level 70, no associativity). - - Parameter empty : t. - (** The empty set. *) - - Parameter is_empty : t -> bool. - (** Test whether a set is empty or not. *) - - Parameter mem : elt -> t -> bool. - (** [mem x s] tests whether [x] belongs to the set [s]. *) - - Parameter add : elt -> t -> t. - (** [add x s] returns a set containing all elements of [s], - plus [x]. If [x] was already in [s], [s] is returned unchanged. *) - - Parameter singleton : elt -> t. - (** [singleton x] returns the one-element set containing only [x]. *) - - Parameter remove : elt -> t -> t. - (** [remove x s] returns a set containing all elements of [s], - except [x]. If [x] was not in [s], [s] is returned unchanged. *) - - Parameter union : t -> t -> t. - (** Set union. *) - - Parameter inter : t -> t -> t. - (** Set intersection. *) - - Parameter diff : t -> t -> t. - (** Set difference. *) - - Definition eq : t -> t -> Prop := Equal. - - Parameter eq_dec : forall s s', { eq s s' } + { ~ eq s s' }. - - Parameter equal : t -> t -> bool. - (** [equal s1 s2] tests whether the sets [s1] and [s2] are - equal, that is, contain equal elements. *) - - Parameter subset : t -> t -> bool. - (** [subset s1 s2] tests whether the set [s1] is a subset of - the set [s2]. *) - - Parameter fold : forall A : Type, (elt -> A -> A) -> t -> A -> A. - (** [fold f s a] computes [(f xN ... (f x2 (f x1 a))...)], - where [x1 ... xN] are the elements of [s]. - The order in which elements of [s] are presented to [f] is - unspecified. *) - - Parameter for_all : (elt -> bool) -> t -> bool. - (** [for_all p s] checks if all elements of the set - satisfy the predicate [p]. *) - - Parameter exists_ : (elt -> bool) -> t -> bool. - (** [exists p s] checks if at least one element of - the set satisfies the predicate [p]. *) - - Parameter filter : (elt -> bool) -> t -> t. - (** [filter p s] returns the set of all elements in [s] - that satisfy predicate [p]. *) - - Parameter partition : (elt -> bool) -> t -> t * t. - (** [partition p s] returns a pair of sets [(s1, s2)], where - [s1] is the set of all the elements of [s] that satisfy the - predicate [p], and [s2] is the set of all the elements of - [s] that do not satisfy [p]. *) - - Parameter cardinal : t -> nat. - (** Return the number of elements of a set. *) - - Parameter elements : t -> list elt. - (** Return the list of all elements of the given set, in any order. *) - - Parameter choose : t -> option elt. - (** Return one element of the given set, or [None] if - the set is empty. Which element is chosen is unspecified. - Equal sets could return different elements. *) - - Section Spec. - - Variable s s' s'': t. - Variable x y : elt. - - (** Specification of [In] *) - Parameter In_1 : E.eq x y -> In x s -> In y s. - - (** Specification of [eq] *) - Parameter eq_refl : eq s s. - Parameter eq_sym : eq s s' -> eq s' s. - Parameter eq_trans : eq s s' -> eq s' s'' -> eq s s''. - - (** Specification of [mem] *) - Parameter mem_1 : In x s -> mem x s = true. - Parameter mem_2 : mem x s = true -> In x s. - - (** Specification of [equal] *) - Parameter equal_1 : Equal s s' -> equal s s' = true. - Parameter equal_2 : equal s s' = true -> Equal s s'. - - (** Specification of [subset] *) - Parameter subset_1 : Subset s s' -> subset s s' = true. - Parameter subset_2 : subset s s' = true -> Subset s s'. - - (** Specification of [empty] *) - Parameter empty_1 : Empty empty. - - (** Specification of [is_empty] *) - Parameter is_empty_1 : Empty s -> is_empty s = true. - Parameter is_empty_2 : is_empty s = true -> Empty s. - - (** Specification of [add] *) - Parameter add_1 : E.eq x y -> In y (add x s). - Parameter add_2 : In y s -> In y (add x s). - Parameter add_3 : ~ E.eq x y -> In y (add x s) -> In y s. - - (** Specification of [remove] *) - Parameter remove_1 : E.eq x y -> ~ In y (remove x s). - Parameter remove_2 : ~ E.eq x y -> In y s -> In y (remove x s). - Parameter remove_3 : In y (remove x s) -> In y s. - - (** Specification of [singleton] *) - Parameter singleton_1 : In y (singleton x) -> E.eq x y. - Parameter singleton_2 : E.eq x y -> In y (singleton x). - - (** Specification of [union] *) - Parameter union_1 : In x (union s s') -> In x s \/ In x s'. - Parameter union_2 : In x s -> In x (union s s'). - Parameter union_3 : In x s' -> In x (union s s'). - - (** Specification of [inter] *) - Parameter inter_1 : In x (inter s s') -> In x s. - Parameter inter_2 : In x (inter s s') -> In x s'. - Parameter inter_3 : In x s -> In x s' -> In x (inter s s'). - - (** Specification of [diff] *) - Parameter diff_1 : In x (diff s s') -> In x s. - Parameter diff_2 : In x (diff s s') -> ~ In x s'. - Parameter diff_3 : In x s -> ~ In x s' -> In x (diff s s'). - - (** Specification of [fold] *) - Parameter fold_1 : forall (A : Type) (i : A) (f : elt -> A -> A), - fold f s i = fold_left (fun a e => f e a) (elements s) i. - - (** Specification of [cardinal] *) - Parameter cardinal_1 : cardinal s = length (elements s). - - Section Filter. - - Variable f : elt -> bool. - - (** Specification of [filter] *) - Parameter filter_1 : compat_bool E.eq f -> In x (filter f s) -> In x s. - Parameter filter_2 : compat_bool E.eq f -> In x (filter f s) -> f x = true. - Parameter filter_3 : - compat_bool E.eq f -> In x s -> f x = true -> In x (filter f s). - - (** Specification of [for_all] *) - Parameter for_all_1 : - compat_bool E.eq f -> - For_all (fun x => f x = true) s -> for_all f s = true. - Parameter for_all_2 : - compat_bool E.eq f -> - for_all f s = true -> For_all (fun x => f x = true) s. - - (** Specification of [exists] *) - Parameter exists_1 : - compat_bool E.eq f -> - Exists (fun x => f x = true) s -> exists_ f s = true. - Parameter exists_2 : - compat_bool E.eq f -> - exists_ f s = true -> Exists (fun x => f x = true) s. - - (** Specification of [partition] *) - Parameter partition_1 : - compat_bool E.eq f -> Equal (fst (partition f s)) (filter f s). - Parameter partition_2 : - compat_bool E.eq f -> - Equal (snd (partition f s)) (filter (fun x => negb (f x)) s). - - End Filter. - - (** Specification of [elements] *) - Parameter elements_1 : In x s -> InA E.eq x (elements s). - Parameter elements_2 : InA E.eq x (elements s) -> In x s. - (** When compared with ordered sets, here comes the only - property that is really weaker: *) - Parameter elements_3w : NoDupA E.eq (elements s). - - (** Specification of [choose] *) - Parameter choose_1 : choose s = Some x -> In x s. - Parameter choose_2 : choose s = None -> Empty s. - - End Spec. - - #[global] - Hint Transparent elt : core. - #[global] - Hint Resolve mem_1 equal_1 subset_1 empty_1 - is_empty_1 choose_1 choose_2 add_1 add_2 remove_1 - remove_2 singleton_2 union_1 union_2 union_3 - inter_3 diff_3 fold_1 filter_3 for_all_1 exists_1 - partition_1 partition_2 elements_1 elements_3w - : set. - #[global] - Hint Immediate In_1 mem_2 equal_2 subset_2 is_empty_2 add_3 - remove_3 singleton_1 inter_1 inter_2 diff_1 diff_2 - filter_1 filter_2 for_all_2 exists_2 elements_2 - : set. - -End WSfun. - - - -(** ** Static signature for weak sets - - Similar to the functorial signature [SW], except that the - module [E] of base elements is incorporated in the signature. *) - -Module Type WS. - Declare Module E : DecidableType. - Include WSfun E. -End WS. - - - -(** ** Functorial signature for sets on ordered elements - - Based on [WSfun], plus ordering on sets and [min_elt] and [max_elt] - and some stronger specifications for other functions. *) - -Module Type Sfun (E : OrderedType). - Include WSfun E. - - Parameter lt : t -> t -> Prop. - Parameter compare : forall s s' : t, Compare lt eq s s'. - (** Total ordering between sets. Can be used as the ordering function - for doing sets of sets. *) - - Parameter min_elt : t -> option elt. - (** Return the smallest element of the given set - (with respect to the [E.compare] ordering), - or [None] if the set is empty. *) - - Parameter max_elt : t -> option elt. - (** Same as [min_elt], but returns the largest element of the - given set. *) - - Section Spec. - - Variable s s' s'' : t. - Variable x y : elt. - - (** Specification of [lt] *) - Parameter lt_trans : lt s s' -> lt s' s'' -> lt s s''. - Parameter lt_not_eq : lt s s' -> ~ eq s s'. - - (** Additional specification of [elements] *) - Parameter elements_3 : sort E.lt (elements s). - - (** Remark: since [fold] is specified via [elements], this stronger - specification of [elements] has an indirect impact on [fold], - which can now be proved to receive elements in increasing order. - *) - - (** Specification of [min_elt] *) - Parameter min_elt_1 : min_elt s = Some x -> In x s. - Parameter min_elt_2 : min_elt s = Some x -> In y s -> ~ E.lt y x. - Parameter min_elt_3 : min_elt s = None -> Empty s. - - (** Specification of [max_elt] *) - Parameter max_elt_1 : max_elt s = Some x -> In x s. - Parameter max_elt_2 : max_elt s = Some x -> In y s -> ~ E.lt x y. - Parameter max_elt_3 : max_elt s = None -> Empty s. - - (** Additional specification of [choose] *) - Parameter choose_3 : choose s = Some x -> choose s' = Some y -> - Equal s s' -> E.eq x y. - - End Spec. - - #[global] - Hint Resolve elements_3 : set. - #[global] - Hint Immediate - min_elt_1 min_elt_2 min_elt_3 max_elt_1 max_elt_2 max_elt_3 : set. - -End Sfun. - - -(** ** Static signature for sets on ordered elements - - Similar to the functorial signature [Sfun], except that the - module [E] of base elements is incorporated in the signature. *) - -Module Type S. - Declare Module E : OrderedType. - Include Sfun E. -End S. - - -(** ** Some subtyping tests -<< -WSfun ---> WS - | | - | | - V V -Sfun ---> S - -Module S_WS (M : S) <: WS := M. -Module Sfun_WSfun (E:OrderedType)(M : Sfun E) <: WSfun E := M. -Module S_Sfun (M : S) <: Sfun M.E := M. -Module WS_WSfun (M : WS) <: WSfun M.E := M. ->> -*) - -(** * Dependent signature - - Signature [Sdep] presents ordered sets using dependent types *) - -Module Type Sdep. - - Declare Module E : OrderedType. - Definition elt := E.t. - - Parameter t : Type. - - Parameter In : elt -> t -> Prop. - Definition Equal s s' := forall a : elt, In a s <-> In a s'. - Definition Subset s s' := forall a : elt, In a s -> In a s'. - Definition Add x s s' := forall y, In y s' <-> E.eq x y \/ In y s. - Definition Empty s := forall a : elt, ~ In a s. - Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x. - Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x. - - Notation "s [=] t" := (Equal s t) (at level 70, no associativity). - - Definition eq : t -> t -> Prop := Equal. - Parameter lt : t -> t -> Prop. - Parameter compare : forall s s' : t, Compare lt eq s s'. - - Parameter eq_refl : forall s : t, eq s s. - Parameter eq_sym : forall s s' : t, eq s s' -> eq s' s. - Parameter eq_trans : forall s s' s'' : t, eq s s' -> eq s' s'' -> eq s s''. - Parameter lt_trans : forall s s' s'' : t, lt s s' -> lt s' s'' -> lt s s''. - Parameter lt_not_eq : forall s s' : t, lt s s' -> ~ eq s s'. - - Parameter eq_In : forall (s : t) (x y : elt), E.eq x y -> In x s -> In y s. - - Parameter empty : {s : t | Empty s}. - - Parameter is_empty : forall s : t, {Empty s} + {~ Empty s}. - - Parameter mem : forall (x : elt) (s : t), {In x s} + {~ In x s}. - - Parameter add : forall (x : elt) (s : t), {s' : t | Add x s s'}. - - Parameter - singleton : forall x : elt, {s : t | forall y : elt, In y s <-> E.eq x y}. - - Parameter - remove : - forall (x : elt) (s : t), - {s' : t | forall y : elt, In y s' <-> ~ E.eq x y /\ In y s}. - - Parameter - union : - forall s s' : t, - {s'' : t | forall x : elt, In x s'' <-> In x s \/ In x s'}. - - Parameter - inter : - forall s s' : t, - {s'' : t | forall x : elt, In x s'' <-> In x s /\ In x s'}. - - Parameter - diff : - forall s s' : t, - {s'' : t | forall x : elt, In x s'' <-> In x s /\ ~ In x s'}. - - Parameter equal : forall s s' : t, {s[=]s'} + {~ s[=]s'}. - - Parameter subset : forall s s' : t, {Subset s s'} + {~ Subset s s'}. - - Parameter - filter : - forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}) - (s : t), - {s' : t | compat_P E.eq P -> forall x : elt, In x s' <-> In x s /\ P x}. - - Parameter - for_all : - forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}) - (s : t), - {compat_P E.eq P -> For_all P s} + {compat_P E.eq P -> ~ For_all P s}. - - Parameter - exists_ : - forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}) - (s : t), - {compat_P E.eq P -> Exists P s} + {compat_P E.eq P -> ~ Exists P s}. - - Parameter - partition : - forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}) - (s : t), - {partition : t * t | - let (s1, s2) := partition in - compat_P E.eq P -> - For_all P s1 /\ - For_all (fun x => ~ P x) s2 /\ - (forall x : elt, In x s <-> In x s1 \/ In x s2)}. - - Parameter - elements : - forall s : t, - {l : list elt | - sort E.lt l /\ (forall x : elt, In x s <-> InA E.eq x l)}. - - Parameter - fold : - forall (A : Type) (f : elt -> A -> A) (s : t) (i : A), - {r : A | let (l,_) := elements s in - r = fold_left (fun a e => f e a) l i}. - - Parameter - cardinal : - forall s : t, - {r : nat | let (l,_) := elements s in r = length l }. - - Parameter - min_elt : - forall s : t, - {x : elt | In x s /\ For_all (fun y => ~ E.lt y x) s} + {Empty s}. - - Parameter - max_elt : - forall s : t, - {x : elt | In x s /\ For_all (fun y => ~ E.lt x y) s} + {Empty s}. - - Parameter choose : forall s : t, {x : elt | In x s} + {Empty s}. - - (** The [choose_3] specification of [S] cannot be packed - in the dependent version of [choose], so we leave it separate. *) - Parameter choose_equal : forall s s', Equal s s' -> - match choose s, choose s' with - | inleft (exist _ x _), inleft (exist _ x' _) => E.eq x x' - | inright _, inright _ => True - | _, _ => False - end. - -End Sdep. diff --git a/stdlib/theories/FSets/FSetList.v b/stdlib/theories/FSets/FSetList.v deleted file mode 100644 index d32a9c4995e2..000000000000 --- a/stdlib/theories/FSets/FSetList.v +++ /dev/null @@ -1,29 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* bool -> tree -> tree. - - Scheme tree_ind := Induction for tree Sort Prop. - - Definition t := tree : Type. - - Definition empty : t := Leaf. - - Fixpoint is_empty (m : t) : bool := - match m with - | Leaf => true - | Node l b r => negb b &&& is_empty l &&& is_empty r - end. - - Fixpoint mem (i : elt) (m : t) {struct m} : bool := - match m with - | Leaf => false - | Node l o r => - match i with - | 1 => o - | i~0 => mem i l - | i~1 => mem i r - end - end. - - Fixpoint add (i : elt) (m : t) : t := - match m with - | Leaf => - match i with - | 1 => Node Leaf true Leaf - | i~0 => Node (add i Leaf) false Leaf - | i~1 => Node Leaf false (add i Leaf) - end - | Node l o r => - match i with - | 1 => Node l true r - | i~0 => Node (add i l) o r - | i~1 => Node l o (add i r) - end - end. - - Definition singleton i := add i empty. - - (** helper function to avoid creating empty trees that are not leaves *) - - Definition node (l : t) (b: bool) (r : t) : t := - if b then Node l b r else - match l,r with - | Leaf,Leaf => Leaf - | _,_ => Node l false r end. - - Fixpoint remove (i : elt) (m : t) {struct m} : t := - match m with - | Leaf => Leaf - | Node l o r => - match i with - | 1 => node l false r - | i~0 => node (remove i l) o r - | i~1 => node l o (remove i r) - end - end. - - Fixpoint union (m m': t) : t := - match m with - | Leaf => m' - | Node l o r => - match m' with - | Leaf => m - | Node l' o' r' => Node (union l l') (o||o') (union r r') - end - end. - - Fixpoint inter (m m': t) : t := - match m with - | Leaf => Leaf - | Node l o r => - match m' with - | Leaf => Leaf - | Node l' o' r' => node (inter l l') (o&&o') (inter r r') - end - end. - - Fixpoint diff (m m': t) : t := - match m with - | Leaf => Leaf - | Node l o r => - match m' with - | Leaf => m - | Node l' o' r' => node (diff l l') (o&&negb o') (diff r r') - end - end. - - Fixpoint equal (m m': t): bool := - match m with - | Leaf => is_empty m' - | Node l o r => - match m' with - | Leaf => is_empty m - | Node l' o' r' => eqb o o' &&& equal l l' &&& equal r r' - end - end. - - Fixpoint subset (m m': t): bool := - match m with - | Leaf => true - | Node l o r => - match m' with - | Leaf => is_empty m - | Node l' o' r' => (negb o ||| o') &&& subset l l' &&& subset r r' - end - end. - - (** reverses [y] and concatenate it with [x] *) - - Fixpoint rev_append (y x : elt) : elt := - match y with - | 1 => x - | y~1 => rev_append y x~1 - | y~0 => rev_append y x~0 - end. - Infix "@" := rev_append (at level 60). - Definition rev x := x@1. - - Section Fold. - - Variable B : Type. - Variable f : elt -> B -> B. - - (** the additional argument, [i], records the current path, in - reverse order (this should be more efficient: we reverse this argument - only at present nodes only, rather than at each node of the tree). - we also use this convention in all functions below - *) - - Fixpoint xfold (m : t) (v : B) (i : elt) := - match m with - | Leaf => v - | Node l true r => - xfold r (f (rev i) (xfold l v i~0)) i~1 - | Node l false r => - xfold r (xfold l v i~0) i~1 - end. - Definition fold m i := xfold m i 1. - - End Fold. - - Section Quantifiers. - - Variable f : elt -> bool. - - Fixpoint xforall (m : t) (i : elt) := - match m with - | Leaf => true - | Node l o r => - (negb o ||| f (rev i)) &&& xforall r i~1 &&& xforall l i~0 - end. - Definition for_all m := xforall m 1. - - Fixpoint xexists (m : t) (i : elt) := - match m with - | Leaf => false - | Node l o r => (o &&& f (rev i)) ||| xexists r i~1 ||| xexists l i~0 - end. - Definition exists_ m := xexists m 1. - - Fixpoint xfilter (m : t) (i : elt) : t := - match m with - | Leaf => Leaf - | Node l o r => node (xfilter l i~0) (o &&& f (rev i)) (xfilter r i~1) - end. - Definition filter m := xfilter m 1. - - Fixpoint xpartition (m : t) (i : elt) : t * t := - match m with - | Leaf => (Leaf,Leaf) - | Node l o r => - let (lt,lf) := xpartition l i~0 in - let (rt,rf) := xpartition r i~1 in - if o then - let fi := f (rev i) in - (node lt fi rt, node lf (negb fi) rf) - else - (node lt false rt, node lf false rf) - end. - Definition partition m := xpartition m 1. - - End Quantifiers. - - (** uses [a] to accumulate values rather than doing a lot of concatenations *) - - Fixpoint xelements (m : t) (i : elt) (a: list elt) := - match m with - | Leaf => a - | Node l false r => xelements l i~0 (xelements r i~1 a) - | Node l true r => xelements l i~0 (rev i :: xelements r i~1 a) - end. - - Definition elements (m : t) := xelements m 1 nil. - - Fixpoint cardinal (m : t) : nat := - match m with - | Leaf => O - | Node l false r => (cardinal l + cardinal r)%nat - | Node l true r => S (cardinal l + cardinal r) - end. - - Definition omap (f: elt -> elt) x := - match x with - | None => None - | Some i => Some (f i) - end. - - (** would it be more efficient to use a path like in the above functions ? *) - - Fixpoint choose (m: t) : option elt := - match m with - | Leaf => None - | Node l o r => if o then Some 1 else - match choose l with - | None => omap xI (choose r) - | Some i => Some i~0 - end - end. - - Fixpoint min_elt (m: t) : option elt := - match m with - | Leaf => None - | Node l o r => - match min_elt l with - | None => if o then Some 1 else omap xI (min_elt r) - | Some i => Some i~0 - end - end. - - Fixpoint max_elt (m: t) : option elt := - match m with - | Leaf => None - | Node l o r => - match max_elt r with - | None => if o then Some 1 else omap xO (max_elt l) - | Some i => Some i~1 - end - end. - - (** lexicographic product, defined using a notation to keep things lazy *) - - Notation lex u v := match u with Eq => v | Lt => Lt | Gt => Gt end. - - Definition compare_bool a b := - match a,b with - | false, true => Lt - | true, false => Gt - | _,_ => Eq - end. - - Fixpoint compare_fun (m m': t): comparison := - match m,m' with - | Leaf,_ => if is_empty m' then Eq else Lt - | _,Leaf => if is_empty m then Eq else Gt - | Node l o r,Node l' o' r' => - lex (compare_bool o o') (lex (compare_fun l l') (compare_fun r r')) - end. - - - Definition In i t := mem i t = true. - Definition Equal s s' := forall a : elt, In a s <-> In a s'. - Definition Subset s s' := forall a : elt, In a s -> In a s'. - Definition Empty s := forall a : elt, ~ In a s. - Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x. - Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x. - - Notation "s [=] t" := (Equal s t) (at level 70, no associativity). - Notation "s [<=] t" := (Subset s t) (at level 70, no associativity). - - Definition eq := Equal. - - Declare Equivalent Keys Equal eq. - - Definition lt m m' := compare_fun m m' = Lt. - - (** Specification of [In] *) - - Lemma In_1: forall s x y, E.eq x y -> In x s -> In y s. - Proof. intros s x y ->. trivial. Qed. - - (** Specification of [eq] *) - - Lemma eq_refl: forall s, eq s s. - Proof. unfold eq, Equal. reflexivity. Qed. - - Lemma eq_sym: forall s s', eq s s' -> eq s' s. - Proof. unfold eq, Equal. intros. symmetry. trivial. Qed. - - Lemma eq_trans: forall s s' s'', eq s s' -> eq s' s'' -> eq s s''. - Proof. unfold eq, Equal. intros ? ? ? H ? ?. rewrite H. trivial. Qed. - - (** Specification of [mem] *) - - Lemma mem_1: forall s x, In x s -> mem x s = true. - Proof. unfold In. trivial. Qed. - - Lemma mem_2: forall s x, mem x s = true -> In x s. - Proof. unfold In. trivial. Qed. - - (** Additional lemmas for mem *) - - Lemma mem_Leaf: forall x, mem x Leaf = false. - Proof. destruct x; trivial. Qed. - - (** Specification of [empty] *) - - Lemma empty_1 : Empty empty. - Proof. unfold Empty, In. intro. rewrite mem_Leaf. discriminate. Qed. - - (** Specification of node *) - - Lemma mem_node: forall x l o r, mem x (node l o r) = mem x (Node l o r). - Proof. - intros x l o r. - case o; trivial. - destruct l; trivial. - destruct r; trivial. - now destruct x. - Qed. - Local Opaque node. - - (** Specification of [is_empty] *) - - Lemma is_empty_spec: forall s, Empty s <-> is_empty s = true. - Proof. - unfold Empty, In. - induction s as [|l IHl o r IHr]; simpl. - - now split. - - rewrite <- 2andb_lazy_alt, 2andb_true_iff, <- IHl, <- IHr. clear IHl IHr. - destruct o; simpl; split. - + intro H. elim (H 1). reflexivity. - + intuition discriminate. - + intro H. split. - * split. - -- reflexivity. - -- intro a. apply (H a~0). - * intro a. apply (H a~1). - + intros H [a|a|]; apply H || intro; discriminate. - Qed. - - Lemma is_empty_1: forall s, Empty s -> is_empty s = true. - Proof. intro. rewrite is_empty_spec. trivial. Qed. - - Lemma is_empty_2: forall s, is_empty s = true -> Empty s. - Proof. intro. rewrite is_empty_spec. trivial. Qed. - - (** Specification of [subset] *) - - Lemma subset_Leaf_s: forall s, Leaf [<=] s. - Proof. intros s i Hi. elim (empty_1 Hi). Qed. - - Lemma subset_spec: forall s s', s [<=] s' <-> subset s s' = true. - Proof. - induction s as [|l IHl o r IHr]; intros [|l' o' r']; simpl. - - split; intros. - + reflexivity. - + apply subset_Leaf_s. - - - split; intros. - + reflexivity. - + apply subset_Leaf_s. - - - rewrite <- 2andb_lazy_alt, 2andb_true_iff, <- 2is_empty_spec. - destruct o; simpl. - + split. - * intro H. elim (@empty_1 1). apply H. reflexivity. - * intuition discriminate. - + split; intro H. - * split. - -- split. - ++ reflexivity. - ++ unfold Empty. intros a H1. apply (@empty_1 (a~0)). apply H. assumption. - -- unfold Empty. intros a H1. apply (@empty_1 (a~1)). apply H. assumption. - * destruct H as [[_ Hl] Hr]. - intros [i|i|] Hi. - -- elim (Hr i Hi). - -- elim (Hl i Hi). - -- discriminate. - - - rewrite <- 2andb_lazy_alt, 2andb_true_iff, <- IHl, <- IHr. clear. - destruct o; simpl. - + split; intro H. - * split. - -- split. - ++ destruct o'; trivial. - specialize (H 1). unfold In in H. simpl in H. apply H. reflexivity. - ++ intros i Hi. apply (H i~0). apply Hi. - -- intros i Hi. apply (H i~1). apply Hi. - * destruct H as [[Ho' Hl] Hr]. rewrite Ho'. - intros i Hi. destruct i. - -- apply (Hr i). assumption. - -- apply (Hl i). assumption. - -- assumption. - + split; intros. - * split. - -- split. - ++ reflexivity. - ++ intros i Hi. apply (H i~0). apply Hi. - -- intros i Hi. apply (H i~1). apply Hi. - * intros i Hi. destruct i; destruct H as [[H Hl] Hr]. - -- apply (Hr i). assumption. - -- apply (Hl i). assumption. - -- discriminate Hi. - Qed. - - - Lemma subset_1: forall s s', Subset s s' -> subset s s' = true. - Proof. intros s s'. apply -> subset_spec; trivial. Qed. - - Lemma subset_2: forall s s', subset s s' = true -> Subset s s'. - Proof. intros s s'. apply <- subset_spec; trivial. Qed. - - (** Specification of [equal] (via subset) *) - - Lemma equal_subset: forall s s', equal s s' = subset s s' && subset s' s. - Proof. - induction s as [|l IHl o r IHr]; intros [|l' o' r']; simpl; trivial. - - destruct o. - + reflexivity. - + rewrite andb_comm. reflexivity. - - rewrite <- 6andb_lazy_alt. rewrite eq_iff_eq_true. - rewrite 7andb_true_iff, eqb_true_iff. - rewrite IHl, IHr, 2andb_true_iff. clear IHl IHr. intuition subst. - + destruct o'; reflexivity. - + destruct o'; reflexivity. - + destruct o; auto. destruct o'; trivial. - Qed. - - Lemma equal_spec: forall s s', Equal s s' <-> equal s s' = true. - Proof. - intros. rewrite equal_subset. rewrite andb_true_iff. - rewrite <- 2subset_spec. unfold Equal, Subset. firstorder. - Qed. - - Lemma equal_1: forall s s', Equal s s' -> equal s s' = true. - Proof. intros s s'. apply -> equal_spec; trivial. Qed. - - Lemma equal_2: forall s s', equal s s' = true -> Equal s s'. - Proof. intros s s'. apply <- equal_spec; trivial. Qed. - - Lemma eq_dec : forall s s', { eq s s' } + { ~ eq s s' }. - Proof. - unfold eq. - intros. case_eq (equal s s'); intro H. - - left. apply equal_2, H. - - right. abstract (intro H'; rewrite (equal_1 H') in H; discriminate). - Defined. - - (** (Specified) definition of [compare] *) - - Lemma lex_Opp: forall u v u' v', u = CompOpp u' -> v = CompOpp v' -> - lex u v = CompOpp (lex u' v'). - Proof. intros ? ? u' ? -> ->. case u'; reflexivity. Qed. - - Lemma compare_bool_inv: forall b b', - compare_bool b b' = CompOpp (compare_bool b' b). - Proof. intros [|] [|]; reflexivity. Qed. - - Lemma compare_inv: forall s s', compare_fun s s' = CompOpp (compare_fun s' s). - Proof. - induction s as [|l IHl o r IHr]; destruct s' as [|l' o' r']; trivial. - - unfold compare_fun. case is_empty; reflexivity. - - unfold compare_fun. case is_empty; reflexivity. - - simpl. rewrite compare_bool_inv. - case compare_bool; simpl; trivial; apply lex_Opp; auto. - Qed. - - Lemma lex_Eq: forall u v, lex u v = Eq <-> u=Eq /\ v=Eq. - Proof. intros u v; destruct u; intuition discriminate. Qed. - - Lemma compare_bool_Eq: forall b1 b2, - compare_bool b1 b2 = Eq <-> eqb b1 b2 = true. - Proof. intros [|] [|]; intuition discriminate. Qed. - - Lemma compare_equal: forall s s', compare_fun s s' = Eq <-> equal s s' = true. - Proof. - induction s as [|l IHl o r IHr]; destruct s' as [|l' o' r']. - - simpl. tauto. - - unfold compare_fun, equal. case is_empty; intuition discriminate. - - unfold compare_fun, equal. case is_empty; intuition discriminate. - - simpl. rewrite <- 2andb_lazy_alt, 2andb_true_iff. - rewrite <- IHl, <- IHr, <- compare_bool_Eq. clear IHl IHr. - rewrite and_assoc. rewrite <- 2lex_Eq. reflexivity. - Qed. - - - Lemma compare_gt: forall s s', compare_fun s s' = Gt -> lt s' s. - Proof. - unfold lt. intros s s'. rewrite compare_inv. - case compare_fun; trivial; intros; discriminate. - Qed. - - Lemma compare_eq: forall s s', compare_fun s s' = Eq -> eq s s'. - Proof. - unfold eq. intros s s'. rewrite compare_equal, equal_spec. trivial. - Qed. - - Lemma compare : forall s s' : t, Compare lt eq s s'. - Proof. - intros. case_eq (compare_fun s s'); intro H. - - apply EQ. apply compare_eq, H. - - apply LT. assumption. - - apply GT. apply compare_gt, H. - Defined. - - Section lt_spec. - - Inductive ct: comparison -> comparison -> comparison -> Prop := - | ct_xxx: forall x, ct x x x - | ct_xex: forall x, ct x Eq x - | ct_exx: forall x, ct Eq x x - | ct_glx: forall x, ct Gt Lt x - | ct_lgx: forall x, ct Lt Gt x. - - Lemma ct_cxe: forall x, ct (CompOpp x) x Eq. - Proof. destruct x; constructor. Qed. - - Lemma ct_xce: forall x, ct x (CompOpp x) Eq. - Proof. destruct x; constructor. Qed. - - Lemma ct_lxl: forall x, ct Lt x Lt. - Proof. destruct x; constructor. Qed. - - Lemma ct_gxg: forall x, ct Gt x Gt. - Proof. destruct x; constructor. Qed. - - Lemma ct_xll: forall x, ct x Lt Lt. - Proof. destruct x; constructor. Qed. - - Lemma ct_xgg: forall x, ct x Gt Gt. - Proof. destruct x; constructor. Qed. - - Local Hint Constructors ct: ct. - Local Hint Resolve ct_cxe ct_xce ct_lxl ct_xll ct_gxg ct_xgg: ct. - Ltac ct := trivial with ct. - - Lemma ct_lex: forall u v w u' v' w', - ct u v w -> ct u' v' w' -> ct (lex u u') (lex v v') (lex w w'). - Proof. - intros u v w u' v' w' H H'. - inversion_clear H; inversion_clear H'; ct; destruct w; ct; destruct w'; ct. - Qed. - - Lemma ct_compare_bool: - forall a b c, ct (compare_bool a b) (compare_bool b c) (compare_bool a c). - Proof. - intros [|] [|] [|]; constructor. - Qed. - - Lemma compare_x_Leaf: forall s, - compare_fun s Leaf = if is_empty s then Eq else Gt. - Proof. - intros. rewrite compare_inv. simpl. case (is_empty s); reflexivity. - Qed. - - Lemma compare_empty_x: forall a, is_empty a = true -> - forall b, compare_fun a b = if is_empty b then Eq else Lt. - Proof. - induction a as [|l IHl o r IHr]; trivial. - destruct o. - - intro; discriminate. - - simpl is_empty. rewrite <- andb_lazy_alt, andb_true_iff. - intros [Hl Hr]. - destruct b as [|l' [|] r']; simpl compare_fun; trivial. - + rewrite Hl, Hr. trivial. - + rewrite (IHl Hl), (IHr Hr). simpl. - case (is_empty l'); case (is_empty r'); trivial. - Qed. - - Lemma compare_x_empty: forall a, is_empty a = true -> - forall b, compare_fun b a = if is_empty b then Eq else Gt. - Proof. - setoid_rewrite <- compare_x_Leaf. - intros. rewrite 2(compare_inv b), (compare_empty_x _ H). reflexivity. - Qed. - - Lemma ct_compare_fun: - forall a b c, ct (compare_fun a b) (compare_fun b c) (compare_fun a c). - Proof. - induction a as [|l IHl o r IHr]; intros s' s''. - - destruct s' as [|l' o' r']; destruct s'' as [|l'' o'' r'']; ct. - + rewrite compare_inv. ct. - + unfold compare_fun at 1. case_eq (is_empty (Node l' o' r')); intro H'. - * rewrite (compare_empty_x _ H'). ct. - * unfold compare_fun at 2. case_eq (is_empty (Node l'' o'' r'')); intro H''. - -- rewrite (compare_x_empty _ H''), H'. ct. - -- ct. - - - destruct s' as [|l' o' r']; destruct s'' as [|l'' o'' r'']. - + ct. - + unfold compare_fun at 2. rewrite compare_x_Leaf. - case_eq (is_empty (Node l o r)); intro H. - * rewrite (compare_empty_x _ H). ct. - * case_eq (is_empty (Node l'' o'' r'')); intro H''. - -- rewrite (compare_x_empty _ H''), H. ct. - -- ct. - - + rewrite 2 compare_x_Leaf. - case_eq (is_empty (Node l o r)); intro H. - * rewrite compare_inv, (compare_x_empty _ H). ct. - * case_eq (is_empty (Node l' o' r')); intro H'. - -- rewrite (compare_x_empty _ H'), H. ct. - -- ct. - - + simpl compare_fun. apply ct_lex. - * apply ct_compare_bool. - * apply ct_lex; trivial. - Qed. - - End lt_spec. - - Lemma lt_trans: forall s s' s'', lt s s' -> lt s' s'' -> lt s s''. - Proof. - unfold lt. intros a b c. assert (H := ct_compare_fun a b c). - inversion_clear H; trivial; intros; discriminate. - Qed. - - Lemma lt_not_eq: forall s s', lt s s' -> ~ eq s s'. - Proof. - unfold lt, eq. intros s s' H H'. - rewrite equal_spec, <- compare_equal in H'. congruence. - Qed. - - (** Specification of [add] *) - - Lemma add_spec: forall x y s, In y (add x s) <-> x=y \/ In y s. - Proof. - unfold In. induction x; intros [y|y|] [|l o r]; simpl mem; - try (rewrite IHx; clear IHx); rewrite ?mem_Leaf; intuition congruence. - Qed. - - Lemma add_1: forall s x y, x = y -> In y (add x s). - Proof. intros. apply <- add_spec. left. assumption. Qed. - - Lemma add_2: forall s x y, In y s -> In y (add x s). - Proof. intros. apply <- add_spec. right. assumption. Qed. - - Lemma add_3: forall s x y, x<>y -> In y (add x s) -> In y s. - Proof. - intros s x y H. rewrite add_spec. intros [->|?]; trivial. elim H; trivial. - Qed. - - (** Specification of [remove] *) - - Lemma remove_spec: forall x y s, In y (remove x s) <-> x<>y /\ In y s. - Proof. - unfold In. - induction x; intros [y|y|] [|l o r]; simpl remove; rewrite ?mem_node; - simpl mem; try (rewrite IHx; clear IHx); rewrite ?mem_Leaf; - intuition congruence. - Qed. - - Lemma remove_1: forall s x y, x=y -> ~ In y (remove x s). - Proof. intros. rewrite remove_spec. tauto. Qed. - - Lemma remove_2: forall s x y, x<>y -> In y s -> In y (remove x s). - Proof. intros. rewrite remove_spec. split; assumption. Qed. - - Lemma remove_3: forall s x y, In y (remove x s) -> In y s. - Proof. intros s x y. rewrite remove_spec. tauto. Qed. - - (** Specification of [singleton] *) - - Lemma singleton_1: forall x y, In y (singleton x) -> x=y. - Proof. - unfold singleton. intros x y. rewrite add_spec. - unfold In. rewrite mem_Leaf. intuition discriminate. - Qed. - - Lemma singleton_2: forall x y, x = y -> In y (singleton x). - Proof. - unfold singleton. intros. apply add_1. assumption. - Qed. - - (** Specification of [union] *) - - Lemma union_spec: forall x s s', In x (union s s') <-> In x s \/ In x s'. - Proof. - unfold In. - induction x; destruct s; destruct s'; simpl union; simpl mem; - try (rewrite IHx; clear IHx); try intuition congruence. - apply orb_true_iff. - Qed. - - Lemma union_1: forall s s' x, In x (union s s') -> In x s \/ In x s'. - Proof. intros. apply -> union_spec. assumption. Qed. - - Lemma union_2: forall s s' x, In x s -> In x (union s s'). - Proof. intros. apply <- union_spec. left. assumption. Qed. - - Lemma union_3: forall s s' x, In x s' -> In x (union s s'). - Proof. intros. apply <- union_spec. right. assumption. Qed. - - (** Specification of [inter] *) - - Lemma inter_spec: forall x s s', In x (inter s s') <-> In x s /\ In x s'. - Proof. - unfold In. - induction x; destruct s; destruct s'; simpl inter; rewrite ?mem_node; - simpl mem; try (rewrite IHx; clear IHx); try intuition congruence. - apply andb_true_iff. - Qed. - - Lemma inter_1: forall s s' x, In x (inter s s') -> In x s. - Proof. intros s s' x. rewrite inter_spec. tauto. Qed. - - Lemma inter_2: forall s s' x, In x (inter s s') -> In x s'. - Proof. intros s s' x. rewrite inter_spec. tauto. Qed. - - Lemma inter_3: forall s s' x, In x s -> In x s' -> In x (inter s s'). - Proof. intros. rewrite inter_spec. split; assumption. Qed. - - (** Specification of [diff] *) - - Lemma diff_spec: forall x s s', In x (diff s s') <-> In x s /\ ~ In x s'. - Proof. - unfold In. - induction x; destruct s; destruct s' as [|l' o' r']; simpl diff; - rewrite ?mem_node; simpl mem; - try (rewrite IHx; clear IHx); try intuition congruence. - rewrite andb_true_iff. destruct o'; intuition discriminate. - Qed. - - Lemma diff_1: forall s s' x, In x (diff s s') -> In x s. - Proof. intros s s' x. rewrite diff_spec. tauto. Qed. - - Lemma diff_2: forall s s' x, In x (diff s s') -> ~ In x s'. - Proof. intros s s' x. rewrite diff_spec. tauto. Qed. - - Lemma diff_3: forall s s' x, In x s -> ~ In x s' -> In x (diff s s'). - Proof. intros. rewrite diff_spec. split; assumption. Qed. - - (** Specification of [fold] *) - - Lemma fold_1: forall s (A : Type) (i : A) (f : elt -> A -> A), - fold f s i = fold_left (fun a e => f e a) (elements s) i. - Proof. - unfold fold, elements. intros s A i f. revert s i. - set (f' := fun a e => f e a). - assert (H: forall s i j acc, - fold_left f' acc (xfold f s i j) = - fold_left f' (xelements s j acc) i). - - - induction s as [|l IHl o r IHr]; intros; trivial. - destruct o; simpl xelements; simpl xfold. - + rewrite IHr, <- IHl. reflexivity. - + rewrite IHr. apply IHl. - - - intros. exact (H s i 1 nil). - Qed. - - (** Specification of [cardinal] *) - - Lemma cardinal_1: forall s, cardinal s = length (elements s). - Proof. - unfold elements. - assert (H: forall s j acc, - (cardinal s + length acc)%nat = length (xelements s j acc)). - - - induction s as [|l IHl b r IHr]; intros j acc; simpl; trivial. destruct b. - + rewrite <- IHl. simpl. rewrite <- IHr. - rewrite <- plus_n_Sm, Nat.add_assoc. reflexivity. - + rewrite <- IHl, <- IHr. rewrite Nat.add_assoc. reflexivity. - - - intros. rewrite <- H. simpl. rewrite Nat.add_comm. reflexivity. - Qed. - - (** Specification of [filter] *) - - Lemma xfilter_spec: forall f s x i, - In x (xfilter f s i) <-> In x s /\ f (i@x) = true. - Proof. - intro f. unfold In. - induction s as [|l IHl o r IHr]; intros x i; simpl xfilter. - - rewrite mem_Leaf. intuition discriminate. - - rewrite mem_node. destruct x; simpl. - + rewrite IHr. reflexivity. - + rewrite IHl. reflexivity. - + rewrite <- andb_lazy_alt. apply andb_true_iff. - Qed. - - Lemma filter_1 : forall s x f, @compat_bool elt E.eq f -> - In x (filter f s) -> In x s. - Proof. unfold filter. intros s x f _. rewrite xfilter_spec. tauto. Qed. - - Lemma filter_2 : forall s x f, @compat_bool elt E.eq f -> - In x (filter f s) -> f x = true. - Proof. unfold filter. intros s x f _. rewrite xfilter_spec. tauto. Qed. - - Lemma filter_3 : forall s x f, @compat_bool elt E.eq f -> In x s -> - f x = true -> In x (filter f s). - Proof. unfold filter. intros s x f _. rewrite xfilter_spec. tauto. Qed. - - - (** Specification of [for_all] *) - - Lemma xforall_spec: forall f s i, - xforall f s i = true <-> For_all (fun x => f (i@x) = true) s. - Proof. - unfold For_all, In. intro f. - induction s as [|l IHl o r IHr]; intros i; simpl. - - now split. - - rewrite <- 2andb_lazy_alt, <- orb_lazy_alt, 2 andb_true_iff. - rewrite IHl, IHr. clear IHl IHr. - split. - + intros [[Hi Hr] Hl] x. destruct x; simpl; intro H. - * apply Hr, H. - * apply Hl, H. - * rewrite H in Hi. assumption. - + intro H; intuition. - * specialize (H 1). destruct o. - -- apply H. reflexivity. - -- reflexivity. - * apply H. assumption. - * apply H. assumption. - Qed. - - Lemma for_all_1 : forall s f, @compat_bool elt E.eq f -> - For_all (fun x => f x = true) s -> for_all f s = true. - Proof. intros s f _. unfold for_all. rewrite xforall_spec. trivial. Qed. - - Lemma for_all_2 : forall s f, @compat_bool elt E.eq f -> - for_all f s = true -> For_all (fun x => f x = true) s. - Proof. intros s f _. unfold for_all. rewrite xforall_spec. trivial. Qed. - - - (** Specification of [exists] *) - - Lemma xexists_spec: forall f s i, - xexists f s i = true <-> Exists (fun x => f (i@x) = true) s. - Proof. - unfold Exists, In. intro f. - induction s as [|l IHl o r IHr]; intros i; simpl. - - split; [ discriminate | now intros [ _ [? _]]]. - - rewrite <- 2orb_lazy_alt, 2orb_true_iff, <- andb_lazy_alt, andb_true_iff. - rewrite IHl, IHr. clear IHl IHr. - split. - + intros [[Hi|[x Hr]]|[x Hl]]. - * exists 1. exact Hi. - * exists x~1. exact Hr. - * exists x~0. exact Hl. - + intros [[x|x|] H]; eauto. - Qed. - - Lemma exists_1 : forall s f, @compat_bool elt E.eq f -> - Exists (fun x => f x = true) s -> exists_ f s = true. - Proof. intros s f _. unfold exists_. rewrite xexists_spec. trivial. Qed. - - Lemma exists_2 : forall s f, @compat_bool elt E.eq f -> - exists_ f s = true -> Exists (fun x => f x = true) s. - Proof. intros s f _. unfold exists_. rewrite xexists_spec. trivial. Qed. - - - (** Specification of [partition] *) - - Lemma partition_filter : forall s f, - partition f s = (filter f s, filter (fun x => negb (f x)) s). - Proof. - unfold partition, filter. intros s f. generalize 1 as j. - induction s as [|l IHl o r IHr]; intro j. - - reflexivity. - - destruct o; simpl; rewrite IHl, IHr; reflexivity. - Qed. - - Lemma partition_1 : forall s f, @compat_bool elt E.eq f -> - Equal (fst (partition f s)) (filter f s). - Proof. intros. rewrite partition_filter. apply eq_refl. Qed. - - Lemma partition_2 : forall s f, @compat_bool elt E.eq f -> - Equal (snd (partition f s)) (filter (fun x => negb (f x)) s). - Proof. intros. rewrite partition_filter. apply eq_refl. Qed. - - - (** Specification of [elements] *) - - Notation InL := (InA E.eq). - - Lemma xelements_spec: forall s j acc y, - InL y (xelements s j acc) - <-> - InL y acc \/ exists x, y=(j@x) /\ mem x s = true. - Proof. - induction s as [|l IHl o r IHr]; simpl. - - intros. split; intro H. - + left. assumption. - + destruct H as [H|[x [Hx Hx']]]. - * assumption. - * discriminate. - - - intros j acc y. case o. - + rewrite IHl. rewrite InA_cons. rewrite IHr. clear IHl IHr. split. - * intros [[H|[H|[x [-> H]]]]|[x [-> H]]]; eauto. - -- right. exists x~1. auto. - -- right. exists x~0. auto. - * intros [H|[x [-> H]]]. - -- eauto. - -- destruct x. - ++ left. right. right. exists x; auto. - ++ right. exists x; auto. - ++ left. left. reflexivity. - - + rewrite IHl, IHr. clear IHl IHr. split. - * intros [[H|[x [-> H]]]|[x [-> H]]]. - -- eauto. - -- right. exists x~1. auto. - -- right. exists x~0. auto. - * intros [H|[x [-> H]]]. - -- eauto. - -- destruct x. - ++ left. right. exists x; auto. - ++ right. exists x; auto. - ++ discriminate. - Qed. - - Lemma elements_1: forall s x, In x s -> InL x (elements s). - Proof. - unfold elements, In. intros. - rewrite xelements_spec. right. exists x. auto. - Qed. - - Lemma elements_2: forall s x, InL x (elements s) -> In x s. - Proof. - unfold elements, In. intros s x H. - rewrite xelements_spec in H. destruct H as [H|[y [H H']]]. - - inversion_clear H. - - rewrite H. assumption. - Qed. - - Lemma lt_rev_append: forall j x y, E.lt x y -> E.lt (j@x) (j@y). - Proof. induction j; intros; simpl; auto. Qed. - - Lemma elements_3: forall s, sort E.lt (elements s). - Proof. - unfold elements. - assert (H: forall s j acc, - sort E.lt acc -> - (forall x y, In x s -> InL y acc -> E.lt (j@x) y) -> - sort E.lt (xelements s j acc)). { - - induction s as [|l IHl o r IHr]; simpl; trivial. - intros j acc Hacc Hsacc. destruct o. - - apply IHl. - + constructor. - * apply IHr. - -- apply Hacc. - -- intros x y Hx Hy. apply Hsacc; assumption. - * case_eq (xelements r j~1 acc). - -- constructor. - -- intros z q H. constructor. - assert (H': InL z (xelements r j~1 acc)). { - rewrite H. constructor. reflexivity. - } - clear H q. rewrite xelements_spec in H'. destruct H' as [Hy|[x [-> Hx]]]. - ++ apply (Hsacc 1 z); trivial. reflexivity. - ++ simpl. apply lt_rev_append. exact I. - + intros x y Hx Hy. inversion_clear Hy. - * rewrite H. simpl. apply lt_rev_append. exact I. - * rewrite xelements_spec in H. destruct H as [Hy|[z [-> Hy]]]. - -- apply Hsacc; assumption. - -- simpl. apply lt_rev_append. exact I. - - - apply IHl. - + apply IHr. - * apply Hacc. - * intros x y Hx Hy. apply Hsacc; assumption. - + intros x y Hx Hy. rewrite xelements_spec in Hy. - destruct Hy as [Hy|[z [-> Hy]]]. - * apply Hsacc; assumption. - * simpl. apply lt_rev_append. exact I. - } - - intros. apply H. - - constructor. - - intros x y _ H'. inversion H'. - Qed. - - Lemma elements_3w: forall s, NoDupA E.eq (elements s). - Proof. - intro. apply SortA_NoDupA with E.lt. - - constructor. - + intro. apply E.eq_refl. - + intro. apply E.eq_sym. - + intro. apply E.eq_trans. - - constructor. - + intros x H. apply E.lt_not_eq in H. apply H. reflexivity. - + intro. apply E.lt_trans. - - solve_proper. - - apply elements_3. - Qed. - - - (** Specification of [choose] *) - - Lemma choose_1: forall s x, choose s = Some x -> In x s. - Proof. - induction s as [| l IHl o r IHr]; simpl. - - intros. discriminate. - - destruct o. - + intros x H. injection H; intros; subst. reflexivity. - + revert IHl. case choose. - * intros p Hp x [= <-]. apply Hp. - reflexivity. - * intros _ x. revert IHr. case choose. - -- intros p Hp [= <-]. apply Hp. - reflexivity. - -- intros. discriminate. - Qed. - - Lemma choose_2: forall s, choose s = None -> Empty s. - Proof. - unfold Empty, In. intros s H. - induction s as [|l IHl o r IHr]. - - intro. apply empty_1. - - destruct o. - + discriminate. - + simpl in H. destruct (choose l). - * discriminate. - * destruct (choose r). - -- discriminate. - -- intros [a|a|]. - ++ apply IHr. reflexivity. - ++ apply IHl. reflexivity. - ++ discriminate. - Qed. - - Lemma choose_empty: forall s, is_empty s = true -> choose s = None. - Proof. - intros s Hs. case_eq (choose s); trivial. - intros p Hp. apply choose_1 in Hp. apply is_empty_2 in Hs. elim (Hs _ Hp). - Qed. - - Lemma choose_3': forall s s', Equal s s' -> choose s = choose s'. - Proof. - setoid_rewrite equal_spec. - induction s as [|l IHl o r IHr]. - - intros. symmetry. apply choose_empty. assumption. - - - destruct s' as [|l' o' r']. - + generalize (Node l o r) as s. simpl. intros. apply choose_empty. - rewrite <- equal_spec in H. apply eq_sym in H. rewrite equal_spec in H. - assumption. - - + simpl. rewrite <- 2andb_lazy_alt, 2andb_true_iff, eqb_true_iff. - intros [[<- Hl] Hr]. rewrite (IHl _ Hl), (IHr _ Hr). reflexivity. - Qed. - - Lemma choose_3: forall s s' x y, - choose s = Some x -> choose s' = Some y -> Equal s s' -> E.eq x y. - Proof. intros s s' x y Hx Hy H. apply choose_3' in H. congruence. Qed. - - - (** Specification of [min_elt] *) - - Lemma min_elt_1: forall s x, min_elt s = Some x -> In x s. - Proof. - unfold In. - induction s as [| l IHl o r IHr]; simpl. - - intros. discriminate. - - intros x. destruct (min_elt l); intros. - + injection H as [= <-]. apply IHl. reflexivity. - + destruct o; simpl. - * injection H as [= <-]. reflexivity. - * destruct (min_elt r); simpl in *. - -- injection H as [= <-]. apply IHr. reflexivity. - -- discriminate. - Qed. - - Lemma min_elt_3: forall s, min_elt s = None -> Empty s. - Proof. - unfold Empty, In. intros s H. - induction s as [|l IHl o r IHr]. - - intro. apply empty_1. - - intros [a|a|]. - + apply IHr. revert H. clear. simpl. destruct (min_elt r); trivial. - case min_elt; intros; try discriminate. destruct o; discriminate. - + apply IHl. revert H. clear. simpl. destruct (min_elt l); trivial. - intro; discriminate. - + revert H. clear. simpl. case min_elt; intros; try discriminate. - destruct o; discriminate. - Qed. - - Lemma min_elt_2: forall s x y, min_elt s = Some x -> In y s -> ~ E.lt y x. - Proof. - unfold In. - induction s as [|l IHl o r IHr]; intros x y H H'. - - discriminate. - - simpl in H. case_eq (min_elt l). - + intros p Hp. rewrite Hp in H. injection H as [= <-]. - destruct y as [z|z|]; simpl; intro; trivial. apply (IHl p z); trivial. - + intro Hp; rewrite Hp in H. apply min_elt_3 in Hp. - destruct o. - * injection H as [= <-]. intros Hl. - destruct y as [z|z|]; simpl; trivial. elim (Hp _ H'). - - * destruct (min_elt r). - -- injection H as [= <-]. - destruct y as [z|z|]. - ++ apply (IHr e z); trivial. - ++ elim (Hp _ H'). - ++ discriminate. - -- discriminate. - Qed. - - - (** Specification of [max_elt] *) - - Lemma max_elt_1: forall s x, max_elt s = Some x -> In x s. - Proof. - unfold In. - induction s as [| l IHl o r IHr]; simpl. - - intros. discriminate. - - intros x. destruct (max_elt r); intros. - + injection H as [= <-]. apply IHr. reflexivity. - + destruct o; simpl. - * injection H as [= <-]. reflexivity. - * destruct (max_elt l); simpl in *. - -- injection H as [= <-]. apply IHl. reflexivity. - -- discriminate. - Qed. - - Lemma max_elt_3: forall s, max_elt s = None -> Empty s. - Proof. - unfold Empty, In. intros s H. - induction s as [|l IHl o r IHr]. - - intro. apply empty_1. - - intros [a|a|]. - + apply IHr. revert H. clear. simpl. destruct (max_elt r); trivial. - intro; discriminate. - + apply IHl. revert H. clear. simpl. destruct (max_elt l); trivial. - case max_elt; intros; try discriminate. destruct o; discriminate. - + revert H. clear. simpl. case max_elt; intros; try discriminate. - destruct o; discriminate. - Qed. - - Lemma max_elt_2: forall s x y, max_elt s = Some x -> In y s -> ~ E.lt x y. - Proof. - unfold In. - induction s as [|l IHl o r IHr]; intros x y H H'. - - discriminate. - - simpl in H. case_eq (max_elt r). - + intros p Hp. rewrite Hp in H. injection H as [= <-]. - destruct y as [z|z|]; simpl; intro; trivial. apply (IHr p z); trivial. - + intro Hp; rewrite Hp in H. apply max_elt_3 in Hp. - destruct o. - * injection H as [= <-]. intros Hl. - destruct y as [z|z|]; simpl; trivial. elim (Hp _ H'). - - * destruct (max_elt l). - -- injection H as [= <-]. - destruct y as [z|z|]. - ++ elim (Hp _ H'). - ++ apply (IHl e z); trivial. - ++ discriminate. - -- discriminate. - Qed. - -End PositiveSet. diff --git a/stdlib/theories/FSets/FSetProperties.v b/stdlib/theories/FSets/FSetProperties.v deleted file mode 100644 index 9f5442e21d1d..000000000000 --- a/stdlib/theories/FSets/FSetProperties.v +++ /dev/null @@ -1,1193 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* constructor; congruence : fset. - -(** First, a functor for Weak Sets in functorial version. *) - -Module WProperties_fun (Import E : DecidableType)(M : WSfun E). - Module Import Dec := WDecide_fun E M. - Module Import FM := Dec.F (* FSetFacts.WFacts_fun E M *). - Import M. - - Lemma In_dec : forall x s, {In x s} + {~ In x s}. - Proof. - intros; generalize (mem_iff s x); case (mem x s); intuition auto with bool. - Qed. - - Definition Add x s s' := forall y, In y s' <-> E.eq x y \/ In y s. - - Lemma Add_Equal : forall x s s', Add x s s' <-> s' [=] add x s. - Proof. - unfold Add. - split; intros. - - red; intros. - rewrite H; clear H. - fsetdec. - - fsetdec. - Qed. - - Ltac expAdd := repeat rewrite Add_Equal. - - Section BasicProperties. - - Variable s s' s'' s1 s2 s3 : t. - Variable x x' : elt. - - Lemma equal_refl : s[=]s. - Proof. fsetdec. Qed. - - Lemma equal_sym : s[=]s' -> s'[=]s. - Proof. fsetdec. Qed. - - Lemma equal_trans : s1[=]s2 -> s2[=]s3 -> s1[=]s3. - Proof. fsetdec. Qed. - - Lemma subset_refl : s[<=]s. - Proof. fsetdec. Qed. - - Lemma subset_trans : s1[<=]s2 -> s2[<=]s3 -> s1[<=]s3. - Proof. fsetdec. Qed. - - Lemma subset_antisym : s[<=]s' -> s'[<=]s -> s[=]s'. - Proof. fsetdec. Qed. - - Lemma subset_equal : s[=]s' -> s[<=]s'. - Proof. fsetdec. Qed. - - Lemma subset_empty : empty[<=]s. - Proof. fsetdec. Qed. - - Lemma subset_remove_3 : s1[<=]s2 -> remove x s1 [<=] s2. - Proof. fsetdec. Qed. - - Lemma subset_diff : s1[<=]s3 -> diff s1 s2 [<=] s3. - Proof. fsetdec. Qed. - - Lemma subset_add_3 : In x s2 -> s1[<=]s2 -> add x s1 [<=] s2. - Proof. fsetdec. Qed. - - Lemma subset_add_2 : s1[<=]s2 -> s1[<=] add x s2. - Proof. fsetdec. Qed. - - Lemma in_subset : In x s1 -> s1[<=]s2 -> In x s2. - Proof. fsetdec. Qed. - - Lemma double_inclusion : s1[=]s2 <-> s1[<=]s2 /\ s2[<=]s1. - Proof. intuition fsetdec. Qed. - - Lemma empty_is_empty_1 : Empty s -> s[=]empty. - Proof. fsetdec. Qed. - - Lemma empty_is_empty_2 : s[=]empty -> Empty s. - Proof. fsetdec. Qed. - - Lemma add_equal : In x s -> add x s [=] s. - Proof. fsetdec. Qed. - - Lemma add_add : add x (add x' s) [=] add x' (add x s). - Proof. fsetdec. Qed. - - Lemma remove_equal : ~ In x s -> remove x s [=] s. - Proof. fsetdec. Qed. - - Lemma Equal_remove : s[=]s' -> remove x s [=] remove x s'. - Proof. fsetdec. Qed. - - Lemma add_remove : In x s -> add x (remove x s) [=] s. - Proof. fsetdec. Qed. - - Lemma remove_add : ~In x s -> remove x (add x s) [=] s. - Proof. fsetdec. Qed. - - Lemma singleton_equal_add : singleton x [=] add x empty. - Proof. fsetdec. Qed. - - Lemma remove_singleton_empty : - In x s -> remove x s [=] empty -> singleton x [=] s. - Proof. fsetdec. Qed. - - Lemma union_sym : union s s' [=] union s' s. - Proof. fsetdec. Qed. - - Lemma union_subset_equal : s[<=]s' -> union s s' [=] s'. - Proof. fsetdec. Qed. - - Lemma union_equal_1 : s[=]s' -> union s s'' [=] union s' s''. - Proof. fsetdec. Qed. - - Lemma union_equal_2 : s'[=]s'' -> union s s' [=] union s s''. - Proof. fsetdec. Qed. - - Lemma union_assoc : union (union s s') s'' [=] union s (union s' s''). - Proof. fsetdec. Qed. - - Lemma add_union_singleton : add x s [=] union (singleton x) s. - Proof. fsetdec. Qed. - - Lemma union_add : union (add x s) s' [=] add x (union s s'). - Proof. fsetdec. Qed. - - Lemma union_remove_add_1 : - union (remove x s) (add x s') [=] union (add x s) (remove x s'). - Proof. fsetdec. Qed. - - Lemma union_remove_add_2 : In x s -> - union (remove x s) (add x s') [=] union s s'. - Proof. fsetdec. Qed. - - Lemma union_subset_1 : s [<=] union s s'. - Proof. fsetdec. Qed. - - Lemma union_subset_2 : s' [<=] union s s'. - Proof. fsetdec. Qed. - - Lemma union_subset_3 : s[<=]s'' -> s'[<=]s'' -> union s s' [<=] s''. - Proof. fsetdec. Qed. - - Lemma union_subset_4 : s[<=]s' -> union s s'' [<=] union s' s''. - Proof. fsetdec. Qed. - - Lemma union_subset_5 : s[<=]s' -> union s'' s [<=] union s'' s'. - Proof. fsetdec. Qed. - - Lemma empty_union_1 : Empty s -> union s s' [=] s'. - Proof. fsetdec. Qed. - - Lemma empty_union_2 : Empty s -> union s' s [=] s'. - Proof. fsetdec. Qed. - - Lemma not_in_union : ~In x s -> ~In x s' -> ~In x (union s s'). - Proof. fsetdec. Qed. - - Lemma inter_sym : inter s s' [=] inter s' s. - Proof. fsetdec. Qed. - - Lemma inter_subset_equal : s[<=]s' -> inter s s' [=] s. - Proof. fsetdec. Qed. - - Lemma inter_equal_1 : s[=]s' -> inter s s'' [=] inter s' s''. - Proof. fsetdec. Qed. - - Lemma inter_equal_2 : s'[=]s'' -> inter s s' [=] inter s s''. - Proof. fsetdec. Qed. - - Lemma inter_assoc : inter (inter s s') s'' [=] inter s (inter s' s''). - Proof. fsetdec. Qed. - - Lemma union_inter_1 : inter (union s s') s'' [=] union (inter s s'') (inter s' s''). - Proof. fsetdec. Qed. - - Lemma union_inter_2 : union (inter s s') s'' [=] inter (union s s'') (union s' s''). - Proof. fsetdec. Qed. - - Lemma inter_add_1 : In x s' -> inter (add x s) s' [=] add x (inter s s'). - Proof. fsetdec. Qed. - - Lemma inter_add_2 : ~ In x s' -> inter (add x s) s' [=] inter s s'. - Proof. fsetdec. Qed. - - Lemma empty_inter_1 : Empty s -> Empty (inter s s'). - Proof. fsetdec. Qed. - - Lemma empty_inter_2 : Empty s' -> Empty (inter s s'). - Proof. fsetdec. Qed. - - Lemma inter_subset_1 : inter s s' [<=] s. - Proof. fsetdec. Qed. - - Lemma inter_subset_2 : inter s s' [<=] s'. - Proof. fsetdec. Qed. - - Lemma inter_subset_3 : - s''[<=]s -> s''[<=]s' -> s''[<=] inter s s'. - Proof. fsetdec. Qed. - - Lemma empty_diff_1 : Empty s -> Empty (diff s s'). - Proof. fsetdec. Qed. - - Lemma empty_diff_2 : Empty s -> diff s' s [=] s'. - Proof. fsetdec. Qed. - - Lemma diff_subset : diff s s' [<=] s. - Proof. fsetdec. Qed. - - Lemma diff_subset_equal : s[<=]s' -> diff s s' [=] empty. - Proof. fsetdec. Qed. - - Lemma remove_diff_singleton : - remove x s [=] diff s (singleton x). - Proof. fsetdec. Qed. - - Lemma diff_inter_empty : inter (diff s s') (inter s s') [=] empty. - Proof. fsetdec. Qed. - - Lemma diff_inter_all : union (diff s s') (inter s s') [=] s. - Proof. fsetdec. Qed. - - Lemma Add_add : Add x s (add x s). - Proof. expAdd; fsetdec. Qed. - - Lemma Add_remove : In x s -> Add x (remove x s) s. - Proof. expAdd; fsetdec. Qed. - - Lemma union_Add : Add x s s' -> Add x (union s s'') (union s' s''). - Proof. expAdd; fsetdec. Qed. - - Lemma inter_Add : - In x s'' -> Add x s s' -> Add x (inter s s'') (inter s' s''). - Proof. expAdd; fsetdec. Qed. - - Lemma union_Equal : - In x s'' -> Add x s s' -> union s s'' [=] union s' s''. - Proof. expAdd; fsetdec. Qed. - - Lemma inter_Add_2 : - ~In x s'' -> Add x s s' -> inter s s'' [=] inter s' s''. - Proof. expAdd; fsetdec. Qed. - - End BasicProperties. - - #[global] - Hint Immediate equal_sym add_remove remove_add union_sym inter_sym: set. - #[global] - Hint Resolve equal_refl equal_trans subset_refl subset_equal subset_antisym - subset_trans subset_empty subset_remove_3 subset_diff subset_add_3 - subset_add_2 in_subset empty_is_empty_1 empty_is_empty_2 add_equal - remove_equal singleton_equal_add union_subset_equal union_equal_1 - union_equal_2 union_assoc add_union_singleton union_add union_subset_1 - union_subset_2 union_subset_3 inter_subset_equal inter_equal_1 inter_equal_2 - inter_assoc union_inter_1 union_inter_2 inter_add_1 inter_add_2 - empty_inter_1 empty_inter_2 empty_union_1 empty_union_2 empty_diff_1 - empty_diff_2 union_Add inter_Add union_Equal inter_Add_2 not_in_union - inter_subset_1 inter_subset_2 inter_subset_3 diff_subset diff_subset_equal - remove_diff_singleton diff_inter_empty diff_inter_all Add_add Add_remove - Equal_remove add_add : set. - - (** * Properties of elements *) - - Lemma elements_Empty : forall s, Empty s <-> elements s = nil. - Proof. - intros. - unfold Empty. - split; intros. - - assert (forall a, ~ List.In a (elements s)). { - red; intros. - apply (H a). - rewrite elements_iff. - rewrite InA_alt; exists a; auto. - } - destruct (elements s); auto. - elim (H0 e); simpl; auto. - - red; intros. - rewrite elements_iff in H0. - rewrite InA_alt in H0; destruct H0. - rewrite H in H0; destruct H0 as (_,H0); inversion H0. - Qed. - - Lemma elements_empty : elements empty = nil. - Proof. - rewrite <-elements_Empty; auto with set. - Qed. - - (** * Conversions between lists and sets *) - - Definition of_list (l : list elt) := List.fold_right add empty l. - - Definition to_list := elements. - - Lemma of_list_1 : forall l x, In x (of_list l) <-> InA E.eq x l. - Proof. - induction l; simpl; intro x. - - rewrite empty_iff, InA_nil. intuition. - - rewrite add_iff, InA_cons, IHl. intuition. - Qed. - - Lemma of_list_2 : forall l, equivlistA E.eq (to_list (of_list l)) l. - Proof. - unfold to_list; red; intros. - rewrite <- elements_iff; apply of_list_1. - Qed. - - Lemma of_list_3 : forall s, of_list (to_list s) [=] s. - Proof. - unfold to_list; red; intros. - rewrite of_list_1; symmetry; apply elements_iff. - Qed. - - (** * Fold *) - - Section Fold. - - (** Alternative specification via [fold_right] *) - - Lemma fold_spec_right (s:t)(A:Type)(i:A)(f : elt -> A -> A) : - fold f s i = List.fold_right f i (rev (elements s)). - Proof. - rewrite fold_1. symmetry. apply fold_left_rev_right. - Qed. - - Notation NoDup := (NoDupA E.eq). - Notation InA := (InA E.eq). - - (** ** Induction principles for fold (contributed by S. Lescuyer) *) - - (** In the following lemma, the step hypothesis is deliberately restricted - to the precise set s we are considering. *) - - Theorem fold_rec : - forall (A:Type)(P : t -> A -> Type)(f : elt -> A -> A)(i:A)(s:t), - (forall s', Empty s' -> P s' i) -> - (forall x a s' s'', In x s -> ~In x s' -> Add x s' s'' -> - P s' a -> P s'' (f x a)) -> - P s (fold f s i). - Proof. - intros A P f i s Pempty Pstep. - rewrite fold_spec_right. set (l:=rev (elements s)). - 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. - } - 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 - (unfold l; intros; rewrite elements_iff, InA_rev; intuition). - clear Pstep; clearbody l; revert s Hsame; induction l. - - (* empty *) - intros s Hsame; simpl. - apply Pempty. intro x. rewrite Hsame, InA_nil; intuition. - - (* step *) - intros s Hsame; simpl. - apply Pstep' with (of_list l); auto. - + inversion_clear Hdup; rewrite of_list_1; auto. - + red. intros. rewrite Hsame, of_list_1, InA_cons; intuition. - + apply IHl. - * intros; eapply Pstep'; eauto. - * inversion_clear Hdup; auto. - * exact (of_list_1 l). - Qed. - - (** Same, with [empty] and [add] instead of [Empty] and [Add]. In this - case, [P] must be compatible with equality of sets *) - - Theorem fold_rec_bis : - forall (A:Type)(P : t -> A -> Type)(f : elt -> A -> A)(i:A)(s:t), - (forall s s' a, s[=]s' -> P s a -> P s' a) -> - (P empty i) -> - (forall x a s', In x s -> ~In x s' -> P s' a -> P (add x s') (f x a)) -> - P s (fold f s i). - Proof. - intros A P f i s Pmorphism Pempty Pstep. - apply fold_rec; intros. - - apply Pmorphism with empty; auto with set. - - rewrite Add_Equal in H1; auto with set. - apply Pmorphism with (add x s'); auto with set. - Qed. - - Lemma fold_rec_nodep : - forall (A:Type)(P : A -> Type)(f : elt -> A -> A)(i:A)(s:t), - P i -> (forall x a, In x s -> P a -> P (f x a)) -> - P (fold f s i). - Proof. - intros; apply fold_rec_bis with (P:=fun _ => P); auto. - Qed. - - (** [fold_rec_weak] is a weaker principle than [fold_rec_bis] : - the step hypothesis must here be applicable to any [x]. - At the same time, it looks more like an induction principle, - and hence can be easier to use. *) - - Lemma fold_rec_weak : - forall (A:Type)(P : t -> A -> Type)(f : elt -> A -> A)(i:A), - (forall s s' a, s[=]s' -> P s a -> P s' a) -> - P empty i -> - (forall x a s, ~In x s -> P s a -> P (add x s) (f x a)) -> - forall s, P s (fold f s i). - Proof. - intros; apply fold_rec_bis; auto. - Qed. - - Lemma fold_rel : - forall (A B:Type)(R : A -> B -> Type) - (f : elt -> A -> A)(g : elt -> B -> B)(i : A)(j : B)(s : t), - R i j -> - (forall x a b, In x s -> R a b -> R (f x a) (g x b)) -> - R (fold f s i) (fold g s j). - Proof. - 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). - clearbody l; clear Rstep s. - induction l; simpl; auto. - Qed. - - (** From the induction principle on [fold], we can deduce some general - induction principles on sets. *) - - Lemma set_induction : - forall P : t -> Type, - (forall s, Empty s -> P s) -> - (forall s s', P s -> forall x, ~In x s -> Add x s s' -> P s') -> - forall s, P s. - Proof. - intros. apply (@fold_rec _ (fun s _ => P s) (fun _ _ => tt) tt s); eauto. - Qed. - - Lemma set_induction_bis : - forall P : t -> Type, - (forall s s', s [=] s' -> P s -> P s') -> - P empty -> - (forall x s, ~In x s -> P s -> P (add x s)) -> - forall s, P s. - Proof. - intros. - apply (@fold_rec_bis _ (fun s _ => P s) (fun _ _ => tt) tt s); eauto. - Qed. - - (** [fold] can be used to reconstruct the same initial set. *) - - Lemma fold_identity : forall s, fold add s empty [=] s. - Proof. - intros. - apply fold_rec with (P:=fun s acc => acc[=]s); auto with set. - intros. rewrite H2; rewrite Add_Equal in H1; auto with set. - Qed. - - (** ** Alternative (weaker) specifications for [fold] *) - - (** When [FSets] was first designed, the order in which Ocaml's [Set.fold] - takes the set elements was unspecified. This specification reflects - this fact: - *) - - Lemma fold_0 : - forall s (A : Type) (i : A) (f : elt -> A -> A), - exists l : list elt, - NoDup l /\ - (forall x : elt, In x s <-> InA x l) /\ - fold f s i = fold_right f i l. - Proof. - intros; exists (rev (elements s)); split. - - 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. - + apply fold_spec_right. - Qed. - - (** An alternate (and previous) specification for [fold] was based on - the recursive structure of a set. It is now lemmas [fold_1] and - [fold_2]. *) - - Lemma fold_1 : - forall s (A : Type) (eqA : A -> A -> Prop) - (st : Equivalence eqA) (i : A) (f : elt -> A -> A), - Empty s -> eqA (fold f s i) i. - Proof. - unfold Empty; intros; destruct (fold_0 s i f) as (l,(H1, (H2, H3))). - rewrite H3; clear H3. - generalize H H2; clear H H2; case l; simpl; intros. - - reflexivity. - - elim (H e). - elim (H2 e); intuition. - Qed. - - Lemma fold_2 : - forall s s' x (A : Type) (eqA : A -> A -> Prop) - (st : Equivalence eqA) (i : A) (f : elt -> A -> A), - compat_op E.eq eqA f -> - transpose eqA f -> - ~ In x s -> Add x s s' -> eqA (fold f s' i) (f x (fold f s i)). - Proof. - 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 typeclass_instances. } 1-5: auto. - - rewrite <- Hl1; auto. - - intros a; rewrite InA_cons; rewrite <- Hl1; rewrite <- Hl'1; - rewrite (H2 a); intuition. - Qed. - - (** In fact, [fold] on empty sets is more than equivalent to - the initial element, it is Leibniz-equal to it. *) - - Lemma fold_1b : - forall s (A : Type)(i : A) (f : elt -> A -> A), - Empty s -> (fold f s i) = i. - Proof. - intros. - rewrite M.fold_1. - rewrite elements_Empty in H; rewrite H; simpl; auto. - Qed. - - Section Fold_More. - - Variables (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA). - Variables (f:elt->A->A)(Comp:compat_op E.eq eqA f)(Ass:transpose eqA f). - - Lemma fold_commutes : forall i s x, - eqA (fold f s (f x i)) (f x (fold f s i)). - Proof. - 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. - Qed. - - (** ** Fold is a morphism *) - - Lemma fold_init : forall i i' s, eqA i i' -> - eqA (fold f s i) (fold f s i'). - Proof. - intros. apply fold_rel with (R:=eqA); auto. - intros; apply Comp; auto. - Qed. - - Lemma fold_equal : - forall i s s', s[=]s' -> eqA (fold f s i) (fold f s' i). - Proof. - intros i s; pattern s; apply set_induction; clear s; intros. - - transitivity i. - + apply fold_1; auto. - + symmetry; apply fold_1; auto. - rewrite <- H0; auto. - - transitivity (f x (fold f s i)). - + apply fold_2 with (eqA := eqA); auto. - + symmetry; apply fold_2 with (eqA := eqA); auto. - unfold Add in *; intros. - rewrite <- H2; auto. - Qed. - - (** ** Fold and other set operators *) - - Lemma fold_empty : forall i, fold f empty i = i. - Proof. - intros i; apply fold_1b; auto with set. - Qed. - - Lemma fold_add : forall i s x, ~In x s -> - eqA (fold f (add x s) i) (f x (fold f s i)). - Proof. - intros; apply fold_2 with (eqA := eqA); auto with set. - Qed. - - Lemma add_fold : forall i s x, In x s -> - eqA (fold f (add x s) i) (fold f s i). - Proof. - intros; apply fold_equal; auto with set. - Qed. - - Lemma remove_fold_1: forall i s x, In x s -> - eqA (f x (fold f (remove x s) i)) (fold f s i). - Proof. - intros. - symmetry. - apply fold_2 with (eqA:=eqA); auto with set. - Qed. - - Lemma remove_fold_2: forall i s x, ~In x s -> - eqA (fold f (remove x s) i) (fold f s i). - Proof. - intros. - apply fold_equal; auto with set. - Qed. - - Lemma fold_union_inter : forall i s s', - eqA (fold f (union s s') (fold f (inter s s') i)) - (fold f s (fold f s' i)). - Proof. - intros; pattern s; apply set_induction; clear s; intros. - - transitivity (fold f s' (fold f (inter s s') i)). - { apply fold_equal; auto with set. } - transitivity (fold f s' i). - + apply fold_init; auto. - apply fold_1; auto with set. - + symmetry; apply fold_1; auto. - - rename s'0 into s''. - destruct (In_dec x s'). - + (* In x s' *) - transitivity (fold f (union s'' s') (f x (fold f (inter s s') i))); auto with set. - * apply fold_init; auto. - apply fold_2 with (eqA:=eqA); auto with set. - rewrite inter_iff; intuition. - * transitivity (f x (fold f s (fold f s' i))). - 1:transitivity (fold f (union s s') (f x (fold f (inter s s') i))). - -- apply fold_equal; auto. - apply equal_sym; apply union_Equal with x; auto with set. - -- transitivity (f x (fold f (union s s') (fold f (inter s s') i))). - { apply fold_commutes; auto. } - apply Comp; auto. - -- symmetry; apply fold_2 with (eqA:=eqA); auto. - + (* ~(In x s') *) - transitivity (f x (fold f (union s s') (fold f (inter s'' s') i))). - { apply fold_2 with (eqA:=eqA); auto with set. } - transitivity (f x (fold f (union s s') (fold f (inter s s') i))). - * apply Comp;auto. - apply fold_init;auto. - apply fold_equal;auto. - apply equal_sym; apply inter_Add_2 with x; auto with set. - * transitivity (f x (fold f s (fold f s' i))). - -- apply Comp; auto. - -- symmetry; apply fold_2 with (eqA:=eqA); auto. - Qed. - - Lemma fold_diff_inter : forall i s s', - eqA (fold f (diff s s') (fold f (inter s s') i)) (fold f s i). - Proof. - intros. - transitivity (fold f (union (diff s s') (inter s s')) - (fold f (inter (diff s s') (inter s s')) i)). - { symmetry; apply fold_union_inter; auto. } - transitivity (fold f s (fold f (inter (diff s s') (inter s s')) i)). - { apply fold_equal; auto with set. } - apply fold_init; auto. - apply fold_1; auto with set. - Qed. - - Lemma fold_union: forall i s s', - (forall x, ~(In x s/\In x s')) -> - eqA (fold f (union s s') i) (fold f s (fold f s' i)). - Proof. - intros. - transitivity (fold f (union s s') (fold f (inter s s') i)). - { apply fold_init; auto. - symmetry; apply fold_1; auto with set. - unfold Empty; intro a; generalize (H a); set_iff; tauto. } - apply fold_union_inter; auto. - Qed. - - End Fold_More. - - Lemma fold_plus : - forall s p, fold (fun _ => S) s p = fold (fun _ => S) s 0 + p. - Proof. - intros. apply fold_rel with (R:=fun u v => u = v + p); simpl; auto. - Qed. - - End Fold. - - (** * Cardinal *) - - (** ** Characterization of cardinal in terms of fold *) - - Lemma cardinal_fold : forall s, cardinal s = fold (fun _ => S) s 0. - Proof. - intros; rewrite cardinal_1; rewrite M.fold_1. - symmetry; apply fold_left_S_0; auto. - Qed. - - (** ** Old specifications for [cardinal]. *) - - Lemma cardinal_0 : - forall s, exists l : list elt, - NoDupA E.eq l /\ - (forall x : elt, In x s <-> InA E.eq x l) /\ - cardinal s = length l. - Proof. - intros; exists (elements s); intuition auto with set; apply cardinal_1. - Qed. - - Lemma cardinal_1 : forall s, Empty s -> cardinal s = 0. - Proof. - intros; rewrite cardinal_fold; apply fold_1; auto with fset. - Qed. - - Lemma cardinal_2 : - forall s s' x, ~ In x s -> Add x s s' -> cardinal s' = S (cardinal s). - Proof. - intros; do 2 rewrite cardinal_fold. - change S with ((fun _ => S) x). - apply fold_2; auto with fset. - Qed. - - (** ** Cardinal and (non-)emptiness *) - - Lemma cardinal_Empty : forall s, Empty s <-> cardinal s = 0. - Proof. - intros. - rewrite elements_Empty, M.cardinal_1. - destruct (elements s); intuition; discriminate. - Qed. - - Lemma cardinal_inv_1 : forall s, cardinal s = 0 -> Empty s. - Proof. - intros; rewrite cardinal_Empty; auto. - Qed. - #[global] - Hint Resolve cardinal_inv_1 : fset. - - Lemma cardinal_inv_2 : - forall s n, cardinal s = S n -> { x : elt | In x s }. - Proof. - intros; rewrite M.cardinal_1 in H. - generalize (elements_2 (s:=s)). - destruct (elements s); try discriminate. - exists e; auto. - Qed. - - Lemma cardinal_inv_2b : - forall s, cardinal s <> 0 -> { x : elt | In x s }. - Proof. - intro; generalize (@cardinal_inv_2 s); destruct cardinal; - [intuition|eauto]. - Qed. - - (** ** Cardinal is a morphism *) - - Lemma Equal_cardinal : forall s s', s[=]s' -> cardinal s = cardinal s'. - Proof. - symmetry. - remember (cardinal s) as n; symmetry in Heqn; revert s s' Heqn H. - induction n; intros. - - apply cardinal_1; rewrite <- H; auto with fset. - - destruct (cardinal_inv_2 Heqn) as (x,H2). - revert Heqn. - rewrite (cardinal_2 (s:=remove x s) (s':=s) (x:=x)); auto with set. - rewrite (cardinal_2 (s:=remove x s') (s':=s') (x:=x)); eauto with set. - Qed. - - Add Morphism cardinal with signature (Equal ==> Logic.eq) as cardinal_m. - Proof. - exact Equal_cardinal. - Qed. - - #[global] - Hint Resolve Add_add Add_remove Equal_remove cardinal_inv_1 Equal_cardinal : fset. - - (** ** Cardinal and set operators *) - - Lemma empty_cardinal : cardinal empty = 0. - Proof. - rewrite cardinal_fold; apply fold_1; auto with set fset. - Qed. - - #[global] - Hint Immediate empty_cardinal cardinal_1 : set. - - Lemma singleton_cardinal : forall x, cardinal (singleton x) = 1. - Proof. - intros. - rewrite (singleton_equal_add x). - replace 0 with (cardinal empty); auto with set. - apply cardinal_2 with x; auto with set. - Qed. - - #[global] - Hint Resolve singleton_cardinal: set. - - Lemma diff_inter_cardinal : - forall s s', cardinal (diff s s') + cardinal (inter s s') = cardinal s . - Proof. - intros; do 3 rewrite cardinal_fold. - rewrite <- fold_plus. - apply fold_diff_inter with (eqA:=@Logic.eq nat); auto with fset. - Qed. - - Lemma union_cardinal: - forall s s', (forall x, ~(In x s/\In x s')) -> - cardinal (union s s')=cardinal s+cardinal s'. - Proof. - intros; do 3 rewrite cardinal_fold. - rewrite <- fold_plus. - apply fold_union; auto with fset. - Qed. - - Lemma subset_cardinal : - forall s s', s[<=]s' -> cardinal s <= cardinal s' . - Proof. - intros. - rewrite <- (diff_inter_cardinal s' s). - rewrite (inter_sym s' s). - rewrite (inter_subset_equal H). - apply Nat.le_add_l. - Qed. - - Lemma subset_cardinal_lt : - forall s s' x, s[<=]s' -> In x s' -> ~In x s -> cardinal s < cardinal s'. - Proof. - intros. - rewrite <- (diff_inter_cardinal s' s). - rewrite (inter_sym s' s). - rewrite (inter_subset_equal H). - generalize (@cardinal_inv_1 (diff s' s)). - destruct (cardinal (diff s' s)). - - intro H2; destruct (H2 Logic.eq_refl x). - set_iff; auto. - - intros _. - change (0 + cardinal s < S n + cardinal s). - apply Nat.add_lt_le_mono; [ apply Nat.lt_0_succ | reflexivity ]. - Qed. - - Theorem union_inter_cardinal : - forall s s', cardinal (union s s') + cardinal (inter s s') = cardinal s + cardinal s' . - Proof. - intros. - do 4 rewrite cardinal_fold. - do 2 rewrite <- fold_plus. - apply fold_union_inter with (eqA:=@Logic.eq nat); auto with fset. - Qed. - - Lemma union_cardinal_inter : - forall s s', cardinal (union s s') = cardinal s + cardinal s' - cardinal (inter s s'). - Proof. - intros. - rewrite <- union_inter_cardinal, Nat.add_sub. - reflexivity. - Qed. - - Lemma union_cardinal_le : - forall s s', cardinal (union s s') <= cardinal s + cardinal s'. - Proof. - intros; generalize (union_inter_cardinal s s'). - intros; rewrite <- H; auto with arith. - Qed. - - Lemma add_cardinal_1 : - forall s x, In x s -> cardinal (add x s) = cardinal s. - Proof. - auto with set fset. - Qed. - - Lemma add_cardinal_2 : - forall s x, ~In x s -> cardinal (add x s) = S (cardinal s). - Proof. - intros. - do 2 rewrite cardinal_fold. - change S with ((fun _ => S) x); - apply fold_add with (eqA:=@Logic.eq nat); auto with fset. - Qed. - - Lemma remove_cardinal_1 : - forall s x, In x s -> S (cardinal (remove x s)) = cardinal s. - Proof. - intros. - do 2 rewrite cardinal_fold. - change S with ((fun _ =>S) x). - apply remove_fold_1 with (eqA:=@Logic.eq nat); auto with fset. - Qed. - - Lemma remove_cardinal_2 : - forall s x, ~In x s -> cardinal (remove x s) = cardinal s. - Proof. - auto with set fset. - Qed. - - #[global] - Hint Resolve subset_cardinal union_cardinal add_cardinal_1 add_cardinal_2 : fset. - -End WProperties_fun. - -(** Now comes variants for self-contained weak sets and for full sets. - For these variants, only one argument is necessary. Thanks to - the subtyping [WS<=S], the [Properties] functor which is meant to be - used on modules [(M:S)] can simply be an alias of [WProperties]. *) - -Module WProperties (M:WS) := WProperties_fun M.E M. -Module Properties := WProperties. - - -(** Now comes some properties specific to the element ordering, - invalid for Weak Sets. *) - -Module OrdProperties (M:S). - Module ME:=OrderedTypeFacts(M.E). - Module Import P := Properties M. - Import FM. - Import M.E. - Import M. - - (** First, a specialized version of SortA_equivlistA_eqlistA: *) - 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; auto with typeclass_instances. - Qed. - - Definition gtb x y := match E.compare x y with GT _ => true | _ => false end. - Definition leb x := fun y => negb (gtb x y). - - Definition elements_lt x s := List.filter (gtb x) (elements s). - Definition elements_ge x s := List.filter (leb x) (elements s). - - Lemma gtb_1 : forall x y, gtb x y = true <-> E.lt y x. - Proof. - intros; unfold gtb; destruct (E.compare x y); intuition; try discriminate; ME.order. - Qed. - - Lemma leb_1 : forall x y, leb x y = true <-> ~E.lt y x. - Proof. - intros; unfold leb, gtb; destruct (E.compare x y); intuition try discriminate; ME.order. - Qed. - - Lemma gtb_compat : forall x, Proper (E.eq==>Logic.eq) (gtb x). - Proof. - red; intros x a b H. - generalize (gtb_1 x a)(gtb_1 x b); destruct (gtb x a); destruct (gtb x b); auto. - - intros. - symmetry; rewrite H1. - apply ME.eq_lt with a; auto with ordered_type. - rewrite <- H0; auto. - - intros. - rewrite H0. - apply ME.eq_lt with b; auto. - rewrite <- H1; auto. - Qed. - - Lemma leb_compat : forall x, Proper (E.eq==>Logic.eq) (leb x). - Proof. - red; intros x a b H; unfold leb. - f_equal; apply gtb_compat; auto. - Qed. - #[global] - Hint Resolve gtb_compat leb_compat : fset. - - Lemma elements_split : forall x 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). 1-2: auto with typeclass_instances. 2: auto with set. - intros. - rewrite gtb_1 in H. - assert (~E.lt y x). { - unfold gtb in *; destruct (E.compare x y); intuition try discriminate; ME.order. - } - ME.order. - Qed. - - Lemma elements_Add : forall s s' x, ~In x s -> Add x s s' -> - eqlistA E.eq (elements s') (elements_lt x s ++ x :: elements_ge x s). - Proof. - intros; unfold elements_ge, elements_lt. - apply sort_equivlistA_eqlistA; auto with set. - - 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). 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 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 by auto with fset. destruct H1. - rewrite gtb_1 in H3. - inversion_clear H2. - * ME.order. - * 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 fset. - intuition auto with relations set. - destruct (E.compare a x); intuition auto with set. - fold (~E.lt a x); auto with ordered_type set. - Qed. - - Definition Above x s := forall y, In y s -> E.lt y x. - Definition Below x s := forall y, In y s -> E.lt x y. - - Lemma elements_Add_Above : forall s s' x, - Above x s -> Add x s s' -> - eqlistA E.eq (elements s') (elements s ++ x::nil). - Proof. - intros. - 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. - do 2 rewrite <- elements_iff; rewrite (H0 a); intuition auto with relations. - Qed. - - Lemma elements_Add_Below : forall s s' x, - Below x s -> Add x s s' -> - eqlistA E.eq (elements s') (x::elements s). - Proof. - intros. - apply sort_equivlistA_eqlistA. - - auto with set. - - change (sort E.lt ((x::nil) ++ elements s)). - apply (@SortA_app _ E.eq). - + auto with typeclass_instances. - + auto. - + auto with set. - + intros. - inversion_clear H1. - * rewrite <- elements_iff in H2. - apply ME.eq_lt with x; auto. - * inversion H3. - - red; intros a. - rewrite InA_cons. - do 2 rewrite <- elements_iff; rewrite (H0 a); intuition auto with relations. - Qed. - - (** Two other induction principles on sets: we can be more restrictive - on the element we add at each step. *) - - Lemma set_induction_max : - forall P : t -> Type, - (forall s : t, Empty s -> P s) -> - (forall s s', P s -> forall x, Above x s -> Add x s s' -> P s') -> - forall s : t, P s. - Proof. - intros; remember (cardinal s) as n; revert s Heqn; induction n; intros; auto with fset. - case_eq (max_elt s); intros. - - apply X0 with (remove e s) e; auto with set. - + apply IHn. - assert (S n = S (cardinal (remove e s))). - { rewrite Heqn; apply cardinal_2 with e; auto with set ordered_type. } - inversion H0; auto. - + red; intros. - rewrite remove_iff in H0; destruct H0. - generalize (@max_elt_2 s e y H H0); ME.order. - - - assert (H0:=max_elt_3 H). - rewrite cardinal_Empty in H0; rewrite H0 in Heqn; inversion Heqn. - Qed. - - Lemma set_induction_min : - forall P : t -> Type, - (forall s : t, Empty s -> P s) -> - (forall s s', P s -> forall x, Below x s -> Add x s s' -> P s') -> - forall s : t, P s. - Proof. - intros; remember (cardinal s) as n; revert s Heqn; induction n; intros; auto with fset. - case_eq (min_elt s); intros. - - apply X0 with (remove e s) e; auto with set. - + apply IHn. - assert (S n = S (cardinal (remove e s))). - { rewrite Heqn; apply cardinal_2 with e; auto with set ordered_type. } - inversion H0; auto. - + red; intros. - rewrite remove_iff in H0; destruct H0. - generalize (@min_elt_2 s e y H H0); ME.order. - - - assert (H0:=min_elt_3 H). - rewrite cardinal_Empty in H0; auto; rewrite H0 in Heqn; inversion Heqn. - Qed. - - (** More properties of [fold] : behavior with respect to Above/Below *) - - Lemma fold_3 : - forall s s' x (A : Type) (eqA : A -> A -> Prop) - (st : Equivalence eqA) (i : A) (f : elt -> A -> A), - compat_op E.eq eqA f -> - Above x s -> Add x s s' -> eqA (fold f s' i) (f x (fold f s i)). - Proof. - intros. - rewrite 2 fold_spec_right. - change (f x (fold_right f i (rev (elements s)))) with - (fold_right f i (rev (x::nil)++rev (elements s))). - apply (@fold_right_eqlistA E.t E.eq A eqA st); auto. - rewrite <- distr_rev. - apply eqlistA_rev. - apply elements_Add_Above; auto. - Qed. - - Lemma fold_4 : - forall s s' x (A : Type) (eqA : A -> A -> Prop) - (st : Equivalence eqA) (i : A) (f : elt -> A -> A), - compat_op E.eq eqA f -> - Below x s -> Add x s s' -> eqA (fold f s' i) (fold f s (f x i)). - Proof. - intros. - rewrite 2 M.fold_1. - set (g:=fun (a : A) (e : elt) => f e a). - change (eqA (fold_left g (elements s') i) (fold_left g (x::elements s) i)). - unfold g. - rewrite <- 2 fold_left_rev_right. - apply (@fold_right_eqlistA E.t E.eq A eqA st); auto. - apply eqlistA_rev. - apply elements_Add_Below; auto. - Qed. - - (** The following results have already been proved earlier, - but we can now prove them with one hypothesis less: - no need for [(transpose eqA f)]. *) - - Section FoldOpt. - Variables (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA). - Variables (f:elt->A->A)(Comp:compat_op E.eq eqA f). - - Lemma fold_equal : - forall i s s', s[=]s' -> eqA (fold f s i) (fold f s' i). - Proof. - intros. rewrite 2 fold_spec_right. - apply (@fold_right_eqlistA E.t E.eq A eqA st); auto. - apply eqlistA_rev. - apply sort_equivlistA_eqlistA; auto with set. - red; intro a; do 2 rewrite <- elements_iff; auto. - Qed. - - Lemma add_fold : forall i s x, In x s -> - eqA (fold f (add x s) i) (fold f s i). - Proof. - intros; apply fold_equal; auto with set. - Qed. - - Lemma remove_fold_2: forall i s x, ~In x s -> - eqA (fold f (remove x s) i) (fold f s i). - Proof. - intros. - apply fold_equal; auto with set. - Qed. - - End FoldOpt. - - (** An alternative version of [choose_3] *) - - Lemma choose_equal : forall s s', Equal s s' -> - match choose s, choose s' with - | Some x, Some x' => E.eq x x' - | None, None => True - | _, _ => False - end. - Proof. - intros s s' H; - generalize (@choose_1 s)(@choose_2 s) - (@choose_1 s')(@choose_2 s')(@choose_3 s s'); - destruct (choose s); destruct (choose s'); simpl; intuition. - - apply H5 with e; rewrite <-H; auto. - - apply H5 with e; rewrite H; auto. - Qed. - -End OrdProperties. diff --git a/stdlib/theories/FSets/FSetToFiniteSet.v b/stdlib/theories/FSets/FSetToFiniteSet.v deleted file mode 100644 index 972359b6b20c..000000000000 --- a/stdlib/theories/FSets/FSetToFiniteSet.v +++ /dev/null @@ -1,156 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* Ensemble M.elt := - fun s x => M.In x s. - - Notation " !! " := mkEns. - - Lemma In_In : forall s x, M.In x s <-> In _ (!!s) x. - Proof. - unfold In; compute; auto with extcore. - Qed. - - Lemma Subset_Included : forall s s', s[<=]s' <-> Included _ (!!s) (!!s'). - Proof. - unfold Subset, Included, In, mkEns; intuition. - Qed. - - Notation " a === b " := (Same_set M.elt a b) (at level 70, no associativity). - - Lemma Equal_Same_set : forall s s', s[=]s' <-> !!s === !!s'. - Proof. - intros. - rewrite double_inclusion. - unfold Subset, Included, Same_set, In, mkEns; intuition. - Qed. - - Lemma empty_Empty_Set : !!M.empty === Empty_set _. - Proof. - unfold Same_set, Included, mkEns, In. - split; intro; set_iff; inversion 1. - Qed. - - Lemma Empty_Empty_set : forall s, Empty s -> !!s === Empty_set _. - Proof. - unfold Same_set, Included, mkEns, In. - split; intros. - - destruct(H x H0). - - inversion H0. - Qed. - - Lemma singleton_Singleton : forall x, !!(M.singleton x) === Singleton _ x . - Proof. - unfold Same_set, Included, mkEns, In. - split; intro; set_iff; inversion 1; try constructor; auto. - Qed. - - Lemma union_Union : forall s s', !!(union s s') === Union _ (!!s) (!!s'). - Proof. - unfold Same_set, Included, mkEns, In. - split; intro; set_iff; inversion 1; [ constructor 1 | constructor 2 | | ]; auto. - Qed. - - Lemma inter_Intersection : forall s s', !!(inter s s') === Intersection _ (!!s) (!!s'). - Proof. - unfold Same_set, Included, mkEns, In. - split; intro; set_iff; inversion 1; try constructor; auto. - Qed. - - Lemma add_Add : forall x s, !!(add x s) === Add _ (!!s) x. - Proof. - unfold Same_set, Included, mkEns, In. - split; intro; set_iff; inversion 1; auto with sets. - - inversion H0. - constructor 2; constructor. - - constructor 1; auto. - Qed. - - Lemma Add_Add : forall x s s', MP.Add x s s' -> !!s' === Add _ (!!s) x. - Proof. - unfold Same_set, Included, mkEns, In. - split; intros. - - red in H; rewrite H in H0. - destruct H0. - + inversion H0. - constructor 2; constructor. - + constructor 1; auto. - - red in H; rewrite H. - inversion H0; auto. - inversion H1; auto. - Qed. - - Lemma remove_Subtract : forall x s, !!(remove x s) === Subtract _ (!!s) x. - Proof. - unfold Same_set, Included, mkEns, In. - split; intro; set_iff; inversion 1; auto with sets. - split; auto. - contradict H1. - inversion H1; auto. - Qed. - - Lemma mkEns_Finite : forall s, Finite _ (!!s). - Proof. - intro s; pattern s; apply set_induction; clear s; intros. - - intros; replace (!!s) with (Empty_set elt); auto with sets. - symmetry; apply Extensionality_Ensembles. - apply Empty_Empty_set; auto. - - replace (!!s') with (Add _ (!!s) x). - + constructor 2; auto. - + symmetry; apply Extensionality_Ensembles. - apply Add_Add; auto. - Qed. - - Lemma mkEns_cardinal : forall s, cardinal _ (!!s) (M.cardinal s). - Proof. - intro s; pattern s; apply set_induction; clear s; intros. - - intros; replace (!!s) with (Empty_set elt); auto with sets. - + rewrite cardinal_1; auto with sets. - + symmetry; apply Extensionality_Ensembles. - apply Empty_Empty_set; auto. - - replace (!!s') with (Add _ (!!s) x). - + rewrite (cardinal_2 H0 H1); auto with sets. - + symmetry; apply Extensionality_Ensembles. - apply Add_Add; auto. - Qed. - - (** we can even build a function from Finite Ensemble to FSet - ... at least in Prop. *) - - Lemma Ens_to_FSet : forall e : Ensemble M.elt, Finite _ e -> - exists s:M.t, !!s === e. - Proof. - induction 1. - - exists M.empty. - apply empty_Empty_Set. - - destruct IHFinite as (s,Hs). - exists (M.add x s). - apply Extensionality_Ensembles in Hs. - rewrite <- Hs. - apply add_Add. - Qed. - -End WS_to_Finite_set. - - -Module S_to_Finite_set (U:UsualOrderedType)(M: Sfun U) := - WS_to_Finite_set U M. diff --git a/stdlib/theories/FSets/FSetWeakList.v b/stdlib/theories/FSets/FSetWeakList.v deleted file mode 100644 index e0c8dc61f3ca..000000000000 --- a/stdlib/theories/FSets/FSetWeakList.v +++ /dev/null @@ -1,30 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* z = 0%Z). - { - intro z. - unfold Zdigits2. - now destruct z. - } - - assert (Hshr_p0 : forall p0, (prec < Z.pos p0)%Z -> shr_m (iter_pos shr_1 p0 {| shr_m := Z.pos m; shr_r := false; shr_s := false |}) = Z0). - { - intros p0 Hp0. - apply Hd0. - rewrite Hshr. - rewrite Z.max_l; [ reflexivity | ]. - unfold shr_m. - unfold Zdigits2. - lia. - } - - assert (Hshr_p0_r : forall p0, (prec < Z.pos p0)%Z -> shr_r (iter_pos shr_1 p0 {| shr_m := Z.pos m; shr_r := false; shr_s := false |}) = false). - { - intros p0 Hp0. - - assert (Hshr_p0m1 : shr_m (iter_pos shr_1 (p0-1) {| shr_m := Z.pos m; shr_r := false; shr_s := false |}) = Z0). - { - apply Hd0. - rewrite Hshr. - rewrite Z.max_l; [ reflexivity | ]. - unfold shr_m. - unfold Zdigits2. - lia. - } - - assert (Hiter_pos : forall A (f : A -> A) p e, iter_pos f (p + 1) e = f (iter_pos f p e)). - { - assert (Hiter_pos' : forall A (f : A -> A) p e, iter_pos f p (f e) = f (iter_pos f p e)). - { - intros A f'. - induction p. - - intro e'. - simpl. - now do 2 rewrite IHp. - - intro e'. - simpl. - now do 2 rewrite IHp. - - intro e'. - now simpl. - } - intros A f'. - induction p. - - intros. - simpl. - rewrite <- Pos.add_1_r. - do 2 rewrite IHp. - now do 3 rewrite Hiter_pos'. - - intros. - simpl. - now do 2 rewrite Hiter_pos'. - - intros. - now simpl. - } - replace p0 with (p0 - 1 + 1)%positive. - - rewrite Hiter_pos. - unfold shr_1 at 1. - remember (iter_pos _ _ _) as shr_p0m1. - destruct shr_p0m1. - unfold SpecFloat.shr_m in Hshr_p0m1. - now rewrite Hshr_p0m1. - - rewrite Pos.add_1_r. - rewrite Pos.sub_1_r. - apply Pos.succ_pred. - lia. - } - - rewrite Z.leb_le in H2. - - destruct (Z.max_spec (Z.pos (digits2_pos m) + (e0 + (emin - emax - 1)) - prec) emin) as [ (H, Hm) | (H, Hm) ]. - + rewrite Hm. - replace (_ - _)%Z with (emax - e0 + 1)%Z by ring. - remember (emax - e0 + 1)%Z as z'. - destruct z'; [ exfalso; lia | | exfalso; lia ]. - unfold binary_round_aux. - unfold shr_fexp, fexp. - unfold shr, shr_record_of_loc. - unfold Zdigits2. - rewrite Hm. - replace (_ - _)%Z with (Z.pos p) by (rewrite Heqz'; ring). - set (rne := round_nearest_even _ _). - assert (rne = 0%Z). - { - unfold rne. - unfold round_nearest_even. - - assert (Hp0 : (prec < Z.pos p)%Z) by lia. - - unfold loc_of_shr_record. - specialize (Hshr_p0_r _ Hp0). - specialize (Hshr_p0 _ Hp0). - revert Hshr_p0_r Hshr_p0. - set (shr_p0 := iter_pos shr_1 _ _). - destruct shr_p0. - unfold SpecFloat.shr_r, SpecFloat.shr_m. - intros Hshr_r Hshr_m. - rewrite Hshr_r, Hshr_m. - now destruct shr_s. - } - - rewrite H0. - rewrite Z.max_r by (rewrite Heqz'; unfold prec; lia). - replace (_ - _)%Z with 0%Z by lia. - unfold shr_m. - - rewrite Z.max_r by lia. - remember (emin - (e0 + e))%Z as eminmze. - destruct eminmze; [ exfalso; lia | | exfalso; lia ]. - - rewrite Z.max_r by lia. - rewrite <- Heqeminmze. - - set (rne' := round_nearest_even _ _). - assert (Hrne'0 : rne' = 0%Z). - { - unfold rne'. - unfold round_nearest_even. - - assert (Hp1 : (prec < Z.pos p0)%Z) by lia. - - unfold loc_of_shr_record. - specialize (Hshr_p0_r _ Hp1). - specialize (Hshr_p0 _ Hp1). - revert Hshr_p0_r Hshr_p0. - set (shr_p1 := iter_pos shr_1 _ _). - destruct shr_p1. - unfold SpecFloat.shr_r, SpecFloat.shr_m. - intros Hshr_r Hshr_m. - rewrite Hshr_r, Hshr_m. - now destruct shr_s. - } - - rewrite Hrne'0. - rewrite Z.max_r by (rewrite Heqeminmze; unfold prec; lia). - replace (_ - _)%Z with 0%Z by lia. - reflexivity. - + exfalso; lia. -Qed. diff --git a/stdlib/theories/Floats/FloatOps.v b/stdlib/theories/Floats/FloatOps.v deleted file mode 100644 index 06a8d4b1c2fa..000000000000 --- a/stdlib/theories/Floats/FloatOps.v +++ /dev/null @@ -1 +0,0 @@ -From Corelib Require Export FloatOps. diff --git a/stdlib/theories/Floats/Floats.v b/stdlib/theories/Floats/Floats.v deleted file mode 100644 index f7ce3228db55..000000000000 --- a/stdlib/theories/Floats/Floats.v +++ /dev/null @@ -1,31 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* default - | x :: _ => x - end. - - Definition hd_error (l:list A) := - match l with - | [] => None - | x :: _ => Some x - end. - - Definition tl (l:list A) := - match l with - | [] => [] - | _ :: l' => l' - end. - - (** The [In] predicate *) - Fixpoint In (a:A) (l:list A) : Prop := - match l with - | [] => False - | b :: l' => b = a \/ In a l' - end. - -End Lists. - -Section Facts. - - Variable A : Type. - - (** *** Generic facts *) - - (** Discrimination *) - Theorem nil_cons (x:A) (l:list A) : [] <> x :: l. - Proof. - discriminate. - Qed. - - - (** Destruction *) - - Theorem destruct_list (l : list A) : {x:A & {tl:list A | l = x::tl}}+{l = []}. - Proof. - induction l as [|a tail]. - - right; reflexivity. - - left; exists a, tail; reflexivity. - Qed. - - Lemma hd_error_tl_repr l (a:A) r : - hd_error l = Some a /\ tl l = r <-> l = a :: r. - Proof. - destruct l as [|x xs]; [easy|cbn;split]. - - now intros [[= ->] ->]. - - now intros [= -> ->]. - Qed. - - Lemma hd_error_some_nil l (a:A) : hd_error l = Some a -> l <> []. - Proof. unfold hd_error. destruct l; now discriminate. Qed. - - Theorem length_zero_iff_nil (l : list A): - length l = 0 <-> l = []. - Proof. - split; [now destruct l | now intros ->]. - Qed. - - (** *** Head and tail *) - - Theorem hd_error_nil : hd_error (@nil A) = None. - Proof. - reflexivity. - Qed. - - Theorem hd_error_cons (l : list A) (x : A) : hd_error (x::l) = Some x. - Proof. - reflexivity. - Qed. - - - (**************************) - (** *** Facts about [app] *) - (**************************) - - (** Discrimination *) - Theorem app_cons_not_nil (x y:list A) (a:A) : [] <> x ++ a :: y. - Proof. - now destruct x. - Qed. - - - (** Concat with [nil] *) - Theorem app_nil_l (l:list A) : [] ++ l = l. - Proof. - reflexivity. - Qed. - - Theorem app_nil_r (l:list A) : l ++ [] = l. - Proof. - induction l; simpl; f_equal; auto. - Qed. - - (* begin hide *) - (* Deprecated since 8.3 but attribute added in 8.18 *) - Theorem app_nil_end_deprecated (l:list A) : l = l ++ []. - Proof. symmetry; apply app_nil_r. Qed. - (* end hide *) - - (** [app] is associative *) - Theorem app_assoc (l m n:list A) : l ++ m ++ n = (l ++ m) ++ n. - Proof. - induction l; simpl; f_equal; auto. - Qed. - - (* begin hide *) - (* Deprecated since 8.3 but attribute added in 8.18 *) - Theorem app_assoc_reverse_deprecated (l m n:list A) : (l ++ m) ++ n = l ++ m ++ n. - Proof. symmetry; apply app_assoc. Qed. - (* end hide *) - - (** [app] commutes with [cons] *) - Theorem app_comm_cons (x y:list A) (a:A) : a :: (x ++ y) = (a :: x) ++ y. - Proof. - reflexivity. - Qed. - - (** Facts deduced from the result of a concatenation *) - - Theorem app_eq_nil (l l':list A) : l ++ l' = [] -> l = [] /\ l' = []. - Proof. - now destruct l, l'. - Qed. - - Lemma app_eq_cons x y z (a : A): - x ++ y = a :: z -> (x = [] /\ y = a :: z) \/ exists x', x = a :: x' /\ z = x' ++ y. - Proof. - intro H. destruct x as [|b x]. - - now left. - - right. injection H as ->. now exists x. - Qed. - - Theorem app_eq_unit (x y:list A) (a:A) : - x ++ y = [a] -> x = [] /\ y = [a] \/ x = [a] /\ y = []. - Proof. - destruct x; cbn. - - intros ->. now left. - - intros [= -> [-> ->] %app_eq_nil]. now right. - Qed. - - Lemma elt_eq_unit l1 l2 (a b : A) : - l1 ++ a :: l2 = [b] -> a = b /\ l1 = [] /\ l2 = []. - Proof. - intros Heq. - apply app_eq_unit in Heq. - now destruct Heq as [[Heq1 Heq2]|[Heq1 Heq2]]; inversion_clear Heq2. - Qed. - - Theorem app_eq_app X (x1 x2 y1 y2: list X) : x1++x2 = y1++y2 -> - exists l, (x1 = y1++l /\ y2 = l++x2) \/ (y1 = x1++l /\ x2 = l++y2). - Proof. - revert y1. induction x1 as [|a x1 IH]. - - cbn. intros y1 ->. exists y1. now right. - - intros [|b y1]; cbn. - + intros <-. exists (a :: x1). now left. - + intros [=-> [l Hl] %IH]. exists l. - now destruct Hl as [[-> ->]|[-> ->]]; [left|right]. - Qed. - - Lemma app_inj_tail : - forall (x y:list A) (a b:A), x ++ [a] = y ++ [b] -> x = y /\ a = b. - Proof. - intros x y a b [l [[-> Hl %eq_sym]|[-> Hl %eq_sym]]] %app_eq_app; - apply elt_eq_unit in Hl as [? [-> ?]]; now rewrite app_nil_r. - Qed. - - Lemma app_inj_tail_iff : - forall (x y:list A) (a b:A), x ++ [a] = y ++ [b] <-> x = y /\ a = b. - Proof. - intros. now split; [apply app_inj_tail|intros [-> ->]]. - Qed. - - (** Compatibility with other operations *) - - Lemma length_nil : length (@nil A) = 0. - Proof. - reflexivity. - Qed. - - Lemma length_cons : forall (l : list A) a, length (a :: l) = S (length l). - Proof. - reflexivity. - Qed. - - Lemma length_app : forall l l' : list A, length (l++l') = length l + length l'. - Proof. - intro l; induction l; simpl; auto. - Qed. - - Lemma last_length : forall (l : list A) a, length (l ++ [a]) = S (length l). - Proof. - intros ; rewrite length_app ; simpl. - rewrite Nat.add_succ_r, Nat.add_0_r; reflexivity. - Qed. - - Lemma app_inv_head_iff: - forall l l1 l2 : list A, l ++ l1 = l ++ l2 <-> l1 = l2. - Proof. - intro l; induction l as [|? l IHl]; split; intros H; simpl; auto. - - apply IHl. inversion H. auto. - - subst. auto. - Qed. - - Lemma app_inv_head: - forall l l1 l2 : list A, l ++ l1 = l ++ l2 -> l1 = l2. - Proof. - apply app_inv_head_iff. - Qed. - - Lemma app_inv_tail: - forall l l1 l2 : list A, l1 ++ l = l2 ++ l -> l1 = l2. - Proof. - intros l. induction l as [|a l IHl]. - - intros ? ?. now rewrite !app_nil_r. - - intros ? ?. change (a :: l) with ([a] ++ l). - rewrite !app_assoc. now intros [? ?] %IHl %app_inj_tail_iff. - Qed. - - Lemma app_inv_tail_iff: - forall l l1 l2 : list A, l1 ++ l = l2 ++ l <-> l1 = l2. - Proof. - split; [apply app_inv_tail | now intros ->]. - Qed. - - (************************) - (** *** Facts about [In] *) - (************************) - - - (** Characterization of [In] *) - - Theorem in_eq : forall (a:A) (l:list A), In a (a :: l). - Proof. - simpl; auto. - Qed. - - Theorem in_cons : forall (a b:A) (l:list A), In b l -> In b (a :: l). - Proof. - simpl; auto. - Qed. - - Theorem not_in_cons (x a : A) (l : list A): - ~ In x (a::l) <-> x<>a /\ ~ In x l. - Proof. - simpl. intuition. - Qed. - - Theorem in_nil : forall a:A, ~ In a []. - Proof. - unfold not; intros a H; inversion_clear H. - Qed. - - Lemma in_app_or : forall (l m:list A) (a:A), In a (l ++ m) -> In a l \/ In a m. - Proof. - intros l m a. induction l; cbn; tauto. - Qed. - - Lemma in_or_app : forall (l m:list A) (a:A), In a l \/ In a m -> In a (l ++ m). - Proof. - intros l m a. induction l; cbn; tauto. - Qed. - - Lemma in_app_iff : forall l l' (a:A), In a (l++l') <-> In a l \/ In a l'. - Proof. - split; auto using in_app_or, in_or_app. - Qed. - - Theorem in_split : forall x (l:list A), In x l -> exists l1 l2, l = l1++x::l2. - Proof. - intros x l; induction l as [|a l IHl]; simpl; [destruct 1|destruct 1 as [?|H]]. - - subst a; auto. - exists [], l; auto. - - destruct (IHl H) as (l1,(l2,H0)). - exists (a::l1), l2; simpl. apply f_equal. auto. - Qed. - - Lemma in_elt : forall (x:A) l1 l2, In x (l1 ++ x :: l2). - Proof. - intros. - apply in_or_app. - right; left; reflexivity. - Qed. - - Lemma in_elt_inv : forall (x y : A) l1 l2, - In x (l1 ++ y :: l2) -> x = y \/ In x (l1 ++ l2). - Proof. - intros x y l1 l2 Hin. - apply in_app_or in Hin. - destruct Hin as [Hin|[Hin|Hin]]; [right|left|right]; try apply in_or_app; intuition. - Qed. - - Lemma app_inj_pivot x1 x2 y1 y2 (a : A): x1 ++ a :: x2 = y1 ++ a :: y2 -> - ((In a x1 /\ In a y2) \/ (In a x2 /\ In a y1)) \/ (x1 = y1 /\ x2 = y2). - Proof. - induction y1 as [|b y1 IHy] in x1 |- *; intros [[-> H]|[x' [-> H]]]%app_eq_cons. - - right. now injection H. - - subst y2. - left; left. split; [apply in_eq | apply in_elt]. - - injection H as -> ->. - left; right. split; [ apply in_elt | apply in_eq ]. - - symmetry in H. apply IHy in H as [[[]|[]]|[]]. - + left; left. split; [apply in_cons|]; assumption. - + left; right. split; [|apply in_cons]; assumption. - + right. split; congruence. - Qed. - - (** Inversion *) - Lemma in_inv : forall (a b:A) (l:list A), In b (a :: l) -> a = b \/ In b l. - Proof. easy. Qed. - - (** Decidability of [In] *) - Theorem in_dec : - (forall x y:A, {x = y} + {x <> y}) -> - forall (a:A) (l:list A), {In a l} + {~ In a l}. - Proof. - intros H a l; induction l as [| a0 l IHl]. - - right; apply in_nil. - - destruct (H a0 a); simpl; auto. - destruct IHl; simpl; auto. - right; unfold not; intros [Hc1| Hc2]; auto. - Defined. - - Lemma length_tl l : length (@tl A l) = length l - 1. - Proof. case l; cbn [length tl Nat.sub]; auto using Nat.sub_0_r. Qed. -End Facts. - -#[global] -Hint Resolve app_assoc app_assoc_reverse_deprecated: datatypes. -#[global] -Hint Resolve app_comm_cons app_cons_not_nil: datatypes. -#[global] -Hint Immediate app_eq_nil: datatypes. -#[global] -Hint Resolve app_eq_unit app_inj_tail: datatypes. -#[global] -Hint Resolve in_eq in_cons in_inv in_nil in_app_or in_or_app: datatypes. - -(* XXX declare datatypes db and move to top of file *) -Local Ltac Tauto.intuition_solver ::= auto with datatypes. - - - -(*******************************************) -(** * Operations on the elements of a list *) -(*******************************************) - -Section Elts. - - Variable A : Type. - - (*****************************) - (** ** Nth element of a list *) - (*****************************) - - Local Notation nth := (@nth A). - - Fixpoint nth_ok (n:nat) (l:list A) (default:A) {struct l} : bool := - match n, l with - | O, x :: l' => true - | O, [] => false - | S m, [] => false - | S m, x :: l' => nth_ok m l' default - end. - - Lemma nth_in_or_default : - forall (n:nat) (l:list A) (d:A), {In (nth n l d) l} + {nth n l d = d}. - Proof. - intros n l d; revert n; induction l as [|? ? IHl]. - - intro n; right; destruct n; trivial. - - intros [|n]; simpl. - * left; auto. - * destruct (IHl n); auto. - Qed. - - Lemma nth_S_cons : - forall (n:nat) (l:list A) (d a:A), - In (nth n l d) l -> In (nth (S n) (a :: l) d) (a :: l). - Proof. - simpl; auto. - Qed. - - Fixpoint nth_error (l:list A) (n:nat) {struct n} : option A := - match n, l with - | O, x :: _ => Some x - | S n, _ :: l' => nth_error l' n - | _, _ => None - end. - - Definition nth_default (default:A) (l:list A) (n:nat) : A := - match nth_error l n with - | Some x => x - | None => default - end. - - Lemma nth_default_eq : - forall n l (d:A), nth_default d l n = nth n l d. - Proof. - unfold nth_default; intro n; induction n; intros [ | ] ?; simpl; auto. - Qed. - - (** Results about [nth] *) - - Lemma nth_In : - forall (n:nat) (l:list A) (d:A), n < length l -> In (nth n l d) l. - Proof. - unfold lt; intro n; induction n as [| n hn]; simpl; intro l. - - destruct l; simpl; [ inversion 2 | auto ]. - - destruct l; simpl. - * inversion 2. - * intros d ie; right; apply hn. now apply Nat.succ_le_mono. - Qed. - - Lemma In_nth l x d : In x l -> - exists n, n < length l /\ nth n l d = x. - Proof. - induction l as [|a l IH]. - - easy. - - intros [H|H]. - * subst; exists 0; simpl; auto using Nat.lt_0_succ. - * destruct (IH H) as (n & Hn & Hn'). - apply Nat.succ_lt_mono in Hn. now exists (S n). - Qed. - - Lemma nth_overflow : forall l n d, length l <= n -> nth n l d = d. - Proof. - intro l; induction l as [|? ? IHl]; intro n; destruct n; - simpl; intros d H; auto. - - inversion H. - - apply IHl. now apply Nat.succ_le_mono. - Qed. - - Lemma nth_indep : - forall l n d d', n < length l -> nth n l d = nth n l d'. - Proof. - intro l; induction l as [|? ? IHl]. - - inversion 1. - - intros [|n] d d'; [intros; reflexivity|]. - intros H. apply IHl. now apply Nat.succ_lt_mono. - Qed. - - Lemma app_nth1 : - forall l l' d n, n < length l -> nth n (l++l') d = nth n l d. - Proof. - intro l; induction l as [|? ? IHl]. - - inversion 1. - - intros l' d [|n]; simpl; [intros; reflexivity|]. - intros H. apply IHl. now apply Nat.succ_lt_mono. - Qed. - - Lemma app_nth2 : - forall l l' d n, n >= length l -> nth n (l++l') d = nth (n-length l) l' d. - Proof. - intro l; induction l as [|? ? IHl]; intros l' d [|n]; auto. - - inversion 1. - - intros; simpl; rewrite IHl; [reflexivity|now apply Nat.succ_le_mono]. - Qed. - - Lemma app_nth2_plus : forall l l' d n, - nth (length l + n) (l ++ l') d = nth n l' d. - Proof. - intros. - now rewrite app_nth2, Nat.add_comm, Nat.add_sub; [|apply Nat.le_add_r]. - Qed. - - Lemma nth_middle : forall l l' a d, - nth (length l) (l ++ a :: l') d = a. - Proof. - intros. - rewrite <- Nat.add_0_r at 1. - apply app_nth2_plus. - Qed. - - Lemma nth_split n l d : n < length l -> - exists l1, exists l2, l = l1 ++ nth n l d :: l2 /\ length l1 = n. - Proof. - revert l. - induction n as [|n IH]; intros [|a l] H; try easy. - - exists nil; exists l; now simpl. - - destruct (IH l) as (l1 & l2 & Hl & Hl1); [now apply Nat.succ_lt_mono|]. - exists (a::l1); exists l2; simpl; split; now f_equal. - Qed. - - Lemma nth_ext : forall l l' d d', length l = length l' -> - (forall n, n < length l -> nth n l d = nth n l' d') -> l = l'. - Proof. - intro l; induction l as [|a l IHl]; - intros l' d d' Hlen Hnth; destruct l' as [| b l']. - - reflexivity. - - inversion Hlen. - - inversion Hlen. - - change a with (nth 0 (a :: l) d). - change b with (nth 0 (b :: l') d'). - rewrite Hnth; f_equal. - + apply IHl with d d'; [ now inversion Hlen | ]. - intros n Hlen'; apply (Hnth (S n)). - now apply (Nat.succ_lt_mono n (length l)). - + simpl; apply Nat.lt_0_succ. - Qed. - - (** Results about [nth_error] *) - - Lemma nth_error_In l n x : nth_error l n = Some x -> In x l. - Proof. - revert n. induction l as [|a l IH]; intros [|n]; simpl; try easy. - - injection 1; auto. - - eauto. - Qed. - - Lemma In_nth_error l x : In x l -> exists n, nth_error l n = Some x. - Proof. - induction l as [|a l IH]. - - easy. - - intros [H|[n ?] %IH]. - + subst; now exists 0. - + now exists (S n). - Qed. - - Lemma In_iff_nth_error l x : In x l <-> exists n, nth_error l n = Some x. - Proof. firstorder eauto using In_nth_error, nth_error_In. Qed. - - Lemma nth_error_None l n : nth_error l n = None <-> length l <= n. - Proof. - revert n. induction l as [|? ? IHl]; intro n; destruct n; simpl. - - split; auto. - - now split; intros; [apply Nat.le_0_l|]. - - now split; [|intros ? %Nat.nle_succ_0]. - - now rewrite IHl, Nat.succ_le_mono. - Qed. - - Lemma nth_error_Some l n : nth_error l n <> None <-> n < length l. - Proof. - revert n. induction l as [|? ? IHl]; intro n; destruct n; simpl. - - split; [now destruct 1 | inversion 1]. - - split; [now destruct 1 | inversion 1]. - - now split; intros; [apply Nat.lt_0_succ|]. - - now rewrite IHl, Nat.succ_lt_mono. - Qed. - - Lemma nth_error_split l n a : nth_error l n = Some a -> - exists l1, exists l2, l = l1 ++ a :: l2 /\ length l1 = n. - Proof. - revert l. - induction n as [|n IH]; intros [|x l] H; [easy| |easy|]. - - exists nil; exists l. now injection H as [= ->]. - - destruct (IH _ H) as (l1 & l2 & H1 & H2). - exists (x::l1); exists l2; simpl; split; now f_equal. - Qed. - - Lemma nth_error_app1 l l' n : n < length l -> - nth_error (l++l') n = nth_error l n. - Proof. - revert l. - induction n as [|n IHn]; intros [|a l] H; [easy ..|]. - cbn. now apply IHn, Nat.succ_le_mono. - Qed. - - Lemma nth_error_app2 l l' n : length l <= n -> - nth_error (l++l') n = nth_error l' (n-length l). - Proof. - revert l. - induction n as [|n IHn]; intros [|a l] H; [easy ..|]. - cbn. now apply IHn, Nat.succ_le_mono. - Qed. - - Lemma nth_error_app l l' n : nth_error (l ++ l') n = - if Nat.ltb n (length l) - then nth_error l n - else nth_error l' (n - length l). - Proof. - case (Nat.ltb_spec n (length l)) as []. - - rewrite nth_error_app1; trivial. - - rewrite nth_error_app2; trivial. - Qed. - - Lemma nth_error_ext l l': - (forall n, nth_error l n = nth_error l' n) -> l = l'. - Proof. - revert l'. induction l as [|a l IHl]; - intros l' Hnth; destruct l'. - - reflexivity. - - discriminate (Hnth 0). - - discriminate (Hnth 0). - - injection (Hnth 0) as ->. f_equal. apply IHl. - intro n. exact (Hnth (S n)). - Qed. - - Lemma unfold_nth_error l n - : nth_error l n - = match n, l with - | O, x :: _ => Some x - | S n, _ :: l' => nth_error l' n - | _, _ => None - end. - Proof. destruct n; reflexivity. Qed. - - Lemma nth_error_nil n : nth_error [] n = None. - Proof. destruct n; reflexivity. Qed. - - Lemma nth_error_cons x xs n - : nth_error (x :: xs) n - = match n with - | O => Some x - | S n => nth_error xs n - end. - Proof. apply unfold_nth_error. Qed. - - Lemma nth_error_0 l - : nth_error l O = hd_error l. - Proof. destruct l; reflexivity. Qed. - - Lemma nth_error_S l n - : nth_error l (S n) = nth_error (tl l) n. - Proof. destruct l; rewrite ?nth_error_nil; reflexivity. Qed. - - Lemma nth_error_cons_0 x l : nth_error (cons x l) 0 = Some x. - Proof. trivial. Qed. - - Lemma nth_error_cons_succ x l n : - nth_error (cons x l) (S n) = nth_error l n. - Proof. trivial. Qed. - - (** Results directly relating [nth] and [nth_error] *) - - Lemma nth_error_nth : forall (l : list A) (n : nat) (x d : A), - nth_error l n = Some x -> nth n l d = x. - Proof. - intros l n x d H. - apply nth_error_split in H. destruct H as [l1 [l2 [H H']]]. - subst. rewrite app_nth2; [|auto]. - rewrite Nat.sub_diag. reflexivity. - Qed. - - Lemma nth_error_nth' : forall (l : list A) (n : nat) (d : A), - n < length l -> nth_error l n = Some (nth n l d). - Proof. - intros l n d H. - apply (nth_split _ d) in H. destruct H as [l1 [l2 [H H']]]. - subst. rewrite H. rewrite nth_error_app2; [|auto]. - rewrite app_nth2; [| auto]. repeat (rewrite Nat.sub_diag). reflexivity. - Qed. - - Lemma nth_error_nth_None (l : list A) (n : nat) (d : A) : - nth_error l n = None -> nth n l d = d. - Proof. - intros H%nth_error_None. apply nth_overflow. assumption. - Qed. - - (******************************) - (** ** Last element of a list *) - (******************************) - - (** [last l d] returns the last element of the list [l], - or the default value [d] if [l] is empty. *) - - Fixpoint last (l:list A) (d:A) : A := - match l with - | [] => d - | [a] => a - | a :: l' => last l' d - end. - - Lemma last_last : forall l a d, last (l ++ [a]) d = a. - Proof. - intro l; induction l as [|? l IHl]; intros; [ reflexivity | ]. - simpl; rewrite IHl. - destruct l; reflexivity. - Qed. - - (** [removelast l] remove the last element of [l] *) - - Fixpoint removelast (l:list A) : list A := - match l with - | [] => [] - | [a] => [] - | a :: l' => a :: removelast l' - end. - - Lemma app_removelast_last : - forall l d, l <> [] -> l = removelast l ++ [last l d]. - Proof. - intro l; induction l as [|? l IHl]. - - destruct 1; auto. - - intros d _. - destruct l as [|a0 l]; auto. - pattern (a0::l) at 1; rewrite IHl with d; auto; discriminate. - Qed. - - Lemma exists_last : - forall l, l <> [] -> { l' : (list A) & { a : A | l = l' ++ [a]}}. - Proof. - intro l; induction l as [|a l IHl]. - - destruct 1; auto. - - intros _. - destruct l. - + exists [], a; auto. - + destruct IHl as [l' (a',H)]; try discriminate. - rewrite H. - exists (a::l'), a'; auto. - Qed. - - Lemma removelast_app : - forall l l', l' <> [] -> removelast (l++l') = l ++ removelast l'. - Proof. - intro l; induction l as [|? l IHl]; [easy|]. - intros l' H. cbn. rewrite <- IHl by assumption. - now destruct l, l'. - Qed. - - Lemma removelast_last : forall l a, removelast (l ++ [a]) = l. - Proof. - intros. rewrite removelast_app. - - apply app_nil_r. - - intros Heq; inversion Heq. - Qed. - - - (*****************) - (** ** Remove *) - (*****************) - - Hypothesis eq_dec : forall x y : A, {x = y}+{x <> y}. - - Fixpoint remove (x : A) (l : list A) : list A := - match l with - | [] => [] - | y::tl => if (eq_dec x y) then remove x tl else y :: remove x tl - end. - - Lemma remove_cons : forall x l, remove x (x :: l) = remove x l. - Proof. - intros x l; simpl; destruct (eq_dec x x); [ reflexivity | now exfalso ]. - Qed. - - Lemma remove_app : forall x l1 l2, - remove x (l1 ++ l2) = remove x l1 ++ remove x l2. - Proof. - intros x l1; induction l1 as [|a l1 IHl1]; intros l2; simpl. - - reflexivity. - - destruct (eq_dec x a). - + apply IHl1. - + rewrite <- app_comm_cons; f_equal. - apply IHl1. - Qed. - - Theorem remove_In : forall (l : list A) (x : A), ~ In x (remove x l). - Proof. - intro l; induction l as [|x l IHl]; auto. - intro y; simpl; destruct (eq_dec y x) as [yeqx | yneqx]. - - apply IHl. - - unfold not; intro HF; simpl in HF; destruct HF; auto. - apply (IHl y); assumption. - Qed. - - Lemma notin_remove: forall l x, ~ In x l -> remove x l = l. - Proof. - intros l x; induction l as [|y l IHl]; simpl; intros Hnin. - - reflexivity. - - destruct (eq_dec x y); [subst|f_equal]; tauto. - Qed. - - Lemma in_remove: forall l x y, In x (remove y l) -> In x l /\ x <> y. - Proof. - intro l; induction l as [|z l IHl]; intros x y Hin. - - inversion Hin. - - simpl in Hin. - destruct (eq_dec y z) as [Heq|Hneq]; subst; split. - + right; now apply IHl with z. - + intros Heq; revert Hin; subst; apply remove_In. - + inversion Hin; subst; [left; reflexivity|right]. - now apply IHl with y. - + destruct Hin as [Hin|Hin]; subst. - * now intros Heq; apply Hneq. - * intros Heq; revert Hin; subst; apply remove_In. - Qed. - - Lemma in_in_remove : forall l x y, x <> y -> In x l -> In x (remove y l). - Proof. - intro l; induction l as [|z l IHl]; simpl; intros x y Hneq Hin. - - apply Hin. - - destruct (eq_dec y z); subst. - + destruct Hin. - * exfalso; now apply Hneq. - * now apply IHl. - + simpl; destruct Hin; [now left|right]. - now apply IHl. - Qed. - - Lemma remove_remove_comm : forall l x y, - remove x (remove y l) = remove y (remove x l). - Proof. - intro l; induction l as [| z l IHl]; simpl; intros x y. - - reflexivity. - - destruct (eq_dec y z); simpl; destruct (eq_dec x z); try rewrite IHl; auto. - + subst; symmetry; apply remove_cons. - + simpl; destruct (eq_dec y z); tauto. - Qed. - - Lemma remove_remove_eq : forall l x, remove x (remove x l) = remove x l. - Proof. intros l x; now rewrite (notin_remove _ _ (remove_In l x)). Qed. - - Lemma remove_length_le : forall l x, length (remove x l) <= length l. - Proof. - intro l; induction l as [|y l IHl]; simpl; intros x; trivial. - destruct (eq_dec x y); simpl. - - rewrite IHl; constructor; reflexivity. - - apply (proj1 (Nat.succ_le_mono _ _) (IHl x)). - Qed. - - Lemma remove_length_lt : forall l x, In x l -> length (remove x l) < length l. - Proof. - intro l; induction l as [|y l IHl]; simpl; intros x Hin. - - contradiction Hin. - - destruct Hin as [-> | Hin]. - + destruct (eq_dec x x); [|easy]. - apply Nat.lt_succ_r, remove_length_le. - + specialize (IHl _ Hin); destruct (eq_dec x y); simpl; auto. - now apply Nat.succ_lt_mono in IHl. - Qed. - - - (******************************************) - (** ** Counting occurrences of an element *) - (******************************************) - - Fixpoint count_occ (l : list A) (x : A) : nat := - match l with - | [] => 0 - | y :: tl => - let n := count_occ tl x in - if eq_dec y x then S n else n - end. - - (** Compatibility of count_occ with operations on list *) - Theorem count_occ_In l x : In x l <-> count_occ l x > 0. - Proof. - induction l as [|y l IHl]; simpl. - - split; [destruct 1 | apply Nat.nlt_0_r]. - - destruct eq_dec as [->|Hneq]; rewrite IHl; intuition (apply Nat.lt_0_succ). - Qed. - - Theorem count_occ_not_In l x : ~ In x l <-> count_occ l x = 0. - Proof. - rewrite count_occ_In. unfold gt. now rewrite Nat.nlt_ge, Nat.le_0_r. - Qed. - - Lemma count_occ_nil x : count_occ [] x = 0. - Proof. - reflexivity. - Qed. - - Theorem count_occ_inv_nil l : - (forall x:A, count_occ l x = 0) <-> l = []. - Proof. - split. - - induction l as [|x l]; trivial. - intros H. specialize (H x). simpl in H. - destruct eq_dec as [_|NEQ]; [discriminate|now elim NEQ]. - - now intros ->. - Qed. - - Lemma count_occ_cons_eq l x y : - x = y -> count_occ (x::l) y = S (count_occ l y). - Proof. - intros H. simpl. now destruct (eq_dec x y). - Qed. - - Lemma count_occ_cons_neq l x y : - x <> y -> count_occ (x::l) y = count_occ l y. - Proof. - intros H. simpl. now destruct (eq_dec x y). - Qed. - - Lemma count_occ_app l1 l2 x : - count_occ (l1 ++ l2) x = count_occ l1 x + count_occ l2 x. - Proof. - induction l1 as [ | h l1 IHl1]; cbn; trivial. - now destruct (eq_dec h x); [ rewrite IHl1 | ]. - Qed. - - Lemma count_occ_elt_eq l1 l2 x y : x = y -> - count_occ (l1 ++ x :: l2) y = S (count_occ (l1 ++ l2) y). - Proof. - intros ->. - rewrite ? count_occ_app; cbn. - destruct (eq_dec y y) as [Heq | Hneq]; - [ apply Nat.add_succ_r | now contradiction Hneq ]. - Qed. - - Lemma count_occ_elt_neq l1 l2 x y : x <> y -> - count_occ (l1 ++ x :: l2) y = count_occ (l1 ++ l2) y. - Proof. - intros Hxy. - rewrite ? count_occ_app; cbn. - now destruct (eq_dec x y) as [Heq | Hneq]; [ contradiction Hxy | ]. - Qed. - - Lemma count_occ_bound x l : count_occ l x <= length l. - Proof. - induction l as [|h l]; cbn; auto. - destruct (eq_dec h x); [ apply (proj1 (Nat.succ_le_mono _ _)) | ]; intuition. - Qed. - -End Elts. -Notation nth := nth. - -(*******************************) -(** * Manipulating whole lists *) -(*******************************) - -Section ListOps. - - Variable A : Type. - - (*************************) - (** ** Reverse *) - (*************************) - - Fixpoint rev (l:list A) : list A := - match l with - | [] => [] - | x :: l' => rev l' ++ [x] - end. - - Lemma rev_app_distr : forall x y:list A, rev (x ++ y) = rev y ++ rev x. - Proof. - intros x y; induction x as [| a l IHl]; cbn. - - now rewrite app_nil_r. - - now rewrite IHl, app_assoc. - Qed. - - Remark rev_unit : forall (l:list A) (a:A), rev (l ++ [a]) = a :: rev l. - Proof. - intros l a. apply rev_app_distr. - Qed. - - Lemma rev_involutive : forall l:list A, rev (rev l) = l. - Proof. - intro l; induction l as [| a l IHl]. - - reflexivity. - - cbn. now rewrite rev_unit, IHl. - Qed. - - Lemma rev_inj (l1 l2: list A): - rev l1 = rev l2 -> l1 = l2. - Proof. - intro H. apply (f_equal rev) in H. - rewrite !rev_involutive in H. assumption. - Qed. - - Lemma rev_eq_app : forall l l1 l2, rev l = l1 ++ l2 -> l = rev l2 ++ rev l1. - Proof. - intros l l1 l2 Heq. - rewrite <- (rev_involutive l), Heq. - apply rev_app_distr. - Qed. - - (*********************************************) - (** Reverse Induction Principle on Lists *) - (*********************************************) - - Lemma rev_list_ind : forall P:list A-> Prop, - P [] -> - (forall (a:A) (l:list A), P (rev l) -> P (rev (a :: l))) -> - forall l:list A, P (rev l). - Proof. - intros P ? ? l; induction l; auto. - Qed. - - Theorem rev_ind : forall P:list A -> Prop, - P [] -> - (forall (x:A) (l:list A), P l -> P (l ++ [x])) -> forall l:list A, P l. - Proof. - intros P ? ? l. rewrite <- (rev_involutive l). - apply (rev_list_ind P); cbn; auto. - Qed. - - (** Compatibility with other operations *) - - Lemma in_rev : forall l x, In x l <-> In x (rev l). - Proof. - intro l; induction l as [|? ? IHl]; [easy|]. - intros. cbn. rewrite in_app_iff, IHl. cbn. tauto. - Qed. - - Lemma length_rev : forall l, length (rev l) = length l. - Proof. - intro l; induction l as [|? l IHl];simpl; auto. - now rewrite length_app, IHl, Nat.add_comm. - Qed. - - Lemma rev_nth : forall l d n, n < length l -> - nth n (rev l) d = nth (length l - S n) l d. - Proof. - intros l d; induction l as [|a l IHl] using rev_ind; [easy|]. - rewrite rev_app_distr, length_app, Nat.add_comm. cbn. intros [|n]. - - now rewrite Nat.sub_0_r, nth_middle. - - intros Hn %Nat.succ_lt_mono. - rewrite (IHl _ Hn), app_nth1; [reflexivity|]. - apply Nat.sub_lt; [assumption|apply Nat.lt_0_succ]. - Qed. - - Lemma nth_error_rev n l : nth_error (rev l) n = - if Nat.ltb n (length l) then nth_error l (length l - S n) else None. - Proof. - case (Nat.ltb_spec n (length l)) as []; cycle 1. - { apply nth_error_None; rewrite ?length_rev; trivial. } - destruct l as [|x l']; [inversion H|]; set (x::l') as l in *. - rewrite 2 nth_error_nth' with (d:=x), rev_nth; - rewrite ?length_rev; auto using Nat.lt_0_succ, Nat.sub_lt. - Qed. - - - (** An alternative tail-recursive definition for reverse *) - - Fixpoint rev_append (l l': list A) : list A := - match l with - | [] => l' - | a :: l => rev_append l (a::l') - end. - - Definition rev' l : list A := rev_append l []. - - Lemma rev_append_rev : forall l l', rev_append l l' = rev l ++ l'. - Proof. - intro l; induction l; simpl; auto; intros. - rewrite <- app_assoc; firstorder. - Qed. - - Lemma rev_alt : forall l, rev l = rev_append l []. - Proof. - intros; rewrite rev_append_rev. - rewrite app_nil_r; trivial. - Qed. - - (*************************) - (** ** Concatenation *) - (*************************) - - Fixpoint concat (l : list (list A)) : list A := - match l with - | [] => [] - | x :: l => x ++ concat l - end. - - Lemma concat_nil : concat [] = []. - Proof. - reflexivity. - Qed. - - Lemma concat_cons : forall x l, concat (cons x l) = x ++ concat l. - Proof. - reflexivity. - Qed. - - Lemma concat_app : forall l1 l2, concat (l1 ++ l2) = concat l1 ++ concat l2. - Proof. - intros l1; induction l1 as [|x l1 IH]; intros l2; simpl. - - reflexivity. - - rewrite IH; apply app_assoc. - Qed. - - Lemma in_concat : forall l y, - In y (concat l) <-> exists x, In x l /\ In y x. - Proof. - intro l; induction l as [|a l IHl]; simpl; intro y; split; intros H. - - contradiction. - - destruct H as (x,(H,_)); contradiction. - - destruct (in_app_or _ _ _ H) as [H0|H0]. - + exists a; auto. - + destruct (IHl y) as (H1,_); destruct (H1 H0) as (x,(H2,H3)). - exists x; auto. - - apply in_or_app. - destruct H as (x,(H0,H1)); destruct H0. - + subst; auto. - + right; destruct (IHl y) as (_,H2); apply H2. - exists x; auto. - Qed. - - - (***********************************) - (** ** Decidable equality on lists *) - (***********************************) - - Hypothesis eq_dec : forall (x y : A), {x = y}+{x <> y}. - - Lemma list_eq_dec : forall l l':list A, {l = l'} + {l <> l'}. - Proof. decide equality. Defined. - - Lemma count_occ_rev l x : count_occ eq_dec (rev l) x = count_occ eq_dec l x. - Proof. - induction l as [|a l IHl]; trivial. - cbn; rewrite count_occ_app, IHl; cbn. - destruct (eq_dec a x); rewrite Nat.add_comm; reflexivity. - Qed. - -End ListOps. - -(***************************************************) -(** * Applying functions to the elements of a list *) -(***************************************************) - -(************) -(** ** Map *) -(************) - -Section Map. - Variables (A : Type) (B : Type). - Variable f : A -> B. - - Local Notation map := (@map A B f). - - Lemma map_cons (x:A)(l:list A) : map (x::l) = (f x) :: (map l). - Proof. - reflexivity. - Qed. - - Lemma in_map : - forall (l:list A) (x:A), In x l -> In (f x) (map l). - Proof. - intro l; induction l; firstorder (subst; auto). - Qed. - - Lemma in_map_iff : forall l y, In y (map l) <-> exists x, f x = y /\ In x l. - Proof. - intro l; induction l; firstorder (subst; auto). - Qed. - - Lemma length_map : forall l, length (map l) = length l. - Proof. - intro l; induction l; simpl; auto. - Qed. - - Lemma map_nth : forall l d n, - nth n (map l) (f d) = f (nth n l d). - Proof. - intro l; induction l; simpl map; intros d n; destruct n; firstorder. - Qed. - - Lemma nth_error_map : forall n l, - nth_error (map l) n = option_map f (nth_error l n). - Proof. - intro n. induction n as [|n IHn]; intro l. - - now destruct l. - - destruct l as [|? l]; [reflexivity|exact (IHn l)]. - Qed. - - Lemma map_nth_error : forall n l d, - nth_error l n = Some d -> nth_error (map l) n = Some (f d). - Proof. - intros n l d H. now rewrite nth_error_map, H. - Qed. - - Lemma tl_map l : tl (map l) = map (tl l). - Proof. case l; trivial. Qed. - - Lemma map_app : forall l l', - map (l++l') = (map l)++(map l'). - Proof. - intro l; induction l as [|a l IHl]; simpl; auto. - intros; rewrite IHl; auto. - Qed. - - Lemma map_last : forall l a, - map (l ++ [a]) = (map l) ++ [f a]. - Proof. - intro l; induction l as [|a l IHl]; intros; [ reflexivity | ]. - simpl; rewrite IHl; reflexivity. - Qed. - - Lemma map_rev : forall l, map (rev l) = rev (map l). - Proof. - intro l; induction l as [|a l IHl]; simpl; auto. - rewrite map_app. - rewrite IHl; auto. - Qed. - - Lemma map_eq_nil : forall l, map l = [] -> l = []. - Proof. - intro l; destruct l; simpl; reflexivity || discriminate. - Qed. - - Lemma map_eq_cons : forall l l' b, - map l = b :: l' -> exists a tl, l = a :: tl /\ f a = b /\ map tl = l'. - Proof. - intros l l' b Heq. - destruct l as [|a l]; inversion_clear Heq. - exists a, l; repeat split. - Qed. - - Lemma map_eq_app : forall l l1 l2, - map l = l1 ++ l2 -> exists l1' l2', l = l1' ++ l2' /\ map l1' = l1 /\ map l2' = l2. - Proof. - intro l; induction l as [|a l IHl]; simpl; intros l1 l2 Heq. - - symmetry in Heq; apply app_eq_nil in Heq; destruct Heq; subst. - exists nil, nil; repeat split. - - destruct l1; simpl in Heq; inversion Heq as [[Heq2 Htl]]. - + exists nil, (a :: l); repeat split. - + destruct (IHl _ _ Htl) as (l1' & l2' & ? & ? & ?); subst. - exists (a :: l1'), l2'; repeat split. - Qed. - - (** [map] and count of occurrences *) - - Hypothesis decA: forall x1 x2 : A, {x1 = x2} + {x1 <> x2}. - Hypothesis decB: forall y1 y2 : B, {y1 = y2} + {y1 <> y2}. - Hypothesis Hfinjective: forall x1 x2: A, (f x1) = (f x2) -> x1 = x2. - - Theorem count_occ_map x l: - count_occ decA l x = count_occ decB (map l) (f x). - Proof. - revert x. induction l as [| a l' Hrec]; intro x; simpl. - - reflexivity. - - specialize (Hrec x). - destruct (decA a x) as [H1|H1], (decB (f a) (f x)) as [H2|H2]. - + rewrite Hrec. reflexivity. - + contradiction H2. rewrite H1. reflexivity. - + specialize (Hfinjective H2). contradiction H1. - + assumption. - Qed. - -End Map. -Notation map := map. - -(*****************) -(** ** Flat Map *) -(*****************) - -Section FlatMap. - Variables (A : Type) (B : Type). - Variable f : A -> list B. - - (** [flat_map] *) - - Fixpoint flat_map (l:list A) : list B := - match l with - | [] => [] - | x :: l => f x ++ flat_map l - end. - - Lemma flat_map_concat_map l : - flat_map l = concat (map f l). - Proof. - induction l as [|x l IH]; simpl. - - reflexivity. - - rewrite IH; reflexivity. - Qed. - - Lemma flat_map_app l1 l2 : - flat_map (l1 ++ l2) = flat_map l1 ++ flat_map l2. - Proof. - now rewrite !flat_map_concat_map, map_app, concat_app. - Qed. - - Lemma in_flat_map l y : - In y (flat_map l) <-> exists x, In x l /\ In y (f x). - Proof. - rewrite flat_map_concat_map, in_concat. - split. - - intros [l' [[x [<- ?]] %in_map_iff ?]]. - now exists x. - - intros [x [? ?]]. exists (f x). - now split; [apply in_map|]. - Qed. - -End FlatMap. - -Lemma concat_map : forall A B (f : A -> B) l, map f (concat l) = concat (map (map f) l). -Proof. - intros A B f l; induction l as [|x l IH]; simpl. - - reflexivity. - - rewrite map_app, IH; reflexivity. -Qed. - -Lemma remove_concat A (eq_dec : forall x y : A, {x = y}+{x <> y}) : forall l x, - remove eq_dec x (concat l) = flat_map (remove eq_dec x) l. -Proof. - intros l x; induction l as [|? ? IHl]; [ reflexivity | simpl ]. - rewrite remove_app, IHl; reflexivity. -Qed. - -Lemma map_id : forall (A :Type) (l : list A), - map (fun x => x) l = l. -Proof. - intros A l; induction l as [|? ? IHl]; simpl; auto; rewrite IHl; auto. -Qed. - -Lemma map_map : forall (A B C:Type)(f:A->B)(g:B->C) l, - map g (map f l) = map (fun x => g (f x)) l. -Proof. - intros A B C f g l; induction l as [|? ? IHl]; simpl; auto. - rewrite IHl; auto. -Qed. - -Lemma map_ext_in : - forall (A B : Type)(f g:A->B) l, (forall a, In a l -> f a = g a) -> map f l = map g l. -Proof. - intros A B f g l; induction l as [|? ? IHl]; simpl; auto. - intros H; rewrite H by intuition; rewrite IHl; auto. -Qed. - -Lemma ext_in_map : - forall (A B : Type)(f g:A->B) l, map f l = map g l -> forall a, In a l -> f a = g a. -Proof. intros A B f g l; induction l; intros [=] ? []; subst; auto. Qed. - -Arguments ext_in_map [A B f g l]. - -Lemma map_ext_in_iff : - forall (A B : Type)(f g:A->B) l, map f l = map g l <-> forall a, In a l -> f a = g a. -Proof. split; [apply ext_in_map | apply map_ext_in]. Qed. - -Arguments map_ext_in_iff {A B f g l}. - -Lemma map_ext : - forall (A B : Type)(f g:A->B), (forall a, f a = g a) -> forall l, map f l = map g l. -Proof. - intros; apply map_ext_in; auto. -Qed. - -Global Instance Proper_map {A B} : - Proper (pointwise_relation _ eq ==> eq ==> eq) (@map A B). -Proof. repeat intro; subst; auto using map_ext. Qed. - -Lemma flat_map_ext : forall (A B : Type)(f g : A -> list B), - (forall a, f a = g a) -> forall l, flat_map f l = flat_map g l. -Proof. - intros A B f g Hext l. - rewrite 2 flat_map_concat_map. - now rewrite (map_ext _ g). -Qed. - -Lemma nth_nth_nth_map A : forall (l : list A) n d ln dn, n < length ln \/ length l <= dn -> - nth (nth n ln dn) l d = nth n (map (fun x => nth x l d) ln) d. -Proof. - intros l n d ln dn Hlen. - rewrite <- (map_nth (fun m => nth m l d)). - destruct Hlen. - - apply nth_indep. now rewrite length_map. - - now rewrite (nth_overflow l). -Qed. - - -(************************************) -(** Left-to-right iterator on lists *) -(************************************) - -Section Fold_Left_Recursor. - Variables (A : Type) (B : Type). - Variable f : A -> B -> A. - - Fixpoint fold_left (l:list B) (a0:A) : A := - match l with - | [] => a0 - | b :: l => fold_left l (f a0 b) - end. - - Lemma fold_left_app : forall (l l':list B)(i:A), - fold_left (l++l') i = fold_left l' (fold_left l i). - Proof. - now intro l; induction l; cbn. - Qed. - -End Fold_Left_Recursor. - -Lemma fold_left_S_0 : - forall (A:Type)(l:list A), fold_left (fun x _ => S x) l 0 = length l. -Proof. - intros A l. induction l as [|? ? IH] using rev_ind; [reflexivity|]. - now rewrite fold_left_app, length_app, IH, Nat.add_comm. -Qed. - -(************************************) -(** Right-to-left iterator on lists *) -(************************************) - -Section Fold_Right_Recursor. - Variables (A : Type) (B : Type). - Variable f : B -> A -> A. - Variable a0 : A. - - Fixpoint fold_right (l:list B) : A := - match l with - | [] => a0 - | b :: l => f b (fold_right l) - end. - -End Fold_Right_Recursor. - - Lemma fold_right_app : forall (A B:Type)(f:A->B->B) l l' i, - fold_right f i (l++l') = fold_right f (fold_right f i l') l. - Proof. - intros A B f l; induction l. - - simpl; auto. - - simpl; intros. - f_equal; auto. - Qed. - - Lemma fold_left_rev_right : forall (A B:Type)(f:A->B->B) l i, - fold_right f i (rev l) = fold_left (fun x y => f y x) l i. - Proof. - intros A B f l; induction l. - - simpl; auto. - - intros. - simpl. - rewrite fold_right_app; simpl; auto. - Qed. - - Theorem fold_symmetric : - forall (A : Type) (f : A -> A -> A), - (forall x y z : A, f x (f y z) = f (f x y) z) -> - forall (a0 : A), (forall y : A, f a0 y = f y a0) -> - forall (l : list A), fold_left f l a0 = fold_right f a0 l. - Proof. - intros A f assoc a0 comma0 l. - induction l as [ | a1 l IHl]; [ simpl; reflexivity | ]. - simpl. rewrite <- IHl. clear IHl. revert a1. - induction l as [|? ? IHl]; [ auto | ]. - simpl. intro. rewrite <- assoc. rewrite IHl. rewrite IHl. auto. - Qed. - - (** [(list_power x y)] is [y^x], or the set of sequences of elts of [y] - indexed by elts of [x], sorted in lexicographic order. *) - - Fixpoint list_power (A B:Type)(l:list A) (l':list B) : - list (list (A * B)) := - match l with - | [] => [[]] - | x :: l => - flat_map (fun f:list (A * B) => map (fun y:B => (x, y) :: f) l') - (list_power l l') - end. - - - (*************************************) - (** ** Boolean operations over lists *) - (*************************************) - - Section Bool. - Variable A : Type. - Variable f : A -> bool. - - (** find whether a boolean function can be satisfied by an - elements of the list. *) - - Fixpoint existsb (l:list A) : bool := - match l with - | [] => false - | a :: l => f a || existsb l - end. - - Lemma existsb_exists : - forall l, existsb l = true <-> exists x, In x l /\ f x = true. - Proof. - intro l; induction l as [ | a m IH ]; split; simpl. - - easy. - - intros [x [[]]]. - - destruct (f a) eqn:Ha. - + intros _. exists a. tauto. - + intros [x [? ?]] %IH. exists x. tauto. - - 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 -> - existsb l = false -> f (nth n l d) = false. - Proof. - intro l; induction l as [|a ? IHl]; [easy|]. - cbn. intros [|n]; [now destruct (f a)|]. - intros d ? %Nat.succ_lt_mono. - now destruct (f a); [|apply IHl]. - Qed. - - Lemma existsb_app : forall l1 l2, - existsb (l1++l2) = existsb l1 || existsb l2. - Proof. - intro l1; induction l1 as [|a ? ?]; intros l2; simpl. - - auto. - - case (f a); simpl; solve[auto]. - Qed. - - (** find whether a boolean function is satisfied by - all the elements of a list. *) - - Fixpoint forallb (l:list A) : bool := - match l with - | [] => true - | a::l => f a && forallb l - end. - - Lemma forallb_forall : - forall l, forallb l = true <-> (forall x, In x l -> f x = true). - Proof. - intro l; induction l as [|a l IHl]; simpl; [ tauto | split; intro H ]. - + destruct (andb_prop _ _ H); intros a' [?|?]. - - congruence. - - apply IHl; assumption. - + apply andb_true_intro; split. - - apply H; left; reflexivity. - - apply IHl; intros; apply H; right; assumption. - Qed. - - Lemma forallb_app : - forall l1 l2, forallb (l1++l2) = forallb l1 && forallb l2. - Proof. - intro l1; induction l1 as [|a ? ?]; simpl. - - auto. - - case (f a); simpl; solve[auto]. - Qed. - - (** [filter] *) - - Fixpoint filter (l:list A) : list A := - match l with - | [] => [] - | x :: l => if f x then x::(filter l) else filter l - end. - - Lemma filter_In : forall x l, In x (filter l) <-> In x l /\ f x = true. - Proof. - intros x l; induction l as [|a ? ?]; simpl. - - tauto. - - intros. - case_eq (f a); intros; simpl; intuition congruence. - Qed. - - Lemma filter_app (l l':list A) : - filter (l ++ l') = filter l ++ filter l'. - Proof. - induction l as [|x l IH]; simpl; trivial. - destruct (f x); simpl; now rewrite IH. - Qed. - - Lemma concat_filter_map : forall (l : list (list A)), - concat (map filter l) = filter (concat l). - Proof. - intro l; induction l as [| v l IHl]; [auto|]. - simpl. rewrite IHl. rewrite filter_app. reflexivity. - Qed. - - Lemma forallb_filter l: forallb (filter l) = true. - Proof. - induction l as [|x l IH]; [reflexivity|]. - cbn. remember (f x) as y. destruct y. - - apply andb_true_intro. auto. - - exact IH. - Qed. - - Lemma forallb_filter_id l: forallb l = true -> filter l = l. - Proof. - induction l as [|x l IH]; [easy|]. - cbn. intro H. destruct (f x). - - f_equal. apply IH, H. - - discriminate H. - Qed. - - (** [find] *) - - Fixpoint find (l:list A) : option A := - match l with - | [] => None - | x :: tl => if f x then Some x else find tl - end. - - Lemma find_some l x : find l = Some x -> In x l /\ f x = true. - Proof. - induction l as [|a l IH]; simpl; [easy| ]. - case_eq (f a); intros Ha Eq. - * injection Eq as [= ->]; auto. - * destruct (IH Eq); auto. - Qed. - - Lemma find_none l : find l = None -> forall x, In x l -> f x = false. - Proof. - induction l as [|a l IH]; simpl; [easy|]. - case_eq (f a); intros Ha Eq x IN; [easy|]. - destruct IN as [<-|IN]; auto. - Qed. - - Lemma filter_rev (l : list A) : filter (rev l) = rev (filter l). - Proof. - induction l; cbn [rev]; trivial. - rewrite filter_app, IHl; cbn [filter]. - case f; cbn [app]; auto using app_nil_r. - Qed. - - (** [partition] *) - - Fixpoint partition (l:list A) : list A * list A := - match l with - | [] => ([], []) - | x :: tl => let (g,d) := partition tl in - if f x then (x::g,d) else (g,x::d) - end. - - Theorem partition_cons1 a l l1 l2: - partition l = (l1, l2) -> - f a = true -> - partition (a::l) = (a::l1, l2). - Proof. - simpl. now intros -> ->. - Qed. - - Theorem partition_cons2 a l l1 l2: - partition l = (l1, l2) -> - f a=false -> - partition (a::l) = (l1, a::l2). - Proof. - simpl. now intros -> ->. - Qed. - - Theorem partition_length l l1 l2: - partition l = (l1, l2) -> - length l = length l1 + length l2. - Proof. - revert l1 l2. induction l as [ | a l' Hrec]; intros l1 l2. - - now intros [= <- <- ]. - - simpl. destruct (f a), (partition l') as (left, right); - intros [= <- <- ]; simpl; rewrite (Hrec left right); auto. - Qed. - - Theorem partition_inv_nil (l : list A): - partition l = ([], []) <-> l = []. - Proof. - split. - - destruct l as [|a l']. - * intuition. - * simpl. destruct (f a), (partition l'); now intros [= -> ->]. - - now intros ->. - Qed. - - Theorem elements_in_partition l l1 l2: - partition l = (l1, l2) -> - forall x:A, In x l <-> In x l1 \/ In x l2. - Proof. - revert l1 l2. induction l as [| a l' Hrec]; simpl; intros l1 l2 Eq x. - - injection Eq as [= <- <-]. tauto. - - destruct (partition l') as (left, right). - specialize (Hrec left right eq_refl x). - destruct (f a); injection Eq as [= <- <-]; simpl; tauto. - Qed. - - End Bool. - - - (*******************************) - (** ** Further filtering facts *) - (*******************************) - - Section Filtering. - - Lemma filter_map_swap A B f g l : - filter f (@map A B g l) = @map A B g (filter (fun a => f (g a)) l). - Proof. induction l; cbn [map filter]; auto. rewrite IHl; case f; auto. Qed. - - Variables (A : Type). - - Lemma filter_true l : filter (fun _ : A => true) l = l. - Proof. induction l; cbn [filter]; congruence. Qed. - - Lemma filter_false l : filter (fun _ : A => false) l = nil. - Proof. induction l; cbn [filter]; congruence. Qed. - - Lemma filter_ext_in : forall (f g : A -> bool) (l : list A), - (forall a, In a l -> f a = g a) -> filter f l = filter g l. - Proof. - intros f g l. induction l as [| a l IHl]; [easy|cbn]. - intros H. rewrite (H a) by (now left). - destruct (g a); [f_equal|]; apply IHl; intros; apply H; now right. - Qed. - - Lemma ext_in_filter : forall (f g : A -> bool) (l : list A), - filter f l = filter g l -> (forall a, In a l -> f a = g a). - Proof. - intros f g l. induction l as [| a l IHl]; [easy|cbn]. - intros H. assert (Ha : f a = g a). - - pose proof (Hf := proj1 (filter_In f a l)). - pose proof (Hg := proj1 (filter_In g a l)). - destruct (f a), (g a); [reflexivity| | |reflexivity]. - + symmetry. apply Hg. rewrite <- H. now left. - + apply Hf. rewrite H. now left. - - intros b [<-|Hbl]; [assumption|]. - apply IHl; [|assumption]. - destruct (f a), (g a); congruence. - Qed. - - Lemma filter_ext_in_iff : forall (f g : A -> bool) (l : list A), - filter f l = filter g l <-> (forall a, In a l -> f a = g a). - Proof. - split; [apply ext_in_filter | apply filter_ext_in]. - Qed. - - Lemma filter_map : forall (f g : A -> bool) (l : list A), - filter f l = filter g l <-> map f l = map g l. - Proof. - intros f g l. now rewrite filter_ext_in_iff, map_ext_in_iff. - Qed. - - Lemma filter_ext : forall (f g : A -> bool), - (forall a, f a = g a) -> forall l, filter f l = filter g l. - Proof. - intros f g H l. rewrite filter_map. apply map_ext. assumption. - Qed. - - Lemma partition_as_filter f (l : list A) : partition f l = (filter f l, filter (fun x => negb (f x)) l). - Proof. - induction l as [|x l IH]. - - reflexivity. - - cbn. rewrite IH. destruct (f x); reflexivity. - Qed. - - Corollary filter_length f (l : list A) : length (filter f l) + length (filter (fun x => negb (f x)) l) = length l. - Proof. symmetry. apply (partition_length f), partition_as_filter. Qed. - - Corollary filter_length_le f (l : list A): length (filter f l) <= length l. - Proof. rewrite <- (filter_length f l). apply Nat.le_add_r. Qed. - - Lemma filter_length_forallb f (l : list A): length (filter f l) = length l -> forallb f l = true. - Proof. - intro H. induction l as [|x l IH]; [reflexivity |]. - cbn in *. destruct (f x). - - apply IH. now injection H. - - exfalso. assert (length l < length (filter f l)) as E. - + symmetry in H. apply Nat.eq_le_incl in H. exact H. - + eapply Nat.le_ngt; [apply filter_length_le | exact E]. - Qed. - - (** Remove by filtering *) - - Hypothesis eq_dec : forall x y : A, {x = y}+{x <> y}. - - Definition remove' (x : A) : list A -> list A := - filter (fun y => if eq_dec x y then false else true). - - Lemma remove_alt (x : A) (l : list A) : remove' x l = remove eq_dec x l. - Proof. - induction l; [reflexivity|]. - simpl. now destruct eq_dec; [|f_equal]. - Qed. - - (** Counting occurrences by filtering *) - - Definition count_occ' (l : list A) (x : A) : nat := - length (filter (fun y => if eq_dec y x then true else false) l). - - Lemma count_occ_alt (l : list A) (x : A) : - count_occ' l x = count_occ eq_dec l x. - Proof. - unfold count_occ'. induction l; [reflexivity|]. - simpl. now destruct eq_dec; simpl; [f_equal|]. - Qed. - - End Filtering. - - - (******************************************************) - (** ** Operations on lists of pairs or lists of lists *) - (******************************************************) - - Section ListPairs. - Variables (A : Type) (B : Type). - - (** [split] derives two lists from a list of pairs *) - - Fixpoint split (l:list (A*B)) : list A * list B := - match l with - | [] => ([], []) - | (x,y) :: tl => let (left,right) := split tl in (x::left, y::right) - end. - - Lemma in_split_l : forall (l:list (A*B))(p:A*B), - In p l -> In (fst p) (fst (split l)). - Proof. - intro l. induction l as [|[? ?] l IHl]; [easy|]. - intros [? ?]. cbn. - now intros [[=]|? %IHl]; destruct (split l); [left|right]. - Qed. - - Lemma in_split_r : forall (l:list (A*B))(p:A*B), - In p l -> In (snd p) (snd (split l)). - Proof. - intro l. induction l as [|[? ?] l IHl]; [easy|]. - intros [? ?]. cbn. - now intros [[=]|? %IHl]; destruct (split l); [left|right]. - Qed. - - Lemma split_nth : forall (l:list (A*B))(n:nat)(d:A*B), - nth n l d = (nth n (fst (split l)) (fst d), nth n (snd (split l)) (snd d)). - Proof. - intro l; induction l as [|a l IHl]. - - intros n d; destruct n; destruct d; simpl; auto. - - intros n d; destruct n; destruct d; simpl; auto. - + destruct a; destruct (split l); simpl; auto. - + destruct a; destruct (split l); simpl in *; auto. - Qed. - - Lemma length_fst_split : forall (l:list (A*B)), - length (fst (split l)) = length l. - Proof. - intro l; induction l as [|a l IHl]; simpl; auto. - destruct a; destruct (split l); simpl; auto. - Qed. - - Lemma length_snd_split : forall (l:list (A*B)), - length (snd (split l)) = length l. - Proof. - intro l; induction l as [|a l IHl]; simpl; auto. - destruct a; destruct (split l); simpl; auto. - Qed. - - (** [combine] is the opposite of [split]. - Lists given to [combine] are meant to be of same length. - If not, [combine] stops on the shorter list *) - - Fixpoint combine (l : list A) (l' : list B) : list (A*B) := - match l,l' with - | x::tl, y::tl' => (x,y)::(combine tl tl') - | _, _ => [] - end. - - Lemma split_combine : forall (l: list (A*B)), - forall l1 l2, split l = (l1, l2) -> combine l1 l2 = l. - Proof. - intro l; induction l as [|a l IHl]. - 1: simpl; auto. - all: intuition; inversion H; auto. - destruct (split l); simpl in *. - inversion H1; subst; simpl. - f_equal; auto. - Qed. - - Lemma combine_split : forall (l:list A)(l':list B), length l = length l' -> - split (combine l l') = (l,l'). - Proof. - intro l; induction l as [|a l IHl]; intro l'; destruct l'; - simpl; trivial; try discriminate. - now intros [= ->%IHl]. - Qed. - - Lemma in_combine_l : forall (l:list A)(l':list B)(x:A)(y:B), - In (x,y) (combine l l') -> In x l. - Proof. - intro l; induction l as [|a l IHl]. - - simpl; auto. - - intro l'; destruct l' as [|a0 l']; simpl; auto; intros x y H. - + contradiction. - + destruct H as [H|H]. - * injection H; auto. - * right; apply IHl with l' y; auto. - Qed. - - Lemma in_combine_r : forall (l:list A)(l':list B)(x:A)(y:B), - In (x,y) (combine l l') -> In y l'. - Proof. - intro l; induction l as [|? ? IHl]. - - simpl; intros; contradiction. - - intro l'; destruct l'; simpl; auto; intros x y H. - destruct H as [H|H]. - + injection H; auto. - + right; apply IHl with x; auto. - Qed. - - Lemma length_combine : forall (l:list A)(l':list B), - length (combine l l') = min (length l) (length l'). - Proof. - intro l; induction l. - - simpl; auto. - - intro l'; destruct l'; simpl; auto. - Qed. - - Lemma combine_nth : forall (l:list A)(l':list B)(n:nat)(x:A)(y:B), - length l = length l' -> - nth n (combine l l') (x,y) = (nth n l x, nth n l' y). - Proof. - intro l; induction l; intro l'; destruct l'; intros n x y; try discriminate. - - destruct n; simpl; auto. - - destruct n; simpl in *; auto. - Qed. - - (** [list_prod] has the same signature as [combine], but unlike - [combine], it adds every possible pairs, not only those at the - same position. *) - - Fixpoint list_prod (l:list A) (l':list B) : - list (A * B) := - match l with - | [] => [] - | x :: t => (map (fun y:B => (x, y)) l')++(list_prod t l') - end. - - Lemma in_prod_aux : - forall (x:A) (y:B) (l:list B), - In y l -> In (x, y) (map (fun y0:B => (x, y0)) l). - Proof. - intros x y l; induction l; - [ simpl; auto - | simpl; destruct 1 as [H1| ]; - [ left; rewrite H1; trivial | right; auto ] ]. - Qed. - - Lemma in_prod : - forall (l:list A) (l':list B) (x:A) (y:B), - In x l -> In y l' -> In (x, y) (list_prod l l'). - Proof. - intro l; induction l; - [ simpl; tauto - | simpl; intros l' x y H H0; apply in_or_app; destruct H as [H|H]; - [ left; rewrite H; apply in_prod_aux; assumption | right; auto ] ]. - Qed. - - Lemma in_prod_iff : - forall (l:list A)(l':list B)(x:A)(y:B), - In (x,y) (list_prod l l') <-> In x l /\ In y l'. - Proof. - intros l l' x y; split; [ | intros H; now apply in_prod ]. - induction l as [|a l IHl]; cbn; [easy|]. - intros [[? [[= -> ->] ?]] %in_map_iff|] %in_app_or; tauto. - Qed. - - Lemma length_prod : forall (l:list A)(l':list B), - length (list_prod l l') = (length l) * (length l'). - Proof. - intro l; induction l as [|? ? IHl]; simpl; [easy|]. - intros. now rewrite length_app, length_map, IHl. - Qed. - - Lemma list_prod_as_flat_map : forall l l', - list_prod l l' = flat_map (fun a => map (pair a) l') l. - Proof. induction l; intros; cbn; rewrite ?IHl; trivial. Qed. - End ListPairs. - - - - -(*****************************************) -(** * Miscellaneous operations on lists *) -(*****************************************) - - - -(******************************) -(** ** Length order of lists *) -(******************************) - -Section length_order. - Variable A : Type. - - Definition lel (l m:list A) := length l <= length m. - - Variables a b : A. - Variables l m n : list A. - - Lemma lel_refl : lel l l. - Proof. - now apply Nat.le_refl. - Qed. - - Lemma lel_trans : lel l m -> lel m n -> lel l n. - Proof. - unfold lel; intros. - now_show (length l <= length n). - now apply Nat.le_trans with (length m). - Qed. - - Lemma lel_cons_cons : lel l m -> lel (a :: l) (b :: m). - Proof. - now intros ? %Nat.succ_le_mono. - Qed. - - Lemma lel_cons : lel l m -> lel l (b :: m). - Proof. - intros. now apply Nat.le_le_succ_r. - Qed. - - Lemma lel_tail : lel (a :: l) (b :: m) -> lel l m. - Proof. - intros. now apply Nat.succ_le_mono. - Qed. - - Lemma lel_nil : forall l':list A, lel l' [] -> [] = l'. - Proof. - intro l'; elim l'; [now intros|]. - now intros a' y H H0 %Nat.nle_succ_0. - Qed. -End length_order. - -#[global] -Hint Resolve lel_refl lel_cons_cons lel_cons lel_nil lel_nil nil_cons: - datatypes. - - -(******************************) -(** ** Set inclusion on list *) -(******************************) - -Section SetIncl. - - Variable A : Type. - - Definition incl (l m:list A) := forall a:A, In a l -> In a m. - #[local] - Hint Unfold incl : core. - - Lemma incl_nil_l : forall l, incl [] l. - Proof. - intros l a Hin; inversion Hin. - Qed. - - Lemma incl_l_nil : forall l, incl l [] -> l = []. - Proof. - intro l; destruct l as [|a l]; intros Hincl. - - reflexivity. - - exfalso; apply Hincl with a; simpl; auto. - Qed. - - Lemma incl_refl : forall l:list A, incl l l. - Proof. - auto. - Qed. - #[local] - Hint Resolve incl_refl : core. - - Lemma incl_tl : forall (a:A) (l m:list A), incl l m -> incl l (a :: m). - Proof. - auto with datatypes. - Qed. - #[local] - Hint Immediate incl_tl : core. - - Lemma incl_tran : forall l m n:list A, incl l m -> incl m n -> incl l n. - Proof. - auto. - Qed. - - Lemma incl_appl : forall l m n:list A, incl l n -> incl l (n ++ m). - Proof. - auto with datatypes. - Qed. - #[local] - Hint Immediate incl_appl : core. - - Lemma incl_appr : forall l m n:list A, incl l n -> incl l (m ++ n). - Proof. - auto with datatypes. - Qed. - #[local] - Hint Immediate incl_appr : core. - - Lemma incl_cons : - forall (a:A) (l m:list A), In a m -> incl l m -> incl (a :: l) m. - Proof. - now intros a l m ? H b [<-|]; [|apply H]. - Qed. - #[local] - Hint Resolve incl_cons : core. - - Lemma incl_cons_inv : forall (a:A) (l m:list A), - incl (a :: l) m -> In a m /\ incl l m. - Proof. - intros a l m Hi. - split; [ | intros ? ? ]; apply Hi; simpl; auto. - Qed. - - Lemma incl_app : forall l m n:list A, incl l n -> incl m n -> incl (l ++ m) n. - Proof. - unfold incl; simpl; intros l m n H H0 a H1. - now_show (In a n). - elim (in_app_or _ _ _ H1); auto. - Qed. - #[local] - Hint Resolve incl_app : core. - - Lemma incl_app_app : forall l1 l2 m1 m2:list A, - incl l1 m1 -> incl l2 m2 -> incl (l1 ++ l2) (m1 ++ m2). - Proof. - intros. - apply incl_app; [ apply incl_appl | apply incl_appr]; assumption. - Qed. - - Lemma incl_app_inv : forall l1 l2 m : list A, - incl (l1 ++ l2) m -> incl l1 m /\ incl l2 m. - Proof. - intro l1; induction l1 as [|a l1 IHl1]; intros l2 m Hin; split; auto. - - apply incl_nil_l. - - intros b Hb; inversion_clear Hb; subst; apply Hin. - + now constructor. - + simpl; apply in_cons. - apply incl_appl with l1; [ apply incl_refl | assumption ]. - - apply IHl1. - now apply incl_cons_inv in Hin. - Qed. - - Lemma incl_filter f l : incl (filter f l) l. - Proof. intros x Hin; now apply filter_In in Hin. Qed. - - Lemma remove_incl (eq_dec : forall x y : A, {x = y} + {x <> y}) : forall l1 l2 x, - incl l1 l2 -> incl (remove eq_dec x l1) (remove eq_dec x l2). - Proof. - intros l1 l2 x Hincl y Hin. - apply in_remove in Hin; destruct Hin as [Hin Hneq]. - apply in_in_remove; intuition. - Qed. - -End SetIncl. - -Lemma incl_map A B (f : A -> B) l1 l2 : incl l1 l2 -> incl (map f l1) (map f l2). -Proof. - intros Hincl x Hinx. - destruct (proj1 (in_map_iff _ _ _) Hinx) as [y [<- Hiny]]. - now apply in_map, Hincl. -Qed. - -#[global] -Hint Resolve incl_refl incl_tl incl_tran incl_appl incl_appr incl_cons - incl_app incl_map: datatypes. - - -(**************************************) -(** * Cutting a list at some position *) -(**************************************) - -Section Cutting. - - Variable A : Type. - - Local Notation firstn := (@firstn A). - Local Notation skipn := (@skipn A). - - Lemma firstn_nil n: firstn n [] = []. - Proof. induction n; now simpl. Qed. - - Lemma firstn_cons n a l: firstn (S n) (a::l) = a :: (firstn n l). - Proof. now simpl. Qed. - - Lemma nth_error_firstn n l i - : nth_error (firstn n l) i = if Nat.ltb i n then nth_error l i else None. - Proof. - revert l i; induction n, l, i; cbn [firstn nth_error]; trivial. - case Nat.ltb; trivial. - Qed. - - Lemma nth_firstn (n : nat) (l : list A) (i : nat) (d : A) : - nth i (firstn n l) d = if i firstn n l = l. - Proof. induction n as [|k iHk]. - - intro l. inversion 1 as [H1|?]. - rewrite (length_zero_iff_nil l) in H1. subst. now simpl. - - intro l; destruct l as [|x xs]; simpl. - * now reflexivity. - * simpl. intro H. f_equal. apply iHk. now apply Nat.succ_le_mono. - Qed. - - Lemma firstn_0 l: firstn 0 l = []. - Proof. now simpl. Qed. - - Lemma firstn_le_length n: forall l:list A, length (firstn n l) <= n. - Proof. - induction n as [|k iHk]; simpl; [auto | intro l; destruct l as [|x xs]; simpl]. - - now apply Nat.le_0_l. - - now rewrite <- Nat.succ_le_mono. - Qed. - - Lemma firstn_length_le: forall l:list A, forall n:nat, - n <= length l -> length (firstn n l) = n. - Proof. intro l; induction l as [|x xs Hrec]. - - simpl. intros n H. apply Nat.le_0_r in H. now subst. - - intro n; destruct n as [|n]. - * now simpl. - * simpl. intro H. f_equal. apply Hrec. now apply Nat.succ_le_mono. - Qed. - - Lemma firstn_app n: - forall l1 l2, - firstn n (l1 ++ l2) = (firstn n l1) ++ (firstn (n - length l1) l2). - Proof. induction n as [|k iHk]; intros l1 l2. - - now simpl. - - destruct l1 as [|x xs]. - * reflexivity. - * rewrite <- app_comm_cons. simpl. f_equal. apply iHk. - Qed. - - Lemma firstn_app_2 n: - forall l1 l2, - firstn ((length l1) + n) (l1 ++ l2) = l1 ++ firstn n l2. - Proof. induction n as [| k iHk];intros l1 l2. - - unfold firstn at 2. rewrite Nat.add_0_r, app_nil_r. - rewrite firstn_app. rewrite Nat.sub_diag. - unfold firstn at 2. rewrite app_nil_r. apply firstn_all. - - destruct l2 as [|x xs]. - * simpl. rewrite app_nil_r. apply firstn_all2. now apply Nat.le_add_r. - * rewrite firstn_app. assert (H0 : (length l1 + S k - length l1) = S k). - 1:now rewrite Nat.add_comm, Nat.add_sub. - rewrite H0, firstn_all2; [reflexivity | now apply Nat.le_add_r]. - Qed. - - Lemma firstn_firstn: - forall l:list A, - forall i j : nat, - firstn i (firstn j l) = firstn (min i j) l. - Proof. intro l; induction l as [|x xs Hl]. - - intros. simpl. now rewrite ?firstn_nil. - - intros [|i]; [easy|]. - intros [|j]; [easy|]. - cbn. f_equal. apply Hl. - Qed. - - Lemma nth_error_skipn n l i : nth_error (skipn n l) i = nth_error l (n + i). - Proof. - revert l; induction n, l; cbn [nth_error skipn]; - rewrite ?nth_error_nil; trivial. - Qed. - - Lemma nth_skipn n l i d : nth i (skipn n l) d = nth (n + i) l d. - Proof. - revert l; induction n, l; cbn [nth skipn]; - rewrite ?nth_error_nil; destruct i; trivial. - Qed. - - Lemma hd_error_skipn n l : hd_error (skipn n l) = nth_error l n. - Proof. rewrite <-nth_error_0, nth_error_skipn, Nat.add_0_r; trivial. Qed. - - Lemma firstn_skipn_comm : forall m n l, - firstn m (skipn n l) = skipn n (firstn (n + m) l). - Proof. now intros m n; induction n; intros []; simpl; destruct m. Qed. - - Lemma skipn_firstn_comm : forall m n l, - skipn m (firstn n l) = firstn (n - m) (skipn m l). - Proof. now intro m; induction m; intros [] []; simpl; rewrite ?firstn_nil. Qed. - - Lemma skipn_0 : forall l, skipn 0 l = l. - Proof. reflexivity. Qed. - - Lemma skipn_nil : forall n, skipn n ([] : list A) = []. - Proof. now intros []. Qed. - - Lemma skipn_cons n a l: skipn (S n) (a::l) = skipn n l. - Proof. reflexivity. Qed. - - Lemma skipn_all : forall l, skipn (length l) l = []. - Proof. now intro l; induction l. Qed. - - Lemma skipn_all2 n: forall l, length l <= n -> skipn n l = []. - Proof. - intros l L%Nat.sub_0_le; rewrite <-(firstn_all l) at 1. - now rewrite skipn_firstn_comm, L. - Qed. - - Lemma skipn_all_iff n l : length l <= n <-> skipn n l = []. - Proof. - split; [apply skipn_all2|]. - revert l; induction n as [|n IH]; intros l. - - destruct l; simpl; [reflexivity|discriminate]. - - destruct l; simpl. - + intros _. apply Nat.le_0_l. - + intros H%IH. apply le_n_S. exact H. - Qed. - - Lemma skipn_skipn : forall x y l, skipn x (skipn y l) = skipn (x + y) l. - Proof. - intros x y. rewrite Nat.add_comm. induction y as [|y IHy]. - - reflexivity. - - intros [|]. - + now rewrite skipn_nil. - + now rewrite skipn_cons, IHy. - Qed. - - Lemma firstn_skipn : forall n l, firstn n l ++ skipn n l = l. - Proof. - intro n; induction n. - - simpl; auto. - - intro l; destruct l; simpl; auto. - f_equal; auto. - Qed. - - Lemma firstn_skipn_middle n l x : - nth_error l n = Some x -> - firstn n l ++ x :: skipn (S n) l = l. - Proof. - revert l x; induction n as [|n IH]; intros [|y l] x. - - discriminate. - - injection 1. intros ->. reflexivity. - - discriminate. - - simpl. intros H. f_equal. apply IH. exact H. - Qed. - - Lemma length_firstn : forall n l, length (firstn n l) = min n (length l). - Proof. - intro n; induction n; intro l; destruct l; simpl; auto. - Qed. - - Lemma length_skipn n : - forall l, length (skipn n l) = length l - n. - Proof. - induction n. - - intros l; simpl; rewrite Nat.sub_0_r; reflexivity. - - intro l; destruct l; simpl; auto. - Qed. - - Lemma skipn_app n : forall l1 l2, - skipn n (l1 ++ l2) = (skipn n l1) ++ (skipn (n - length l1) l2). - Proof. induction n; auto; intros [|]; simpl; auto. Qed. - - Lemma firstn_skipn_rev: forall x l, - firstn x l = rev (skipn (length l - x) (rev l)). - Proof. - intros x l; rewrite <-(firstn_skipn x l) at 3. - rewrite rev_app_distr, skipn_app, rev_app_distr, length_rev, - length_skipn, Nat.sub_diag; simpl; rewrite rev_involutive. - rewrite <-app_nil_r at 1; f_equal; symmetry; apply length_zero_iff_nil. - repeat rewrite length_rev, length_skipn; apply Nat.sub_diag. - Qed. - - Lemma firstn_rev: forall x l, - firstn x (rev l) = rev (skipn (length l - x) l). - Proof. - now intros x l; rewrite firstn_skipn_rev, rev_involutive, length_rev. - Qed. - - Lemma skipn_rev: forall x l, - skipn x (rev l) = rev (firstn (length l - x) l). - Proof. - intros x l; rewrite firstn_skipn_rev, rev_involutive, <-length_rev. - destruct (Nat.le_ge_cases (length (rev l)) x) as [L | L]. - - rewrite skipn_all2; [apply Nat.sub_0_le in L | trivial]. - now rewrite L, Nat.sub_0_r, skipn_all. - - f_equal. now apply Nat.eq_sym, Nat.add_sub_eq_l, Nat.sub_add. - Qed. - - Lemma removelast_firstn : forall n l, n < length l -> - removelast (firstn (S n) l) = firstn n l. - Proof. - intro n; induction n as [|n IHn]; intros [|? l]; [easy ..|]. - cbn [length firstn]. destruct l. - - now intros ? %Nat.succ_lt_mono. - - now intros <- %Nat.succ_lt_mono %IHn. - Qed. - - Lemma removelast_firstn_len : forall l, - removelast l = firstn (pred (length l)) l. - Proof. - intro l; induction l as [|a l IHl]; [ reflexivity | simpl ]. - destruct l; [ | rewrite IHl ]; reflexivity. - Qed. - - Lemma firstn_removelast : forall n l, n < length l -> - firstn n (removelast l) = firstn n l. - Proof. - intro n; induction n as [|n IHn]; intros [|? l]; [easy ..|]. - cbn [length firstn]. destruct l. - - now intros ? %Nat.succ_lt_mono. - - now intros <- %Nat.succ_lt_mono %IHn. - Qed. - -End Cutting. -Notation firstn := firstn. -Notation skipn := skipn. - -Section CuttingMap. - Variables A B : Type. - Variable f : A -> B. - - Lemma firstn_map : forall n l, - firstn n (map f l) = map f (firstn n l). - Proof. - intro n; induction n; intros []; simpl; f_equal; trivial. - Qed. - - Lemma skipn_map : forall n l, - skipn n (map f l) = map f (skipn n l). - Proof. - intro n; induction n; intros []; simpl; trivial. - Qed. -End CuttingMap. - -(**************************************************************) -(** ** Combining pairs of lists of possibly-different lengths *) -(**************************************************************) - -Section Combining. - Variables (A B : Type). - - Lemma combine_nil : forall (l : list A), - combine l (@nil B) = @nil (A*B). - Proof. - intros l. - apply length_zero_iff_nil. - rewrite length_combine. simpl. rewrite Nat.min_0_r. - reflexivity. - Qed. - - Lemma combine_firstn_l : forall (l : list A) (l' : list B), - combine l l' = combine l (firstn (length l) l'). - Proof. - intro l; induction l as [| x l IHl]; intros l'; [reflexivity|]. - destruct l' as [| x' l']; [reflexivity|]. - simpl. specialize IHl with l'. rewrite <- IHl. - reflexivity. - Qed. - - Lemma combine_firstn_r : forall (l : list A) (l' : list B), - combine l l' = combine (firstn (length l') l) l'. - Proof. - intros l l'. generalize dependent l. - induction l' as [| x' l' IHl']; intros l. - - simpl. apply combine_nil. - - destruct l as [| x l]; [reflexivity|]. - simpl. specialize IHl' with l. rewrite <- IHl'. - reflexivity. - Qed. - - Lemma combine_firstn : forall (l : list A) (l' : list B) (n : nat), - firstn n (combine l l') = combine (firstn n l) (firstn n l'). - Proof. - intro l; induction l as [| x l IHl]; intros l' n. - - simpl. repeat (rewrite firstn_nil). reflexivity. - - destruct l' as [| x' l']. - + simpl. repeat (rewrite firstn_nil). rewrite combine_nil. reflexivity. - + simpl. destruct n as [| n]; [reflexivity|]. - repeat (rewrite firstn_cons). simpl. - rewrite IHl. reflexivity. - Qed. - -End Combining. - -(**********************************************************************) -(** ** Predicate for List addition/removal (no need for decidability) *) -(**********************************************************************) - -Section Add. - - Variable A : Type. - - (* [Add a l l'] means that [l'] is exactly [l], with [a] added - once somewhere *) - Inductive Add (a:A) : list A -> list A -> Prop := - | Add_head l : Add a l (a::l) - | Add_cons x l l' : Add a l l' -> Add a (x::l) (x::l'). - - Lemma Add_app a l1 l2 : Add a (l1++l2) (l1++a::l2). - Proof. - induction l1; simpl; now constructor. - Qed. - - Lemma Add_split a l l' : - Add a l l' -> exists l1 l2, l = l1++l2 /\ l' = l1++a::l2. - Proof. - induction 1 as [l|x ? ? ? IHAdd]. - - exists nil; exists l; split; trivial. - - destruct IHAdd as (l1 & l2 & Hl & Hl'). - exists (x::l1); exists l2; split; simpl; f_equal; trivial. - Qed. - - Lemma Add_in a l l' : Add a l l' -> - forall x, In x l' <-> In x (a::l). - Proof. - induction 1 as [|? ? ? ? IHAdd]; intros; simpl in *; rewrite ?IHAdd; tauto. - Qed. - - Lemma Add_length a l l' : Add a l l' -> length l' = S (length l). - Proof. - induction 1; simpl; now auto. - Qed. - - Lemma Add_inv a l : In a l -> exists l', Add a l' l. - Proof. - intro Ha. destruct (in_split _ _ Ha) as (l1 & l2 & ->). - exists (l1 ++ l2). apply Add_app. - Qed. - - Lemma incl_Add_inv a l u v : - ~In a l -> incl (a::l) v -> Add a u v -> incl l u. - Proof. - intros Ha H AD y Hy. - assert (Hy' : In y (a::u)). - { rewrite <- (Add_in AD). apply H; simpl; auto. } - destruct Hy'; [ subst; now elim Ha | trivial ]. - Qed. - -End Add. - -(********************************) -(** ** Lists without redundancy *) -(********************************) - -Section ReDun. - - Variable A : Type. - - Inductive NoDup : list A -> Prop := - | NoDup_nil : NoDup [] - | NoDup_cons : forall x l, ~ In x l -> NoDup l -> NoDup (x::l). - - Lemma NoDup_Add a l l' : Add a l l' -> (NoDup l' <-> NoDup l /\ ~In a l). - Proof. - induction 1 as [l|x l l' AD IH]. - - split; [ inversion_clear 1; now split | now constructor ]. - - split. - + inversion_clear 1. rewrite IH in *. rewrite (Add_in AD) in *. - simpl in *; split; try constructor; intuition. - + intros (N,IN). inversion_clear N. constructor. - * rewrite (Add_in AD); simpl in *; intuition. - * apply IH. split; trivial. simpl in *; intuition. - Qed. - - Lemma NoDup_remove l l' a : - NoDup (l++a::l') -> NoDup (l++l') /\ ~In a (l++l'). - Proof. - apply NoDup_Add. apply Add_app. - Qed. - - Lemma NoDup_remove_1 l l' a : NoDup (l++a::l') -> NoDup (l++l'). - Proof. - intros. now apply NoDup_remove with a. - Qed. - - Lemma NoDup_remove_2 l l' a : NoDup (l++a::l') -> ~In a (l++l'). - Proof. - intros. now apply NoDup_remove. - Qed. - - Theorem NoDup_cons_iff a l: - NoDup (a::l) <-> ~ In a l /\ NoDup l. - Proof. - split. - + inversion_clear 1. now split. - + now constructor. - Qed. - - Lemma NoDup_app (l1 l2 : list A): - NoDup l1 -> NoDup l2 -> (forall a, In a l1 -> ~ In a l2) -> - NoDup (l1 ++ l2). - Proof. - intros H1 H2 H. induction l1 as [|a l1 IHl1]; [assumption|]. - apply NoDup_cons_iff in H1 as []. - cbn. constructor. - - intros H3%in_app_or. destruct H3. - + contradiction. - + apply (H a); [apply in_eq|assumption]. - - apply IHl1; [assumption|]. - intros. apply H, in_cons. assumption. - Qed. - - Lemma NoDup_app_remove_l l l' : NoDup (l++l') -> NoDup l'. - Proof. - induction l as [|a l IHl]; intro H. - - exact H. - - apply IHl, (NoDup_remove_1 nil _ _ H). - Qed. - - Lemma NoDup_app_remove_r l l' : NoDup (l++l') -> NoDup l. - Proof. - induction l' as [|a l' IHl']; intro H. - - now rewrite app_nil_r in H. - - apply IHl', (NoDup_remove_1 _ _ _ H). - Qed. - - Lemma NoDup_rev l : NoDup l -> NoDup (rev l). - Proof. - induction l as [|a l IHl]; simpl; intros Hnd; [ constructor | ]. - inversion_clear Hnd as [ | ? ? Hnin Hndl ]. - assert (Add a (rev l) (rev l ++ a :: nil)) as Hadd - by (rewrite <- (app_nil_r (rev l)) at 1; apply Add_app). - apply NoDup_Add in Hadd; apply Hadd; intuition. - now apply Hnin, in_rev. - Qed. - - Lemma NoDup_filter f l : NoDup l -> NoDup (filter f l). - Proof. - induction l as [|a l IHl]; simpl; intros Hnd; auto. - apply NoDup_cons_iff in Hnd. - destruct (f a); [ | intuition ]. - apply NoDup_cons_iff; split; [intro H|]; intuition. - apply filter_In in H; intuition. - Qed. - - (** Effective computation of a list without duplicates *) - - Hypothesis decA: forall x y : A, {x = y} + {x <> y}. - - Fixpoint nodup (l : list A) : list A := - match l with - | [] => [] - | x::xs => if in_dec decA x xs then nodup xs else x::(nodup xs) - end. - - Lemma nodup_fixed_point (l : list A) : - NoDup l -> nodup l = l. - Proof. - induction l as [| x l IHl]; [auto|]. intros H. - simpl. destruct (in_dec decA x l) as [Hx | Hx]; rewrite NoDup_cons_iff in H. - - destruct H as [H' _]. contradiction. - - destruct H as [_ H']. apply IHl in H'. rewrite -> H'. reflexivity. - Qed. - - Lemma nodup_In l x : In x (nodup l) <-> In x l. - Proof. - induction l as [|a l' Hrec]; simpl. - - reflexivity. - - destruct (in_dec decA a l'); simpl; rewrite Hrec. - * now intuition subst. - * reflexivity. - Qed. - - Lemma nodup_incl l1 l2 : incl l1 (nodup l2) <-> incl l1 l2. - Proof. - split; intros Hincl a Ha; apply nodup_In; intuition. - Qed. - - Lemma NoDup_nodup l: NoDup (nodup l). - Proof. - induction l as [|a l' Hrec]; simpl. - - constructor. - - destruct (in_dec decA a l'); simpl. - * assumption. - * constructor; [ now rewrite nodup_In | assumption]. - Qed. - - Lemma nodup_inv k l a : nodup k = a :: l -> ~ In a l. - Proof. - intros H. - assert (H' : NoDup (a::l)). - { rewrite <- H. apply NoDup_nodup. } - now inversion_clear H'. - Qed. - - Theorem NoDup_count_occ l: - NoDup l <-> (forall x:A, count_occ decA l x <= 1). - Proof. - induction l as [| a l' Hrec]. - - simpl; split; auto. constructor. - - rewrite NoDup_cons_iff, Hrec, (count_occ_not_In decA). clear Hrec. split. - + intros (Ha, H) x. simpl. destruct (decA a x); auto. - subst; now rewrite Ha. - + intro H; split. - * specialize (H a). rewrite count_occ_cons_eq in H; trivial. - now inversion H. - * intros x. specialize (H x). simpl in *. destruct (decA a x); auto. - now apply Nat.lt_le_incl. - Qed. - - Theorem NoDup_count_occ' l: - NoDup l <-> (forall x:A, In x l -> count_occ decA l x = 1). - Proof. - rewrite NoDup_count_occ. - setoid_rewrite (count_occ_In decA). unfold gt, lt in *. - split; intros H x; specialize (H x); - set (n := count_occ decA l x) in *; clearbody n. - (* the rest would be solved by omega if we had it here... *) - - now apply Nat.le_antisymm. - - destruct (Nat.le_gt_cases 1 n); trivial. - + rewrite H; trivial. - + now apply Nat.lt_le_incl. - Qed. - - (** Alternative characterisations of being without duplicates, - thanks to [nth_error] and [nth] *) - - Lemma NoDup_nth_error l : - NoDup l <-> - (forall i j, i nth_error l i = nth_error l j -> i = j). - Proof. - split. - { intros H; induction H as [|a l Hal Hl IH]; intros i j Hi E. - - inversion Hi. - - destruct i, j; simpl in *; auto. - * elim Hal. eapply nth_error_In; eauto. - * elim Hal. eapply nth_error_In; eauto. - * f_equal. now apply IH;[apply Nat.succ_lt_mono|]. } - { induction l as [|a l IHl]; intros H; constructor. - * intro Ha. apply In_nth_error in Ha. destruct Ha as (n,Hn). - assert (n < length l) by (now rewrite <- nth_error_Some, Hn). - specialize (H 0 (S n)). simpl in H. now discriminate H; [apply Nat.lt_0_succ|]. - * apply IHl. - intros i j Hi %Nat.succ_lt_mono E. now apply eq_add_S, H. } - Qed. - - Lemma NoDup_nth l d : - NoDup l <-> - (forall i j, i j - nth i l d = nth j l d -> i = j). - Proof. - rewrite NoDup_nth_error. split. - - intros H i j ? ? E. apply H; [assumption|]. - now rewrite !(nth_error_nth' l d), E. - - intros H i j ? E. assert (j < length l). - { apply nth_error_Some. rewrite <- E. now apply nth_error_Some. } - apply H; [assumption ..|]. - rewrite !(nth_error_nth' l d) in E; congruence. - Qed. - - (** Having [NoDup] hypotheses bring more precise facts about [incl]. *) - - Lemma NoDup_incl_length l l' : - NoDup l -> incl l l' -> length l <= length l'. - Proof. - intros N. revert l'. induction N as [|a l Hal N IH]; simpl. - - intros. now apply Nat.le_0_l. - - intros l' H. - destruct (Add_inv a l') as (l'', AD). { apply H; simpl; auto. } - rewrite (Add_length AD). apply le_n_S. apply IH. - now apply incl_Add_inv with a l'. - Qed. - - Lemma NoDup_length_incl l l' : - NoDup l -> length l' <= length l -> incl l l' -> incl l' l. - Proof. - intros N. revert l'. induction N as [|a l Hal N IH]. - - intro l'; destruct l'; easy. - - intros l' E H x Hx. - destruct (Add_inv a l') as (l'', AD). { apply H; simpl; auto. } - rewrite (Add_in AD) in Hx. simpl in Hx. - destruct Hx as [Hx|Hx]; [left; trivial|right]. - revert x Hx. apply (IH l''); trivial. - * apply Nat.succ_le_mono. now rewrite <- (Add_length AD). - * now apply incl_Add_inv with a l'. - Qed. - - Lemma NoDup_incl_NoDup (l l' : list A) : NoDup l -> - length l' <= length l -> incl l l' -> NoDup l'. - Proof. - revert l'; induction l as [|a l IHl]; simpl; intros l' Hnd Hlen Hincl. - - now destruct l'; inversion Hlen. - - assert (In a l') as Ha by now apply Hincl; left. - apply in_split in Ha as [l1' [l2' ->]]. - inversion_clear Hnd as [|? ? Hnin Hnd']. - apply (NoDup_Add (Add_app a l1' l2')); split. - + apply IHl; auto. - * rewrite length_app. - rewrite length_app in Hlen; simpl in Hlen; rewrite Nat.add_succ_r in Hlen. - now apply Nat.succ_le_mono. - * apply (incl_Add_inv (u:= l1' ++ l2')) in Hincl; auto. - apply Add_app. - + intros Hnin'. - assert (incl (a :: l) (l1' ++ l2')) as Hincl''. - { apply incl_tran with (l1' ++ a :: l2'); auto. - intros x Hin. - apply in_app_or in Hin as [Hin|[->|Hin]]; intuition. } - apply NoDup_incl_length in Hincl''; [ | now constructor ]. - apply (Nat.nle_succ_diag_l (length l1' + length l2')). - rewrite_all length_app. - simpl in Hlen; rewrite Nat.add_succ_r in Hlen. - now transitivity (S (length l)). - Qed. - -End ReDun. - -(** NoDup and map *) - -(** NB: the reciprocal result holds only for injective functions, - see FinFun.v *) - -Lemma NoDup_map_inv A B (f:A->B) l : NoDup (map f l) -> NoDup l. -Proof. - induction l; simpl; inversion_clear 1; subst; constructor; auto. - intro H. now apply (in_map f) in H. -Qed. - -(***********************************) -(** ** Sequence of natural numbers *) -(***********************************) - -Section NatSeq. - - Lemma cons_seq : forall len start, start :: seq (S start) len = seq start (S len). - Proof. - reflexivity. - Qed. - - Lemma length_seq : forall len start, length (seq start len) = len. - Proof. - intro len; induction len; simpl; auto. - Qed. - - Lemma seq_nth : forall len start n d, - n < len -> nth n (seq start len) d = start+n. - Proof. - intro len; induction len as [|len IHlen]; intros start n d H. - - inversion H. - - simpl seq. - destruct n; simpl. - + now rewrite Nat.add_0_r. - + now rewrite IHlen; [rewrite Nat.add_succ_r|apply Nat.succ_lt_mono]. - Qed. - - Lemma seq_shift : forall len start, - map S (seq start len) = seq (S start) len. - Proof. - intro len; induction len as [|len IHlen]; simpl; auto. - intros. - now rewrite IHlen. - Qed. - - Lemma in_seq len start n : - In n (seq start len) <-> start <= n < start+len. - Proof. - revert start. induction len as [|len IHlen]; simpl; intros start. - - rewrite Nat.add_0_r. split;[easy|]. - intros (H,H'). apply (Nat.lt_irrefl start). - eapply Nat.le_lt_trans; eassumption. - - rewrite IHlen, Nat.add_succ_r; simpl; split. - + intros [H|H]; subst; intuition. - * apply -> Nat.succ_le_mono. apply Nat.le_add_r. - * now apply Nat.lt_le_incl. - + intros (H,H'). inversion H. - * now left. - * right. subst. now split; [apply -> Nat.succ_le_mono|]. - Qed. - - Lemma seq_NoDup len start : NoDup (seq start len). - Proof. - revert start; induction len as [|len IH]; - intros start; simpl; constructor; trivial. - rewrite in_seq. intros (H,_). now apply (Nat.lt_irrefl start). - Qed. - - Lemma seq_app : forall len1 len2 start, - seq start (len1 + len2) = seq start len1 ++ seq (start + len1) len2. - Proof. - intro len1; induction len1 as [|len1' IHlen]; intros; simpl in *. - - now rewrite Nat.add_0_r. - - now rewrite Nat.add_succ_r, IHlen. - Qed. - - Lemma seq_S : forall len start, seq start (S len) = seq start len ++ [start + len]. - Proof. - intros len start. - change [start + len] with (seq (start + len) 1). - rewrite <- seq_app. - rewrite Nat.add_succ_r, Nat.add_0_r; reflexivity. - Qed. - - Lemma skipn_seq n start len : skipn n (seq start len) = seq (start+n) (len-n). - Proof. - revert len; revert start; induction n, len; - cbn [skipn seq]; rewrite ?Nat.add_0_r, ?IHn; cbn [Nat.add]; auto. - Qed. - - Lemma nth_error_seq start len n : - nth_error (seq start len) n = - if Nat.ltb n len then Some (start + n) else None. - Proof. - revert len; revert start; induction n, len; - cbn [nth_error seq]; rewrite ?Nat.add_0_r; trivial. - rewrite <-seq_shift, nth_error_map, IHn. - cbn [Nat.ltb Nat.leb]; case len, Nat.leb; trivial. - cbn [option_map]; rewrite ?plus_n_Sm; trivial. - Qed. - -End NatSeq. -Notation seq := seq. - -(***********************) -(** ** List comparison *) -(***********************) - -Section Compare. - - Variable A : Type. - Variable cmp : A -> A -> comparison. - - Local Notation list_compare := (@list_compare A cmp). - - Section Lemmas. - - Variable Hcmp : forall x y, cmp x y = Eq <-> x = y. - - Lemma list_compare_cons (x : A) (xs ys : list A) : - list_compare (x :: xs) (x :: ys) = list_compare xs ys. - Proof. - simpl. rewrite (proj2 (Hcmp x x) eq_refl). reflexivity. - Qed. - - Lemma list_compare_app (xs ys zs : list A) : - list_compare (xs ++ ys) (xs ++ zs) = list_compare ys zs. - Proof. - induction xs as [|x xs IH]; [reflexivity|]. - rewrite <-!app_comm_cons, list_compare_cons. exact IH. - Qed. - - Lemma prefix_eq {prefix1 prefix2 xs1 xs2 ys1 ys2 : list A} {x1 x2 y1 y2 : A} : - prefix1 ++ x1 :: xs1 = prefix2 ++ x2 :: xs2 -> - prefix1 ++ y1 :: ys1 = prefix2 ++ y2 :: ys2 -> - x1 <> y1 -> - x2 <> y2 -> - prefix1 = prefix2. - Proof. - clear Hcmp cmp. - intros Heq1 Heq2 Hne1 Hne2. - revert prefix2 xs1 xs2 ys1 ys2 Heq1 Heq2. - induction prefix1 as [|z prefix1 IH]; intros prefix2 xs1 xs2 ys1 ys2. - - destruct prefix2; [reflexivity|]. simpl. intros H1 H2. - injection H1; clear H1; intros ??; subst. - injection H2; clear H2; intros ??; subst. - exfalso. apply Hne1. reflexivity. - - destruct prefix2. - + simpl. intros H1 H2. - injection H1; clear H1; intros ??; subst. - injection H2; clear H2; intros ??; subst. - exfalso. apply Hne2. reflexivity. - + simpl. intros H1 H2. - injection H1; clear H1; intros ??; subst. - injection H2; clear H2; intros ?; subst. - intros. f_equal. eapply IH; eassumption. - Qed. - - #[local] Ltac list_auto := - repeat lazymatch goal with - | |- ?x = ?x => - reflexivity - | H : ?xs = ?xs ++ _ |- _ => - rewrite <-(app_nil_r xs) in H at 1 - | H : ?xs ++ _ = ?xs |- _ => - symmetry in H - | H : ?xs ++ _ = ?xs ++ _ |- _ => - apply app_inv_head in H - | H : _ :: _ = _ :: _ |- _ => - injection H; intros; clear H; subst - | H : [] = _ :: _ |- _ => - inversion H - | H : cmp ?x ?x = Lt |- _ => - rewrite (proj2 (Hcmp _ _) eq_refl) in H; discriminate - | H : cmp ?x ?x = Gt |- _ => - rewrite (proj2 (Hcmp _ _) eq_refl) in H; discriminate - | H1 : ?p1 ++ _ :: _ = ?p2 ++ _ :: _, - H2 : ?p2 ++ _ :: _ = ?p1 ++ _ :: _ |- _ => - symmetry in H2 - | H1 : ?p1 ++ ?x1 :: ?xs1 = ?p2 ++ ?x2 :: ?xs2, - H2 : ?p1 ++ ?y1 :: ?ys1 = ?p2 ++ ?y2 :: ?ys2 |- _ => - assert (p1 = p2) as Hp; - [ eapply (prefix_eq H1 H2); intros Heq; subst - | subst; apply app_inv_head in H1, H2 ] - | H : cmp ?x ?x = _ |- _ => - rewrite (proj2 (Hcmp _ _) eq_refl) in H; try discriminate H - | H1 : cmp ?x1 ?x2 = _, - H2 : cmp ?x1 ?x2 = _ |- _ => - rewrite H1 in H2; discriminate H2 - | Htrans : forall (x y z : A) (c : comparison), cmp x y = c -> cmp y z = c -> cmp x z = c, - H1 : cmp ?x1 ?x2 = ?c, - H2 : cmp ?x2 ?x3 = ?c |- _ => - pose proof (Htrans x1 x2 x3 c H1 H2); clear H1 H2 - | Hcmp_opp : (forall x y, cmp y x = CompOpp (cmp x y)), - H1 : cmp ?x1 ?x2 = ?c, H2 : cmp ?x2 ?x1 = ?c |- _ => - rewrite Hcmp_opp, H2 in H1; simpl in H1; discriminate H1 - end. - - Inductive ListCompareSpec (xs ys : list A) : forall (c : comparison), Prop := - | ListCompareEq : - xs = ys -> - ListCompareSpec xs ys Eq - | ListCompareShorter y ys' : - ys = xs ++ y :: ys' -> - ListCompareSpec xs ys Lt - | ListCompareLonger x xs' : - xs = ys ++ x :: xs' -> - ListCompareSpec xs ys Gt - | ListCompareLt prefix x xs' y ys' : - xs = prefix ++ x :: xs' -> - ys = prefix ++ y :: ys' -> - cmp x y = Lt -> - ListCompareSpec xs ys Lt - | ListCompareGt prefix x xs' y ys' : - xs = prefix ++ x :: xs' -> - ys = prefix ++ y :: ys' -> - cmp x y = Gt -> - ListCompareSpec xs ys Gt. - - Lemma list_compareP (xs ys : list A) : - ListCompareSpec xs ys (list_compare xs ys). - Proof. - assert (xs = [] ++ xs) as Hxs by reflexivity. - assert (ys = [] ++ ys) as Hys by reflexivity. - revert Hxs Hys. - generalize (@nil A) as prefix. - generalize ys at 2 4. - generalize xs at 2 4. - intros xs'; induction xs' as [|x xs' IH]; intros ys' prefix -> ->. - - destruct ys' as [|y ys']; rewrite app_nil_r; simpl. - + apply ListCompareEq. reflexivity. - + eapply ListCompareShorter; reflexivity. - - destruct ys' as [|y ys']; rewrite ?app_nil_r; simpl. - + eapply ListCompareLonger; reflexivity. - + destruct (cmp x y) eqn:Hxy. - * apply Hcmp in Hxy; subst y. - apply (IH ys' (prefix ++ [x])); rewrite <-app_assoc; reflexivity. - * eapply ListCompareLt; [reflexivity|reflexivity|exact Hxy]. - * eapply ListCompareGt; [reflexivity|reflexivity|exact Hxy]. - Qed. - - Lemma list_compare_refl (xs ys : list A) : - list_compare xs ys = Eq <-> xs = ys. - Proof. - destruct (list_compareP xs ys); subst; split; intros. - all: first [discriminate | list_auto]. - Qed. - - Lemma list_compare_antisym (xs ys : list A) : - (forall x y, cmp y x = CompOpp (cmp x y)) -> - list_compare ys xs = CompOpp (list_compare xs ys). - Proof. - intros Hcmp_opp. - destruct (list_compareP xs ys), (list_compareP ys xs); subst. - all: repeat rewrite <-app_assoc in *; simpl in *; list_auto. - Qed. - - Lemma list_compare_trans (xs ys zs : list A) (c : comparison) : - (forall x y z c, cmp x y = c -> cmp y z = c -> cmp x z = c) -> - (forall x y, cmp y x = CompOpp (cmp x y)) -> - list_compare xs ys = c -> list_compare ys zs = c -> list_compare xs zs = c. - Proof. - intros Hcmp_trans Hcmp_opp. - destruct - (list_compareP xs ys) as [?|???|???|p1 x1 xs1 y1 ys1 Hxy1 Hxy2 Hlt1|p1 x1 xs1 y1 ys1 Hxy1 Hxy2 Hgt1], - (list_compareP ys zs) as [?|???|???|p2 y2 ys2 z2 zs2 Hyz1 Hyz2 Hlt2|p2 y2 ys2 z2 zs2 Hyz1 Hyz2 Hgt2], - (list_compareP xs zs) as [?|???|???|p3 x3 xs3 z3 zs3 Hxz1 Hxz2 Hlt3|p3 x3 xs3 z3 zs3 Hxz1 Hxz2 Hgt3]. - all: intros <-; try discriminate; intros _; try reflexivity; exfalso. - all: try (subst; rewrite <-?app_assoc in *; simpl in *; list_auto; fail). - all: rewrite Hxy1 in Hxz1; rewrite Hxy2 in Hyz1; rewrite Hyz2 in Hxz2; clear Hxy1 Hxy2 Hyz2. - all: revert p2 p3 xs1 ys1 ys2 zs2 xs3 zs3 Hyz1 Hxz1 Hxz2. - all: induction p1 as [|h1 p1 IH]; intros; destruct p2 as [|h2 p2]; destruct p3 as [|h3 p3]. - all: simpl in *; list_auto. - all: eapply IH; eassumption. - Qed. - - Lemma list_compare_spec_complete (xs ys : list A) (c : comparison) : - ListCompareSpec xs ys c -> list_compare xs ys = c. - Proof. - intros [->|??->|??->|?????->->Heq|?????->->Heq]. - - apply list_compare_refl. reflexivity. - - rewrite <-(app_nil_r xs) at 1. apply list_compare_app. - - rewrite <-(app_nil_r ys) at 2. apply list_compare_app. - - rewrite list_compare_app. simpl. rewrite Heq. reflexivity. - - rewrite list_compare_app. simpl. rewrite Heq. reflexivity. - Qed. - - End Lemmas. - -End Compare. -Notation list_compare := list_compare. - -Section Exists_Forall. - - (** * Existential and universal predicates over lists *) - - Variable A:Type. - - Section One_predicate. - - Variable P:A->Prop. - - Inductive Exists : list A -> Prop := - | Exists_cons_hd : forall x l, P x -> Exists (x::l) - | Exists_cons_tl : forall x l, Exists l -> Exists (x::l). - - #[local] - Hint Constructors Exists : core. - - Lemma Exists_exists (l:list A) : - Exists l <-> (exists x, In x l /\ P x). - Proof. - split. - - induction 1; firstorder. - - induction l; firstorder (subst; auto). - Qed. - - Lemma Exists_nth l : - Exists l <-> exists i d, i < length l /\ P (nth i l d). - Proof. - split. - - intros HE; apply Exists_exists in HE. - destruct HE as [a [Hin HP]]. - apply (In_nth _ _ a) in Hin; destruct Hin as [i [Hl Heq]]. - rewrite <- Heq in HP. - now exists i; exists a. - - intros [i [d [Hl HP]]]. - apply Exists_exists; exists (nth i l d); split. - + apply nth_In; assumption. - + assumption. - Qed. - - Lemma Exists_nil : Exists [] <-> False. - Proof. split; inversion 1. Qed. - - Lemma Exists_cons x l: - Exists (x::l) <-> P x \/ Exists l. - Proof. split; inversion 1; auto. Qed. - - Lemma Exists_app l1 l2 : - Exists (l1 ++ l2) <-> Exists l1 \/ Exists l2. - Proof. - induction l1; simpl; split; intros HE; try now intuition. - - inversion_clear HE; intuition. - - destruct HE as [HE|HE]; intuition. - inversion_clear HE; intuition. - Qed. - - Lemma Exists_rev l : Exists l -> Exists (rev l). - Proof. - induction l; intros HE; intuition. - inversion_clear HE; simpl; apply Exists_app; intuition. - Qed. - - Lemma Exists_dec l: - (forall x:A, {P x} + { ~ P x }) -> - {Exists l} + {~ Exists l}. - Proof. - intro Pdec. induction l as [|a l' Hrec]. - - right. abstract now rewrite Exists_nil. - - destruct Hrec as [Hl'|Hl']. - + left. now apply Exists_cons_tl. - + destruct (Pdec a) as [Ha|Ha]. - * left. now apply Exists_cons_hd. - * right. abstract now inversion 1. - Defined. - - Lemma Exists_fold_right l : - Exists l <-> fold_right (fun x => or (P x)) False l. - Proof. - induction l; simpl; split; intros HE; try now inversion HE; intuition. - Qed. - - Lemma incl_Exists l1 l2 : incl l1 l2 -> Exists l1 -> Exists l2. - Proof. - intros Hincl HE. - apply Exists_exists in HE; destruct HE as [a [Hin HP]]. - apply Exists_exists; exists a; intuition. - Qed. - - #[local] - Hint Constructors Forall : core. - - Local Notation Forall := (@Forall A P). - - Lemma Forall_inv : forall (a:A) l, Forall (a :: l) -> P a. - Proof. - intros a l H; inversion H; trivial. - Qed. - - Theorem Forall_inv_tail : forall (a:A) l, Forall (a :: l) -> Forall l. - Proof. - intros a l H; inversion H; trivial. - Qed. - - Lemma Forall_nil_iff : Forall [] <-> True. - Proof. - easy. - Qed. - - Lemma Forall_cons_iff : forall (a:A) l, Forall (a :: l) <-> P a /\ Forall l. - Proof. - intros. now split; [intro H; inversion H|constructor]. - Qed. - - Lemma Forall_forall (l:list A): - Forall l <-> (forall x, In x l -> P x). - Proof. - split. - - induction 1; firstorder (subst; auto). - - induction l; firstorder auto with datatypes. - Qed. - - Lemma Forall_nth l : - Forall l <-> forall i d, i < length l -> P (nth i l d). - Proof. - split. - - intros HF i d Hl. - apply (Forall_forall l). - + assumption. - + apply nth_In; assumption. - - intros HF. - apply Forall_forall; intros a Hin. - apply (In_nth _ _ a) in Hin; destruct Hin as [i [Hl Heq]]. - rewrite <- Heq; intuition. - Qed. - - Lemma Forall_app l1 l2 : - Forall (l1 ++ l2) <-> Forall l1 /\ Forall l2. - Proof. - induction l1 as [|a l1 IH]; cbn. - - now rewrite Forall_nil_iff. - - now rewrite !Forall_cons_iff, IH, and_assoc. - Qed. - - Lemma Forall_elt a l1 l2 : Forall (l1 ++ a :: l2) -> P a. - Proof. - intros HF; apply Forall_app in HF; destruct HF as [HF1 HF2]; now inversion HF2. - Qed. - - Lemma Forall_rev l : Forall l -> Forall (rev l). - Proof. - induction l; intros HF; [assumption|]. - inversion_clear HF; simpl; apply Forall_app; intuition. - Qed. - - Lemma Forall_rect : forall (Q : list A -> Type), - Q [] -> (forall b l, P b -> Q (b :: l)) -> forall l, Forall l -> Q l. - Proof. - intros Q H H' l; induction l; intro; [|eapply H', Forall_inv]; eassumption. - Qed. - - Lemma Forall_dec : - (forall x:A, {P x} + { ~ P x }) -> - forall l:list A, {Forall l} + {~ Forall l}. - Proof. - intros Pdec l. induction l as [|a l' Hrec]. - - left. apply Forall_nil. - - destruct Hrec as [Hl'|Hl']. - + destruct (Pdec a) as [Ha|Ha]. - * left. now apply Forall_cons. - * right. abstract now inversion 1. - + right. abstract now inversion 1. - Defined. - - Lemma Forall_fold_right l : - Forall l <-> fold_right (fun x => and (P x)) True l. - Proof. - induction l; simpl; split; intros HF; try now inversion HF; intuition. - Qed. - - Lemma incl_Forall l1 l2 : incl l2 l1 -> Forall l1 -> Forall l2. - Proof. - intros Hincl HF. - apply Forall_forall; intros a Ha. - apply (Forall_forall l1); intuition. - Qed. - - End One_predicate. - Local Notation Forall := (@Forall A). - - Lemma map_ext_Forall B : forall (f g : A -> B) l, - Forall (fun x => f x = g x) l -> map f l = map g l. - Proof. - intros; apply map_ext_in, Forall_forall; assumption. - Qed. - - Theorem Exists_impl : forall (P Q : A -> Prop), (forall a : A, P a -> Q a) -> - forall l, Exists P l -> Exists Q l. - Proof. - intros P Q H l H0. - induction H0 as [x l H0|x l H0 IHExists]. - - apply (Exists_cons_hd Q x l (H x H0)). - - apply (Exists_cons_tl x IHExists). - Qed. - - Lemma Exists_or : forall (P Q : A -> Prop) l, - Exists P l \/ Exists Q l -> Exists (fun x => P x \/ Q x) l. - Proof. - intros P Q l; induction l as [|a l IHl]; intros [H | H]; inversion H; subst. - 1,3: apply Exists_cons_hd; auto. - all: apply Exists_cons_tl, IHl; auto. - Qed. - - Lemma Exists_or_inv : forall (P Q : A -> Prop) l, - Exists (fun x => P x \/ Q x) l -> Exists P l \/ Exists Q l. - Proof. - intros P Q l; induction l as [|a l IHl]; - intro Hl; inversion Hl as [ ? ? H | ? ? H ]; subst. - - inversion H; now repeat constructor. - - destruct (IHl H); now repeat constructor. - Qed. - - Lemma Forall_impl : forall (P Q : A -> Prop), (forall a, P a -> Q a) -> - forall l, Forall P l -> Forall Q l. - Proof. - intros P Q H l. rewrite !Forall_forall. firstorder. - Qed. - - Lemma Forall_and : forall (P Q : A -> Prop) l, - Forall P l -> Forall Q l -> Forall (fun x => P x /\ Q x) l. - Proof. - intros P Q l; induction l; intros HP HQ; constructor; inversion HP; inversion HQ; auto. - Qed. - - Lemma Forall_and_inv : forall (P Q : A -> Prop) l, - Forall (fun x => P x /\ Q x) l -> Forall P l /\ Forall Q l. - Proof. - intros P Q l; induction l; intro Hl; split; constructor; inversion Hl; firstorder. - Qed. - - Lemma Forall_Exists_neg (P:A->Prop)(l:list A) : - Forall (fun x => ~ P x) l <-> ~(Exists P l). - Proof. - rewrite Forall_forall, Exists_exists. firstorder. - Qed. - - Lemma Exists_Forall_neg (P:A->Prop)(l:list A) : - (forall x, P x \/ ~P x) -> - Exists (fun x => ~ P x) l <-> ~(Forall P l). - Proof. - intro Dec. - split. - - rewrite Forall_forall, Exists_exists; firstorder. - - intros NF. - induction l as [|a l IH]. - + destruct NF. constructor. - + destruct (Dec a) as [Ha|Ha]. - * apply Exists_cons_tl, IH. contradict NF. now constructor. - * now apply Exists_cons_hd. - Qed. - - Lemma neg_Forall_Exists_neg (P:A->Prop) (l:list A) : - (forall x:A, {P x} + { ~ P x }) -> - ~ Forall P l -> - Exists (fun x => ~ P x) l. - Proof. - intro Dec. - apply Exists_Forall_neg; intros x. - destruct (Dec x); auto. - Qed. - - Lemma Forall_Exists_dec (P:A->Prop) : - (forall x:A, {P x} + { ~ P x }) -> - forall l:list A, - {Forall P l} + {Exists (fun x => ~ P x) l}. - Proof. - intros Pdec l. - destruct (Forall_dec P Pdec l); [left|right]; trivial. - now apply neg_Forall_Exists_neg. - Defined. - - Lemma incl_Forall_in_iff l l' : - incl l l' <-> Forall (fun x => In x l') l. - Proof. now rewrite Forall_forall; split. Qed. - -End Exists_Forall. -Notation Forall := Forall. -Notation Forall_nil := ListDef.Forall_nil (only parsing). -Notation Forall_cons := ListDef.Forall_cons (only parsing). - -#[global] -Hint Constructors Exists : core. -#[global] -Hint Constructors Forall : core. - -Lemma Exists_map A B (f : A -> B) P l : - Exists P (map f l) <-> Exists (fun x => P (f x)) l. -Proof. - induction l as [|a l IHl]. - - cbn. now rewrite Exists_nil. - - cbn. now rewrite ?Exists_cons, IHl. -Qed. - -Lemma Exists_concat A P (ls : list (list A)) : - Exists P (concat ls) <-> Exists (Exists P) ls. -Proof. - induction ls as [|l ls IHls]. - - cbn. now rewrite Exists_nil. - - cbn. now rewrite Exists_app, Exists_cons, IHls. -Qed. - -Lemma Exists_flat_map A B P ls (f : A -> list B) : - Exists P (flat_map f ls) <-> Exists (fun d => Exists P (f d)) ls. -Proof. - now rewrite flat_map_concat_map, Exists_concat, Exists_map. -Qed. - -Lemma Forall_map A B (f : A -> B) P l : - Forall P (map f l) <-> Forall (fun x => P (f x)) l. -Proof. - induction l as [|a l IHl]; cbn. - - now rewrite !Forall_nil_iff. - - now rewrite !Forall_cons_iff, IHl. -Qed. - -Lemma Forall_concat A P (ls : list (list A)) : - Forall P (concat ls) <-> Forall (Forall P) ls. -Proof. - induction ls as [|l ls IHls]; cbn. - - now rewrite !Forall_nil_iff. - - now rewrite Forall_app, Forall_cons_iff, IHls. -Qed. - -Lemma Forall_flat_map A B P ls (f : A -> list B) : - Forall P (flat_map f ls) <-> Forall (fun d => Forall P (f d)) ls. -Proof. - now rewrite flat_map_concat_map, Forall_concat, Forall_map. -Qed. - -Lemma exists_Forall A B : forall (P : A -> B -> Prop) l, - (exists k, Forall (P k) l) -> Forall (fun x => exists k, P k x) l. -Proof. - intros P l; induction l as [|a l IHl]; intros [k HF]; constructor; inversion_clear HF. - - now exists k. - - now apply IHl; exists k. -Qed. - -Lemma Forall_image A B : forall (f : A -> B) l, - Forall (fun y => exists x, y = f x) l <-> exists l', l = map f l'. -Proof. - intros f l; induction l as [|a l IHl]; split; intros HF. - - exists nil; reflexivity. - - constructor. - - apply Forall_cons_iff in HF as [[x ->] [l' ->] %IHl]. - now exists (x :: l'). - - destruct HF as [l' Heq]. - symmetry in Heq; apply map_eq_cons in Heq. - destruct Heq as (x & tl & ? & ? & ?); subst. - constructor. - + now exists x. - + now apply IHl; exists tl. -Qed. - -Lemma concat_nil_Forall A : forall (l : list (list A)), - concat l = [] <-> Forall (fun x => x = []) l. -Proof. - intro l; induction l as [|a l IHl]; simpl; split; intros Hc; auto. - - apply app_eq_nil in Hc. - constructor; firstorder. - - inversion Hc; subst; simpl. - now apply IHl. -Qed. - -Lemma in_flat_map_Exists A B : forall (f : A -> list B) x l, - In x (flat_map f l) <-> Exists (fun y => In x (f y)) l. -Proof. - intros f x l; rewrite in_flat_map. - split; apply Exists_exists. -Qed. - -Lemma notin_flat_map_Forall A B : forall (f : A -> list B) x l, - ~ In x (flat_map f l) <-> Forall (fun y => ~ In x (f y)) l. -Proof. - intros f x l; rewrite Forall_Exists_neg. - apply not_iff_compat, in_flat_map_Exists. -Qed. - - -Section Forall2. - - (** [Forall2]: stating that elements of two lists are pairwise related. *) - - Variables A B : Type. - Variable R : A -> B -> Prop. - - Inductive Forall2 : list A -> list B -> Prop := - | Forall2_nil : Forall2 [] [] - | Forall2_cons : forall x y l l', - R x y -> Forall2 l l' -> Forall2 (x::l) (y::l'). - - #[local] - Hint Constructors Forall2 : core. - - (* NB: when deprecation phase ends, instead of removing prove "Reflexive R -> Reflexive Forall2" - and close #6131 *) - #[deprecated(since = "8.18", use = Forall2_nil)] - Theorem Forall2_refl : Forall2 [] []. - Proof. intros; apply Forall2_nil. Qed. - - Theorem Forall2_cons_iff : forall x y l l', - Forall2 (x :: l) (y :: l') <-> R x y /\ Forall2 l l'. - Proof. - intros x y l l'. split. - - intros H. now inversion H. - - intros [? ?]. now constructor. - Qed. - - Theorem Forall2_length : forall l l', - Forall2 l l' -> length l = length l'. - Proof. - intros l. induction l as [|x l IH]; intros l' Hl'; inversion Hl'. - - reflexivity. - - cbn. f_equal. now apply IH. - Qed. - - Theorem Forall2_app_inv_l : forall l1 l2 l', - Forall2 (l1 ++ l2) l' -> - exists l1' l2', Forall2 l1 l1' /\ Forall2 l2 l2' /\ l' = l1' ++ l2'. - Proof. - intro l1; induction l1 as [|a l1 IHl1]; intros l2 l' H. - - exists [], l'; auto. - - simpl in H; inversion H as [|? y ? ? ? H4]; subst; clear H. - apply IHl1 in H4 as (l1' & l2' & Hl1 & Hl2 & ->). - exists (y::l1'), l2'; simpl; auto. - Qed. - - Theorem Forall2_app_inv_r : forall l1' l2' l, - Forall2 l (l1' ++ l2') -> - exists l1 l2, Forall2 l1 l1' /\ Forall2 l2 l2' /\ l = l1 ++ l2. - Proof. - intro l1'; induction l1' as [|a l1' IHl1']; intros l2' l H. - - exists [], l; auto. - - simpl in H; inversion H as [|x ? ? ? ? H4]; subst; clear H. - apply IHl1' in H4 as (l1 & l2 & Hl1 & Hl2 & ->). - exists (x::l1), l2; simpl; auto. - Qed. - - Theorem Forall2_app : forall l1 l2 l1' l2', - Forall2 l1 l1' -> Forall2 l2 l2' -> Forall2 (l1 ++ l2) (l1' ++ l2'). - Proof. - intros l1 l2 l1' l2' H H0. induction l1 in l1', H, H0 |- *; inversion H; subst; simpl; auto. - Qed. - - Theorem Forall_Exists_exists_Forall2 l1 l2 : - Forall (fun a => Exists (R a) l2) l1 -> - exists l2', Forall2 l1 l2' /\ incl l2' l2. - Proof. - induction l1 as [|a l1 IH]. - - intros _. now exists []. - - intros [[b [Hb Hab]] %Exists_exists Hl1l2] %Forall_cons_iff. - destruct (IH Hl1l2) as [l2' [Hl1l2' Hl2'l2]]. - exists (b :: l2'). now eauto using incl_cons. - Qed. -End Forall2. - -Lemma Forall2_impl (A B : Type) (R1 R2 : A -> B -> Prop) : (forall a b, R1 a b -> R2 a b) -> - forall l1 l2, Forall2 R1 l1 l2 -> Forall2 R2 l1 l2. -Proof. - intros HPQ l1 l2 HPl1l2. induction HPl1l2; now eauto using Forall2. -Qed. - -Lemma Forall2_flip (A B : Type) (R : A -> B -> Prop) l1 l2 : - Forall2 R l1 l2 -> Forall2 (fun b a => R a b) l2 l1. -Proof. - intros HPl1l2. induction HPl1l2; now eauto using Forall2. -Qed. - -#[global] -Hint Constructors Forall2 : core. - -Section ForallPairs. - - (** [ForallPairs] : specifies that a certain relation should - always hold when inspecting all possible pairs of elements of a list. *) - - Variable A : Type. - Variable R : A -> A -> Prop. - - Definition ForallPairs l := - forall a b, In a l -> In b l -> R a b. - - (** [ForallOrdPairs] : we still check a relation over all pairs - of elements of a list, but now the order of elements matters. *) - - Inductive ForallOrdPairs : list A -> Prop := - | FOP_nil : ForallOrdPairs [] - | FOP_cons : forall a l, - Forall (R a) l -> ForallOrdPairs l -> ForallOrdPairs (a::l). - - #[local] - Hint Constructors ForallOrdPairs : core. - - Lemma ForallOrdPairs_In : forall l, - ForallOrdPairs l -> - forall x y, In x l -> In y l -> x=y \/ R x y \/ R y x. - Proof. - induction 1. - - inversion 1. - - simpl; destruct 1; destruct 1; subst; auto. - + right; left. apply -> Forall_forall; eauto. - + right; right. apply -> Forall_forall; eauto. - Qed. - - (** [ForallPairs] implies [ForallOrdPairs]. The reverse implication is true - only when [R] is symmetric and reflexive. *) - - Lemma ForallPairs_ForallOrdPairs l: ForallPairs l -> ForallOrdPairs l. - Proof. - induction l as [|a l IHl]; [easy|]. - intros H. constructor. - - rewrite Forall_forall. intros; apply H; simpl; auto. - - apply IHl. red; intros; apply H; simpl; auto. - Qed. - - Lemma ForallOrdPairs_ForallPairs : - (forall x, R x x) -> - (forall x y, R x y -> R y x) -> - forall l, ForallOrdPairs l -> ForallPairs l. - Proof. - intros Refl Sym l Hl x y Hx Hy. - destruct (ForallOrdPairs_In Hl _ _ Hx Hy); subst; intuition. - Qed. -End ForallPairs. - -Lemma NoDup_iff_ForallOrdPairs [A] (l: list A): - NoDup l <-> ForallOrdPairs (fun a b => a <> b) l. -Proof. - split; intro H. - - induction H; constructor. - + apply Forall_forall. - intros y Hy ->. contradiction. - + assumption. - - induction H as [|a l H1 H2]; constructor. - + rewrite Forall_forall in H1. intro E. - contradiction (H1 a E). reflexivity. - + assumption. -Qed. - -Lemma NoDup_map_NoDup_ForallPairs [A B] (f: A->B) (l: list A) : - ForallPairs (fun x y => f x = f y -> x = y) l -> NoDup l -> NoDup (map f l). -Proof. - intros Hinj Hl. - induction Hl as [|x ?? _ IH]; cbn; constructor. - - intros [y [??]]%in_map_iff. - destruct (Hinj y x); cbn; auto. - - apply IH. - intros x' y' Hx' Hy'. - now apply Hinj; right. -Qed. - -Lemma NoDup_concat [A] (L: list (list A)): - Forall (@NoDup A) L -> - ForallOrdPairs (fun l1 l2 => forall a, In a l1 -> ~ In a l2) L -> - NoDup (concat L). -Proof. - intros H1 H2. induction L as [|l1 L IHL]; [constructor|]. - cbn. apply NoDup_app. - - apply Forall_inv in H1. assumption. - - apply IHL. - + apply Forall_inv_tail in H1. assumption. - + inversion H2. assumption. - - intros a aInl1 ainL%in_concat. destruct ainL as [l2 [l2inL ainL2]]. - inversion H2 as [|l L' H3]. - rewrite Forall_forall in H3. - apply (H3 _ l2inL _ aInl1). assumption. -Qed. - -Section Repeat. - - Variable A : Type. - - Local Notation repeat := (@repeat A). - - Theorem repeat_length x n: - length (repeat x n) = n. - Proof. - induction n as [| k Hrec]; simpl; rewrite ?Hrec; reflexivity. - Qed. - - Theorem repeat_spec n x y: - In y (repeat x n) -> y=x. - Proof. - induction n as [|k Hrec]; simpl; destruct 1; auto. - Qed. - - Lemma repeat_cons n a : - a :: repeat a n = repeat a n ++ [a]. - Proof. - induction n as [|n IHn]; simpl. - - reflexivity. - - f_equal; apply IHn. - Qed. - - Lemma repeat_app x n m : - repeat x (n + m) = repeat x n ++ repeat x m. - Proof. - induction n as [|n IHn]; simpl; auto. - now rewrite IHn. - Qed. - - Lemma repeat_eq_app x n l1 l2 : - repeat x n = l1 ++ l2 -> repeat x (length l1) = l1 /\ repeat x (length l2) = l2. - Proof. - revert n; induction l1 as [|a l1 IHl1]; simpl; intros n Hr; subst. - - repeat split; now rewrite repeat_length. - - destruct n; inversion Hr as [ [Heq Hr0] ]; subst. - now apply IHl1 in Hr0 as [-> ->]. - Qed. - - Lemma repeat_eq_cons x y n l : - repeat x n = y :: l -> x = y /\ repeat x (pred n) = l. - Proof. - intros Hr. - destruct n; inversion_clear Hr; auto. - Qed. - - Lemma repeat_eq_elt x y n l1 l2 : - repeat x n = l1 ++ y :: l2 -> x = y /\ repeat x (length l1) = l1 /\ repeat x (length l2) = l2. - Proof. - intros Hr; apply repeat_eq_app in Hr as [Hr1 Hr2]; subst. - apply repeat_eq_cons in Hr2; intuition. - Qed. - - Lemma Forall_eq_repeat x l : - Forall (eq x) l -> l = repeat x (length l). - Proof. - induction l as [|a l IHl]; simpl; intros HF; auto. - inversion_clear HF as [ | ? ? ? HF']; subst. - now rewrite (IHl HF') at 1. - Qed. - - Hypothesis decA : forall x y : A, {x = y}+{x <> y}. - - Lemma count_occ_repeat_eq x y n : x = y -> count_occ decA (repeat y n) x = n. - Proof. - intros ->. - induction n; cbn; auto. - destruct (decA y y); auto. - exfalso; intuition. - Qed. - - Lemma count_occ_repeat_neq x y n : x <> y -> count_occ decA (repeat y n) x = 0. - Proof. - intros Hneq. - induction n; cbn; auto. - destruct (decA y x); auto. - exfalso; intuition. - Qed. - - Lemma count_occ_unique x l : count_occ decA l x = length l -> l = repeat x (length l). - Proof. - induction l as [|h l]; cbn; intros Hocc; auto. - destruct (decA h x). - - f_equal; intuition. - - assert (Hb := count_occ_bound decA x l). - rewrite Hocc in Hb. - exfalso; apply (Nat.nle_succ_diag_l _ Hb). - Qed. - - Lemma count_occ_repeat_excl x l : - (forall y, y <> x -> count_occ decA l y = 0) -> l = repeat x (length l). - Proof. - intros Hocc. - apply Forall_eq_repeat, Forall_forall; intros z Hin. - destruct (decA z x) as [Heq|Hneq]; auto. - apply Hocc, count_occ_not_In in Hneq; intuition. - Qed. - - Lemma count_occ_sgt l x : l = [x] <-> - count_occ decA l x = 1 /\ forall y, y <> x -> count_occ decA l y = 0. - Proof. - split. - - intros ->; cbn; split; intros; destruct decA; subst; intuition. - - intros [Heq Hneq]. - apply count_occ_repeat_excl in Hneq. - rewrite Hneq, count_occ_repeat_eq in Heq; trivial. - now rewrite Heq in Hneq. - Qed. - - Lemma nth_repeat a m n : - nth n (repeat a m) a = a. - Proof. - revert n. induction m as [|m IHm]. - - now intros [|n]. - - intros [|n]; [reflexivity|exact (IHm n)]. - Qed. - - Lemma nth_repeat_lt a m n d : - n < m -> - nth n (repeat a m) d = a. - Proof. - revert n. induction m as [|m IHm]. - - now intros [|n]. - - intros [|n]; [reflexivity|]. - intros Hlt%Nat.succ_lt_mono. apply (IHm _ Hlt). - Qed. - - Lemma nth_error_repeat a m n : - n < m -> nth_error (repeat a m) n = Some a. - Proof. - intro Hnm. rewrite (nth_error_nth' _ a). - - now rewrite nth_repeat. - - now rewrite repeat_length. - Qed. - -End Repeat. -Notation repeat := repeat. - -Lemma repeat_to_concat A n (a:A) : - repeat a n = concat (repeat [a] n). -Proof. - induction n as [|n IHn]; simpl. - - reflexivity. - - f_equal; apply IHn. -Qed. - -Lemma map_repeat A B (a:A) n (f : A -> B): - map f (repeat a n) = repeat (f a) n. -Proof. - induction n as [|n IHn]. - - reflexivity. - - cbn. f_equal. exact IHn. -Qed. - -Lemma map_const (A B : Type) (b : B) (l : list A) : - map (fun _ => b) l = repeat b (length l). -Proof. induction l; cbn [repeat map length]; congruence. Qed. - -Lemma rev_repeat A n (a:A): - rev (repeat a n) = repeat a n. -Proof. - induction n as [|n IHn]. - - reflexivity. - - cbn. rewrite IHn. symmetry. apply repeat_cons. -Qed. - -Lemma fst_list_prod [A B] l l' : map fst (@list_prod A B l l') = - flat_map (fun a => repeat a (length l')) l. -Proof. - revert l'; induction l; intros; trivial. cbn. - erewrite map_app, map_map, map_ext, map_const; eauto using f_equal2. -Qed. -#[deprecated(use = fst_list_prod)] -Notation map_fst_list_prod := fst_list_prod (only parsing). - -Lemma snd_list_prod [A B] l l' : map snd (@list_prod A B l l') = - concat (repeat l' (length l)). -Proof. - revert l'; induction l; intros; trivial. cbn. - erewrite map_app, map_map, map_ext, map_id; eauto using f_equal2. -Qed. -#[deprecated(use = snd_list_prod)] -Notation map_snd_list_prod := snd_list_prod (only parsing). - -(** Sum of elements of a list of [nat]: [list_sum] *) - -Definition list_sum l := fold_right plus 0 l. - -Lemma list_sum_app : forall l1 l2, - list_sum (l1 ++ l2) = list_sum l1 + list_sum l2. -Proof. -intro l1; induction l1 as [|a l1 IHl1]; intros l2; [ reflexivity | ]. -simpl; rewrite IHl1. -apply Nat.add_assoc. -Qed. - -Lemma length_concat A l: - length (concat l) = list_sum (map (@length A) l). -Proof. - induction l; [reflexivity|]. - simpl. rewrite length_app. - f_equal. assumption. -Qed. - -Lemma length_flat_map A B (f: A -> list B) l: - length (flat_map f l) = list_sum (map (fun x => length (f x)) l). -Proof. - rewrite flat_map_concat_map, length_concat, map_map. reflexivity. -Qed. - -Corollary flat_map_constant_length A B c (f: A -> list B) l: - (forall x, In x l -> length (f x) = c) -> length (flat_map f l) = (length l) * c. -Proof. - intro H. rewrite length_flat_map. - induction l as [ | a l IHl ]; [reflexivity|]. - simpl. rewrite IHl, H; [reflexivity | left; reflexivity | ]. - intros x Hx. apply H. right. assumption. -Qed. - -Lemma length_list_power (A B:Type)(l:list A) (l':list B): - length (list_power l l') = (length l')^(length l). -Proof. - induction l as [ | a m IH ]; [reflexivity|]. - cbn. rewrite flat_map_constant_length with (c := length l'). - - rewrite IH. apply Nat.mul_comm. - - intros x H. apply length_map. -Qed. - -(** Max of elements of a list of [nat]: [list_max] *) - -Definition list_max l := fold_right max 0 l. - -Lemma list_max_app : forall l1 l2, - list_max (l1 ++ l2) = max (list_max l1) (list_max l2). -Proof. -intro l1; induction l1 as [|a l1 IHl1]; intros l2; [ reflexivity | ]. -now simpl; rewrite IHl1, Nat.max_assoc. -Qed. - -Lemma list_max_le : forall l n, - list_max l <= n <-> Forall (fun k => k <= n) l. -Proof. - intro l; induction l as [|a l IHl]; simpl; intros n; split. - - now intros. - - intros. now apply Nat.le_0_l. - - intros [? ?] %Nat.max_lub_iff. now constructor; [|apply IHl]. - - now rewrite Forall_cons_iff, <- IHl, Nat.max_lub_iff. -Qed. - -Lemma list_max_lt : forall l n, l <> [] -> - list_max l < n <-> Forall (fun k => k < n) l. -Proof. -intro l; induction l as [|a l IHl]; simpl; intros n Hnil; split; intros H; intuition. -- destruct l. - + repeat constructor. - now simpl in H; rewrite Nat.max_0_r in H. - + apply Nat.max_lub_lt_iff in H. - now constructor; [ | apply IHl ]. -- destruct l; inversion_clear H as [ | ? ? Hlt HF ]. - + now simpl; rewrite Nat.max_0_r. - + apply IHl in HF. - * now apply Nat.max_lub_lt_iff. - * intros Heq; inversion Heq. -Qed. - - -(** * Inversion of predicates over lists based on head symbol *) - -Ltac is_list_constr c := - match c with - | [] => idtac - | _ :: _ => idtac - | _ => fail - end. - -Ltac invlist f := - match goal with - | H:f ?l |- _ => is_list_constr l; inversion_clear H; invlist f - | H:f _ ?l |- _ => is_list_constr l; inversion_clear H; invlist f - | H:f _ _ ?l |- _ => is_list_constr l; inversion_clear H; invlist f - | H:f _ _ _ ?l |- _ => is_list_constr l; inversion_clear H; invlist f - | H:f _ _ _ _ ?l |- _ => is_list_constr l; inversion_clear H; invlist f - | _ => idtac - end. - - - -(** * Exporting hints and tactics *) - - -Global Hint Rewrite - rev_involutive (* rev (rev l) = l *) - rev_unit (* rev (l ++ a :: nil) = a :: rev l *) - map_nth (* nth n (map f l) (f d) = f (nth n l d) *) - length_map (* length (map f l) = length l *) - length_seq (* length (seq start len) = len *) - length_app (* length (l ++ l') = length l + length l' *) - length_rev (* length (rev l) = length l *) - app_nil_r (* l ++ nil = l *) - : list. - -Ltac simpl_list := autorewrite with list. -Ltac ssimpl_list := autorewrite with list using simpl. - -(* begin hide *) -(* Compatibility notations after the migration of [list] to [Datatypes] *) -Notation list := list (only parsing). -Notation list_rect := list_rect (only parsing). -Notation list_rec := list_rec (only parsing). -Notation list_ind := list_ind (only parsing). -Notation nil := nil (only parsing). -Notation cons := cons (only parsing). -Notation length := length (only parsing). -Notation app := app (only parsing). -(* Compatibility Names *) -Notation tail := tl (only parsing). -Notation head := hd_error (only parsing). -Notation head_nil := hd_error_nil (only parsing). -Notation head_cons := hd_error_cons (only parsing). -#[deprecated(since = "8.18", use = app_assoc)] -Notation ass_app := app_assoc (only parsing). -#[deprecated(since = "8.18", use = app_assoc)] -Notation app_ass := app_assoc_reverse_deprecated (only parsing). -Notation In_split := in_split (only parsing). -Notation In_rev := in_rev (only parsing). -Notation In_dec := in_dec (only parsing). -Notation distr_rev := rev_app_distr (only parsing). -Notation rev_acc := rev_append (only parsing). -Notation rev_acc_rev := rev_append_rev (only parsing). -Notation AllS := Forall (only parsing). (* was formerly in TheoryList *) - -#[deprecated(since = "8.18", use = app_nil_r)] -Notation app_nil_end := app_nil_end_deprecated (only parsing). -#[deprecated(since = "8.18", use = app_assoc)] -Notation app_assoc_reverse := app_assoc_reverse_deprecated (only parsing). -#[deprecated(since = "8.20", use = nth_error_cons_succ)] -Notation nth_error_cons_S := nth_error_cons_succ. - -#[global] -Hint Resolve app_nil_end_deprecated : datatypes. - -#[deprecated(since = "8.20", use = length_app)] -Notation app_length := length_app (only parsing). -#[deprecated(since = "8.20", use = length_rev)] -Notation rev_length := length_rev (only parsing). -#[deprecated(since = "8.20", use = length_map)] -Notation map_length := length_map (only parsing). -#[deprecated(since = "8.20", use = fold_left_S_0)] -Notation fold_left_length := fold_left_S_0 (only parsing). -#[deprecated(since = "8.20", use = length_fst_split)] -Notation split_length_l := length_fst_split (only parsing). -#[deprecated(since = "8.20", use = length_snd_split)] -Notation split_length_r := length_snd_split (only parsing). -#[deprecated(since = "8.20", use = length_combine)] -Notation combine_length := length_combine (only parsing). -#[deprecated(since = "8.20", use = length_prod)] -Notation prod_length := length_prod (only parsing). -#[deprecated(since = "8.20", use = length_firstn)] -Notation firstn_length := length_firstn (only parsing). -#[deprecated(since = "8.20", use = length_skipn)] -Notation skipn_length := length_skipn (only parsing). -#[deprecated(since = "8.20", use = length_seq)] -Notation seq_length := length_seq (only parsing). -#[deprecated(since = "8.20", use = length_concat)] -Notation concat_length := length_concat (only parsing). -#[deprecated(since = "8.20", use = length_flat_map)] -Notation flat_map_length := length_flat_map (only parsing). -#[deprecated(since = "8.20", use = length_list_power)] -Notation nth_error_O := nth_error_0 (only parsing). -Notation firstn_O := firstn_0 (only parsing). -Notation skipn_O := skipn_0 (only parsing). -Notation list_power_length := length_list_power (only parsing). -(* end hide *) - - -(* Unset Universe Polymorphism. *) diff --git a/stdlib/theories/Lists/ListDec.v b/stdlib/theories/Lists/ListDec.v deleted file mode 100644 index 2d35a9804e0b..000000000000 --- a/stdlib/theories/Lists/ListDec.v +++ /dev/null @@ -1,128 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* exists a l1 l2 l3, l = l1++a::l2++a::l3. -Proof using A dec. -intro H0. induction l as [|a l IHl]. -- contradiction H0; constructor. -- destruct (NoDup_decidable l) as [H1|H1]. - + destruct (In_decidable a l) as [H2|H2]. - * destruct (in_split _ _ H2) as (l1 & l2 & ->). - now exists a, nil, l1, l2. - * now contradiction H0; constructor. - + destruct (IHl H1) as (b & l1 & l2 & l3 & ->). - now exists b, (a::l1), l2, l3. -Qed. - -Lemma NoDup_list_decidable (l:list A) : NoDup l -> forall x y:A, In x l -> In y l -> decidable (x=y). -Proof using A. - clear dec; intros Hl; induction Hl; firstorder congruence. -Qed. - -End Dec_in_Prop. - -Section Dec_in_Type. -Variables (A:Type)(dec : forall x y:A, {x=y}+{x<>y}). - -Definition In_dec := List.In_dec dec. (* Already in List.v *) - -Lemma incl_dec (l l':list A) : {incl l l'}+{~incl l l'}. -Proof using A dec. - induction l as [|a l IH]. - - left. inversion 1. - - destruct (In_dec a l') as [IN|IN]. - + destruct IH as [IC|IC]. - * left. destruct 1; subst; auto. - * right. contradict IC. intros x H. apply IC; now right. - + right. contradict IN. apply IN; now left. -Qed. - -Lemma NoDup_dec (l:list A) : {NoDup l}+{~NoDup l}. -Proof using A dec. - induction l as [|a l IH]. - - left; now constructor. - - destruct (In_dec a l). - + right. inversion_clear 1. tauto. - + destruct IH. - * left. now constructor. - * right. inversion_clear 1. tauto. -Qed. - -End Dec_in_Type. - -(** An extra result: thanks to decidability, a list can be purged - from redundancies. *) - -Lemma uniquify_map A B (d:decidable_eq B)(f:A->B)(l:list A) : - exists l', NoDup (map f l') /\ incl (map f l) (map f l'). -Proof. - induction l as [|a l IHl]. - - exists nil. simpl. split; [now constructor | red; trivial]. - - destruct IHl as (l' & N & I). - destruct (In_decidable d (f a) (map f l')). - + exists l'; simpl; split; trivial. - intros x [Hx|Hx]. - * now subst. - * now apply I. - + exists (a::l'); simpl; split. - * now constructor. - * intros x [Hx|Hx]. - -- subst; now left. - -- right; now apply I. -Qed. - -Lemma uniquify A (d:decidable_eq A)(l:list A) : - exists l', NoDup l' /\ incl l l'. -Proof. - destruct (uniquify_map d id l) as (l',H). - exists l'. now rewrite !map_id in H. -Qed. diff --git a/stdlib/theories/Lists/ListDef.v b/stdlib/theories/Lists/ListDef.v deleted file mode 100644 index aa3414c0fc71..000000000000 --- a/stdlib/theories/Lists/ListDef.v +++ /dev/null @@ -1 +0,0 @@ -From Corelib Require Export ListDef. diff --git a/stdlib/theories/Lists/ListSet.v b/stdlib/theories/Lists/ListSet.v deleted file mode 100644 index 6a08ab896481..000000000000 --- a/stdlib/theories/Lists/ListSet.v +++ /dev/null @@ -1,497 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* y}. - - Definition set := list A. - - Definition empty_set : set := nil. - - Fixpoint set_add (a:A) (x:set) : set := - match x with - | nil => a :: nil - | a1 :: x1 => - match Aeq_dec a a1 with - | left _ => a1 :: x1 - | right _ => a1 :: set_add a x1 - end - end. - - - Fixpoint set_mem (a:A) (x:set) : bool := - match x with - | nil => false - | a1 :: x1 => - match Aeq_dec a a1 with - | left _ => true - | right _ => set_mem a x1 - end - end. - - (** If [a] belongs to [x], removes [a] from [x]. If not, does nothing. - Invariant: any element should occur at most once in [x], see for - instance [set_add]. We hence remove here only the first occurrence - of [a] in [x]. *) - - Fixpoint set_remove (a:A) (x:set) : set := - match x with - | nil => empty_set - | a1 :: x1 => - match Aeq_dec a a1 with - | left _ => x1 - | right _ => a1 :: set_remove a x1 - end - end. - - Fixpoint set_inter (x:set) : set -> set := - match x with - | nil => fun y => nil - | a1 :: x1 => - fun y => - if set_mem a1 y then a1 :: set_inter x1 y else set_inter x1 y - end. - - Fixpoint set_union (x y:set) : set := - match y with - | nil => x - | a1 :: y1 => set_add a1 (set_union x y1) - end. - - (** returns the set of all els of [x] that does not belong to [y] *) - Fixpoint set_diff (x y:set) : set := - match x with - | nil => nil - | a1 :: x1 => - if set_mem a1 y then set_diff x1 y else set_add a1 (set_diff x1 y) - end. - - - Definition set_In : A -> set -> Prop := In (A:=A). - - Lemma set_In_dec : forall (a:A) (x:set), {set_In a x} + {~ set_In a x}. - Proof. exact (List.In_dec Aeq_dec). Qed. - - Lemma set_mem_ind : - forall (B:Type) (P:B -> Prop) (y z:B) (a:A) (x:set), - (set_In a x -> P y) -> P z -> P (if set_mem a x then y else z). - - Proof. - simple induction x; simpl; intros. - - assumption. - - elim (Aeq_dec a a0); auto with datatypes. - Qed. - - Lemma set_mem_ind2 : - forall (B:Type) (P:B -> Prop) (y z:B) (a:A) (x:set), - (set_In a x -> P y) -> - (~ set_In a x -> P z) -> P (if set_mem a x then y else z). - - Proof. - simple induction x; simpl; intros. - - apply H0; red; trivial. - - case (Aeq_dec a a0); auto with datatypes. - intro Hneg; apply H; intros; auto. - apply H1; red; intro. - case H3; auto. - Qed. - - - Lemma set_mem_correct1 : - forall (a:A) (x:set), set_mem a x = true -> set_In a x. - Proof. - simple induction x; simpl. - - discriminate. - - intros a0 l; elim (Aeq_dec a a0); auto with datatypes. - Qed. - - Lemma set_mem_correct2 : - forall (a:A) (x:set), set_In a x -> set_mem a x = true. - Proof. - simple induction x; simpl. - - intro Ha; elim Ha. - - intros a0 l; elim (Aeq_dec a a0); auto with datatypes. - intros H1 H2 [H3| H4]. - + absurd (a0 = a); auto with datatypes. - + auto with datatypes. - Qed. - - Lemma set_mem_complete1 : - forall (a:A) (x:set), set_mem a x = false -> ~ set_In a x. - Proof. - simple induction x; simpl. - - tauto. - - intros a0 l; elim (Aeq_dec a a0). - + intros _ _ [=]. - + unfold not; intros H H0 H1 [|]; auto with datatypes. - Qed. - - Lemma set_mem_complete2 : - forall (a:A) (x:set), ~ set_In a x -> set_mem a x = false. - Proof. - simple induction x; simpl. - - tauto. - - intros a0 l; elim (Aeq_dec a a0). - + intros H H0 []; auto with datatypes. - + tauto. - Qed. - - Lemma set_add_intro1 : - forall (a b:A) (x:set), set_In a x -> set_In a (set_add b x). - - Proof. - unfold set_In; simple induction x; simpl. - - auto with datatypes. - - intros a0 l H [Ha0a| Hal]. - + elim (Aeq_dec b a0); left; assumption. - + elim (Aeq_dec b a0); right; [ assumption | auto with datatypes ]. - Qed. - - Lemma set_add_intro2 : - forall (a b:A) (x:set), a = b -> set_In a (set_add b x). - - Proof. - unfold set_In; simple induction x; simpl. - - auto with datatypes. - - intros a0 l H Hab. - elim (Aeq_dec b a0); - [ rewrite Hab; intro Hba0; rewrite Hba0; simpl; - auto with datatypes - | auto with datatypes ]. - Qed. - - #[local] - Hint Resolve set_add_intro1 set_add_intro2 : core. - - Lemma set_add_intro : - forall (a b:A) (x:set), a = b \/ set_In a x -> set_In a (set_add b x). - - Proof. - intros a b x [H1| H2]; auto with datatypes. - Qed. - - Lemma set_add_elim : - forall (a b:A) (x:set), set_In a (set_add b x) -> a = b \/ set_In a x. - - Proof. - unfold set_In. - simple induction x. - - simpl; intros [H1| H2]; auto with datatypes. - - simpl; do 3 intro. - elim (Aeq_dec b a0). - + simpl; tauto. - + simpl; intros H0 [|]. - * trivial with datatypes. - tauto. - * tauto. - Qed. - - Lemma set_add_elim2 : - forall (a b:A) (x:set), set_In a (set_add b x) -> a <> b -> set_In a x. - intros a b x H; case (set_add_elim _ _ _ H); intros; trivial. - case H1; trivial. - Qed. - - #[local] - Hint Resolve set_add_intro set_add_elim set_add_elim2 : core. - - Lemma set_add_not_empty : forall (a:A) (x:set), set_add a x <> empty_set. - Proof. - simple induction x; simpl. - - discriminate. - - intros; elim (Aeq_dec a a0); intros; discriminate. - Qed. - - Lemma set_add_iff a b l : In a (set_add b l) <-> a = b \/ In a l. - Proof. - split. - - apply set_add_elim. - - apply set_add_intro. - Qed. - - Lemma set_add_nodup a l : NoDup l -> NoDup (set_add a l). - Proof. - induction 1 as [|x l H H' IH]; simpl. - - constructor; [ tauto | constructor ]. - - destruct (Aeq_dec a x) as [<-|Hax]; constructor; trivial. - rewrite set_add_iff. intuition. - Qed. - - Lemma set_remove_1 (a b : A) (l : set) : - In a (set_remove b l) -> In a l. - Proof. - induction l as [|x xs Hrec]. - - intros. auto. - - simpl. destruct (Aeq_dec b x). - * tauto. - * intro H. destruct H. - + rewrite H. apply in_eq. - + apply in_cons. apply Hrec. assumption. - Qed. - - Lemma set_remove_2 (a b:A) (l : set) : - NoDup l -> In a (set_remove b l) -> a <> b. - Proof. - induction l as [|x l IH]; intro ND; simpl. - - tauto. - - inversion_clear ND. - destruct (Aeq_dec b x) as [<-|Hbx]. - + congruence. - + destruct 1; subst; auto. - Qed. - - Lemma set_remove_3 (a b : A) (l : set) : - In a l -> a <> b -> In a (set_remove b l). - Proof. - induction l as [|x xs Hrec]. - - now simpl. - - simpl. destruct (Aeq_dec b x) as [<-|Hbx]; simpl; intuition. - congruence. - Qed. - - Lemma set_remove_iff (a b : A) (l : set) : - NoDup l -> (In a (set_remove b l) <-> In a l /\ a <> b). - Proof. - split; try split. - - eapply set_remove_1; eauto. - - eapply set_remove_2; eauto. - - destruct 1; apply set_remove_3; auto. - Qed. - - Lemma set_remove_nodup a l : NoDup l -> NoDup (set_remove a l). - Proof. - induction 1 as [|x l H H' IH]; simpl. - - constructor. - - destruct (Aeq_dec a x) as [<-|Hax]; trivial. - constructor; trivial. - rewrite set_remove_iff; trivial. intuition. - Qed. - - Lemma set_union_intro1 : - forall (a:A) (x y:set), set_In a x -> set_In a (set_union x y). - Proof. - simple induction y; simpl; auto with datatypes. - Qed. - - Lemma set_union_intro2 : - forall (a:A) (x y:set), set_In a y -> set_In a (set_union x y). - Proof. - simple induction y; simpl. - - tauto. - - intros; elim H0; auto with datatypes. - Qed. - - #[local] - Hint Resolve set_union_intro2 set_union_intro1 : core. - - Lemma set_union_intro : - forall (a:A) (x y:set), - set_In a x \/ set_In a y -> set_In a (set_union x y). - Proof. - intros; elim H; auto with datatypes. - Qed. - - Lemma set_union_elim : - forall (a:A) (x y:set), - set_In a (set_union x y) -> set_In a x \/ set_In a y. - Proof. - simple induction y; simpl. - - auto with datatypes. - - intros. - generalize (set_add_elim _ _ _ H0). - intros [H1| H1]. - + auto with datatypes. - + tauto. - Qed. - - Lemma set_union_iff a l l': In a (set_union l l') <-> In a l \/ In a l'. - Proof. - split. - - apply set_union_elim. - - apply set_union_intro. - Qed. - - Lemma set_union_nodup l l' : NoDup l -> NoDup l' -> NoDup (set_union l l'). - Proof. - induction 2 as [|x' l' ? ? IH]; simpl; trivial. now apply set_add_nodup. - Qed. - - Lemma set_union_emptyL : - forall (a:A) (x:set), set_In a (set_union empty_set x) -> set_In a x. - intros a x H; case (set_union_elim _ _ _ H); auto || contradiction. - Qed. - - Lemma set_union_emptyR : - forall (a:A) (x:set), set_In a (set_union x empty_set) -> set_In a x. - intros a x H; case (set_union_elim _ _ _ H); auto || contradiction. - Qed. - - Lemma set_inter_intro : - forall (a:A) (x y:set), - set_In a x -> set_In a y -> set_In a (set_inter x y). - Proof. - simple induction x. - - auto with datatypes. - - simpl; intros a0 l Hrec y [Ha0a| Hal] Hy. - + simpl; rewrite Ha0a. - generalize (set_mem_correct1 a y). - generalize (set_mem_complete1 a y). - elim (set_mem a y); simpl; intros. - * auto with datatypes. - * absurd (set_In a y); auto with datatypes. - + elim (set_mem a0 y); [ right; auto with datatypes | auto with datatypes ]. - Qed. - - Lemma set_inter_elim1 : - forall (a:A) (x y:set), set_In a (set_inter x y) -> set_In a x. - Proof. - simple induction x. - - auto with datatypes. - - simpl; intros a0 l Hrec y. - generalize (set_mem_correct1 a0 y). - elim (set_mem a0 y); simpl; intros. - + elim H0; eauto with datatypes. - + eauto with datatypes. - Qed. - - Lemma set_inter_elim2 : - forall (a:A) (x y:set), set_In a (set_inter x y) -> set_In a y. - Proof. - simple induction x. - - simpl; tauto. - - simpl; intros a0 l Hrec y. - generalize (set_mem_correct1 a0 y). - elim (set_mem a0 y); simpl; intros. - + elim H0; - [ intro Hr; rewrite <- Hr; eauto with datatypes | eauto with datatypes ]. - + eauto with datatypes. - Qed. - - #[local] - Hint Resolve set_inter_elim1 set_inter_elim2 : core. - - Lemma set_inter_elim : - forall (a:A) (x y:set), - set_In a (set_inter x y) -> set_In a x /\ set_In a y. - Proof. - eauto with datatypes. - Qed. - - Lemma set_inter_iff a l l' : In a (set_inter l l') <-> In a l /\ In a l'. - Proof. - split. - - apply set_inter_elim. - - destruct 1. now apply set_inter_intro. - Qed. - - Lemma set_inter_nodup l l' : NoDup l -> NoDup l' -> NoDup (set_inter l l'). - Proof. - induction 1 as [|x l H H' IH]; intro Hl'; simpl. - - constructor. - - destruct (set_mem x l'); auto. - constructor; auto. rewrite set_inter_iff; tauto. - Qed. - - Lemma set_diff_intro : - forall (a:A) (x y:set), - set_In a x -> ~ set_In a y -> set_In a (set_diff x y). - Proof. - simple induction x. - - simpl; tauto. - - simpl; intros a0 l Hrec y [Ha0a| Hal] Hay. - + rewrite Ha0a; generalize (set_mem_complete2 _ _ Hay). - elim (set_mem a y); - [ intro Habs; discriminate Habs | auto with datatypes ]. - + elim (set_mem a0 y); auto with datatypes. - Qed. - - Lemma set_diff_elim1 : - forall (a:A) (x y:set), set_In a (set_diff x y) -> set_In a x. - Proof. - simple induction x. - - simpl; tauto. - - simpl; intros a0 l Hrec y; elim (set_mem a0 y). - + eauto with datatypes. - + intro; generalize (set_add_elim _ _ _ H). - intros [H1| H2]; eauto with datatypes. - Qed. - - Lemma set_diff_elim2 : - forall (a:A) (x y:set), set_In a (set_diff x y) -> ~ set_In a y. - intros a x y; elim x; simpl. - - intros; contradiction. - - intros a0 l Hrec. - apply set_mem_ind2; auto. - intros H1 H2; case (set_add_elim _ _ _ H2); intros; auto. - rewrite H; trivial. - Qed. - - Lemma set_diff_iff a l l' : In a (set_diff l l') <-> In a l /\ ~In a l'. - Proof. - split. - - split; [eapply set_diff_elim1 | eapply set_diff_elim2]; eauto. - - destruct 1. now apply set_diff_intro. - Qed. - - Lemma set_diff_nodup l l' : NoDup l -> NoDup (set_diff l l'). - Proof. - induction 1 as [|x l H IH]; simpl. - - constructor. - - destruct (set_mem x l'); auto using set_add_nodup. - Qed. - - Lemma set_diff_trivial : forall (a:A) (x:set), ~ set_In a (set_diff x x). - red; intros a x H. - apply (set_diff_elim2 _ _ _ H). - apply (set_diff_elim1 _ _ _ H). - Qed. - -#[local] -Hint Resolve set_diff_intro set_diff_trivial : core. - - -End first_definitions. - -Section other_definitions. - - Definition set_prod : forall {A B:Type}, set A -> set B -> set (A * B) := - list_prod. - - (** [B^A], set of applications from [A] to [B] *) - Definition set_power : forall {A B:Type}, set A -> set B -> set (set (A * B)) := - list_power. - - Definition set_fold_left {A B:Type} : (B -> A -> B) -> set A -> B -> B := - fold_left (A:=B) (B:=A). - - Definition set_fold_right {A B:Type} (f:A -> B -> B) (x:set A) - (b:B) : B := fold_right f b x. - - Definition set_map {A B:Type} (Aeq_dec : forall x y:B, {x = y} + {x <> y}) - (f : A -> B) (x : set A) : set B := - set_fold_right (fun a => set_add Aeq_dec (f a)) x (empty_set B). - -End other_definitions. - -Unset Implicit Arguments. diff --git a/stdlib/theories/Lists/ListTactics.v b/stdlib/theories/Lists/ListTactics.v deleted file mode 100644 index ddc311e69f7f..000000000000 --- a/stdlib/theories/Lists/ListTactics.v +++ /dev/null @@ -1,81 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* fcons x ltac:(list_fold_right fcons fnil tl) - | nil => fnil - end. - -(* A variant of list_fold_right, to prevent the match of list_fold_right - from catching errors raised by fcons. *) -Ltac lazy_list_fold_right fcons fnil l := - let f := - match l with - | ?x :: ?tl => - fun _ => - fcons x ltac:(fun _ => lazy_list_fold_right fcons fnil tl) - | nil => fun _ => fnil() - end in - f(). - -Ltac list_fold_left fcons fnil l := - match l with - | ?x :: ?tl => list_fold_left fcons ltac:(fcons x fnil) tl - | nil => fnil - end. - -Ltac list_iter f l := - match l with - | ?x :: ?tl => f x; list_iter f tl - | nil => idtac - end. - -Ltac list_iter_gen seq f l := - match l with - | ?x :: ?tl => - let t1 _ := f x in - let t2 _ := list_iter_gen seq f tl in - seq t1 t2 - | nil => idtac - end. - -Ltac AddFvTail a l := - match l with - | nil => constr:(a::nil) - | a :: _ => l - | ?x :: ?l => let l' := AddFvTail a l in constr:(x::l') - end. - -Ltac Find_at a l := - let rec find n l := - match l with - | nil => fail 100 "anomaly: Find_at" - | a :: _ => eval compute in n - | _ :: ?l => find (Pos.succ n) l - end - in find 1%positive l. - -Ltac check_is_list t := - match t with - | _ :: ?l => check_is_list l - | nil => idtac - | _ => fail 100 "anomaly: failed to build a canonical list" - end. - -Ltac check_fv l := - check_is_list l; - match type of l with - | list _ => idtac - | _ => fail 100 "anomaly: built an ill-typed list" - end. diff --git a/stdlib/theories/Lists/SetoidList.v b/stdlib/theories/Lists/SetoidList.v deleted file mode 100644 index c29aaab53f06..000000000000 --- a/stdlib/theories/Lists/SetoidList.v +++ /dev/null @@ -1,1110 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* A -> Prop. - -(** Being in a list modulo an equality relation over type [A]. *) - -Inductive InA (x : A) : list A -> Prop := - | InA_cons_hd : forall y l, eqA x y -> InA x (y :: l) - | InA_cons_tl : forall y l, InA x l -> InA x (y :: l). - -#[local] -Hint Constructors InA : core. - -(** TODO: it would be nice to have a generic definition instead - of the previous one. Having [InA = Exists eqA] raises too - many compatibility issues. For now, we only state the equivalence: *) - -Lemma InA_altdef : forall x l, InA x l <-> Exists (eqA x) l. -Proof. split; induction 1; auto. Qed. - -Lemma InA_cons : forall x y l, InA x (y::l) <-> eqA x y \/ InA x l. -Proof. - intuition. invlist InA; auto. -Qed. - -Lemma InA_nil : forall x, InA x nil <-> False. -Proof. - intuition. invlist InA. -Qed. - -(** An alternative definition of [InA]. *) - -Lemma InA_alt : forall x l, InA x l <-> exists y, eqA x y /\ In y l. -Proof. - intros; rewrite InA_altdef, Exists_exists; firstorder. -Qed. - -(** A list without redundancy modulo the equality over [A]. *) - -Inductive NoDupA : list A -> Prop := - | NoDupA_nil : NoDupA nil - | NoDupA_cons : forall x l, ~ InA x l -> NoDupA l -> NoDupA (x::l). - -#[local] -Hint Constructors NoDupA : core. - -(** An alternative definition of [NoDupA] based on [ForallOrdPairs] *) - -Lemma NoDupA_altdef : forall l, - NoDupA l <-> ForallOrdPairs (complement eqA) l. -Proof. - split; induction 1 as [|a l H rest]; constructor; auto. - - rewrite Forall_forall. intros b Hb. - intro Eq; elim H. rewrite InA_alt. exists b; auto. - - rewrite InA_alt; intros (a' & Haa' & Ha'). - rewrite Forall_forall in H. exact (H a' Ha' Haa'). -Qed. - - -(** lists with same elements modulo [eqA] *) - -Definition inclA l l' := forall x, InA x l -> InA x l'. -Definition equivlistA l l' := forall x, InA x l <-> InA x l'. - -Lemma incl_nil l : inclA nil l. -Proof. intros a H. inversion H. Qed. -#[local] -Hint Resolve incl_nil : list. - -(** lists with same elements modulo [eqA] at the same place *) - -Inductive eqlistA : list A -> list A -> Prop := - | eqlistA_nil : eqlistA nil nil - | eqlistA_cons : forall x x' l l', - eqA x x' -> eqlistA l l' -> eqlistA (x::l) (x'::l'). - -#[local] -Hint Constructors eqlistA : core. - -(** We could also have written [eqlistA = Forall2 eqA]. *) - -Lemma eqlistA_altdef : forall l l', eqlistA l l' <-> Forall2 eqA l l'. -Proof. split; induction 1; auto. Qed. - -(** Results concerning lists modulo [eqA] *) - -Hypothesis eqA_equiv : Equivalence eqA. -Definition eqarefl := (@Equivalence_Reflexive _ _ eqA_equiv). -Definition eqatrans := (@Equivalence_Transitive _ _ eqA_equiv). -Definition eqasym := (@Equivalence_Symmetric _ _ eqA_equiv). - -#[local] -Hint Resolve eqarefl eqatrans : core. -#[local] -Hint Immediate eqasym : core. - -Ltac inv := invlist InA; invlist sort; invlist lelistA; invlist NoDupA. - -(** First, the two notions [equivlistA] and [eqlistA] are indeed equivlances *) - -Global Instance equivlist_equiv : Equivalence equivlistA. -Proof. - firstorder. -Qed. - -Global Instance eqlistA_equiv : Equivalence eqlistA. -Proof. - constructor; red. - - intros x; induction x; auto. - - induction 1; auto. - - intros x y z H; revert z; induction H; auto. - inversion 1; subst; auto. invlist eqlistA; eauto with *. -Qed. -(** Moreover, [eqlistA] implies [equivlistA]. A reverse result - will be proved later for sorted list without duplicates. *) - -Global Instance eqlistA_equivlistA : subrelation eqlistA equivlistA. -Proof. - intros x x' H. induction H as [|? ? ? ? H ? IHeqlistA]. - - intuition auto with relations. - - red; intros x0. - rewrite 2 InA_cons. - rewrite (IHeqlistA x0), H; intuition. -Qed. - -(** InA is compatible with eqA (for its first arg) and with - equivlistA (and hence eqlistA) for its second arg *) - -Global Instance InA_compat : Proper (eqA==>equivlistA==>iff) InA. -Proof. - intros x x' Hxx' l l' Hll'. rewrite (Hll' x). - rewrite 2 InA_alt; firstorder. -Qed. - -(** For compatibility, an immediate consequence of [InA_compat] *) - -Lemma InA_eqA : forall l x y, eqA x y -> InA x l -> InA y l. -Proof. - intros l x y H H'. rewrite <- H. auto. -Qed. -#[local] -Hint Immediate InA_eqA : core. - -Lemma In_InA : forall l x, In x l -> InA x l. -Proof. - intros l; induction l; simpl; intuition. - subst; auto. -Qed. -#[local] -Hint Resolve In_InA : core. - -Lemma InA_split : forall l x, InA x l -> - exists l1 y l2, eqA x y /\ l = l1++y::l2. -Proof. -intros l; induction l as [|a l IHl]; intros x H; inv. -- exists (@nil A); exists a; exists l; auto. -- match goal with H' : InA x l |- _ => rename H' into H0 end. - destruct (IHl x H0) as (l1,(y,(l2,(H1,H2)))). - exists (a::l1); exists y; exists l2; auto. - split; simpl; f_equal; auto. -Qed. - -Lemma InA_app : forall l1 l2 x, - InA x (l1 ++ l2) -> InA x l1 \/ InA x l2. -Proof. - intros l1; induction l1 as [|a l1 IHl1]; simpl in *; intuition. - inv; auto. - match goal with H0' : InA _ (l1 ++ _) |- _ => rename H0' into H0 end. - elim (IHl1 _ _ H0); auto. -Qed. - -Lemma InA_app_iff : forall l1 l2 x, - InA x (l1 ++ l2) <-> InA x l1 \/ InA x l2. -Proof. - split. - - apply InA_app. - - destruct 1 as [H|H]; generalize H; do 2 rewrite InA_alt. - + destruct 1 as (y,(H1,H2)); exists y; split; auto. - apply in_or_app; auto. - + destruct 1 as (y,(H1,H2)); exists y; split; auto. - apply in_or_app; auto. -Qed. - -Lemma InA_rev : forall p m, - InA p (rev m) <-> InA p m. -Proof. - intros; do 2 rewrite InA_alt. - split; intros (y,H); exists y; intuition. - - rewrite In_rev; auto. - - rewrite <- In_rev; auto. -Qed. - -(** Some more facts about InA *) - -Lemma InA_singleton x y : InA x (y::nil) <-> eqA x y. -Proof. - rewrite InA_cons, InA_nil; tauto. -Qed. - -Lemma InA_double_head x y l : - InA x (y :: y :: l) <-> InA x (y :: l). -Proof. - rewrite !InA_cons; tauto. -Qed. - -Lemma InA_permute_heads x y z l : - InA x (y :: z :: l) <-> InA x (z :: y :: l). -Proof. - rewrite !InA_cons; tauto. -Qed. - -Lemma InA_app_idem x l : InA x (l ++ l) <-> InA x l. -Proof. - rewrite InA_app_iff; tauto. -Qed. - -Section NoDupA. - -Lemma NoDupA_app : forall l l', NoDupA l -> NoDupA l' -> - (forall x, InA x l -> InA x l' -> False) -> - NoDupA (l++l'). -Proof. -intros l; induction l as [|a l IHl]; simpl; auto; intros l' H H0 H1. -inv. -constructor. -- rewrite InA_alt; intros (y,(H4,H5)). - destruct (in_app_or _ _ _ H5). - + match goal with H2' : ~ InA a l |- _ => rename H2' into H2 end. - elim H2. - rewrite InA_alt. - exists y; auto. - + apply (H1 a). - * auto. - * rewrite InA_alt. - exists y; auto. -- apply IHl; auto. - intros x ? ?. - apply (H1 x); auto. -Qed. - -Lemma NoDupA_rev : forall l, NoDupA l -> NoDupA (rev l). -Proof. -intros l; induction l. -- simpl; auto. -- simpl; intros. - inv. - apply NoDupA_app; auto. - + constructor; auto. - intro; inv. - + intros x. - rewrite InA_alt. - intros (x1,(H2,H3)). - intro; inv. - match goal with H0 : ~ InA _ _ |- _ => destruct H0 end. - match goal with H4 : eqA x ?x' |- InA ?x' _ => rewrite <- H4, H2 end. - apply In_InA. - rewrite In_rev; auto. -Qed. - -Lemma NoDupA_split : forall l l' x, NoDupA (l++x::l') -> NoDupA (l++l'). -Proof. - intros l; induction l; simpl in *; intros; inv; auto. - constructor; eauto. - match goal with H0 : ~ InA _ _ |- _ => contradict H0 end. - rewrite InA_app_iff in *. - rewrite InA_cons. - intuition. -Qed. - -Lemma NoDupA_swap : forall l l' x, NoDupA (l++x::l') -> NoDupA (x::l++l'). -Proof. - intros l; induction l as [|a l IHl]; simpl in *; intros l' x H; inv; auto. - constructor; eauto. - - match goal with H1 : NoDupA (l ++ x :: l') |- _ => assert (H2:=IHl _ _ H1) end. - inv. - rewrite InA_cons. - red; destruct 1. - + match goal with H0 : ~ InA a (l ++ x :: l') |- _ => apply H0 end. - rewrite InA_app_iff in *; rewrite InA_cons; auto. - + auto. - - constructor. - + match goal with H0 : ~ InA a (l ++ x :: l') |- _ => contradict H0 end. - rewrite InA_app_iff in *; rewrite InA_cons; intuition. - + eapply NoDupA_split; eauto. -Qed. - -Lemma NoDupA_singleton x : NoDupA (x::nil). -Proof. - repeat constructor. inversion 1. -Qed. - -End NoDupA. - -Section EquivlistA. - -Global Instance equivlistA_cons_proper: - Proper (eqA ==> equivlistA ==> equivlistA) (@cons A). -Proof. - intros ? ? E1 ? ? E2 ?; now rewrite !InA_cons, E1, E2. -Qed. - -Global Instance equivlistA_app_proper: - Proper (equivlistA ==> equivlistA ==> equivlistA) (@app A). -Proof. - intros ? ? E1 ? ? E2 ?. now rewrite !InA_app_iff, E1, E2. -Qed. - -Lemma equivlistA_cons_nil x l : ~ equivlistA (x :: l) nil. -Proof. - intros E. now eapply InA_nil, E, InA_cons_hd. -Qed. - -Lemma equivlistA_nil_eq l : equivlistA l nil -> l = nil. -Proof. - destruct l. - - trivial. - - intros H. now apply equivlistA_cons_nil in H. -Qed. - -Lemma equivlistA_double_head x l : equivlistA (x :: x :: l) (x :: l). -Proof. - intro. apply InA_double_head. -Qed. - -Lemma equivlistA_permute_heads x y l : - equivlistA (x :: y :: l) (y :: x :: l). -Proof. - intro. apply InA_permute_heads. -Qed. - -Lemma equivlistA_app_idem l : equivlistA (l ++ l) l. -Proof. - intro. apply InA_app_idem. -Qed. - -Lemma equivlistA_NoDupA_split l l1 l2 x y : eqA x y -> - NoDupA (x::l) -> NoDupA (l1++y::l2) -> - equivlistA (x::l) (l1++y::l2) -> equivlistA l (l1++l2). -Proof. - intros H H0 H1 H2; intro a. - generalize (H2 a). - rewrite !InA_app_iff, !InA_cons. - inv. - assert (SW:=NoDupA_swap H1). inv. - rewrite InA_app_iff in *. - split; intros. - - match goal with H3 : ~ InA x l |- _ => - assert (~eqA a x) by (contradict H3; rewrite <- H3; auto) - end. - assert (~eqA a y) by (rewrite <- H; auto). - tauto. - - assert (OR : eqA a x \/ InA a l) by intuition. - destruct OR as [EQN|INA]; auto. - match goal with H0 : ~ (InA y l1 \/ InA y l2) |- _ => elim H0 end. - rewrite <-H,<-EQN; auto. -Qed. - -End EquivlistA. - -Section Fold. - -Variable B:Type. -Variable eqB:B->B->Prop. -Variable st:Equivalence eqB. -Variable f:A->B->B. -Variable i:B. -Variable Comp:Proper (eqA==>eqB==>eqB) f. - -Lemma fold_right_eqlistA : - forall s s', eqlistA s s' -> - eqB (fold_right f i s) (fold_right f i s'). -Proof. -induction 1; simpl; auto with relations. -apply Comp; auto. -Qed. - -(** Fold with restricted [transpose] hypothesis. *) - -Section Fold_With_Restriction. -Variable R : A -> A -> Prop. -Hypothesis R_sym : Symmetric R. -Hypothesis R_compat : Proper (eqA==>eqA==>iff) R. - - -(* - -(** [ForallOrdPairs R] is compatible with [equivlistA] over the - lists without duplicates, as long as the relation [R] - is symmetric and compatible with [eqA]. To prove this fact, - we use an auxiliary notion: "forall distinct pairs, ...". -*) - -Definition ForallNeqPairs := - ForallPairs (fun a b => ~eqA a b -> R a b). - -(** [ForallOrdPairs] and [ForallNeqPairs] are related, but not completely - equivalent. For proving one implication, we need to know that the - list has no duplicated elements... *) - -Lemma ForallNeqPairs_ForallOrdPairs : forall l, NoDupA l -> - ForallNeqPairs l -> ForallOrdPairs R l. -Proof. - induction l; auto. - constructor. inv. - rewrite Forall_forall; intros b Hb. - apply H0; simpl; auto. - contradict H1; rewrite H1; auto. - apply IHl. - inv; auto. - intros b c Hb Hc Hneq. - apply H0; simpl; auto. -Qed. - -(** ... and for proving the other implication, we need to be able - to reverse relation [R]. *) - -Lemma ForallOrdPairs_ForallNeqPairs : forall l, - ForallOrdPairs R l -> ForallNeqPairs l. -Proof. - intros l Hl x y Hx Hy N. - destruct (ForallOrdPairs_In Hl x y Hx Hy) as [H|[H|H]]. - subst; elim N; auto. - assumption. - apply R_sym; assumption. -Qed. - -*) - -(** Compatibility of [ForallOrdPairs] with respect to [inclA]. *) - -Lemma ForallOrdPairs_inclA : forall l l', - NoDupA l' -> inclA l' l -> ForallOrdPairs R l -> ForallOrdPairs R l'. -Proof. -intros l l'. induction l' as [|x l' IH]. -- constructor. -- intros ND Incl FOP. apply FOP_cons; inv; unfold inclA in *; auto. - rewrite Forall_forall; intros y Hy. - assert (Ix : InA x (x::l')) by (rewrite InA_cons; auto). - apply Incl in Ix. rewrite InA_alt in Ix. destruct Ix as (x' & Hxx' & Hx'). - assert (Iy : InA y (x::l')) by (apply In_InA; simpl; auto). - apply Incl in Iy. rewrite InA_alt in Iy. destruct Iy as (y' & Hyy' & Hy'). - rewrite Hxx', Hyy'. - destruct (ForallOrdPairs_In FOP x' y' Hx' Hy') as [E|[?|?]]; auto. - absurd (InA x l'); auto. rewrite Hxx', E, <- Hyy'; auto. -Qed. - - -(** Two-argument functions that allow to reorder their arguments. *) -Definition transpose (f : A -> B -> B) := - forall (x y : A) (z : B), eqB (f x (f y z)) (f y (f x z)). - -(** A version of transpose with restriction on where it should hold *) -Definition transpose_restr (R : A -> A -> Prop)(f : A -> B -> B) := - forall (x y : A) (z : B), R x y -> eqB (f x (f y z)) (f y (f x z)). - -Variable TraR :transpose_restr R f. - -Lemma fold_right_commutes_restr : - forall s1 s2 x, ForallOrdPairs R (s1++x::s2) -> - eqB (fold_right f i (s1++x::s2)) (f x (fold_right f i (s1++s2))). -Proof. -intros s1; induction s1 as [|a s1 IHs1]; simpl; auto; intros s2 x H. -- reflexivity. -- transitivity (f a (f x (fold_right f i (s1++s2)))). - + apply Comp; auto. - apply IHs1. - invlist ForallOrdPairs; auto. - + apply TraR. - invlist ForallOrdPairs; auto. - match goal with H0 : Forall (R a) (s1 ++ x :: s2) |- R a x => - rewrite Forall_forall in H0; apply H0 - end. - apply in_or_app; simpl; auto. -Qed. - -Lemma fold_right_equivlistA_restr : - forall s s', NoDupA s -> NoDupA s' -> ForallOrdPairs R s -> - equivlistA s s' -> eqB (fold_right f i s) (fold_right f i s'). -Proof. - intros s; induction s as [|x l Hrec]. - - intros s'; destruct s' as [|a s']; simpl. - + intros; reflexivity. - + unfold equivlistA; intros H H0 H1 H2. - destruct (H2 a). - assert (InA a nil) by auto; inv. - - intros s' N N' F E; simpl in *. - assert (InA x s') as H by (rewrite <- (E x); auto). - destruct (InA_split H) as (s1,(y,(s2,(H1,H2)))). - subst s'. - transitivity (f x (fold_right f i (s1++s2))). - + apply Comp; auto. - apply Hrec; auto. - * inv; auto. - * eapply NoDupA_split; eauto. - * invlist ForallOrdPairs; auto. - * eapply equivlistA_NoDupA_split; eauto. - + transitivity (f y (fold_right f i (s1++s2))). - * apply Comp; auto. reflexivity. - * symmetry; apply fold_right_commutes_restr. - apply ForallOrdPairs_inclA with (x::l); auto. - red; intros; rewrite E; auto. -Qed. - -Lemma fold_right_add_restr : - forall s' s x, NoDupA s -> NoDupA s' -> ForallOrdPairs R s' -> ~ InA x s -> - equivlistA s' (x::s) -> eqB (fold_right f i s') (f x (fold_right f i s)). -Proof. - intros s' s x **; apply (@fold_right_equivlistA_restr s' (x::s)); auto. -Qed. - -End Fold_With_Restriction. - -(** we now state similar results, but without restriction on transpose. *) - -Variable Tra :transpose f. - -Lemma fold_right_commutes : forall s1 s2 x, - eqB (fold_right f i (s1++x::s2)) (f x (fold_right f i (s1++s2))). -Proof. -intros s1; induction s1 as [|a s1 IHs1]; simpl; auto; intros s2 x. -- reflexivity. -- transitivity (f a (f x (fold_right f i (s1++s2)))); auto. - apply Comp; auto. -Qed. - -Lemma fold_right_equivlistA : - forall s s', NoDupA s -> NoDupA s' -> - equivlistA s s' -> eqB (fold_right f i s) (fold_right f i s'). -Proof. -intros; apply (fold_right_equivlistA_restr (R:=fun _ _ => True)); - repeat red; auto. -apply ForallPairs_ForallOrdPairs; try red; auto. -Qed. - -Lemma fold_right_add : - forall s' s x, NoDupA s -> NoDupA s' -> ~ InA x s -> - equivlistA s' (x::s) -> eqB (fold_right f i s') (f x (fold_right f i s)). -Proof. - intros s' s x **; apply (@fold_right_equivlistA s' (x::s)); auto. -Qed. - -End Fold. - - -Section Fold2. - -Variable B:Type. -Variable eqB:B->B->Prop. -Variable st:Equivalence eqB. -Variable f:A->B->B. -Variable Comp:Proper (eqA==>eqB==>eqB) f. - - -Lemma fold_right_eqlistA2 : - forall s s' (i j:B) (heqij: eqB i j) (heqss': eqlistA s s'), - eqB (fold_right f i s) (fold_right f j s'). -Proof. - intros s. - induction s as [|a s IHs];intros s' i j heqij heqss'. - - inversion heqss'. - subst. - simpl. - assumption. - - inversion heqss'. - subst. - simpl. - apply Comp. - + assumption. - + apply IHs;assumption. -Qed. - -Section Fold2_With_Restriction. - -Variable R : A -> A -> Prop. -Hypothesis R_sym : Symmetric R. -Hypothesis R_compat : Proper (eqA==>eqA==>iff) R. - -(** Two-argument functions that allow to reorder their arguments. *) -Definition transpose2 (f : A -> B -> B) := - forall (x y : A) (z z': B), eqB z z' -> eqB (f x (f y z)) (f y (f x z')). - -(** A version of transpose with restriction on where it should hold *) -Definition transpose_restr2 (R : A -> A -> Prop)(f : A -> B -> B) := - forall (x y : A) (z z': B), R x y -> eqB z z' -> eqB (f x (f y z)) (f y (f x z')). - -Variable TraR :transpose_restr2 R f. - -Lemma fold_right_commutes_restr2 : - forall s1 s2 x (i j:B) (heqij: eqB i j), ForallOrdPairs R (s1++x::s2) -> - eqB (fold_right f i (s1++x::s2)) (f x (fold_right f j (s1++s2))). -Proof. -intros s1; induction s1 as [|a s1 IHs1]; simpl; auto; intros s2 x i j heqij ?. -- apply Comp. - + destruct eqA_equiv. apply Equivalence_Reflexive. - + eapply fold_right_eqlistA2. - * assumption. - * reflexivity. -- transitivity (f a (f x (fold_right f j (s1++s2)))). - + apply Comp; auto. - eapply IHs1. - * assumption. - * invlist ForallOrdPairs; auto. - + apply TraR. - * invlist ForallOrdPairs; auto. - match goal with H0 : Forall (R a) (s1 ++ x :: s2) |- _ => - rewrite Forall_forall in H0; apply H0 - end. - apply in_or_app; simpl; auto. - * reflexivity. -Qed. - -Lemma fold_right_equivlistA_restr2 : - forall s s' i j, - NoDupA s -> NoDupA s' -> ForallOrdPairs R s -> - equivlistA s s' -> eqB i j -> - eqB (fold_right f i s) (fold_right f j s'). -Proof. - intros s; induction s as [|x l Hrec]. - { intros s'; destruct s' as [|a s']; simpl. - - intros. assumption. - - unfold equivlistA; intros ? ? H H0 H1 H2 **. - destruct (H2 a). - assert (InA a nil) by auto; inv. - } - intros s' i j N N' F E eqij; simpl in *. - assert (InA x s') as H by (rewrite <- (E x); auto). - destruct (InA_split H) as (s1,(y,(s2,(H1,H2)))). - subst s'. - transitivity (f x (fold_right f j (s1++s2))). - - apply Comp; auto. - apply Hrec; auto. - + inv; auto. - + eapply NoDupA_split; eauto. - + invlist ForallOrdPairs; auto. - + eapply equivlistA_NoDupA_split; eauto. - - transitivity (f y (fold_right f i (s1++s2))). - + apply Comp; auto. - symmetry. - apply fold_right_eqlistA2. - * assumption. - * reflexivity. - + symmetry. - apply fold_right_commutes_restr2. - * symmetry. - assumption. - * apply ForallOrdPairs_inclA with (x::l); auto. - red; intros; rewrite E; auto. -Qed. - -Lemma fold_right_add_restr2 : - forall s' s i j x, NoDupA s -> NoDupA s' -> eqB i j -> ForallOrdPairs R s' -> ~ InA x s -> - equivlistA s' (x::s) -> eqB (fold_right f i s') (f x (fold_right f j s)). -Proof. - intros s' s i j x **; apply (@fold_right_equivlistA_restr2 s' (x::s) i j); auto. -Qed. - -End Fold2_With_Restriction. - -Variable Tra :transpose2 f. - -Lemma fold_right_commutes2 : forall s1 s2 i x x', - eqA x x' -> - eqB (fold_right f i (s1++x::s2)) (f x' (fold_right f i (s1++s2))). -Proof. - intros s1; induction s1 as [|a s1 IHs1];simpl;intros s2 i x x' H. -- apply Comp;auto. - reflexivity. -- transitivity (f a (f x' (fold_right f i (s1++s2)))); auto. - + apply Comp;auto. - + apply Tra. - reflexivity. -Qed. - -Lemma fold_right_equivlistA2 : - forall s s' i j, NoDupA s -> NoDupA s' -> eqB i j -> - equivlistA s s' -> eqB (fold_right f i s) (fold_right f j s'). -Proof. -red in Tra. -intros; apply (fold_right_equivlistA_restr2 (R:=fun _ _ => True)); -repeat red; auto. -apply ForallPairs_ForallOrdPairs; try red; auto. -Qed. - -Lemma fold_right_add2 : - forall s' s i j x, NoDupA s -> NoDupA s' -> eqB i j -> ~ InA x s -> - equivlistA s' (x::s) -> eqB (fold_right f i s') (f x (fold_right f j s)). -Proof. - intros s' s i j x **. - replace (f x (fold_right f j s)) with (fold_right f j (x::s)) by auto. - eapply fold_right_equivlistA2;auto. -Qed. - -End Fold2. - -Section Remove. - -Hypothesis eqA_dec : forall x y : A, {eqA x y}+{~(eqA x y)}. - -Lemma InA_dec : forall x l, { InA x l } + { ~ InA x l }. -Proof. -intros x l; induction l as [|a l IHl]. -- right; auto. - intro; inv. -- destruct (eqA_dec x a). - + left; auto. - + destruct IHl. - * left; auto. - * right; intro; inv; contradiction. -Defined. - -Fixpoint removeA (x : A) (l : list A) : list A := - match l with - | nil => nil - | y::tl => if (eqA_dec x y) then removeA x tl else y::(removeA x tl) - end. - -Lemma removeA_filter : forall x l, - removeA x l = filter (fun y => if eqA_dec x y then false else true) l. -Proof. -intros x l; induction l as [|a l IHl]; simpl; auto. -destruct (eqA_dec x a); auto. -rewrite IHl; auto. -Qed. - -Lemma removeA_InA : forall l x y, InA y (removeA x l) <-> InA y l /\ ~eqA x y. -Proof. -intros l; induction l as [|a l IHl]; simpl; auto. -- intros x y; split. - + intro; inv. - + destruct 1; inv. -- intros x y. - destruct (eqA_dec x a) as [Heq|Hnot]; simpl; auto. - + rewrite IHl; split; destruct 1; split; auto. - inv; auto. - match goal with H0 : ~ eqA x y |- _ => destruct H0 end; transitivity a; auto. - + split. - * intro; inv. - -- split; auto. - contradict Hnot. - transitivity y; auto. - -- match goal with H0 : InA y (removeA x l) |- _ => - rewrite (IHl x y) in H0; destruct H0; auto - end. - * destruct 1; inv; auto. - right; rewrite IHl; auto. -Qed. - -Lemma removeA_NoDupA : - forall s x, NoDupA s -> NoDupA (removeA x s). -Proof. -intros s; induction s as [|a s IHs]; simpl; intros x ?. -- auto. -- inv. - destruct (eqA_dec x a); simpl; auto. - constructor; auto. - rewrite removeA_InA. - intuition. -Qed. - -Lemma removeA_equivlistA : forall l l' x, - ~InA x l -> equivlistA (x :: l) l' -> equivlistA l (removeA x l'). -Proof. -unfold equivlistA; intros l l' x H H0 x0. -rewrite removeA_InA. -split; intros H1. -- rewrite <- H0; split; auto. - contradict H. - apply InA_eqA with x0; auto. -- rewrite <- (H0 x0) in H1. - destruct H1. - inv; auto. - match goal with H2 : ~ eqA x x0 |- _ => elim H2; auto end. -Qed. - -End Remove. - - - -(** Results concerning lists modulo [eqA] and [ltA] *) - -Variable ltA : A -> A -> Prop. -Hypothesis ltA_strorder : StrictOrder ltA. -Hypothesis ltA_compat : Proper (eqA==>eqA==>iff) ltA. - -Let sotrans := (@StrictOrder_Transitive _ _ ltA_strorder). - -#[local] -Hint Resolve sotrans : core. - -Notation InfA:=(lelistA ltA). -Notation SortA:=(sort ltA). - -#[local] -Hint Constructors lelistA sort : core. - -Lemma InfA_ltA : - forall l x y, ltA x y -> InfA y l -> InfA x l. -Proof. - intros l; destruct l; constructor. inv; eauto. -Qed. - -Global Instance InfA_compat : Proper (eqA==>eqlistA==>iff) InfA. -Proof using eqA_equiv ltA_compat. (* and not ltA_strorder *) - intros x x' Hxx' l l' Hll'. - inversion_clear Hll'. - - intuition. - - split; intro; inv; constructor. - + match goal with H : eqA _ _ |- _ => rewrite <- Hxx', <- H; auto end. - + match goal with H : eqA _ _ |- _ => rewrite Hxx', H; auto end. -Qed. - -(** For compatibility, can be deduced from [InfA_compat] *) -Lemma InfA_eqA l x y : eqA x y -> InfA y l -> InfA x l. -Proof using eqA_equiv ltA_compat. - intros H; now rewrite H. -Qed. -#[local] -Hint Immediate InfA_ltA InfA_eqA : core. - -Lemma SortA_InfA_InA : - forall l x a, SortA l -> InfA a l -> InA x l -> ltA a x. -Proof. - intros l; induction l as [|a l IHl]. - - intros x a **. inv. - - intros x a0 **. inv. - + setoid_replace x with a; auto. - + eauto. -Qed. - -Lemma In_InfA : - forall l x, (forall y, In y l -> ltA x y) -> InfA x l. -Proof. - intros l; induction l; simpl; intros; constructor; auto. -Qed. - -Lemma InA_InfA : - forall l x, (forall y, InA y l -> ltA x y) -> InfA x l. -Proof. - intros l; induction l; simpl; intros; constructor; auto. -Qed. - -(* In fact, this may be used as an alternative definition for InfA: *) - -Lemma InfA_alt : - forall l x, SortA l -> (InfA x l <-> (forall y, InA y l -> ltA x y)). -Proof. -split. -- intros; eapply SortA_InfA_InA; eauto. -- apply InA_InfA. -Qed. - -Lemma InfA_app : forall l1 l2 a, InfA a l1 -> InfA a l2 -> InfA a (l1++l2). -Proof. - intros l1; induction l1; simpl; auto. - intros; inv; auto. -Qed. - -Lemma SortA_app : - forall l1 l2, SortA l1 -> SortA l2 -> - (forall x y, InA x l1 -> InA y l2 -> ltA x y) -> - SortA (l1 ++ l2). -Proof. - intros l1; induction l1; intros l2; simpl in *; intuition. - inv. - constructor; auto. - apply InfA_app; auto. - destruct l2; auto. -Qed. - -Lemma SortA_NoDupA : forall l, SortA l -> NoDupA l. -Proof. - intros l; induction l as [|x l' H]; auto. - intros H0. - inv. - constructor; auto. - intro. - apply (StrictOrder_Irreflexive x). - eapply SortA_InfA_InA; eauto. -Qed. - - -(** Some results about [eqlistA] *) - -Section EqlistA. - -Lemma eqlistA_length : forall l l', eqlistA l l' -> length l = length l'. -Proof. -induction 1; auto; simpl; congruence. -Qed. - -Global Instance app_eqlistA_compat : - Proper (eqlistA==>eqlistA==>eqlistA) (@app A). -Proof. - repeat red; induction 1; simpl; auto. -Qed. - -(** For compatibility, can be deduced from app_eqlistA_compat **) -Lemma eqlistA_app : forall l1 l1' l2 l2', - eqlistA l1 l1' -> eqlistA l2 l2' -> eqlistA (l1++l2) (l1'++l2'). -Proof. -intros l1 l1' l2 l2' H H'; rewrite H, H'; reflexivity. -Qed. - -Lemma eqlistA_rev_app : forall l1 l1', - eqlistA l1 l1' -> forall l2 l2', eqlistA l2 l2' -> - eqlistA ((rev l1)++l2) ((rev l1')++l2'). -Proof. -induction 1; auto. -simpl; intros. -do 2 rewrite <- app_assoc; simpl; auto. -Qed. - -Global Instance rev_eqlistA_compat : Proper (eqlistA==>eqlistA) (@rev A). -Proof. -repeat red. intros x y ?. -rewrite <- (app_nil_r (rev x)), <- (app_nil_r (rev y)). -apply eqlistA_rev_app; auto. -Qed. - -Lemma eqlistA_rev : forall l1 l1', - eqlistA l1 l1' -> eqlistA (rev l1) (rev l1'). -Proof. -apply rev_eqlistA_compat. -Qed. - -Lemma SortA_equivlistA_eqlistA : forall l l', - SortA l -> SortA l' -> equivlistA l l' -> eqlistA l l'. -Proof. -intros l; induction l as [|a l IHl]; intros l'; destruct l' as [|a0 l']; simpl; intros H H0 H1; auto. -- destruct (H1 a0); assert (InA a0 nil) by auto; inv. -- destruct (H1 a); assert (InA a nil) by auto; inv. -- inv. - assert (forall y, InA y l -> ltA a y) by - (intros; eapply (SortA_InfA_InA (l:=l)); eauto). - assert (forall y, InA y l' -> ltA a0 y) by - (intros; eapply (SortA_InfA_InA (l:=l')); eauto). - do 2 match goal with H : InfA _ _ |- _ => clear H end. - assert (eqA a a0). - + destruct (H1 a). - destruct (H1 a0). - assert (InA a (a0::l')) by auto. inv; auto. - assert (InA a0 (a::l)) by auto. inv; auto. - elim (StrictOrder_Irreflexive a); eauto. - + constructor; auto. - apply IHl; auto. - intros x; split; intros. - * destruct (H1 x). - assert (InA x (a0::l')) by auto. inv; auto. - match goal with H3 : eqA a a0, H4 : InA x l, H9 : eqA x a0 |- InA x l' => - rewrite H9,<-H3 in H4 - end. - elim (StrictOrder_Irreflexive a); eauto. - * destruct (H1 x). - assert (InA x (a::l)) by auto. inv; auto. - match goal with H3 : eqA a a0, H4 : InA x l', H9 : eqA x a |- InA x l => - rewrite H9,H3 in H4 - end. - elim (StrictOrder_Irreflexive a0); eauto. -Qed. - -End EqlistA. - -(** A few things about [filter] *) - -Section Filter. - -Lemma filter_sort : forall f l, SortA l -> SortA (List.filter f l). -Proof. -intros f l; induction l as [|a l IHl]; simpl; auto. -intros; inv; auto. -destruct (f a); auto. -constructor; auto. -apply In_InfA; auto. -intros y H. -rewrite filter_In in H; destruct H. -eapply SortA_InfA_InA; eauto. -Qed. -Arguments eq {A} x _. - -Lemma filter_InA : forall f, Proper (eqA==>eq) f -> - forall l x, InA x (List.filter f l) <-> InA x l /\ f x = true. -Proof. -(* Unset Mangle Names. *) -clear sotrans ltA ltA_strorder ltA_compat. -intros f H l x; do 2 rewrite InA_alt; intuition; - match goal with Hex' : exists _, _ |- _ => rename Hex' into Hex end. -- destruct Hex as (y,(H0,H1)); rewrite filter_In in H1; exists y; intuition. -- destruct Hex as (y,(H0,H1)); rewrite filter_In in H1; intuition. - rewrite (H _ _ H0); auto. -- destruct Hex as (y,(H0,H1)); exists y; rewrite filter_In; intuition. - rewrite <- (H _ _ H0); auto. -Qed. - -Lemma filter_split : - forall f, (forall x y, f x = true -> f y = false -> ltA x y) -> - forall l, SortA l -> l = filter f l ++ filter (fun x=>negb (f x)) l. -Proof. -intros f H l; induction l as [|a l IHl]; simpl; intros H0; auto. -inv. -match goal with H1' : SortA l, H2' : InfA a l |- _ => rename H1' into H1, H2' into H2 end. -rewrite IHl at 1; auto. -case_eq (f a); simpl; intros; auto. -assert (forall e, In e l -> f e = false) as H3. { - intros e H3. - assert (H4:=SortA_InfA_InA H1 H2 (In_InA H3)). - case_eq (f e); simpl; intros; auto. - elim (StrictOrder_Irreflexive e). - transitivity a; auto. -} -replace (List.filter f l) with (@nil A); auto. -generalize H3; clear; induction l as [|a l IHl]; simpl; auto. -case_eq (f a); auto; intros H H3. -rewrite H3 in H; auto; try discriminate. -Qed. - -End Filter. -End Type_with_equality. - -#[global] -Hint Constructors InA eqlistA NoDupA sort lelistA : core. - -Arguments equivlistA_cons_nil {A} eqA {eqA_equiv} x l _. -Arguments equivlistA_nil_eq {A} eqA {eqA_equiv} l _. - -Section Find. - -Variable A B : Type. -Variable eqA : A -> A -> Prop. -Hypothesis eqA_equiv : Equivalence eqA. -Hypothesis eqA_dec : forall x y : A, {eqA x y}+{~(eqA x y)}. - -Fixpoint findA (f : A -> bool) (l:list (A*B)) : option B := - match l with - | nil => None - | (a,b)::l => if f a then Some b else findA f l - end. - -Lemma findA_NoDupA : - forall l a b, - NoDupA (fun p p' => eqA (fst p) (fst p')) l -> - (InA (fun p p' => eqA (fst p) (fst p') /\ snd p = snd p') (a,b) l <-> - findA (fun a' => if eqA_dec a a' then true else false) l = Some b). -Proof. -set (eqk := fun p p' : A*B => eqA (fst p) (fst p')). -set (eqke := fun p p' : A*B => eqA (fst p) (fst p') /\ snd p = snd p'). -intros l; induction l as [|a l IHl]; intros a0 b H; simpl. -- split; intros H0; try discriminate. - invlist InA. -- destruct a as (a',b'); rename a0 into a. - invlist NoDupA. - split; intros. - + invlist InA. - * match goal with H2 : eqke (a, b) (a', b') |- _ => compute in H2; destruct H2 end. - subst b'. - destruct (eqA_dec a a'); intuition. - * destruct (eqA_dec a a') as [HeqA|]; simpl. - -- match goal with H0 : ~ InA eqk (a', b') l |- _ => contradict H0 end. - match goal with H2 : InA eqke (a, b) l |- _ => revert HeqA H2; clear - eqA_equiv end. - induction l. - ++ intros; invlist InA. - ++ intros; invlist InA; auto. - match goal with |- InA eqk _ (?p :: _) => destruct p as [a0 b0] end. - match goal with H : eqke (a, b) (a0, b0) |- _ => compute in H; destruct H end. - subst b. - left; auto. - compute. - transitivity a; auto. symmetry; auto. - -- rewrite <- IHl; auto. - + destruct (eqA_dec a a'); simpl in *. - * left; split; simpl; congruence. - * right. rewrite IHl; auto. -Qed. - -End Find. - -(** Compatibility aliases. [Proper] is rather to be used directly now.*) - -Definition compat_bool {A} (eqA:A->A->Prop)(f:A->bool) := - Proper (eqA==>Logic.eq) f. - -Definition compat_nat {A} (eqA:A->A->Prop)(f:A->nat) := - Proper (eqA==>Logic.eq) f. - -Definition compat_P {A} (eqA:A->A->Prop)(P:A->Prop) := - Proper (eqA==>impl) P. - -Definition compat_op {A B} (eqA:A->A->Prop)(eqB:B->B->Prop)(f:A->B->B) := - Proper (eqA==>eqB==>eqB) f. diff --git a/stdlib/theories/Lists/SetoidPermutation.v b/stdlib/theories/Lists/SetoidPermutation.v deleted file mode 100644 index 3dbfe8afd48a..000000000000 --- a/stdlib/theories/Lists/SetoidPermutation.v +++ /dev/null @@ -1,206 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* list A -> Prop := - | permA_nil: PermutationA nil nil - | permA_skip xā‚ xā‚‚ lā‚ lā‚‚ : - eqA xā‚ xā‚‚ -> PermutationA lā‚ lā‚‚ -> PermutationA (xā‚ :: lā‚) (xā‚‚ :: lā‚‚) - | permA_swap x y l : PermutationA (y :: x :: l) (x :: y :: l) - | permA_trans lā‚ lā‚‚ lā‚ƒ : - PermutationA lā‚ lā‚‚ -> PermutationA lā‚‚ lā‚ƒ -> PermutationA lā‚ lā‚ƒ. -Local Hint Constructors PermutationA : core. - -Global Instance: Equivalence PermutationA. -Proof. - constructor. - - intro l. induction l; intuition. - - intros lā‚ lā‚‚. induction 1; eauto. apply permA_skip; intuition. - - exact permA_trans. -Qed. - -Global Instance PermutationA_cons : - Proper (eqA ==> PermutationA ==> PermutationA) (@cons A). -Proof. - repeat intro. now apply permA_skip. -Qed. - -Lemma PermutationA_app_head lā‚ lā‚‚ l : - PermutationA lā‚ lā‚‚ -> PermutationA (l ++ lā‚) (l ++ lā‚‚). -Proof. - induction l; trivial; intros. apply permA_skip; intuition. -Qed. - -Global Instance PermutationA_app : - Proper (PermutationA ==> PermutationA ==> PermutationA) (@app A). -Proof. - intros lā‚ lā‚‚ Pl kā‚ kā‚‚ Pk. - induction Pl. - - easy. - - now apply permA_skip. - - etransitivity. - * rewrite <-!app_comm_cons. now apply permA_swap. - * rewrite !app_comm_cons. now apply PermutationA_app_head. - - do 2 (etransitivity; try eassumption). - apply PermutationA_app_head. now symmetry. -Qed. - -Lemma PermutationA_app_tail lā‚ lā‚‚ l : - PermutationA lā‚ lā‚‚ -> PermutationA (lā‚ ++ l) (lā‚‚ ++ l). -Proof. - intros E. now rewrite E. -Qed. - -Lemma PermutationA_cons_append l x : - PermutationA (x :: l) (l ++ x :: nil). -Proof. - induction l. - - easy. - - simpl. rewrite <-IHl. intuition. -Qed. - -Lemma PermutationA_app_comm lā‚ lā‚‚ : - PermutationA (lā‚ ++ lā‚‚) (lā‚‚ ++ lā‚). -Proof. - induction lā‚. - - now rewrite app_nil_r. - - rewrite <-app_comm_cons, IHlā‚, app_comm_cons. - now rewrite PermutationA_cons_append, <-app_assoc. -Qed. - -Lemma PermutationA_cons_app l lā‚ lā‚‚ x : - PermutationA l (lā‚ ++ lā‚‚) -> PermutationA (x :: l) (lā‚ ++ x :: lā‚‚). -Proof. - intros E. rewrite E. - now rewrite app_comm_cons, (PermutationA_cons_append lā‚ x), <- app_assoc. -Qed. - -Lemma PermutationA_middle lā‚ lā‚‚ x : - PermutationA (x :: lā‚ ++ lā‚‚) (lā‚ ++ x :: lā‚‚). -Proof. - now apply PermutationA_cons_app. -Qed. - -Lemma PermutationA_equivlistA lā‚ lā‚‚ : - PermutationA lā‚ lā‚‚ -> equivlistA eqA lā‚ lā‚‚. -Proof. - induction 1. - - reflexivity. - - now apply equivlistA_cons_proper. - - now apply equivlistA_permute_heads. - - etransitivity; eassumption. -Qed. - -Lemma NoDupA_equivlistA_PermutationA lā‚ lā‚‚ : - NoDupA eqA lā‚ -> NoDupA eqA lā‚‚ -> - equivlistA eqA lā‚ lā‚‚ -> PermutationA lā‚ lā‚‚. -Proof. - intros Plā‚. revert lā‚‚. induction Plā‚ as [|x lā‚ E1]. - - intros lā‚‚ _ Hā‚‚. symmetry in Hā‚‚. now rewrite (equivlistA_nil_eq eqA). - - intros lā‚‚ Plā‚‚ E2. - destruct (@InA_split _ eqA lā‚‚ x) as [lā‚‚h [y [lā‚‚t [E3 ?]]]]. - { rewrite <-E2. intuition. } - subst. transitivity (y :: lā‚); [intuition |]. - apply PermutationA_cons_app, IHPlā‚. - + now apply NoDupA_split with y. - + apply equivlistA_NoDupA_split with x y; intuition. -Qed. - -Lemma Permutation_eqlistA_commute lā‚ lā‚‚ lā‚ƒ : - eqlistA eqA lā‚ lā‚‚ -> Permutation lā‚‚ lā‚ƒ -> - exists lā‚‚', Permutation lā‚ lā‚‚' /\ eqlistA eqA lā‚‚' lā‚ƒ. -Proof. - intros E P. revert lā‚ E. - induction P; intros. - - inversion_clear E. now exists nil. - - inversion_clear E. - destruct (IHP l0) as (l0',(P',E')); trivial. clear IHP. - exists (x0::l0'). split; auto. - - inversion_clear E. inversion_clear H0. - exists (x1::x0::l1). now repeat constructor. - - clear P1 P2. - destruct (IHP1 _ E) as (lā‚',(Pā‚,Eā‚)). - destruct (IHP2 _ Eā‚) as (lā‚‚',(Pā‚‚,Eā‚‚)). - exists lā‚‚'. split; trivial. econstructor; eauto. -Qed. - -Lemma PermutationA_decompose lā‚ lā‚‚ : - PermutationA lā‚ lā‚‚ -> - exists l, Permutation lā‚ l /\ eqlistA eqA l lā‚‚. -Proof. - induction 1. - - now exists nil. - - destruct IHPermutationA as (l,(P,E)). exists (xā‚::l); auto. - - exists (x::y::l). split. - + constructor. - + reflexivity. - - destruct IHPermutationA1 as (lā‚',(P,E)). - destruct IHPermutationA2 as (lā‚‚',(P',E')). - destruct (@Permutation_eqlistA_commute lā‚' lā‚‚ lā‚‚') as (lā‚'',(P'',E'')); - trivial. - exists lā‚''. split. - + now transitivity lā‚'. - + now transitivity lā‚‚'. -Qed. - -Lemma Permutation_PermutationA lā‚ lā‚‚ : - Permutation lā‚ lā‚‚ -> PermutationA lā‚ lā‚‚. -Proof. - induction 1. - - constructor. - - now constructor. - - apply permA_swap. - - econstructor; eauto. -Qed. - -Lemma eqlistA_PermutationA lā‚ lā‚‚ : - eqlistA eqA lā‚ lā‚‚ -> PermutationA lā‚ lā‚‚. -Proof. - induction 1; now constructor. -Qed. - -Lemma NoDupA_equivlistA_decompose l1 l2 : - NoDupA eqA l1 -> NoDupA eqA l2 -> equivlistA eqA l1 l2 -> - exists l, Permutation l1 l /\ eqlistA eqA l l2. -Proof. - intros. apply PermutationA_decompose. - now apply NoDupA_equivlistA_PermutationA. -Qed. - -Lemma PermutationA_preserves_NoDupA lā‚ lā‚‚ : - PermutationA lā‚ lā‚‚ -> NoDupA eqA lā‚ -> NoDupA eqA lā‚‚. -Proof. - induction 1; trivial. - - inversion_clear 1; constructor; auto. - apply PermutationA_equivlistA in H0. contradict H2. - now rewrite H, H0. - - inversion_clear 1. inversion_clear H1. constructor. - + contradict H. inversion_clear H; trivial. - elim H0. now constructor. - + constructor; trivial. - contradict H0. now apply InA_cons_tl. - - eauto. -Qed. - -End Permutation. diff --git a/stdlib/theories/Lists/StreamMemo.v b/stdlib/theories/Lists/StreamMemo.v deleted file mode 100644 index 6a32b7147bdb..000000000000 --- a/stdlib/theories/Lists/StreamMemo.v +++ /dev/null @@ -1,209 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* A. - -CoFixpoint memo_make (n:nat) : Stream A := Cons (f n) (memo_make (S n)). - -Definition memo_list := memo_make 0. - -Fixpoint memo_get (n:nat) (l:Stream A) : A := - match n with - | O => hd l - | S n1 => memo_get n1 (tl l) - end. - -Theorem memo_get_correct: forall n, memo_get n memo_list = f n. -Proof. -assert (F1: forall n m, memo_get n (memo_make m) = f (n + m)). -{ induction n as [| n Hrec]; try (intros m; reflexivity). - intros m; simpl; rewrite Hrec. - rewrite plus_n_Sm; auto. } -intros n; transitivity (f (n + 0)); try exact (F1 n 0). -rewrite <- plus_n_O; auto. -Qed. - -(** Building with possible sharing using a iterator [g] : - We now suppose in addition that [f n] is in fact the [n]-th - iterate of a function [g]. -*) - -Variable g: A -> A. - -Hypothesis Hg_correct: forall n, f (S n) = g (f n). - -CoFixpoint imemo_make (fn:A) : Stream A := - let fn1 := g fn in - Cons fn1 (imemo_make fn1). - -Definition imemo_list := let f0 := f 0 in - Cons f0 (imemo_make f0). - -Theorem imemo_get_correct: forall n, memo_get n imemo_list = f n. -Proof. -assert (F1: forall n m, memo_get n (imemo_make (f m)) = f (S (n + m))). -{ induction n as [| n Hrec]; try (intros m; exact (eq_sym (Hg_correct m))). - simpl; intros m; rewrite <- Hg_correct, Hrec, <- plus_n_Sm; auto. } -destruct n as [| n]; try reflexivity. -unfold imemo_list; simpl; rewrite F1. -rewrite <- plus_n_O; auto. -Qed. - -End MemoFunction. - -(** For a dependent function, the previous solution is - reused thanks to a temporary hiding of the dependency - in a "container" [memo_val]. *) - -#[universes(template)] -Inductive memo_val {A : nat -> Type} : Type := - memo_mval: forall n, A n -> memo_val. -Arguments memo_val : clear implicits. - -Section DependentMemoFunction. - -Variable A: nat -> Type. -Variable f: forall n, A n. - -Notation memo_val := (memo_val A). - -Fixpoint is_eq (n m : nat) : {n = m} + {True} := - match n, m return {n = m} + {True} with - | 0, 0 =>left True (eq_refl 0) - | 0, S m1 => right (0 = S m1) I - | S n1, 0 => right (S n1 = 0) I - | S n1, S m1 => - match is_eq n1 m1 with - | left H => left True (f_equal S H) - | right _ => right (S n1 = S m1) I - end - end. - -Definition memo_get_val n (v: memo_val): A n := -match v with -| memo_mval m x => - match is_eq n m with - | left H => - match H in (eq _ y) return (A y -> A n) with - | eq_refl => fun v1 : A n => v1 - end - | right _ => fun _ : A m => f n - end x -end. - -Let mf n := memo_mval n (f n). - -Definition dmemo_list := memo_list _ mf. - -Definition dmemo_get n l := memo_get_val n (memo_get _ n l). - -Theorem dmemo_get_correct: forall n, dmemo_get n dmemo_list = f n. -Proof. -intros n; unfold dmemo_get, dmemo_list. -rewrite (memo_get_correct memo_val mf n); simpl. -case (is_eq n n); simpl; auto; intros e. -assert (e = eq_refl n). -- apply eq_proofs_unicity. - induction x as [| x Hx]; destruct y as [| y]. - + left; auto. - + right; intros HH; discriminate HH. - + right; intros HH; discriminate HH. - + case (Hx y). - * intros HH; left; case HH; auto. - * intros HH; right; intros HH1; case HH. - injection HH1; auto. -- rewrite H; auto. -Qed. - -(** Finally, a version with both dependency and iterator *) - -Variable g: forall n, A n -> A (S n). - -Hypothesis Hg_correct: forall n, f (S n) = g n (f n). - -Let mg v := match v with - memo_mval n1 v1 => memo_mval (S n1) (g n1 v1) end. - -Definition dimemo_list := imemo_list _ mf mg. - -Theorem dimemo_get_correct: forall n, dmemo_get n dimemo_list = f n. -Proof. -intros n; unfold dmemo_get, dimemo_list. -rewrite (imemo_get_correct memo_val mf mg); simpl. -- case (is_eq n n); simpl; auto; intros e. - assert (e = eq_refl n). - + apply eq_proofs_unicity. - induction x as [| x Hx]; destruct y as [| y]. - * left; auto. - * right; intros HH; discriminate HH. - * right; intros HH; discriminate HH. - * case (Hx y). - -- intros HH; left; case HH; auto. - -- intros HH; right; intros HH1; case HH. - injection HH1; auto. - + rewrite H; auto. -- intros n1; unfold mf; rewrite Hg_correct; auto. -Qed. - -End DependentMemoFunction. - -(** An example with the memo function on factorial *) - -(* -Require Import ZArith. -Open Scope Z_scope. - -Fixpoint tfact (n: nat) := - match n with - | O => 1 - | S n1 => Z.of_nat n * tfact n1 - end. - -Definition lfact_list := - dimemo_list _ tfact (fun n z => (Z.of_nat (S n) * z)). - -Definition lfact n := dmemo_get _ tfact n lfact_list. - -Theorem lfact_correct n: lfact n = tfact n. -Proof. -intros n; unfold lfact, lfact_list. -rewrite dimemo_get_correct; auto. -Qed. - -Fixpoint nop p := - match p with - | xH => 0 - | xI p1 => nop p1 - | xO p1 => nop p1 - end. - -Fixpoint test z := - match z with - | Z0 => 0 - | Zpos p1 => nop p1 - | Zneg p1 => nop p1 - end. - -Time Eval vm_compute in test (lfact 2000). -Time Eval vm_compute in test (lfact 2000). -Time Eval vm_compute in test (lfact 1500). -Time Eval vm_compute in (lfact 1500). -*) diff --git a/stdlib/theories/Lists/Streams.v b/stdlib/theories/Lists/Streams.v deleted file mode 100644 index 09c357fdd8b3..000000000000 --- a/stdlib/theories/Lists/Streams.v +++ /dev/null @@ -1,250 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* Stream A -> Stream A. - -Section Streams. - Variable A : Type. - - Notation Stream := (Stream A). - - -Definition hd (x:Stream) := match x with - | Cons a _ => a - end. - -Definition tl (x:Stream) := match x with - | Cons _ s => s - end. - - -Fixpoint Str_nth_tl (n:nat) (s:Stream) : Stream := - match n with - | O => s - | S m => Str_nth_tl m (tl s) - end. - -Definition Str_nth (n:nat) (s:Stream) : A := hd (Str_nth_tl n s). - - -Lemma unfold_Stream : - forall x:Stream, x = match x with - | Cons a s => Cons a s - end. -Proof. - intro x. - case x. - trivial. -Qed. - -Lemma tl_nth_tl : - forall (n:nat) (s:Stream), tl (Str_nth_tl n s) = Str_nth_tl n (tl s). -Proof. - simple induction n; simpl; auto. -Qed. -#[local] -Hint Resolve tl_nth_tl: datatypes. - -Lemma Str_nth_tl_plus : - forall (n m:nat) (s:Stream), - Str_nth_tl n (Str_nth_tl m s) = Str_nth_tl (n + m) s. -simple induction n; simpl; intros; auto with datatypes. -rewrite <- H. -rewrite tl_nth_tl; trivial with datatypes. -Qed. - -Lemma Str_nth_plus : - forall (n m:nat) (s:Stream), Str_nth n (Str_nth_tl m s) = Str_nth (n + m) s. -intros; unfold Str_nth; rewrite Str_nth_tl_plus; - trivial with datatypes. -Qed. - -(** Extensional Equality between two streams *) - -CoInductive EqSt (s1 s2: Stream) : Prop := - eqst : - hd s1 = hd s2 -> EqSt (tl s1) (tl s2) -> EqSt s1 s2. - -(** A coinduction principle *) - -Ltac coinduction proof := - cofix proof; intros; constructor; - [ clear proof | try (apply proof; clear proof) ]. - - -(** Extensional equality is an equivalence relation *) - -Theorem EqSt_reflex : forall s:Stream, EqSt s s. -coinduction EqSt_reflex. -reflexivity. -Qed. - -Theorem sym_EqSt : forall s1 s2:Stream, EqSt s1 s2 -> EqSt s2 s1. -coinduction Eq_sym. -+ case H; intros; symmetry ; assumption. -+ case H; intros; assumption. -Qed. - - -Theorem trans_EqSt : - forall s1 s2 s3:Stream, EqSt s1 s2 -> EqSt s2 s3 -> EqSt s1 s3. -coinduction Eq_trans. -- transitivity (hd s2). - + case H; intros; assumption. - + case H0; intros; assumption. -- apply (Eq_trans (tl s1) (tl s2) (tl s3)). - + case H; trivial with datatypes. - + case H0; trivial with datatypes. -Qed. - -(** The definition given is equivalent to require the elements at each - position to be equal *) - -Theorem eqst_ntheq : - forall (n:nat) (s1 s2:Stream), EqSt s1 s2 -> Str_nth n s1 = Str_nth n s2. -unfold Str_nth; simple induction n. -- intros s1 s2 H; case H; trivial with datatypes. -- intros m hypind. - simpl. - intros s1 s2 H. - apply hypind. - case H; trivial with datatypes. -Qed. - -Theorem ntheq_eqst : - forall s1 s2:Stream, - (forall n:nat, Str_nth n s1 = Str_nth n s2) -> EqSt s1 s2. -coinduction Equiv2. -- apply (H 0). -- intros n; apply (H (S n)). -Qed. - -Section Stream_Properties. - -Variable P : Stream -> Prop. - -(*i -Inductive Exists : Stream -> Prop := - | Here : forall x:Stream, P x -> Exists x - | Further : forall x:Stream, ~ P x -> Exists (tl x) -> Exists x. -i*) - -Inductive Exists ( x: Stream ) : Prop := - | Here : P x -> Exists x - | Further : Exists (tl x) -> Exists x. - -CoInductive ForAll (x: Stream) : Prop := - HereAndFurther : P x -> ForAll (tl x) -> ForAll x. - -Lemma ForAll_Str_nth_tl : forall m x, ForAll x -> ForAll (Str_nth_tl m x). -Proof. -induction m. -- tauto. -- intros x [_ H]. - simpl. - apply IHm. - assumption. -Qed. - -Section Co_Induction_ForAll. -Variable Inv : Stream -> Prop. -Hypothesis InvThenP : forall x:Stream, Inv x -> P x. -Hypothesis InvIsStable : forall x:Stream, Inv x -> Inv (tl x). - -Theorem ForAll_coind : forall x:Stream, Inv x -> ForAll x. -coinduction ForAll_coind; auto. -Qed. -End Co_Induction_ForAll. - -End Stream_Properties. - -End Streams. - -Section Map. -Variables A B : Type. -Variable f : A -> B. -CoFixpoint map (s:Stream A) : Stream B := Cons (f (hd s)) (map (tl s)). - -Lemma Str_nth_tl_map : forall n s, Str_nth_tl n (map s)= map (Str_nth_tl n s). -Proof. -induction n. -- reflexivity. -- simpl. - intros s. - apply IHn. -Qed. - -Lemma Str_nth_map : forall n s, Str_nth n (map s)= f (Str_nth n s). -Proof. -intros n s. -unfold Str_nth. -rewrite Str_nth_tl_map. -reflexivity. -Qed. - -Lemma ForAll_map : forall (P:Stream B -> Prop) (S:Stream A), ForAll (fun s => P -(map s)) S <-> ForAll P (map S). -Proof. -intros P S. -split; generalize S; clear S; cofix ForAll_map; intros S; constructor; -destruct H as [H0 H]; firstorder. -Qed. - -Lemma Exists_map : forall (P:Stream B -> Prop) (S:Stream A), Exists (fun s => P -(map s)) S -> Exists P (map S). -Proof. -intros P S H. -(induction H;[left|right]); firstorder. -Defined. - -End Map. - -Section Constant_Stream. -Variable A : Type. -Variable a : A. -CoFixpoint const : Stream A := Cons a const. -End Constant_Stream. - -Section Zip. - -Variable A B C : Type. -Variable f: A -> B -> C. - -CoFixpoint zipWith (a:Stream A) (b:Stream B) : Stream C := -Cons (f (hd a) (hd b)) (zipWith (tl a) (tl b)). - -Lemma Str_nth_tl_zipWith : forall n (a:Stream A) (b:Stream B), - Str_nth_tl n (zipWith a b)= zipWith (Str_nth_tl n a) (Str_nth_tl n b). -Proof. -induction n. -- reflexivity. -- intros [x xs] [y ys]. - unfold Str_nth in *. - simpl in *. - apply IHn. -Qed. - -Lemma Str_nth_zipWith : forall n (a:Stream A) (b:Stream B), Str_nth n (zipWith a - b)= f (Str_nth n a) (Str_nth n b). -Proof. -intros. -unfold Str_nth. -rewrite Str_nth_tl_zipWith. -reflexivity. -Qed. - -End Zip. - -Unset Implicit Arguments. diff --git a/stdlib/theories/Logic/Adjointification.v b/stdlib/theories/Logic/Adjointification.v deleted file mode 100644 index 788a4be4db43..000000000000 --- a/stdlib/theories/Logic/Adjointification.v +++ /dev/null @@ -1,113 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* A} - (H : forall a, f a = a) {x y : A} (p : x = y) - : eq_trans (H x) p = eq_trans (f_equal f p) (H y) - := match p in (_ = y) - return eq_trans (H x) p = eq_trans (f_equal f p) (H y) - with eq_refl => eq_sym (eq_trans_refl_l (H x)) end. - -End lemmas. - -Section adjointify. -Context {A B} (f : A -> B) (g : B -> A). - -(** One adjoint equation implies the other *) -Section g_adjoint. -Context - (gf_id : forall a, g (f a) = a) - (fg_id : forall b, f (g b) = b). - -Definition f_adjoint_gives_g_adjoint_pointwise - (b : B) (f_adjoint_at_gb : fg_id (f (g b)) = f_equal f (gf_id (g b))) - : gf_id (g b) = f_equal g (fg_id b) - := let precomposed_eq - : eq_trans (f_equal (fun a => g (f a)) (f_equal g (fg_id b))) - (gf_id (g b)) = - eq_trans (f_equal g (f_equal (fun b => f (g b)) (fg_id b))) - (f_equal g (fg_id b)) - := eq_trans - (eq_sym (commute_homotopy_id gf_id (f_equal g (fg_id b)))) - (eq_rect (f_equal g (fg_id (f (g b)))) (fun p => eq_trans p _ = _) - (eq_trans (eq_trans - (eq_sym (eq_trans_map_distr g _ _)) - (f_equal (fun p => f_equal g p) - (commute_homotopy_id fg_id (fg_id b)))) - (eq_trans_map_distr g _ _)) _ - (eq_trans (eq_trans - (f_equal (fun p => f_equal g p) f_adjoint_at_gb) - (f_equal_compose f g _)) - (eq_id_comm_r _ gf_id (g b)))) in - match fg_id b as p - return - forall p1 p2, - eq_trans (f_equal _ (f_equal g p)) p1 = - eq_trans (f_equal g (f_equal _ p)) p2 -> - p1 = p2 - with eq_refl => fun p1 p2 eq => - eq_trans (eq_trans - (eq_sym (eq_trans_refl_l _)) - eq) - (eq_trans_refl_l _) - end (gf_id (g b)) (f_equal g (fg_id b)) precomposed_eq. - -(** We can flip an adjoint equivalence around without changing the proofs. *) -Definition f_adjoint_gives_g_adjoint - (f_adjoint : forall a, fg_id (f a) = f_equal f (gf_id a)) - (b : B) : gf_id (g b) = f_equal g (fg_id b) - := f_adjoint_gives_g_adjoint_pointwise b (f_adjoint (g b)). -End g_adjoint. - -Section correction. -Context - (gf_id : forall a, g (f a) = a) - (fg_id : forall b, f (g b) = b). - -(** Modifies the proof of (f (g b) = b) to be adjoint *) -Definition fg_id' b : f (g b) = b - := eq_trans (eq_sym (fg_id (f (g b)))) - (eq_trans (f_equal f (gf_id (g b))) (fg_id b)). - -(** The main lemma: *) -Definition f_adjoint a : fg_id' (f a) = f_equal f (gf_id a) - := let symmetric_eq - : eq_trans (f_equal f (gf_id (g (f a)))) (fg_id (f a)) = - eq_trans (fg_id (f (g (f a)))) (f_equal f (gf_id a)) - := eq_trans (eq_trans - (f_equal (fun H => eq_trans (f_equal f H) (fg_id (f a))) - (eq_sym (eq_id_comm_r _ gf_id a))) - (f_equal (fun p => eq_trans p _) - (eq_trans - (f_equal_compose (fun a => g (f a)) f _) - (eq_sym (f_equal_compose f (fun b => f (g b)) _))))) - (eq_sym (commute_homotopy_id fg_id (f_equal f (gf_id a)))) in - match fg_id (f (g (f a))) as p - return forall p', _ = eq_trans p p' -> eq_trans (eq_sym p) _ = p' - with eq_refl => fun p' eq => - eq_trans (eq_trans_refl_l _) (eq_trans eq (eq_trans_refl_l _)) - end _ symmetric_eq. - -(** And the symmetric version. Note that we use the same proofs of inverse. *) -Definition g_adjoint - : forall b, gf_id (g b) = f_equal g (fg_id' b) - := f_adjoint_gives_g_adjoint gf_id fg_id' f_adjoint. - -End correction. - -End adjointify. diff --git a/stdlib/theories/Logic/Berardi.v b/stdlib/theories/Logic/Berardi.v deleted file mode 100644 index eb9c02bbd76e..000000000000 --- a/stdlib/theories/Logic/Berardi.v +++ /dev/null @@ -1,156 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* > -*) - -Set Implicit Arguments. - -Section Berardis_paradox. - -(** Excluded middle *) -Hypothesis EM : forall P:Prop, P \/ ~ P. - -(** Conditional on any proposition. *) -Definition IFProp (P B:Prop) (e1 e2:P) := - match EM B with - | or_introl _ => e1 - | or_intror _ => e2 - end. - -(** Axiom of choice applied to disjunction. - Provable in Coq because of dependent elimination. *) -Lemma AC_IF : - forall (P B:Prop) (e1 e2:P) (Q:P -> Prop), - (B -> Q e1) -> (~ B -> Q e2) -> Q (IFProp B e1 e2). -Proof. -intros P B e1 e2 Q p1 p2. -unfold IFProp. -case (EM B); assumption. -Qed. - - -(** We assume a type with two elements. They play the role of booleans. - The main theorem under the current assumptions is that [T=F] *) -Variable Bool : Prop. -Variable T : Bool. -Variable F : Bool. - -(** The powerset operator *) -Definition pow (P:Prop) := P -> Bool. - - -(** A piece of theory about retracts *) -Section Retracts. - -Variables A B : Prop. - -Record retract : Prop := - {i : A -> B; j : B -> A; inv : forall a:A, j (i a) = a}. -Record retract_cond : Prop := - {i2 : A -> B; j2 : B -> A; inv2 : retract -> forall a:A, j2 (i2 a) = a}. - -(** The dependent elimination above implies the axiom of choice: *) - -Lemma AC : forall r:retract_cond, retract -> forall a:A, j2 r (i2 r a) = a. -Proof. intros r. exact (inv2 r). Qed. - -End Retracts. - -(** This lemma is basically a commutation of implication and existential - quantification: (EX x | A -> P(x)) <=> (A -> EX x | P(x)) - which is provable in classical logic ( => is already provable in - intuitionistic logic). *) - -Lemma L1 : forall A B:Prop, retract_cond (pow A) (pow B). -Proof. -intros A B. -destruct (EM (retract (pow A) (pow B))) as [(f0,g0,e) | hf]. -- exists f0 g0; trivial. -- exists (fun (x:pow A) (y:B) => F) (fun (x:pow B) (y:A) => F); intros; - destruct hf; auto. -Qed. - - -(** The paradoxical set *) -Definition U := forall P:Prop, pow P. - -(** Bijection between [U] and [(pow U)] *) -Definition f (u:U) : pow U := u U. - -Definition g (h:pow U) : U := - fun X => let lX := j2 (L1 X U) in let rU := i2 (L1 U U) in lX (rU h). - -(** We deduce that the powerset of [U] is a retract of [U]. - This lemma is stated in Berardi's article, but is not used - afterwards. *) -Lemma retract_pow_U_U : retract (pow U) U. -Proof. -exists g f. -intro a. -unfold f, g; simpl. -apply AC. -exists (fun x:pow U => x) (fun x:pow U => x). -trivial. -Qed. - -(** Encoding of Russel's paradox *) - -(** The boolean negation. *) -Definition Not_b (b:Bool) := IFProp (b = T) F T. - -(** the set of elements not belonging to itself *) -Definition R : U := g (fun u:U => Not_b (u U u)). - - -Lemma not_has_fixpoint : R R = Not_b (R R). -Proof. -unfold R at 1. -unfold g. -rewrite AC. -- trivial. -- exists (fun x:pow U => x) (fun x:pow U => x). - trivial. -Qed. - - -Theorem classical_proof_irrelevance : T = F. -Proof. -generalize not_has_fixpoint. -unfold Not_b. -apply AC_IF. -- intros is_true is_false. - elim is_true; elim is_false; trivial. - -- intros not_true is_true. - elim not_true; trivial. -Qed. - - -#[deprecated(since = "8.8", note = "Use classical_proof_irrelevance instead.")] -Notation classical_proof_irrelevence := classical_proof_irrelevance. - -End Berardis_paradox. diff --git a/stdlib/theories/Logic/ChoiceFacts.v b/stdlib/theories/Logic/ChoiceFacts.v deleted file mode 100644 index 779088ead888..000000000000 --- a/stdlib/theories/Logic/ChoiceFacts.v +++ /dev/null @@ -1,1326 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* Prop. - -(** ** Constructive choice and description *) - -(** AC_rel = relational form of the (non extensional) axiom of choice - (a "set-theoretic" axiom of choice) *) - -Definition RelationalChoice_on := - forall R:A->B->Prop, - (forall x : A, exists y : B, R x y) -> - (exists R' : A->B->Prop, subrelation R' R /\ forall x, exists! y, R' x y). - -(** AC_fun = functional form of the (non extensional) axiom of choice - (a "type-theoretic" axiom of choice) *) - -(* Note: This is called Type-Theoretic Description Axiom (TTDA) in - [[Werner97]] (using a non-standard meaning of "description"). This - is called intensional axiom of choice (AC_int) in [[Carlstrƶm04]] *) - -Definition FunctionalChoice_on_rel (R:A->B->Prop) := - (forall x:A, exists y : B, R x y) -> - exists f : A -> B, (forall x:A, R x (f x)). - -Definition FunctionalChoice_on := - forall R:A->B->Prop, - (forall x : A, exists y : B, R x y) -> - (exists f : A->B, forall x : A, R x (f x)). - -(** AC_fun_dep = functional form of the (non extensional) axiom of - choice, with dependent functions *) -Definition DependentFunctionalChoice_on (A:Type) (B:A -> Type) := - forall R:forall x:A, B x -> Prop, - (forall x:A, exists y : B x, R x y) -> - (exists f : (forall x:A, B x), forall x:A, R x (f x)). - -(** AC_trunc = axiom of choice for propositional truncations - (truncation and quantification commute) *) -Definition InhabitedForallCommute_on (A : Type) (B : A -> Type) := - (forall x, inhabited (B x)) -> inhabited (forall x, B x). - -(** DC_fun = functional form of the dependent axiom of choice *) - -Definition FunctionalDependentChoice_on := - forall (R:A->A->Prop), - (forall x, exists y, R x y) -> forall x0, - (exists f : nat -> A, f 0 = x0 /\ forall n, R (f n) (f (S n))). - -(** ACw_fun = functional form of the countable axiom of choice *) - -Definition FunctionalCountableChoice_on := - forall (R:nat->A->Prop), - (forall n, exists y, R n y) -> - (exists f : nat -> A, forall n, R n (f n)). - -(** AC! = functional relation reification - (known as axiom of unique choice in topos theory, - sometimes called principle of definite description in - the context of constructive type theory, sometimes - called axiom of no choice) *) - -Definition FunctionalRelReification_on := - forall R:A->B->Prop, - (forall x : A, exists! y : B, R x y) -> - (exists f : A->B, forall x : A, R x (f x)). - -(** AC_dep! = functional relation reification, with dependent functions - see AC! *) -Definition DependentFunctionalRelReification_on (A:Type) (B:A -> Type) := - forall (R:forall x:A, B x -> Prop), - (forall x:A, exists! y : B x, R x y) -> - (exists f : (forall x:A, B x), forall x:A, R x (f x)). - -(** AC_fun_repr = functional choice of a representative in an equivalence class *) - -(* Note: This is called Type-Theoretic Choice Axiom (TTCA) in - [[Werner97]] (by reference to the extensional set-theoretic - formulation of choice); Note also a typo in its intended - formulation in [[Werner97]]. *) - -Definition RepresentativeFunctionalChoice_on := - forall R:A->A->Prop, - (Equivalence R) -> - (exists f : A->A, forall x : A, (R x (f x)) /\ forall x', R x x' -> f x = f x'). - -(** AC_fun_setoid = functional form of the (so-called extensional) axiom of - choice from setoids *) - -Definition SetoidFunctionalChoice_on := - forall R : A -> A -> Prop, - forall T : A -> B -> Prop, - Equivalence R -> - (forall x x' y, R x x' -> T x y -> T x' y) -> - (forall x, exists y, T x y) -> - exists f : A -> B, forall x : A, T x (f x) /\ (forall x' : A, R x x' -> f x = f x'). - -(** AC_fun_setoid_gen = functional form of the general form of the (so-called - extensional) axiom of choice over setoids *) - -(* Note: This is called extensional axiom of choice (AC_ext) in - [[Carlstrƶm04]]. *) - -Definition GeneralizedSetoidFunctionalChoice_on := - forall R : A -> A -> Prop, - forall S : B -> B -> Prop, - forall T : A -> B -> Prop, - Equivalence R -> - Equivalence S -> - (forall x x' y y', R x x' -> S y y' -> T x y -> T x' y') -> - (forall x, exists y, T x y) -> - exists f : A -> B, - forall x : A, T x (f x) /\ (forall x' : A, R x x' -> S (f x) (f x')). - -(** AC_fun_setoid_simple = functional form of the (so-called extensional) axiom of - choice from setoids on locally compatible relations *) - -Definition SimpleSetoidFunctionalChoice_on A B := - forall R : A -> A -> Prop, - forall T : A -> B -> Prop, - Equivalence R -> - (forall x, exists y, forall x', R x x' -> T x' y) -> - exists f : A -> B, forall x : A, T x (f x) /\ (forall x' : A, R x x' -> f x = f x'). - -(** ID_epsilon = constructive version of indefinite description; - combined with proof-irrelevance, it may be connected to - Carlstrƶm's type theory with a constructive indefinite description - operator *) - -Definition ConstructiveIndefiniteDescription_on := - forall P:A->Prop, - (exists x, P x) -> { x:A | P x }. - -(** ID_iota = constructive version of definite description; - combined with proof-irrelevance, it may be connected to - Carlstrƶm's and Stenlund's type theory with a - constructive definite description operator) *) - -Definition ConstructiveDefiniteDescription_on := - forall P:A->Prop, - (exists! x, P x) -> { x:A | P x }. - -(** ** Weakly classical choice and description *) - -(** GAC_rel = guarded relational form of the (non extensional) axiom of choice *) - -Definition GuardedRelationalChoice_on := - forall P : A->Prop, forall R : A->B->Prop, - (forall x : A, P x -> exists y : B, R x y) -> - (exists R' : A->B->Prop, - subrelation R' R /\ forall x, P x -> exists! y, R' x y). - -(** GAC_fun = guarded functional form of the (non extensional) axiom of choice *) - -Definition GuardedFunctionalChoice_on := - forall P : A->Prop, forall R : A->B->Prop, - inhabited B -> - (forall x : A, P x -> exists y : B, R x y) -> - (exists f : A->B, forall x, P x -> R x (f x)). - -(** GAC! = guarded functional relation reification *) - -Definition GuardedFunctionalRelReification_on := - forall P : A->Prop, forall R : A->B->Prop, - inhabited B -> - (forall x : A, P x -> exists! y : B, R x y) -> - (exists f : A->B, forall x : A, P x -> R x (f x)). - -(** OAC_rel = "omniscient" relational form of the (non extensional) axiom of choice *) - -Definition OmniscientRelationalChoice_on := - forall R : A->B->Prop, - exists R' : A->B->Prop, - subrelation R' R /\ forall x : A, (exists y : B, R x y) -> exists! y, R' x y. - -(** OAC_fun = "omniscient" functional form of the (non extensional) axiom of choice - (called AC* in Bell [[Bell]]) *) - -Definition OmniscientFunctionalChoice_on := - forall R : A->B->Prop, - inhabited B -> - exists f : A->B, forall x : A, (exists y : B, R x y) -> R x (f x). - -(** D_epsilon = (weakly classical) indefinite description principle *) - -Definition EpsilonStatement_on := - forall P:A->Prop, - inhabited A -> { x:A | (exists x, P x) -> P x }. - -(** D_iota = (weakly classical) definite description principle *) - -Definition IotaStatement_on := - forall P:A->Prop, - inhabited A -> { x:A | (exists! x, P x) -> P x }. - -End ChoiceSchemes. - -(** Generalized schemes *) - -Notation RelationalChoice := - (forall A B : Type, RelationalChoice_on A B). -Notation FunctionalChoice := - (forall A B : Type, FunctionalChoice_on A B). -Notation DependentFunctionalChoice := - (forall A (B:A->Type), DependentFunctionalChoice_on B). -Notation InhabitedForallCommute := - (forall A (B : A -> Type), InhabitedForallCommute_on B). -Notation FunctionalDependentChoice := - (forall A : Type, FunctionalDependentChoice_on A). -Notation FunctionalCountableChoice := - (forall A : Type, FunctionalCountableChoice_on A). -Notation FunctionalChoiceOnInhabitedSet := - (forall A B : Type, inhabited B -> FunctionalChoice_on A B). -Notation FunctionalRelReification := - (forall A B : Type, FunctionalRelReification_on A B). -Notation DependentFunctionalRelReification := - (forall A (B:A->Type), DependentFunctionalRelReification_on B). -Notation RepresentativeFunctionalChoice := - (forall A : Type, RepresentativeFunctionalChoice_on A). -Notation SetoidFunctionalChoice := - (forall A B: Type, SetoidFunctionalChoice_on A B). -Notation GeneralizedSetoidFunctionalChoice := - (forall A B : Type, GeneralizedSetoidFunctionalChoice_on A B). -Notation SimpleSetoidFunctionalChoice := - (forall A B : Type, SimpleSetoidFunctionalChoice_on A B). - -Notation GuardedRelationalChoice := - (forall A B : Type, GuardedRelationalChoice_on A B). -Notation GuardedFunctionalChoice := - (forall A B : Type, GuardedFunctionalChoice_on A B). -Notation GuardedFunctionalRelReification := - (forall A B : Type, GuardedFunctionalRelReification_on A B). - -Notation OmniscientRelationalChoice := - (forall A B : Type, OmniscientRelationalChoice_on A B). -Notation OmniscientFunctionalChoice := - (forall A B : Type, OmniscientFunctionalChoice_on A B). - -Notation ConstructiveDefiniteDescription := - (forall A : Type, ConstructiveDefiniteDescription_on A). -Notation ConstructiveIndefiniteDescription := - (forall A : Type, ConstructiveIndefiniteDescription_on A). - -Notation IotaStatement := - (forall A : Type, IotaStatement_on A). -Notation EpsilonStatement := - (forall A : Type, EpsilonStatement_on A). - -(** Subclassical schemes *) - -(** PI = proof irrelevance *) -Definition ProofIrrelevance := - forall (A:Prop) (a1 a2:A), a1 = a2. - -(** IGP = independence of general premises - (an unconstrained generalisation of the constructive principle of - independence of premises) *) -Definition IndependenceOfGeneralPremises := - forall (A:Type) (P:A -> Prop) (Q:Prop), - inhabited A -> - (Q -> exists x, P x) -> exists x, Q -> P x. - -(** Drinker = drinker's paradox (small form) - (called Ex in Bell [[Bell]]) *) -Definition SmallDrinker'sParadox := - forall (A:Type) (P:A -> Prop), inhabited A -> - exists x, (exists x, P x) -> P x. - -(** EM = excluded-middle *) -Definition ExcludedMiddle := - forall P:Prop, P \/ ~ P. - -(** Extensional schemes *) - -(** Ext_prop_repr = choice of a representative among extensional propositions *) -Local Notation ExtensionalPropositionRepresentative := - (forall (A:Type), - exists h : Prop -> Prop, - forall P : Prop, (P <-> h P) /\ forall Q, (P <-> Q) -> h P = h Q). - -(** Ext_pred_repr = choice of a representative among extensional predicates *) -Local Notation ExtensionalPredicateRepresentative := - (forall (A:Type), - exists h : (A->Prop) -> (A->Prop), - forall (P : A -> Prop), (forall x, P x <-> h P x) /\ forall Q, (forall x, P x <-> Q x) -> h P = h Q). - -(** Ext_fun_repr = choice of a representative among extensional functions *) -Local Notation ExtensionalFunctionRepresentative := - (forall (A B:Type), - exists h : (A->B) -> (A->B), - forall (f : A -> B), (forall x, f x = h f x) /\ forall g, (forall x, f x = g x) -> h f = h g). - -(** We let also - -- IPL_2 = 2nd-order impredicative minimal predicate logic (with ex. quant.) -- IPL^2 = 2nd-order functional minimal predicate logic (with ex. quant.) -- IPL_2^2 = 2nd-order impredicative, 2nd-order functional minimal pred. logic (with ex. quant.) - -with no prerequisite on the non-emptiness of domains -*) - -(**********************************************************************) -(** * Table of contents *) - -(* This is very fragile. *) -(** -1. Definitions - -2. IPL_2^2 |- AC_rel + AC! = AC_fun - -3.1. typed IPL_2 + Sigma-types + PI |- AC_rel = GAC_rel and IPL_2 |- AC_rel + IGP -> GAC_rel and IPL_2 |- GAC_rel = OAC_rel - -3.2. IPL^2 |- AC_fun + IGP = GAC_fun = OAC_fun = AC_fun + Drinker - -3.3. D_iota -> ID_iota and D_epsilon <-> ID_epsilon + Drinker - -4. Derivability of choice for decidable relations with well-ordered codomain - -5. AC_fun = AC_fun_dep = AC_trunc - -6. Non contradiction of constructive descriptions wrt functional choices - -7. Definite description transports classical logic to the computational world - -8. Choice -> Dependent choice -> Countable choice - -9.1. AC_fun_setoid = AC_fun + Ext_fun_repr + EM - -9.2. AC_fun_setoid = AC_fun + Ext_pred_repr + PI - *) - -(**********************************************************************) -(** * AC_rel + AC! = AC_fun - - We show that the functional formulation of the axiom of Choice - (usual formulation in type theory) is equivalent to its relational - formulation (only formulation of set theory) + functional relation - reification (aka axiom of unique choice, or, principle of (parametric) - definite descriptions) *) - -(** This shows that the axiom of choice can be assumed (under its - relational formulation) without known inconsistency with classical logic, - though functional relation reification conflicts with classical logic *) - -Lemma functional_rel_reification_and_rel_choice_imp_fun_choice : - forall A B : Type, - FunctionalRelReification_on A B -> RelationalChoice_on A B -> FunctionalChoice_on A B. -Proof. - intros A B Descr RelCh R H. - destruct (RelCh R H) as (R',(HR'R,H0)). - destruct (Descr R') as (f,Hf). - - firstorder. - - exists f; intro x. - destruct (H0 x) as (y,(HR'xy,Huniq)). - rewrite <- (Huniq (f x) (Hf x)). - apply HR'R; assumption. -Qed. - -Lemma fun_choice_imp_rel_choice : - forall A B : Type, FunctionalChoice_on A B -> RelationalChoice_on A B. -Proof. - intros A B FunCh R H. - destruct (FunCh R H) as (f,H0). - exists (fun x y => f x = y). - split. - - intros x y Heq; rewrite <- Heq; trivial. - - intro x; exists (f x); split. - + reflexivity. - + trivial. -Qed. - -Lemma fun_choice_imp_functional_rel_reification : - forall A B : Type, FunctionalChoice_on A B -> FunctionalRelReification_on A B. -Proof. - intros A B FunCh R H. - destruct (FunCh R) as [f H0]. - - (* 1 *) - intro x. - destruct (H x) as (y,(HRxy,_)). - exists y; exact HRxy. - - (* 2 *) - exists f; exact H0. -Qed. - -Corollary fun_choice_iff_rel_choice_and_functional_rel_reification : - forall A B : Type, FunctionalChoice_on A B <-> - RelationalChoice_on A B /\ FunctionalRelReification_on A B. -Proof. - intros A B. split. - - intro H; split; - [ exact (fun_choice_imp_rel_choice H) - | exact (fun_choice_imp_functional_rel_reification H) ]. - - intros [H H0]; exact (functional_rel_reification_and_rel_choice_imp_fun_choice H0 H). -Qed. - -(**********************************************************************) -(** * Connection between the guarded, non guarded and omniscient choices *) - -(** We show that the guarded formulations of the axiom of choice - are equivalent to their "omniscient" variant and comes from the non guarded - formulation in presence either of the independence of general premises - or subset types (themselves derivable from subtypes thanks to proof- - irrelevance) *) - -(**********************************************************************) -(** ** AC_rel + PI -> GAC_rel and AC_rel + IGP -> GAC_rel and GAC_rel = OAC_rel *) - -Lemma rel_choice_and_proof_irrel_imp_guarded_rel_choice : - RelationalChoice -> ProofIrrelevance -> GuardedRelationalChoice. -Proof. - intros rel_choice proof_irrel. - red; intros A B P R H. - destruct (rel_choice _ _ (fun (x:sigT P) (y:B) => R (projT1 x) y)) as (R',(HR'R,H0)). - - intros (x,HPx). - destruct (H x HPx) as (y,HRxy). - exists y; exact HRxy. - - set (R'' := fun (x:A) (y:B) => exists H : P x, R' (existT P x H) y). - exists R''; split. - + intros x y (HPx,HR'xy). - change x with (projT1 (existT P x HPx)); apply HR'R; exact HR'xy. - + intros x HPx. - destruct (H0 (existT P x HPx)) as (y,(HR'xy,Huniq)). - exists y; split. - * exists HPx; exact HR'xy. - * intros y' (H'Px,HR'xy'). - apply Huniq. - rewrite proof_irrel with (a1 := HPx) (a2 := H'Px); exact HR'xy'. -Qed. - -Lemma rel_choice_indep_of_general_premises_imp_guarded_rel_choice : - forall A B : Type, inhabited B -> RelationalChoice_on A B -> - IndependenceOfGeneralPremises -> GuardedRelationalChoice_on A B. -Proof. - intros A B Inh AC_rel IndPrem P R H. - destruct (AC_rel (fun x y => P x -> R x y)) as (R',(HR'R,H0)). - - intro x. apply IndPrem. - + exact Inh. - + intro Hx. - apply H; assumption. - - exists (fun x y => P x /\ R' x y). - firstorder. -Qed. - -Lemma guarded_rel_choice_imp_rel_choice : - forall A B : Type, GuardedRelationalChoice_on A B -> RelationalChoice_on A B. -Proof. - intros A B GAC_rel R H. - destruct (GAC_rel (fun _ => True) R) as (R',(HR'R,H0)). - - firstorder. - - exists R'; firstorder. -Qed. - -Lemma subset_types_imp_guarded_rel_choice_iff_rel_choice : - ProofIrrelevance -> (GuardedRelationalChoice <-> RelationalChoice). -Proof. - intuition auto using - guarded_rel_choice_imp_rel_choice, - rel_choice_and_proof_irrel_imp_guarded_rel_choice. -Qed. - -(** OAC_rel = GAC_rel *) - -Corollary guarded_iff_omniscient_rel_choice : - GuardedRelationalChoice <-> OmniscientRelationalChoice. -Proof. - split. - - intros GAC_rel A B R. - apply (GAC_rel A B (fun x => exists y, R x y) R); auto. - - intros OAC_rel A B P R H. - destruct (OAC_rel A B R) as (f,Hf); exists f; firstorder. -Qed. - -(**********************************************************************) -(** ** AC_fun + IGP = GAC_fun = OAC_fun = AC_fun + Drinker *) - -(** AC_fun + IGP = GAC_fun *) - -Lemma guarded_fun_choice_imp_indep_of_general_premises : - GuardedFunctionalChoice -> IndependenceOfGeneralPremises. -Proof. - intros GAC_fun A P Q Inh H. - destruct (GAC_fun unit A (fun _ => Q) (fun _ => P) Inh) as (f,Hf). - - tauto. - - exists (f tt); auto. -Qed. - - -Lemma guarded_fun_choice_imp_fun_choice : - GuardedFunctionalChoice -> FunctionalChoiceOnInhabitedSet. -Proof. - intros GAC_fun A B Inh R H. - destruct (GAC_fun A B (fun _ => True) R Inh) as (f,Hf). - - firstorder. - - exists f; auto. -Qed. - -Lemma fun_choice_and_indep_general_prem_imp_guarded_fun_choice : - FunctionalChoiceOnInhabitedSet -> IndependenceOfGeneralPremises - -> GuardedFunctionalChoice. -Proof. - intros AC_fun IndPrem A B P R Inh H. - apply (AC_fun A B Inh (fun x y => P x -> R x y)). - intro x; apply IndPrem; eauto. -Qed. - -Corollary fun_choice_and_indep_general_prem_iff_guarded_fun_choice : - FunctionalChoiceOnInhabitedSet /\ IndependenceOfGeneralPremises - <-> GuardedFunctionalChoice. -Proof. - intuition auto using - guarded_fun_choice_imp_indep_of_general_premises, - guarded_fun_choice_imp_fun_choice, - fun_choice_and_indep_general_prem_imp_guarded_fun_choice. -Qed. - -(** AC_fun + Drinker = OAC_fun *) - -(** This was already observed by Bell [[Bell]] *) - -Lemma omniscient_fun_choice_imp_small_drinker : - OmniscientFunctionalChoice -> SmallDrinker'sParadox. -Proof. - intros OAC_fun A P Inh. - destruct (OAC_fun unit A (fun _ => P)) as (f,Hf). - - auto. - - exists (f tt); firstorder. -Qed. - -Lemma omniscient_fun_choice_imp_fun_choice : - OmniscientFunctionalChoice -> FunctionalChoiceOnInhabitedSet. -Proof. - intros OAC_fun A B Inh R H. - destruct (OAC_fun A B R Inh) as (f,Hf). - exists f; firstorder. -Qed. - -Lemma fun_choice_and_small_drinker_imp_omniscient_fun_choice : - FunctionalChoiceOnInhabitedSet -> SmallDrinker'sParadox - -> OmniscientFunctionalChoice. -Proof. - intros AC_fun Drinker A B R Inh. - destruct (AC_fun A B Inh (fun x y => (exists y, R x y) -> R x y)) as (f,Hf). - - intro x; apply (Drinker B (R x) Inh). - - exists f; assumption. -Qed. - -Corollary fun_choice_and_small_drinker_iff_omniscient_fun_choice : - FunctionalChoiceOnInhabitedSet /\ SmallDrinker'sParadox - <-> OmniscientFunctionalChoice. -Proof. - intuition auto using - omniscient_fun_choice_imp_small_drinker, - omniscient_fun_choice_imp_fun_choice, - fun_choice_and_small_drinker_imp_omniscient_fun_choice. -Qed. - -(** OAC_fun = GAC_fun *) - -(** This is derivable from the intuitionistic equivalence between IGP and Drinker -but we give a direct proof *) - -Theorem guarded_iff_omniscient_fun_choice : - GuardedFunctionalChoice <-> OmniscientFunctionalChoice. -Proof. - split. - - intros GAC_fun A B R Inh. - apply (GAC_fun A B (fun x => exists y, R x y) R); auto. - - intros OAC_fun A B P R Inh H. - destruct (OAC_fun A B R Inh) as (f,Hf). - exists f; firstorder. -Qed. - -(**********************************************************************) -(** ** D_iota -> ID_iota and D_epsilon <-> ID_epsilon + Drinker *) - -(** D_iota -> ID_iota *) - -Lemma iota_imp_constructive_definite_description : - IotaStatement -> ConstructiveDefiniteDescription. -Proof. - intros D_iota A P H. - destruct D_iota with (P:=P) as (x,H1). - - destruct H; red in H; auto. - - exists x; apply H1; assumption. -Qed. - -(** ID_epsilon + Drinker <-> D_epsilon *) - -Lemma epsilon_imp_constructive_indefinite_description: - EpsilonStatement -> ConstructiveIndefiniteDescription. -Proof. - intros D_epsilon A P H. - destruct D_epsilon with (P:=P) as (x,H1). - - destruct H; auto. - - exists x; apply H1; assumption. -Qed. - -Lemma constructive_indefinite_description_and_small_drinker_imp_epsilon : - SmallDrinker'sParadox -> ConstructiveIndefiniteDescription -> - EpsilonStatement. -Proof. - intros Drinkers D_epsilon A P Inh; - apply D_epsilon; apply Drinkers; assumption. -Qed. - -Lemma epsilon_imp_small_drinker : - EpsilonStatement -> SmallDrinker'sParadox. -Proof. - intros D_epsilon A P Inh; edestruct D_epsilon; eauto. -Qed. - -Theorem constructive_indefinite_description_and_small_drinker_iff_epsilon : - (SmallDrinker'sParadox * ConstructiveIndefiniteDescription -> - EpsilonStatement) * - (EpsilonStatement -> - SmallDrinker'sParadox * ConstructiveIndefiniteDescription). -Proof. - intuition auto using - epsilon_imp_constructive_indefinite_description, - constructive_indefinite_description_and_small_drinker_imp_epsilon, - epsilon_imp_small_drinker. -Qed. - -(**********************************************************************) -(** * Derivability of choice for decidable relations with well-ordered codomain *) - -(** Countable codomains, such as [nat], can be equipped with a - well-order, which implies the existence of a least element on - inhabited decidable subsets. As a consequence, the relational form of - the axiom of choice is derivable on [nat] for decidable relations. - - We show instead that functional relation reification and the - functional form of the axiom of choice are equivalent on decidable - relations with [nat] as codomain. -*) - -Require Import Wf_nat. -Require Import Decidable. - -Lemma classical_denumerable_description_imp_fun_choice : - forall A:Type, - FunctionalRelReification_on A nat -> - forall R:A->nat->Prop, - (forall x y, decidable (R x y)) -> FunctionalChoice_on_rel R. -Proof. - intros A Descr. - red; intros R Rdec H. - set (R':= fun x y => R x y /\ forall y', R x y' -> y <= y'). - destruct (Descr R') as (f,Hf). - - intro x. - apply (dec_inh_nat_subset_has_unique_least_element (R x)). - + apply Rdec. - + apply (H x). - - exists f. - intros x. - destruct (Hf x) as (Hfx,_). - assumption. -Qed. - -(**********************************************************************) -(** * AC_fun = AC_fun_dep = AC_trunc *) - -(** ** Choice on dependent and non dependent function types are equivalent *) - -(** The easy part *) - -Theorem dep_non_dep_functional_choice : - DependentFunctionalChoice -> FunctionalChoice. -Proof. - intros AC_depfun A B R H. - destruct (AC_depfun A (fun _ => B) R H) as (f,Hf). - exists f; trivial. -Qed. - -(** Deriving choice on product types requires some computation on - singleton propositional types, so we need computational - conjunction projections and dependent elimination of conjunction - and equality *) - -Scheme and_indd := Induction for and Sort Prop. -Scheme eq_indd := Induction for eq Sort Prop. - -Definition proj1_inf (A B:Prop) (p : A/\B) := - let (a,b) := p in a. - -Theorem non_dep_dep_functional_choice : - FunctionalChoice -> DependentFunctionalChoice. -Proof. - intros AC_fun A B R H. - pose (B' := { x:A & B x }). - pose (R' := fun (x:A) (y:B') => projT1 y = x /\ R (projT1 y) (projT2 y)). - destruct (AC_fun A B' R') as (f,Hf). - - intros x. destruct (H x) as (y,Hy). - exists (existT (fun x => B x) x y). split; trivial. - - exists (fun x => eq_rect _ _ (projT2 (f x)) _ (proj1_inf (Hf x))). - intro x; destruct (Hf x) as (Heq,HR) using and_indd. - destruct (f x); simpl in *. - destruct Heq using eq_indd; trivial. -Qed. - -(** ** Functional choice and truncation choice are equivalent *) - -Theorem functional_choice_to_inhabited_forall_commute : - FunctionalChoice -> InhabitedForallCommute. -Proof. - intros choose0 A B Hinhab. - pose proof (non_dep_dep_functional_choice choose0) as choose;clear choose0. - assert (Hexists : forall x, exists _ : B x, True). - { intros x;apply inhabited_sig_to_exists. - refine (inhabited_covariant _ (Hinhab x)). - intros y;exists y;exact I. } - apply choose in Hexists. - destruct Hexists as [f _]. - exact (inhabits f). -Qed. - -Theorem inhabited_forall_commute_to_functional_choice : - InhabitedForallCommute -> FunctionalChoice. -Proof. - intros choose A B R Hexists. - assert (Hinhab : forall x, inhabited {y : B | R x y}). - { intros x;apply exists_to_inhabited_sig;trivial. } - apply choose in Hinhab. destruct Hinhab as [f]. - exists (fun x => proj1_sig (f x)). - exact (fun x => proj2_sig (f x)). -Qed. - -(** ** Reification of dependent and non dependent functional relation are equivalent *) - -(** The easy part *) - -Theorem dep_non_dep_functional_rel_reification : - DependentFunctionalRelReification -> FunctionalRelReification. -Proof. - intros DepFunReify A B R H. - destruct (DepFunReify A (fun _ => B) R H) as (f,Hf). - exists f; trivial. -Qed. - -(** Deriving choice on product types requires some computation on - singleton propositional types, so we need computational - conjunction projections and dependent elimination of conjunction - and equality *) - -Theorem non_dep_dep_functional_rel_reification : - FunctionalRelReification -> DependentFunctionalRelReification. -Proof. - intros AC_fun A B R H. - pose (B' := { x:A & B x }). - pose (R' := fun (x:A) (y:B') => projT1 y = x /\ R (projT1 y) (projT2 y)). - destruct (AC_fun A B' R') as (f,Hf). - - intros x. destruct (H x) as (y,(Hy,Huni)). - exists (existT (fun x => B x) x y). repeat split; trivial. - intros (x',y') (Heqx',Hy'). - simpl in *. - destruct Heqx'. - rewrite (Huni y'); trivial. - - exists (fun x => eq_rect _ _ (projT2 (f x)) _ (proj1_inf (Hf x))). - intro x; destruct (Hf x) as (Heq,HR) using and_indd. - destruct (f x); simpl in *. - destruct Heq using eq_indd; trivial. -Qed. - -Corollary dep_iff_non_dep_functional_rel_reification : - FunctionalRelReification <-> DependentFunctionalRelReification. -Proof. - intuition auto using - non_dep_dep_functional_rel_reification, - dep_non_dep_functional_rel_reification. -Qed. - -(**********************************************************************) -(** * Non contradiction of constructive descriptions wrt functional axioms of choice *) - -(** ** Non contradiction of indefinite description *) - -Lemma relative_non_contradiction_of_indefinite_descr : - forall C:Prop, (ConstructiveIndefiniteDescription -> C) - -> (FunctionalChoice -> C). -Proof. - intros C H AC_fun. - assert (AC_depfun := non_dep_dep_functional_choice AC_fun). - pose (A0 := { A:Type & { P:A->Prop & exists x, P x }}). - pose (B0 := fun x:A0 => projT1 x). - pose (R0 := fun x:A0 => fun y:B0 x => projT1 (projT2 x) y). - pose (H0 := fun x:A0 => projT2 (projT2 x)). - destruct (AC_depfun A0 B0 R0 H0) as (f, Hf). - apply H. - intros A P H'. - exists (f (existT _ A (existT _ P H'))). - pose (Hf' := Hf (existT _ A (existT _ P H'))). - assumption. -Qed. - -Lemma constructive_indefinite_descr_fun_choice : - ConstructiveIndefiniteDescription -> FunctionalChoice. -Proof. - intros IndefDescr A B R H. - exists (fun x => proj1_sig (IndefDescr B (R x) (H x))). - intro x. - apply (proj2_sig (IndefDescr B (R x) (H x))). -Qed. - -(** ** Non contradiction of definite description *) - -Lemma relative_non_contradiction_of_definite_descr : - forall C:Prop, (ConstructiveDefiniteDescription -> C) - -> (FunctionalRelReification -> C). -Proof. - intros C H FunReify. - assert (DepFunReify := non_dep_dep_functional_rel_reification FunReify). - pose (A0 := { A:Type & { P:A->Prop & exists! x, P x }}). - pose (B0 := fun x:A0 => projT1 x). - pose (R0 := fun x:A0 => fun y:B0 x => projT1 (projT2 x) y). - pose (H0 := fun x:A0 => projT2 (projT2 x)). - destruct (DepFunReify A0 B0 R0 H0) as (f, Hf). - apply H. - intros A P H'. - exists (f (existT _ A (existT _ P H'))). - pose (Hf' := Hf (existT _ A (existT _ P H'))). - assumption. -Qed. - -Lemma constructive_definite_descr_fun_reification : - ConstructiveDefiniteDescription -> FunctionalRelReification. -Proof. - intros DefDescr A B R H. - exists (fun x => proj1_sig (DefDescr B (R x) (H x))). - intro x. - apply (proj2_sig (DefDescr B (R x) (H x))). -Qed. - -(** Remark, the following corollaries morally hold: - -Definition In_propositional_context (A:Type) := forall C:Prop, (A -> C) -> C. - -Corollary constructive_definite_descr_in_prop_context_iff_fun_reification : - In_propositional_context ConstructiveIndefiniteDescription - <-> FunctionalChoice. - -Corollary constructive_definite_descr_in_prop_context_iff_fun_reification : - In_propositional_context ConstructiveDefiniteDescription - <-> FunctionalRelReification. - -but expecting [FunctionalChoice] (resp. [FunctionalRelReification]) to -be applied on the same Type universes on both sides of the first -(resp. second) equivalence breaks the stratification of universes. -*) - -(**********************************************************************) -(** * Excluded-middle + definite description => computational excluded-middle *) - -(** The idea for the following proof comes from [[ChicliPottierSimpson02]] *) - -(** Classical logic and axiom of unique choice (i.e. functional - relation reification), as shown in [[ChicliPottierSimpson02]], - implies the double-negation of excluded-middle in [Set] (which is - incompatible with the impredicativity of [Set]). - - We adapt the proof to show that constructive definite description - transports excluded-middle from [Prop] to [Set]. - - [[ChicliPottierSimpson02]] Laurent Chicli, LoĆÆc Pottier, Carlos - Simpson, Mathematical Quotients and Quotient Types in Coq, - Proceedings of TYPES 2002, Lecture Notes in Computer Science 2646, - Springer Verlag. *) - -Require Import Setoid. - -Theorem constructive_definite_descr_excluded_middle : - (forall A : Type, ConstructiveDefiniteDescription_on A) -> - (forall P:Prop, P \/ ~ P) -> (forall P:Prop, {P} + {~ P}). -Proof. - intros Descr EM P. - pose (select := fun b:bool => if b then P else ~P). - assert { b:bool | select b } as ([|],HP). - - red in Descr. - apply Descr. - rewrite <- unique_existence; split. - + destruct (EM P). - * exists true; trivial. - * exists false; trivial. - + intros [|] [|] H1 H2; simpl in *; reflexivity || contradiction. - - left; trivial. - - right; trivial. -Qed. - -Corollary fun_reification_descr_computational_excluded_middle_in_prop_context : - FunctionalRelReification -> - (forall P:Prop, P \/ ~ P) -> - forall C:Prop, ((forall P:Prop, {P} + {~ P}) -> C) -> C. -Proof. - intros FunReify EM C H. pose proof relative_non_contradiction_of_definite_descr (C:=C); intuition auto using - constructive_definite_descr_excluded_middle. -Qed. - -(**********************************************************************) -(** * Choice => Dependent choice => Countable choice *) -(* The implications below are standard *) - -Require Import Arith. - -Theorem functional_choice_imp_functional_dependent_choice : - FunctionalChoice -> FunctionalDependentChoice. -Proof. - intros FunChoice A R HRfun x0. - apply FunChoice in HRfun as (g,Rg). - set (f:=fix f n := match n with 0 => x0 | S n' => g (f n') end). - exists f; firstorder. -Qed. - -Theorem functional_dependent_choice_imp_functional_countable_choice : - FunctionalDependentChoice -> FunctionalCountableChoice. -Proof. - intros H A R H0. - set (R' (p q:nat*A) := fst q = S (fst p) /\ R (fst p) (snd q)). - destruct (H0 0) as (y0,Hy0). - destruct H with (R:=R') (x0:=(0,y0)) as (f,(Hf0,HfS)). - - intro x; destruct (H0 (fst x)) as (y,Hy). - exists (S (fst x),y). - red. auto. - - assert (Heq:forall n, fst (f n) = n). - + induction n. - * rewrite Hf0; reflexivity. - * specialize HfS with n; destruct HfS as (->,_); congruence. - + exists (fun n => snd (f (S n))). - intro n'. specialize HfS with n'. - destruct HfS as (_,HR). - rewrite Heq in HR. - assumption. -Qed. - -(**********************************************************************) -(** * About the axiom of choice over setoids *) - -Require Import ClassicalFacts PropExtensionalityFacts. - -(**********************************************************************) -(** ** Consequences of the choice of a representative in an equivalence class *) - -Theorem repr_fun_choice_imp_ext_prop_repr : - RepresentativeFunctionalChoice -> ExtensionalPropositionRepresentative. -Proof. - intros ReprFunChoice A. - pose (R P Q := P <-> Q). - assert (Hequiv:Equivalence R) by (split; firstorder). - apply (ReprFunChoice _ R Hequiv). -Qed. - -Theorem repr_fun_choice_imp_ext_pred_repr : - RepresentativeFunctionalChoice -> ExtensionalPredicateRepresentative. -Proof. - intros ReprFunChoice A. - pose (R P Q := forall x : A, P x <-> Q x). - assert (Hequiv:Equivalence R) by (split; firstorder). - apply (ReprFunChoice _ R Hequiv). -Qed. - -Theorem repr_fun_choice_imp_ext_function_repr : - RepresentativeFunctionalChoice -> ExtensionalFunctionRepresentative. -Proof. - intros ReprFunChoice A B. - pose (R (f g : A -> B) := forall x : A, f x = g x). - assert (Hequiv:Equivalence R). - { split; try easy. firstorder using eq_trans. } - apply (ReprFunChoice _ R Hequiv). -Qed. - -(** *** This is a variant of Diaconescu and Goodman-Myhill theorems *) - -Theorem repr_fun_choice_imp_excluded_middle : - RepresentativeFunctionalChoice -> ExcludedMiddle. -Proof. - intros ReprFunChoice. - apply representative_boolean_partition_imp_excluded_middle, ReprFunChoice. -Qed. - -Theorem repr_fun_choice_imp_relational_choice : - RepresentativeFunctionalChoice -> RelationalChoice. -Proof. - intros ReprFunChoice A B T Hexists. - pose (D := (A*B)%type). - pose (R (z z':D) := - let x := fst z in - let x' := fst z' in - let y := snd z in - let y' := snd z' in - x = x' /\ (T x y -> y = y' \/ T x y') /\ (T x y' -> y = y' \/ T x y)). - assert (Hequiv : Equivalence R). - { split. - - split. + easy. + firstorder. - - intros (x,y) (x',y') (H1,(H2,H2')). split. - + easy. - + simpl fst in *. simpl snd in *. - subst x'. split; intro H. - * destruct (H2' H); firstorder. - * destruct (H2 H); firstorder. - - intros (x,y) (x',y') (x'',y'') (H1,(H2,H2')) (H3,(H4,H4')). - simpl fst in *. simpl snd in *. subst x'' x'. split. { easy. } split; intro H. - + simpl fst in *. simpl snd in *. destruct (H2 H) as [<-|H0]. - * destruct (H4 H); firstorder. - * destruct (H2' H0), (H4 H0); try subst y'; try subst y''; try firstorder. - + simpl fst in *. simpl snd in *. destruct (H4' H) as [<-|H0]. - * destruct (H2' H); firstorder. - * destruct (H2' H0), (H4 H0); try subst y'; try subst y''; try firstorder. } - destruct (ReprFunChoice D R Hequiv) as (g,Hg). - set (T' x y := T x y /\ exists y', T x y' /\ g (x,y') = (x,y)). - exists T'. split. - - intros x y (H,_); easy. - - intro x. destruct (Hexists x) as (y,Hy). - exists (snd (g (x,y))). - destruct (Hg (x,y)) as ((Heq1,(H',H'')),Hgxyuniq); clear Hg. - destruct (H' Hy) as [Heq2|Hgy]; clear H'. - + split;[split|]. - * rewrite <- Heq2. assumption. - * exists y. destruct (g (x,y)) as (x',y'). simpl in Heq1, Heq2. subst; easy. - * intros y' (Hy',(y'',(Hy'',Heq))). - rewrite (Hgxyuniq (x,y'')), Heq. { easy. } split. { easy. } - split; right; easy. - + split;[split|]. - * assumption. - * exists y. destruct (g (x,y)) as (x',y'). simpl in Heq1. subst x'; easy. - * intros y' (Hy',(y'',(Hy'',Heq))). - rewrite (Hgxyuniq (x,y'')), Heq. { easy. } split. { easy. } - split; right; easy. -Qed. - -(**********************************************************************) -(** ** AC_fun_setoid = AC_fun_setoid_gen = AC_fun_setoid_simple *) - -Theorem gen_setoid_fun_choice_imp_setoid_fun_choice : - forall A B, GeneralizedSetoidFunctionalChoice_on A B -> SetoidFunctionalChoice_on A B. -Proof. - intros A B GenSetoidFunChoice R T Hequiv Hcompat Hex. - apply GenSetoidFunChoice; try easy. - - apply eq_equivalence. - - intros * H <-. firstorder. -Qed. - -Theorem setoid_fun_choice_imp_gen_setoid_fun_choice : - forall A B, SetoidFunctionalChoice_on A B -> GeneralizedSetoidFunctionalChoice_on A B. -Proof. - intros A B SetoidFunChoice R S T HequivR HequivS Hcompat Hex. - destruct SetoidFunChoice with (R:=R) (T:=T) as (f,Hf); try easy. - { intros; apply (Hcompat x x' y y); try easy. } - exists f. intros x; specialize Hf with x as (Hf,Huniq). intuition. now erewrite Huniq. -Qed. - -Corollary setoid_fun_choice_iff_gen_setoid_fun_choice : - forall A B, SetoidFunctionalChoice_on A B <-> GeneralizedSetoidFunctionalChoice_on A B. -Proof. - split; auto using gen_setoid_fun_choice_imp_setoid_fun_choice, setoid_fun_choice_imp_gen_setoid_fun_choice. -Qed. - -Theorem setoid_fun_choice_imp_simple_setoid_fun_choice : - forall A B, SetoidFunctionalChoice_on A B -> SimpleSetoidFunctionalChoice_on A B. -Proof. - intros A B SetoidFunChoice R T Hequiv Hexists. - pose (T' x y := forall x', R x x' -> T x' y). - assert (Hcompat : forall (x x' : A) (y : B), R x x' -> T' x y -> T' x' y) by firstorder. - destruct (SetoidFunChoice R T' Hequiv Hcompat Hexists) as (f,Hf). - exists f. firstorder. -Qed. - -Theorem simple_setoid_fun_choice_imp_setoid_fun_choice : - forall A B, SimpleSetoidFunctionalChoice_on A B -> SetoidFunctionalChoice_on A B. -Proof. - intros A B SimpleSetoidFunChoice R T Hequiv Hcompat Hexists. - destruct (SimpleSetoidFunChoice R T Hequiv) as (f,Hf); firstorder. -Qed. - -Corollary setoid_fun_choice_iff_simple_setoid_fun_choice : - forall A B, SetoidFunctionalChoice_on A B <-> SimpleSetoidFunctionalChoice_on A B. -Proof. - split; auto using simple_setoid_fun_choice_imp_setoid_fun_choice, setoid_fun_choice_imp_simple_setoid_fun_choice. -Qed. - -(**********************************************************************) -(** ** AC_fun_setoid = AC! + AC_fun_repr *) - -Theorem setoid_fun_choice_imp_fun_choice : - forall A B, SetoidFunctionalChoice_on A B -> FunctionalChoice_on A B. -Proof. - intros A B SetoidFunChoice T Hexists. - destruct SetoidFunChoice with (R:=@eq A) (T:=T) as (f,Hf). - - apply eq_equivalence. - - now intros * ->. - - assumption. - - exists f. firstorder. -Qed. - -Corollary setoid_fun_choice_imp_functional_rel_reification : - forall A B, SetoidFunctionalChoice_on A B -> FunctionalRelReification_on A B. -Proof. - intros A B SetoidFunChoice. - apply fun_choice_imp_functional_rel_reification. - now apply setoid_fun_choice_imp_fun_choice. -Qed. - -Theorem setoid_fun_choice_imp_repr_fun_choice : - SetoidFunctionalChoice -> RepresentativeFunctionalChoice . -Proof. - intros SetoidFunChoice A R Hequiv. - apply SetoidFunChoice; firstorder. -Qed. - -Theorem functional_rel_reification_and_repr_fun_choice_imp_setoid_fun_choice : - FunctionalRelReification -> RepresentativeFunctionalChoice -> SetoidFunctionalChoice. -Proof. - intros FunRelReify ReprFunChoice A B R T Hequiv Hcompat Hexists. - assert (FunChoice : FunctionalChoice). - { intros A' B'. apply functional_rel_reification_and_rel_choice_imp_fun_choice. - - apply FunRelReify. - - now apply repr_fun_choice_imp_relational_choice. } - destruct (FunChoice _ _ T Hexists) as (f,Hf). - destruct (ReprFunChoice A R Hequiv) as (g,Hg). - exists (fun a => f (g a)). - intro x. destruct (Hg x) as (Hgx,HRuniq). - split. - - eapply Hcompat. - + symmetry. apply Hgx. - + apply Hf. - - intros y Hxy. f_equal. auto. -Qed. - -Theorem functional_rel_reification_and_repr_fun_choice_iff_setoid_fun_choice : - FunctionalRelReification /\ RepresentativeFunctionalChoice <-> SetoidFunctionalChoice. -Proof. - split; intros. - - now apply functional_rel_reification_and_repr_fun_choice_imp_setoid_fun_choice. - - split. - + now intros A B; apply setoid_fun_choice_imp_functional_rel_reification. - + now apply setoid_fun_choice_imp_repr_fun_choice. -Qed. - -(** Note: What characterization to give of -RepresentativeFunctionalChoice? A formulation of it as a functional -relation would certainly be equivalent to the formulation of -SetoidFunctionalChoice as a functional relation, but in their -functional forms, SetoidFunctionalChoice seems strictly stronger *) - -(**********************************************************************) -(** * AC_fun_setoid = AC_fun + Ext_fun_repr + EM *) - -Import EqNotations. - -(** ** This is the main theorem in [[Carlstrƶm04]] *) - -(** Note: all ingredients have a computational meaning when taken in - separation. However, to compute with the functional choice, - existential quantification has to be thought as a strong - existential, which is incompatible with the computational content of - excluded-middle *) - -Theorem fun_choice_and_ext_functions_repr_and_excluded_middle_imp_setoid_fun_choice : - FunctionalChoice -> ExtensionalFunctionRepresentative -> ExcludedMiddle -> RepresentativeFunctionalChoice. -Proof. - intros FunChoice SetoidFunRepr EM A R (Hrefl,Hsym,Htrans). - assert (H:forall P:Prop, exists b, b = true <-> P). - { intros P. destruct (EM P). - - exists true; firstorder. - - exists false; easy. } - destruct (FunChoice _ _ _ H) as (c,Hc). - pose (class_of a y := c (R a y)). - pose (isclass f := exists x:A, f x = true). - pose (class := {f:A -> bool | isclass f}). - pose (contains (c:class) (a:A) := proj1_sig c a = true). - destruct (FunChoice class A contains) as (f,Hf). - - intros f. destruct (proj2_sig f) as (x,Hx). - exists x. easy. - - destruct (SetoidFunRepr A bool) as (h,Hh). - assert (Hisclass:forall a, isclass (h (class_of a))). - { intro a. exists a. destruct (Hh (class_of a)) as (Ha,Huniqa). - rewrite <- Ha. apply Hc. apply Hrefl. } - pose (f':= fun a => exist _ (h (class_of a)) (Hisclass a) : class). - exists (fun a => f (f' a)). - intros x. destruct (Hh (class_of x)) as (Hx,Huniqx). split. - + specialize Hf with (f' x). unfold contains in Hf. simpl in Hf. rewrite <- Hx in Hf. apply Hc. assumption. - + intros y Hxy. - f_equal. - assert (Heq1: h (class_of x) = h (class_of y)). - { apply Huniqx. intro z. unfold class_of. - destruct (c (R x z)) eqn:Hxz. - - symmetry. apply Hc. apply -> Hc in Hxz. firstorder. - - destruct (c (R y z)) eqn:Hyz. - + apply -> Hc in Hyz. rewrite <- Hxz. apply Hc. firstorder. - + easy. } - assert (Heq2:rew Heq1 in Hisclass x = Hisclass y). - { apply proof_irrelevance_cci, EM. } - unfold f'. - rewrite <- Heq2. - rewrite <- Heq1. - reflexivity. -Qed. - -Theorem setoid_functional_choice_first_characterization : - FunctionalChoice /\ ExtensionalFunctionRepresentative /\ ExcludedMiddle <-> SetoidFunctionalChoice. -Proof. - split. - - intros (FunChoice & SetoidFunRepr & EM). - apply functional_rel_reification_and_repr_fun_choice_imp_setoid_fun_choice. - + intros A B. apply fun_choice_imp_functional_rel_reification, FunChoice. - + now apply fun_choice_and_ext_functions_repr_and_excluded_middle_imp_setoid_fun_choice. - - intro SetoidFunChoice. repeat split. - + now intros A B; apply setoid_fun_choice_imp_fun_choice. - + apply repr_fun_choice_imp_ext_function_repr. - now apply setoid_fun_choice_imp_repr_fun_choice. - + apply repr_fun_choice_imp_excluded_middle. - now apply setoid_fun_choice_imp_repr_fun_choice. -Qed. - -(**********************************************************************) -(** ** AC_fun_setoid = AC_fun + Ext_pred_repr + PI *) - -(** Note: all ingredients have a computational meaning when taken in - separation. However, to compute with the functional choice, - existential quantification has to be thought as a strong - existential, which is incompatible with proof-irrelevance which - requires existential quantification to be truncated *) - -Theorem fun_choice_and_ext_pred_ext_and_proof_irrel_imp_setoid_fun_choice : - FunctionalChoice -> ExtensionalPredicateRepresentative -> ProofIrrelevance -> RepresentativeFunctionalChoice. -Proof. - intros FunChoice PredExtRepr PI A R (Hrefl,Hsym,Htrans). - pose (isclass P := exists x:A, P x). - pose (class := {P:A -> Prop | isclass P}). - pose (contains (c:class) (a:A) := proj1_sig c a). - pose (class_of a := R a). - destruct (FunChoice class A contains) as (f,Hf). - - intros c. apply proj2_sig. - - destruct (PredExtRepr A) as (h,Hh). - assert (Hisclass:forall a, isclass (h (class_of a))). - { intro a. exists a. destruct (Hh (class_of a)) as (Ha,Huniqa). - rewrite <- Ha; apply Hrefl. } - pose (f':= fun a => exist _ (h (class_of a)) (Hisclass a) : class). - exists (fun a => f (f' a)). - intros x. destruct (Hh (class_of x)) as (Hx,Huniqx). split. - + specialize Hf with (f' x). simpl in Hf. rewrite <- Hx in Hf. assumption. - + intros y Hxy. - f_equal. - assert (Heq1: h (class_of x) = h (class_of y)). - { apply Huniqx. intro z. unfold class_of. firstorder. } - assert (Heq2:rew Heq1 in Hisclass x = Hisclass y). - { apply PI. } - unfold f'. - rewrite <- Heq2. - rewrite <- Heq1. - reflexivity. -Qed. - -Theorem setoid_functional_choice_second_characterization : - FunctionalChoice /\ ExtensionalPredicateRepresentative /\ ProofIrrelevance <-> SetoidFunctionalChoice. -Proof. - split. - - intros (FunChoice & ExtPredRepr & PI). - apply functional_rel_reification_and_repr_fun_choice_imp_setoid_fun_choice. - + intros A B. now apply fun_choice_imp_functional_rel_reification. - + now apply fun_choice_and_ext_pred_ext_and_proof_irrel_imp_setoid_fun_choice. - - intro SetoidFunChoice. repeat split. - + now intros A B; apply setoid_fun_choice_imp_fun_choice. - + apply repr_fun_choice_imp_ext_pred_repr. - now apply setoid_fun_choice_imp_repr_fun_choice. - + red. apply proof_irrelevance_cci. - apply repr_fun_choice_imp_excluded_middle. - now apply setoid_fun_choice_imp_repr_fun_choice. -Qed. - -(**********************************************************************) -(** * Compatibility notations *) -Notation description_rel_choice_imp_funct_choice := - functional_rel_reification_and_rel_choice_imp_fun_choice (only parsing). - -Notation funct_choice_imp_rel_choice := fun_choice_imp_rel_choice (only parsing). - -Notation FunChoice_Equiv_RelChoice_and_ParamDefinDescr := - fun_choice_iff_rel_choice_and_functional_rel_reification (only parsing). - -Notation funct_choice_imp_description := fun_choice_imp_functional_rel_reification (only parsing). diff --git a/stdlib/theories/Logic/Classical.v b/stdlib/theories/Logic/Classical.v deleted file mode 100644 index a0392aa9bb95..000000000000 --- a/stdlib/theories/Logic/Classical.v +++ /dev/null @@ -1,16 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* false] in [Set]. *) - -Require Export ClassicalUniqueChoice. -Require Export RelationalChoice. -Require Import ChoiceFacts. - -Set Implicit Arguments. - -Definition subset (U:Type) (P Q:U->Prop) : Prop := forall x, P x -> Q x. - -Theorem singleton_choice : - forall (A : Type) (P : A->Prop), - (exists x : A, P x) -> exists P' : A->Prop, subset P' P /\ exists! x, P' x. -Proof. -intros A P H. -destruct (relational_choice unit A (fun _ => P) (fun _ => H)) as (R',(Hsub,HR')). -exists (R' tt); firstorder. -Qed. - -Theorem choice : - forall (A B : Type) (R : A->B->Prop), - (forall x : A, exists y : B, R x y) -> - exists f : A->B, (forall x : A, R x (f x)). -Proof. -intros A B. -apply description_rel_choice_imp_funct_choice. -- exact (unique_choice A B). -- exact (relational_choice A B). -Qed. diff --git a/stdlib/theories/Logic/ClassicalDescription.v b/stdlib/theories/Logic/ClassicalDescription.v deleted file mode 100644 index e5c69f061740..000000000000 --- a/stdlib/theories/Logic/ClassicalDescription.v +++ /dev/null @@ -1,87 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* Prop), inhabited A -> - { x : A | (exists! x : A, P x) -> P x }. -Proof. -intros A P i. -destruct (excluded_middle_informative (exists! x, P x)) as [Hex|HnonP]. -- apply constructive_definite_description with (P:= fun x => (exists! x : A, P x) -> P x). - destruct Hex as (x,(Hx,Huni)). - exists x; split. - + intros _; exact Hx. - + firstorder. -- exists i; tauto. -Qed. - -(** Church's iota operator *) - -Definition iota (A : Type) (i:inhabited A) (P : A->Prop) : A - := proj1_sig (classical_definite_description P i). - -Definition iota_spec (A : Type) (i:inhabited A) (P : A->Prop) : - (exists! x:A, P x) -> P (iota i P) - := proj2_sig (classical_definite_description P i). - -(** Axiom of unique "choice" (functional reification of functional relations) *) -Theorem dependent_unique_choice : - forall (A:Type) (B:A -> Type) (R:forall x:A, B x -> Prop), - (forall x:A, exists! y : B x, R x y) -> - (exists f : (forall x:A, B x), forall x:A, R x (f x)). -Proof. -intros A B R H. -assert (Hexuni:forall x, exists! y, R x y). -- intro x. apply H. -- exists (fun x => proj1_sig (constructive_definite_description (R x) (Hexuni x))). - intro x. - apply (proj2_sig (constructive_definite_description (R x) (Hexuni x))). -Qed. - -Theorem unique_choice : - forall (A B:Type) (R:A -> B -> Prop), - (forall x:A, exists! y : B, R x y) -> - (exists f : A -> B, forall x:A, R x (f x)). -Proof. -intros A B. -apply dependent_unique_choice with (B:=fun _:A => B). -Qed. - -(** Compatibility lemmas *) - -Unset Implicit Arguments. - -Definition dependent_description := dependent_unique_choice. -Definition description := unique_choice. diff --git a/stdlib/theories/Logic/ClassicalEpsilon.v b/stdlib/theories/Logic/ClassicalEpsilon.v deleted file mode 100644 index af8b1b85cca6..000000000000 --- a/stdlib/theories/Logic/ClassicalEpsilon.v +++ /dev/null @@ -1,102 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* Prop), - (exists x, P x) -> { x : A | P x }. - -Lemma constructive_definite_description : - forall (A : Type) (P : A->Prop), - (exists! x, P x) -> { x : A | P x }. -Proof. - intros; apply constructive_indefinite_description; firstorder. -Qed. - -Theorem excluded_middle_informative : forall P:Prop, {P} + {~ P}. -Proof. - apply - (constructive_definite_descr_excluded_middle - constructive_definite_description classic). -Qed. - -Theorem classical_indefinite_description : - forall (A : Type) (P : A->Prop), inhabited A -> - { x : A | (exists x, P x) -> P x }. -Proof. - intros A P i. - destruct (excluded_middle_informative (exists x, P x)) as [Hex|HnonP]. - - apply constructive_indefinite_description - with (P:= fun x => (exists x, P x) -> P x). - destruct Hex as (x,Hx). - exists x; intros _; exact Hx. - - assert {x : A | True} as (a,_). - { apply constructive_indefinite_description with (P := fun _ : A => True). - destruct i as (a); firstorder. } - firstorder. -Defined. - -(** Hilbert's epsilon operator *) - -Definition epsilon (A : Type) (i:inhabited A) (P : A->Prop) : A - := proj1_sig (classical_indefinite_description P i). - -Definition epsilon_spec (A : Type) (i:inhabited A) (P : A->Prop) : - (exists x, P x) -> P (epsilon i P) - := proj2_sig (classical_indefinite_description P i). - -(** Open question: is classical_indefinite_description constructively - provable from [relational_choice] and - [constructive_definite_description] (at least, using the fact that - [functional_choice] is provable from [relational_choice] and - [unique_choice], we know that the double negation of - [classical_indefinite_description] is provable (see - [relative_non_contradiction_of_indefinite_desc]). *) - -(** A proof that if [P] is inhabited, [epsilon a P] does not depend on - the actual proof that the domain of [P] is inhabited - (proof idea kindly provided by Pierre CastĆ©ran) *) - -Lemma epsilon_inh_irrelevance : - forall (A:Type) (i j : inhabited A) (P:A->Prop), - (exists x, P x) -> epsilon i P = epsilon j P. -Proof. - intros. - unfold epsilon, classical_indefinite_description. - destruct (excluded_middle_informative (exists x : A, P x)) as [|[]]; trivial. -Qed. - -Opaque epsilon. - -(** *** Weaker lemmas (compatibility lemmas) *) - -Theorem choice : - forall (A B : Type) (R : A->B->Prop), - (forall x : A, exists y : B, R x y) -> - (exists f : A->B, forall x : A, R x (f x)). -Proof. - intros A B R H. - exists (fun x => proj1_sig (constructive_indefinite_description _ (H x))). - intro x. - apply (proj2_sig (constructive_indefinite_description _ (H x))). -Qed. diff --git a/stdlib/theories/Logic/ClassicalFacts.v b/stdlib/theories/Logic/ClassicalFacts.v deleted file mode 100644 index 24e3e35da0ec..000000000000 --- a/stdlib/theories/Logic/ClassicalFacts.v +++ /dev/null @@ -1,896 +0,0 @@ -(* -*- coding: utf-8 -*- *) -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* (A = A->A) -> A has fixpoint - -2.2. CC |- prop. ext. + dep elim on bool -> proof-irrelevance - -2.3. CIC |- prop. ext. -> proof-irrelevance - -2.4. CC |- excluded-middle + dep elim on bool -> proof-irrelevance - -2.5. CIC |- excluded-middle -> proof-irrelevance - -3. Weak classical axioms - -3.1. Weak excluded middle and classical de Morgan law - -3.2. Gƶdel-Dummett axiom and right distributivity of implication over - disjunction - -3.3. Independence of general premises and drinker's paradox - -3.4. Relativized independence of general premises and excluded-middle - -4. Principles equivalent to classical logic - -4.1 Classical logic = principle of unrestricted minimization - -4.2 Classical logic = choice of representatives in a partition of bool -*) - -(************************************************************************) -(** * Prop degeneracy = excluded-middle + prop extensionality *) -(** - i.e. [(forall A, A=True \/ A=False) - <-> - (forall A, A\/~A) /\ (forall A B, (A<->B) -> A=B)] -*) - -(** [prop_degeneracy] (also referred to as propositional completeness) - asserts (up to consistency) that there are only two distinct formulas *) -Definition prop_degeneracy := forall A:Prop, A = True \/ A = False. - -(** [prop_extensionality] asserts that equivalent formulas are equal *) -Definition prop_extensionality := forall A B:Prop, (A <-> B) -> A = B. - -(** [excluded_middle] asserts that we can reason by case on the truth - or falsity of any formula *) -Definition excluded_middle := forall A:Prop, A \/ ~ A. - -(** We show [prop_degeneracy <-> (prop_extensionality /\ excluded_middle)] *) - -Lemma prop_degen_ext : prop_degeneracy -> prop_extensionality. -Proof. - intros H A B [Hab Hba]. - destruct (H A); destruct (H B). - - rewrite H1; exact H0. - - absurd B. - + rewrite H1; exact (fun H => H). - + apply Hab; rewrite H0; exact I. - - absurd A. - + rewrite H0; exact (fun H => H). - + apply Hba; rewrite H1; exact I. - - rewrite H1; exact H0. -Qed. - -Lemma prop_degen_em : prop_degeneracy -> excluded_middle. -Proof. - intros H A. - destruct (H A). - - left; rewrite H0; exact I. - - right; rewrite H0; exact (fun x => x). -Qed. - -Lemma prop_ext_em_degen : - prop_extensionality -> excluded_middle -> prop_degeneracy. -Proof. - intros Ext EM A. - destruct (EM A). - - left; apply (Ext A True); split; - [ exact (fun _ => I) | exact (fun _ => H) ]. - - right; apply (Ext A False); split; [ exact H | apply False_ind ]. -Qed. - -(** A weakest form of propositional extensionality: extensionality for - provable propositions only *) - -Require Import PropExtensionalityFacts. - -Definition provable_prop_extensionality := forall A:Prop, A -> A = True. - -Lemma provable_prop_ext : - prop_extensionality -> provable_prop_extensionality. -Proof. - exact PropExt_imp_ProvPropExt. -Qed. - -(************************************************************************) -(** * Classical logic and proof-irrelevance *) - -(************************************************************************) -(** ** CC |- prop ext + A inhabited -> (A = A->A) -> A has fixpoint *) - -(** We successively show that: - - [prop_extensionality] - implies equality of [A] and [A->A] for inhabited [A], which - implies the existence of a (trivial) retract from [A->A] to [A] - (just take the identity), which - implies the existence of a fixpoint operator in [A] - (e.g. take the Y combinator of lambda-calculus) - -*) - -Local Notation inhabited A := A (only parsing). - -Lemma prop_ext_A_eq_A_imp_A : - prop_extensionality -> forall A:Prop, inhabited A -> (A -> A) = A. -Proof. - intros Ext A a. - apply (Ext (A -> A) A); split; [ exact (fun _ => a) | exact (fun _ _ => a) ]. -Qed. - -Record retract (A B:Prop) : Prop := - {f1 : A -> B; f2 : B -> A; f1_o_f2 : forall x:B, f1 (f2 x) = x}. - -Lemma prop_ext_retract_A_A_imp_A : - prop_extensionality -> forall A:Prop, inhabited A -> retract A (A -> A). -Proof. - intros Ext A a. - rewrite (prop_ext_A_eq_A_imp_A Ext A a). - exists (fun x:A => x) (fun x:A => x). - reflexivity. -Qed. - -Record has_fixpoint (A:Prop) : Prop := - {F : (A -> A) -> A; Fix : forall f:A -> A, F f = f (F f)}. - -Lemma ext_prop_fixpoint : - prop_extensionality -> forall A:Prop, inhabited A -> has_fixpoint A. -Proof. - intros Ext A a. - case (prop_ext_retract_A_A_imp_A Ext A a); intros g1 g2 g1_o_g2. - exists (fun f => (fun x:A => f (g1 x x)) (g2 (fun x => f (g1 x x)))). - intro f. - pattern (g1 (g2 (fun x:A => f (g1 x x)))) at 1. - rewrite (g1_o_g2 (fun x:A => f (g1 x x))). - reflexivity. -Qed. - -(** Remark: [prop_extensionality] can be replaced in lemma [ext_prop_fixpoint] - by the weakest property [provable_prop_extensionality]. -*) - -(************************************************************************) -(** ** CC |- prop_ext /\ dep elim on bool -> proof-irrelevance *) - -(** [proof_irrelevance] asserts equality of all proofs of a given formula *) -Definition proof_irrelevance := forall (A:Prop) (a1 a2:A), a1 = a2. - -(** Assume that we have booleans with the property that there is at most 2 - booleans (which is equivalent to dependent case analysis). Consider - the fixpoint of the negation function: it is either true or false by - dependent case analysis, but also the opposite by fixpoint. Hence - proof-irrelevance. - - We then map equality of boolean proofs to proof irrelevance in all - propositions. -*) - -Section Proof_irrelevance_gen. - - Variable bool : Prop. - Variable true : bool. - Variable false : bool. - Hypothesis bool_elim : forall C:Prop, C -> C -> bool -> C. - Hypothesis - bool_elim_redl : forall (C:Prop) (c1 c2:C), c1 = bool_elim C c1 c2 true. - Hypothesis - bool_elim_redr : forall (C:Prop) (c1 c2:C), c2 = bool_elim C c1 c2 false. - Let bool_dep_induction := - forall P:bool -> Prop, P true -> P false -> forall b:bool, P b. - - Lemma aux : prop_extensionality -> bool_dep_induction -> true = false. - Proof. - intros Ext Ind. - case (ext_prop_fixpoint Ext bool true); intros G Gfix. - set (neg := fun b:bool => bool_elim bool false true b). - generalize (eq_refl (G neg)). - pattern (G neg) at 1. - apply Ind with (b := G neg); intro Heq. - - rewrite (bool_elim_redl bool false true). - change (true = neg true); rewrite Heq; apply Gfix. - - rewrite (bool_elim_redr bool false true). - change (neg false = false); rewrite Heq; symmetry ; - apply Gfix. - Qed. - - Lemma ext_prop_dep_proof_irrel_gen : - prop_extensionality -> bool_dep_induction -> proof_irrelevance. - Proof. - intros Ext Ind A a1 a2. - set (f := fun b:bool => bool_elim A a1 a2 b). - rewrite (bool_elim_redl A a1 a2). - change (f true = a2). - rewrite (bool_elim_redr A a1 a2). - change (f true = f false). - rewrite (aux Ext Ind). - reflexivity. - Qed. - -End Proof_irrelevance_gen. - -(** In the pure Calculus of Constructions, we can define the boolean - proposition bool = (C:Prop)C->C->C but we cannot prove that it has at - most 2 elements. -*) - -Section Proof_irrelevance_Prop_Ext_CC. - - Definition BoolP := forall C:Prop, C -> C -> C. - Definition TrueP : BoolP := fun C c1 c2 => c1. - Definition FalseP : BoolP := fun C c1 c2 => c2. - Definition BoolP_elim C c1 c2 (b:BoolP) := b C c1 c2. - Definition BoolP_elim_redl (C:Prop) (c1 c2:C) : - c1 = BoolP_elim C c1 c2 TrueP := eq_refl c1. - Definition BoolP_elim_redr (C:Prop) (c1 c2:C) : - c2 = BoolP_elim C c1 c2 FalseP := eq_refl c2. - - Definition BoolP_dep_induction := - forall P:BoolP -> Prop, P TrueP -> P FalseP -> forall b:BoolP, P b. - - Lemma ext_prop_dep_proof_irrel_cc : - prop_extensionality -> BoolP_dep_induction -> proof_irrelevance. - Proof. - exact (ext_prop_dep_proof_irrel_gen BoolP TrueP FalseP BoolP_elim BoolP_elim_redl - BoolP_elim_redr). - Qed. - -End Proof_irrelevance_Prop_Ext_CC. - -(** Remark: [prop_extensionality] can be replaced in lemma - [ext_prop_dep_proof_irrel_gen] by the weakest property - [provable_prop_extensionality]. -*) - -(************************************************************************) -(** ** CIC |- prop. ext. -> proof-irrelevance *) - -(** In the Calculus of Inductive Constructions, inductively defined booleans - enjoy dependent case analysis, hence directly proof-irrelevance from - propositional extensionality. -*) - -Section Proof_irrelevance_CIC. - - Inductive boolP : Prop := - | trueP : boolP - | falseP : boolP. - Definition boolP_elim_redl (C:Prop) (c1 c2:C) : - c1 = boolP_ind C c1 c2 trueP := eq_refl c1. - Definition boolP_elim_redr (C:Prop) (c1 c2:C) : - c2 = boolP_ind C c1 c2 falseP := eq_refl c2. - Scheme boolP_indd := Induction for boolP Sort Prop. - - Lemma ext_prop_dep_proof_irrel_cic : prop_extensionality -> proof_irrelevance. - Proof. - exact (fun pe => - ext_prop_dep_proof_irrel_gen boolP trueP falseP boolP_ind boolP_elim_redl - boolP_elim_redr pe boolP_indd). - Qed. - -End Proof_irrelevance_CIC. - -(** Can we state proof irrelevance from propositional degeneracy - (i.e. propositional extensionality + excluded middle) without - dependent case analysis ? - - Berardi [[Berardi90]] built a model of CC interpreting inhabited - types by the set of all untyped lambda-terms. This model satisfies - propositional degeneracy without satisfying proof-irrelevance (nor - dependent case analysis). This implies that the previous results - cannot be refined. - - [[Berardi90]] Stefano Berardi, "Type dependence and constructive - mathematics", Ph. D. thesis, Dipartimento Matematica, UniversitĆ  di - Torino, 1990. -*) - -(************************************************************************) -(** ** CC |- excluded-middle + dep elim on bool -> proof-irrelevance *) - -(** This is a proof in the pure Calculus of Construction that - classical logic in [Prop] + dependent elimination of disjunction entails - proof-irrelevance. - - Reference: - - [[Coquand90]] T. Coquand, "Metamathematical Investigations of a - Calculus of Constructions", Proceedings of Logic in Computer Science - (LICS'90), 1990. - - Proof skeleton: classical logic + dependent elimination of - disjunction + discrimination of proofs implies the existence of a - retract from [Prop] into [bool], hence inconsistency by encoding any - paradox of system U- (e.g. Hurkens' paradox). -*) - -Require Import Hurkens. - -Section Proof_irrelevance_EM_CC. - - Variable or : Prop -> Prop -> Prop. - Variable or_introl : forall A B:Prop, A -> or A B. - Variable or_intror : forall A B:Prop, B -> or A B. - Hypothesis or_elim : forall A B C:Prop, (A -> C) -> (B -> C) -> or A B -> C. - Hypothesis - or_elim_redl : - forall (A B C:Prop) (f:A -> C) (g:B -> C) (a:A), - f a = or_elim A B C f g (or_introl A B a). - Hypothesis - or_elim_redr : - forall (A B C:Prop) (f:A -> C) (g:B -> C) (b:B), - g b = or_elim A B C f g (or_intror A B b). - Hypothesis - or_dep_elim : - forall (A B:Prop) (P:or A B -> Prop), - (forall a:A, P (or_introl A B a)) -> - (forall b:B, P (or_intror A B b)) -> forall b:or A B, P b. - - Hypothesis em : forall A:Prop, or A (~ A). - Variable B : Prop. - Variables b1 b2 : B. - - (** [p2b] and [b2p] form a retract if [~b1=b2] *) - - Let p2b A := or_elim A (~ A) B (fun _ => b1) (fun _ => b2) (em A). - Let b2p b := b1 = b. - - Lemma p2p1 : forall A:Prop, A -> b2p (p2b A). - Proof. - unfold p2b; intro A; apply or_dep_elim with (b := em A); - unfold b2p; intros. - - apply (or_elim_redl A (~ A) B (fun _ => b1) (fun _ => b2)). - - destruct (b H). - Qed. - - Lemma p2p2 : b1 <> b2 -> forall A:Prop, b2p (p2b A) -> A. - Proof. - intro not_eq_b1_b2. - unfold p2b; intro A; apply or_dep_elim with (b := em A); - unfold b2p; intros. - - assumption. - - destruct not_eq_b1_b2. - rewrite <- (or_elim_redr A (~ A) B (fun _ => b1) (fun _ => b2)) in H. - assumption. - Qed. - - (** Using excluded-middle a second time, we get proof-irrelevance *) - - Theorem proof_irrelevance_cc : b1 = b2. - Proof. - refine (or_elim _ _ _ _ _ (em (b1 = b2))); intro H. - - trivial. - - apply (NoRetractFromSmallPropositionToProp.paradox B p2b b2p (p2p2 H) p2p1). - Qed. - -End Proof_irrelevance_EM_CC. - -(** Hurkens' paradox still holds with a retract from the _negative_ - fragment of [Prop] into [bool], hence weak classical logic, - i.e. [forall A, ~A\/~~A], is enough for deriving a weak version of - proof-irrelevance. This is enough to derive a contradiction from a - [Set]-bound weak excluded middle with an impredicative [Set] - universe. *) - -Section Proof_irrelevance_WEM_CC. - - Variable or : Prop -> Prop -> Prop. - Variable or_introl : forall A B:Prop, A -> or A B. - Variable or_intror : forall A B:Prop, B -> or A B. - Hypothesis or_elim : forall A B C:Prop, (A -> C) -> (B -> C) -> or A B -> C. - Hypothesis - or_elim_redl : - forall (A B C:Prop) (f:A -> C) (g:B -> C) (a:A), - f a = or_elim A B C f g (or_introl A B a). - Hypothesis - or_elim_redr : - forall (A B C:Prop) (f:A -> C) (g:B -> C) (b:B), - g b = or_elim A B C f g (or_intror A B b). - Hypothesis - or_dep_elim : - forall (A B:Prop) (P:or A B -> Prop), - (forall a:A, P (or_introl A B a)) -> - (forall b:B, P (or_intror A B b)) -> forall b:or A B, P b. - - Hypothesis wem : forall A:Prop, or (~~A) (~ A). - - Local Notation NProp := NoRetractToNegativeProp.NProp. - Local Notation El := NoRetractToNegativeProp.El. - - Variable B : Prop. - Variables b1 b2 : B. - - (** [p2b] and [b2p] form a retract if [~b1=b2] *) - - Let p2b (A:NProp) := or_elim (~~El A) (~El A) B (fun _ => b1) (fun _ => b2) (wem (El A)). - Let b2p b : NProp := exist (fun P=>~~P -> P) (~~(b1 = b)) (fun h x => h (fun k => k x)). - - Lemma wp2p1 : forall A:NProp, El A -> El (b2p (p2b A)). - Proof. - intros A. unfold p2b. - apply or_dep_elim with (b := wem (El A)). - + intros nna a. - rewrite <- or_elim_redl. - cbn. auto. - + intros n x. - destruct (n x). - Qed. - - Lemma wp2p2 : b1 <> b2 -> forall A:NProp, El (b2p (p2b A)) -> El A. - Proof. - intro not_eq_b1_b2. - intros A. unfold p2b. - apply or_dep_elim with (b := wem (El A)). - + cbn. - intros x _. - destruct A. cbn in x |- *. - auto. - + intros na. - rewrite <- or_elim_redr. cbn. - intros h. destruct (h not_eq_b1_b2). - Qed. - - (** By Hurkens's paradox, we get a weak form of proof irrelevance. *) - - Theorem wproof_irrelevance_cc : ~~(b1 = b2). - Proof. - intros h. - unshelve (refine (let NB := exist (fun P=>~~P -> P) B _ in _)). - { exact (fun _ => b1). } - pose proof (NoRetractToNegativeProp.paradox NB p2b b2p (wp2p2 h) wp2p1) as paradox. - unshelve (refine (let F := exist (fun P=>~~P->P) False _ in _)). - { auto. } - exact (paradox F). - Qed. - -End Proof_irrelevance_WEM_CC. - -(************************************************************************) -(** ** CIC |- excluded-middle -> proof-irrelevance *) - -(** - Since, dependent elimination is derivable in the Calculus of - Inductive Constructions (CCI), we get proof-irrelevance from classical - logic in the CCI. -*) - -Section Proof_irrelevance_CCI. - - Hypothesis em : forall A:Prop, A \/ ~ A. - - Definition or_elim_redl (A B C:Prop) (f:A -> C) (g:B -> C) - (a:A) : f a = or_ind f g (or_introl B a) := eq_refl (f a). - Definition or_elim_redr (A B C:Prop) (f:A -> C) (g:B -> C) - (b:B) : g b = or_ind f g (or_intror A b) := eq_refl (g b). - Scheme or_indd := Induction for or Sort Prop. - - Theorem proof_irrelevance_cci : forall (B:Prop) (b1 b2:B), b1 = b2. - Proof. - exact (proof_irrelevance_cc or or_introl or_intror or_ind or_elim_redl - or_elim_redr or_indd em). - Qed. - -End Proof_irrelevance_CCI. - -(** The same holds with weak excluded middle. The proof is a little - more involved, however. *) - - - -Section Weak_proof_irrelevance_CCI. - - Hypothesis wem : forall A:Prop, ~~A \/ ~ A. - - Theorem wem_proof_irrelevance_cci : forall (B:Prop) (b1 b2:B), ~~b1 = b2. - Proof. - exact (wproof_irrelevance_cc or or_introl or_intror or_ind or_elim_redl - or_elim_redr or_indd wem). - Qed. - -End Weak_proof_irrelevance_CCI. - -(** Remark: in the Set-impredicative CCI, Hurkens' paradox still holds with - [bool] in [Set] and since [~true=false] for [true] and [false] - in [bool] from [Set], we get the inconsistency of - [em : forall A:Prop, {A}+{~A}] in the Set-impredicative CCI. -*) - -(** * Weak classical axioms *) - -(** We show the following increasing in the strength of axioms: - - weak excluded-middle and classical De Morgan's law - - right distributivity of implication over disjunction and Gƶdel-Dummett axiom - - independence of general premises and drinker's paradox - - excluded-middle -*) - -(** ** Weak excluded-middle *) - -(** The weak classical logic based on [~~A \/ ~A] is referred to with - name KC in [[ChagrovZakharyaschev97]]. See [[SorbiTerwijn11]] for - a short survey. - - [[ChagrovZakharyaschev97]] Alexander Chagrov and Michael - Zakharyaschev, "Modal Logic", Clarendon Press, 1997. - - [[SorbiTerwijn11]] Andrea Sorbi and Sebastiaan A. Terwijn, - "Generalizations of the weak law of the excluded-middle", Notre - Dame J. Formal Logic, vol 56(2), pp 321-331, 2015. *) - -Definition weak_excluded_middle := - forall A:Prop, ~~A \/ ~A. - -(** The interest in the equivalent variant - [weak_generalized_excluded_middle] is that it holds even in logic - without a primitive [False] connective (like Gƶdel-Dummett axiom) *) - -Definition weak_generalized_excluded_middle := - forall A B:Prop, ((A -> B) -> B) \/ (A -> B). - -(** Classical De Morgan's law *) - -Definition classical_de_morgan_law := - forall A B:Prop, ~(A /\ B) -> ~A \/ ~B. - -(** ** Gƶdel-Dummett axiom *) - -(** [(A->B) \/ (B->A)] is studied in [[Dummett59]] and is based on [[Gƶdel33]]. - - [[Dummett59]] Michael A. E. Dummett. "A Propositional Calculus - with a Denumerable Matrix", In the Journal of Symbolic Logic, vol - 24(2), pp 97-103, 1959. - - [[Gƶdel33]] Kurt Gƶdel. "Zum intuitionistischen AussagenkalkĆ¼l", - Ergeb. Math. Koll. 4, pp. 34-38, 1933. - *) - -Definition GodelDummett := forall A B:Prop, (A -> B) \/ (B -> A). - -Lemma excluded_middle_Godel_Dummett : excluded_middle -> GodelDummett. -Proof. - intros EM A B. destruct (EM B) as [HB|HnotB]. - - left; intros _; exact HB. - - right; intros HB; destruct (HnotB HB). -Qed. - -(** [(A->B) \/ (B->A)] is equivalent to [(C -> A\/B) -> (C->A) \/ (C->B)] - (proof from [[Dummett59]]) *) - -Definition RightDistributivityImplicationOverDisjunction := - forall A B C:Prop, (C -> A\/B) -> (C->A) \/ (C->B). - -Lemma Godel_Dummett_iff_right_distr_implication_over_disjunction : - GodelDummett <-> RightDistributivityImplicationOverDisjunction. -Proof. - split. - - intros GD A B C HCAB. - destruct (GD B A) as [HBA|HAB]; [left|right]; intro HC; - destruct (HCAB HC) as [HA|HB]; [ | apply HBA | apply HAB | ]; assumption. - - intros Distr A B. - destruct (Distr A B (A\/B)) as [HABA|HABB]. - + intro HAB; exact HAB. - + right; intro HB; apply HABA; right; assumption. - + left; intro HA; apply HABB; left; assumption. -Qed. - -(** [(A->B) \/ (B->A)] is stronger than the weak excluded middle *) - -Lemma Godel_Dummett_weak_excluded_middle : - GodelDummett -> weak_excluded_middle. -Proof. - intros GD A. destruct (GD (~A) A) as [HnotAA|HAnotA]. - - left; intro HnotA; apply (HnotA (HnotAA HnotA)). - - right; intro HA; apply (HAnotA HA HA). -Qed. - -(** The weak excluded middle is equivalent to the classical De Morgan's law *) - -Lemma weak_excluded_middle_iff_classical_de_morgan_law : - weak_excluded_middle <-> classical_de_morgan_law. -Proof. - split; [intro WEM|intro CDML]; intros A *. - - destruct (WEM A); tauto. - - destruct (CDML A (~A)); tauto. -Qed. - -(** ** Independence of general premises and drinker's paradox *) - -(** Independence of general premises is the unconstrained - (i.e. without the constraint of the premise being negative) - version of the Independence of Premises considered in - [[Troelstra73]]. - - In the context of intuitionistic arithmetic (and actually already - in the context of the theory of Boolean values), it generalizes - the right distributivity of implication over disjunction (and - hence Gƶdel-Dummett axiom). Note contrastingly that both the usual - constrained independence of premises and the right distributivity - of implication formula over distributivity with the constraint - that the implication is from a negative formula (that is - Kreisel-Putnam principle [[KreiselPutnam57]]) preserve the - disjunction property. - - In the context of predicate logic, the Independence of general - premises is however weaker than the right distributivity of - implication over disjunction (hence of Gƶdel-Dummett axiom) since - its restriction to a singleton domain makes it collapse to an - intuitionistic propositional tautology while right distributivity - of implication over disjunction is definitely not - intuitionistically propositionally provable (consider the Kripke - model with a root node splitting into an node with C and A and an - other node with C and B). - - [[KreiselPutnam57]], Georg Kreisel and Hilary Putnam. "Eine - Unableitsbarkeitsbeweismethode fĆ¼r den intuitionistischen - AussagenkalkĆ¼l". Archiv fĆ¼r Mathematische Logik und - Graundlagenforschung, 3:74- 78, 1957. - - [[Troelstra73]], Anne Troelstra, editor. Metamathematical - Investigation of Intuitionistic Arithmetic and Analysis, volume - 344 of Lecture Notes in Mathematics, Springer-Verlag, 1973. -*) - -Definition IndependenceOfGeneralPremises A := - forall (P:A -> Prop) (Q:Prop), - inhabited A -> (Q -> exists x, P x) -> exists x, Q -> P x. - -Lemma - independence_general_premises_right_distr_implication_over_disjunction : - IndependenceOfGeneralPremises bool -> RightDistributivityImplicationOverDisjunction. -Proof. - intros IGP A B C HCAB. - destruct (IGP (fun b => if b then A else B) C true) as ([|],H). - - intro HC; destruct (HCAB HC); [exists true|exists false]; assumption. - - left; assumption. - - right; assumption. -Qed. - -Lemma independence_general_premises_Godel_Dummett : - IndependenceOfGeneralPremises bool -> GodelDummett. -Proof. - destruct Godel_Dummett_iff_right_distr_implication_over_disjunction. - auto using independence_general_premises_right_distr_implication_over_disjunction. -Qed. - -(** The Drinker's paradox [[Smullyan78]] and its dual (a weak form of indefinite - description, see e.g. in [[WarrenDienerMcKubreJordens18]]) - -[[Smullyan78]] What is the Name of this Book? Raymond Smullyan, 1978. - -[[WarrenDienerMcKubreJordens18]] The Drinker Paradox and its Dual, -Louis Warren and Hannes Diener and Maarten McKubre-Jordens, 2018, unpublished. -*) - -Definition DrinkerParadox A := - forall (P:A -> Prop), - inhabited A -> exists x, P x -> forall y, P y. - -Definition DualDrinkerParadox A := - forall (P:A -> Prop), - inhabited A -> exists x, (exists x, P x) -> P x. - -(** Independence of general premises is equivalent to the dual drinker's paradox *) - -Lemma independence_general_premises_dual_drinker A : - IndependenceOfGeneralPremises A <-> DualDrinkerParadox A. -Proof. - split. - - intros IGP P InhA; apply (IGP P (exists x, P x) InhA); intro Hx; exact Hx. - - intros DualDrinker P Q InhA H; destruct (DualDrinker P InhA) as (x,Hx). - exists x; intro HQ; apply (Hx (H HQ)). -Qed. - -(** Independence of general premises is a consequence of (generalized) - excluded middle - -Remark: generalized excluded middle is preferred here to avoid relying on -the "ex falso quodlibet" property (i.e. [False -> forall A, A]) -*) - -Definition generalized_excluded_middle := - forall A B:Prop, A \/ (A -> B). - -Lemma excluded_middle_drinker_paradox A : - generalized_excluded_middle -> DrinkerParadox A. -Proof. - intros GEM P x0. - destruct (GEM (exists x, P x -> (forall y, P y)) (forall y, P y)) as [(x,Hx)|Hnot]. - - exists x. exact Hx. - - exists x0. intros _ y. destruct (GEM (P y) (forall y, P y)) as [|H]. - + assumption. - + apply Hnot. exists y. exact H. -Qed. - -Lemma excluded_middle_dual_drinker_paradox A : - generalized_excluded_middle -> DualDrinkerParadox A. -Proof. - intros GEM P x0. - destruct (GEM (exists x, P x) (P x0)) as [(x,Hx)|Hnot]. - - exists x; intro; exact Hx. - - exists x0; exact Hnot. -Qed. - -(** Using subtypes to relativize the domain, independence of general - premises is equivalent to excluded-middle in the theory of Boolean - values (see Kirst and Zeng, 2024) *) - -Notation "x .1" := (projT1 x) (at level 1, left associativity, format "x .1"). -Notation "( x ; y )" := (existT _ x y) (at level 0, format "'[' ( x ; '/ ' y ) ']'"). - -Definition RelativizedIndependenceOfGeneralPremises A (P : A -> Prop) := - IndependenceOfGeneralPremises {a:A & P a}. - -Lemma - relativized_independence_general_premises_excluded_middle : - (forall P, RelativizedIndependenceOfGeneralPremises bool P) -> excluded_middle. -Proof. - intros RIGP A. - destruct (RIGP (fun b => b = true \/ A) (fun b => b.1 = false) A) as ((x,[->|H1]),H2). - - exists true. left. reflexivity. - - intro HA. exists (false; or_intror HA). reflexivity. - - right. intro HA. apply H2 in HA. discriminate. - - left. assumption. -Qed. - -(** Similarly, using subtypes, drinker's paradox on Boolean values - implies excluded-middile *) - -Definition RelativizedDualDrinkerParadox A (P : A -> Prop) := - DualDrinkerParadox {a : A & P a}. - -Lemma - relativized_dual_drinker_paradox_excluded_middle : - (forall P, RelativizedDualDrinkerParadox bool P) -> excluded_middle. -Proof. - intros RDP. apply relativized_independence_general_premises_excluded_middle. - intro P. apply independence_general_premises_dual_drinker, RDP. -Qed. - -(** * Axioms equivalent to classical logic *) - -(** ** Principle of unrestricted minimization *) - -Require Import Stdlib.Arith.PeanoNat. - -Definition Minimal (P:nat -> Prop) (n:nat) : Prop := - P n /\ forall k, P k -> n<=k. - -Definition Minimization_Property (P : nat -> Prop) : Prop := - forall n, P n -> exists m, Minimal P m. - -Section Unrestricted_minimization_entails_excluded_middle. - - Hypothesis unrestricted_minimization: forall P, Minimization_Property P. - - Theorem unrestricted_minimization_entails_excluded_middle : forall A, A\/~A. - Proof. - intros A. - pose (P := fun n:nat => n=0/\A \/ n=1). - assert (P 1) as h. - { unfold P. intuition. } - assert (P 0 <-> A) as pā‚€. - { split. - + intros [[_ hā‚€]|[=]]. assumption. - + unfold P. tauto. } - apply unrestricted_minimization in h as ([|[|m]] & hm & hmm). - + intuition. - + right. - intros HA. apply pā‚€, hmm, PeanoNat.Nat.nle_succ_0 in HA. assumption. - + destruct hm as [([=],_) | [=] ]. - Qed. - -End Unrestricted_minimization_entails_excluded_middle. - -Require Import Wf_nat. - -Section Excluded_middle_entails_unrestricted_minimization. - - Hypothesis em : forall A, A\/~A. - - Theorem excluded_middle_entails_unrestricted_minimization : - forall P, Minimization_Property P. - Proof. - intros P n HPn. - assert (dec : forall n, P n \/ ~ P n) by auto using em. - assert (ex : exists n, P n) by (exists n; assumption). - destruct (dec_inh_nat_subset_has_unique_least_element P dec ex) as (n' & HPn' & _). - exists n'. assumption. - Qed. - -End Excluded_middle_entails_unrestricted_minimization. - -(** However, minimization for a given predicate does not necessarily imply - decidability of this predicate *) - -Section Example_of_undecidable_predicate_with_the_minimization_property. - - Variable s : nat -> bool. - - Let P n := exists k, n<=k /\ s k = true. - - Example undecidable_predicate_with_the_minimization_property : - Minimization_Property P. - Proof. - unfold Minimization_Property. - intros h hn. - exists 0. split. - + unfold P in *. destruct hn as (k&hkā‚&hkā‚‚). - exists k. split. - * rewrite <- hkā‚. - apply PeanoNat.Nat.le_0_l. - * assumption. - + intros **. apply PeanoNat.Nat.le_0_l. - Qed. - -End Example_of_undecidable_predicate_with_the_minimization_property. - -(** ** Choice of representatives in a partition of bool *) - -(** This is similar to Bell's "weak extensional selection principle" in [[Bell]] - - [[Bell]] John L. Bell, Choice principles in intuitionistic set theory, unpublished. -*) - -Require Import RelationClasses. - -Local Notation representative_boolean_partition := - (forall R:bool->bool->Prop, - Equivalence R -> exists f, forall x, R x (f x) /\ forall y, R x y -> f x = f y). - -Theorem representative_boolean_partition_imp_excluded_middle : - representative_boolean_partition -> excluded_middle. -Proof. - intros ReprFunChoice P. - pose (R (b1 b2 : bool) := b1 = b2 \/ P). - assert (Equivalence R). - { split. - - now left. - - destruct 1. + now left. + now right. - - destruct 1, 1; try now right. left; now transitivity y. } - destruct (ReprFunChoice R H) as (f,Hf). clear H. - destruct (Bool.bool_dec (f true) (f false)) as [Heq|Hneq]. - + left. - destruct (Hf false) as ([Hfalse|HP],_); try easy. - destruct (Hf true) as ([Htrue|HP],_); try easy. - congruence. - + right. intro HP. - destruct (Hf true) as (_,H). apply Hneq, H. now right. -Qed. - -Theorem excluded_middle_imp_representative_boolean_partition : - excluded_middle -> representative_boolean_partition. -Proof. - intros EM R H. - destruct (EM (R true false)). - - exists (fun _ => true). - intros []; firstorder. - - exists (fun b => b). - intro b. split. - + reflexivity. - + destruct b, y; intros HR; easy || now symmetry in HR. -Qed. - -Theorem excluded_middle_iff_representative_boolean_partition : - excluded_middle <-> representative_boolean_partition. -Proof. - split; auto using excluded_middle_imp_representative_boolean_partition, - representative_boolean_partition_imp_excluded_middle. -Qed. diff --git a/stdlib/theories/Logic/ClassicalUniqueChoice.v b/stdlib/theories/Logic/ClassicalUniqueChoice.v deleted file mode 100644 index 2dec94ed059a..000000000000 --- a/stdlib/theories/Logic/ClassicalUniqueChoice.v +++ /dev/null @@ -1,94 +0,0 @@ -(* -*- coding: utf-8 -*- *) -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* Type) (R:forall x:A, B x -> Prop), - (forall x : A, exists! y : B x, R x y) -> - (exists f : (forall x:A, B x), forall x:A, R x (f x)). - -(** Unique choice reifies functional relations into functions *) - -Theorem unique_choice : - forall (A B:Type) (R:A -> B -> Prop), - (forall x:A, exists! y : B, R x y) -> - (exists f:A->B, forall x:A, R x (f x)). -Proof. -intros A B. -apply (dependent_unique_choice A (fun _ => B)). -Qed. - - -(** The following proof comes from [[ChicliPottierSimpson02]] *) -Require Import Setoid. - -Theorem classic_set_in_prop_context : - forall C:Prop, ((forall P:Prop, {P} + {~ P}) -> C) -> C. -Proof. -intros C HnotEM. -set (R := fun A b => A /\ true = b \/ ~ A /\ false = b). -assert (H : exists f : Prop -> bool, (forall A:Prop, R A (f A))). { -apply unique_choice. -intro A. -destruct (classic A) as [Ha| Hnota]. -- exists true; split. - + left; split; [ assumption | reflexivity ]. - + intros y [[_ Hy]| [Hna _]]. - * assumption. - * contradiction. -- exists false; split. - + right; split; [ assumption | reflexivity ]. - + intros y [[Ha _]| [_ Hy]]. - * contradiction. - * assumption. -} -destruct H as [f Hf]. -apply HnotEM. -intro P. -assert (HfP := Hf P). -(* Elimination from Hf to Set is not allowed but from f to Set yes ! *) -destruct (f P). -- left. - destruct HfP as [[Ha _]| [_ Hfalse]]. - + assumption. - + discriminate. -- right. - destruct HfP as [[_ Hfalse]| [Hna _]]. - + discriminate. - + assumption. -Qed. - -Corollary not_not_classic_set : - ((forall P:Prop, {P} + {~ P}) -> False) -> False. -Proof. -apply classic_set_in_prop_context. -Qed. - -(* Compatibility *) -Notation classic_set := not_not_classic_set (only parsing). diff --git a/stdlib/theories/Logic/Classical_Pred_Type.v b/stdlib/theories/Logic/Classical_Pred_Type.v deleted file mode 100644 index cb9f6abc4e44..000000000000 --- a/stdlib/theories/Logic/Classical_Pred_Type.v +++ /dev/null @@ -1,74 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* Prop, ~ (forall n:U, ~ P n) -> exists n : U, P n. -Proof. -intros P notall. -apply NNPP. -intro abs. -apply notall. -intros n H. -apply abs; exists n; exact H. -Qed. - -Lemma not_all_ex_not : - forall P:U -> Prop, ~ (forall n:U, P n) -> exists n : U, ~ P n. -Proof. -intros P notall. -apply not_all_not_ex with (P:=fun x => ~ P x). -intro all; apply notall. -intro n; apply NNPP. -apply all. -Qed. - -Lemma not_ex_all_not : - forall P:U -> Prop, ~ (exists n : U, P n) -> forall n:U, ~ P n. -Proof. (* Intuitionistic *) -unfold not; intros P notex n abs. -apply notex. -exists n; trivial. -Qed. - -Lemma not_ex_not_all : - forall P:U -> Prop, ~ (exists n : U, ~ P n) -> forall n:U, P n. -Proof. -intros P H n. -apply NNPP. -red; intro K; apply H; exists n; trivial. -Qed. - -Lemma ex_not_not_all : - forall P:U -> Prop, (exists n : U, ~ P n) -> ~ (forall n:U, P n). -Proof. (* Intuitionistic *) -unfold not; intros P exnot allP. -elim exnot; auto. -Qed. - -Lemma all_not_not_ex : - forall P:U -> Prop, (forall n:U, ~ P n) -> ~ (exists n : U, P n). -Proof. (* Intuitionistic *) -unfold not; intros P allnot exP; elim exP; intros n p. -apply allnot with n; auto. -Qed. - -End Generic. diff --git a/stdlib/theories/Logic/Classical_Prop.v b/stdlib/theories/Logic/Classical_Prop.v deleted file mode 100644 index ce20ccebcdc4..000000000000 --- a/stdlib/theories/Logic/Classical_Prop.v +++ /dev/null @@ -1,126 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* p. -Proof. -unfold not; intros; elim (classic p); auto. -intro NP; elim (H NP). -Qed. - -Register NNPP as core.nnpp.type. - -(** Peirce's law states [forall P Q:Prop, ((P -> Q) -> P) -> P]. - Thanks to [forall P, False -> P], it is equivalent to the - following form *) - -Lemma Peirce : forall P:Prop, ((P -> False) -> P) -> P. -Proof. -intros P H; destruct (classic P); auto. -Qed. - -Lemma not_imply_elim : forall P Q:Prop, ~ (P -> Q) -> P. -Proof. -intros; apply NNPP; red. -intro; apply H; intro; absurd P; trivial. -Qed. - -Lemma not_imply_elim2 : forall P Q:Prop, ~ (P -> Q) -> ~ Q. -Proof. (* Intuitionistic *) -tauto. -Qed. - -Lemma imply_to_or : forall P Q:Prop, (P -> Q) -> ~ P \/ Q. -Proof. -intros; elim (classic P); auto. -Qed. - -Lemma imply_to_and : forall P Q:Prop, ~ (P -> Q) -> P /\ ~ Q. -Proof. -intros; split. -- apply not_imply_elim with Q; trivial. -- apply not_imply_elim2 with P; trivial. -Qed. - -Lemma or_to_imply : forall P Q:Prop, ~ P \/ Q -> P -> Q. -Proof. (* Intuitionistic *) -tauto. -Qed. - -Lemma not_and_or : forall P Q:Prop, ~ (P /\ Q) -> ~ P \/ ~ Q. -Proof. -intros; elim (classic P); auto. -Qed. - -Lemma or_not_and : forall P Q:Prop, ~ P \/ ~ Q -> ~ (P /\ Q). -Proof. -simple induction 1; red; simple induction 2; auto. -Qed. - -Lemma not_or_and : forall P Q:Prop, ~ (P \/ Q) -> ~ P /\ ~ Q. -Proof. (* Intuitionistic *) -tauto. -Qed. - -Lemma and_not_or : forall P Q:Prop, ~ P /\ ~ Q -> ~ (P \/ Q). -Proof. (* Intuitionistic *) -tauto. -Qed. - -Lemma imply_and_or : forall P Q:Prop, (P -> Q) -> P \/ Q -> Q. -Proof. (* Intuitionistic *) -tauto. -Qed. - -Lemma imply_and_or2 : forall P Q R:Prop, (P -> Q) -> P \/ R -> Q \/ R. -Proof. (* Intuitionistic *) -tauto. -Qed. - -Lemma proof_irrelevance : forall (P:Prop) (p1 p2:P), p1 = p2. -Proof proof_irrelevance_cci classic. - -(* classical_left transforms |- A \/ B into ~B |- A *) -(* classical_right transforms |- A \/ B into ~A |- B *) - -Ltac classical_right := match goal with -|- ?X \/ _ => (elim (classic X);intro;[left;trivial|right]) -end. - -Ltac classical_left := match goal with -|- _ \/ ?X => (elim (classic X);intro;[right;trivial|left]) -end. - -Require Export EqdepFacts. - -Module Eq_rect_eq. - -Lemma eq_rect_eq : - forall (U:Type) (p:U) (Q:U -> Type) (x:Q p) (h:p = p), x = eq_rect p Q x p h. -Proof. -intros; rewrite proof_irrelevance with (p1:=h) (p2:=eq_refl p); reflexivity. -Qed. - -End Eq_rect_eq. - -Module EqdepTheory := EqdepTheory(Eq_rect_eq). -Export EqdepTheory. diff --git a/stdlib/theories/Logic/ConstructiveEpsilon.v b/stdlib/theories/Logic/ConstructiveEpsilon.v deleted file mode 100644 index 3e0db8318d3c..000000000000 --- a/stdlib/theories/Logic/ConstructiveEpsilon.v +++ /dev/null @@ -1,448 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* Prop. - -Hypothesis P_dec : forall n, {P n}+{~(P n)}. - - -(** The termination argument is [before_witness n], which says that -any number before any witness (not necessarily the [x] of [exists x :A, P x]) -makes the search eventually stops. *) - -Inductive before_witness (n:nat) : Prop := - | stop : P n -> before_witness n - | next : before_witness (S n) -> before_witness n. - -(* Computation of the initial termination certificate *) -Fixpoint O_witness (n : nat) : before_witness n -> before_witness 0 := - match n return (before_witness n -> before_witness 0) with - | 0 => fun b => b - | S n => fun b => O_witness n (next n b) - end. - -(* Inversion of [inv_before_witness n] in a way such that the result -is structurally smaller even in the [stop] case. *) -Definition inv_before_witness : - forall n, before_witness n -> ~(P n) -> before_witness (S n) := - fun n b not_p => - match b with - | stop _ p => match not_p p with end - | next _ b => b - end. - -(** Basic program *) -Fixpoint prog_linear_search start (b : before_witness start) : nat := - match P_dec start with - | left yes => start - | right no => prog_linear_search (S start) (inv_before_witness start b no) - end. - -(** rel_ls = relational version of linear search *) -Inductive rel_ls : nat -> nat -> Prop := -| Rstop : forall {found}, P found -> rel_ls found found -| Rnext : forall {start found}, ~(P start) -> rel_ls (S start) found -> rel_ls start found. - -(** Following the Braga method, the output is packed with a proof of its conformity wrt rel_ls *) -Definition linear_search_conform start (b : before_witness start) : {n : nat | rel_ls start n}. - revert start b. - refine (fix loop start b := - match P_dec start with - | left yes => exist _ start _ - | right no => - let (n, r) := loop (S start) (inv_before_witness start b no) in - exist _ n _ - end). - - apply (Rstop yes). - - apply (Rnext no r). -Defined. - -(** A variant where the computational contents is closer to [prog_linear_search] - (no deconstruction/reconstruction of the result), using a suitable - abstraction of the postcondition. - The predicate [rel_ls start] is abstracted into [Q], with an additional - implication [rq] they are equivalent (but only one direction is needed); - and as linear search is tail recursive, [Q] can be fixed (but [rq] varies, - behaving like a logical continuation). *) -Definition linear_search_conform_alt start (b : before_witness start) : {n : nat | rel_ls start n}. - refine ((fun Q: nat -> Prop => _ : (forall y, rel_ls start y -> Q y) -> {n | Q n}) - (rel_ls start) (fun y r => r)). - revert start b. - refine (fix loop start b := - fun rq => - match P_dec start with - | left yes => exist _ start _ - | right no => loop (S start) (inv_before_witness start b no) _ - end). - - apply rq, (Rstop yes). - - intros y r. apply rq, (Rnext no r). -Defined. - -(** Start at 0 *) -Definition linear_search_from_0_conform (e : exists n, P n) : {n:nat | rel_ls 0 n} := - let b := let (n, p) := e in O_witness n (stop n p) in - linear_search_conform 0 b. - -(** Partial correctness properties *) - -(** rel_ls entails P on the output *) -Theorem rel_ls_post : forall {start found}, rel_ls start found -> P found. -Proof. - intros * rls. induction rls as [x p | x y b rls IHrls]. - - exact p. - - exact IHrls. -Qed. - -(** rel_ls entails minimality of the output *) -Lemma rel_ls_lower_bound {found start} : - rel_ls start found -> forall {k}, P k -> start <= k -> found <= k. -Proof. - induction 1 as [x p | x y no _ IH]; intros k pk greater. - - exact greater. - - destruct greater as [ | k greater]. - + case (no pk). - + apply (IH _ pk), le_n_S, greater. -Qed. - -(** For compatibility with previous version *) -Definition linear_search start (b : before_witness start) : {n : nat | P n} := - let (n, p) := linear_search_conform start b in exist _ n (rel_ls_post p). - -(** Main definitions *) -Definition constructive_indefinite_ground_description_nat : - (exists n, P n) -> {n:nat | P n}. -Proof. - intro e; destruct (linear_search_from_0_conform e) as [found r]; exists found. - apply (rel_ls_post r). -Defined. - -Definition epsilon_smallest : - (exists n : nat, P n) -> { n : nat | P n /\ forall k, P k -> n <= k }. -Proof. - intro e; destruct (linear_search_from_0_conform e) as [found r]; exists found. - split. - - apply (rel_ls_post r). - - intros k pk. apply (rel_ls_lower_bound r pk), Nat.le_0_l. -Defined. - -(** NB. The previous version used a negative formulation: - [forall k, k < n -> ~P k] - Lemmas [le_not_lt] and [lt_not_le] can help if needed. *) - -(************************************************************************) - -(** In simple situations like here, a direct proof that [prog_linear_search] - satisfies [rel_ls] can be provided. - On the computational side of the proof, the fixpoint (coming from - [before_witness_dep_ind]) has to come first, before the pattern matching - on [P_dec], so we get a slight mismatch between the program - [prog_linear_search] and the proof; in particular, there is a duplication - for [Rstop]. - *) - -Scheme before_witness_dep_ind := Induction for before_witness Sort Prop. - -Lemma linear_search_rel : forall start b, rel_ls start (prog_linear_search start b). -Proof. - intros start b. - induction b as [n p | n b IHb] using before_witness_dep_ind; - unfold prog_linear_search; destruct (P_dec n) as [yes | no]; fold prog_linear_search. - - apply Rstop, yes. - - case (no p). - - apply Rstop, yes. - - apply (Rnext no), IHb. -Qed. - -(** Start at 0 *) -Definition linear_search_from_0 (e : exists n, P n) : nat := - let b := let (n, p) := e in O_witness n (stop n p) in - prog_linear_search 0 b. - -Lemma linear_search_from_0_rel (e : exists n, P n) : - rel_ls 0 (linear_search_from_0 e). -Proof. apply linear_search_rel. Qed. - -(** Main definitions *) -Definition constructive_indefinite_ground_description_nat_direct : - (exists n, P n) -> {n:nat | P n}. -Proof. - intro e. exists (linear_search_from_0 e). - apply (rel_ls_post (linear_search_from_0_rel e)). -Defined. - -Definition epsilon_smallest_direct : - (exists n : nat, P n) -> { n : nat | P n /\ forall k, P k -> n <= k }. -Proof. - intro e. exists (linear_search_from_0 e). split. - - apply (rel_ls_post (linear_search_from_0_rel e)). - - intros k pk. - apply (@rel_ls_lower_bound _ 0 (linear_search_from_0_rel e) k pk), Nat.le_0_l. -Defined. - -End ConstructiveIndefiniteGroundDescription_Direct. - -(************************************************************************) - -(* Version using the predicate [Acc] *) - -Section ConstructiveIndefiniteGroundDescription_Acc. - -Variable P : nat -> Prop. - -Hypothesis P_decidable : forall n : nat, {P n} + {~ P n}. - -(** The predicate [Acc] delineates elements that are accessible via a -given relation [R]. An element is accessible if there are no infinite -[R]-descending chains starting from it. - -To use [Fix_F], we define a relation R and prove that if [exists n, P n] -then 0 is accessible with respect to R. Then, by induction on the -definition of [Acc R 0], we show [{n : nat | P n}]. - -The relation [R] describes the connection between the two successive -numbers we try. Namely, [y] is [R]-less then [x] if we try [y] after -[x], i.e., [y = S x] and [P x] is false. Then the absence of an -infinite [R]-descending chain from 0 is equivalent to the termination -of our searching algorithm. *) - -Let R (x y : nat) : Prop := x = S y /\ ~ P y. - -Local Notation acc x := (Acc R x). - -Lemma P_implies_acc : forall x : nat, P x -> acc x. -Proof. -intros x H. constructor. -intros y [_ not_Px]. absurd (P x); assumption. -Qed. - -Lemma P_eventually_implies_acc : forall (x : nat) (n : nat), P (n + x) -> acc x. -Proof. -intros x n; generalize x; clear x; induction n as [|n IH]; simpl. -- apply P_implies_acc. -- intros x H. constructor. intros y [fxy _]. - apply IH. rewrite fxy. - replace (n + S x) with (S (n + x)); auto with arith. -Defined. - -Corollary P_eventually_implies_acc_ex : (exists n : nat, P n) -> acc 0. -Proof. -intros H; elim H. intros x Px. apply P_eventually_implies_acc with (n := x). -replace (x + 0) with x; auto with arith. -Defined. - -(** In the following statement, we use the trick with recursion on -[Acc]. This is also where decidability of [P] is used. *) - -Theorem acc_implies_P_eventually : acc 0 -> {n : nat | P n}. -Proof. -intros Acc_0. pattern 0. apply Fix_F with (R := R); [| assumption]. -clear Acc_0; intros x IH. -destruct (P_decidable x) as [Px | not_Px]. -- exists x; simpl; assumption. -- set (y := S x). - assert (Ryx : R y x). - + unfold R; split; auto. - + destruct (IH y Ryx) as [n Hn]. - exists n; assumption. -Defined. - -Theorem constructive_indefinite_ground_description_nat_Acc : - (exists n : nat, P n) -> {n : nat | P n}. -Proof. -intros H; apply acc_implies_P_eventually. -apply P_eventually_implies_acc_ex; assumption. -Defined. - -End ConstructiveIndefiniteGroundDescription_Acc. - -(************************************************************************) - -Section ConstructiveGroundEpsilon_nat. - -Variable P : nat -> Prop. - -Hypothesis P_decidable : forall x : nat, {P x} + {~ P x}. - -Definition constructive_ground_epsilon_nat (E : exists n : nat, P n) : nat - := proj1_sig (constructive_indefinite_ground_description_nat P P_decidable E). - -Definition constructive_ground_epsilon_spec_nat (E : (exists n, P n)) : P (constructive_ground_epsilon_nat E) - := proj2_sig (constructive_indefinite_ground_description_nat P P_decidable E). - -End ConstructiveGroundEpsilon_nat. - -(************************************************************************) - -Section ConstructiveGroundEpsilon. - -(** For the current purpose, we say that a set [A] is countable if -there are functions [f : A -> nat] and [g : nat -> A] such that [g] is -a left inverse of [f]. *) - -Variable A : Type. -Variable f : A -> nat. -Variable g : nat -> A. - -Hypothesis gof_eq_id : forall x : A, g (f x) = x. - -Variable P : A -> Prop. - -Hypothesis P_decidable : forall x : A, {P x} + {~ P x}. - -Definition P' (x : nat) : Prop := P (g x). - -Lemma P'_decidable : forall n : nat, {P' n} + {~ P' n}. -Proof. -intro n; unfold P'; destruct (P_decidable (g n)); auto. -Defined. - -Lemma constructive_indefinite_ground_description : (exists x : A, P x) -> {x : A | P x}. -Proof. -intro H. assert (H1 : exists n : nat, P' n). -{ destruct H as [x Hx]. exists (f x); unfold P'. rewrite gof_eq_id; assumption. } -apply (constructive_indefinite_ground_description_nat P' P'_decidable) in H1. -destruct H1 as [n Hn]. exists (g n); unfold P' in Hn; assumption. -Defined. - -Lemma constructive_definite_ground_description : (exists! x : A, P x) -> {x : A | P x}. -Proof. - intros; apply constructive_indefinite_ground_description; firstorder. -Defined. - -Definition constructive_ground_epsilon (E : exists x : A, P x) : A - := proj1_sig (constructive_indefinite_ground_description E). - -Definition constructive_ground_epsilon_spec (E : (exists x, P x)) : P (constructive_ground_epsilon E) - := proj2_sig (constructive_indefinite_ground_description E). - -End ConstructiveGroundEpsilon. - -(* begin hide *) -(* Compatibility: the qualificative "ground" was absent from the initial -names of the results in this file but this had introduced confusion -with the similarly named statement in Description.v *) -Notation constructive_indefinite_description_nat := - constructive_indefinite_ground_description_nat (only parsing). -Notation constructive_epsilon_spec_nat := - constructive_ground_epsilon_spec_nat (only parsing). -Notation constructive_epsilon_nat := - constructive_ground_epsilon_nat (only parsing). -Notation constructive_indefinite_description := - constructive_indefinite_ground_description (only parsing). -Notation constructive_definite_description := - constructive_definite_ground_description (only parsing). -Notation constructive_epsilon_spec := - constructive_ground_epsilon_spec (only parsing). -Notation constructive_epsilon := - constructive_ground_epsilon (only parsing). -(* end hide *) diff --git a/stdlib/theories/Logic/Decidable.v b/stdlib/theories/Logic/Decidable.v deleted file mode 100644 index 1dba658cf82e..000000000000 --- a/stdlib/theories/Logic/Decidable.v +++ /dev/null @@ -1,239 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* (~ P -> False) -> P. -Proof. -unfold decidable; tauto. -Qed. - -Theorem dec_True : decidable True. -Proof. -unfold decidable; auto. -Qed. - -Theorem dec_False : decidable False. -Proof. -unfold decidable, not; auto. -Qed. - -Theorem dec_or : - forall A B:Prop, decidable A -> decidable B -> decidable (A \/ B). -Proof. -unfold decidable; tauto. -Qed. - -Theorem dec_and : - forall A B:Prop, decidable A -> decidable B -> decidable (A /\ B). -Proof. -unfold decidable; tauto. -Qed. - -Theorem dec_not : forall A:Prop, decidable A -> decidable (~ A). -Proof. -unfold decidable; tauto. -Qed. - -Theorem dec_imp : - forall A B:Prop, decidable A -> decidable B -> decidable (A -> B). -Proof. -unfold decidable; tauto. -Qed. - -Theorem dec_iff : - forall A B:Prop, decidable A -> decidable B -> decidable (A<->B). -Proof. -unfold decidable. tauto. -Qed. - -Theorem not_not : forall P:Prop, decidable P -> ~ ~ P -> P. -Proof. -unfold decidable; tauto. -Qed. - -Theorem not_or : forall A B:Prop, ~ (A \/ B) -> ~ A /\ ~ B. -Proof. -tauto. -Qed. - -Theorem not_and : forall A B:Prop, decidable A -> ~ (A /\ B) -> ~ A \/ ~ B. -Proof. -unfold decidable; tauto. -Qed. - -Theorem not_imp : forall A B:Prop, decidable A -> ~ (A -> B) -> A /\ ~ B. -Proof. -unfold decidable; tauto. -Qed. - -Theorem imp_simp : forall A B:Prop, decidable A -> (A -> B) -> ~ A \/ B. -Proof. -unfold decidable; tauto. -Qed. - -Theorem not_iff : - forall A B:Prop, decidable A -> decidable B -> - ~ (A <-> B) -> (A /\ ~ B) \/ (~ A /\ B). -Proof. -unfold decidable; tauto. -Qed. - -Register dec_True as core.dec.True. -Register dec_False as core.dec.False. -Register dec_or as core.dec.or. -Register dec_and as core.dec.and. -Register dec_not as core.dec.not. -Register dec_imp as core.dec.imp. -Register dec_iff as core.dec.iff. -Register dec_not_not as core.dec.not_not. -Register not_not as core.dec.dec_not_not. -Register not_or as core.dec.not_or. -Register not_and as core.dec.not_and. -Register not_imp as core.dec.not_imp. -Register imp_simp as core.dec.imp_simp. -Register not_iff as core.dec.not_iff. - -(** Results formulated with iff, used in FSetDecide. - Negation are expanded since it is unclear whether setoid rewrite - will always perform conversion. *) - -(** We begin with lemmas that, when read from left to right, - can be understood as ways to eliminate uses of [not]. *) - -Theorem not_true_iff : (True -> False) <-> False. -Proof. -tauto. -Qed. - -Theorem not_false_iff : (False -> False) <-> True. -Proof. -tauto. -Qed. - -Theorem not_not_iff : forall A:Prop, decidable A -> - (((A -> False) -> False) <-> A). -Proof. -unfold decidable; tauto. -Qed. - -Theorem contrapositive : forall A B:Prop, decidable A -> - (((A -> False) -> (B -> False)) <-> (B -> A)). -Proof. -unfold decidable; tauto. -Qed. - -Lemma or_not_l_iff_1 : forall A B: Prop, decidable A -> - ((A -> False) \/ B <-> (A -> B)). -Proof. -unfold decidable. tauto. -Qed. - -Lemma or_not_l_iff_2 : forall A B: Prop, decidable B -> - ((A -> False) \/ B <-> (A -> B)). -Proof. -unfold decidable. tauto. -Qed. - -Lemma or_not_r_iff_1 : forall A B: Prop, decidable A -> - (A \/ (B -> False) <-> (B -> A)). -Proof. -unfold decidable. tauto. -Qed. - -Lemma or_not_r_iff_2 : forall A B: Prop, decidable B -> - (A \/ (B -> False) <-> (B -> A)). -Proof. -unfold decidable. tauto. -Qed. - -Lemma imp_not_l : forall A B: Prop, decidable A -> - (((A -> False) -> B) <-> (A \/ B)). -Proof. -unfold decidable. tauto. -Qed. - - -(** Moving Negations Around: - We have four lemmas that, when read from left to right, - describe how to push negations toward the leaves of a - proposition and, when read from right to left, describe - how to pull negations toward the top of a proposition. *) - -Theorem not_or_iff : forall A B:Prop, - (A \/ B -> False) <-> (A -> False) /\ (B -> False). -Proof. -tauto. -Qed. - -Lemma not_and_iff : forall A B:Prop, - (A /\ B -> False) <-> (A -> B -> False). -Proof. -tauto. -Qed. - -Lemma not_imp_iff : forall A B:Prop, decidable A -> - (((A -> B) -> False) <-> A /\ (B -> False)). -Proof. -unfold decidable. tauto. -Qed. - -Lemma not_imp_rev_iff : forall A B : Prop, decidable A -> - (((A -> B) -> False) <-> (B -> False) /\ A). -Proof. -unfold decidable. tauto. -Qed. - -(* Functional relations on decidable co-domains are decidable *) - -Theorem dec_functional_relation : - forall (X Y : Type) (A:X->Y->Prop), (forall y y' : Y, decidable (y=y')) -> - (forall x, exists! y, A x y) -> forall x y, decidable (A x y). -Proof. -intros X Y A Hdec H x y. -destruct (H x) as (y',(Hex,Huniq)). -destruct (Hdec y y') as [->|Hnot]; firstorder. -Qed. - -(** With the following hint database, we can leverage [auto] to check - decidability of propositions. *) - -#[global] -Hint Resolve dec_True dec_False dec_or dec_and dec_imp dec_not dec_iff - : decidable_prop. - -(** [solve_decidable using lib] will solve goals about the - decidability of a proposition, assisted by an auxiliary - database of lemmas. The database is intended to contain - lemmas stating the decidability of base propositions, - (e.g., the decidability of equality on a particular - inductive type). *) - -Tactic Notation "solve_decidable" "using" ident(db) := - match goal with - | |- decidable _ => - solve [ auto 100 with decidable_prop db ] - end. - -Tactic Notation "solve_decidable" := - solve_decidable using core. diff --git a/stdlib/theories/Logic/Description.v b/stdlib/theories/Logic/Description.v deleted file mode 100644 index ab87b816b131..000000000000 --- a/stdlib/theories/Logic/Description.v +++ /dev/null @@ -1,21 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* Prop), - (exists! x, P x) -> { x : A | P x }. diff --git a/stdlib/theories/Logic/Diaconescu.v b/stdlib/theories/Logic/Diaconescu.v deleted file mode 100644 index bcbb4a62a6af..000000000000 --- a/stdlib/theories/Logic/Diaconescu.v +++ /dev/null @@ -1,308 +0,0 @@ -(* -*- coding: utf-8 -*- *) -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* Excluded-Middle *) - -Section PredExt_RelChoice_imp_EM. - -(** The axiom of extensionality for predicates *) - -Definition PredicateExtensionality := - forall P Q:bool -> Prop, (forall b:bool, P b <-> Q b) -> P = Q. - -(** From predicate extensionality we get propositional extensionality - hence proof-irrelevance *) - -Import ClassicalFacts. - -Variable pred_extensionality : PredicateExtensionality. - -Lemma prop_ext : forall A B:Prop, (A <-> B) -> A = B. -Proof. - intros A B H. - change ((fun _ => A) true = (fun _ => B) true). - rewrite - pred_extensionality with (P := fun _:bool => A) (Q := fun _:bool => B). - - reflexivity. - - intros _; exact H. -Qed. - -Lemma proof_irrel : forall (A:Prop) (a1 a2:A), a1 = a2. -Proof. - apply (ext_prop_dep_proof_irrel_cic prop_ext). -Qed. - -(** From proof-irrelevance and relational choice, we get guarded - relational choice *) - -Import ChoiceFacts. - -Variable rel_choice : RelationalChoice. - -Lemma guarded_rel_choice : GuardedRelationalChoice. -Proof. - apply - (rel_choice_and_proof_irrel_imp_guarded_rel_choice rel_choice proof_irrel). -Qed. - -(** The form of choice we need: there is a functional relation which chooses - an element in any non empty subset of bool *) - -Import Bool. - -Lemma AC_bool_subset_to_bool : - exists R : (bool -> Prop) -> bool -> Prop, - (forall P:bool -> Prop, - (exists b : bool, P b) -> - exists b : bool, P b /\ R P b /\ (forall b':bool, R P b' -> b = b')). -Proof. - destruct (guarded_rel_choice _ _ - (fun Q:bool -> Prop => exists y : _, Q y) - (fun (Q:bool -> Prop) (y:bool) => Q y)) as (R,(HRsub,HR)). - - exact (fun _ H => H). - - exists R; intros P HP. - destruct (HR P HP) as (y,(Hy,Huni)). - exists y; firstorder. -Qed. - -(** The proof of the excluded middle *) -(** Remark: P could have been in Set or Type *) - -Theorem pred_ext_and_rel_choice_imp_EM : forall P:Prop, P \/ ~ P. -Proof. -intro P. - -(* first we exhibit the choice functional relation R *) -destruct AC_bool_subset_to_bool as [R H]. - -set (class_of_true := fun b => b = true \/ P). -set (class_of_false := fun b => b = false \/ P). - -(* the actual "decision": is (R class_of_true) = true or false? *) -destruct (H class_of_true) as [b0 [H0 [H0' H0'']]]. -- exists true; left; reflexivity. -- destruct H0. - - (* the actual "decision": is (R class_of_false) = true or false? *) - + destruct (H class_of_false) as [b1 [H1 [H1' H1'']]]. - * exists false; left; reflexivity. - * destruct H1. - - -- (* case where P is false: (R class_of_true)=true /\ (R class_of_false)=false *) - right. - intro HP. - assert (Hequiv : forall b:bool, class_of_true b <-> class_of_false b). - ++ intro b; split. - ** unfold class_of_false; right; assumption. - ** unfold class_of_true; right; assumption. - ++ assert (Heq : class_of_true = class_of_false). - ** apply pred_extensionality with (1 := Hequiv). - ** apply diff_true_false. - rewrite <- H0. - rewrite <- H1. - rewrite <- H0''. - { reflexivity. } - rewrite Heq. - assumption. - - -- (* cases where P is true *) - left; assumption. - + left; assumption. - -Qed. - -End PredExt_RelChoice_imp_EM. - -(**********************************************************************) -(** * Proof-Irrel. + Rel. Axiom of Choice -> Excl.-Middle for Equality *) - -(** This is an adaptation of Diaconescu's theorem, exploiting the - form of extensionality provided by proof-irrelevance *) - -Section ProofIrrel_RelChoice_imp_EqEM. - -Import ChoiceFacts. - -Variable rel_choice : RelationalChoice. - -Variable proof_irrelevance : forall P:Prop , forall x y:P, x=y. - -(** Let [a1] and [a2] be two elements in some type [A] *) - -Variable A :Type. -Variables a1 a2 : A. - -(** We build the subset [A'] of [A] made of [a1] and [a2] *) - -Definition A' := @sigT A (fun x => x=a1 \/ x=a2). - -Definition a1':A'. -exists a1 ; auto. -Defined. - -Definition a2':A'. -exists a2 ; auto. -Defined. - -(** By proof-irrelevance, projection is a retraction *) - -Lemma projT1_injective : a1=a2 -> a1'=a2'. -Proof. - intro Heq ; unfold a1', a2', A'. - rewrite Heq. - replace (or_introl (a2=a2) (eq_refl a2)) - with (or_intror (a2=a2) (eq_refl a2)). - - reflexivity. - - apply proof_irrelevance. -Qed. - -(** But from the actual proofs of being in [A'], we can assert in the - proof-irrelevant world the existence of relevant boolean witnesses *) - -Lemma decide : forall x:A', exists y:bool , - (projT1 x = a1 /\ y = true ) \/ (projT1 x = a2 /\ y = false). -Proof. - intros [a [Ha1|Ha2]]; [exists true | exists false]; auto. -Qed. - -(** Thanks to the axiom of choice, the boolean witnesses move from the - propositional world to the relevant world *) - -Theorem proof_irrel_rel_choice_imp_eq_dec : a1=a2 \/ ~a1=a2. -Proof. - destruct - (rel_choice A' bool - (fun x y => projT1 x = a1 /\ y = true \/ projT1 x = a2 /\ y = false)) - as (R,(HRsub,HR)). - - apply decide. - - destruct (HR a1') as (b1,(Ha1'b1,_Huni1)). - destruct (HRsub a1' b1 Ha1'b1) as [(_, Hb1true)|(Ha1a2, _Hb1false)]. - + destruct (HR a2') as (b2,(Ha2'b2,Huni2)). - destruct (HRsub a2' b2 Ha2'b2) as [(Ha2a1, _Hb2true)|(_, Hb2false)]. - * left; symmetry; assumption. - * right; intro H. - subst b1; subst b2. - rewrite (projT1_injective H) in Ha1'b1. - assert (false = true) by auto using Huni2. - discriminate. - + left; assumption. -Qed. - -(** An alternative more concise proof can be done by directly using - the guarded relational choice *) - -Lemma proof_irrel_rel_choice_imp_eq_dec' : a1=a2 \/ ~a1=a2. -Proof. - assert (decide: forall x:A, x=a1 \/ x=a2 -> - exists y:bool, x=a1 /\ y=true \/ x=a2 /\ y=false). - - intros a [Ha1|Ha2]; [exists true | exists false]; auto. - - assert (guarded_rel_choice := - rel_choice_and_proof_irrel_imp_guarded_rel_choice - rel_choice - proof_irrelevance). - destruct - (guarded_rel_choice A bool - (fun x => x=a1 \/ x=a2) - (fun x y => x=a1 /\ y=true \/ x=a2 /\ y=false)) - as (R,(HRsub,HR)). - + apply decide. - + destruct (HR a1) as (b1,(Ha1b1,_Huni1)). - * left; reflexivity. - * destruct (HRsub a1 b1 Ha1b1) as [(_, Hb1true)|(Ha1a2, _Hb1false)]. - -- destruct (HR a2) as (b2,(Ha2b2,Huni2)). - ++ right; reflexivity. - ++ destruct (HRsub a2 b2 Ha2b2) as [(Ha2a1, _Hb2true)|(_, Hb2false)]. - ** left; symmetry; assumption. - ** right; intro H. - subst b1; subst b2; subst a1. - assert (false = true) by auto using Huni2, Ha1b1. - discriminate. - -- left; assumption. -Qed. - -End ProofIrrel_RelChoice_imp_EqEM. - -(**********************************************************************) -(** * Extensional Hilbert's epsilon description operator -> Excluded-Middle *) - -(** Proof sketch from Bell [[Bell93]] (with thanks to P. CastĆ©ran) *) - -Local Notation inhabited A := A (only parsing). - -Section ExtensionalEpsilon_imp_EM. - -Variable epsilon : forall A : Type, inhabited A -> (A -> Prop) -> A. - -Hypothesis epsilon_spec : - forall (A:Type) (i:inhabited A) (P:A->Prop), - (exists x, P x) -> P (epsilon A i P). - -Hypothesis epsilon_extensionality : - forall (A:Type) (i:inhabited A) (P Q:A->Prop), - (forall a, P a <-> Q a) -> epsilon A i P = epsilon A i Q. - -Local Notation eps := (epsilon bool true) (only parsing). - -Theorem extensional_epsilon_imp_EM : forall P:Prop, P \/ ~ P. -Proof. - intro P. - pose (B := fun y => y=false \/ P). - pose (C := fun y => y=true \/ P). - assert (B (eps B)) as [Hfalse|HP] - by (apply epsilon_spec; exists false; left; reflexivity). - - assert (C (eps C)) as [Htrue|HP] - by (apply epsilon_spec; exists true; left; reflexivity). - + right; intro HP. - assert (forall y, B y <-> C y) by (intro y; split; intro; right; assumption). - rewrite epsilon_extensionality with (1:=H) in Hfalse. - rewrite Htrue in Hfalse. - discriminate. - + auto. - - auto. -Qed. - -End ExtensionalEpsilon_imp_EM. diff --git a/stdlib/theories/Logic/Epsilon.v b/stdlib/theories/Logic/Epsilon.v deleted file mode 100644 index bd19288c17f5..000000000000 --- a/stdlib/theories/Logic/Epsilon.v +++ /dev/null @@ -1,71 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* Prop), inhabited A -> - { x : A | (exists x, P x) -> P x }. - -Lemma constructive_indefinite_description : - forall (A : Type) (P : A->Prop), - (exists x, P x) -> { x : A | P x }. -Proof. - apply epsilon_imp_constructive_indefinite_description. - exact epsilon_statement. -Qed. - -Lemma small_drinkers'_paradox : - forall (A:Type) (P:A -> Prop), inhabited A -> - exists x, (exists x, P x) -> P x. -Proof. - apply epsilon_imp_small_drinker. - exact epsilon_statement. -Qed. - -Theorem iota_statement : - forall (A : Type) (P : A->Prop), inhabited A -> - { x : A | (exists! x : A, P x) -> P x }. -Proof. - intros; destruct epsilon_statement with (P:=P); firstorder. -Qed. - -Lemma constructive_definite_description : - forall (A : Type) (P : A->Prop), - (exists! x, P x) -> { x : A | P x }. -Proof. - apply iota_imp_constructive_definite_description. - exact iota_statement. -Qed. - -(** Hilbert's epsilon operator and its specification *) - -Definition epsilon (A : Type) (i:inhabited A) (P : A->Prop) : A - := proj1_sig (epsilon_statement P i). - -Definition epsilon_spec (A : Type) (i:inhabited A) (P : A->Prop) : - (exists x, P x) -> P (epsilon i P) - := proj2_sig (epsilon_statement P i). - -(** Church's iota operator and its specification *) - -Definition iota (A : Type) (i:inhabited A) (P : A->Prop) : A - := proj1_sig (iota_statement P i). - -Definition iota_spec (A : Type) (i:inhabited A) (P : A->Prop) : - (exists! x:A, P x) -> P (iota i P) - := proj2_sig (iota_statement P i). diff --git a/stdlib/theories/Logic/Eqdep.v b/stdlib/theories/Logic/Eqdep.v deleted file mode 100644 index 53624f928d34..000000000000 --- a/stdlib/theories/Logic/Eqdep.v +++ /dev/null @@ -1,41 +0,0 @@ -(* -*- coding: utf-8 -*- *) -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* Type) (x:Q p) (h:p = p), x = eq_rect p Q x p h. - -End Eq_rect_eq. - -Module EqdepTheory := EqdepTheory(Eq_rect_eq). -Export EqdepTheory. - -(** Exported hints *) - -#[global] -Hint Resolve eq_dep_eq: eqdep. -#[global] -Hint Resolve inj_pair2 inj_pairT2: eqdep. diff --git a/stdlib/theories/Logic/EqdepFacts.v b/stdlib/theories/Logic/EqdepFacts.v deleted file mode 100644 index 91205c869c92..000000000000 --- a/stdlib/theories/Logic/EqdepFacts.v +++ /dev/null @@ -1,504 +0,0 @@ -(* -*- coding: utf-8 -*- *) -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* Eq_dep_eq <-> UIP <-> UIP_refl <-> K - -3. Definition of the functor that builds properties of dependent - equalities assuming axiom eq_rect_eq - -*) - -(************************************************************************) -(** * Definition of dependent equality and equivalence with equality of dependent pairs *) - -Import EqNotations. - -(* Set Universe Polymorphism. *) - -Section Dependent_Equality. - - Variable U : Type. - Variable P : U -> Type. - - (** Dependent equality *) - - Inductive eq_dep (p:U) (x:P p) : forall q:U, P q -> Prop := - eq_dep_intro : eq_dep p x p x. - #[local] - Hint Constructors eq_dep: core. - - Lemma eq_dep_refl : forall (p:U) (x:P p), eq_dep p x p x. - Proof eq_dep_intro. - - Lemma eq_dep_sym : - forall (p q:U) (x:P p) (y:P q), eq_dep p x q y -> eq_dep q y p x. - Proof. - destruct 1; auto. - Qed. - #[local] - Hint Immediate eq_dep_sym: core. - - Lemma eq_dep_trans : - forall (p q r:U) (x:P p) (y:P q) (z:P r), - eq_dep p x q y -> eq_dep q y r z -> eq_dep p x r z. - Proof. - destruct 1; auto. - Qed. - - Scheme eq_indd := Induction for eq Sort Prop. - - (** Equivalent definition of dependent equality as a dependent pair of - equalities *) - - Inductive eq_dep1 (p:U) (x:P p) (q:U) (y:P q) : Prop := - eq_dep1_intro : forall h:q = p, x = rew h in y -> eq_dep1 p x q y. - - Lemma eq_dep1_dep : - forall (p:U) (x:P p) (q:U) (y:P q), eq_dep1 p x q y -> eq_dep p x q y. - Proof. - destruct 1 as (eq_qp, H). - destruct eq_qp using eq_indd. - rewrite H. - apply eq_dep_intro. - Qed. - - Lemma eq_dep_dep1 : - forall (p q:U) (x:P p) (y:P q), eq_dep p x q y -> eq_dep1 p x q y. - Proof. - intros p; destruct 1. - apply eq_dep1_intro with (eq_refl p). - simpl; trivial. - Qed. - -End Dependent_Equality. - -Arguments eq_dep [U P] p x q _. -Arguments eq_dep1 [U P] p x q y. - -(** Dependent equality is equivalent to equality on dependent pairs *) - -Lemma eq_sigT_eq_dep : - forall (U:Type) (P:U -> Type) (p q:U) (x:P p) (y:P q), - existT P p x = existT P q y -> eq_dep p x q y. -Proof. - intros * H. - dependent rewrite H. - apply eq_dep_intro. -Qed. - -Lemma eq_dep_eq_sigT : - forall (U:Type) (P:U -> Type) (p q:U) (x:P p) (y:P q), - eq_dep p x q y -> existT P p x = existT P q y. -Proof. - destruct 1; reflexivity. -Qed. - -Lemma eq_sigT_iff_eq_dep : - forall (U:Type) (P:U -> Type) (p q:U) (x:P p) (y:P q), - existT P p x = existT P q y <-> eq_dep p x q y. -Proof. - split; auto using eq_sigT_eq_dep, eq_dep_eq_sigT. -Qed. - -Notation equiv_eqex_eqdep := eq_sigT_iff_eq_dep (only parsing). (* Compat *) - -Lemma eq_sig_eq_dep : - forall (U:Type) (P:U -> Prop) (p q:U) (x:P p) (y:P q), - exist P p x = exist P q y -> eq_dep p x q y. -Proof. - intros * H. - dependent rewrite H. - apply eq_dep_intro. -Qed. - -Lemma eq_dep_eq_sig : - forall (U:Type) (P:U -> Prop) (p q:U) (x:P p) (y:P q), - eq_dep p x q y -> exist P p x = exist P q y. -Proof. - destruct 1; reflexivity. -Qed. - -Lemma eq_sig_iff_eq_dep : - forall (U:Type) (P:U -> Prop) (p q:U) (x:P p) (y:P q), - exist P p x = exist P q y <-> eq_dep p x q y. -Proof. - split; auto using eq_sig_eq_dep, eq_dep_eq_sig. -Qed. - -(** Dependent equality is equivalent to a dependent pair of equalities *) - -Set Implicit Arguments. - -Lemma eq_sigT_sig_eq X P (x1 x2:X) H1 H2 : - existT P x1 H1 = existT P x2 H2 <-> {H:x1=x2 | rew H in H1 = H2}. -Proof. - split; intro H. - - change x2 with (projT1 (existT P x2 H2)). - change H2 with (projT2 (existT P x2 H2)) at 5. - destruct H. simpl. - exists eq_refl. - reflexivity. - - destruct H as (->,<-). - reflexivity. -Defined. - -Lemma eq_sigT_fst X P (x1 x2:X) H1 H2 (H:existT P x1 H1 = existT P x2 H2) : - x1 = x2. -Proof. - change x2 with (projT1 (existT P x2 H2)). - destruct H. - reflexivity. -Defined. - -Lemma eq_sigT_snd X P (x1 x2:X) H1 H2 (H:existT P x1 H1 = existT P x2 H2) : - rew (eq_sigT_fst H) in H1 = H2. -Proof. - unfold eq_sigT_fst. - change x2 with (projT1 (existT P x2 H2)). - change H2 with (projT2 (existT P x2 H2)) at 3. - destruct H. - reflexivity. -Defined. - -Lemma eq_sig_fst X P (x1 x2:X) H1 H2 (H:exist P x1 H1 = exist P x2 H2) : - x1 = x2. -Proof. - change x2 with (proj1_sig (exist P x2 H2)). - destruct H. - reflexivity. -Defined. - -Lemma eq_sig_snd X P (x1 x2:X) H1 H2 (H:exist P x1 H1 = exist P x2 H2) : - rew (eq_sig_fst H) in H1 = H2. -Proof. - unfold eq_sig_fst, eq_ind. - change x2 with (proj1_sig (exist P x2 H2)). - change H2 with (proj2_sig (exist P x2 H2)) at 3. - destruct H. - reflexivity. -Defined. - -Unset Implicit Arguments. - -(** Exported hints *) - -#[global] -Hint Resolve eq_dep_intro: core. -#[global] -Hint Immediate eq_dep_sym: core. - -(************************************************************************) -(** * Eq_rect_eq <-> Eq_dep_eq <-> UIP <-> UIP_refl <-> K *) - -Section Equivalences. - - Variable U:Type. - - (** Invariance by Substitution of Reflexive Equality Proofs *) - - Definition Eq_rect_eq_on (p : U) (Q : U -> Type) (x : Q p) := - forall (h : p = p), x = eq_rect p Q x p h. - Definition Eq_rect_eq := forall p Q x, Eq_rect_eq_on p Q x. - - (** Injectivity of Dependent Equality *) - - Definition Eq_dep_eq_on (P : U -> Type) (p : U) (x : P p) := - forall (y : P p), eq_dep p x p y -> x = y. - Definition Eq_dep_eq := forall P p x, Eq_dep_eq_on P p x. - - (** Uniqueness of Identity Proofs (UIP) *) - - Definition UIP_on_ (x y : U) (p1 : x = y) := - forall (p2 : x = y), p1 = p2. - Definition UIP_ := forall x y p1, UIP_on_ x y p1. - - (** Uniqueness of Reflexive Identity Proofs *) - - Definition UIP_refl_on_ (x : U) := - forall (p : x = x), p = eq_refl x. - Definition UIP_refl_ := forall x, UIP_refl_on_ x. - - (** Streicher's axiom K *) - - Definition Streicher_K_on_ (x : U) (P : x = x -> Prop) := - P (eq_refl x) -> forall p : x = x, P p. - Definition Streicher_K_ := forall x P, Streicher_K_on_ x P. - - (** Injectivity of Dependent Equality is a consequence of *) - (** Invariance by Substitution of Reflexive Equality Proof *) - - Lemma eq_rect_eq_on__eq_dep1_eq_on (p : U) (P : U -> Type) (y : P p) : - Eq_rect_eq_on p P y -> forall (x : P p), eq_dep1 p x p y -> x = y. - Proof. - intro eq_rect_eq. - simple destruct 1; intro. - rewrite <- eq_rect_eq; auto. - Qed. - Lemma eq_rect_eq__eq_dep1_eq : - Eq_rect_eq -> forall (P:U->Type) (p:U) (x y:P p), eq_dep1 p x p y -> x = y. - Proof (fun eq_rect_eq P p y x => - @eq_rect_eq_on__eq_dep1_eq_on p P x (eq_rect_eq p P x) y). - - Lemma eq_rect_eq_on__eq_dep_eq_on (p : U) (P : U -> Type) (x : P p) : - Eq_rect_eq_on p P x -> Eq_dep_eq_on P p x. - Proof. - intros eq_rect_eq; red; intros y H. - symmetry; apply (eq_rect_eq_on__eq_dep1_eq_on _ _ _ eq_rect_eq). - apply eq_dep_sym in H; apply eq_dep_dep1; trivial. - Qed. - Lemma eq_rect_eq__eq_dep_eq : Eq_rect_eq -> Eq_dep_eq. - Proof (fun eq_rect_eq P p x y => - @eq_rect_eq_on__eq_dep_eq_on p P x (eq_rect_eq p P x) y). - - (** Uniqueness of Identity Proofs (UIP) is a consequence of *) - (** Injectivity of Dependent Equality *) - - Lemma eq_dep_eq_on__UIP_on (x y : U) (p1 : x = y) : - Eq_dep_eq_on (fun y => x = y) x eq_refl -> UIP_on_ x y p1. - Proof. - intro eq_dep_eq; red. - elim p1 using eq_indd. - intros p2; apply eq_dep_eq. - elim p2 using eq_indd. - apply eq_dep_intro. - Qed. - Lemma eq_dep_eq__UIP : Eq_dep_eq -> UIP_. - Proof (fun eq_dep_eq x y p1 => - @eq_dep_eq_on__UIP_on x y p1 (eq_dep_eq _ _ _)). - - (** Uniqueness of Reflexive Identity Proofs is a direct instance of UIP *) - - Lemma UIP_on__UIP_refl_on (x : U) : - UIP_on_ x x eq_refl -> UIP_refl_on_ x. - Proof. - intro UIP; red; intros; symmetry; apply UIP. - Qed. - Lemma UIP__UIP_refl : UIP_ -> UIP_refl_. - Proof (fun UIP x p => - @UIP_on__UIP_refl_on x (UIP x x eq_refl) p). - - (** Streicher's axiom K is a direct consequence of Uniqueness of - Reflexive Identity Proofs *) - - Lemma UIP_refl_on__Streicher_K_on (x : U) (P : x = x -> Prop) : - UIP_refl_on_ x -> Streicher_K_on_ x P. - Proof. - intro UIP_refl; red; intros; rewrite UIP_refl; assumption. - Qed. - Lemma UIP_refl__Streicher_K : UIP_refl_ -> Streicher_K_. - Proof (fun UIP_refl x P => - @UIP_refl_on__Streicher_K_on x P (UIP_refl x)). - - (** We finally recover from K the Invariance by Substitution of - Reflexive Equality Proofs *) - - Lemma Streicher_K_on__eq_rect_eq_on (p : U) (P : U -> Type) (x : P p) : - Streicher_K_on_ p (fun h => x = rew -> [P] h in x) - -> Eq_rect_eq_on p P x. - Proof. - intro Streicher_K; red; intros. - apply Streicher_K. - reflexivity. - Qed. - Lemma Streicher_K__eq_rect_eq : Streicher_K_ -> Eq_rect_eq. - Proof (fun Streicher_K p P x => - @Streicher_K_on__eq_rect_eq_on p P x (Streicher_K p _)). - -(** Remark: It is reasonable to think that [eq_rect_eq] is strictly - stronger than [eq_rec_eq] (which is [eq_rect_eq] restricted on [Set]): - - [Definition Eq_rec_eq := - forall (P:U -> Set) (p:U) (x:P p) (h:p = p), x = eq_rec p P x p h.] - - Typically, [eq_rect_eq] allows proving UIP and Streicher's K what - does not seem possible with [eq_rec_eq]. In particular, the proof of [UIP] - requires to use [eq_rect_eq] on [fun y -> x=y] which is in [Type] but not - in [Set]. -*) - -End Equivalences. - -(** UIP_refl is downward closed (a short proof of the key lemma of Voevodsky's - proof of inclusion of h-level n into h-level n+1; see hlevelntosn - in https://github.com/vladimirias/Foundations.git). *) - -Theorem UIP_shift_on (X : Type) (x : X) : - UIP_refl_on_ X x -> forall y : x = x, UIP_refl_on_ (x = x) y. -Proof. - intros UIP_refl y. - rewrite (UIP_refl y). - intros z. - assert (UIP:forall y' y'' : x = x, y' = y''). - { intros. apply eq_trans_r with (eq_refl x); apply UIP_refl. } - transitivity (eq_trans (eq_trans (UIP (eq_refl x) (eq_refl x)) z) - (eq_sym (UIP (eq_refl x) (eq_refl x)))). - - destruct z. destruct (UIP _ _). reflexivity. - - change - (match eq_refl x as y' in _ = x' return y' = y' -> Prop with - | eq_refl => fun z => z = (eq_refl (eq_refl x)) - end (eq_trans (eq_trans (UIP (eq_refl x) (eq_refl x)) z) - (eq_sym (UIP (eq_refl x) (eq_refl x))))). - destruct z. destruct (UIP _ _). reflexivity. -Qed. -Theorem UIP_shift : forall U, UIP_refl_ U -> forall x:U, UIP_refl_ (x = x). -Proof (fun U UIP_refl x => - @UIP_shift_on U x (UIP_refl x)). - -Section Corollaries. - - Variable U:Type. - - (** UIP implies the injectivity of equality on dependent pairs in Type *) - - - Definition Inj_dep_pair_on (P : U -> Type) (p : U) (x : P p) := - forall (y : P p), existT P p x = existT P p y -> x = y. - Definition Inj_dep_pair := forall P p x, Inj_dep_pair_on P p x. - - Lemma eq_dep_eq_on__inj_pair2_on (P : U -> Type) (p : U) (x : P p) : - Eq_dep_eq_on U P p x -> Inj_dep_pair_on P p x. - Proof. - intro eq_dep_eq; red; intros. - apply eq_dep_eq. - apply eq_sigT_eq_dep. - assumption. - Qed. - Lemma eq_dep_eq__inj_pair2 : Eq_dep_eq U -> Inj_dep_pair. - Proof (fun eq_dep_eq P p x => - @eq_dep_eq_on__inj_pair2_on P p x (eq_dep_eq P p x)). - -End Corollaries. - -Notation Inj_dep_pairS := Inj_dep_pair. -Notation Inj_dep_pairT := Inj_dep_pair. -Notation eq_dep_eq__inj_pairT2 := eq_dep_eq__inj_pair2. - - -(************************************************************************) -(** * Definition of the functor that builds properties of dependent equalities assuming axiom eq_rect_eq *) - -Module Type EqdepElimination. - - Axiom eq_rect_eq : - forall (U:Type) (p:U) (Q:U -> Type) (x:Q p) (h:p = p), - x = eq_rect p Q x p h. - -End EqdepElimination. - -Module EqdepTheory (M:EqdepElimination). - - Section Axioms. - - Variable U:Type. - -(** Invariance by Substitution of Reflexive Equality Proofs *) - -Lemma eq_rect_eq : - forall (p:U) (Q:U -> Type) (x:Q p) (h:p = p), x = eq_rect p Q x p h. -Proof M.eq_rect_eq U. - -Lemma eq_rec_eq : - forall (p:U) (Q:U -> Set) (x:Q p) (h:p = p), x = eq_rec p Q x p h. -Proof (fun p Q => M.eq_rect_eq U p Q). - -(** Injectivity of Dependent Equality *) - -Lemma eq_dep_eq : forall (P:U->Type) (p:U) (x y:P p), eq_dep p x p y -> x = y. -Proof (eq_rect_eq__eq_dep_eq U eq_rect_eq). - -(** Uniqueness of Identity Proofs (UIP) is a consequence of *) -(** Injectivity of Dependent Equality *) - -Lemma UIP : forall (x y:U) (p1 p2:x = y), p1 = p2. -Proof (eq_dep_eq__UIP U eq_dep_eq). - -(** Uniqueness of Reflexive Identity Proofs is a direct instance of UIP *) - -Lemma UIP_refl : forall (x:U) (p:x = x), p = eq_refl x. -Proof (UIP__UIP_refl U UIP). - -(** Streicher's axiom K is a direct consequence of Uniqueness of - Reflexive Identity Proofs *) - -Lemma Streicher_K : - forall (x:U) (P:x = x -> Prop), P (eq_refl x) -> forall p:x = x, P p. -Proof (UIP_refl__Streicher_K U UIP_refl). - -End Axioms. - -(** UIP implies the injectivity of equality on dependent pairs in Type *) - -Lemma inj_pair2 : - forall (U:Type) (P:U -> Type) (p:U) (x y:P p), - existT P p x = existT P p y -> x = y. -Proof (fun U => eq_dep_eq__inj_pair2 U (eq_dep_eq U)). - -Notation inj_pairT2 := inj_pair2. - -End EqdepTheory. - -(** Basic facts about eq_dep *) - -Lemma f_eq_dep : - forall U (P:U->Type) R p q x y (f:forall p, P p -> R p), - eq_dep p x q y -> eq_dep p (f p x) q (f q y). -Proof. -intros * []. reflexivity. -Qed. - -Lemma eq_dep_non_dep : - forall U P p q x y, @eq_dep U (fun _ => P) p x q y -> x = y. -Proof. -intros * []. reflexivity. -Qed. - -Lemma f_eq_dep_non_dep : - forall U (P:U->Type) R p q x y (f:forall p, P p -> R), - eq_dep p x q y -> f p x = f q y. -Proof. -intros * []. reflexivity. -Qed. - -Arguments eq_dep U P p x q _ : clear implicits. -Arguments eq_dep1 U P p x q y : clear implicits. diff --git a/stdlib/theories/Logic/Eqdep_dec.v b/stdlib/theories/Logic/Eqdep_dec.v deleted file mode 100644 index e2746a837187..000000000000 --- a/stdlib/theories/Logic/Eqdep_dec.v +++ /dev/null @@ -1,406 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* | in Lego - adapted to Coq by B. Barras - - Credit: Proofs up to [K_dec] follow an outline by Michael Hedberg - -Table of contents: - -1. Streicher's K and injectivity of dependent pair hold on decidable types - -1.1. Definition of the functor that builds properties of dependent equalities - from a proof of decidability of equality for a set in Type - -1.2. Definition of the functor that builds properties of dependent equalities - from a proof of decidability of equality for a set in Set - -*) - -(************************************************************************) -(** * Streicher's K and injectivity of dependent pair hold on decidable types *) - -Set Implicit Arguments. -(* Set Universe Polymorphism. *) - -Section EqdepDec. - - Variable A : Type. - - Let comp (x y y':A) (eq1:x = y) (eq2:x = y') : y = y' := - eq_ind _ (fun a => a = y') eq2 _ eq1. - - Remark trans_sym_eq (x y:A) (u:x = y) : comp u u = eq_refl y. - Proof. - case u; trivial. - Qed. - - Variable x : A. - - Variable eq_dec : forall y:A, x = y \/ x <> y. - - Let nu (y:A) (u:x = y) : x = y := - match eq_dec y with - | or_introl eqxy => eqxy - | or_intror neqxy => False_ind _ (neqxy u) - end. - - Local Lemma nu_constant (y:A) (u v:x = y) : nu u = nu v. - Proof. - unfold nu. - destruct (eq_dec y) as [Heq|Hneq]. - - reflexivity. - - case Hneq; trivial. - Qed. - - - Let nu_inv (y:A) (v:x = y) : x = y := comp (nu (eq_refl x)) v. - - - Remark nu_left_inv_on (y:A) (u:x = y) : nu_inv (nu u) = u. - Proof. - case u; unfold nu_inv. - apply trans_sym_eq. - Qed. - - - Theorem eq_proofs_unicity_on (y:A) (p1 p2:x = y) : p1 = p2. - Proof. - elim (nu_left_inv_on p1). - elim (nu_left_inv_on p2). - elim nu_constant with y p1 p2. - reflexivity. - Qed. - - Theorem K_dec_on (P:x = x -> Prop) (H:P (eq_refl x)) (p:x = x) : P p. - Proof. - elim eq_proofs_unicity_on with x (eq_refl x) p. - trivial. - Qed. - - (** The corollary *) - - Let proj (P:A -> Prop) (exP:ex P) (def:P x) : P x := - match exP with - | ex_intro _ x' prf => - match eq_dec x' with - | or_introl eqprf => eq_ind x' P prf x (eq_sym eqprf) - | _ => def - end - end. - - - Theorem inj_right_pair_on (P:A -> Prop) (y y':P x) : - ex_intro P x y = ex_intro P x y' -> y = y'. - Proof. - intros H. - cut (proj (ex_intro P x y) y = proj (ex_intro P x y') y). - - simpl. - destruct (eq_dec x) as [Heq|Hneq]. - + elim Heq using K_dec_on; trivial. - - + intros. - case Hneq; trivial. - - - case H. - reflexivity. - Qed. - -End EqdepDec. - -(** Now we prove the versions that require decidable equality for the entire type - rather than just on the given element. The rest of the file uses this total - decidable equality. We could do everything using decidable equality at a point - (because the induction rule for [eq] is really an induction rule for - [{ y : A | x = y }]), but we don't currently, because changing everything - would break backward compatibility and no-one has yet taken the time to define - the pointed versions, and then re-define the non-pointed versions in terms of - those. *) - -Theorem eq_proofs_unicity A (eq_dec : forall x y : A, x = y \/ x <> y) (x : A) -: forall (y:A) (p1 p2:x = y), p1 = p2. -Proof (@eq_proofs_unicity_on A x (eq_dec x)). - -Theorem K_dec A (eq_dec : forall x y : A, x = y \/ x <> y) (x : A) -: forall P:x = x -> Prop, P (eq_refl x) -> forall p:x = x, P p. -Proof (@K_dec_on A x (eq_dec x)). - -Theorem inj_right_pair A (eq_dec : forall x y : A, x = y \/ x <> y) (x : A) -: forall (P:A -> Prop) (y y':P x), - ex_intro P x y = ex_intro P x y' -> y = y'. -Proof (@inj_right_pair_on A x (eq_dec x)). - -Require Import EqdepFacts. - -(** We deduce axiom [K] for (decidable) types *) -Theorem K_dec_type (A:Type) (eq_dec:forall x y:A, {x = y} + {x <> y}) (x:A) - (P:x = x -> Prop) (H:P (eq_refl x)) (p:x = x) : P p. -Proof. - elim p using K_dec. - - intros x0 y; case (eq_dec x0 y); [left|right]; assumption. - - trivial. -Qed. - -Theorem K_dec_set : - forall A:Set, - (forall x y:A, {x = y} + {x <> y}) -> - forall (x:A) (P:x = x -> Prop), P (eq_refl x) -> forall p:x = x, P p. -Proof fun A => K_dec_type (A:=A). - -(** We deduce the [eq_rect_eq] axiom for (decidable) types *) -Theorem eq_rect_eq_dec : - forall A:Type, - (forall x y:A, {x = y} + {x <> y}) -> - forall (p:A) (Q:A -> Type) (x:Q p) (h:p = p), x = eq_rect p Q x p h. -Proof. - intros A eq_dec. - apply (Streicher_K__eq_rect_eq A (K_dec_type eq_dec)). -Qed. - -(** We deduce the injectivity of dependent equality for decidable types *) -Theorem eq_dep_eq_dec : - forall A:Type, - (forall x y:A, {x = y} + {x <> y}) -> - forall (P:A->Type) (p:A) (x y:P p), eq_dep A P p x p y -> x = y. -Proof (fun A eq_dec => eq_rect_eq__eq_dep_eq A (eq_rect_eq_dec eq_dec)). - -Theorem UIP_dec : - forall (A:Type), - (forall x y:A, {x = y} + {x <> y}) -> - forall (x y:A) (p1 p2:x = y), p1 = p2. -Proof (fun A eq_dec => eq_dep_eq__UIP A (eq_dep_eq_dec eq_dec)). - -Unset Implicit Arguments. - -(************************************************************************) -(** ** Definition of the functor that builds properties of dependent equalities on decidable sets in Type *) - -(** The signature of decidable sets in [Type] *) - -Module Type DecidableType. - - Monomorphic Parameter U:Type. - Axiom eq_dec : forall x y:U, {x = y} + {x <> y}. - -End DecidableType. - -(** The module [DecidableEqDep] collects equality properties for decidable - set in [Type] *) - -Module DecidableEqDep (M:DecidableType). - - Import M. - - (** Invariance by Substitution of Reflexive Equality Proofs *) - - Lemma eq_rect_eq : - forall (p:U) (Q:U -> Type) (x:Q p) (h:p = p), x = eq_rect p Q x p h. - Proof eq_rect_eq_dec eq_dec. - - (** Injectivity of Dependent Equality *) - - Theorem eq_dep_eq : - forall (P:U->Type) (p:U) (x y:P p), eq_dep U P p x p y -> x = y. - Proof (eq_rect_eq__eq_dep_eq U eq_rect_eq). - - (** Uniqueness of Identity Proofs (UIP) *) - - Lemma UIP : forall (x y:U) (p1 p2:x = y), p1 = p2. - Proof (eq_dep_eq__UIP U eq_dep_eq). - - (** Uniqueness of Reflexive Identity Proofs *) - - Lemma UIP_refl : forall (x:U) (p:x = x), p = eq_refl x. - Proof (UIP__UIP_refl U UIP). - - (** Streicher's axiom K *) - - Lemma Streicher_K : - forall (x:U) (P:x = x -> Prop), P (eq_refl x) -> forall p:x = x, P p. - Proof (K_dec_type eq_dec). - - (** Injectivity of equality on dependent pairs in [Type] *) - - Lemma inj_pairT2 : - forall (P:U -> Type) (p:U) (x y:P p), - existT P p x = existT P p y -> x = y. - Proof eq_dep_eq__inj_pairT2 U eq_dep_eq. - - (** Proof-irrelevance on subsets of decidable sets *) - - Lemma inj_pairP2 : - forall (P:U -> Prop) (x:U) (p q:P x), - ex_intro P x p = ex_intro P x q -> p = q. - Proof. - intros. - apply inj_right_pair. - - intros x0 y0; case (eq_dec x0 y0); [left|right]; assumption. - - assumption. - Qed. - -End DecidableEqDep. - -(************************************************************************) -(** ** Definition of the functor that builds properties of dependent equalities on decidable sets in Set *) - -(** The signature of decidable sets in [Set] *) - -Module Type DecidableSet. - - Parameter U:Set. - Axiom eq_dec : forall x y:U, {x = y} + {x <> y}. - -End DecidableSet. - -(** The module [DecidableEqDepSet] collects equality properties for decidable - set in [Set] *) - -Module DecidableEqDepSet (M:DecidableSet). - - Import M. - Module N:=DecidableEqDep(M). - - (** Invariance by Substitution of Reflexive Equality Proofs *) - - Lemma eq_rect_eq : - forall (p:U) (Q:U -> Type) (x:Q p) (h:p = p), x = eq_rect p Q x p h. - Proof eq_rect_eq_dec eq_dec. - - (** Injectivity of Dependent Equality *) - - Theorem eq_dep_eq : - forall (P:U->Type) (p:U) (x y:P p), eq_dep U P p x p y -> x = y. - Proof (eq_rect_eq__eq_dep_eq U eq_rect_eq). - - (** Uniqueness of Identity Proofs (UIP) *) - - Lemma UIP : forall (x y:U) (p1 p2:x = y), p1 = p2. - Proof (eq_dep_eq__UIP U eq_dep_eq). - - (** Uniqueness of Reflexive Identity Proofs *) - - Lemma UIP_refl : forall (x:U) (p:x = x), p = eq_refl x. - Proof (UIP__UIP_refl U UIP). - - (** Streicher's axiom K *) - - Lemma Streicher_K : - forall (x:U) (P:x = x -> Prop), P (eq_refl x) -> forall p:x = x, P p. - Proof (K_dec_type eq_dec). - - (** Proof-irrelevance on subsets of decidable sets *) - - Lemma inj_pairP2 : - forall (P:U -> Prop) (x:U) (p q:P x), - ex_intro P x p = ex_intro P x q -> p = q. - Proof N.inj_pairP2. - - (** Injectivity of equality on dependent pairs in [Type] *) - - Lemma inj_pair2 : - forall (P:U -> Type) (p:U) (x y:P p), - existT P p x = existT P p y -> x = y. - Proof eq_dep_eq__inj_pair2 U N.eq_dep_eq. - - (** Injectivity of equality on dependent pairs with second component - in [Type] *) - - Notation inj_pairT2 := inj_pair2. - -End DecidableEqDepSet. - - (** From decidability to inj_pair2 **) -Lemma inj_pair2_eq_dec : forall A:Type, (forall x y:A, {x=y}+{x<>y}) -> - ( forall (P:A -> Type) (p:A) (x y:P p), existT P p x = existT P p y -> x = y ). -Proof. - intros A eq_dec. - apply eq_dep_eq__inj_pair2. - apply eq_rect_eq__eq_dep_eq. - unfold Eq_rect_eq, Eq_rect_eq_on. - intros; apply eq_rect_eq_dec. - apply eq_dec. -Qed. - -Register inj_pair2_eq_dec as core.eqdep_dec.inj_pair2. - - (** Examples of short direct proofs of unicity of reflexivity proofs - on specific domains *) - -Lemma UIP_refl_unit (x : tt = tt) : x = eq_refl tt. -Proof. - change (match tt as b return tt = b -> Prop with - | tt => fun x => x = eq_refl tt - end x). - destruct x; reflexivity. -Defined. - -Lemma UIP_refl_bool (b:bool) (x : b = b) : x = eq_refl. -Proof. - destruct b. - - change (match true as b return true=b -> Prop with - | true => fun x => x = eq_refl - | _ => fun _ => True - end x). - destruct x; reflexivity. - - change (match false as b return false=b -> Prop with - | false => fun x => x = eq_refl - | _ => fun _ => True - end x). - destruct x; reflexivity. -Defined. - -Lemma UIP_refl_nat (n:nat) (x : n = n) : x = eq_refl. -Proof. - induction n as [|n IHn]. - - change (match 0 as n return 0=n -> Prop with - | 0 => fun x => x = eq_refl - | _ => fun _ => True - end x). - destruct x; reflexivity. - - specialize IHn with (f_equal pred x). - change eq_refl with (f_equal S (@eq_refl _ n)). - rewrite <- IHn; clear IHn. - change (match S n as n' return S n = n' -> Prop with - | 0 => fun _ => True - | S n' => fun x => - x = f_equal S (f_equal pred x) - end x). - pattern (S n) at 2 3, x. - destruct x; reflexivity. -Defined. - - -Lemma UIP_None_l {A} (x : option A) (p1 p2 : None = x) : p1 = p2. -Proof. apply eq_proofs_unicity_on. intros []; constructor; congruence. Qed. - -Lemma UIP_None_r {A} (x : option A) (p1 p2 : x = None) : p1 = p2. -Proof. apply eq_proofs_unicity_on. intros []; constructor; congruence. Qed. - -Lemma UIP_None_None {A} (p1 p2 : None = None :> option A) : p1 = p2. -Proof. apply eq_proofs_unicity_on. intros []; constructor; congruence. Qed. - - -Lemma UIP_nil_l {A} (x : list A) (p1 p2 : nil = x) : p1 = p2. -Proof. apply eq_proofs_unicity_on. intros []; constructor; congruence. Qed. - -Lemma UIP_nil_r {A} (x : list A) (p1 p2 : x = nil) : p1 = p2. -Proof. apply eq_proofs_unicity_on. intros []; constructor; congruence. Qed. - -Lemma UIP_nil_nil {A} (p1 p2 : nil = nil :> list A) : p1 = p2. -Proof. apply eq_proofs_unicity_on. intros []; constructor; congruence. Qed. diff --git a/stdlib/theories/Logic/ExtensionalFunctionRepresentative.v b/stdlib/theories/Logic/ExtensionalFunctionRepresentative.v deleted file mode 100644 index 198c8e68eed8..000000000000 --- a/stdlib/theories/Logic/ExtensionalFunctionRepresentative.v +++ /dev/null @@ -1,26 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* B), - (forall x, f x = repr f x) /\ - (forall g, (forall x, f x = g x) -> repr f = repr g). diff --git a/stdlib/theories/Logic/ExtensionalityFacts.v b/stdlib/theories/Logic/ExtensionalityFacts.v deleted file mode 100644 index 784d30aa2738..000000000000 --- a/stdlib/theories/Logic/ExtensionalityFacts.v +++ /dev/null @@ -1,139 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* Equality of projections from diagonal - -3. Functional extensionality <-> Unicity of inverse bijections - -4. Functional extensionality <-> Bijectivity of bijective composition - -*) - -Set Implicit Arguments. - -(**********************************************************************) -(** * Definitions *) - -(** Being an inverse *) - -Definition is_inverse A B f g := (forall a:A, g (f a) = a) /\ (forall b:B, f (g b) = b). - -(** The diagonal over A and the one-one correspondence with A *) - -#[universes(template)] -Record Delta A := { pi1:A; pi2:A; eq:pi1=pi2 }. - -Definition delta {A} (a:A) := {| pi1 := a; pi2 := a; eq := eq_refl a |}. - -Arguments pi1 {A} _. -Arguments pi2 {A} _. - -Lemma diagonal_projs_same_behavior : forall A (x:Delta A), pi1 x = pi2 x. -Proof. - destruct x as (a1,a2,Heq); assumption. -Qed. - -Lemma diagonal_inverse1 : forall A, is_inverse (A:=A) delta pi1. -Proof. - split; [trivial|]; destruct b as (a1,a2,[]); reflexivity. -Qed. - -Lemma diagonal_inverse2 : forall A, is_inverse (A:=A) delta pi2. -Proof. - split; [trivial|]; destruct b as (a1,a2,[]); reflexivity. -Qed. - -(** Functional extensionality *) - -Local Notation FunctionalExtensionality := - (forall A B (f g : A -> B), (forall x, f x = g x) -> f = g). - -(** Equality of projections from diagonal *) - -Local Notation EqDeltaProjs := (forall A, pi1 = pi2 :> (Delta A -> A)). - -(** Unicity of bijection inverse *) - -Local Notation UniqueInverse := (forall A B (f:A->B) g1 g2, is_inverse f g1 -> is_inverse f g2 -> g1 = g2). - -(** Bijectivity of bijective composition *) - -Definition action A B C (f:A->B) := (fun h:B->C => fun x => h (f x)). - -Local Notation BijectivityBijectiveComp := (forall A B C (f:A->B) g, - is_inverse f g -> is_inverse (A:=B->C) (action f) (action g)). - -(**********************************************************************) -(** * Functional extensionality <-> Equality of projections from diagonal *) - -Theorem FunctExt_iff_EqDeltaProjs : FunctionalExtensionality <-> EqDeltaProjs. -Proof. - split. - - intros FunExt *; apply FunExt, diagonal_projs_same_behavior. - - intros EqProjs **; change f with (fun x => pi1 {|pi1:=f x; pi2:=g x; eq:=H x|}). - rewrite EqProjs; reflexivity. -Qed. - -(**********************************************************************) -(** * Functional extensionality <-> Unicity of bijection inverse *) - -Lemma FunctExt_UniqInverse : FunctionalExtensionality -> UniqueInverse. -Proof. - intros FunExt * (Hg1f,Hfg1) (Hg2f,Hfg2). - apply FunExt. intros; congruence. -Qed. - -Lemma UniqInverse_EqDeltaProjs : UniqueInverse -> EqDeltaProjs. -Proof. - intros UniqInv *. - apply UniqInv with delta; [apply diagonal_inverse1 | apply diagonal_inverse2]. -Qed. - -Theorem FunctExt_iff_UniqInverse : FunctionalExtensionality <-> UniqueInverse. -Proof. - split. - - apply FunctExt_UniqInverse. - - intro; apply FunctExt_iff_EqDeltaProjs, UniqInverse_EqDeltaProjs; trivial. -Qed. - -(**********************************************************************) -(** * Functional extensionality <-> Bijectivity of bijective composition *) - -Lemma FunctExt_BijComp : FunctionalExtensionality -> BijectivityBijectiveComp. -Proof. - intros FunExt * (Hgf,Hfg). split; unfold action. - - intros h; apply FunExt; intro b; rewrite Hfg; reflexivity. - - intros h; apply FunExt; intro a; rewrite Hgf; reflexivity. -Qed. - -Lemma BijComp_FunctExt : BijectivityBijectiveComp -> FunctionalExtensionality. -Proof. - intros BijComp. - apply FunctExt_iff_UniqInverse. intros * H1 H2. - destruct BijComp with (C:=A) (1:=H2) as (Hg2f,_). - destruct BijComp with (C:=A) (1:=H1) as (_,Hfg1). - rewrite <- (Hg2f g1). - change g1 with (action g1 (fun x => x)). - rewrite -> (Hfg1 (fun x => x)). - reflexivity. -Qed. diff --git a/stdlib/theories/Logic/FinFun.v b/stdlib/theories/Logic/FinFun.v deleted file mode 100644 index d55e9867e128..000000000000 --- a/stdlib/theories/Logic/FinFun.v +++ /dev/null @@ -1,431 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* A] with finite [A], - f injective <-> f bijective <-> f surjective. *) - -#[local] Set Warnings "-stdlib-vector". -Require Import List PeanoNat Compare_dec EqNat Decidable ListDec. Require Fin. -Set Implicit Arguments. - -(** General definitions *) - -Definition Injective {A B} (f : A->B) := - forall x y, f x = f y -> x = y. - -Definition Surjective {A B} (f : A->B) := - forall y, exists x, f x = y. - -Definition Bijective {A B} (f : A->B) := - exists g:B->A, (forall x, g (f x) = x) /\ (forall y, f (g y) = y). - -(** Finiteness is defined here via exhaustive list enumeration *) - -Definition Full {A:Type} (l:list A) := forall a:A, In a l. -Definition Finite (A:Type) := exists (l:list A), Full l. - -(** In many of the following proofs, it will be convenient to have - list enumerations without duplicates. As soon as we have - decidability of equality (in Prop), this is equivalent - to the previous notion (s. lemma Finite_dec). *) - -Definition Listing {A:Type} (l:list A) := NoDup l /\ Full l. -Definition Finite' (A:Type) := exists (l:list A), Listing l. - -Lemma Listing_decidable_eq {A:Type} (l:list A): Listing l -> decidable_eq A. -Proof. - intros (Hnodup & Hfull) a a'. - now apply (NoDup_list_decidable Hnodup). -Qed. - -Lemma Finite_dec {A:Type}: Finite A /\ decidable_eq A <-> Finite' A. -Proof. - split. - - intros ((l, Hfull) & Hdec). - destruct (uniquify Hdec l) as (l' & H_nodup & H_inc). - exists l'. split; trivial. - intros a. apply H_inc. apply Hfull. - - intros (l & Hlist). - apply Listing_decidable_eq in Hlist as Heqdec. - destruct Hlist as (Hnodup & Hfull). - split; [ exists l | ]; assumption. -Qed. - -(* Finite_alt is a weaker version of Finite_dec and has been deprecated. *) -Lemma Finite_alt_deprecated A (d:decidable_eq A) : Finite A <-> Finite' A. -Proof. - split. - - intros F. now apply Finite_dec. - - intros (l & _ & F). now exists l. -Qed. -#[deprecated(since="8.17", note="Use Finite_dec instead.")] -Notation Finite_alt := Finite_alt_deprecated. - -(** Injections characterized in term of lists *) - -Lemma Injective_map_NoDup A B (f:A->B) (l:list A) : - Injective f -> NoDup l -> NoDup (map f l). -Proof. - intros Ij. induction 1 as [|x l X N IH]; simpl; constructor; trivial. - rewrite in_map_iff. intros (y & E & Y). apply Ij in E. now subst. -Qed. - -Lemma Injective_map_NoDup_in A B (f:A->B) (l:list A) : - (forall x y, In x l -> In y l -> f x = f y -> x = y) -> NoDup l -> NoDup (map f l). -Proof. - pose proof @in_cons. pose proof @in_eq. - intros Ij N; revert Ij; induction N; cbn [map]; constructor; auto. - rewrite in_map_iff. intros (y & E & Y). apply Ij in E; auto; congruence. -Qed. - -Lemma Injective_list_carac A B (d:decidable_eq A)(f:A->B) : - Injective f <-> (forall l, NoDup l -> NoDup (map f l)). -Proof. - split. - - intros. now apply Injective_map_NoDup. - - intros H x y E. - destruct (d x y); trivial. - assert (N : NoDup (x::y::nil)). - { repeat constructor; simpl; intuition. } - specialize (H _ N). simpl in H. rewrite E in H. - inversion_clear H; simpl in *; intuition. -Qed. - -Lemma Injective_carac A B (l:list A) : Listing l -> - forall (f:A->B), Injective f <-> NoDup (map f l). -Proof. - intros L f. split. - - intros Ij. apply Injective_map_NoDup; trivial. apply L. - - intros N x y E. - assert (X : In x l) by apply L. - assert (Y : In y l) by apply L. - apply In_nth_error in X. destruct X as (i,X). - apply In_nth_error in Y. destruct Y as (j,Y). - assert (X' := map_nth_error f _ _ X). - assert (Y' := map_nth_error f _ _ Y). - assert (i = j). - { rewrite NoDup_nth_error in N. apply N. - - rewrite <- nth_error_Some. now rewrite X'. - - rewrite X', Y'. now f_equal. } - subst j. rewrite Y in X. now injection X. -Qed. - -(** Surjection characterized in term of lists *) - -Lemma Surjective_list_carac A B (f:A->B): - Surjective f <-> (forall lB, exists lA, incl lB (map f lA)). -Proof. - split. - - intros Su lB. - induction lB as [|b lB IH]. - + now exists nil. - + destruct (Su b) as (a,E). - destruct IH as (lA,IC). - exists (a::lA). simpl. rewrite E. - intros x [X|X]; simpl; intuition. - - intros H y. - destruct (H (y::nil)) as (lA,IC). - assert (IN : In y (map f lA)) by (apply (IC y); now left). - rewrite in_map_iff in IN. destruct IN as (x & E & _). - now exists x. -Qed. - -Lemma Surjective_carac A B : Finite B -> decidable_eq B -> - forall f:A->B, Surjective f <-> (exists lA, Listing (map f lA)). -Proof. - intros (lB,FB) d f. split. - - rewrite Surjective_list_carac. - intros Su. destruct (Su lB) as (lA,IC). - destruct (uniquify_map d f lA) as (lA' & N & IC'). - exists lA'. split; trivial. - intro x. apply IC', IC, FB. - - intros (lA & N & FA) y. - generalize (FA y). rewrite in_map_iff. intros (x & E & _). - now exists x. -Qed. - -(** Main result : *) - -Lemma Endo_Injective_Surjective : - forall A, Finite A -> decidable_eq A -> - forall f:A->A, Injective f <-> Surjective f. -Proof. - intros A F d f. rewrite (Surjective_carac F d). split. - - assert (Finite' A) as (l, L) by (now apply Finite_dec); clear F. - rewrite (Injective_carac L); intros. - exists l; split; trivial. - destruct L as (N,F). - assert (I : incl l (map f l)). - { apply NoDup_length_incl; trivial. - - now rewrite length_map. - - intros x _. apply F. } - intros x. apply I, F. - - clear F d. intros (l,L). - assert (N : NoDup l). { apply (NoDup_map_inv f), L. } - assert (I : incl (map f l) l). - { apply NoDup_length_incl; trivial. - - now rewrite length_map. - - intros x _. apply L. } - assert (L' : Listing l). - { split; trivial. - intro x. apply I, L. } - apply (Injective_carac L'), L. -Qed. - -(** An injective and surjective function is bijective. - We need here stronger hypothesis : decidability of equality in Type. *) - -Definition EqDec (A:Type) := forall x y:A, {x=y}+{x<>y}. - -(** First, we show that a surjective f has an inverse function g such that - f.g = id. *) - -(* NB: instead of (Finite A), we could ask for (RecEnum A) with: -Definition RecEnum A := exists h:nat->A, surjective h. -*) - -Lemma Finite_Empty_or_not A : - Finite A -> (A->False) \/ exists a:A,True. -Proof. - intros (l,F). - destruct l as [|a l]. - - left; exact F. - - right; now exists a. -Qed. - -Lemma Surjective_inverse : - forall A B, Finite A -> EqDec B -> - forall f:A->B, Surjective f -> - exists g:B->A, forall x, f (g x) = x. -Proof. - intros A B F d f Su. - destruct (Finite_Empty_or_not F) as [noA | (a,_)]. - - (* A is empty : g is obtained via False_rect *) - assert (noB : B -> False). { intros y. now destruct (Su y). } - exists (fun y => False_rect _ (noB y)). - intro y. destruct (noB y). - - (* A is inhabited by a : we use it in Option.get *) - destruct F as (l,F). - set (h := fun x k => if d (f k) x then true else false). - set (get := fun o => match o with Some y => y | None => a end). - exists (fun x => get (List.find (h x) l)). - intros x. - case_eq (find (h x) l); simpl; clear get; [intros y H|intros H]. - * apply find_some in H. destruct H as (_,H). unfold h in H. - now destruct (d (f y) x) in H. - * exfalso. - destruct (Su x) as (y & Y). - generalize (find_none _ l H y (F y)). - unfold h. now destruct (d (f y) x). -Qed. - -(** Same, with more knowledge on the inverse function: g.f = f.g = id *) - -Lemma Injective_Surjective_Bijective : - forall A B, Finite A -> EqDec B -> - forall f:A->B, Injective f -> Surjective f -> Bijective f. -Proof. - intros A B F d f Ij Su. - destruct (Surjective_inverse F d Su) as (g, E). - exists g. split; trivial. - intros y. apply Ij. now rewrite E. -Qed. - - -(** An example of finite type : [Fin.t] *) - -Lemma Fin_Finite n : Finite (Fin.t n). -Proof. - induction n as [|n IHn]. - - exists nil. - red;inversion 1. - - destruct IHn as (l,Hl). - exists (Fin.F1 :: map Fin.FS l). - intros a. revert n a l Hl. - refine (@Fin.caseS _ _ _); intros. - + now left. - + right. now apply in_map. -Qed. - -(** Instead of working on a finite subset of nat, another - solution is to use restricted [nat->nat] functions, and - to consider them only below a certain bound [n]. *) - -Definition bFun n (f:nat->nat) := forall x, x < n -> f x < n. - -Definition bInjective n (f:nat->nat) := - forall x y, x < n -> y < n -> f x = f y -> x = y. - -Definition bSurjective n (f:nat->nat) := - forall y, y < n -> exists x, x < n /\ f x = y. - -(** We show that this is equivalent to the use of [Fin.t n]. *) - -Module Fin2Restrict. - -Notation n2f := Fin.of_nat_lt. -Definition f2n {n} (x:Fin.t n) := proj1_sig (Fin.to_nat x). -Definition f2n_ok n (x:Fin.t n) : f2n x < n := proj2_sig (Fin.to_nat x). -Definition n2f_f2n : forall n x, n2f (f2n_ok x) = x := @Fin.of_nat_to_nat_inv. -Definition f2n_n2f x n h : f2n (n2f h) = x := f_equal (@proj1_sig _ _) (@Fin.to_nat_of_nat x n h). -Definition n2f_ext : forall x n h h', n2f h = n2f h' := @Fin.of_nat_ext. -Definition f2n_inj : forall n x y, f2n x = f2n y -> x = y := @Fin.to_nat_inj. - -Definition extend n (f:Fin.t n -> Fin.t n) : (nat->nat) := - fun x => - match le_lt_dec n x with - | left _ => 0 - | right h => f2n (f (n2f h)) - end. - -Definition restrict n (f:nat->nat)(hf : bFun n f) : (Fin.t n -> Fin.t n) := - fun x => let (x',h) := Fin.to_nat x in n2f (hf _ h). - -Ltac break_dec H := - let H' := fresh "H" in - destruct le_lt_dec as [H'|H']; - [elim (proj1 (Nat.le_ngt _ _) H' H) - |try rewrite (n2f_ext H' H) in *; try clear H']. - -Lemma extend_ok n f : bFun n (@extend n f). -Proof. - intros x h. unfold extend. break_dec h. apply f2n_ok. -Qed. - -Lemma extend_f2n n f (x:Fin.t n) : extend f (f2n x) = f2n (f x). -Proof. - generalize (n2f_f2n x). unfold extend, f2n, f2n_ok. - destruct (Fin.to_nat x) as (x',h); simpl. - break_dec h. - now intros ->. -Qed. - -Lemma extend_n2f n f x (h:x. - now apply n2f_ext. -Qed. - -Lemma extend_surjective n f : - bSurjective n (@extend n f) <-> Surjective f. -Proof. - split. - - intros hf y. - destruct (hf _ (f2n_ok y)) as (x & h & Eq). - exists (n2f h). - apply f2n_inj. now rewrite <- Eq, <- extend_f2n, f2n_n2f. - - intros hf y hy. - destruct (hf (n2f hy)) as (x,Eq). - exists (f2n x). - split. - + apply f2n_ok. - + rewrite extend_f2n, Eq. apply f2n_n2f. -Qed. - -Lemma extend_injective n f : - bInjective n (@extend n f) <-> Injective f. -Proof. - split. - - intros hf x y Eq. - apply f2n_inj. apply hf; try apply f2n_ok. - now rewrite 2 extend_f2n, Eq. - - intros hf x y hx hy Eq. - rewrite <- (f2n_n2f hx), <- (f2n_n2f hy). f_equal. - apply hf. - rewrite <- 2 extend_n2f. - generalize (extend_ok f hx) (extend_ok f hy). - rewrite Eq. apply n2f_ext. -Qed. - -Lemma restrict_surjective n f h : - Surjective (@restrict n f h) <-> bSurjective n f. -Proof. - split. - - intros hf y hy. - destruct (hf (n2f hy)) as (x,Eq). - exists (f2n x). - split. - + apply f2n_ok. - + rewrite <- (restrict_f2n h), Eq. apply f2n_n2f. - - intros hf y. - destruct (hf _ (f2n_ok y)) as (x & hx & Eq). - exists (n2f hx). - apply f2n_inj. now rewrite restrict_f2n, f2n_n2f. -Qed. - -Lemma restrict_injective n f h : - Injective (@restrict n f h) <-> bInjective n f. -Proof. - split. - - intros hf x y hx hy Eq. - rewrite <- (f2n_n2f hx), <- (f2n_n2f hy). f_equal. - apply hf. - rewrite 2 restrict_n2f. - generalize (h x hx) (h y hy). - rewrite Eq. apply n2f_ext. - - intros hf x y Eq. - apply f2n_inj. apply hf; try apply f2n_ok. - now rewrite <- 2 (restrict_f2n h), Eq. -Qed. - -End Fin2Restrict. -Import Fin2Restrict. - -(** We can now use Proof via the equivalence ... *) - -Lemma bInjective_bSurjective n (f:nat->nat) : - bFun n f -> (bInjective n f <-> bSurjective n f). -Proof. - intros h. - rewrite <- (restrict_injective h), <- (restrict_surjective h). - apply Endo_Injective_Surjective. - - apply Fin_Finite. - - intros x y. destruct (Fin.eq_dec x y); [left|right]; trivial. -Qed. - -Lemma bSurjective_bBijective n (f:nat->nat) : - bFun n f -> bSurjective n f -> - exists g, bFun n g /\ forall x, x < n -> g (f x) = x /\ f (g x) = x. -Proof. - intro hf. - rewrite <- (restrict_surjective hf). intros Su. - assert (Ij : Injective (restrict hf)). - { apply Endo_Injective_Surjective; trivial. - - apply Fin_Finite. - - intros x y. destruct (Fin.eq_dec x y); [left|right]; trivial. } - assert (Bi : Bijective (restrict hf)). - { apply Injective_Surjective_Bijective; trivial. - - apply Fin_Finite. - - exact Fin.eq_dec. } - destruct Bi as (g & Hg & Hg'). - exists (extend g). - split. - - apply extend_ok. - - intros x Hx. split. - + now rewrite <- (f2n_n2f Hx), <- (restrict_f2n hf), extend_f2n, Hg. - + now rewrite <- (f2n_n2f Hx), extend_f2n, <- (restrict_f2n hf), Hg'. -Qed. diff --git a/stdlib/theories/Logic/FunctionalExtensionality.v b/stdlib/theories/Logic/FunctionalExtensionality.v deleted file mode 100644 index bddd622c4ae1..000000000000 --- a/stdlib/theories/Logic/FunctionalExtensionality.v +++ /dev/null @@ -1,262 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* B} : - f = g -> forall x, f x = g x - := fun H x => f_equal (fun h => h x) H. - -Definition equal_f_dep {A B} {f g : forall (x : A), B x} : - f = g -> forall x, f x = g x - := fun H x => f_equal (fun h => h x) H. - -(** Statements of functional extensionality for simple and dependent functions. *) - -Axiom functional_extensionality_dep : forall {A} {B : A -> Type}, - forall (f g : forall x : A, B x), - (forall x, f x = g x) -> f = g. - -Lemma functional_extensionality {A B} (f g : A -> B) : - (forall x, f x = g x) -> f = g. -Proof. - intros ; eauto using @functional_extensionality_dep. -Qed. - -(** Extensionality of [forall]s follows from functional extensionality. *) -Lemma forall_extensionality {A} {B C : A -> Type} (H : forall x : A, B x = C x) -: (forall x, B x) = (forall x, C x). -Proof. - apply functional_extensionality in H. destruct H. reflexivity. -Defined. - -Lemma forall_extensionalityP {A} {B C : A -> Prop} (H : forall x : A, B x = C x) -: (forall x, B x) = (forall x, C x). -Proof. - apply functional_extensionality in H. destruct H. reflexivity. -Defined. - -Lemma forall_extensionalityS {A} {B C : A -> Set} (H : forall x : A, B x = C x) -: (forall x, B x) = (forall x, C x). -Proof. - apply functional_extensionality in H. destruct H. reflexivity. -Defined. - -(** A version of [functional_extensionality_dep] which is provably - equal to [eq_refl] on [fun _ => eq_refl] *) -Definition functional_extensionality_dep_good - {A} {B : A -> Type} - (f g : forall x : A, B x) - (H : forall x, f x = g x) - : f = g - := eq_trans (eq_sym (functional_extensionality_dep f f (fun _ => eq_refl))) - (functional_extensionality_dep f g H). - -Lemma functional_extensionality_dep_good_refl {A B} f - : @functional_extensionality_dep_good A B f f (fun _ => eq_refl) = eq_refl. -Proof. - unfold functional_extensionality_dep_good; edestruct functional_extensionality_dep; reflexivity. -Defined. - -Opaque functional_extensionality_dep_good. - -Lemma forall_sig_eq_rect - {A B} (f : forall a : A, B a) - (P : { g : _ | (forall a, f a = g a) } -> Type) - (k : P (exist (fun g => forall a, f a = g a) f (fun a => eq_refl))) - g -: P g. -Proof. - destruct g as [g1 g2]. - set (g' := fun x => (exist _ (g1 x) (g2 x))). - change g2 with (fun x => proj2_sig (g' x)). - change g1 with (fun x => proj1_sig (g' x)). - clearbody g'; clear g1 g2. - cut (forall x, (exist _ (f x) eq_refl) = g' x). - { intro H'. - apply functional_extensionality_dep_good in H'. - destruct H'. - exact k. } - { intro x. - destruct (g' x) as [g'x1 g'x2]. - destruct g'x2. - reflexivity. } -Defined. - -Definition forall_eq_rect - {A B} (f : forall a : A, B a) - (P : forall g, (forall a, f a = g a) -> Type) - (k : P f (fun a => eq_refl)) - g H - : P g H - := @forall_sig_eq_rect A B f (fun g => P (proj1_sig g) (proj2_sig g)) k (exist _ g H). - -Theorem forall_eq_rect_comp {A B} f P k - : @forall_eq_rect A B f P k f (fun _ => eq_refl) = k. -Proof. - unfold forall_eq_rect, forall_sig_eq_rect; simpl. - rewrite functional_extensionality_dep_good_refl; reflexivity. -Qed. - -Definition f_equal__functional_extensionality_dep_good - {A B f g} H a - : f_equal (fun h => h a) (@functional_extensionality_dep_good A B f g H) = H a. -Proof. - apply (fun P k => forall_eq_rect _ P k _ H); clear H g. - change (eq_refl (f a)) with (f_equal (fun h => h a) (eq_refl f)). - apply f_equal, functional_extensionality_dep_good_refl. -Defined. - -Definition f_equal__functional_extensionality_dep_good__fun - {A B f g} H - : (fun a => f_equal (fun h => h a) (@functional_extensionality_dep_good A B f g H)) = H. -Proof. - apply functional_extensionality_dep_good; intro a; apply f_equal__functional_extensionality_dep_good. -Defined. - -(* Expressing that [equal_f_dep] and [functional_extensionality_dep_good] form an equivalence *) - -Definition equal_f_dep__functional_extensionality_dep_good - {A B} {f g : forall x : A, B x} (H : forall x, f x = g x) - : equal_f_dep (functional_extensionality_dep_good f g H) = H. -Proof. - apply f_equal__functional_extensionality_dep_good__fun. -Defined. - -Definition equal_f__functional_extensionality_dep_good - {A B} {f g : A -> B} (H : forall x, f x = g x) - : equal_f (functional_extensionality_dep_good f g H) = H. -Proof. - apply f_equal__functional_extensionality_dep_good__fun. -Defined. - -Lemma functional_extensionality_dep_good__equal_f_dep - {A B} {f g : forall x : A, B x} (H : f = g) - : functional_extensionality_dep_good _ _ (equal_f_dep H) = H. -Proof. - destruct H; simpl; apply functional_extensionality_dep_good_refl. -Defined. - -Lemma functional_extensionality_dep_good__equal_f - {A B} {f g : A -> B} (H : f = g) - : functional_extensionality_dep_good _ _ (equal_f H) = H. -Proof. - destruct H; simpl; apply functional_extensionality_dep_good_refl. -Defined. - -(** Apply [functional_extensionality], introducing variable x. *) - -Tactic Notation "extensionality" ident(x) := - match goal with - [ |- ?X = ?Y ] => - (apply (@functional_extensionality _ _ X Y) || - apply (@functional_extensionality_dep _ _ X Y) || - apply forall_extensionalityP || - apply forall_extensionalityS || - apply forall_extensionality) ; intro x - end. - -(** Iteratively apply [functional_extensionality] on an hypothesis - until finding an equality statement *) -(* Note that you can write [Ltac extensionality_in_checker tac ::= tac tt.] to get a more informative error message. *) -Ltac extensionality_in_checker tac := - first [ tac tt | fail 1 "Anomaly: Unexpected error in extensionality tactic. Please report." ]. -Tactic Notation "extensionality" "in" hyp(H) := - let rec check_is_extensional_equality H := - lazymatch type of H with - | _ = _ => constr:(Prop) - | forall a : ?A, ?T - => let Ha := fresh in - constr:(forall a : A, match H a with Ha => ltac:(let v := check_is_extensional_equality Ha in exact v) end) - end in - let assert_is_extensional_equality H := - first [ let dummy := check_is_extensional_equality H in idtac - | fail 1 "Not an extensional equality" ] in - let assert_not_intensional_equality H := - lazymatch type of H with - | _ = _ => fail "Already an intensional equality" - | _ => idtac - end in - let enforce_no_body H := - (tryif (let dummy := (eval unfold H in H) in idtac) - then clearbody H - else idtac) in - let rec extensionality_step_make_type H := - lazymatch type of H with - | forall a : ?A, ?f = ?g - => constr:({ H' | (fun a => f_equal (fun h => h a) H') = H }) - | forall a : ?A, _ - => let H' := fresh in - constr:(forall a : A, match H a with H' => ltac:(let ret := extensionality_step_make_type H' in exact ret) end) - end in - let rec eta_contract T := - lazymatch (eval cbv beta in T) with - | context T'[fun a : ?A => ?f a] - => let T'' := context T'[f] in - eta_contract T'' - | ?T => T - end in - let rec lift_sig_extensionality H := - lazymatch type of H with - | sig _ => H - | forall a : ?A, _ - => let Ha := fresh in - let ret := constr:(fun a : A => match H a with Ha => ltac:(let v := lift_sig_extensionality Ha in exact v) end) in - lazymatch type of ret with - | forall a : ?A, sig (fun b : ?B => @?f a b = @?g a b) - => eta_contract (exist (fun b : (forall a : A, B) => (fun a : A => f a (b a)) = (fun a : A => g a (b a))) - (fun a : A => proj1_sig (ret a)) - (@functional_extensionality_dep_good _ _ _ _ (fun a : A => proj2_sig (ret a)))) - end - end in - let extensionality_pre_step H H_out Heq := - let T := extensionality_step_make_type H in - let H' := fresh in - assert (H' : T) by (intros; eexists; apply f_equal__functional_extensionality_dep_good__fun); - let H''b := lift_sig_extensionality H' in - case H''b; clear H'; - intros H_out Heq in - let rec extensionality_rec H H_out Heq := - lazymatch type of H with - | forall a, _ = _ - => extensionality_pre_step H H_out Heq - | _ - => let pre_H_out' := fresh H_out in - let H_out' := fresh pre_H_out' in - extensionality_pre_step H H_out' Heq; - let Heq' := fresh Heq in - extensionality_rec H_out' H_out Heq'; - subst H_out' - end in - first [ assert_is_extensional_equality H | fail 1 "Not an extensional equality" ]; - first [ assert_not_intensional_equality H | fail 1 "Already an intensional equality" ]; - (tryif enforce_no_body H then idtac else clearbody H); - let H_out := fresh in - let Heq := fresh "Heq" in - extensionality_in_checker ltac:(fun tt => extensionality_rec H H_out Heq); - (* If we [subst H], things break if we already have another equation of the form [_ = H] *) - destruct Heq; rename H_out into H. - -(** Eta expansion is built into Coq. *) - -Lemma eta_expansion_dep {A} {B : A -> Type} (f : forall x : A, B x) : - f = fun x => f x. -Proof. - intros. - reflexivity. -Qed. - -Lemma eta_expansion {A B} (f : A -> B) : f = fun x => f x. -Proof. - apply (eta_expansion_dep f). -Qed. diff --git a/stdlib/theories/Logic/HLevels.v b/stdlib/theories/Logic/HLevels.v deleted file mode 100644 index ff17b99bc01e..000000000000 --- a/stdlib/theories/Logic/HLevels.v +++ /dev/null @@ -1,149 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* Prop), - (forall x:A, IsHProp (P x)) - -> IsHProp (forall x:A, P x). -Proof. - intros A P H p q. apply functional_extensionality_dep. - intro x. apply H. -Qed. - -(* Homotopy propositions are stable by conjunction, but not by disjunction, - which can have a proof by the left and another proof by the right. *) -Lemma and_hprop : forall P Q : Prop, - IsHProp P -> IsHProp Q -> IsHProp (P /\ Q). -Proof. - intros. intros p q. destruct p,q. - replace p0 with p. - - replace q0 with q. - + reflexivity. - + apply H0. - - apply H. -Qed. - -Lemma impl_hprop : forall P Q : Prop, - IsHProp Q -> IsHProp (P -> Q). -Proof. - intros P Q H p q. apply functional_extensionality. - intros. apply H. -Qed. - -Lemma false_hprop : IsHProp False. -Proof. - intros p q. contradiction. -Qed. - -Lemma true_hprop : IsHProp True. -Proof. - intros p q. destruct p,q. reflexivity. -Qed. - -(* All negations are homotopy propositions. *) -Lemma not_hprop : forall P : Type, IsHProp (P -> False). -Proof. - intros P p q. apply functional_extensionality. - intros. contradiction. -Qed. - -(* Homotopy propositions are included in homotopy sets. - They are the first 2 levels of a cumulative hierarchy of types - indexed by the natural numbers. In homotopy type theory, - homotopy propositions are call (-1)-types and homotopy - sets 0-types. *) -Lemma hset_hprop : forall X : Type, - IsHProp X -> IsHSet X. -Proof. - intros X H. - assert (forall (x y z:X) (p : y = z), eq_trans (H x y) p = H x z). - { intros. unfold eq_trans, eq_ind. destruct p. reflexivity. } - assert (forall (x y z:X) (p : y = z), - p = eq_trans (eq_sym (H x y)) (H x z)). - { intros. rewrite <- (H0 x y z p). unfold eq_trans, eq_sym, eq_ind. - destruct p, (H x y). reflexivity. } - intros x y p q. - rewrite (H1 x x y p), (H1 x x y q). reflexivity. -Qed. - -Lemma eq_trans_cancel : forall {X : Type} {x y z : X} (p : x = y) (q r : y = z), - (eq_trans p q = eq_trans p r) -> q = r. -Proof. - intros. destruct p. simpl in H. destruct r. - simpl in H. rewrite eq_trans_refl_l in H. exact H. -Qed. - -Lemma hset_hOneType : forall X : Type, - IsHSet X -> IsHOneType X. -Proof. - intros X f x y p q. - pose (fun a => f x y p a) as g. - assert (forall a (r : q = a), eq_trans (g q) r = g a). - { intros. destruct a. subst q. reflexivity. } - intros r s. pose proof (H p (eq_sym r)). - pose proof (H p (eq_sym s)). - rewrite <- H1 in H0. apply eq_trans_cancel in H0. - rewrite <- eq_sym_involutive. rewrite <- (eq_sym_involutive r). - rewrite H0. reflexivity. -Qed. - -(* "IsHProp X" sounds like a proposition, because it asserts - a property of the type X. And indeed: *) -Lemma hprop_hprop : forall X : Type, - IsHProp (IsHProp X). -Proof. - intros X p q. - apply forall_hprop. intro x. - apply forall_hprop. intro y. intros f g. - apply (hset_hprop X p). -Qed. - -Lemma hprop_hset : forall X : Type, - IsHProp (IsHSet X). -Proof. - intros X f g. - apply functional_extensionality_dep. intro x. - apply functional_extensionality_dep. intro y. - apply functional_extensionality_dep. intro a. - apply functional_extensionality_dep. intro b. - apply (hset_hOneType). exact f. -Qed. diff --git a/stdlib/theories/Logic/Hurkens.v b/stdlib/theories/Logic/Hurkens.v deleted file mode 100644 index 8ee91f2c1c45..000000000000 --- a/stdlib/theories/Logic/Hurkens.v +++ /dev/null @@ -1,721 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* A]) cannot be a - retract of a modal proposition. It is an example of use of the - paradox where the universes of system U- are not mapped to - universes of Coq. - - - The [NoRetractToNegativeProp] module is the specialisation of - the [NoRetractFromSmallPropositionToProp] module where the - modality is double-negation. This result implies that the - principle of weak excluded middle ([forall A, ~~A\/~A]) implies - a weak variant of proof irrelevance. - - - The [NoRetractFromTypeToProp] module proves that [Prop] cannot - be a retract of a larger type. - - - The [TypeNeqSmallType] module proves that [Type] is different - from any smaller type. - - - The [PropNeqType] module proves that [Prop] is different from - any larger [Type]. It is an instance of the previous result. - - References: - - - [[Coquand90]] T. Coquand, "Metamathematical Investigations of a - Calculus of Constructions", Proceedings of Logic in Computer - Science (LICS'90), 1990. - - - [[Hurkens95]] A. J. Hurkens, "A simplification of Girard's paradox", - Proceedings of the 2nd international conference Typed Lambda-Calculi - and Applications (TLCA'95), 1995. - - - [[Geuvers01]] H. Geuvers, "Inconsistency of Classical Logic in Type - Theory", 2001, revised 2007 - (see external link {{http://www.cs.ru.nl/~herman/PUBS/newnote.ps.gz}}). -*) - - -Set Universe Polymorphism. - -(* begin show *) - -(** * A modular proof of Hurkens's paradox. *) - -(** It relies on an axiomatisation of a shallow embedding of system U- - (i.e. types of U- are interpreted by types of Coq). The - universes are encoded in a style, due to Martin-Lƶf, where they - are given by a set of names and a family [El:Name->Type] which - interprets each name into a type. This allows the encoding of - universe to be decoupled from Coq's universes. Dependent products - and abstractions are similarly postulated rather than encoded as - Coq's dependent products and abstractions. *) - -Module Generic. - -(* begin hide *) -(* Notations used in the proof. Hidden in coqdoc. *) - -Reserved Notation "'āˆ€ā‚' x : A , B" (at level 200, x name, A at level 200,right associativity). -Reserved Notation "A 'āŸ¶ā‚' B" (at level 99, right associativity, B at level 200). -Reserved Notation "'Ī»ā‚' x , u" (at level 200, x name, right associativity). -Reserved Notation "f 'Ā·ā‚' x" (at level 5, left associativity). -Reserved Notation "'āˆ€ā‚‚' A , F" (at level 200, A name, right associativity). -Reserved Notation "'Ī»ā‚‚' x , u" (at level 200, x name, right associativity). -#[warning="-postfix-notation-not-level-1"] -Reserved Notation "f 'Ā·ā‚' [ A ]" (at level 5, left associativity). -Reserved Notation "'āˆ€ā‚€' x : A , B" (at level 200, x name, A at level 200,right associativity). -Reserved Notation "A 'āŸ¶ā‚€' B" (at level 99, right associativity, B at level 200). -Reserved Notation "'Ī»ā‚€' x , u" (at level 200, x name, right associativity). -Reserved Notation "f 'Ā·ā‚€' x" (at level 5, left associativity). -Reserved Notation "'āˆ€ā‚€Ā¹' A : U , F" (at level 200, A name, right associativity). -Reserved Notation "'Ī»ā‚€Ā¹' x , u" (at level 200, x name, right associativity). -#[warning="-postfix-notation-not-level-1"] -Reserved Notation "f 'Ā·ā‚€' [ A ]" (at level 5, left associativity). - -(* end hide *) - -Section Paradox. - -(** ** Axiomatisation of impredicative universes in a Martin-Lƶf style *) - -(** System U- has two impredicative universes. In the proof of the - paradox they are slightly asymmetric (in particular the reduction - rules of the small universe are not needed). Therefore, the - axioms are duplicated allowing for a weaker requirement than the - actual system U-. *) - - -(** *** Large universe *) -Variable U1 : Type. -Variable El1 : U1 -> Type. -(** **** Closure by small product *) -Variable Forall1 : forall u:U1, (El1 u -> U1) -> U1. - Notation "'āˆ€ā‚' x : A , B" := (Forall1 A (fun x => B)). - Notation "A 'āŸ¶ā‚' B" := (Forall1 A (fun _ => B)). -Variable lam1 : forall u B, (forall x:El1 u, El1 (B x)) -> El1 (āˆ€ā‚ x:u, B x). - Notation "'Ī»ā‚' x , u" := (lam1 _ _ (fun x => u)). -Variable app1 : forall u B (f:El1 (Forall1 u B)) (x:El1 u), El1 (B x). - Notation "f 'Ā·ā‚' x" := (app1 _ _ f x). -Variable beta1 : forall u B (f:forall x:El1 u, El1 (B x)) x, - (Ī»ā‚ y, f y) Ā·ā‚ x = f x. -(** **** Closure by large products *) -(** [U1] only needs to quantify over itself. *) -Variable ForallU1 : (U1->U1) -> U1. - Notation "'āˆ€ā‚‚' A , F" := (ForallU1 (fun A => F)). -Variable lamU1 : forall F, (forall A:U1, El1 (F A)) -> El1 (āˆ€ā‚‚ A, F A). - Notation "'Ī»ā‚‚' x , u" := (lamU1 _ (fun x => u)). -Variable appU1 : forall F (f:El1(āˆ€ā‚‚ A,F A)) (A:U1), El1 (F A). - Notation "f 'Ā·ā‚' [ A ]" := (appU1 _ f A). -Variable betaU1 : forall F (f:forall A:U1, El1 (F A)) A, - (Ī»ā‚‚ x, f x) Ā·ā‚ [ A ] = f A. - -(** *** Small universe *) -(** The small universe is an element of the large one. *) -Variable u0 : U1. -Notation U0 := (El1 u0). -Variable El0 : U0 -> Type. -(** **** Closure by small product *) -(** [U0] does not need reduction rules *) -Variable Forall0 : forall u:U0, (El0 u -> U0) -> U0. - Notation "'āˆ€ā‚€' x : A , B" := (Forall0 A (fun x => B)). - Notation "A 'āŸ¶ā‚€' B" := (Forall0 A (fun _ => B)). -Variable lam0 : forall u B, (forall x:El0 u, El0 (B x)) -> El0 (āˆ€ā‚€ x:u, B x). - Notation "'Ī»ā‚€' x , u" := (lam0 _ _ (fun x => u)). -Variable app0 : forall u B (f:El0 (Forall0 u B)) (x:El0 u), El0 (B x). - Notation "f 'Ā·ā‚€' x" := (app0 _ _ f x). -(** **** Closure by large products *) -Variable ForallU0 : forall u:U1, (El1 u->U0) -> U0. - Notation "'āˆ€ā‚€Ā¹' A : U , F" := (ForallU0 U (fun A => F)). -Variable lamU0 : forall U F, (forall A:El1 U, El0 (F A)) -> El0 (āˆ€ā‚€Ā¹ A:U, F A). - Notation "'Ī»ā‚€Ā¹' x , u" := (lamU0 _ _ (fun x => u)). -Variable appU0 : forall U F (f:El0(āˆ€ā‚€Ā¹ A:U,F A)) (A:El1 U), El0 (F A). - Notation "f 'Ā·ā‚€' [ A ]" := (appU0 _ _ f A). - -(** ** Automating the rewrite rules of our encoding. *) -Local Ltac simplify := - (* spiwack: ideally we could use [rewrite_strategy] here, but I am a tad - scared of the idea of depending on setoid rewrite in such a simple - file. *) - (repeat rewrite ?beta1, ?betaU1); - lazy beta. - -Local Ltac simplify_in h := - (repeat rewrite ?beta1, ?betaU1 in h); - lazy beta in h. - - -(** ** Hurkens's paradox. *) - -(** An inhabitant of [U0] standing for [False]. *) -Variable F:U0. - -(** *** Preliminary definitions *) - -Definition V : U1 := āˆ€ā‚‚ A, ((A āŸ¶ā‚ u0) āŸ¶ā‚ A āŸ¶ā‚ u0) āŸ¶ā‚ A āŸ¶ā‚ u0. -Definition U : U1 := V āŸ¶ā‚ u0. - -Definition sb (z:El1 V) : El1 V := Ī»ā‚‚ A, Ī»ā‚ r, Ī»ā‚ a, r Ā·ā‚ (zĀ·ā‚[A]Ā·ā‚r) Ā·ā‚ a. - -Definition le (i:El1 (UāŸ¶ā‚u0)) (x:El1 U) : U0 := - x Ā·ā‚ (Ī»ā‚‚ A, Ī»ā‚ r, Ī»ā‚ a, i Ā·ā‚ (Ī»ā‚ v, (sb v) Ā·ā‚ [A] Ā·ā‚ r Ā·ā‚ a)). -Definition le' : El1 ((UāŸ¶ā‚u0) āŸ¶ā‚ U āŸ¶ā‚ u0) := Ī»ā‚ i, Ī»ā‚ x, le i x. -Definition induct (i:El1 (UāŸ¶ā‚u0)) : U0 := - āˆ€ā‚€Ā¹ x:U, le i x āŸ¶ā‚€ i Ā·ā‚ x. - -Definition WF : El1 U := Ī»ā‚ z, (induct (zĀ·ā‚[U] Ā·ā‚ le')). -Definition I (x:El1 U) : U0 := - (āˆ€ā‚€Ā¹ i:UāŸ¶ā‚u0, le i x āŸ¶ā‚€ i Ā·ā‚ (Ī»ā‚ v, (sb v) Ā·ā‚ [U] Ā·ā‚ le' Ā·ā‚ x)) āŸ¶ā‚€ F -. - -(** *** Proof *) - -Lemma Omega : El0 (āˆ€ā‚€Ā¹ i:UāŸ¶ā‚u0, induct i āŸ¶ā‚€ i Ā·ā‚ WF). -Proof. - refine (Ī»ā‚€Ā¹ i, Ī»ā‚€ y, _). - refine (yĀ·ā‚€[_]Ā·ā‚€_). - unfold le,WF,induct. simplify. - refine (Ī»ā‚€Ā¹ x, Ī»ā‚€ h0, _). simplify. - refine (yĀ·ā‚€[_]Ā·ā‚€_). - unfold le. simplify. - unfold sb at 1. simplify. - unfold le' at 1. simplify. - exact h0. -Qed. - -Lemma lemma1 : El0 (induct (Ī»ā‚ u, I u)). -Proof. - unfold induct. - refine (Ī»ā‚€Ā¹ x, Ī»ā‚€ p, _). simplify. - refine (Ī»ā‚€ q,_). - assert (El0 (I (Ī»ā‚ v, (sb v)Ā·ā‚[U]Ā·ā‚le'Ā·ā‚x))) as h. - { generalize (qĀ·ā‚€[Ī»ā‚ u, I u]Ā·ā‚€p). simplify. - intros q'. - exact q'. } - refine (hĀ·ā‚€_). - refine (Ī»ā‚€Ā¹ i,_). - refine (Ī»ā‚€ h', _). - generalize (qĀ·ā‚€[Ī»ā‚ y, i Ā·ā‚ (Ī»ā‚ v, (sb v)Ā·ā‚[U] Ā·ā‚ le' Ā·ā‚ y)]). simplify. - intros q'. - refine (q'Ā·ā‚€_). clear q'. - unfold le at 1 in h'. simplify_in h'. - unfold sb at 1 in h'. simplify_in h'. - unfold le' at 1 in h'. simplify_in h'. - exact h'. -Qed. - -Lemma lemma2 : El0 ((āˆ€ā‚€Ā¹i:UāŸ¶ā‚u0, induct i āŸ¶ā‚€ iĀ·ā‚WF) āŸ¶ā‚€ F). -Proof. - refine (Ī»ā‚€ x, _). - assert (El0 (I WF)) as h. - { generalize (xĀ·ā‚€[Ī»ā‚ u, I u]Ā·ā‚€lemma1). simplify. - intros q. - exact q. } - refine (hĀ·ā‚€_). clear h. - refine (Ī»ā‚€Ā¹ i, Ī»ā‚€ h0, _). - generalize (xĀ·ā‚€[Ī»ā‚ y, iĀ·ā‚(Ī»ā‚ v, (sb v)Ā·ā‚[U]Ā·ā‚le'Ā·ā‚y)]). simplify. - intros q. - refine (qĀ·ā‚€_). clear q. - unfold le in h0. simplify_in h0. - unfold WF in h0. simplify_in h0. - exact h0. -Qed. - -Theorem paradox : El0 F. -Proof. - exact (lemma2Ā·ā‚€Omega). -Qed. - -End Paradox. - -(** The [paradox] tactic can be called as a shortcut to use the paradox. *) -Ltac paradox h := - unshelve (refine ((fun h => _) (paradox _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ ))). - -End Generic. - -(** * Impredicative universes are not retracts. *) - -(** There can be no retract to an impredicative Coq universe from a - smaller type. In this version of the proof, the impredicativity of - the universe is postulated with a pair of functions from the - universe to its type and back which commute with dependent product - in an appropriate way. *) - -Module NoRetractToImpredicativeUniverse. - -Section Paradox. - -Let U2 := Type. -Let U1:U2 := Type. -Variable U0:U1. - -(** *** [U1] is impredicative *) -Variable u22u1 : U2 -> U1. -Hypothesis u22u1_unit : forall (c:U2), c -> u22u1 c. -(** [u22u1_counit] and [u22u1_coherent] only apply to dependent - product so that the equations happen in the smaller [U1] rather - than [U2]. Indeed, it is not generally the case that one can - project from a large universe to an impredicative universe and - then get back the original type again. It would be too strong a - hypothesis to require (in particular, it is not true of - [Prop]). The formulation is reminiscent of the monadic - characteristic of the projection from a large type to [Prop].*) -Hypothesis u22u1_counit : forall (F:U1->U1), u22u1 (forall A,F A) -> (forall A,F A). -Hypothesis u22u1_coherent : forall (F:U1 -> U1) (f:forall x:U1, F x) (x:U1), - u22u1_counit _ (u22u1_unit _ f) x = f x. - -(** *** [U0] is a retract of [U1] *) -Variable u02u1 : U0 -> U1. -Variable u12u0 : U1 -> U0. -Hypothesis u12u0_unit : forall (b:U1), b -> u02u1 (u12u0 b). -Hypothesis u12u0_counit : forall (b:U1), u02u1 (u12u0 b) -> b. - -(** ** Paradox *) - -Theorem paradox : forall F:U1, F. -Proof. - intros F. - Generic.paradox h. - (** Large universe *) - + exact U1. - + exact (fun X => X). - + cbn. exact (fun u F => forall x:u, F x). - + cbn. exact (fun _ _ x => x). - + cbn. exact (fun _ _ x => x). - - + cbn. exact (fun F => u22u1 (forall x, F x)). - + cbn. exact (fun _ x => u22u1_unit _ x). - + cbn. exact (fun _ x => u22u1_counit _ x). - (** Small universe *) - + exact U0. - (** The interpretation of the small universe is the image of - [U0] in [U1]. *) - + cbn. exact (fun X => u02u1 X). - + cbn. exact (fun u F => u12u0 (forall x:(u02u1 u), u02u1 (F x))). - + cbn. exact (fun u F => u12u0 (forall x:u, u02u1 (F x))). - + cbn. exact (u12u0 F). - + cbn in h. - exact (u12u0_counit _ h). - + cbn. easy. - + cbn. intros **. now rewrite u22u1_coherent. - + cbn. intros * x. exact (u12u0_unit _ x). - + cbn. intros * x. exact (u12u0_counit _ x). - + cbn. intros * x. exact (u12u0_unit _ x). - + cbn. intros * x. exact (u12u0_counit _ x). -Qed. - -End Paradox. - -End NoRetractToImpredicativeUniverse. - -(** * Modal fragments of [Prop] are not retracts *) - -(** In presence of a a monadic modality on [Prop], we can define a - subset of [Prop] of modal propositions which is also a complete - Heyting algebra. These cannot be a retract of a modal - proposition. This is a case where the universe in system U- are - not encoded as Coq universes. *) - -Module NoRetractToModalProposition. - -(** ** Monadic modality *) - -Section Paradox. - -Variable M : Prop -> Prop. -Hypothesis incr : forall A B:Prop, (A->B) -> M A -> M B. - -Lemma strength: forall A (P:A->Prop), M(forall x:A,P x) -> forall x:A,M(P x). -Proof. - intros A P h x. - eapply incr in h; eauto. -Qed. - -(** ** The universe of modal propositions *) - -Definition MProp := { P:Prop | M P -> P }. -Definition El : MProp -> Prop := @proj1_sig _ _. - -Lemma modal : forall P:MProp, M(El P) -> El P. -Proof. - intros [P m]. cbn. - exact m. -Qed. - -Definition Forall {A:Type} (P:A->MProp) : MProp. -Proof. - unshelve (refine (exist _ _ _)). - + exact (forall x:A, El (P x)). - + intros h x. - eapply strength in h. - eauto using modal. -Defined. - -(** ** Retract of the modal fragment of [Prop] in a small type *) - -(** The retract is axiomatized using logical equivalence as the - equality on propositions. *) - -Variable bool : MProp. -Variable p2b : MProp -> El bool. -Variable b2p : El bool -> MProp. -Hypothesis p2p1 : forall A:MProp, El (b2p (p2b A)) -> El A. -Hypothesis p2p2 : forall A:MProp, El A -> El (b2p (p2b A)). - -(** ** Paradox *) - -Theorem paradox : forall B:MProp, El B. -Proof. - intros B. - Generic.paradox h. - (** Large universe *) - + exact MProp. - + exact El. - + exact (fun _ => Forall). - + cbn. exact (fun _ _ f => f). - + cbn. exact (fun _ _ f => f). - + exact Forall. - + cbn. exact (fun _ f => f). - + cbn. exact (fun _ f => f). - (** Small universe *) - + exact bool. - + exact (fun b => El (b2p b)). - + cbn. exact (fun _ F => p2b (Forall (fun x => b2p (F x)))). - + exact (fun _ F => p2b (Forall (fun x => b2p (F x)))). - + apply p2b. - exact B. - + cbn in h. auto. - + cbn. easy. - + cbn. easy. - + cbn. auto. - + cbn. intros * f. - apply p2p1 in f. cbn in f. - exact f. - + cbn. auto. - + cbn. intros * f. - apply p2p1 in f. cbn in f. - exact f. -Qed. - -End Paradox. - -End NoRetractToModalProposition. - -(** * The negative fragment of [Prop] is not a retract *) - -(** The existence in the pure Calculus of Constructions of a retract - from the negative fragment of [Prop] into a negative proposition - is inconsistent. This is an instance of the previous result. *) - -Module NoRetractToNegativeProp. - -(** ** The universe of negative propositions. *) - -Definition NProp := { P:Prop | ~~P -> P }. -Definition El : NProp -> Prop := @proj1_sig _ _. - -Section Paradox. - -(** ** Retract of the negative fragment of [Prop] in a small type *) - -(** The retract is axiomatized using logical equivalence as the - equality on propositions. *) - -Variable bool : NProp. -Variable p2b : NProp -> El bool. -Variable b2p : El bool -> NProp. -Hypothesis p2p1 : forall A:NProp, El (b2p (p2b A)) -> El A. -Hypothesis p2p2 : forall A:NProp, El A -> El (b2p (p2b A)). - -(** ** Paradox *) - -Theorem paradox : forall B:NProp, El B. -Proof. - intros B. - unshelve (refine ((fun h => _) (NoRetractToModalProposition.paradox _ _ _ _ _ _ _ _))). - + exact (fun P => ~~P). - + exact bool. - + exact p2b. - + exact b2p. - + exact B. - + exact h. - + cbn. auto. - + cbn. auto. - + cbn. auto. -Qed. - -End Paradox. - -End NoRetractToNegativeProp. - -(** * Prop is not a retract *) - -(** The existence in the pure Calculus of Constructions of a retract - from [Prop] into a small type of [Prop] is inconsistent. This is a - special case of the previous result. *) - -Module NoRetractFromSmallPropositionToProp. - -(** ** The universe of propositions. *) - -Definition NProp := { P:Prop | P -> P}. -Definition El : NProp -> Prop := @proj1_sig _ _. - -Section MParadox. - -(** ** Retract of [Prop] in a small type, using the identity modality. *) - -Variable bool : NProp. -Variable p2b : NProp -> El bool. -Variable b2p : El bool -> NProp. -Hypothesis p2p1 : forall A:NProp, El (b2p (p2b A)) -> El A. -Hypothesis p2p2 : forall A:NProp, El A -> El (b2p (p2b A)). - -(** ** Paradox *) - -Theorem mparadox : forall B:NProp, El B. -Proof. - intros B. - unshelve (refine ((fun h => _) (NoRetractToModalProposition.paradox _ _ _ _ _ _ _ _))). - + exact (fun P => P). - + exact bool. - + exact p2b. - + exact b2p. - + exact B. - + exact h. - + cbn. auto. - + cbn. auto. - + cbn. auto. -Qed. - -End MParadox. - -Section Paradox. - -(** ** Retract of [Prop] in a small type *) - -(** The retract is axiomatized using logical equivalence as the - equality on propositions. *) -Variable bool : Prop. -Variable p2b : Prop -> bool. -Variable b2p : bool -> Prop. -Hypothesis p2p1 : forall A:Prop, b2p (p2b A) -> A. -Hypothesis p2p2 : forall A:Prop, A -> b2p (p2b A). - -(** ** Paradox *) - -Theorem paradox : forall B:Prop, B. -Proof. - intros B. - unshelve (refine (mparadox (exist _ bool (fun x => x)) _ _ _ _ - (exist _ B (fun x => x)))). - + intros p. red. red. exact (p2b (El p)). - + cbn. intros b. red. exists (b2p b). exact (fun x => x). - + cbn. intros [A H]. cbn. apply p2p1. - + cbn. intros [A H]. cbn. apply p2p2. -Qed. - -End Paradox. - -End NoRetractFromSmallPropositionToProp. - - -(** * Large universes are not retracts of [Prop]. *) - -(** The existence in the Calculus of Constructions with universes of a - retract from some [Type] universe into [Prop] is inconsistent. *) - -(* Note: Assuming the context [down:Type->Prop; up:Prop->Type; forth: - forall (A:Type), A -> up (down A); back: forall (A:Type), up - (down A) -> A; H: forall (A:Type) (P:A->Type) (a:A), - P (back A (forth A a)) -> P a] is probably enough. *) - -Module NoRetractFromTypeToProp. - -Definition Type2 := Type. -Definition Type1 := Type : Type2. - -Section Paradox. - -(** ** Assumption of a retract from Type into Prop *) - -Variable down : Type1 -> Prop. -Variable up : Prop -> Type1. -Hypothesis up_down : forall (A:Type1), up (down A) = A :> Type1. - -(** ** Paradox *) - -Theorem paradox : forall P:Prop, P. -Proof. - intros P. - Generic.paradox h. - (** Large universe. *) - + exact Type1. - + exact (fun X => X). - + cbn. exact (fun u F => forall x, F x). - + cbn. exact (fun _ _ x => x). - + cbn. exact (fun _ _ x => x). - + exact (fun F => forall A:Prop, F(up A)). - + cbn. exact (fun F f A => f (up A)). - + cbn. - intros F f A. - specialize (f (down A)). - rewrite up_down in f. - exact f. - + exact Prop. - + cbn. exact (fun X => X). - + cbn. exact (fun A P => forall x:A, P x). - + cbn. exact (fun A P => forall x:A, P x). - + cbn. exact P. - + exact h. - + cbn. easy. - + cbn. - intros F f A. - destruct (up_down A). cbn. - reflexivity. - + cbn. exact (fun _ _ x => x). - + cbn. exact (fun _ _ x => x). - + cbn. exact (fun _ _ x => x). - + cbn. exact (fun _ _ x => x). -Qed. - -End Paradox. - -End NoRetractFromTypeToProp. - -(** * [A<>Type] *) - -(** No Coq universe can be equal to one of its elements. *) - -Module TypeNeqSmallType. - -Unset Universe Polymorphism. - -Section Paradox. - -(** ** Universe [U] is equal to one of its elements. *) - -Let U := Type. -Variable A:U. -Hypothesis h : U=A. - -(** ** Universe [U] is a retract of [A] *) - -(** The following context is actually sufficient for the paradox to - hold. The hypothesis [h:U=A] is only used to define [down], [up] - and [up_down]. *) - -Let down (X:U) : A := @eq_rect _ _ (fun X => X) X _ h. -Let up (X:A) : U := @eq_rect_r _ _ (fun X => X) X _ h. - -Lemma up_down : forall (X:U), up (down X) = X. -Proof. - unfold up,down. - rewrite <- h. - reflexivity. -Qed. - -Theorem paradox : False. -Proof. - Generic.paradox p. - (** Large universe *) - + exact U. - + exact (fun X=>X). - + cbn. exact (fun X F => forall x:X, F x). - + cbn. exact (fun _ _ x => x). - + cbn. exact (fun _ _ x => x). - + exact (fun F => forall x:A, F (up x)). - + cbn. exact (fun _ f => fun x:A => f (up x)). - + cbn. intros * f X. - specialize (f (down X)). - rewrite up_down in f. - exact f. - (** Small universe *) - + exact A. - (** The interpretation of [A] as a universe is [U]. *) - + cbn. exact up. - + cbn. exact (fun _ F => down (forall x, up (F x))). - + cbn. exact (fun _ F => down (forall x, up (F x))). - + cbn. exact (down False). - + rewrite up_down in p. - exact p. - + cbn. easy. - + cbn. intros ? f X. - destruct (up_down X). cbn. - reflexivity. - + cbn. intros ? ? f. - rewrite up_down. - exact f. - + cbn. intros ? ? f. - rewrite up_down in f. - exact f. - + cbn. intros ? ? f. - rewrite up_down. - exact f. - + cbn. intros ? ? f. - rewrite up_down in f. - exact f. -Qed. - -End Paradox. - -End TypeNeqSmallType. - -(** * [Prop<>Type]. *) - -(** Special case of [TypeNeqSmallType]. *) - -Module PropNeqType. - -Theorem paradox : Prop <> Type. -Proof. - intros h. - unshelve (refine (TypeNeqSmallType.paradox _ _)). - + exact Prop. - + easy. -Qed. - -End PropNeqType. - -(* end show *) diff --git a/stdlib/theories/Logic/IndefiniteDescription.v b/stdlib/theories/Logic/IndefiniteDescription.v deleted file mode 100644 index 1c2a5e7549bb..000000000000 --- a/stdlib/theories/Logic/IndefiniteDescription.v +++ /dev/null @@ -1,39 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* Prop), - (exists x, P x) -> { x : A | P x }. - -Lemma constructive_definite_description : - forall (A : Type) (P : A->Prop), - (exists! x, P x) -> { x : A | P x }. -Proof. - intros; apply constructive_indefinite_description; firstorder. -Qed. - -Lemma functional_choice : - forall (A B : Type) (R:A->B->Prop), - (forall x : A, exists y : B, R x y) -> - (exists f : A->B, forall x : A, R x (f x)). -Proof. - apply constructive_indefinite_descr_fun_choice. - exact constructive_indefinite_description. -Qed. diff --git a/stdlib/theories/Logic/JMeq.v b/stdlib/theories/Logic/JMeq.v deleted file mode 100644 index fd61fde9c79f..000000000000 --- a/stdlib/theories/Logic/JMeq.v +++ /dev/null @@ -1,169 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* Prop := - JMeq_refl : JMeq x x. - -Set Elimination Schemes. - -Arguments JMeq_refl {A x} , [A] x. - -Register JMeq as core.JMeq.type. -Register JMeq_refl as core.JMeq.refl. - -#[global] -Hint Resolve JMeq_refl : core. - -Definition JMeq_hom {A : Type} (x y : A) := JMeq x y. - -Register JMeq_hom as core.JMeq.hom. - -Lemma JMeq_sym : forall (A B:Type) (x:A) (y:B), JMeq x y -> JMeq y x. -Proof. -intros A B x y H; destruct H; trivial. -Qed. - -#[global] -Hint Immediate JMeq_sym : core. - -Register JMeq_sym as core.JMeq.sym. - -Lemma JMeq_trans : - forall (A B C:Type) (x:A) (y:B) (z:C), JMeq x y -> JMeq y z -> JMeq x z. -Proof. -destruct 2; trivial. -Qed. - -Register JMeq_trans as core.JMeq.trans. - -Theorem JMeq_eq : forall (A:Type) (x y:A), JMeq x y -> x = y. -Proof. - intros A x y Heq. - inversion Heq. - now apply (inj_pairT2 _ _ A x y). -Qed. - -Lemma JMeq_ind : forall (A:Type) (x:A) (P:A -> Prop), - P x -> forall y, JMeq x y -> P y. -Proof. -intros A x P H y H'; case JMeq_eq with (1 := H'); trivial. -Qed. - -Register JMeq_ind as core.JMeq.ind. - -Lemma JMeq_rec : forall (A:Type) (x:A) (P:A -> Set), - P x -> forall y, JMeq x y -> P y. -Proof. -intros A x P H y H'; case JMeq_eq with (1 := H'); trivial. -Qed. - -Lemma JMeq_rect : forall (A:Type) (x:A) (P:A->Type), - P x -> forall y, JMeq x y -> P y. -Proof. -intros A x P H y H'; case JMeq_eq with (1 := H'); trivial. -Qed. - -Lemma JMeq_ind_r : forall (A:Type) (x:A) (P:A -> Prop), - P x -> forall y, JMeq y x -> P y. -Proof. -intros A x P H y H'; case JMeq_eq with (1 := JMeq_sym H'); trivial. -Qed. - -Lemma JMeq_rec_r : forall (A:Type) (x:A) (P:A -> Set), - P x -> forall y, JMeq y x -> P y. -Proof. -intros A x P H y H'; case JMeq_eq with (1 := JMeq_sym H'); trivial. -Qed. - -Lemma JMeq_rect_r : forall (A:Type) (x:A) (P:A -> Type), - P x -> forall y, JMeq y x -> P y. -Proof. -intros A x P H y H'; case JMeq_eq with (1 := JMeq_sym H'); trivial. -Qed. - -Lemma JMeq_congr : - forall (A:Type) (x:A) (B:Type) (f:A->B) (y:A), JMeq x y -> f x = f y. -Proof. -intros A x B f y H; case JMeq_eq with (1 := H); trivial. -Qed. - -Register JMeq_congr as core.JMeq.congr. - -(** [JMeq] is equivalent to [eq_dep Type (fun X => X)] *) - -Require Import Eqdep. - -Lemma JMeq_eq_dep_id : - forall (A B:Type) (x:A) (y:B), JMeq x y -> eq_dep Type (fun X => X) A x B y. -Proof. -destruct 1. -apply eq_dep_intro. -Qed. - -Lemma eq_dep_id_JMeq : - forall (A B:Type) (x:A) (y:B), eq_dep Type (fun X => X) A x B y -> JMeq x y. -Proof. -destruct 1. -apply JMeq_refl. -Qed. - -(** [eq_dep U P p x q y] is strictly finer than [JMeq (P p) x (P q) y] *) - -Lemma eq_dep_JMeq : - forall U P p x q y, eq_dep U P p x q y -> JMeq x y. -Proof. -destruct 1. -apply JMeq_refl. -Qed. - -Lemma eq_dep_strictly_stronger_JMeq : - exists U P p q x y, JMeq x y /\ ~ eq_dep U P p x q y. -Proof. -exists bool. exists (fun _ => True). exists true. exists false. -exists I. exists I. -split. -- trivial. -- intro H. - assert (true=false) by (destruct H; reflexivity). - discriminate. -Qed. - -(** However, when the dependencies are equal, [JMeq (P p) x (P q) y] - is as strong as [eq_dep U P p x q y] (this uses [JMeq_eq]) *) - -Lemma JMeq_eq_dep : - forall U (P:U->Type) p q (x:P p) (y:P q), - p = q -> JMeq x y -> eq_dep U P p x q y. -Proof. -intros U P p q x y H H0. -destruct H. -apply JMeq_eq in H0 as ->. -reflexivity. -Qed. - - -(* Compatibility *) -Notation sym_JMeq := JMeq_sym (only parsing). -Notation trans_JMeq := JMeq_trans (only parsing). diff --git a/stdlib/theories/Logic/ProofIrrelevance.v b/stdlib/theories/Logic/ProofIrrelevance.v deleted file mode 100644 index c1ecb36cd86c..000000000000 --- a/stdlib/theories/Logic/ProofIrrelevance.v +++ /dev/null @@ -1,22 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* Type) (x:Q p) (h:p = p), - x = eq_rect p Q x p h. - Proof. - intros U p Q x h; rewrite (M.proof_irrelevance _ h (eq_refl p)). - reflexivity. - Qed. - End Eq_rect_eq. - - (** Export the theory of injective dependent elimination *) - - Module EqdepTheory := EqdepTheory(Eq_rect_eq). - Export EqdepTheory. - - Scheme eq_indd := Induction for eq Sort Prop. - - (** We derive the irrelevance of the membership property for subsets *) - - Lemma subset_eq_compat : - forall (U:Type) (P:U->Prop) (x y:U) (p:P x) (q:P y), - x = y -> exist P x p = exist P y q. - Proof. - intros U P x y p q H. - rewrite (M.proof_irrelevance _ q (eq_rect x P p y H)). - elim H using eq_indd. - reflexivity. - Qed. - - Lemma subsetT_eq_compat : - forall (U:Type) (P:U->Prop) (x y:U) (p:P x) (q:P y), - x = y -> existT P x p = existT P y q. - Proof. - intros U P x y p q H. - rewrite (M.proof_irrelevance _ q (eq_rect x P p y H)). - elim H using eq_indd. - reflexivity. - Qed. - -End ProofIrrelevanceTheory. diff --git a/stdlib/theories/Logic/PropExtensionality.v b/stdlib/theories/Logic/PropExtensionality.v deleted file mode 100644 index 2d473e74993c..000000000000 --- a/stdlib/theories/Logic/PropExtensionality.v +++ /dev/null @@ -1,23 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* Q) -> P = Q. - -Require Import ClassicalFacts. - -Theorem proof_irrelevance : forall (P:Prop) (p1 p2:P), p1 = p2. -Proof. - apply ext_prop_dep_proof_irrel_cic. - exact propositional_extensionality. -Qed. diff --git a/stdlib/theories/Logic/PropExtensionalityFacts.v b/stdlib/theories/Logic/PropExtensionalityFacts.v deleted file mode 100644 index 3924eefacc83..000000000000 --- a/stdlib/theories/Logic/PropExtensionalityFacts.v +++ /dev/null @@ -1,111 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* Proposition extensionality + Propositional functional extensionality - -2.2 Propositional extensionality -> Provable propositional extensionality - -2.3 Propositional extensionality -> Refutable propositional extensionality - -*) - -Set Implicit Arguments. - -(**********************************************************************) -(** * Definitions *) - -(** Propositional extensionality *) - -Local Notation PropositionalExtensionality := - (forall A B : Prop, (A <-> B) -> A = B). - -(** Provable-proposition extensionality *) - -Local Notation ProvablePropositionExtensionality := - (forall A:Prop, A -> A = True). - -(** Refutable-proposition extensionality *) - -Local Notation RefutablePropositionExtensionality := - (forall A:Prop, ~A -> A = False). - -(** Predicate extensionality *) - -Local Notation PredicateExtensionality := - (forall (A:Type) (P Q : A -> Prop), (forall x, P x <-> Q x) -> P = Q). - -(** Propositional functional extensionality *) - -Local Notation PropositionalFunctionalExtensionality := - (forall (A:Type) (P Q : A -> Prop), (forall x, P x = Q x) -> P = Q). - -(**********************************************************************) -(** * Propositional and predicate extensionality *) - -(**********************************************************************) -(** ** Predicate extensionality <-> Propositional extensionality + Propositional functional extensionality *) - -Lemma PredExt_imp_PropExt : PredicateExtensionality -> PropositionalExtensionality. -Proof. - intros Ext A B Equiv. - change A with ((fun _ => A) I). - now rewrite Ext with (P := fun _ : True =>A) (Q := fun _ => B). -Qed. - -Lemma PredExt_imp_PropFunExt : PredicateExtensionality -> PropositionalFunctionalExtensionality. -Proof. - intros Ext A P Q Eq. apply Ext. intros x. now rewrite (Eq x). -Qed. - -Lemma PropExt_and_PropFunExt_imp_PredExt : - PropositionalExtensionality -> PropositionalFunctionalExtensionality -> PredicateExtensionality. -Proof. - intros Ext FunExt A P Q Equiv. - apply FunExt. intros x. now apply Ext. -Qed. - -Theorem PropExt_and_PropFunExt_iff_PredExt : - PropositionalExtensionality /\ PropositionalFunctionalExtensionality <-> PredicateExtensionality. -Proof. - firstorder using PredExt_imp_PropExt, PredExt_imp_PropFunExt, PropExt_and_PropFunExt_imp_PredExt. -Qed. - -(**********************************************************************) -(** ** Propositional extensionality and provable proposition extensionality *) - -Lemma PropExt_imp_ProvPropExt : PropositionalExtensionality -> ProvablePropositionExtensionality. -Proof. - intros Ext A Ha; apply Ext; split; trivial. -Qed. - -(**********************************************************************) -(** ** Propositional extensionality and refutable proposition extensionality *) - -Lemma PropExt_imp_RefutPropExt : PropositionalExtensionality -> RefutablePropositionExtensionality. -Proof. - intros Ext A Ha; apply Ext; split; easy. -Qed. diff --git a/stdlib/theories/Logic/PropFacts.v b/stdlib/theories/Logic/PropFacts.v deleted file mode 100644 index c4328a3e6e4e..000000000000 --- a/stdlib/theories/Logic/PropFacts.v +++ /dev/null @@ -1,52 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* Prop) - (inj : forall A B, (f A <-> f B) -> (A <-> B)) - (ext : forall A B, A <-> B -> f A <-> f B) - : forall A, f (f A) <-> A. -Proof. -intros. -enough (f (f (f A)) <-> f A) by (apply inj; assumption). -split; intro H. -- now_show (f A). - enough (f A <-> True) by firstorder. - enough (f (f A) <-> f True) by (apply inj; assumption). - split; intro H'. - + now_show (f True). - enough (f (f (f A)) <-> f True) by firstorder. - apply ext; firstorder. - + now_show (f (f A)). - enough (f (f A) <-> True) by firstorder. - apply inj; firstorder. -- now_show (f (f (f A))). - enough (f A <-> f (f (f A))) by firstorder. - apply ext. - split; intro H'. - + now_show (f (f A)). - enough (f A <-> f (f A)) by firstorder. - apply ext; firstorder. - + now_show A. - enough (f A <-> A) by firstorder. - apply inj; firstorder. -Defined. diff --git a/stdlib/theories/Logic/RelationalChoice.v b/stdlib/theories/Logic/RelationalChoice.v deleted file mode 100644 index 93d618119bc6..000000000000 --- a/stdlib/theories/Logic/RelationalChoice.v +++ /dev/null @@ -1,17 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* B->Prop), - (forall x : A, exists y : B, R x y) -> - exists R' : A->B->Prop, - subrelation R' R /\ forall x : A, exists! y : B, R' x y. diff --git a/stdlib/theories/Logic/SetIsType.v b/stdlib/theories/Logic/SetIsType.v deleted file mode 100644 index edfd656b08e0..000000000000 --- a/stdlib/theories/Logic/SetIsType.v +++ /dev/null @@ -1,19 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* A -> Prop, - forall T : A -> B -> Prop, - Equivalence R -> - (forall x x' y, R x x' -> T x y -> T x' y) -> - (forall x, exists y, T x y) -> - exists f : A -> B, forall x : A, T x (f x) /\ (forall x' : A, R x x' -> f x = f x'). -Proof. - apply setoid_functional_choice_first_characterization. split; [|split]. - - exact choice. - - exact extensional_function_representative. - - exact classic. -Qed. - -Theorem representative_choice : - forall A (R:A->A->Prop), (Equivalence R) -> - exists f : A->A, forall x : A, R x (f x) /\ forall x', R x x' -> f x = f x'. -Proof. - apply setoid_fun_choice_imp_repr_fun_choice. - exact setoid_choice. -Qed. diff --git a/stdlib/theories/Logic/StrictProp.v b/stdlib/theories/Logic/StrictProp.v deleted file mode 100644 index d473be0e8b55..000000000000 --- a/stdlib/theories/Logic/StrictProp.v +++ /dev/null @@ -1,37 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* Squash A. -Arguments squash {_} _. - -Inductive sEmpty : SProp :=. - -Inductive sUnit : SProp := stt. - -Set Primitive Projections. -Record Ssig {A:Type} (P:A->SProp) := Sexists { Spr1 : A; Spr2 : P Spr1 }. -Arguments Sexists {_} _ _ _. -Arguments Spr1 {_ _} _. -Arguments Spr2 {_ _} _. - -Lemma Spr1_inj {A P} {a b : @Ssig A P} (e : Spr1 a = Spr1 b) : a = b. -Proof. - destruct a,b;simpl in e. - destruct e. reflexivity. -Defined. diff --git a/stdlib/theories/Logic/WKL.v b/stdlib/theories/Logic/WKL.v deleted file mode 100644 index c3d871e339fc..000000000000 --- a/stdlib/theories/Logic/WKL.v +++ /dev/null @@ -1,272 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* Prop) : nat -> list bool -> Prop := -| here l : ~ P l -> is_path_from P 0 l -| next_left l n : ~ P l -> is_path_from P n (true::l) -> is_path_from P (S n) l -| next_right l n : ~ P l -> is_path_from P n (false::l) -> is_path_from P (S n) l. - -(** We give the characterization of is_path_from in terms of a more common arithmetical formula *) - -Proposition is_path_from_characterization P n l : - is_path_from P n l <-> exists l', length l' = n /\ forall n', n'<=n -> ~ P (rev (firstn n' l') ++ l). -Proof. -intros. split. -- induction 1 as [|* HP _ (l'&Hl'&HPl')|* HP _ (l'&Hl'&HPl')]. - + exists []. split. - * reflexivity. - * intros n ->%Nat.le_0_r. assumption. - + exists (true :: l'). split. - * apply eq_S, Hl'. - * intros [|] H. - -- assumption. - -- simpl. rewrite <- app_assoc. apply HPl', le_S_n, H. - + exists (false :: l'). split. - * apply eq_S, Hl'. - * intros [|] H. - -- assumption. - -- simpl. rewrite <- app_assoc. apply HPl', le_S_n, H. -- intros (l'& <- &HPl'). induction l' as [|[|]] in l, HPl' |- *. - + constructor. apply (HPl' 0). apply Nat.le_0_l. - + eapply next_left. - * apply (HPl' 0), Nat.le_0_l. - * fold (length l'). apply IHl'. intros n' H%le_n_S. apply HPl' in H. simpl in H. rewrite <- app_assoc in H. assumption. - + apply next_right. - * apply (HPl' 0), Nat.le_0_l. - * fold (length l'). apply IHl'. intros n' H%le_n_S. apply HPl' in H. simpl in H. rewrite <- app_assoc in H. assumption. -Qed. - -(** [infinite_from P l] means that we can find arbitrary long paths - along which [P] does not hold above [l] *) - -Definition infinite_from (P:list bool -> Prop) l := forall n, is_path_from P n l. - -(** [has_infinite_path P] means that there is an infinite path - (represented as a predicate) along which [P] does not hold at all *) - -Definition has_infinite_path (P:list bool -> Prop) := - exists (X:nat -> Prop), forall l, approx X l -> ~ P l. - -(** [inductively_barred_at P n l] means that [P] eventually holds above - [l] after at most [n] steps upwards *) - -Inductive inductively_barred_at (P:list bool -> Prop) : nat -> list bool -> Prop := -| now_at l n : P l -> inductively_barred_at P n l -| propagate_at l n : - inductively_barred_at P n (true::l) -> - inductively_barred_at P n (false::l) -> - inductively_barred_at P (S n) l. - -(** The proof proceeds by building a set [Y] of finite paths - approximating either the smallest unbarred infinite path in [P], if - there is one (taking [true]>[false]), or the path - true::true::... if [P] happens to be inductively_barred *) - -Fixpoint Y P (l:list bool) := - match l with - | [] => True - | b::l => - Y P l /\ - if b then exists n, inductively_barred_at P n (false::l) else infinite_from P (false::l) - end. - -Require Import Compare_dec. - -Lemma is_path_from_restrict : forall P n n' l, n <= n' -> - is_path_from P n' l -> is_path_from P n l. -Proof. -intros * Hle H; induction H in n, Hle, H |- * ; intros. -- apply Nat.le_0_r in Hle as ->. apply here. assumption. -- destruct n. - + apply here. assumption. - + apply Nat.succ_le_mono in Hle. - apply next_left; auto. -- destruct n. - + apply here. assumption. - + apply Nat.succ_le_mono in Hle. - apply next_right; auto. -Qed. - -Lemma inductively_barred_at_monotone : forall P l n n', n' <= n -> - inductively_barred_at P n' l -> inductively_barred_at P n l. -Proof. -intros * Hle Hbar. -induction Hbar in n, l, Hle, Hbar |- *. -- apply now_at; auto. -- destruct n; [apply Nat.nle_succ_0 in Hle; contradiction|]. - apply Nat.succ_le_mono in Hle. - apply propagate_at; auto. -Qed. - -Definition demorgan_or (P:list bool -> Prop) l l' := ~ (P l /\ P l') -> ~ P l \/ ~ P l'. - -Definition demorgan_inductively_barred_at P := - forall n l, demorgan_or (inductively_barred_at P n) (true::l) (false::l). - -Lemma inductively_barred_at_imp_is_path_from : - forall P, demorgan_inductively_barred_at P -> forall n l, - ~ inductively_barred_at P n l -> is_path_from P n l. -Proof. -intros P Hdemorgan; induction n; intros l H. -- apply here. - intro. apply H. - apply now_at. auto. -- assert (H0:~ (inductively_barred_at P n (true::l) /\ inductively_barred_at P n (false::l))) - by firstorder using inductively_barred_at. - assert (HnP:~ P l) by firstorder using inductively_barred_at. - apply Hdemorgan in H0 as [H0|H0]; apply IHn in H0; auto using is_path_from. -Qed. - -Lemma is_path_from_imp_inductively_barred_at : forall P n l, - is_path_from P n l -> inductively_barred_at P n l -> False. -Proof. -intros P; induction n; intros l H1 H2. -- inversion_clear H1. inversion_clear H2. auto. -- inversion_clear H1. - + inversion_clear H2. - * auto. - * apply IHn with (true::l); auto. - + inversion_clear H2. - * auto. - * apply IHn with (false::l); auto. -Qed. - -Lemma find_left_path : forall P l n, - is_path_from P (S n) l -> inductively_barred_at P n (false :: l) -> is_path_from P n (true :: l). -Proof. -inversion 1; subst; intros. -- auto. -- exfalso. eauto using is_path_from_imp_inductively_barred_at. -Qed. - -Lemma Y_unique : forall P, demorgan_inductively_barred_at P -> - forall l1 l2, length l1 = length l2 -> Y P l1 -> Y P l2 -> l1 = l2. -Proof. -intros * DeMorgan. induction l1, l2. -- trivial. -- discriminate. -- discriminate. -- intros [= H] (HY1,H1) (HY2,H2). - pose proof (IHl1 l2 H HY1 HY2). clear HY1 HY2 H IHl1. - subst l1. - f_equal. - destruct a, b; try reflexivity. - + destruct H1 as (n,Hbar). - destruct (is_path_from_imp_inductively_barred_at _ _ _ (H2 n) Hbar). - + destruct H2 as (n,Hbar). - destruct (is_path_from_imp_inductively_barred_at _ _ _ (H1 n) Hbar). -Qed. - -(** [X] is the translation of [Y] as a predicate *) - -Definition X P n := exists l, length l = n /\ Y P (true::l). - -Lemma Y_approx : forall P, demorgan_inductively_barred_at P -> - forall l, approx (X P) l -> Y P l. -Proof. -intros P DeMorgan. induction l. -- trivial. -- intros (H,Hb). split. - + auto. - + unfold X in Hb. - destruct a. - * destruct Hb as (l',(Hl',(HYl',HY))). - rewrite <- (Y_unique P DeMorgan l' l Hl'); auto. - * intro n. apply inductively_barred_at_imp_is_path_from. - -- assumption. - -- firstorder. -Qed. - -(** Main theorem *) - -Theorem PreWeakKonigsLemma : forall P, - demorgan_inductively_barred_at P -> infinite_from P [] -> has_infinite_path P. -Proof. -intros P DeMorgan Hinf. -exists (X P). intros l Hl. -assert (infinite_from P l). -{ induction l. - - assumption. - - destruct Hl as (Hl,Ha). - intros n. - pose proof (IHl Hl) as IHl'. clear IHl. - apply Y_approx in Hl; [|assumption]. - destruct a. - + destruct Ha as (l'&Hl'&HY'&n'&Hbar). - rewrite (Y_unique _ DeMorgan _ _ Hl' HY' Hl) in Hbar. - destruct (le_lt_dec n n') as [Hle|Hlt]. - * specialize (IHl' (S n')). - apply is_path_from_restrict with n'; [assumption|]. - apply find_left_path; trivial. - * specialize (IHl' (S n)). - apply inductively_barred_at_monotone with (n:=n) in Hbar; [|apply Nat.lt_le_incl, Hlt]. - apply find_left_path; trivial. - + apply inductively_barred_at_imp_is_path_from; firstorder. } -specialize (H 0). inversion H. assumption. -Qed. - -Lemma inductively_barred_at_decidable : - forall P, (forall l, P l \/ ~ P l) -> forall n l, inductively_barred_at P n l \/ ~ inductively_barred_at P n l. -Proof. -intros P HP. induction n; intros. -- destruct (HP l). - + left. apply now_at, H. - + right. inversion 1. auto. -- destruct (HP l). - + left. apply now_at, H. - + destruct (IHn (true::l)). - * destruct (IHn (false::l)). - { left. apply propagate_at; assumption. } - { right. inversion_clear 1; auto. } - * right. inversion_clear 1; auto. -Qed. - -Lemma inductively_barred_at_is_path_from_decidable : - forall P, (forall l, P l \/ ~ P l) -> demorgan_inductively_barred_at P. -Proof. -intros P Hdec n l H. -destruct (inductively_barred_at_decidable P Hdec n (true::l)). -- destruct (inductively_barred_at_decidable P Hdec n (false::l)). - + auto. - + auto. -- auto. -Qed. - -(** Main corollary *) - -Corollary WeakKonigsLemma : forall P, (forall l, P l \/ ~ P l) -> - infinite_from P [] -> has_infinite_path P. -Proof. -intros P Hdec Hinf. -apply inductively_barred_at_is_path_from_decidable in Hdec. -apply PreWeakKonigsLemma; assumption. -Qed. diff --git a/stdlib/theories/Logic/WeakFan.v b/stdlib/theories/Logic/WeakFan.v deleted file mode 100644 index 21d57922f852..000000000000 --- a/stdlib/theories/Logic/WeakFan.v +++ /dev/null @@ -1,104 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* Prop := -| now l : P l -> inductively_barred P l -| propagate l : - inductively_barred P (true::l) -> - inductively_barred P (false::l) -> - inductively_barred P l. - -(** [approx X l] says that [l] is a boolean representation of a prefix of [X] *) - -Fixpoint approx X (l:list bool) := - match l with - | [] => True - | b::l => approx X l /\ (if b then X (length l) else ~ X (length l)) - end. - -(** [barred P] means that for any infinite path represented as a predicate, - the property [P] holds for some prefix of the path *) - -Definition barred P := - forall (X:nat -> Prop), exists l, approx X l /\ P l. - -(** The proof proceeds by building a set [Y] of finite paths - approximating either the smallest unbarred infinite path in [P], if - there is one (taking [true]>[false]), or the path [true::true::...] - if [P] happens to be inductively_barred *) - -Fixpoint Y P (l:list bool) := - match l with - | [] => True - | b::l => - Y P l /\ - if b then inductively_barred P (false::l) else ~ inductively_barred P (false::l) - end. - -Lemma Y_unique : forall P l1 l2, length l1 = length l2 -> Y P l1 -> Y P l2 -> l1 = l2. -Proof. -induction l1, l2. -- trivial. -- discriminate. -- discriminate. -- intros H (HY1,H1) (HY2,H2). - injection H as [= H]. - pose proof (IHl1 l2 H HY1 HY2). clear HY1 HY2 H IHl1. - subst l1. - f_equal. - destruct a, b; firstorder. -Qed. - -(** [X] is the translation of [Y] as a predicate *) - -Definition X P n := exists l, length l = n /\ Y P (true::l). - -Lemma Y_approx : forall P l, approx (X P) l -> Y P l. -Proof. -induction l. -- trivial. -- intros (H,Hb). split. - + auto. - + unfold X in Hb. - destruct a. - * destruct Hb as (l',(Hl',(HYl',HY))). - rewrite <- (Y_unique P l' l Hl'); auto. - * firstorder. -Qed. - -Theorem WeakFanTheorem : forall P, barred P -> inductively_barred P []. -Proof. -intros P Hbar. -destruct Hbar with (X P) as (l,(Hd%Y_approx,HP)). -assert (inductively_barred P l) by (apply (now P l), HP). -clear Hbar HP. -induction l as [|a l]. -- assumption. -- destruct Hd as (Hd,HX). - apply (IHl Hd). clear IHl. - destruct a; unfold X in HX; simpl in HX. - + apply propagate; assumption. - + exfalso; destruct (HX H). -Qed. diff --git a/stdlib/theories/MSets/MSetAVL.v b/stdlib/theories/MSets/MSetAVL.v deleted file mode 100644 index c06b903f7495..000000000000 --- a/stdlib/theories/MSets/MSetAVL.v +++ /dev/null @@ -1,1040 +0,0 @@ -(* -*- coding: utf-8 -*- *) -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* 0 - | Node h _ _ _ => h - end. - -(** ** Singleton set *) - -Definition singleton x := Node 1 Leaf x Leaf. - -(** ** Helper functions *) - -(** [create l x r] creates a node, assuming [l] and [r] - to be balanced and [|height l - height r| <= 2]. *) - -Definition create l x r := - Node (max (height l) (height r) + 1) l x r. - -(** [bal l x r] acts as [create], but performs one step of - rebalancing if necessary, i.e. assumes [|height l - height r| <= 3]. *) - -Definition assert_false := create. - -Definition bal l x r := - let hl := height l in - let hr := height r in - if (hr+2) assert_false l x r - | Node _ ll lx lr => - if (height lr) <=? (height ll) then - create ll lx (create lr x r) - else - match lr with - | Leaf => assert_false l x r - | Node _ lrl lrx lrr => - create (create ll lx lrl) lrx (create lrr x r) - end - end - else - if (hl+2) assert_false l x r - | Node _ rl rx rr => - if (height rl) <=? (height rr) then - create (create l x rl) rx rr - else - match rl with - | Leaf => assert_false l x r - | Node _ rll rlx rlr => - create (create l x rll) rlx (create rlr rx rr) - end - end - else - create l x r. - -(** ** Insertion *) - -Fixpoint add x s := match s with - | Leaf => Node 1 Leaf x Leaf - | Node h l y r => - match X.compare x y with - | Lt => bal (add x l) y r - | Eq => Node h l y r - | Gt => bal l y (add x r) - end - end. - -(** ** Join - - Same as [bal] but does not assume anything regarding heights - of [l] and [r]. -*) - -Fixpoint join l : elt -> t -> t := - match l with - | Leaf => add - | Node lh ll lx lr => fun x => - fix join_aux (r:t) : t := match r with - | Leaf => add x l - | Node rh rl rx rr => - if (rh+2) (r,x) - | Node lh ll lx lr => - let (l',m) := remove_min ll lx lr in (bal l' x r, m) - end. - -(** ** Merging two trees - - [merge t1 t2] builds the union of [t1] and [t2] assuming all elements - of [t1] to be smaller than all elements of [t2], and - [|height t1 - height t2| <= 2]. -*) - -Definition merge s1 s2 := match s1,s2 with - | Leaf, _ => s2 - | _, Leaf => s1 - | _, Node _ l2 x2 r2 => - let (s2',m) := remove_min l2 x2 r2 in bal s1 m s2' -end. - -(** ** Deletion *) - -Fixpoint remove x s := match s with - | Leaf => Leaf - | Node _ l y r => - match X.compare x y with - | Lt => bal (remove x l) y r - | Eq => merge l r - | Gt => bal l y (remove x r) - end - end. - -(** ** Concatenation - - Same as [merge] but does not assume anything about heights. -*) - -Definition concat s1 s2 := - match s1, s2 with - | Leaf, _ => s2 - | _, Leaf => s1 - | _, Node _ l2 x2 r2 => - let (s2',m) := remove_min l2 x2 r2 in - join s1 m s2' - end. - -(** ** Splitting - - [split x s] returns a triple [(l, present, r)] where - - [l] is the set of elements of [s] that are [< x] - - [r] is the set of elements of [s] that are [> x] - - [present] is [true] if and only if [s] contains [x]. -*) - -Record triple := mktriple { t_left:t; t_in:bool; t_right:t }. -Notation "<< l , b , r >>" := (mktriple l b r) (at level 9). - -Fixpoint split x s : triple := match s with - | Leaf => << Leaf, false, Leaf >> - | Node _ l y r => - match X.compare x y with - | Lt => let (ll,b,rl) := split x l in << ll, b, join rl y r >> - | Eq => << l, true, r >> - | Gt => let (rl,b,rr) := split x r in << join l y rl, b, rr >> - end - end. - -(** ** Intersection *) - -Fixpoint inter s1 s2 := match s1, s2 with - | Leaf, _ => Leaf - | _, Leaf => Leaf - | Node _ l1 x1 r1, _ => - let (l2',pres,r2') := split x1 s2 in - if pres then join (inter l1 l2') x1 (inter r1 r2') - else concat (inter l1 l2') (inter r1 r2') - end. - -(** ** Difference *) - -Fixpoint diff s1 s2 := match s1, s2 with - | Leaf, _ => Leaf - | _, Leaf => s1 - | Node _ l1 x1 r1, _ => - let (l2',pres,r2') := split x1 s2 in - if pres then concat (diff l1 l2') (diff r1 r2') - else join (diff l1 l2') x1 (diff r1 r2') -end. - -(** ** Union *) - -(** In ocaml, heights of [s1] and [s2] are compared each time in order - to recursively perform the split on the smaller set. - Unfortunately, this leads to a non-structural algorithm. The - following code is a simplification of the ocaml version: no - comparison of heights. It might be slightly slower, but - experimentally all the tests I've made in ocaml have shown this - potential slowdown to be non-significant. Anyway, the exact code - of ocaml has also been formalized thanks to Function+measure, see - [ocaml_union] in [MSetFullAVL]. -*) - -Fixpoint union s1 s2 := - match s1, s2 with - | Leaf, _ => s2 - | _, Leaf => s1 - | Node _ l1 x1 r1, _ => - let (l2',_,r2') := split x1 s2 in - join (union l1 l2') x1 (union r1 r2') - end. - -(** ** Filter *) - -Fixpoint filter (f:elt->bool) s := match s with - | Leaf => Leaf - | Node _ l x r => - let l' := filter f l in - let r' := filter f r in - if f x then join l' x r' else concat l' r' - end. - -(** ** Partition *) - -Fixpoint partition (f:elt->bool)(s : t) : t*t := - match s with - | Leaf => (Leaf, Leaf) - | Node _ l x r => - let (l1,l2) := partition f l in - let (r1,r2) := partition f r in - if f x then (join l1 x r1, concat l2 r2) - else (concat l1 r1, join l2 x r2) - end. - -End Ops. - - -(** * MakeRaw - - Functor of pure functions + a posteriori proofs of invariant - preservation *) - -Module MakeRaw (Import I:Int)(X:OrderedType) <: RawSets X. -Include Ops I X. - -(** Generic definition of binary-search-trees and proofs of - specifications for generic functions such as mem or fold. *) - -Include MSetGenTree.Props X I. - -(** Automation and dedicated tactics *) - -Local Hint Immediate MX.eq_sym : core. -Local Hint Unfold In lt_tree gt_tree Ok : core. -Local Hint Constructors InT bst : core. -Local Hint Resolve MX.eq_refl MX.eq_trans MX.lt_trans ok : core. -Local Hint Resolve lt_leaf gt_leaf lt_tree_node gt_tree_node : core. -Local Hint Resolve lt_tree_not_in lt_tree_trans gt_tree_not_in gt_tree_trans : core. -Local Hint Resolve elements_spec2 : core. - -(* Sometimes functional induction will expose too much of - a tree structure. The following tactic allows factoring back - a Node whose internal parts occurs nowhere else. *) - -(* TODO: why Ltac instead of Tactic Notation don't work ? why clear ? *) - -Tactic Notation "factornode" ident(s) := - try clear s; - match goal with - | |- context [Node ?l ?x ?r ?h] => - set (s:=Node l x r h) in *; clearbody s; clear l x r h - | _ : context [Node ?l ?x ?r ?h] |- _ => - set (s:=Node l x r h) in *; clearbody s; clear l x r h - end. - -(** Inductions principles for some of the set operators *) - -#[local] Ltac caseq := -match goal with [ |- context [match ?t with _ => _ end] ] => - let cmp := fresh in - let H := fresh in - remember t as cmp eqn:H; symmetry in H; destruct cmp -end. - -Lemma bal_ind [P : t -> X.t -> t -> tree -> Prop] : - (forall (l : t) (x : X.t) (r : t), - let hl := height l in - let hr := height r in (hr + 2 l = Leaf -> P Leaf x r (assert_false l x r)) -> - (forall (l : t) (x : X.t) (r : t), - let hl := height l in - let hr := height r in - (hr + 2 - forall (_x : I.t) (ll : tree) (lx : X.t) (lr : tree), - l = Node _x ll lx lr -> - (height lr <=? height ll) = true -> P (Node _x ll lx lr) x r (create ll lx (create lr x r))) -> - (forall (l : t) (x : X.t) (r : t), - let hl := height l in - let hr := height r in - (hr + 2 - forall (_x : I.t) (ll : tree) (lx : X.t) (lr : tree), - l = Node _x ll lx lr -> - (height lr <=? height ll) = false -> - lr = Leaf -> P (Node _x ll lx Leaf) x r (assert_false l x r)) -> - (forall (l : t) (x : X.t) (r : t), - let hl := height l in - let hr := height r in - (hr + 2 - forall (_x : I.t) (ll : tree) (lx : X.t) (lr : tree), - l = Node _x ll lx lr -> - (height lr <=? height ll) = false -> - forall (_x0 : I.t) (lrl : tree) (lrx : X.t) (lrr : tree), - lr = Node _x0 lrl lrx lrr -> - P (Node _x ll lx (Node _x0 lrl lrx lrr)) x r (create (create ll lx lrl) lrx (create lrr x r))) -> - (forall (l : t) (x : X.t) (r : t), - let hl := height l in - let hr := height r in - (hr + 2 - (hl + 2 r = Leaf -> P l x Leaf (assert_false l x r)) -> - (forall (l : t) (x : X.t) (r : t), - let hl := height l in - let hr := height r in - (hr + 2 - (hl + 2 - forall (_x : I.t) (rl : tree) (rx : X.t) (rr : tree), - r = Node _x rl rx rr -> - (height rl <=? height rr) = true -> P l x (Node _x rl rx rr) (create (create l x rl) rx rr)) -> - (forall (l : t) (x : X.t) (r : t), - let hl := height l in - let hr := height r in - (hr + 2 - (hl + 2 - forall (_x : I.t) (rl : tree) (rx : X.t) (rr : tree), - r = Node _x rl rx rr -> - (height rl <=? height rr) = false -> - rl = Leaf -> P l x (Node _x Leaf rx rr) (assert_false l x r)) -> - (forall (l : t) (x : X.t) (r : t), - let hl := height l in - let hr := height r in - (hr + 2 - (hl + 2 - forall (_x : I.t) (rl : tree) (rx : X.t) (rr : tree), - r = Node _x rl rx rr -> - (height rl <=? height rr) = false -> - forall (_x0 : I.t) (rll : tree) (rlx : X.t) (rlr : tree), - rl = Node _x0 rll rlx rlr -> - P l x (Node _x (Node _x0 rll rlx rlr) rx rr) (create (create l x rll) rlx (create rlr rx rr))) -> - (forall (l : t) (x : X.t) (r : t), - let hl := height l in - let hr := height r in - (hr + 2 (hl + 2 P l x r (create l x r)) -> - forall (l : t) (x : X.t) (r : t), P l x r (bal l x r). -Proof. -intros; unfold bal; repeat caseq; eauto. -Qed. - -Lemma remove_min_ind [P : tree -> elt -> t -> t * elt -> Prop] : - (forall (l : tree) (x : elt) (r : t), l = Leaf -> P Leaf x r (r, x)) -> - (forall (l : tree) (x : elt) (r : t) (_x : I.t) (ll : tree) (lx : X.t) (lr : tree), - l = Node _x ll lx lr -> - P ll lx lr (remove_min ll lx lr) -> - forall (l' : t) (m : elt), - remove_min ll lx lr = (l', m) -> P (Node _x ll lx lr) x r (bal l' x r, m)) -> - forall (l : tree) (x : elt) (r : t), P l x r (remove_min l x r). -Proof. -induction l; cbn; repeat caseq; eauto. -Qed. - -Lemma merge_ind [P : tree -> tree -> tree -> Prop] : - (forall s1 s2 : tree, s1 = Leaf -> P Leaf s2 s2) -> - (forall (s1 s2 : tree) (_x : I.t) (_x0 : tree) (_x1 : X.t) (_x2 : tree), - s1 = Node _x _x0 _x1 _x2 -> s2 = Leaf -> P (Node _x _x0 _x1 _x2) Leaf s1) -> - (forall (s1 s2 : tree) (_x : I.t) (_x0 : tree) (_x1 : X.t) (_x2 : tree), - s1 = Node _x _x0 _x1 _x2 -> - forall (_x3 : I.t) (l2 : tree) (x2 : X.t) (r2 : tree), - s2 = Node _x3 l2 x2 r2 -> - forall (s2' : t) (m : elt), - remove_min l2 x2 r2 = (s2', m) -> P (Node _x _x0 _x1 _x2) (Node _x3 l2 x2 r2) (bal s1 m s2')) -> - forall s1 s2 : tree, P s1 s2 (merge s1 s2). -Proof. -intros; unfold merge; repeat caseq; eauto. -Qed. - -Lemma concat_ind [P : tree -> tree -> tree -> Prop] : - (forall s1 s2 : tree, s1 = Leaf -> P Leaf s2 s2) -> - (forall (s1 s2 : tree) (_x : I.t) (_x0 : tree) (_x1 : X.t) (_x2 : tree), - s1 = Node _x _x0 _x1 _x2 -> s2 = Leaf -> P (Node _x _x0 _x1 _x2) Leaf s1) -> - (forall (s1 s2 : tree) (_x : I.t) (_x0 : tree) (_x1 : X.t) (_x2 : tree), - s1 = Node _x _x0 _x1 _x2 -> - forall (_x3 : I.t) (l2 : tree) (x2 : X.t) (r2 : tree), - s2 = Node _x3 l2 x2 r2 -> - forall (s2' : t) (m : elt), - remove_min l2 x2 r2 = (s2', m) -> P (Node _x _x0 _x1 _x2) (Node _x3 l2 x2 r2) (join s1 m s2')) -> - forall s1 s2 : tree, P s1 s2 (concat s1 s2). -Proof. -intros; unfold concat; repeat caseq; eauto. -Qed. - -Lemma inter_ind [P : tree -> tree -> tree -> Prop] : - (forall s1 s2 : tree, s1 = Leaf -> P Leaf s2 Leaf) -> - (forall (s1 s2 : tree) (_x : I.t) (l1 : tree) (x1 : X.t) (r1 : tree), - s1 = Node _x l1 x1 r1 -> s2 = Leaf -> P (Node _x l1 x1 r1) Leaf Leaf) -> - (forall (s1 s2 : tree) (_x : I.t) (l1 : tree) (x1 : X.t) (r1 : tree), - s1 = Node _x l1 x1 r1 -> - forall (_x0 : I.t) (_x1 : tree) (_x2 : X.t) (_x3 : tree), - s2 = Node _x0 _x1 _x2 _x3 -> - forall (l2' : t) (pres : bool) (r2' : t), - split x1 s2 = << l2', pres, r2' >> -> - pres = true -> - P l1 l2' (inter l1 l2') -> - P r1 r2' (inter r1 r2') -> - P (Node _x l1 x1 r1) (Node _x0 _x1 _x2 _x3) (join (inter l1 l2') x1 (inter r1 r2'))) -> - (forall (s1 s2 : tree) (_x : I.t) (l1 : tree) (x1 : X.t) (r1 : tree), - s1 = Node _x l1 x1 r1 -> - forall (_x0 : I.t) (_x1 : tree) (_x2 : X.t) (_x3 : tree), - s2 = Node _x0 _x1 _x2 _x3 -> - forall (l2' : t) (pres : bool) (r2' : t), - split x1 s2 = << l2', pres, r2' >> -> - pres = false -> - P l1 l2' (inter l1 l2') -> - P r1 r2' (inter r1 r2') -> - P (Node _x l1 x1 r1) (Node _x0 _x1 _x2 _x3) (concat (inter l1 l2') (inter r1 r2'))) -> - forall s1 s2 : tree, P s1 s2 (inter s1 s2). -Proof. -induction s1; cbn; intros; repeat caseq; eauto. -Qed. - -Lemma diff_ind [P : tree -> tree -> tree -> Prop] : - (forall s1 s2 : tree, s1 = Leaf -> P Leaf s2 Leaf) -> - (forall (s1 s2 : tree) (_x : I.t) (l1 : tree) (x1 : X.t) (r1 : tree), - s1 = Node _x l1 x1 r1 -> s2 = Leaf -> P (Node _x l1 x1 r1) Leaf s1) -> - (forall (s1 s2 : tree) (_x : I.t) (l1 : tree) (x1 : X.t) (r1 : tree), - s1 = Node _x l1 x1 r1 -> - forall (_x0 : I.t) (_x1 : tree) (_x2 : X.t) (_x3 : tree), - s2 = Node _x0 _x1 _x2 _x3 -> - forall (l2' : t) (pres : bool) (r2' : t), - split x1 s2 = << l2', pres, r2' >> -> - pres = true -> - P l1 l2' (diff l1 l2') -> - P r1 r2' (diff r1 r2') -> - P (Node _x l1 x1 r1) (Node _x0 _x1 _x2 _x3) (concat (diff l1 l2') (diff r1 r2'))) -> - (forall (s1 s2 : tree) (_x : I.t) (l1 : tree) (x1 : X.t) (r1 : tree), - s1 = Node _x l1 x1 r1 -> - forall (_x0 : I.t) (_x1 : tree) (_x2 : X.t) (_x3 : tree), - s2 = Node _x0 _x1 _x2 _x3 -> - forall (l2' : t) (pres : bool) (r2' : t), - split x1 s2 = << l2', pres, r2' >> -> - pres = false -> - P l1 l2' (diff l1 l2') -> - P r1 r2' (diff r1 r2') -> - P (Node _x l1 x1 r1) (Node _x0 _x1 _x2 _x3) (join (diff l1 l2') x1 (diff r1 r2'))) -> - forall s1 s2 : tree, P s1 s2 (diff s1 s2). -Proof. -induction s1; cbn; intros; repeat caseq; eauto. -Qed. - -Lemma union_ind [P : tree -> tree -> tree -> Prop] : - (forall s1 s2 : tree, s1 = Leaf -> P Leaf s2 s2) -> - (forall (s1 s2 : tree) (_x : I.t) (l1 : tree) (x1 : X.t) (r1 : tree), - s1 = Node _x l1 x1 r1 -> s2 = Leaf -> P (Node _x l1 x1 r1) Leaf s1) -> - (forall (s1 s2 : tree) (_x : I.t) (l1 : tree) (x1 : X.t) (r1 : tree), - s1 = Node _x l1 x1 r1 -> - forall (_x0 : I.t) (_x1 : tree) (_x2 : X.t) (_x3 : tree), - s2 = Node _x0 _x1 _x2 _x3 -> - forall (l2' : t) (_x4 : bool) (r2' : t), - split x1 s2 = << l2', _x4, r2' >> -> - P l1 l2' (union l1 l2') -> - P r1 r2' (union r1 r2') -> - P (Node _x l1 x1 r1) (Node _x0 _x1 _x2 _x3) (join (union l1 l2') x1 (union r1 r2'))) -> - forall s1 s2 : tree, P s1 s2 (union s1 s2). -Proof. -induction s1; cbn; intros; repeat caseq; eauto. -Qed. - -(** Notations and helper lemma about pairs and triples *) - -Declare Scope pair_scope. - -Notation "s #1" := (fst s) (at level 9, format "s '#1'") : pair_scope. -Notation "s #2" := (snd s) (at level 9, format "s '#2'") : pair_scope. -Notation "t #l" := (t_left t) (at level 9, format "t '#l'") : pair_scope. -Notation "t #b" := (t_in t) (at level 9, format "t '#b'") : pair_scope. -Notation "t #r" := (t_right t) (at level 9, format "t '#r'") : pair_scope. - -Local Open Scope pair_scope. - -(** ** Singleton set *) - -Lemma singleton_spec : forall x y, InT y (singleton x) <-> X.eq y x. -Proof. - unfold singleton; intuition_in. -Qed. - -#[global] -Instance singleton_ok x : Ok (singleton x). -Proof. - unfold singleton; auto. -Qed. - -(** ** Helper functions *) - -Lemma create_spec : - forall l x r y, InT y (create l x r) <-> X.eq y x \/ InT y l \/ InT y r. -Proof. - unfold create; split; [ inversion_clear 1 | ]; intuition. -Qed. - -#[global] -Instance create_ok l x r `(Ok l, Ok r, lt_tree x l, gt_tree x r) : - Ok (create l x r). -Proof. - unfold create; auto. -Qed. - -Lemma bal_spec : forall l x r y, - InT y (bal l x r) <-> X.eq y x \/ InT y l \/ InT y r. -Proof. - intros l x r; induction l, x, r, (bal l x r) using bal_ind; subst; intros; try clear e0; - rewrite !create_spec; intuition_in. -Qed. - -#[global] -Instance bal_ok l x r `(Ok l, Ok r, lt_tree x l, gt_tree x r) : - Ok (bal l x r). -Proof. - induction l, x, r, (bal l x r) using bal_ind; subst; intros; - inv; repeat apply create_ok; auto; unfold create; - (apply lt_tree_node || apply gt_tree_node); auto; - (eapply lt_tree_trans || eapply gt_tree_trans); eauto. -Qed. - - -(** ** Insertion *) - -Lemma add_spec' : forall s x y, - InT y (add x s) <-> X.eq y x \/ InT y s. -Proof. - induct s x; try rewrite ?bal_spec, ?IHl, ?IHr; intuition_in. - setoid_replace y with x'; eauto. -Qed. - -Lemma add_spec : forall s x y `{Ok s}, - InT y (add x s) <-> X.eq y x \/ InT y s. -Proof. intros; apply add_spec'. Qed. - -#[global] -Instance add_ok s x `(Ok s) : Ok (add x s). -Proof. - induct s x; auto; apply bal_ok; auto; - intros y; rewrite add_spec'; intuition; order. -Qed. - - -Local Open Scope Int_scope. - -(** ** Join *) - -(** Function/Functional Scheme can't deal with internal fix. - Let's do its job by hand: *) - -Ltac join_tac := - let l := fresh "l" in - intro l; induction l as [| lh ll _ lx lr Hlr]; - [ | intros x r; induction r as [| rh rl Hrl rx rr _]; unfold join; - [ | destruct ((rh+2) - replace (bal a b c) - with (bal ll lx (join lr x (Node rh rl rx rr))); [ | auto] - end - | destruct ((lh+2) - replace (bal a b c) - with (bal (join (Node lh ll lx lr) x rl) rx rr); [ | auto] - end - | ] ] ] ]; intros. - -Lemma join_spec : forall l x r y, - InT y (join l x r) <-> X.eq y x \/ InT y l \/ InT y r. -Proof. - join_tac. - - simpl. - rewrite add_spec'; intuition_in. - - rewrite add_spec'; intuition_in. - - rewrite bal_spec, Hlr; clear Hlr Hrl; intuition_in. - - rewrite bal_spec, Hrl; clear Hlr Hrl; intuition_in. - - apply create_spec. -Qed. - -#[global] -Instance join_ok : forall l x r `(Ok l, Ok r, lt_tree x l, gt_tree x r), - Ok (join l x r). -Proof. - join_tac; auto with *; inv; apply bal_ok; auto; - clear Hrl Hlr; intro; intros; rewrite join_spec in *. - - intuition; [ setoid_replace y with x | ]; eauto. - - intuition; [ setoid_replace y with x | ]; eauto. -Qed. - - -(** ** Extraction of minimum element *) - -Lemma remove_min_spec : forall l x r y h, - InT y (Node h l x r) <-> - X.eq y (remove_min l x r)#2 \/ InT y (remove_min l x r)#1. -Proof. - intros l x r; induction l, x, r, (remove_min l x r) using remove_min_ind; subst; simpl in *; intros. - - intuition_in. - - rewrite bal_spec, In_node_iff, IHp, H0; simpl; intuition. -Qed. - -#[global] -Instance remove_min_ok l x r : forall h `(Ok (Node h l x r)), - Ok (remove_min l x r)#1. -Proof. - induction l, x, r, (remove_min l x r) using remove_min_ind; subst; simpl; intros. - - inv; auto. - - assert (O : Ok (Node _x ll lx lr)) by (inv; auto). - assert (L : lt_tree x (Node _x ll lx lr)) by (inv; auto). - specialize IHp with (1:=O); rewrite H0 in IHp; auto; simpl in *. - apply bal_ok; auto. - + inv; auto. - + intro y; specialize (L y). - rewrite remove_min_spec, H0 in L; simpl in L; intuition. - + inv; auto. -Qed. - -Lemma remove_min_gt_tree : forall l x r h `{Ok (Node h l x r)}, - gt_tree (remove_min l x r)#2 (remove_min l x r)#1. -Proof. - intros l x r; induction l, x, r, (remove_min l x r) using remove_min_ind; subst; simpl; intros. - - inv; auto. - - assert (O : Ok (Node _x ll lx lr)) by (inv; auto). - assert (L : lt_tree x (Node _x ll lx lr)) by (inv; auto). - specialize IHp with (1:=O); rewrite H0 in IHp; simpl in IHp. - intro y; rewrite bal_spec; intuition; - specialize (L m); rewrite remove_min_spec, H0 in L; simpl in L; - [setoid_replace y with x|inv]; eauto. -Qed. -Local Hint Resolve remove_min_gt_tree : core. - - -(** ** Merging two trees *) - -Lemma merge_spec : forall s1 s2 y, - InT y (merge s1 s2) <-> InT y s1 \/ InT y s2. -Proof. - intros s1 s2; induction s1, s2, (merge s1 s2) using merge_ind; subst; intros; - try factornode s1. - - intuition_in. - - intuition_in. - - rewrite bal_spec, remove_min_spec, H1; simpl; intuition. -Qed. - -#[global] -Instance merge_ok s1 s2 : forall `(Ok s1, Ok s2) - `(forall y1 y2 : elt, InT y1 s1 -> InT y2 s2 -> X.lt y1 y2), - Ok (merge s1 s2). -Proof. - induction s1, s2, (merge s1 s2) using merge_ind; subst; intros; auto; - try factornode s1. - apply bal_ok; auto. - - change s2' with ((s2',m)#1); rewrite <- H1; eauto with *. - - intros y Hy. - apply H2; auto. - rewrite remove_min_spec, H1; simpl; auto. - - change (gt_tree (s2',m)#2 (s2',m)#1); rewrite <- H1; eauto. -Qed. - - - -(** ** Deletion *) - -Lemma remove_spec : forall s x y `{Ok s}, - (InT y (remove x s) <-> InT y s /\ ~ X.eq y x). -Proof. - induct s x. - - intuition_in. - - rewrite merge_spec; intuition; [order|order|intuition_in]. - elim H2; eauto. - - rewrite bal_spec, IHl; clear IHl IHr; intuition; [order|order|intuition_in]. - - rewrite bal_spec, IHr; clear IHl IHr; intuition; [order|order|intuition_in]. -Qed. - -#[global] -Instance remove_ok s x `(Ok s) : Ok (remove x s). -Proof. - induct s x. - - auto. - - (* EQ *) - apply merge_ok; eauto. - - (* LT *) - apply bal_ok; auto. - intro z; rewrite remove_spec; auto; destruct 1; eauto. - - (* GT *) - apply bal_ok; auto. - intro z; rewrite remove_spec; auto; destruct 1; eauto. -Qed. - - -(** ** Concatenation *) - -Lemma concat_spec : forall s1 s2 y, - InT y (concat s1 s2) <-> InT y s1 \/ InT y s2. -Proof. - intros s1 s2; induction s1, s2, (concat s1 s2) using concat_ind; subst; intros; - try factornode s1. - - intuition_in. - - intuition_in. - - rewrite join_spec, remove_min_spec, H1; simpl; intuition. -Qed. - -#[global] -Instance concat_ok s1 s2 : forall `(Ok s1, Ok s2) - `(forall y1 y2 : elt, InT y1 s1 -> InT y2 s2 -> X.lt y1 y2), - Ok (concat s1 s2). -Proof. - induction s1, s2, (concat s1 s2) using concat_ind; subst; intros; auto; - try factornode s1. - apply join_ok; auto. - - change (Ok (s2',m)#1); rewrite <- H1; eauto with *. - - intros y Hy. - apply H2; auto. - rewrite remove_min_spec, H1; simpl; auto. - - change (gt_tree (s2',m)#2 (s2',m)#1); rewrite <- H1; eauto. -Qed. - - - -(** ** Splitting *) - -Lemma split_spec1 : forall s x y `{Ok s}, - (InT y (split x s)#l <-> InT y s /\ X.lt y x). -Proof. - induct s x. - - intuition_in. - - intuition_in; order. - - specialize (IHl x y). - destruct (split x l); simpl in *. rewrite IHl; intuition_in; order. - - specialize (IHr x y). - destruct (split x r); simpl in *. rewrite join_spec, IHr; intuition_in; order. -Qed. - -Lemma split_spec2 : forall s x y `{Ok s}, - (InT y (split x s)#r <-> InT y s /\ X.lt x y). -Proof. - induct s x. - - intuition_in. - - intuition_in; order. - - specialize (IHl x y). - destruct (split x l); simpl in *. rewrite join_spec, IHl; intuition_in; order. - - specialize (IHr x y). - destruct (split x r); simpl in *. rewrite IHr; intuition_in; order. -Qed. - -Lemma split_spec3 : forall s x `{Ok s}, - ((split x s)#b = true <-> InT x s). -Proof. - induct s x. - - intuition_in; try discriminate. - - intuition. - - specialize (IHl x). - destruct (split x l); simpl in *. rewrite IHl; intuition_in; order. - - specialize (IHr x). - destruct (split x r); simpl in *. rewrite IHr; intuition_in; order. -Qed. - -Lemma split_ok : forall s x `{Ok s}, Ok (split x s)#l /\ Ok (split x s)#r. -Proof. - induct s x; simpl; auto. - - specialize (IHl x). - generalize (fun y => @split_spec2 l x y _). - destruct (split x l); simpl in *; intuition. apply join_ok; auto. - intros y; rewrite H; intuition. - - specialize (IHr x). - generalize (fun y => @split_spec1 r x y _). - destruct (split x r); simpl in *; intuition. apply join_ok; auto. - intros y; rewrite H; intuition. -Qed. - -#[global] -Instance split_ok1 s x `(Ok s) : Ok (split x s)#l. -Proof. intros; destruct (@split_ok s x); auto. Qed. - -#[global] -Instance split_ok2 s x `(Ok s) : Ok (split x s)#r. -Proof. intros; destruct (@split_ok s x); auto. Qed. - - -(** ** Intersection *) - -Ltac destruct_split := match goal with - | H : split ?x ?s = << ?u, ?v, ?w >> |- _ => - assert ((split x s)#l = u) by (rewrite H; auto); - assert ((split x s)#b = v) by (rewrite H; auto); - assert ((split x s)#r = w) by (rewrite H; auto); - clear H; subst u w - end. - -Lemma inter_spec_ok : forall s1 s2 `{Ok s1, Ok s2}, - Ok (inter s1 s2) /\ (forall y, InT y (inter s1 s2) <-> InT y s1 /\ InT y s2). -Proof. - intros s1 s2; induction s1, s2, (inter s1 s2) using inter_ind; subst; intros B1 B2; - [intuition_in|intuition_in | | ]; factornode s2; - destruct_split; inv; - destruct IHt0 as (IHo1,IHi1), IHt1 as (IHo2,IHi2); auto with *; - split; intros. - - (* Ok join *) - apply join_ok; auto with *; intro y; rewrite ?IHi1, ?IHi2; intuition. - - (* InT join *) - rewrite join_spec, IHi1, IHi2, split_spec1, split_spec2; intuition_in. - setoid_replace y with x1; auto. rewrite <- split_spec3; auto. - - (* Ok concat *) - apply concat_ok; auto with *; intros y1 y2; rewrite IHi1, IHi2; - intuition; order. - - (* InT concat *) - rewrite concat_spec, IHi1, IHi2, split_spec1, split_spec2; auto. - intuition_in. - absurd (InT x1 s2). - + rewrite <- split_spec3; auto; congruence. - + setoid_replace x1 with y; auto. -Qed. - -Lemma inter_spec : forall s1 s2 y `{Ok s1, Ok s2}, - (InT y (inter s1 s2) <-> InT y s1 /\ InT y s2). -Proof. intros; destruct (@inter_spec_ok s1 s2); auto. Qed. - -#[global] -Instance inter_ok s1 s2 `(Ok s1, Ok s2) : Ok (inter s1 s2). -Proof. intros; destruct (@inter_spec_ok s1 s2); auto. Qed. - - -(** ** Difference *) - -Lemma diff_spec_ok : forall s1 s2 `{Ok s1, Ok s2}, - Ok (diff s1 s2) /\ (forall y, InT y (diff s1 s2) <-> InT y s1 /\ ~InT y s2). -Proof. - intros s1 s2; induction s1, s2, (diff s1 s2) using diff_ind; subst; intros B1 B2; - [intuition_in|intuition_in | | ]; factornode s2; - destruct_split; inv; - destruct IHt0 as (IHb1,IHi1), IHt1 as (IHb2,IHi2); auto with *; - split; intros. - - (* Ok concat *) - apply concat_ok; auto; intros y1 y2; rewrite IHi1, IHi2; intuition; order. - - (* InT concat *) - rewrite concat_spec, IHi1, IHi2, split_spec1, split_spec2; intuition_in. - absurd (InT x1 s2). - + setoid_replace x1 with y; auto. - + rewrite <- split_spec3; auto; congruence. - - (* Ok join *) - apply join_ok; auto; intro y; rewrite ?IHi1, ?IHi2; intuition. - - (* InT join *) - rewrite join_spec, IHi1, IHi2, split_spec1, split_spec2; auto with *. - intuition_in. - absurd (InT x1 s2); auto. - * rewrite <- split_spec3; auto; congruence. - * setoid_replace x1 with y; auto. -Qed. - -Lemma diff_spec : forall s1 s2 y `{Ok s1, Ok s2}, - (InT y (diff s1 s2) <-> InT y s1 /\ ~InT y s2). -Proof. intros; destruct (@diff_spec_ok s1 s2); auto. Qed. - -#[global] -Instance diff_ok s1 s2 `(Ok s1, Ok s2) : Ok (diff s1 s2). -Proof. intros; destruct (@diff_spec_ok s1 s2); auto. Qed. - - -(** ** Union *) - -Lemma union_spec : forall s1 s2 y `{Ok s1, Ok s2}, - (InT y (union s1 s2) <-> InT y s1 \/ InT y s2). -Proof. - intros s1 s2; induction s1, s2, (union s1 s2) using union_ind; subst; intros y B1 B2. - - intuition_in. - - intuition_in. - - factornode s2; destruct_split; inv. - rewrite join_spec, IHt0, IHt1, split_spec1, split_spec2; auto with *. - destruct (X.compare_spec y x1); intuition_in. -Qed. - -#[global] -Instance union_ok s1 s2 : forall `(Ok s1, Ok s2), Ok (union s1 s2). -Proof. - induction s1, s2, (union s1 s2) using union_ind; subst; intros B1 B2; auto. - factornode s2; destruct_split; inv. - apply join_ok; auto with *. - - intro y; rewrite union_spec, split_spec1; intuition_in; exact _. - - intro y; rewrite union_spec, split_spec2; intuition_in; exact _. -Qed. - -(** * Filter *) - -Lemma filter_spec : forall s x f, - Proper (X.eq==>Logic.eq) f -> - (InT x (filter f s) <-> InT x s /\ f x = true). -Proof. - induction s as [ |h l Hl x0 r Hr]; intros x f Hf; simpl. - - intuition_in. - - case_eq (f x0); intros Hx0. - * rewrite join_spec, Hl, Hr; intuition_in. - now setoid_replace x with x0. - * rewrite concat_spec, Hl, Hr; intuition_in. - assert (f x = f x0) by auto. congruence. -Qed. - -Lemma filter_weak_spec : forall s x f, - InT x (filter f s) -> InT x s. -Proof. - induction s as [ |h l Hl x0 r Hr]; intros x f; simpl. - - trivial. - - destruct (f x0). - * rewrite join_spec; intuition_in; eauto. - * rewrite concat_spec; intuition_in; eauto. -Qed. - -#[global] -Instance filter_ok s f `(H : Ok s) : Ok (filter f s). -Proof. - induction H as [ | h x l r Hl Hfl Hr Hfr Hlt Hgt ]. - - constructor. - - simpl. - assert (lt_tree x (filter f l)) by (eauto using filter_weak_spec). - assert (gt_tree x (filter f r)) by (eauto using filter_weak_spec). - destruct (f x); eauto using concat_ok, join_ok. -Qed. - - -(** * Partition *) - -Lemma partition_spec1' s f : (partition f s)#1 = filter f s. -Proof. - induction s as [ | h l Hl x r Hr ]; simpl. - - trivial. - - rewrite <- Hl, <- Hr. - now destruct (partition f l), (partition f r), (f x). -Qed. - -Lemma partition_spec2' s f : - (partition f s)#2 = filter (fun x => negb (f x)) s. -Proof. - induction s as [ | h l Hl x r Hr ]; simpl. - - trivial. - - rewrite <- Hl, <- Hr. - now destruct (partition f l), (partition f r), (f x). -Qed. - -Lemma partition_spec1 s f : - Proper (X.eq==>Logic.eq) f -> - Equal (partition f s)#1 (filter f s). -Proof. now rewrite partition_spec1'. Qed. - -Lemma partition_spec2 s f : - Proper (X.eq==>Logic.eq) f -> - Equal (partition f s)#2 (filter (fun x => negb (f x)) s). -Proof. now rewrite partition_spec2'. Qed. - -#[global] -Instance partition_ok1 s f `(Ok s) : Ok (partition f s)#1. -Proof. rewrite partition_spec1'; now apply filter_ok. Qed. - -#[global] -Instance partition_ok2 s f `(Ok s) : Ok (partition f s)#2. -Proof. rewrite partition_spec2'; now apply filter_ok. Qed. - -End MakeRaw. - - - -(** * Encapsulation - - Now, in order to really provide a functor implementing [S], we - need to encapsulate everything into a type of binary search trees. - They also happen to be well-balanced, but this has no influence - on the correctness of operations, so we won't state this here, - see [MSetFullAVL] if you need more than just the MSet interface. -*) - -Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. - Module Raw := MakeRaw I X. - Include Raw2Sets X Raw. -End IntMake. - -(* For concrete use inside Coq, we propose an instantiation of [Int] by [Z]. *) - -Module Make (X: OrderedType) <: S with Module E := X - :=IntMake(Z_as_Int)(X). diff --git a/stdlib/theories/MSets/MSetDecide.v b/stdlib/theories/MSets/MSetDecide.v deleted file mode 100644 index 06baee503675..000000000000 --- a/stdlib/theories/MSets/MSetDecide.v +++ /dev/null @@ -1,901 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* ... -> Pk -> P ->> - where [P]'s are defined by the grammar: -<< - -P ::= -| Q -| Empty F -| Subset F F' -| Equal F F' - -Q ::= -| E.eq X X' -| In X F -| Q /\ Q' -| Q \/ Q' -| Q -> Q' -| Q <-> Q' -| ~ Q -| True -| False - -F ::= -| S -| empty -| singleton X -| add X F -| remove X F -| union F F' -| inter F F' -| diff F F' - -X ::= x1 | ... | xm -S ::= s1 | ... | sn - ->> - -The tactic will also work on some goals that vary slightly from -the above form: -- The variables and hypotheses may be mixed in any order and may - have already been introduced into the context. Moreover, - there may be additional, unrelated hypotheses mixed in (these - will be ignored). -- A conjunction of hypotheses will be handled as easily as - separate hypotheses, i.e., [P1 /\ P2 -> P] can be solved iff - [P1 -> P2 -> P] can be solved. -- [fsetdec] should solve any goal if the MSet-related hypotheses - are contradictory. -- [fsetdec] will first perform any necessary zeta and beta - reductions and will invoke [subst] to eliminate any Coq - equalities between finite sets or their elements. -- If [E.eq] is convertible with Coq's equality, it will not - matter which one is used in the hypotheses or conclusion. -- The tactic can solve goals where the finite sets or set - elements are expressed by Coq terms that are more complicated - than variables. However, non-local definitions are not - expanded, and Coq equalities between non-variable terms are - not used. For example, this goal will be solved: -<< - forall (f : t -> t), - forall (g : elt -> elt), - forall (s1 s2 : t), - forall (x1 x2 : elt), - Equal s1 (f s2) -> - E.eq x1 (g (g x2)) -> - In x1 s1 -> - In (g (g x2)) (f s2) ->> - This one will not be solved: -<< - forall (f : t -> t), - forall (g : elt -> elt), - forall (s1 s2 : t), - forall (x1 x2 : elt), - Equal s1 (f s2) -> - E.eq x1 (g x2) -> - In x1 s1 -> - g x2 = g (g x2) -> - In (g (g x2)) (f s2) ->> -*) - - (** * Facts and Tactics for Propositional Logic - These lemmas and tactics are in a module so that they do - not affect the namespace if you import the enclosing - module [Decide]. *) - Module MSetLogicalFacts. - Export Decidable. - Export Setoid. - - (** ** Lemmas and Tactics About Decidable Propositions *) - - (** ** Propositional Equivalences Involving Negation - These are all written with the unfolded form of - negation, since I am not sure if setoid rewriting will - always perform conversion. *) - - (** ** Tactics for Negations *) - - Tactic Notation "fold" "any" "not" := - repeat ( - match goal with - | H: context [?P -> False] |- _ => - fold (~ P) in H - | |- context [?P -> False] => - fold (~ P) - end). - - (** [push not using db] will pushes all negations to the - leaves of propositions in the goal, using the lemmas in - [db] to assist in checking the decidability of the - propositions involved. If [using db] is omitted, then - [core] will be used. Additional versions are provided - to manipulate the hypotheses or the hypotheses and goal - together. - - XXX: This tactic and the similar subsequent ones should - have been defined using [autorewrite]. However, dealing - with multiples rewrite sites and side-conditions is - done more cleverly with the following explicit - analysis of goals. *) - - Ltac or_not_l_iff P Q tac := - (rewrite (or_not_l_iff_1 P Q) by tac) || - (rewrite (or_not_l_iff_2 P Q) by tac). - - Ltac or_not_r_iff P Q tac := - (rewrite (or_not_r_iff_1 P Q) by tac) || - (rewrite (or_not_r_iff_2 P Q) by tac). - - Ltac or_not_l_iff_in P Q H tac := - (rewrite (or_not_l_iff_1 P Q) in H by tac) || - (rewrite (or_not_l_iff_2 P Q) in H by tac). - - Ltac or_not_r_iff_in P Q H tac := - (rewrite (or_not_r_iff_1 P Q) in H by tac) || - (rewrite (or_not_r_iff_2 P Q) in H by tac). - - Tactic Notation "push" "not" "using" ident(db) := - let dec := solve_decidable using db in - unfold not, iff; - repeat ( - match goal with - | |- context [True -> False] => rewrite not_true_iff - | |- context [False -> False] => rewrite not_false_iff - | |- context [(?P -> False) -> False] => rewrite (not_not_iff P) by dec - | |- context [(?P -> False) -> (?Q -> False)] => - rewrite (contrapositive P Q) by dec - | |- context [(?P -> False) \/ ?Q] => or_not_l_iff P Q dec - | |- context [?P \/ (?Q -> False)] => or_not_r_iff P Q dec - | |- context [(?P -> False) -> ?Q] => rewrite (imp_not_l P Q) by dec - | |- context [?P \/ ?Q -> False] => rewrite (not_or_iff P Q) - | |- context [?P /\ ?Q -> False] => rewrite (not_and_iff P Q) - | |- context [(?P -> ?Q) -> False] => rewrite (not_imp_iff P Q) by dec - end); - fold any not. - - Tactic Notation "push" "not" := - push not using core. - - Tactic Notation - "push" "not" "in" "*" "|-" "using" ident(db) := - let dec := solve_decidable using db in - unfold not, iff in * |-; - repeat ( - match goal with - | H: context [True -> False] |- _ => rewrite not_true_iff in H - | H: context [False -> False] |- _ => rewrite not_false_iff in H - | H: context [(?P -> False) -> False] |- _ => - rewrite (not_not_iff P) in H by dec - | H: context [(?P -> False) -> (?Q -> False)] |- _ => - rewrite (contrapositive P Q) in H by dec - | H: context [(?P -> False) \/ ?Q] |- _ => or_not_l_iff_in P Q H dec - | H: context [?P \/ (?Q -> False)] |- _ => or_not_r_iff_in P Q H dec - | H: context [(?P -> False) -> ?Q] |- _ => - rewrite (imp_not_l P Q) in H by dec - | H: context [?P \/ ?Q -> False] |- _ => rewrite (not_or_iff P Q) in H - | H: context [?P /\ ?Q -> False] |- _ => rewrite (not_and_iff P Q) in H - | H: context [(?P -> ?Q) -> False] |- _ => - rewrite (not_imp_iff P Q) in H by dec - end); - fold any not. - - Tactic Notation "push" "not" "in" "*" "|-" := - push not in * |- using core. - - Tactic Notation "push" "not" "in" "*" "using" ident(db) := - push not using db; push not in * |- using db. - Tactic Notation "push" "not" "in" "*" := - push not in * using core. - - (** A simple test case to see how this works. *) - Lemma test_push : forall P Q R : Prop, - decidable P -> - decidable Q -> - (~ True) -> - (~ False) -> - (~ ~ P) -> - (~ (P /\ Q) -> ~ R) -> - ((P /\ Q) \/ ~ R) -> - (~ (P /\ Q) \/ R) -> - (R \/ ~ (P /\ Q)) -> - (~ R \/ (P /\ Q)) -> - (~ P -> R) -> - (~ ((R -> P) \/ (Q -> R))) -> - (~ (P /\ R)) -> - (~ (P -> R)) -> - True. - Proof. - intros. push not in *. - (* note that ~(R->P) remains (since R isn't decidable) *) - tauto. - Qed. - - (** [pull not using db] will pull as many negations as - possible toward the top of the propositions in the goal, - using the lemmas in [db] to assist in checking the - decidability of the propositions involved. If [using - db] is omitted, then [core] will be used. Additional - versions are provided to manipulate the hypotheses or - the hypotheses and goal together. *) - - Tactic Notation "pull" "not" "using" ident(db) := - let dec := solve_decidable using db in - unfold not, iff; - repeat ( - match goal with - | |- context [True -> False] => rewrite not_true_iff - | |- context [False -> False] => rewrite not_false_iff - | |- context [(?P -> False) -> False] => rewrite (not_not_iff P) by dec - | |- context [(?P -> False) -> (?Q -> False)] => - rewrite (contrapositive P Q) by dec - | |- context [(?P -> False) \/ ?Q] => or_not_l_iff P Q dec - | |- context [?P \/ (?Q -> False)] => or_not_r_iff P Q dec - | |- context [(?P -> False) -> ?Q] => rewrite (imp_not_l P Q) by dec - | |- context [(?P -> False) /\ (?Q -> False)] => - rewrite <- (not_or_iff P Q) - | |- context [?P -> ?Q -> False] => rewrite <- (not_and_iff P Q) - | |- context [?P /\ (?Q -> False)] => rewrite <- (not_imp_iff P Q) by dec - | |- context [(?Q -> False) /\ ?P] => - rewrite <- (not_imp_rev_iff P Q) by dec - end); - fold any not. - - Tactic Notation "pull" "not" := - pull not using core. - - Tactic Notation - "pull" "not" "in" "*" "|-" "using" ident(db) := - let dec := solve_decidable using db in - unfold not, iff in * |-; - repeat ( - match goal with - | H: context [True -> False] |- _ => rewrite not_true_iff in H - | H: context [False -> False] |- _ => rewrite not_false_iff in H - | H: context [(?P -> False) -> False] |- _ => - rewrite (not_not_iff P) in H by dec - | H: context [(?P -> False) -> (?Q -> False)] |- _ => - rewrite (contrapositive P Q) in H by dec - | H: context [(?P -> False) \/ ?Q] |- _ => or_not_l_iff_in P Q H dec - | H: context [?P \/ (?Q -> False)] |- _ => or_not_r_iff_in P Q H dec - | H: context [(?P -> False) -> ?Q] |- _ => - rewrite (imp_not_l P Q) in H by dec - | H: context [(?P -> False) /\ (?Q -> False)] |- _ => - rewrite <- (not_or_iff P Q) in H - | H: context [?P -> ?Q -> False] |- _ => - rewrite <- (not_and_iff P Q) in H - | H: context [?P /\ (?Q -> False)] |- _ => - rewrite <- (not_imp_iff P Q) in H by dec - | H: context [(?Q -> False) /\ ?P] |- _ => - rewrite <- (not_imp_rev_iff P Q) in H by dec - end); - fold any not. - - Tactic Notation "pull" "not" "in" "*" "|-" := - pull not in * |- using core. - - Tactic Notation "pull" "not" "in" "*" "using" ident(db) := - pull not using db; pull not in * |- using db. - Tactic Notation "pull" "not" "in" "*" := - pull not in * using core. - - (** A simple test case to see how this works. *) - Lemma test_pull : forall P Q R : Prop, - decidable P -> - decidable Q -> - (~ True) -> - (~ False) -> - (~ ~ P) -> - (~ (P /\ Q) -> ~ R) -> - ((P /\ Q) \/ ~ R) -> - (~ (P /\ Q) \/ R) -> - (R \/ ~ (P /\ Q)) -> - (~ R \/ (P /\ Q)) -> - (~ P -> R) -> - (~ (R -> P) /\ ~ (Q -> R)) -> - (~ P \/ ~ R) -> - (P /\ ~ R) -> - (~ R /\ P) -> - True. - Proof. - intros. pull not in *. tauto. - Qed. - - End MSetLogicalFacts. - Import MSetLogicalFacts. - - (** * Auxiliary Tactics - Again, these lemmas and tactics are in a module so that - they do not affect the namespace if you import the - enclosing module [Decide]. *) - Module MSetDecideAuxiliary. - - (** ** Generic Tactics - We begin by defining a few generic, useful tactics. *) - - (** remove logical hypothesis inter-dependencies (fix #2136). *) - - Ltac no_logical_interdep := - match goal with - | H : ?P |- _ => - match type of P with - | Prop => - match goal with H' : context [ H ] |- _ => clear dependent H' end - | _ => fail - end; no_logical_interdep - | _ => idtac - end. - - Ltac abstract_term t := - tryif (is_var t) then fail "no need to abstract a variable" - else (let x := fresh "x" in set (x := t) in *; try clearbody x). - - Ltac abstract_elements := - repeat - (match goal with - | |- context [ singleton ?t ] => abstract_term t - | _ : context [ singleton ?t ] |- _ => abstract_term t - | |- context [ add ?t _ ] => abstract_term t - | _ : context [ add ?t _ ] |- _ => abstract_term t - | |- context [ remove ?t _ ] => abstract_term t - | _ : context [ remove ?t _ ] |- _ => abstract_term t - | |- context [ In ?t _ ] => abstract_term t - | _ : context [ In ?t _ ] |- _ => abstract_term t - end). - - (** [prop P holds by t] succeeds (but does not modify the - goal or context) if the proposition [P] can be proved by - [t] in the current context. Otherwise, the tactic - fails. *) - Tactic Notation "prop" constr(P) "holds" "by" tactic(t) := - let H := fresh in - assert P as H by t; - clear H. - - (** This tactic acts just like [assert ... by ...] but will - fail if the context already contains the proposition. *) - Tactic Notation "assert" "new" constr(e) "by" tactic(t) := - match goal with - | H: e |- _ => fail 1 - | _ => assert e by t - end. - - (** [subst++] is similar to [subst] except that - - it never fails (as [subst] does on recursive - equations), - - it substitutes locally defined variable for their - definitions, - - it performs beta reductions everywhere, which may - arise after substituting a locally defined function - for its definition. - *) - Tactic Notation "subst" "++" := - repeat ( - match goal with - | x : _ |- _ => subst x - end); - cbv zeta beta in *. - - (** [decompose records] calls [decompose record H] on every - relevant hypothesis [H]. *) - Tactic Notation "decompose" "records" := - repeat ( - match goal with - | H: _ |- _ => progress (decompose record H); clear H - end). - - (** ** Discarding Irrelevant Hypotheses - We will want to clear the context of any - non-MSet-related hypotheses in order to increase the - speed of the tactic. To do this, we will need to be - able to decide which are relevant. We do this by making - a simple inductive definition classifying the - propositions of interest. *) - - Inductive MSet_elt_Prop : Prop -> Prop := - | eq_Prop : forall (S : Type) (x y : S), - MSet_elt_Prop (x = y) - | eq_elt_prop : forall x y, - MSet_elt_Prop (E.eq x y) - | In_elt_prop : forall x s, - MSet_elt_Prop (In x s) - | True_elt_prop : - MSet_elt_Prop True - | False_elt_prop : - MSet_elt_Prop False - | conj_elt_prop : forall P Q, - MSet_elt_Prop P -> - MSet_elt_Prop Q -> - MSet_elt_Prop (P /\ Q) - | disj_elt_prop : forall P Q, - MSet_elt_Prop P -> - MSet_elt_Prop Q -> - MSet_elt_Prop (P \/ Q) - | impl_elt_prop : forall P Q, - MSet_elt_Prop P -> - MSet_elt_Prop Q -> - MSet_elt_Prop (P -> Q) - | not_elt_prop : forall P, - MSet_elt_Prop P -> - MSet_elt_Prop (~ P). - - Inductive MSet_Prop : Prop -> Prop := - | elt_MSet_Prop : forall P, - MSet_elt_Prop P -> - MSet_Prop P - | Empty_MSet_Prop : forall s, - MSet_Prop (Empty s) - | Subset_MSet_Prop : forall s1 s2, - MSet_Prop (Subset s1 s2) - | Equal_MSet_Prop : forall s1 s2, - MSet_Prop (Equal s1 s2). - - (** Here is the tactic that will throw away hypotheses that - are not useful (for the intended scope of the [fsetdec] - tactic). *) - #[global] - Hint Constructors MSet_elt_Prop MSet_Prop : MSet_Prop. - Ltac discard_nonMSet := - repeat ( - match goal with - | H : context [ @Logic.eq ?T ?x ?y ] |- _ => - tryif (change T with E.t in H) then fail - else tryif (change T with t in H) then fail - else clear H - | H : ?P |- _ => - tryif prop (MSet_Prop P) holds by - (auto 100 with MSet_Prop) - then fail - else clear H - end). - - (** ** Turning Set Operators into Propositional Connectives - The lemmas from [MSetFacts] will be used to break down - set operations into propositional formulas built over - the predicates [In] and [E.eq] applied only to - variables. We are going to use them with [autorewrite]. - *) - - Global Hint Rewrite - F.empty_iff F.singleton_iff F.add_iff F.remove_iff - F.union_iff F.inter_iff F.diff_iff - : set_simpl. - - Lemma eq_refl_iff (x : E.t) : E.eq x x <-> True. - Proof. - now split. - Qed. - - Global Hint Rewrite eq_refl_iff : set_eq_simpl. - - (** ** Decidability of MSet Propositions *) - - (** [In] is decidable. *) - Lemma dec_In : forall x s, - decidable (In x s). - Proof. - red; intros; generalize (F.mem_iff s x); case (mem x s); intuition auto with bool. - Qed. - - (** [E.eq] is decidable. *) - Lemma dec_eq : forall (x y : E.t), - decidable (E.eq x y). - Proof. - red; intros x y; destruct (E.eq_dec x y); auto. - Qed. - - (** The hint database [MSet_decidability] will be given to - the [push_neg] tactic from the module [Negation]. *) - #[global] - Hint Resolve dec_In dec_eq : MSet_decidability. - - (** ** Normalizing Propositions About Equality - We have to deal with the fact that [E.eq] may be - convertible with Coq's equality. Thus, we will find the - following tactics useful to replace one form with the - other everywhere. *) - - (** The next tactic, [Logic_eq_to_E_eq], mentions the term - [E.t]; thus, we must ensure that [E.t] is used in favor - of any other convertible but syntactically distinct - term. *) - Ltac change_to_E_t := - repeat ( - match goal with - | H : ?T |- _ => - progress (change T with E.t in H); - repeat ( - match goal with - | J : _ |- _ => progress (change T with E.t in J) - | |- _ => progress (change T with E.t) - end ) - | H : forall x : ?T, _ |- _ => - progress (change T with E.t in H); - repeat ( - match goal with - | J : _ |- _ => progress (change T with E.t in J) - | |- _ => progress (change T with E.t) - end ) - end). - - (** These two tactics take us from Coq's built-in equality - to [E.eq] (and vice versa) when possible. *) - - Ltac Logic_eq_to_E_eq := - repeat ( - match goal with - | H: _ |- _ => - progress (change (@Logic.eq E.t) with E.eq in H) - | |- _ => - progress (change (@Logic.eq E.t) with E.eq) - end). - - Ltac E_eq_to_Logic_eq := - repeat ( - match goal with - | H: _ |- _ => - progress (change E.eq with (@Logic.eq E.t) in H) - | |- _ => - progress (change E.eq with (@Logic.eq E.t)) - end). - - (** This tactic works like the built-in tactic [subst], but - at the level of set element equality (which may not be - the convertible with Coq's equality). *) - Ltac substMSet := - repeat ( - match goal with - | H: E.eq ?x ?x |- _ => clear H - | H: E.eq ?x ?y |- _ => rewrite H in *; clear H - end); - autorewrite with set_eq_simpl in *. - - (** ** Considering Decidability of Base Propositions - This tactic adds assertions about the decidability of - [E.eq] and [In] to the context. This is necessary for - the completeness of the [fsetdec] tactic. However, in - order to minimize the cost of proof search, we should be - careful to not add more than we need. Once negations - have been pushed to the leaves of the propositions, we - only need to worry about decidability for those base - propositions that appear in a negated form. *) - Ltac assert_decidability := - (** We actually don't want these rules to fire if the - syntactic context in the patterns below is trivially - empty, but we'll just do some clean-up at the - afterward. *) - repeat ( - match goal with - | H: context [~ E.eq ?x ?y] |- _ => - assert new (E.eq x y \/ ~ E.eq x y) by (apply dec_eq) - | H: context [~ In ?x ?s] |- _ => - assert new (In x s \/ ~ In x s) by (apply dec_In) - | |- context [~ E.eq ?x ?y] => - assert new (E.eq x y \/ ~ E.eq x y) by (apply dec_eq) - | |- context [~ In ?x ?s] => - assert new (In x s \/ ~ In x s) by (apply dec_In) - end); - (** Now we eliminate the useless facts we added (because - they would likely be very harmful to performance). *) - repeat ( - match goal with - | _: ~ ?P, H : ?P \/ ~ ?P |- _ => clear H - end). - - (** ** Handling [Empty], [Subset], and [Equal] - This tactic instantiates universally quantified - hypotheses (which arise from the unfolding of [Empty], - [Subset], and [Equal]) for each of the set element - expressions that is involved in some membership or - equality fact. Then it throws away those hypotheses, - which should no longer be needed. *) - Ltac inst_MSet_hypotheses := - repeat ( - match goal with - | H : forall a : E.t, _, - _ : context [ In ?x _ ] |- _ => - let P := type of (H x) in - assert new P by (exact (H x)) - | H : forall a : E.t, _ - |- context [ In ?x _ ] => - let P := type of (H x) in - assert new P by (exact (H x)) - | H : forall a : E.t, _, - _ : context [ E.eq ?x _ ] |- _ => - let P := type of (H x) in - assert new P by (exact (H x)) - | H : forall a : E.t, _ - |- context [ E.eq ?x _ ] => - let P := type of (H x) in - assert new P by (exact (H x)) - | H : forall a : E.t, _, - _ : context [ E.eq _ ?x ] |- _ => - let P := type of (H x) in - assert new P by (exact (H x)) - | H : forall a : E.t, _ - |- context [ E.eq _ ?x ] => - let P := type of (H x) in - assert new P by (exact (H x)) - end); - repeat ( - match goal with - | H : forall a : E.t, _ |- _ => - clear H - end). - - (** ** The Core [fsetdec] Auxiliary Tactics *) - - (** Here is the crux of the proof search. Recursion through - [intuition]! (This will terminate if I correctly - understand the behavior of [intuition].) *) - Ltac fsetdec_rec := progress substMSet; intuition fsetdec_rec. - - (** If we add [unfold Empty, Subset, Equal in *; intros;] to - the beginning of this tactic, it will satisfy the same - specification as the [fsetdec] tactic; however, it will - be much slower than necessary without the pre-processing - done by the wrapper tactic [fsetdec]. *) - Ltac fsetdec_body := - autorewrite with set_eq_simpl in *; - inst_MSet_hypotheses; - autorewrite with set_simpl set_eq_simpl in *; - push not in * using MSet_decidability; - substMSet; - assert_decidability; - auto; - (intuition fsetdec_rec) || - fail 1 - "because the goal is beyond the scope of this tactic". - - End MSetDecideAuxiliary. - Import MSetDecideAuxiliary. - - (** * The [fsetdec] Tactic - Here is the top-level tactic (the only one intended for - clients of this library). It's specification is given at - the top of the file. *) - Ltac fsetdec := - (** We first unfold any occurrences of [iff]. *) - unfold iff in *; - (** We fold occurrences of [not] because it is better for - [intros] to leave us with a goal of [~ P] than a goal of - [False]. *) - fold any not; intros; - (** We don't care about the value of elements : complex ones are - abstracted as new variables (avoiding potential dependencies, - see bug #2464) *) - abstract_elements; - (** We remove dependencies to logical hypothesis. This way, - later "clear" will work nicely (see bug #2136) *) - no_logical_interdep; - (** Now we decompose conjunctions, which will allow the - [discard_nonMSet] and [assert_decidability] tactics to - do a much better job. *) - decompose records; - discard_nonMSet; - (** We unfold these defined propositions on finite sets. If - our goal was one of them, then have one more item to - introduce now. *) - unfold Empty, Subset, Equal in *; intros; - (** We now want to get rid of all uses of [=] in favor of - [E.eq]. However, the best way to eliminate a [=] is in - the context is with [subst], so we will try that first. - In fact, we may as well convert uses of [E.eq] into [=] - when possible before we do [subst] so that we can even - more mileage out of it. Then we will convert all - remaining uses of [=] back to [E.eq] when possible. We - use [change_to_E_t] to ensure that we have a canonical - name for set elements, so that [Logic_eq_to_E_eq] will - work properly. *) - change_to_E_t; E_eq_to_Logic_eq; subst++; Logic_eq_to_E_eq; - (** The next optimization is to swap a negated goal with a - negated hypothesis when possible. Any swap will improve - performance by eliminating the total number of - negations, but we will get the maximum benefit if we - swap the goal with a hypotheses mentioning the same set - element, so we try that first. If we reach the fourth - branch below, we attempt any swap. However, to maintain - completeness of this tactic, we can only perform such a - swap with a decidable proposition; hence, we first test - whether the hypothesis is an [MSet_elt_Prop], noting - that any [MSet_elt_Prop] is decidable. *) - pull not using MSet_decidability; - unfold not in *; - match goal with - | H: (In ?x ?r) -> False |- (In ?x ?s) -> False => - contradict H; fsetdec_body - | H: (In ?x ?r) -> False |- (E.eq ?x ?y) -> False => - contradict H; fsetdec_body - | H: (In ?x ?r) -> False |- (E.eq ?y ?x) -> False => - contradict H; fsetdec_body - | H: ?P -> False |- ?Q -> False => - tryif prop (MSet_elt_Prop P) holds by - (auto 100 with MSet_Prop) - then (contradict H; fsetdec_body) - else fsetdec_body - | |- _ => - fsetdec_body - end. - - (** * Examples *) - - Module MSetDecideTestCases. - - Lemma test_eq_trans_1 : forall x y z s, - E.eq x y -> - ~ ~ E.eq z y -> - In x s -> - In z s. - Proof. fsetdec. Qed. - - Lemma test_eq_trans_2 : forall x y z r s, - In x (singleton y) -> - ~ In z r -> - ~ ~ In z (add y r) -> - In x s -> - In z s. - Proof. fsetdec. Qed. - - Lemma test_eq_neq_trans_1 : forall w x y z s, - E.eq x w -> - ~ ~ E.eq x y -> - ~ E.eq y z -> - In w s -> - In w (remove z s). - Proof. fsetdec. Qed. - - Lemma test_eq_neq_trans_2 : forall w x y z r1 r2 s, - In x (singleton w) -> - ~ In x r1 -> - In x (add y r1) -> - In y r2 -> - In y (remove z r2) -> - In w s -> - In w (remove z s). - Proof. fsetdec. Qed. - - Lemma test_In_singleton : forall x, - In x (singleton x). - Proof. fsetdec. Qed. - - Lemma test_add_In : forall x y s, - In x (add y s) -> - ~ E.eq x y -> - In x s. - Proof. fsetdec. Qed. - - Lemma test_Subset_add_remove : forall x s, - s [<=] (add x (remove x s)). - Proof. fsetdec. Qed. - - Lemma test_eq_disjunction : forall w x y z, - In w (add x (add y (singleton z))) -> - E.eq w x \/ E.eq w y \/ E.eq w z. - Proof. fsetdec. Qed. - - Lemma test_not_In_disj : forall x y s1 s2 s3 s4, - ~ In x (union s1 (union s2 (union s3 (add y s4)))) -> - ~ (In x s1 \/ In x s4 \/ E.eq y x). - Proof. fsetdec. Qed. - - Lemma test_not_In_conj : forall x y s1 s2 s3 s4, - ~ In x (union s1 (union s2 (union s3 (add y s4)))) -> - ~ In x s1 /\ ~ In x s4 /\ ~ E.eq y x. - Proof. fsetdec. Qed. - - Lemma test_iff_conj : forall a x s s', - (In a s' <-> E.eq x a \/ In a s) -> - (In a s' <-> In a (add x s)). - Proof. fsetdec. Qed. - - Lemma test_set_ops_1 : forall x q r s, - (singleton x) [<=] s -> - Empty (union q r) -> - Empty (inter (diff s q) (diff s r)) -> - ~ In x s. - Proof. fsetdec. Qed. - - Lemma eq_chain_test : forall x1 x2 x3 x4 s1 s2 s3 s4, - Empty s1 -> - In x2 (add x1 s1) -> - In x3 s2 -> - ~ In x3 (remove x2 s2) -> - ~ In x4 s3 -> - In x4 (add x3 s3) -> - In x1 s4 -> - Subset (add x4 s4) s4. - Proof. fsetdec. Qed. - - Lemma test_too_complex : forall x y z r s, - E.eq x y -> - (In x (singleton y) -> r [<=] s) -> - In z r -> - In z s. - Proof. - (** [fsetdec] is not intended to solve this directly. *) - intros until s; intros Heq H Hr; lapply H; fsetdec. - Qed. - - Lemma function_test_1 : - forall (f : t -> t), - forall (g : elt -> elt), - forall (s1 s2 : t), - forall (x1 x2 : elt), - Equal s1 (f s2) -> - E.eq x1 (g (g x2)) -> - In x1 s1 -> - In (g (g x2)) (f s2). - Proof. fsetdec. Qed. - - Lemma function_test_2 : - forall (f : t -> t), - forall (g : elt -> elt), - forall (s1 s2 : t), - forall (x1 x2 : elt), - Equal s1 (f s2) -> - E.eq x1 (g x2) -> - In x1 s1 -> - g x2 = g (g x2) -> - In (g (g x2)) (f s2). - Proof. - (** [fsetdec] is not intended to solve this directly. *) - intros until 3. intros g_eq. rewrite <- g_eq. fsetdec. - Qed. - - Lemma test_baydemir : - forall (f : t -> t), - forall (s : t), - forall (x y : elt), - In x (add y (f s)) -> - ~ E.eq x y -> - In x (f s). - Proof. - fsetdec. - Qed. - - End MSetDecideTestCases. - -End WDecideOn. - -Require Import MSetInterface. - -(** Now comes variants for self-contained weak sets and for full sets. - For these variants, only one argument is necessary. Thanks to - the subtyping [WS<=S], the [Decide] functor which is meant to be - used on modules [(M:S)] can simply be an alias of [WDecide]. *) - -Module WDecide (M:WSets) := !WDecideOn M.E M. -Module Decide := WDecide. diff --git a/stdlib/theories/MSets/MSetEqProperties.v b/stdlib/theories/MSets/MSetEqProperties.v deleted file mode 100644 index 20f33d9ba6c4..000000000000 --- a/stdlib/theories/MSets/MSetEqProperties.v +++ /dev/null @@ -1,941 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* mem x s=mem y s. -Proof. -intro H; rewrite H; auto. -Qed. - -Lemma equal_mem_1: - (forall a, mem a s=mem a s') -> equal s s'=true. -Proof. -intros; apply equal_1; unfold Equal; intros. -do 2 rewrite mem_iff; rewrite H; tauto. -Qed. - -Lemma equal_mem_2: - equal s s'=true -> forall a, mem a s=mem a s'. -Proof. -intros; rewrite (equal_2 H); auto. -Qed. - -Lemma subset_mem_1: - (forall a, mem a s=true->mem a s'=true) -> subset s s'=true. -Proof. -intros; apply subset_1; unfold Subset; intros a. -do 2 rewrite mem_iff; auto. -Qed. - -Lemma subset_mem_2: - subset s s'=true -> forall a, mem a s=true -> mem a s'=true. -Proof. -intros H a; do 2 rewrite <- mem_iff; apply subset_2; auto. -Qed. - -Lemma empty_mem: mem x empty=false. -Proof. -rewrite <- not_mem_iff; auto with set. -Qed. - -Lemma is_empty_equal_empty: is_empty s = equal s empty. -Proof. -apply bool_1; split; intros. -- auto with set. -- rewrite <- is_empty_iff; auto with set. -Qed. - -Lemma choose_mem_1: choose s=Some x -> mem x s=true. -Proof. -auto with set. -Qed. - -Lemma choose_mem_2: choose s=None -> is_empty s=true. -Proof. -auto with set. -Qed. - -Lemma add_mem_1: mem x (add x s)=true. -Proof. -auto with set relations. -Qed. - -Lemma add_mem_2: ~E.eq x y -> mem y (add x s)=mem y s. -Proof. -apply add_neq_b. -Qed. - -Lemma remove_mem_1: mem x (remove x s)=false. -Proof. -rewrite <- not_mem_iff; auto with set relations. -Qed. - -Lemma remove_mem_2: ~E.eq x y -> mem y (remove x s)=mem y s. -Proof. -apply remove_neq_b. -Qed. - -Lemma singleton_equal_add: - equal (singleton x) (add x empty)=true. -Proof. -rewrite (singleton_equal_add x); auto with set. -Qed. - -Lemma union_mem: - mem x (union s s')=mem x s || mem x s'. -Proof. -apply union_b. -Qed. - -Lemma inter_mem: - mem x (inter s s')=mem x s && mem x s'. -Proof. -apply inter_b. -Qed. - -Lemma diff_mem: - mem x (diff s s')=mem x s && negb (mem x s'). -Proof. -apply diff_b. -Qed. - -(** properties of [mem] *) - -Lemma mem_3 : ~In x s -> mem x s=false. -Proof. -intros; rewrite <- not_mem_iff; auto. -Qed. - -Lemma mem_4 : mem x s=false -> ~In x s. -Proof. -intros; rewrite not_mem_iff; auto. -Qed. - -(** Properties of [equal] *) - -Lemma equal_refl: equal s s=true. -Proof. -auto with set. -Qed. - -Lemma equal_sym: equal s s'=equal s' s. -Proof. -intros; apply bool_1; do 2 rewrite <- equal_iff; intuition auto with relations. -Qed. - -Lemma equal_trans: - equal s s'=true -> equal s' s''=true -> equal s s''=true. -Proof. -intros; rewrite (equal_2 H); auto. -Qed. - -Lemma equal_equal: - equal s s'=true -> equal s s''=equal s' s''. -Proof. -intros; rewrite (equal_2 H); auto. -Qed. - -Lemma equal_cardinal: - equal s s'=true -> cardinal s=cardinal s'. -Proof. -auto with set. -Qed. - -(* Properties of [subset] *) - -Lemma subset_refl: subset s s=true. -Proof. -auto with set. -Qed. - -Lemma subset_antisym: - subset s s'=true -> subset s' s=true -> equal s s'=true. -Proof. -auto with set. -Qed. - -Lemma subset_trans: - subset s s'=true -> subset s' s''=true -> subset s s''=true. -Proof. -do 3 rewrite <- subset_iff; intros. -apply subset_trans with s'; auto. -Qed. - -Lemma subset_equal: - equal s s'=true -> subset s s'=true. -Proof. -auto with set. -Qed. - -(** Properties of [choose] *) - -Lemma choose_mem_3: - is_empty s=false -> {x:elt|choose s=Some x /\ mem x s=true}. -Proof. -intros. -generalize (@choose_1 s) (@choose_2 s). -destruct (choose s);intros. -- exists e;auto with set. -- generalize (H1 (eq_refl None)); clear H1. - intros; rewrite (is_empty_1 H1) in H; discriminate. -Qed. - -Lemma choose_mem_4: choose empty=None. -Proof. -generalize (@choose_1 empty). -case (@choose empty);intros;auto. -elim (@empty_1 e); auto. -Qed. - -(** Properties of [add] *) - -Lemma add_mem_3: - mem y s=true -> mem y (add x s)=true. -Proof. -auto with set. -Qed. - -Lemma add_equal: - mem x s=true -> equal (add x s) s=true. -Proof. -auto with set. -Qed. - -(** Properties of [remove] *) - -Lemma remove_mem_3: - mem y (remove x s)=true -> mem y s=true. -Proof. -rewrite remove_b; intros H;destruct (andb_prop _ _ H); auto. -Qed. - -Lemma remove_equal: - mem x s=false -> equal (remove x s) s=true. -Proof. -intros; apply equal_1; apply remove_equal. -rewrite not_mem_iff; auto. -Qed. - -Lemma add_remove: - mem x s=true -> equal (add x (remove x s)) s=true. -Proof. -intros; apply equal_1; apply add_remove; auto with set. -Qed. - -Lemma remove_add: - mem x s=false -> equal (remove x (add x s)) s=true. -Proof. -intros; apply equal_1; apply remove_add; auto. -rewrite not_mem_iff; auto. -Qed. - -(** Properties of [is_empty] *) - -Lemma is_empty_cardinal: is_empty s = zerob (cardinal s). -Proof. -intros; apply bool_1; split; intros. -- rewrite MP.cardinal_1; simpl; auto with set. -- assert (cardinal s = 0) by (apply zerob_true_elim; auto). - auto with set. -Qed. - -(** Properties of [singleton] *) - -Lemma singleton_mem_1: mem x (singleton x)=true. -Proof. -auto with set relations. -Qed. - -Lemma singleton_mem_2: ~E.eq x y -> mem y (singleton x)=false. -Proof. -intros; rewrite singleton_b. -unfold eqb; destruct (E.eq_dec x y); intuition. -Qed. - -Lemma singleton_mem_3: mem y (singleton x)=true -> E.eq x y. -Proof. -intros; apply singleton_1; auto with set. -Qed. - -(** Properties of [union] *) - -Lemma union_sym: - equal (union s s') (union s' s)=true. -Proof. -auto with set. -Qed. - -Lemma union_subset_equal: - subset s s'=true -> equal (union s s') s'=true. -Proof. -auto with set. -Qed. - -Lemma union_equal_1: - equal s s'=true-> equal (union s s'') (union s' s'')=true. -Proof. -auto with set. -Qed. - -Lemma union_equal_2: - equal s' s''=true-> equal (union s s') (union s s'')=true. -Proof. -auto with set. -Qed. - -Lemma union_assoc: - equal (union (union s s') s'') (union s (union s' s''))=true. -Proof. -auto with set. -Qed. - -Lemma add_union_singleton: - equal (add x s) (union (singleton x) s)=true. -Proof. -auto with set. -Qed. - -Lemma union_add: - equal (union (add x s) s') (add x (union s s'))=true. -Proof. -auto with set. -Qed. - -(* characterisation of [union] via [subset] *) - -Lemma union_subset_1: subset s (union s s')=true. -Proof. -auto with set. -Qed. - -Lemma union_subset_2: subset s' (union s s')=true. -Proof. -auto with set. -Qed. - -Lemma union_subset_3: - subset s s''=true -> subset s' s''=true -> - subset (union s s') s''=true. -Proof. -intros; apply subset_1; apply union_subset_3; auto with set. -Qed. - -(** Properties of [inter] *) - -Lemma inter_sym: equal (inter s s') (inter s' s)=true. -Proof. -auto with set. -Qed. - -Lemma inter_subset_equal: - subset s s'=true -> equal (inter s s') s=true. -Proof. -auto with set. -Qed. - -Lemma inter_equal_1: - equal s s'=true -> equal (inter s s'') (inter s' s'')=true. -Proof. -auto with set. -Qed. - -Lemma inter_equal_2: - equal s' s''=true -> equal (inter s s') (inter s s'')=true. -Proof. -auto with set. -Qed. - -Lemma inter_assoc: - equal (inter (inter s s') s'') (inter s (inter s' s''))=true. -Proof. -auto with set. -Qed. - -Lemma union_inter_1: - equal (inter (union s s') s'') (union (inter s s'') (inter s' s''))=true. -Proof. -auto with set. -Qed. - -Lemma union_inter_2: - equal (union (inter s s') s'') (inter (union s s'') (union s' s''))=true. -Proof. -auto with set. -Qed. - -Lemma inter_add_1: mem x s'=true -> - equal (inter (add x s) s') (add x (inter s s'))=true. -Proof. -auto with set. -Qed. - -Lemma inter_add_2: mem x s'=false -> - equal (inter (add x s) s') (inter s s')=true. -Proof. -intros; apply equal_1; apply inter_add_2. -rewrite not_mem_iff; auto. -Qed. - -(* characterisation of [union] via [subset] *) - -Lemma inter_subset_1: subset (inter s s') s=true. -Proof. -auto with set. -Qed. - -Lemma inter_subset_2: subset (inter s s') s'=true. -Proof. -auto with set. -Qed. - -Lemma inter_subset_3: - subset s'' s=true -> subset s'' s'=true -> - subset s'' (inter s s')=true. -Proof. -intros; apply subset_1; apply inter_subset_3; auto with set. -Qed. - -(** Properties of [diff] *) - -Lemma diff_subset: subset (diff s s') s=true. -Proof. -auto with set. -Qed. - -Lemma diff_subset_equal: - subset s s'=true -> equal (diff s s') empty=true. -Proof. -auto with set. -Qed. - -Lemma remove_inter_singleton: - equal (remove x s) (diff s (singleton x))=true. -Proof. -auto with set. -Qed. - -Lemma diff_inter_empty: - equal (inter (diff s s') (inter s s')) empty=true. -Proof. -auto with set. -Qed. - -Lemma diff_inter_all: - equal (union (diff s s') (inter s s')) s=true. -Proof. -auto with set. -Qed. - -End BasicProperties. - -#[global] -Hint Immediate empty_mem is_empty_equal_empty add_mem_1 - remove_mem_1 singleton_equal_add union_mem inter_mem - diff_mem equal_sym add_remove remove_add : set. -#[global] -Hint Resolve equal_mem_1 subset_mem_1 choose_mem_1 - choose_mem_2 add_mem_2 remove_mem_2 equal_refl equal_equal - subset_refl subset_equal subset_antisym - add_mem_3 add_equal remove_mem_3 remove_equal : set. - - -(** General recursion principle *) - -Lemma set_rec: forall (P:t->Type), - (forall s s', equal s s'=true -> P s -> P s') -> - (forall s x, mem x s=false -> P s -> P (add x s)) -> - P empty -> forall s, P s. -Proof. -intros. -apply set_induction; auto; intros. -- apply X with empty; auto with set. -- apply X with (add x s0); auto with set. - + apply equal_1; intro a; rewrite add_iff; rewrite (H0 a); tauto. - + apply X0; auto with set; apply mem_3; auto. -Qed. - -(** Properties of [fold] *) - -Lemma exclusive_set : forall s s' x, - ~(In x s/\In x s') <-> mem x s && mem x s'=false. -Proof. -intros; do 2 rewrite mem_iff. -destruct (mem x s); destruct (mem x s'); intuition auto with bool. -Qed. - -Section Fold. -Variables (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA). -Variables (f:elt->A->A)(Comp:Proper (E.eq==>eqA==>eqA) f)(Ass:transpose eqA f). -Variables (i:A). -Variables (s s':t)(x:elt). - -Lemma fold_empty: (fold f empty i) = i. -Proof. -apply fold_empty; auto. -Qed. - -Lemma fold_equal: - equal s s'=true -> eqA (fold f s i) (fold f s' i). -Proof. -intros; apply fold_equal with (eqA:=eqA); auto with set. -Qed. - -Lemma fold_add: - mem x s=false -> eqA (fold f (add x s) i) (f x (fold f s i)). -Proof. -intros; apply fold_add with (eqA:=eqA); auto. -rewrite not_mem_iff; auto. -Qed. - -Lemma add_fold: - mem x s=true -> eqA (fold f (add x s) i) (fold f s i). -Proof. -intros; apply add_fold with (eqA:=eqA); auto with set. -Qed. - -Lemma remove_fold_1: - mem x s=true -> eqA (f x (fold f (remove x s) i)) (fold f s i). -Proof. -intros; apply remove_fold_1 with (eqA:=eqA); auto with set. -Qed. - -Lemma remove_fold_2: - mem x s=false -> eqA (fold f (remove x s) i) (fold f s i). -Proof. -intros; apply remove_fold_2 with (eqA:=eqA); auto. -rewrite not_mem_iff; auto. -Qed. - -Lemma fold_union: - (forall x, mem x s && mem x s'=false) -> - eqA (fold f (union s s') i) (fold f s (fold f s' i)). -Proof. -intros; apply fold_union with (eqA:=eqA); auto. -intros; rewrite exclusive_set; auto. -Qed. - -End Fold. - -(** Properties of [cardinal] *) - -Lemma add_cardinal_1: - forall s x, mem x s=true -> cardinal (add x s)=cardinal s. -Proof. -auto with set. -Qed. - -Lemma add_cardinal_2: - forall s x, mem x s=false -> cardinal (add x s)=S (cardinal s). -Proof. -intros; apply add_cardinal_2; auto. -rewrite not_mem_iff; auto. -Qed. - -Lemma remove_cardinal_1: - forall s x, mem x s=true -> S (cardinal (remove x s))=cardinal s. -Proof. -intros; apply remove_cardinal_1; auto with set. -Qed. - -Lemma remove_cardinal_2: - forall s x, mem x s=false -> cardinal (remove x s)=cardinal s. -Proof. -intros; apply Equal_cardinal; apply equal_2; auto with set. -Qed. - -Lemma union_cardinal: - forall s s', (forall x, mem x s && mem x s'=false) -> - cardinal (union s s')=cardinal s+cardinal s'. -Proof. -intros; apply union_cardinal; auto; intros. -rewrite exclusive_set; auto. -Qed. - -Lemma subset_cardinal: - forall s s', subset s s'=true -> cardinal s<=cardinal s'. -Proof. -intros; apply subset_cardinal; auto with set. -Qed. - -Section Bool. - -(** Properties of [filter] *) - -Variable f:elt->bool. -Variable Comp: Proper (E.eq==>Logic.eq) f. - -Let Comp' : Proper (E.eq==>Logic.eq) (fun x =>negb (f x)). -Proof. -repeat red; intros; f_equal; auto. -Defined. - -Lemma filter_mem: forall s x, mem x (filter f s)=mem x s && f x. -Proof. -intros; apply filter_b; auto. -Qed. - -Lemma for_all_filter: - forall s, for_all f s=is_empty (filter (fun x => negb (f x)) s). -Proof. -intros; apply bool_1; split; intros. -- apply is_empty_1. - unfold Empty; intros. - rewrite filter_iff; auto. - red; destruct 1. - rewrite <- (@for_all_iff s f) in H; auto. - rewrite (H a H0) in H1; discriminate. -- apply for_all_1; auto; red; intros. - revert H; rewrite <- is_empty_iff. - unfold Empty; intro H; generalize (H x); clear H. - rewrite filter_iff; auto. - destruct (f x); auto. -Qed. - -Lemma exists_filter : - forall s, exists_ f s=negb (is_empty (filter f s)). -Proof. -intros; apply bool_1; split; intros. -- destruct (exists_2 Comp H) as (a,(Ha1,Ha2)). - apply bool_6. - red; intros; apply (@is_empty_2 _ H0 a); auto with set. -- generalize (@choose_1 (filter f s)) (@choose_2 (filter f s)). - destruct (choose (filter f s)). - + intros H0 _; apply exists_1; auto. - exists e; generalize (H0 e); rewrite filter_iff; auto. - + intros _ H0. - rewrite (is_empty_1 (H0 (eq_refl None))) in H; auto; discriminate. -Qed. - -Lemma partition_filter_1: - forall s, equal (fst (partition f s)) (filter f s)=true. -Proof. -auto with set. -Qed. - -Lemma partition_filter_2: - forall s, equal (snd (partition f s)) (filter (fun x => negb (f x)) s)=true. -Proof. -auto with set. -Qed. - -Lemma filter_add_1 : forall s x, f x = true -> - filter f (add x s) [=] add x (filter f s). -Proof. -red; intros; set_iff; do 2 (rewrite filter_iff; auto); set_iff. -intuition. -rewrite <- H; apply Comp; auto with relations. -Qed. - -Lemma filter_add_2 : forall s x, f x = false -> - filter f (add x s) [=] filter f s. -Proof. -red; intros; do 2 (rewrite filter_iff; auto); set_iff. -intuition. -assert (f x = f a) by (apply Comp; auto). -rewrite H in H1; rewrite H2 in H1; discriminate. -Qed. - -Lemma add_filter_1 : forall s s' x, - f x=true -> (Add x s s') -> (Add x (filter f s) (filter f s')). -Proof. -unfold Add, MP.Add; intros. -repeat rewrite filter_iff; auto. -rewrite H0; clear H0. -intuition. -setoid_replace y with x; auto with relations. -Qed. - -Lemma add_filter_2 : forall s s' x, - f x=false -> (Add x s s') -> filter f s [=] filter f s'. -Proof. -unfold Add, MP.Add, Equal; intros. -repeat rewrite filter_iff; auto. -rewrite H0; clear H0. -intuition. -setoid_replace x with a in H; auto. congruence. -Qed. - -Lemma union_filter: forall f g, - Proper (E.eq==>Logic.eq) f -> Proper (E.eq==>Logic.eq) g -> - forall s, union (filter f s) (filter g s) [=] filter (fun x=>orb (f x) (g x)) s. -Proof. -clear Comp' Comp f. -intros. -assert (Proper (E.eq==>Logic.eq) (fun x => orb (f x) (g x))). -- repeat red; intros. - rewrite (H x y H1); rewrite (H0 x y H1); auto. -- unfold Equal; intros; set_iff; repeat rewrite filter_iff; auto. - assert (f a || g a = true <-> f a = true \/ g a = true). - + split; auto with bool. - intro H3; destruct (orb_prop _ _ H3); auto. - + tauto. -Qed. - -Lemma filter_union: forall s s', filter f (union s s') [=] union (filter f s) (filter f s'). -Proof. -unfold Equal; intros; set_iff; repeat rewrite filter_iff; auto; set_iff; tauto. -Qed. - -(** Properties of [for_all] *) - -Lemma for_all_mem_1: forall s, - (forall x, (mem x s)=true->(f x)=true) -> (for_all f s)=true. -Proof. -intros. -rewrite for_all_filter; auto. -rewrite is_empty_equal_empty. -apply equal_mem_1;intros. -rewrite filter_b; auto. -rewrite empty_mem. -generalize (H a); case (mem a s);intros;auto. -rewrite H0;auto. -Qed. - -Lemma for_all_mem_2: forall s, - (for_all f s)=true -> forall x,(mem x s)=true -> (f x)=true. -Proof. -intros. -rewrite for_all_filter in H; auto. -rewrite is_empty_equal_empty in H. -generalize (equal_mem_2 _ _ H x). -rewrite filter_b; auto. -rewrite empty_mem. -rewrite H0; simpl;intros. -rewrite <- negb_false_iff; auto. -Qed. - -Lemma for_all_mem_3: - forall s x,(mem x s)=true -> (f x)=false -> (for_all f s)=false. -Proof. -intros. -apply (bool_eq_ind (for_all f s));intros;auto. -rewrite for_all_filter in H1; auto. -rewrite is_empty_equal_empty in H1. -generalize (equal_mem_2 _ _ H1 x). -rewrite filter_b; auto. -rewrite empty_mem. -rewrite H. -rewrite H0. -simpl;auto. -Qed. - -Lemma for_all_mem_4: - forall s, for_all f s=false -> {x:elt | mem x s=true /\ f x=false}. -Proof. -intros. -rewrite for_all_filter in H; auto. -destruct (choose_mem_3 _ H) as (x,(H0,H1));intros. -exists x. -rewrite filter_b in H1; auto. -elim (andb_prop _ _ H1). -split;auto. -rewrite <- negb_true_iff; auto. -Qed. - -(** Properties of [exists] *) - -Lemma for_all_exists: - forall s, exists_ f s = negb (for_all (fun x =>negb (f x)) s). -Proof. -intros. -rewrite for_all_b; auto. -rewrite exists_b; auto. -induction (elements s); simpl; auto. -destruct (f a); simpl; auto. -Qed. - -End Bool. -Section Bool'. - -Variable f:elt->bool. -Variable Comp: Proper (E.eq==>Logic.eq) f. - -Local Definition Comp' : Proper (E.eq==>Logic.eq) (fun x => negb (f x)). -Proof. -repeat red; intros; f_equal; auto. -Defined. - -Local Hint Resolve Comp' : core. - -Lemma exists_mem_1: - forall s, (forall x, mem x s=true->f x=false) -> exists_ f s=false. -Proof. -intros. -rewrite for_all_exists; auto. -rewrite for_all_mem_1;auto with bool. -intros;generalize (H x H0);intros. -rewrite negb_true_iff; auto. -Qed. - -Lemma exists_mem_2: - forall s, exists_ f s=false -> forall x, mem x s=true -> f x=false. -Proof. -intros. -rewrite for_all_exists in H; auto. -rewrite negb_false_iff in H. -rewrite <- negb_true_iff. -apply for_all_mem_2 with (2:=H); auto. -Qed. - -Lemma exists_mem_3: - forall s x, mem x s=true -> f x=true -> exists_ f s=true. -Proof. -intros. -rewrite for_all_exists; auto. -rewrite negb_true_iff. -apply for_all_mem_3 with x;auto. -rewrite negb_false_iff; auto. -Qed. - -Lemma exists_mem_4: - forall s, exists_ f s=true -> {x:elt | (mem x s)=true /\ (f x)=true}. -Proof. -intros. -rewrite for_all_exists in H; auto. -rewrite negb_true_iff in H. -destruct (@for_all_mem_4 (fun x =>negb (f x)) Comp' s) as (x,[]); auto. -exists x;split;auto. -rewrite <-negb_false_iff; auto. -Qed. - -End Bool'. - -Section Sum. - -(** Adding a valuation function on all elements of a set. *) - -Definition sum (f:elt -> nat)(s:t) := fold (fun x => plus (f x)) s 0. -Notation compat_opL := (Proper (E.eq==>Logic.eq==>Logic.eq)). -Notation transposeL := (transpose Logic.eq). - -Lemma sum_plus : - forall f g, - Proper (E.eq==>Logic.eq) f -> Proper (E.eq==>Logic.eq) g -> - forall s, sum (fun x =>f x+g x) s = sum f s + sum g s. -Proof. -unfold sum. -intros f g Hf Hg. -assert (fc : compat_opL (fun x:elt =>plus (f x))) by - (repeat red; intros; rewrite Hf; auto). -assert (ft : transposeL (fun x:elt =>plus (f x))) by (red; intros; lia). -assert (gc : compat_opL (fun x:elt => plus (g x))) by - (repeat red; intros; rewrite Hg; auto). -assert (gt : transposeL (fun x:elt =>plus (g x))) by (red; intros; lia). -assert (fgc : compat_opL (fun x:elt =>plus ((f x)+(g x)))) by - (repeat red; intros; rewrite Hf,Hg; auto). -assert (fgt : transposeL (fun x:elt=>plus ((f x)+(g x)))) by (red; intros; lia). -intros s;pattern s; apply set_rec. -- intros. - rewrite <- (fold_equal _ _ _ _ fc ft 0 _ _ H). - rewrite <- (fold_equal _ _ _ _ gc gt 0 _ _ H). - rewrite <- (fold_equal _ _ _ _ fgc fgt 0 _ _ H); auto. -- intros. do 3 (rewrite fold_add by auto with fset). lia. -- do 3 rewrite fold_empty;auto. -Qed. - -Lemma sum_filter : forall f : elt -> bool, Proper (E.eq==>Logic.eq) f -> - forall s, (sum (fun x => if f x then 1 else 0) s) = (cardinal (filter f s)). -Proof. -unfold sum; intros f Hf. -assert (st : Equivalence (@Logic.eq nat)) by (split; congruence). -assert (cc : compat_opL (fun x => plus (if f x then 1 else 0))) by - (repeat red; intros; rewrite Hf; auto). -assert (ct : transposeL (fun x => plus (if f x then 1 else 0))) by - (red; intros; lia). -intros s;pattern s; apply set_rec. -- intros. - change elt with E.t. - rewrite <- (fold_equal _ _ st _ cc ct 0 _ _ H). - apply equal_2 in H; rewrite <- H, <-H0; auto. -- intros; rewrite (fold_add _ _ st _ cc ct); auto. - generalize (@add_filter_1 f Hf s0 (add x s0) x) (@add_filter_2 f Hf s0 (add x s0) x) . - assert (~ In x (filter f s0)). - + intro H1; rewrite (mem_1 (filter_1 Hf H1)) in H; discriminate H. - + case (f x); simpl; intros. - * rewrite (MP.cardinal_2 H1 (H2 (eq_refl true) (MP.Add_add s0 x))); auto. - * rewrite <- (MP.Equal_cardinal (H3 (eq_refl false) (MP.Add_add s0 x))); auto. -- intros; rewrite fold_empty;auto. - rewrite MP.cardinal_1; auto. - unfold Empty; intros. - rewrite filter_iff; auto; set_iff; tauto. -Qed. - -Lemma fold_compat : - forall (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA) - (f g:elt->A->A), - Proper (E.eq==>eqA==>eqA) f -> transpose eqA f -> - Proper (E.eq==>eqA==>eqA) g -> transpose eqA g -> - forall (i:A)(s:t),(forall x:elt, (In x s) -> forall y, (eqA (f x y) (g x y))) -> - (eqA (fold f s i) (fold g s i)). -Proof. -intros A eqA st f g fc ft gc gt i. -intro s; pattern s; apply set_rec; intros. -- transitivity (fold f s0 i). - + apply fold_equal with (eqA:=eqA); auto. - rewrite equal_sym; auto. - + transitivity (fold g s0 i). - * apply H0; intros; apply H1; auto with set. - elim (equal_2 H x); auto with set; intros. - * apply fold_equal with (eqA:=eqA); auto with set. -- 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 relations. - transitivity (g x (fold g s0 i)); auto with set relations. - * apply gc; auto with set relations. - * symmetry; apply fold_add with (eqA:=eqA); auto. -- do 2 rewrite fold_empty; reflexivity. -Qed. - -Lemma sum_compat : - forall f g, Proper (E.eq==>Logic.eq) f -> Proper (E.eq==>Logic.eq) g -> - forall s, (forall x, In x s -> f x=g x) -> sum f s=sum g s. -intros. -unfold sum; apply (@fold_compat _ (@Logic.eq nat)); - repeat red; auto with *; lia. -Qed. - -End Sum. - -End WEqPropertiesOn. - -(** Now comes variants for self-contained weak sets and for full sets. - For these variants, only one argument is necessary. Thanks to - the subtyping [WS<=S], the [EqProperties] functor which is meant to be - used on modules [(M:S)] can simply be an alias of [WEqProperties]. *) - -Module WEqProperties (M:WSets) := WEqPropertiesOn M.E M. -Module EqProperties := WEqProperties. diff --git a/stdlib/theories/MSets/MSetFacts.v b/stdlib/theories/MSets/MSetFacts.v deleted file mode 100644 index f7cd7f04da70..000000000000 --- a/stdlib/theories/MSets/MSetFacts.v +++ /dev/null @@ -1,555 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* In x s -> In y s. -Proof. intros E; rewrite E; auto. Qed. - -Lemma mem_1 : In x s -> mem x s = true. -Proof. intros; apply <- mem_spec; auto. Qed. -Lemma mem_2 : mem x s = true -> In x s. -Proof. intros; apply -> mem_spec; auto. Qed. - -Lemma equal_1 : Equal s s' -> equal s s' = true. -Proof. intros; apply <- equal_spec; auto. Qed. -Lemma equal_2 : equal s s' = true -> Equal s s'. -Proof. intros; apply -> equal_spec; auto. Qed. - -Lemma subset_1 : Subset s s' -> subset s s' = true. -Proof. intros; apply <- subset_spec; auto. Qed. -Lemma subset_2 : subset s s' = true -> Subset s s'. -Proof. intros; apply -> subset_spec; auto. Qed. - -Lemma is_empty_1 : Empty s -> is_empty s = true. -Proof. intros; apply <- is_empty_spec; auto. Qed. -Lemma is_empty_2 : is_empty s = true -> Empty s. -Proof. intros; apply -> is_empty_spec; auto. Qed. - -Lemma add_1 : E.eq x y -> In y (add x s). -Proof. intros; apply <- add_spec. auto with relations. Qed. -Lemma add_2 : In y s -> In y (add x s). -Proof. intros; apply <- add_spec; auto. Qed. -Lemma add_3 : ~ E.eq x y -> In y (add x s) -> In y s. -Proof. rewrite add_spec. intros H [H'|H']; auto. elim H; auto with relations. Qed. - -Lemma remove_1 : E.eq x y -> ~ In y (remove x s). -Proof. intros; rewrite remove_spec; intuition. Qed. -Lemma remove_2 : ~ E.eq x y -> In y s -> In y (remove x s). -Proof. intros; apply <- remove_spec; auto with relations. Qed. -Lemma remove_3 : In y (remove x s) -> In y s. -Proof. rewrite remove_spec; intuition. Qed. - -Lemma singleton_1 : In y (singleton x) -> E.eq x y. -Proof. rewrite singleton_spec; auto with relations. Qed. -Lemma singleton_2 : E.eq x y -> In y (singleton x). -Proof. rewrite singleton_spec; auto with relations. Qed. - -Lemma union_1 : In x (union s s') -> In x s \/ In x s'. -Proof. rewrite union_spec; auto. Qed. -Lemma union_2 : In x s -> In x (union s s'). -Proof. rewrite union_spec; auto. Qed. -Lemma union_3 : In x s' -> In x (union s s'). -Proof. rewrite union_spec; auto. Qed. - -Lemma inter_1 : In x (inter s s') -> In x s. -Proof. rewrite inter_spec; intuition. Qed. -Lemma inter_2 : In x (inter s s') -> In x s'. -Proof. rewrite inter_spec; intuition. Qed. -Lemma inter_3 : In x s -> In x s' -> In x (inter s s'). -Proof. rewrite inter_spec; intuition. Qed. - -Lemma diff_1 : In x (diff s s') -> In x s. -Proof. rewrite diff_spec; intuition. Qed. -Lemma diff_2 : In x (diff s s') -> ~ In x s'. -Proof. rewrite diff_spec; intuition. Qed. -Lemma diff_3 : In x s -> ~ In x s' -> In x (diff s s'). -Proof. rewrite diff_spec; auto. Qed. - -Variable f : elt -> bool. -Notation compatb := (Proper (E.eq==>Logic.eq)) (only parsing). - -Lemma filter_1 : compatb f -> In x (filter f s) -> In x s. -Proof. intros P; rewrite filter_spec; intuition. Qed. -Lemma filter_2 : compatb f -> In x (filter f s) -> f x = true. -Proof. intros P; rewrite filter_spec; intuition. Qed. -Lemma filter_3 : compatb f -> In x s -> f x = true -> In x (filter f s). -Proof. intros P; rewrite filter_spec; intuition. Qed. - -Lemma for_all_1 : compatb f -> - For_all (fun x => f x = true) s -> for_all f s = true. -Proof. intros; apply <- for_all_spec; auto. Qed. -Lemma for_all_2 : compatb f -> - for_all f s = true -> For_all (fun x => f x = true) s. -Proof. intros; apply -> for_all_spec; auto. Qed. - -Lemma exists_1 : compatb f -> - Exists (fun x => f x = true) s -> exists_ f s = true. -Proof. intros; apply <- exists_spec; auto. Qed. - -Lemma exists_2 : compatb f -> - exists_ f s = true -> Exists (fun x => f x = true) s. -Proof. intros; apply -> exists_spec; auto. Qed. - -Lemma elements_1 : In x s -> InA E.eq x (elements s). -Proof. intros; apply <- elements_spec1; auto. Qed. -Lemma elements_2 : InA E.eq x (elements s) -> In x s. -Proof. intros; apply -> elements_spec1; auto. Qed. - -End ImplSpec. - -Notation empty_1 := empty_spec (only parsing). -Notation fold_1 := fold_spec (only parsing). -Notation cardinal_1 := cardinal_spec (only parsing). -Notation partition_1 := partition_spec1 (only parsing). -Notation partition_2 := partition_spec2 (only parsing). -Notation choose_1 := choose_spec1 (only parsing). -Notation choose_2 := choose_spec2 (only parsing). -Notation elements_3w := elements_spec2w (only parsing). - -#[global] -Hint Resolve mem_1 equal_1 subset_1 empty_1 - is_empty_1 choose_1 choose_2 add_1 add_2 remove_1 - remove_2 singleton_2 union_1 union_2 union_3 - inter_3 diff_3 fold_1 filter_3 for_all_1 exists_1 - partition_1 partition_2 elements_1 elements_3w - : set. -#[global] -Hint Immediate In_1 mem_2 equal_2 subset_2 is_empty_2 add_3 - remove_3 singleton_1 inter_1 inter_2 diff_1 diff_2 - filter_1 filter_2 for_all_2 exists_2 elements_2 - : set. - - -(** * Specifications written using equivalences : - this is now provided by the default interface. *) - -Section IffSpec. -Variable s s' s'' : t. -Variable x y z : elt. - -Lemma In_eq_iff : E.eq x y -> (In x s <-> In y s). -Proof. -intros E; rewrite E; intuition. -Qed. - -Lemma mem_iff : In x s <-> mem x s = true. -Proof. apply iff_sym, mem_spec. Qed. - -Lemma not_mem_iff : ~In x s <-> mem x s = false. -Proof. -rewrite <-mem_spec; destruct (mem x s); intuition auto with bool. -Qed. - -Lemma equal_iff : s[=]s' <-> equal s s' = true. -Proof. apply iff_sym, equal_spec. Qed. - -Lemma subset_iff : s[<=]s' <-> subset s s' = true. -Proof. apply iff_sym, subset_spec. Qed. - -Lemma empty_iff : In x empty <-> False. -Proof. intuition; apply (empty_spec H). Qed. - -Lemma is_empty_iff : Empty s <-> is_empty s = true. -Proof. apply iff_sym, is_empty_spec. Qed. - -Lemma singleton_iff : In y (singleton x) <-> E.eq x y. -Proof. rewrite singleton_spec; intuition. Qed. - -Lemma add_iff : In y (add x s) <-> E.eq x y \/ In y s. -Proof. rewrite add_spec; intuition. Qed. - -Lemma add_neq_iff : ~ E.eq x y -> (In y (add x s) <-> In y s). -Proof. rewrite add_spec; intuition. elim H; auto with relations. Qed. - -Lemma remove_iff : In y (remove x s) <-> In y s /\ ~E.eq x y. -Proof. rewrite remove_spec; intuition. Qed. - -Lemma remove_neq_iff : ~ E.eq x y -> (In y (remove x s) <-> In y s). -Proof. rewrite remove_spec; intuition. Qed. - -Variable f : elt -> bool. - -Lemma for_all_iff : Proper (E.eq==>Logic.eq) f -> - (For_all (fun x => f x = true) s <-> for_all f s = true). -Proof. intros; apply iff_sym, for_all_spec; auto. Qed. - -Lemma exists_iff : Proper (E.eq==>Logic.eq) f -> - (Exists (fun x => f x = true) s <-> exists_ f s = true). -Proof. intros; apply iff_sym, exists_spec; auto. Qed. - -Lemma elements_iff : In x s <-> InA E.eq x (elements s). -Proof. apply iff_sym, elements_spec1. Qed. - -End IffSpec. - -Notation union_iff := union_spec (only parsing). -Notation inter_iff := inter_spec (only parsing). -Notation diff_iff := diff_spec (only parsing). -Notation filter_iff := filter_spec (only parsing). - -(** Useful tactic for simplifying expressions like [In y (add x (union s s'))] *) - -Ltac set_iff := - repeat (progress ( - rewrite add_iff || rewrite remove_iff || rewrite singleton_iff - || rewrite union_iff || rewrite inter_iff || rewrite diff_iff - || rewrite empty_iff)). - -(** * Specifications written using boolean predicates *) - -Section BoolSpec. -Variable s s' s'' : t. -Variable x y z : elt. - -Lemma mem_b : E.eq x y -> mem x s = mem y s. -Proof. -intros. -generalize (mem_iff s x) (mem_iff s y)(In_eq_iff s H). -destruct (mem x s); destruct (mem y s); intuition. -Qed. - -Lemma empty_b : mem y empty = false. -Proof. -generalize (empty_iff y)(mem_iff empty y). -destruct (mem y empty); intuition. -Qed. - -Lemma add_b : mem y (add x s) = eqb x y || mem y s. -Proof. -generalize (mem_iff (add x s) y)(mem_iff s y)(add_iff s x y); unfold eqb. -destruct (eq_dec x y); destruct (mem y s); destruct (mem y (add x s)); intuition. -Qed. - -Lemma add_neq_b : ~ E.eq x y -> mem y (add x s) = mem y s. -Proof. -intros; generalize (mem_iff (add x s) y)(mem_iff s y)(add_neq_iff s H). -destruct (mem y s); destruct (mem y (add x s)); intuition. -Qed. - -Lemma remove_b : mem y (remove x s) = mem y s && negb (eqb x y). -Proof. -generalize (mem_iff (remove x s) y)(mem_iff s y)(remove_iff s x y); unfold eqb. -destruct (eq_dec x y); destruct (mem y s); destruct (mem y (remove x s)); simpl; intuition. -Qed. - -Lemma remove_neq_b : ~ E.eq x y -> mem y (remove x s) = mem y s. -Proof. -intros; generalize (mem_iff (remove x s) y)(mem_iff s y)(remove_neq_iff s H). -destruct (mem y s); destruct (mem y (remove x s)); intuition. -Qed. - -Lemma singleton_b : mem y (singleton x) = eqb x y. -Proof. -generalize (mem_iff (singleton x) y)(singleton_iff x y); unfold eqb. -destruct (eq_dec x y); destruct (mem y (singleton x)); intuition. -Qed. - -Lemma union_b : mem x (union s s') = mem x s || mem x s'. -Proof. -generalize (mem_iff (union s s') x)(mem_iff s x)(mem_iff s' x)(union_iff s s' x). -destruct (mem x s); destruct (mem x s'); destruct (mem x (union s s')); intuition. -Qed. - -Lemma inter_b : mem x (inter s s') = mem x s && mem x s'. -Proof. -generalize (mem_iff (inter s s') x)(mem_iff s x)(mem_iff s' x)(inter_iff s s' x). -destruct (mem x s); destruct (mem x s'); destruct (mem x (inter s s')); intuition. -Qed. - -Lemma diff_b : mem x (diff s s') = mem x s && negb (mem x s'). -Proof. -generalize (mem_iff (diff s s') x)(mem_iff s x)(mem_iff s' x)(diff_iff s s' x). -destruct (mem x s); destruct (mem x s'); destruct (mem x (diff s s')); simpl; intuition. -Qed. - -Lemma elements_b : mem x s = existsb (eqb x) (elements s). -Proof. -generalize (mem_iff s x)(elements_iff s x)(existsb_exists (eqb x) (elements s)). -rewrite InA_alt. -destruct (mem x s); destruct (existsb (eqb x) (elements s)); auto; intros. -- symmetry. - rewrite H1. - destruct H0 as (H0,_). - destruct H0 as (a,(Ha1,Ha2)); [ intuition |]. - exists a; intuition. - unfold eqb; destruct (eq_dec x a); auto. -- rewrite <- H. - rewrite H0. - destruct H1 as (H1,_). - destruct H1 as (a,(Ha1,Ha2)); [intuition|]. - exists a; intuition. - unfold eqb in *; destruct (eq_dec x a); auto; discriminate. -Qed. - -Variable f : elt->bool. - -Lemma filter_b : Proper (E.eq==>Logic.eq) f -> mem x (filter f s) = mem x s && f x. -Proof. -intros. -generalize (mem_iff (filter f s) x)(mem_iff s x)(filter_iff s x H). -destruct (mem x s); destruct (mem x (filter f s)); destruct (f x); simpl; intuition. -Qed. - -Lemma for_all_b : Proper (E.eq==>Logic.eq) f -> - for_all f s = forallb f (elements s). -Proof. -intros. -generalize (forallb_forall f (elements s))(for_all_iff s H)(elements_iff s). -unfold For_all. -destruct (forallb f (elements s)); destruct (for_all f s); auto; intros. -- rewrite <- H1; intros. - destruct H0 as (H0,_). - rewrite (H2 x0) in H3. - rewrite (InA_alt E.eq x0 (elements s)) in H3. - destruct H3 as (a,(Ha1,Ha2)). - rewrite (H _ _ Ha1). - apply H0; auto. -- symmetry. - rewrite H0; intros. - destruct H1 as (_,H1). - apply H1; auto. - rewrite H2. - rewrite InA_alt. exists x0; split; auto with relations. -Qed. - -Lemma exists_b : Proper (E.eq==>Logic.eq) f -> - exists_ f s = existsb f (elements s). -Proof. -intros. -generalize (existsb_exists f (elements s))(exists_iff s H)(elements_iff s). -unfold Exists. -destruct (existsb f (elements s)); destruct (exists_ f s); auto; intros. -- rewrite <- H1; intros. - destruct H0 as (H0,_). - destruct H0 as (a,(Ha1,Ha2)); auto. - exists a; split; auto. - rewrite H2; rewrite InA_alt; exists a; auto with relations. -- symmetry. - rewrite H0. - destruct H1 as (_,H1). - destruct H1 as (a,(Ha1,Ha2)); auto. - rewrite (H2 a) in Ha1. - rewrite (InA_alt E.eq a (elements s)) in Ha1. - destruct Ha1 as (b,(Hb1,Hb2)). - exists b; auto. - rewrite <- (H _ _ Hb1); auto. -Qed. - -End BoolSpec. - -(** * Declarations of morphisms with respects to [E.eq] and [Equal] *) - -#[global] -Instance In_m : Proper (E.eq==>Equal==>iff) In. -Proof. -unfold Equal; intros x y H s s' H0. -rewrite (In_eq_iff s H); auto. -Qed. - -#[global] -Instance Empty_m : Proper (Equal==>iff) Empty. -Proof. -repeat red; unfold Empty; intros s s' E. -setoid_rewrite E; auto. -Qed. - -#[global] -Instance is_empty_m : Proper (Equal==>Logic.eq) is_empty. -Proof. -intros s s' H. -generalize (is_empty_iff s). rewrite H at 1. rewrite is_empty_iff. -destruct (is_empty s); destruct (is_empty s'); intuition. -Qed. - -#[global] -Instance mem_m : Proper (E.eq==>Equal==>Logic.eq) mem. -Proof. -intros x x' Hx s s' Hs. -generalize (mem_iff s x). rewrite Hs, Hx at 1; rewrite mem_iff. -destruct (mem x s), (mem x' s'); intuition. -Qed. - -#[global] -Instance singleton_m : Proper (E.eq==>Equal) singleton. -Proof. -intros x y H a. rewrite !singleton_iff, H; intuition. -Qed. - -#[global] -Instance add_m : Proper (E.eq==>Equal==>Equal) add. -Proof. -intros x x' Hx s s' Hs a. rewrite !add_iff, Hx, Hs; intuition. -Qed. - -#[global] -Instance remove_m : Proper (E.eq==>Equal==>Equal) remove. -Proof. -intros x x' Hx s s' Hs a. rewrite !remove_iff, Hx, Hs; intuition. -Qed. - -#[global] -Instance union_m : Proper (Equal==>Equal==>Equal) union. -Proof. -intros s1 s1' Hs1 s2 s2' Hs2 a. rewrite !union_iff, Hs1, Hs2; intuition. -Qed. - -#[global] -Instance inter_m : Proper (Equal==>Equal==>Equal) inter. -Proof. -intros s1 s1' Hs1 s2 s2' Hs2 a. rewrite !inter_iff, Hs1, Hs2; intuition. -Qed. - -#[global] -Instance diff_m : Proper (Equal==>Equal==>Equal) diff. -Proof. -intros s1 s1' Hs1 s2 s2' Hs2 a. rewrite !diff_iff, Hs1, Hs2; intuition. -Qed. - -#[global] -Instance Subset_m : Proper (Equal==>Equal==>iff) Subset. -Proof. -unfold Equal, Subset; firstorder. -Qed. - -#[global] -Instance subset_m : Proper (Equal==>Equal==>Logic.eq) subset. -Proof. -intros s1 s1' Hs1 s2 s2' Hs2. -generalize (subset_iff s1 s2). rewrite Hs1, Hs2 at 1. rewrite subset_iff. -destruct (subset s1 s2); destruct (subset s1' s2'); intuition. -Qed. - -#[global] -Instance equal_m : Proper (Equal==>Equal==>Logic.eq) equal. -Proof. -intros s1 s1' Hs1 s2 s2' Hs2. -generalize (equal_iff s1 s2). rewrite Hs1,Hs2 at 1. rewrite equal_iff. -destruct (equal s1 s2); destruct (equal s1' s2'); intuition. -Qed. - -#[global] -Instance SubsetSetoid : PreOrder Subset. (* reflexive + transitive *) -Proof. firstorder. Qed. - -Definition Subset_refl := @PreOrder_Reflexive _ _ SubsetSetoid. -Definition Subset_trans := @PreOrder_Transitive _ _ SubsetSetoid. - -#[global] -Instance In_s_m : Morphisms.Proper (E.eq ==> Subset ++> impl) In | 1. -Proof. - simpl_relation. eauto with set. -Qed. - -#[global] -Instance Empty_s_m : Proper (Subset-->impl) Empty. -Proof. firstorder. Qed. - -#[global] -Instance add_s_m : Proper (E.eq==>Subset++>Subset) add. -Proof. -intros x x' Hx s s' Hs a. rewrite !add_iff, Hx; intuition. -Qed. - -#[global] -Instance remove_s_m : Proper (E.eq==>Subset++>Subset) remove. -Proof. -intros x x' Hx s s' Hs a. rewrite !remove_iff, Hx; intuition. -Qed. - -#[global] -Instance union_s_m : Proper (Subset++>Subset++>Subset) union. -Proof. -intros s1 s1' Hs1 s2 s2' Hs2 a. rewrite !union_iff, Hs1, Hs2; intuition. -Qed. - -#[global] -Instance inter_s_m : Proper (Subset++>Subset++>Subset) inter. -Proof. -intros s1 s1' Hs1 s2 s2' Hs2 a. rewrite !inter_iff, Hs1, Hs2; intuition. -Qed. - -#[global] -Instance diff_s_m : Proper (Subset++>Subset-->Subset) diff. -Proof. -intros s1 s1' Hs1 s2 s2' Hs2 a. rewrite !diff_iff, Hs1, Hs2; intuition. -Qed. - - -(* [fold], [filter], [for_all], [exists_] and [partition] requires - some knowledge on [f] in order to be known as morphisms. *) - -Generalizable Variables f. - -#[global] -Instance filter_equal : forall `(Proper _ (E.eq==>Logic.eq) f), - Proper (Equal==>Equal) (filter f). -Proof. -intros f Hf s s' Hs a. rewrite !filter_iff, Hs by auto; intuition. -Qed. - -#[global] -Instance filter_subset : forall `(Proper _ (E.eq==>Logic.eq) f), - Proper (Subset==>Subset) (filter f). -Proof. -intros f Hf s s' Hs a. rewrite !filter_iff, Hs by auto; intuition. -Qed. - -Lemma filter_ext : forall f f', Proper (E.eq==>Logic.eq) f -> (forall x, f x = f' x) -> - forall s s', s[=]s' -> filter f s [=] filter f' s'. -Proof. -intros f f' Hf Hff' s s' Hss' x. rewrite 2 filter_iff; auto. -- rewrite Hff', Hss'; intuition. -- red; red; intros; rewrite <- 2 Hff'; auto. -Qed. - -(* For [elements], [min_elt], [max_elt] and [choose], we would need setoid - structures on [list elt] and [option elt]. *) - -(* Later: -Add Morphism cardinal ; cardinal_m. -*) - -End WFactsOn. - -(** Now comes variants for self-contained weak sets and for full sets. - For these variants, only one argument is necessary. Thanks to - the subtyping [WS<=S], the [Facts] functor which is meant to be - used on modules [(M:S)] can simply be an alias of [WFacts]. *) - -Module WFacts (M:WSets) := WFactsOn M.E M. -Module Facts := WFacts. diff --git a/stdlib/theories/MSets/MSetGenTree.v b/stdlib/theories/MSets/MSetGenTree.v deleted file mode 100644 index 6f0eab2b1dc8..000000000000 --- a/stdlib/theories/MSets/MSetGenTree.v +++ /dev/null @@ -1,1169 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* tree -> X.t -> tree -> tree. - -(** ** The empty set and emptyness test *) - -Definition empty := Leaf. - -Definition is_empty t := - match t with - | Leaf => true - | _ => false - end. - -(** ** Membership test *) - -(** The [mem] function is deciding membership. It exploits the - binary search tree invariant to achieve logarithmic complexity. *) - -Fixpoint mem x t := - match t with - | Leaf => false - | Node _ l k r => - match X.compare x k with - | Lt => mem x l - | Eq => true - | Gt => mem x r - end - end. - -(** ** Minimal, maximal, arbitrary elements *) - -Fixpoint min_elt (t : tree) : option elt := - match t with - | Leaf => None - | Node _ Leaf x r => Some x - | Node _ l x r => min_elt l - end. - -Fixpoint max_elt (t : tree) : option elt := - match t with - | Leaf => None - | Node _ l x Leaf => Some x - | Node _ l x r => max_elt r - end. - -Definition choose := min_elt. - -(** ** Iteration on elements *) - -Fixpoint fold {A: Type} (f: elt -> A -> A) (t: tree) (base: A) : A := - match t with - | Leaf => base - | Node _ l x r => fold f r (f x (fold f l base)) - end. - -Fixpoint elements_aux acc s := - match s with - | Leaf => acc - | Node _ l x r => elements_aux (x :: elements_aux acc r) l - end. - -Definition elements := elements_aux nil. - -Fixpoint rev_elements_aux acc s := - match s with - | Leaf => acc - | Node _ l x r => rev_elements_aux (x :: rev_elements_aux acc l) r - end. - -Definition rev_elements := rev_elements_aux nil. - -Fixpoint cardinal (s : tree) : nat := - match s with - | Leaf => 0 - | Node _ l _ r => S (cardinal l + cardinal r) - end. - -Fixpoint maxdepth s := - match s with - | Leaf => 0 - | Node _ l _ r => S (max (maxdepth l) (maxdepth r)) - end. - -Fixpoint mindepth s := - match s with - | Leaf => 0 - | Node _ l _ r => S (min (mindepth l) (mindepth r)) - end. - -(** ** Testing universal or existential properties. *) - -(** We do not use the standard boolean operators of Coq, - but lazy ones. *) - -Fixpoint for_all (f:elt->bool) s := match s with - | Leaf => true - | Node _ l x r => f x &&& for_all f l &&& for_all f r -end. - -Fixpoint exists_ (f:elt->bool) s := match s with - | Leaf => false - | Node _ l x r => f x ||| exists_ f l ||| exists_ f r -end. - -(** ** Comparison of trees *) - -(** The algorithm here has been suggested by Xavier Leroy, - and transformed into c.p.s. by Benjamin GrĆ©goire. - The original ocaml code (with non-structural recursive calls) - has also been formalized (thanks to Function+measure), see - [ocaml_compare] in [MSetFullAVL]. The following code with - continuations computes dramatically faster in Coq, and - should be almost as efficient after extraction. -*) - -(** Enumeration of the elements of a tree. This corresponds - to the "samefringe" notion in the literature. *) - -Inductive enumeration := - | End : enumeration - | More : elt -> tree -> enumeration -> enumeration. - - -(** [cons t e] adds the elements of tree [t] on the head of - enumeration [e]. *) - -Fixpoint cons s e : enumeration := - match s with - | Leaf => e - | Node _ l x r => cons l (More x r e) - end. - -(** One step of comparison of elements *) - -Definition compare_more x1 (cont:enumeration->comparison) e2 := - match e2 with - | End => Gt - | More x2 r2 e2 => - match X.compare x1 x2 with - | Eq => cont (cons r2 e2) - | Lt => Lt - | Gt => Gt - end - end. - -(** Comparison of left tree, middle element, then right tree *) - -Fixpoint compare_cont s1 (cont:enumeration->comparison) e2 := - match s1 with - | Leaf => cont e2 - | Node _ l1 x1 r1 => - compare_cont l1 (compare_more x1 (compare_cont r1 cont)) e2 - end. - -(** Initial continuation *) - -Definition compare_end e2 := - match e2 with End => Eq | _ => Lt end. - -(** The complete comparison *) - -Definition compare s1 s2 := compare_cont s1 compare_end (cons s2 End). - -Definition equal s1 s2 := - match compare s1 s2 with Eq => true | _ => false end. - -(** ** Subset test *) - -(** In ocaml, recursive calls are made on "half-trees" such as - (Node _ l1 x1 Leaf) and (Node _ Leaf x1 r1). Instead of these - non-structural calls, we propose here two specialized functions - for these situations. This version should be almost as efficient - as the one of ocaml (closures as arguments may slow things a bit), - it is simply less compact. The exact ocaml version has also been - formalized (thanks to Function+measure), see [ocaml_subset] in - [MSetFullAVL]. -*) - -Fixpoint subsetl (subset_l1 : tree -> bool) x1 s2 : bool := - match s2 with - | Leaf => false - | Node _ l2 x2 r2 => - match X.compare x1 x2 with - | Eq => subset_l1 l2 - | Lt => subsetl subset_l1 x1 l2 - | Gt => mem x1 r2 &&& subset_l1 s2 - end - end. - -Fixpoint subsetr (subset_r1 : tree -> bool) x1 s2 : bool := - match s2 with - | Leaf => false - | Node _ l2 x2 r2 => - match X.compare x1 x2 with - | Eq => subset_r1 r2 - | Lt => mem x1 l2 &&& subset_r1 s2 - | Gt => subsetr subset_r1 x1 r2 - end - end. - -Fixpoint subset s1 s2 : bool := match s1, s2 with - | Leaf, _ => true - | Node _ _ _ _, Leaf => false - | Node _ l1 x1 r1, Node _ l2 x2 r2 => - match X.compare x1 x2 with - | Eq => subset l1 l2 &&& subset r1 r2 - | Lt => subsetl (subset l1) x1 l2 &&& subset r1 s2 - | Gt => subsetr (subset r1) x1 r2 &&& subset l1 s2 - end - end. - -End Ops. - -(** * Props : correctness proofs of these generic operations *) - -Module Type Props (X:OrderedType)(Info:InfoTyp)(Import M:Ops X Info). - -(** ** Occurrence in a tree *) - -Inductive InT (x : elt) : tree -> Prop := - | IsRoot : forall c l r y, X.eq x y -> InT x (Node c l y r) - | InLeft : forall c l r y, InT x l -> InT x (Node c l y r) - | InRight : forall c l r y, InT x r -> InT x (Node c l y r). - -Definition In := InT. - -(** ** Some shortcuts *) - -Definition Equal s s' := forall a : elt, InT a s <-> InT a s'. -Definition Subset s s' := forall a : elt, InT a s -> InT a s'. -Definition Empty s := forall a : elt, ~ InT a s. -Definition For_all (P : elt -> Prop) s := forall x, InT x s -> P x. -Definition Exists (P : elt -> Prop) s := exists x, InT x s /\ P x. - -(** ** Binary search trees *) - -(** [lt_tree x s]: all elements in [s] are smaller than [x] - (resp. greater for [gt_tree]) *) - -Definition lt_tree x s := forall y, InT y s -> X.lt y x. -Definition gt_tree x s := forall y, InT y s -> X.lt x y. - -(** [bst t] : [t] is a binary search tree *) - -Inductive bst : tree -> Prop := - | BSLeaf : bst Leaf - | BSNode : forall c x l r, bst l -> bst r -> - lt_tree x l -> gt_tree x r -> bst (Node c l x r). - -(** [bst] is the (decidable) invariant our trees will have to satisfy. *) - -Definition IsOk := bst. - -Class Ok (s:tree) : Prop := ok : bst s. - -#[global] -Instance bst_Ok s (Hs : bst s) : Ok s := { ok := Hs }. - -Fixpoint ltb_tree x s := - match s with - | Leaf => true - | Node _ l y r => - match X.compare x y with - | Gt => ltb_tree x l && ltb_tree x r - | _ => false - end - end. - -Fixpoint gtb_tree x s := - match s with - | Leaf => true - | Node _ l y r => - match X.compare x y with - | Lt => gtb_tree x l && gtb_tree x r - | _ => false - end - end. - -Fixpoint isok s := - match s with - | Leaf => true - | Node _ l x r => isok l && isok r && ltb_tree x l && gtb_tree x r - end. - - -(** ** Known facts about ordered types *) - -Module Import MX := OrderedTypeFacts X. - -(** ** Automation and dedicated tactics *) - -Scheme tree_ind := Induction for tree Sort Prop. -Scheme bst_ind := Induction for bst Sort Prop. - -Local Hint Resolve MX.eq_refl MX.eq_trans MX.lt_trans ok : core. -Local Hint Immediate MX.eq_sym : core. -Local Hint Unfold In lt_tree gt_tree : core. -Local Hint Constructors InT bst : core. -Local Hint Unfold Ok : core. - -(** Automatic treatment of [Ok] hypothesis *) - -Ltac clear_inversion H := inversion H; clear H; subst. - -Ltac inv_ok := match goal with - | H:Ok (Node _ _ _ _) |- _ => clear_inversion H; inv_ok - | H:Ok Leaf |- _ => clear H; inv_ok - | H:bst ?x |- _ => change (Ok x) in H; inv_ok - | _ => idtac -end. - -(** A tactic to repeat [inversion_clear] on all hyps of the - form [(f (Node _ _ _ _))] *) - -Ltac is_tree_constr c := - match c with - | Leaf => idtac - | Node _ _ _ _ => idtac - | _ => fail - end. - -Ltac invtree f := - match goal with - | H:f ?s |- _ => is_tree_constr s; clear_inversion H; invtree f - | H:f _ ?s |- _ => is_tree_constr s; clear_inversion H; invtree f - | H:f _ _ ?s |- _ => is_tree_constr s; clear_inversion H; invtree f - | _ => idtac - end. - -Ltac inv := inv_ok; invtree InT. - -Ltac intuition_in := repeat (intuition auto; inv). - -(** Helper tactic concerning order of elements. *) - -Ltac order := match goal with - | U: lt_tree _ ?s, V: InT _ ?s |- _ => generalize (U _ V); clear U; order - | U: gt_tree _ ?s, V: InT _ ?s |- _ => generalize (U _ V); clear U; order - | _ => MX.order -end. - - -(** [isok] is indeed a decision procedure for [Ok] *) - -Lemma ltb_tree_iff : forall x s, lt_tree x s <-> ltb_tree x s = true. -Proof. - induction s as [|c l IHl y r IHr]; simpl. - - unfold lt_tree; intuition_in. - - elim_compare x y. - + split; intros; try discriminate. assert (X.lt y x) by auto. order. - + split; intros; try discriminate. assert (X.lt y x) by auto. order. - + rewrite !andb_true_iff, <-IHl, <-IHr. - unfold lt_tree; intuition_in; order. -Qed. - -Lemma gtb_tree_iff : forall x s, gt_tree x s <-> gtb_tree x s = true. -Proof. - induction s as [|c l IHl y r IHr]; simpl. - - unfold gt_tree; intuition_in. - - elim_compare x y. - + split; intros; try discriminate. assert (X.lt x y) by auto. order. - + rewrite !andb_true_iff, <-IHl, <-IHr. - unfold gt_tree; intuition_in; order. - + split; intros; try discriminate. assert (X.lt x y) by auto. order. -Qed. - -Lemma isok_iff : forall s, Ok s <-> isok s = true. -Proof. - induction s as [|c l IHl y r IHr]; simpl. - - intuition_in. - - rewrite !andb_true_iff, <- IHl, <-IHr, <- ltb_tree_iff, <- gtb_tree_iff. - intuition_in. -Qed. - -#[global] -Instance isok_Ok s : isok s = true -> Ok s | 10. -Proof. intros; apply <- isok_iff; auto. Qed. - -(** ** Basic results about [In] *) - -Lemma In_1 : - forall s x y, X.eq x y -> InT x s -> InT y s. -Proof. - induction s; simpl; intuition_in; eauto. -Qed. -Local Hint Immediate In_1 : core. - -#[global] -Instance In_compat : Proper (X.eq==>eq==>iff) InT. -Proof. -apply proper_sym_impl_iff_2; auto with *. -repeat red; intros; subst. apply In_1 with x; auto. -Qed. - -Lemma In_node_iff : - forall c l x r y, - InT y (Node c l x r) <-> InT y l \/ X.eq y x \/ InT y r. -Proof. - intuition_in. -Qed. - -Lemma In_leaf_iff : forall x, InT x Leaf <-> False. -Proof. - intuition_in. -Qed. - -(** Results about [lt_tree] and [gt_tree] *) - -Lemma lt_leaf : forall x : elt, lt_tree x Leaf. -Proof. - red; inversion 1. -Qed. - -Lemma gt_leaf : forall x : elt, gt_tree x Leaf. -Proof. - red; inversion 1. -Qed. - -Lemma lt_tree_node : - forall (x y : elt) (l r : tree) (i : Info.t), - lt_tree x l -> lt_tree x r -> X.lt y x -> lt_tree x (Node i l y r). -Proof. - unfold lt_tree; intuition_in; order. -Qed. - -Lemma gt_tree_node : - forall (x y : elt) (l r : tree) (i : Info.t), - gt_tree x l -> gt_tree x r -> X.lt x y -> gt_tree x (Node i l y r). -Proof. - unfold gt_tree; intuition_in; order. -Qed. - -Local Hint Resolve lt_leaf gt_leaf lt_tree_node gt_tree_node : core. - -Lemma lt_tree_not_in : - forall (x : elt) (t : tree), lt_tree x t -> ~ InT x t. -Proof. - intros; intro; order. -Qed. - -Lemma lt_tree_trans : - forall x y, X.lt x y -> forall t, lt_tree x t -> lt_tree y t. -Proof. - eauto. -Qed. - -Lemma gt_tree_not_in : - forall (x : elt) (t : tree), gt_tree x t -> ~ InT x t. -Proof. - intros; intro; order. -Qed. - -Lemma gt_tree_trans : - forall x y, X.lt y x -> forall t, gt_tree x t -> gt_tree y t. -Proof. - eauto. -Qed. - -#[global] -Instance lt_tree_compat : Proper (X.eq ==> Logic.eq ==> iff) lt_tree. -Proof. - apply proper_sym_impl_iff_2; auto. - intros x x' Hx s s' Hs H y Hy. subst. setoid_rewrite <- Hx; auto. -Qed. - -#[global] -Instance gt_tree_compat : Proper (X.eq ==> Logic.eq ==> iff) gt_tree. -Proof. - apply proper_sym_impl_iff_2; auto. - intros x x' Hx s s' Hs H y Hy. subst. setoid_rewrite <- Hx; auto. -Qed. - -Local Hint Resolve lt_tree_not_in lt_tree_trans gt_tree_not_in gt_tree_trans : core. - -Ltac induct s x := - induction s as [|i l IHl x' r IHr]; simpl; intros; - [|elim_compare x x'; intros; inv]. - -Ltac auto_tc := auto with typeclass_instances. - -Ltac ok := - inv; change bst with Ok in *; - match goal with - | |- Ok (Node _ _ _ _) => constructor; auto_tc; ok - | |- lt_tree _ (Node _ _ _ _) => apply lt_tree_node; ok - | |- gt_tree _ (Node _ _ _ _) => apply gt_tree_node; ok - | _ => eauto with typeclass_instances - end. - -(** ** Empty set *) - -Lemma empty_spec : Empty empty. -Proof. - intros x H. inversion H. -Qed. - -#[global] -Instance empty_ok : Ok empty. -Proof. - auto. -Qed. - -(** ** Emptyness test *) - -Lemma is_empty_spec : forall s, is_empty s = true <-> Empty s. -Proof. - destruct s as [|c r x l]; simpl; auto. - - split; auto. intros _ x H. inv. - - split; auto. - + try discriminate. - + intro H; elim (H x); auto. -Qed. - -(** ** Membership *) - -Lemma mem_spec : forall s x `{Ok s}, mem x s = true <-> InT x s. -Proof. - split. - - induct s x; now auto. - - induct s x; intuition_in; order. -Qed. - -(** ** Minimal and maximal elements *) - -Lemma min_elt_spec1 s x : min_elt s = Some x -> InT x s. -Proof. -induction s as [|t1 [|] IHs1 y s2 IHs2]; simpl; auto; inversion 1; auto. -Qed. - -Lemma min_elt_spec2 s x y `{Ok s} : - min_elt s = Some x -> InT y s -> ~ X.lt y x. -Proof. -revert x y; induction H as [|? z l r Hl IHl Hr IHr Hlt Hgt]; simpl in *; [discriminate|]. -intros x y He Hi; apply In_node_iff in Hi. -destruct l as [|t l1 w l2]. -+ intros; replace z with x in * by congruence. - destruct Hi as [Hi|[Hi|Hi]]; try order. - apply In_leaf_iff in Hi; contradiction. -+ destruct Hi as [Hi|[Hi|Hi]]. - - apply IHl; assumption. - - intros H; eapply lt_tree_trans in Hlt; [|rewrite <- Hi; eassumption]. - apply min_elt_spec1 in He; apply lt_tree_not_in in Hlt; contradiction. - - intros H. - apply min_elt_spec1, Hlt in He. - elim (gt_tree_not_in y r); [|assumption]. - eapply gt_tree_trans; [|exact Hgt]; order. -Qed. - -Lemma min_elt_spec3 s : min_elt s = None -> Empty s. -Proof. -induction s as [|t1 s1 IHs1 x s2 IHs2]; simpl in *; intros H. -+ inversion 1. -+ destruct s1 as [|? ? y]; [congruence|]. - destruct (IHs1 H y); auto. -Qed. - -Lemma max_elt_spec1 s x : max_elt s = Some x -> InT x s. -Proof. -induction s as [|t1 s1 IHs1 y [|] IHs2]; simpl in *; intros H; [congruence| |auto]. -replace y with x by congruence; auto. -Qed. - -Lemma max_elt_spec2 s x y `{Ok s} : - max_elt s = Some x -> InT y s -> ~ X.lt x y. -Proof. -revert x y; induction H as [|? z l r Hl IHl Hr IHr Hlt Hgt]; simpl in *; [discriminate|]. -intros x y He Hi; apply In_node_iff in Hi. -destruct r as [|t l1 w l2]. -+ intros; replace z with x in * by congruence. - destruct Hi as [Hi|[Hi|Hi]]; try order. - apply In_leaf_iff in Hi; contradiction. -+ destruct Hi as [Hi|[Hi|Hi]]. - - intros H. - apply max_elt_spec1, Hgt in He. - elim (lt_tree_not_in y l); [|assumption]. - eapply lt_tree_trans; [|exact Hlt]; order. - - intros H; eapply gt_tree_trans in Hgt; [|rewrite <- Hi; eassumption]. - apply max_elt_spec1 in He; apply gt_tree_not_in in Hgt; contradiction. - - apply IHr; assumption. -Qed. - -Lemma max_elt_spec3 s : max_elt s = None -> Empty s. -Proof. -induction s as [|t1 s1 IHs1 x s2 IHs2]; simpl in *; intros H. -+ inversion 1. -+ destruct s2 as [|? ? y]; [congruence|]. - destruct (IHs2 H y); auto. -Qed. - -Lemma choose_spec1 : forall s x, choose s = Some x -> InT x s. -Proof. - exact min_elt_spec1. -Qed. - -Lemma choose_spec2 : forall s, choose s = None -> Empty s. -Proof. - exact min_elt_spec3. -Qed. - -Lemma choose_spec3 : forall s s' x x' `{Ok s, Ok s'}, - choose s = Some x -> choose s' = Some x' -> - Equal s s' -> X.eq x x'. -Proof. - unfold choose, Equal; intros s s' x x' Hb Hb' Hx Hx' H. - assert (~X.lt x x'). { - apply min_elt_spec2 with s'; auto. - rewrite <-H; auto using min_elt_spec1. - } - assert (~X.lt x' x). { - apply min_elt_spec2 with s; auto. - rewrite H; auto using min_elt_spec1. - } - elim_compare x x'; intuition. -Qed. - -(** ** Elements *) - -Lemma elements_spec1' : forall s acc x, - InA X.eq x (elements_aux acc s) <-> InT x s \/ InA X.eq x acc. -Proof. - induction s as [ | c l Hl x r Hr ]; simpl; auto. - - intuition. - inversion H0. - - intros. - rewrite Hl. - destruct (Hr acc x0); clear Hl Hr. - intuition; inversion_clear H3; intuition. -Qed. - -Lemma elements_spec1 : forall s x, InA X.eq x (elements s) <-> InT x s. -Proof. - intros; generalize (elements_spec1' s nil x); intuition. - inversion_clear H0. -Qed. - -Lemma elements_spec2' : forall s acc `{Ok s}, sort X.lt acc -> - (forall x y : elt, InA X.eq x acc -> InT y s -> X.lt y x) -> - sort X.lt (elements_aux acc s). -Proof. - induction s as [ | c l Hl y r Hr]; simpl; intuition. - inv. - apply Hl; auto. - - constructor. - + apply Hr; auto. - + eapply InA_InfA; eauto with *. - intros. - destruct (elements_spec1' r acc y0); intuition. - - intros. - inversion_clear H. - + order. - + destruct (elements_spec1' r acc x); intuition eauto. -Qed. - -Lemma elements_spec2 : forall s `(Ok s), sort X.lt (elements s). -Proof. - intros; unfold elements; apply elements_spec2'; auto. - intros; inversion H0. -Qed. -Local Hint Resolve elements_spec2 : core. - -Lemma elements_spec2w : forall s `(Ok s), NoDupA X.eq (elements s). -Proof. - intros. eapply SortA_NoDupA; eauto with *. -Qed. - -Lemma elements_aux_cardinal : - forall s acc, (length acc + cardinal s)%nat = length (elements_aux acc s). -Proof. - simple induction s; simpl; intuition. - rewrite <- H. - simpl. - rewrite <- H0. rewrite (Nat.add_comm (cardinal t0)). - now rewrite <- Nat.add_succ_r, Nat.add_assoc. -Qed. - -Lemma elements_cardinal : forall s : tree, cardinal s = length (elements s). -Proof. - exact (fun s => elements_aux_cardinal s nil). -Qed. - -Definition cardinal_spec (s:tree)(Hs:Ok s) := elements_cardinal s. - -Lemma elements_app : - forall s acc, elements_aux acc s = elements s ++ acc. -Proof. - induction s; simpl; intros; auto. - rewrite IHs1, IHs2. - unfold elements; simpl. - rewrite 2 IHs1, IHs2, !app_nil_r, <- !app_assoc; auto. -Qed. - -Lemma elements_node c l x r : - elements (Node c l x r) = elements l ++ x :: elements r. -Proof. - unfold elements; simpl. - now rewrite !elements_app, !app_nil_r. -Qed. - -Lemma rev_elements_app : - forall s acc, rev_elements_aux acc s = rev_elements s ++ acc. -Proof. - induction s; simpl; intros; auto. - rewrite IHs1, IHs2. - unfold rev_elements; simpl. - rewrite IHs1, 2 IHs2, !app_nil_r, <- !app_assoc; auto. -Qed. - -Lemma rev_elements_node c l x r : - rev_elements (Node c l x r) = rev_elements r ++ x :: rev_elements l. -Proof. - unfold rev_elements; simpl. - now rewrite !rev_elements_app, !app_nil_r. -Qed. - -Lemma rev_elements_rev s : rev_elements s = rev (elements s). -Proof. - induction s as [|c l IHl x r IHr]; trivial. - rewrite elements_node, rev_elements_node, IHl, IHr, rev_app_distr. - simpl. now rewrite <- !app_assoc. -Qed. - -(** The converse of [elements_spec2], used in MSetRBT *) - -(* TODO: TO MIGRATE ELSEWHERE... *) - -Lemma sorted_app_inv l1 l2 : - sort X.lt (l1++l2) -> - sort X.lt l1 /\ sort X.lt l2 /\ - forall x1 x2, InA X.eq x1 l1 -> InA X.eq x2 l2 -> X.lt x1 x2. -Proof. - induction l1 as [|a1 l1 IHl1]. - - simpl; repeat split; auto. - intros. now rewrite InA_nil in *. - - simpl. inversion_clear 1 as [ | ? ? Hs Hhd ]. - destruct (IHl1 Hs) as (H1 & H2 & H3). - repeat split. - * constructor; auto. - destruct l1; simpl in *; auto; inversion_clear Hhd; auto. - * trivial. - * intros x1 x2 Hx1 Hx2. rewrite InA_cons in Hx1. destruct Hx1. - + rewrite H. - apply SortA_InfA_InA with (eqA:=X.eq)(l:=l1++l2); auto_tc. - rewrite InA_app_iff; auto_tc. - + auto. -Qed. - -Lemma elements_sort_ok s : sort X.lt (elements s) -> Ok s. -Proof. - induction s as [|c l IHl x r IHr]. - - auto. - - rewrite elements_node. - intros H. destruct (sorted_app_inv _ _ H) as (H1 & H2 & H3). - inversion_clear H2. - constructor; ok. - * intros y Hy. apply H3. - + now rewrite elements_spec1. - + rewrite InA_cons. now left. - * intros y Hy. - apply SortA_InfA_InA with (eqA:=X.eq)(l:=elements r); auto_tc. - now rewrite elements_spec1. -Qed. - -(** ** [for_all] and [exists] *) - -Lemma for_all_spec s f : Proper (X.eq==>eq) f -> - (for_all f s = true <-> For_all (fun x => f x = true) s). -Proof. - intros Hf; unfold For_all. - induction s as [|i l IHl x r IHr]; simpl; auto. - - split; intros; inv; auto. - - rewrite <- !andb_lazy_alt, !andb_true_iff, IHl, IHr. clear IHl IHr. - intuition_in. eauto. -Qed. - -Lemma exists_spec s f : Proper (X.eq==>eq) f -> - (exists_ f s = true <-> Exists (fun x => f x = true) s). -Proof. - intros Hf; unfold Exists. - induction s as [|i l IHl x r IHr]; simpl; auto. - - split. - * discriminate. - * intros (y,(H,_)); inv. - - rewrite <- !orb_lazy_alt, !orb_true_iff, IHl, IHr. clear IHl IHr. - split; [intros [[H|(y,(H,H'))]|(y,(H,H'))]|intros (y,(H,H'))]. - * exists x; auto. - * exists y; auto. - * exists y; auto. - * inv; [left;left|left;right|right]; try (exists y); eauto. -Qed. - -(** ** Fold *) - -Lemma fold_spec' {A} (f : elt -> A -> A) (s : tree) (i : A) (acc : list elt) : - fold_left (flip f) (elements_aux acc s) i = fold_left (flip f) acc (fold f s i). -Proof. - revert i acc. - induction s as [|c l IHl x r IHr]; simpl; intros; auto. - rewrite IHl. - simpl. unfold flip at 2. - apply IHr. -Qed. - -Lemma fold_spec (s:tree) {A} (i : A) (f : elt -> A -> A) : - fold f s i = fold_left (flip f) (elements s) i. -Proof. - revert i. unfold elements. - induction s as [|c l IHl x r IHr]; simpl; intros; auto. - rewrite fold_spec'. - rewrite IHr. - simpl; auto. -Qed. - - -(** ** Subset *) - -Lemma subsetl_spec : forall subset_l1 l1 x1 c1 s2 - `{Ok (Node c1 l1 x1 Leaf), Ok s2}, - (forall s `{Ok s}, (subset_l1 s = true <-> Subset l1 s)) -> - (subsetl subset_l1 x1 s2 = true <-> Subset (Node c1 l1 x1 Leaf) s2 ). -Proof. - induction s2 as [|c2 l2 IHl2 x2 r2 IHr2]; simpl; intros. - - unfold Subset; intuition; try discriminate. - assert (H': InT x1 Leaf) by auto; inversion H'. - - specialize (IHl2 H). - specialize (IHr2 H). - inv. - elim_compare x1 x2. - - + rewrite H1 by auto; clear H1 IHl2 IHr2. - unfold Subset. intuition_in. - * assert (X.eq a x2) by order; intuition_in. - * assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order. - - + rewrite IHl2 by auto; clear H1 IHl2 IHr2. - unfold Subset. intuition_in. - * assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order. - * assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order. - - + rewrite <-andb_lazy_alt, andb_true_iff, H1 by auto; clear H1 IHl2 IHr2. - unfold Subset. intuition_in. - * constructor 3. setoid_replace a with x1; auto. rewrite <- mem_spec; auto. - * rewrite mem_spec; auto. - assert (InT x1 (Node c2 l2 x2 r2)) by auto; intuition_in; order. -Qed. - - -Lemma subsetr_spec : forall subset_r1 r1 x1 c1 s2, - bst (Node c1 Leaf x1 r1) -> bst s2 -> - (forall s, bst s -> (subset_r1 s = true <-> Subset r1 s)) -> - (subsetr subset_r1 x1 s2 = true <-> Subset (Node c1 Leaf x1 r1) s2). -Proof. - induction s2 as [|c2 l2 IHl2 x2 r2 IHr2]; simpl; intros. - - unfold Subset; intuition; try discriminate. - assert (H': InT x1 Leaf) by auto; inversion H'. - - specialize (IHl2 H). - specialize (IHr2 H). - inv. - elim_compare x1 x2. - - + rewrite H1 by auto; clear H1 IHl2 IHr2. - unfold Subset. intuition_in. - * assert (X.eq a x2) by order; intuition_in. - * assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order. - - + rewrite <-andb_lazy_alt, andb_true_iff, H1 by auto; clear H1 IHl2 IHr2. - unfold Subset. intuition_in. - * constructor 2. setoid_replace a with x1; auto. rewrite <- mem_spec; auto. - * rewrite mem_spec; auto. - assert (InT x1 (Node c2 l2 x2 r2)) by auto; intuition_in; order. - - + rewrite IHr2 by auto; clear H1 IHl2 IHr2. - unfold Subset. intuition_in. - * assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order. - * assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order. -Qed. - -Lemma subset_spec : forall s1 s2 `{Ok s1, Ok s2}, - (subset s1 s2 = true <-> Subset s1 s2). -Proof. - induction s1 as [|c1 l1 IHl1 x1 r1 IHr1]; simpl; intros. - - unfold Subset; intuition_in. - - destruct s2 as [|c2 l2 x2 r2]; simpl; intros. - + unfold Subset; intuition_in; try discriminate. - assert (H': InT x1 Leaf) by auto; inversion H'. - + inv. - elim_compare x1 x2. - - * rewrite <-andb_lazy_alt, andb_true_iff, IHl1, IHr1 by auto. - clear IHl1 IHr1. - unfold Subset; intuition_in. - -- assert (X.eq a x2) by order; intuition_in. - -- assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order. - -- assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order. - - * rewrite <-andb_lazy_alt, andb_true_iff, IHr1 by auto. - rewrite (@subsetl_spec (subset l1) l1 x1 c1) by auto. - clear IHl1 IHr1. - unfold Subset; intuition_in. - -- assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order. - -- assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order. - - * rewrite <-andb_lazy_alt, andb_true_iff, IHl1 by auto. - rewrite (@subsetr_spec (subset r1) r1 x1 c1) by auto. - clear IHl1 IHr1. - unfold Subset; intuition_in. - -- assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order. - -- assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order. -Qed. - - -(** ** Comparison *) - -(** Relations [eq] and [lt] over trees *) - -Module L := MSetInterface.MakeListOrdering X. - -Definition eq := Equal. -#[global] -Instance eq_equiv : Equivalence eq. -Proof. firstorder. Qed. - -Lemma eq_Leq : forall s s', eq s s' <-> L.eq (elements s) (elements s'). -Proof. - unfold eq, Equal, L.eq; intros. - setoid_rewrite elements_spec1. - firstorder. -Qed. - -Definition lt (s1 s2 : tree) : Prop := - exists s1' s2', Ok s1' /\ Ok s2' /\ eq s1 s1' /\ eq s2 s2' - /\ L.lt (elements s1') (elements s2'). - -Declare Equivalent Keys L.eq equivlistA. - -#[global] -Instance lt_strorder : StrictOrder lt. -Proof. - split. - - intros s (s1 & s2 & B1 & B2 & E1 & E2 & L). - assert (eqlistA X.eq (elements s1) (elements s2)). - + apply SortA_equivlistA_eqlistA with (ltA:=X.lt); auto with *. - rewrite <- eq_Leq. transitivity s; auto. symmetry; auto. - + rewrite H in L. - apply (StrictOrder_Irreflexive (elements s2)); auto. - - intros s1 s2 s3 (s1' & s2' & B1 & B2 & E1 & E2 & L12) - (s2'' & s3' & B2' & B3 & E2' & E3 & L23). - exists s1', s3'; do 4 (split; trivial). - assert (eqlistA X.eq (elements s2') (elements s2'')). - + apply SortA_equivlistA_eqlistA with (ltA:=X.lt); auto with *. - rewrite <- eq_Leq. transitivity s2; auto. symmetry; auto. - + transitivity (elements s2'); auto. - rewrite H; auto. -Qed. - -#[global] -Instance lt_compat : Proper (eq==>eq==>iff) lt. -Proof. - intros s1 s2 E12 s3 s4 E34. split. - - intros (s1' & s3' & B1 & B3 & E1 & E3 & LT). - exists s1', s3'; do 2 (split; trivial). - split. - + transitivity s1; auto. symmetry; auto. - + split; auto. transitivity s3; auto. symmetry; auto. - - intros (s1' & s3' & B1 & B3 & E1 & E3 & LT). - exists s1', s3'; do 2 (split; trivial). - split. - + transitivity s2; auto. - + split; auto. transitivity s4; auto. -Qed. - - -(** Proof of the comparison algorithm *) - -(** [flatten_e e] returns the list of elements of [e] i.e. the list - of elements actually compared *) - -Fixpoint flatten_e (e : enumeration) : list elt := match e with - | End => nil - | More x t r => x :: elements t ++ flatten_e r - end. - -Lemma flatten_e_elements : - forall l x r c e, - elements l ++ flatten_e (More x r e) = elements (Node c l x r) ++ flatten_e e. -Proof. - intros. now rewrite elements_node, <- app_assoc. -Qed. - -Lemma cons_1 : forall s e, - flatten_e (cons s e) = elements s ++ flatten_e e. -Proof. - induction s; simpl; auto; intros. - rewrite IHs1; apply flatten_e_elements. -Qed. - -(** Correctness of this comparison *) - -Definition Cmp c x y := CompSpec L.eq L.lt x y c. - -Local Hint Unfold Cmp flip : core. - -Lemma compare_end_Cmp : - forall e2, Cmp (compare_end e2) nil (flatten_e e2). -Proof. - destruct e2; simpl; constructor; auto. reflexivity. -Qed. - -Lemma compare_more_Cmp : forall x1 cont x2 r2 e2 l, - Cmp (cont (cons r2 e2)) l (elements r2 ++ flatten_e e2) -> - Cmp (compare_more x1 cont (More x2 r2 e2)) (x1::l) - (flatten_e (More x2 r2 e2)). -Proof. - simpl; intros; elim_compare x1 x2; simpl; red; auto. -Qed. - -Lemma compare_cont_Cmp : forall s1 cont e2 l, - (forall e, Cmp (cont e) l (flatten_e e)) -> - Cmp (compare_cont s1 cont e2) (elements s1 ++ l) (flatten_e e2). -Proof. - induction s1 as [|c1 l1 Hl1 x1 r1 Hr1]; intros; auto. - rewrite elements_node, <- app_assoc; simpl. - apply Hl1; auto. clear e2. intros [|x2 r2 e2]. - - simpl; auto. - - apply compare_more_Cmp. - rewrite <- cons_1; auto. -Qed. - -Lemma compare_Cmp : forall s1 s2, - Cmp (compare s1 s2) (elements s1) (elements s2). -Proof. - intros; unfold compare. - rewrite <- (app_nil_r (elements s1)). - replace (elements s2) with (flatten_e (cons s2 End)) by - (rewrite cons_1; simpl; rewrite app_nil_r; auto). - apply compare_cont_Cmp; auto. - intros. - apply compare_end_Cmp; auto. -Qed. - -Lemma compare_spec : forall s1 s2 `{Ok s1, Ok s2}, - CompSpec eq lt s1 s2 (compare s1 s2). -Proof. - intros. - destruct (compare_Cmp s1 s2); constructor. - - rewrite eq_Leq; auto. - - intros; exists s1, s2; repeat split; auto. - - intros; exists s2, s1; repeat split; auto. -Qed. - - -(** ** Equality test *) - -Lemma equal_spec : forall s1 s2 `{Ok s1, Ok s2}, - equal s1 s2 = true <-> eq s1 s2. -Proof. -unfold equal; intros s1 s2 B1 B2. -destruct (@compare_spec s1 s2 B1 B2) as [H|H|H]; - split; intros H'; auto; try discriminate. -- rewrite H' in H. elim (StrictOrder_Irreflexive s2); auto. -- rewrite H' in H. elim (StrictOrder_Irreflexive s2); auto. -Qed. - -(** ** A few results about [mindepth] and [maxdepth] *) - -Lemma mindepth_maxdepth s : mindepth s <= maxdepth s. -Proof. - induction s; simpl; auto. - rewrite <- Nat.succ_le_mono. - transitivity (mindepth s1). - - apply Nat.le_min_l. - - transitivity (maxdepth s1). - + trivial. - + apply Nat.le_max_l. -Qed. - -Lemma maxdepth_cardinal s : cardinal s < 2^(maxdepth s). -Proof. - unfold Peano.lt. - induction s as [|c l IHl x r IHr]. - - auto. - - simpl. rewrite <- Nat.add_succ_r, <- Nat.add_succ_l, Nat.add_0_r. - apply Nat.add_le_mono; etransitivity; - try apply IHl; try apply IHr; apply Nat.pow_le_mono; auto. - * apply Nat.le_max_l. - * apply Nat.le_max_r. -Qed. - -Lemma mindepth_cardinal s : 2^(mindepth s) <= S (cardinal s). -Proof. - unfold Peano.lt. - induction s as [|c l IHl x r IHr]. - - auto. - - simpl. rewrite <- Nat.add_succ_r, <- Nat.add_succ_l, Nat.add_0_r. - apply Nat.add_le_mono; etransitivity; - try apply IHl; try apply IHr; apply Nat.pow_le_mono; auto. - * apply Nat.le_min_l. - * apply Nat.le_min_r. -Qed. - -Lemma maxdepth_log_cardinal s : s <> Leaf -> - Nat.log2 (cardinal s) < maxdepth s. -Proof. - intros H. - apply Nat.log2_lt_pow2. - - destruct s; simpl; intuition auto with arith. - - apply maxdepth_cardinal. -Qed. - -Lemma mindepth_log_cardinal s : mindepth s <= Nat.log2 (S (cardinal s)). -Proof. - apply Nat.log2_le_pow2. - - auto with arith. - - apply mindepth_cardinal. -Qed. - -End Props. diff --git a/stdlib/theories/MSets/MSetInterface.v b/stdlib/theories/MSets/MSetInterface.v deleted file mode 100644 index e99348ec10c1..000000000000 --- a/stdlib/theories/MSets/MSetInterface.v +++ /dev/null @@ -1,991 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* bool. - (** Test whether a set is empty or not. *) - - Parameter mem : elt -> t -> bool. - (** [mem x s] tests whether [x] belongs to the set [s]. *) - - Parameter add : elt -> t -> t. - (** [add x s] returns a set containing all elements of [s], - plus [x]. If [x] was already in [s], [s] is returned unchanged. *) - - Parameter singleton : elt -> t. - (** [singleton x] returns the one-element set containing only [x]. *) - - Parameter remove : elt -> t -> t. - (** [remove x s] returns a set containing all elements of [s], - except [x]. If [x] was not in [s], [s] is returned unchanged. *) - - Parameter union : t -> t -> t. - (** Set union. *) - - Parameter inter : t -> t -> t. - (** Set intersection. *) - - Parameter diff : t -> t -> t. - (** Set difference. *) - - Parameter equal : t -> t -> bool. - (** [equal s1 s2] tests whether the sets [s1] and [s2] are - equal, that is, contain equal elements. *) - - Parameter subset : t -> t -> bool. - (** [subset s1 s2] tests whether the set [s1] is a subset of - the set [s2]. *) - - Parameter fold : forall A : Type, (elt -> A -> A) -> t -> A -> A. - (** [fold f s a] computes [(f xN ... (f x2 (f x1 a))...)], - where [x1 ... xN] are the elements of [s]. - The order in which elements of [s] are presented to [f] is - unspecified. *) - - Parameter for_all : (elt -> bool) -> t -> bool. - (** [for_all p s] checks if all elements of the set - satisfy the predicate [p]. *) - - Parameter exists_ : (elt -> bool) -> t -> bool. - (** [exists p s] checks if at least one element of - the set satisfies the predicate [p]. *) - - Parameter filter : (elt -> bool) -> t -> t. - (** [filter p s] returns the set of all elements in [s] - that satisfy predicate [p]. *) - - Parameter partition : (elt -> bool) -> t -> t * t. - (** [partition p s] returns a pair of sets [(s1, s2)], where - [s1] is the set of all the elements of [s] that satisfy the - predicate [p], and [s2] is the set of all the elements of - [s] that do not satisfy [p]. *) - - Parameter cardinal : t -> nat. - (** Return the number of elements of a set. *) - - Parameter elements : t -> list elt. - (** Return the list of all elements of the given set, in any order. *) - - Parameter choose : t -> option elt. - (** Return one element of the given set, or [None] if - the set is empty. Which element is chosen is unspecified. - Equal sets could return different elements. *) - -End HasWOps. - -Module Type WOps (E : DecidableType). - Definition elt := E.t. - Parameter t : Type. (** the abstract type of sets *) - Include HasWOps. -End WOps. - - -(** ** Functorial signature for weak sets - - Weak sets are sets without ordering on base elements, only - a decidable equality. *) - -Module Type WSetsOn (E : DecidableType). - (** First, we ask for all the functions *) - Include WOps E. - - (** Logical predicates *) - Parameter In : elt -> t -> Prop. -#[global] - Declare Instance In_compat : Proper (E.eq==>eq==>iff) In. - - Definition Equal s s' := forall a : elt, In a s <-> In a s'. - Definition Subset s s' := forall a : elt, In a s -> In a s'. - Definition Empty s := forall a : elt, ~ In a s. - Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x. - Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x. - - Notation "s [=] t" := (Equal s t) (at level 70, no associativity). - Notation "s [<=] t" := (Subset s t) (at level 70, no associativity). - - Definition eq : t -> t -> Prop := Equal. - Include IsEq. (** [eq] is obviously an equivalence, for subtyping only *) - Include HasEqDec. - - (** Specifications of set operators *) - - Section Spec. - Variable s s': t. - Variable x y : elt. - Variable f : elt -> bool. - Notation compatb := (Proper (E.eq==>Logic.eq)) (only parsing). - - Parameter mem_spec : mem x s = true <-> In x s. - Parameter equal_spec : equal s s' = true <-> s[=]s'. - Parameter subset_spec : subset s s' = true <-> s[<=]s'. - Parameter empty_spec : Empty empty. - Parameter is_empty_spec : is_empty s = true <-> Empty s. - Parameter add_spec : In y (add x s) <-> E.eq y x \/ In y s. - Parameter remove_spec : In y (remove x s) <-> In y s /\ ~E.eq y x. - Parameter singleton_spec : In y (singleton x) <-> E.eq y x. - Parameter union_spec : In x (union s s') <-> In x s \/ In x s'. - Parameter inter_spec : In x (inter s s') <-> In x s /\ In x s'. - Parameter diff_spec : In x (diff s s') <-> In x s /\ ~In x s'. - Parameter fold_spec : forall (A : Type) (i : A) (f : elt -> A -> A), - fold f s i = fold_left (flip f) (elements s) i. - Parameter cardinal_spec : cardinal s = length (elements s). - Parameter filter_spec : compatb f -> - (In x (filter f s) <-> In x s /\ f x = true). - Parameter for_all_spec : compatb f -> - (for_all f s = true <-> For_all (fun x => f x = true) s). - Parameter exists_spec : compatb f -> - (exists_ f s = true <-> Exists (fun x => f x = true) s). - Parameter partition_spec1 : compatb f -> - fst (partition f s) [=] filter f s. - Parameter partition_spec2 : compatb f -> - snd (partition f s) [=] filter (fun x => negb (f x)) s. - Parameter elements_spec1 : InA E.eq x (elements s) <-> In x s. - (** When compared with ordered sets, here comes the only - property that is really weaker: *) - Parameter elements_spec2w : NoDupA E.eq (elements s). - Parameter choose_spec1 : choose s = Some x -> In x s. - Parameter choose_spec2 : choose s = None -> Empty s. - - End Spec. - -End WSetsOn. - -(** ** Static signature for weak sets - - Similar to the functorial signature [WSetsOn], except that the - module [E] of base elements is incorporated in the signature. *) - -Module Type WSets. - Declare Module E : DecidableType. - Include WSetsOn E. -End WSets. - -(** ** Functorial signature for sets on ordered elements - - Based on [WSetsOn], plus ordering on sets and [min_elt] and [max_elt] - and some stronger specifications for other functions. *) - -Module Type HasOrdOps (Import T:TypElt). - - Parameter compare : t -> t -> comparison. - (** Total ordering between sets. Can be used as the ordering function - for doing sets of sets. *) - - Parameter min_elt : t -> option elt. - (** Return the smallest element of the given set - (with respect to the [E.compare] ordering), - or [None] if the set is empty. *) - - Parameter max_elt : t -> option elt. - (** Same as [min_elt], but returns the largest element of the - given set. *) - -End HasOrdOps. - -Module Type Ops (E : OrderedType) := WOps E <+ HasOrdOps. - - -Module Type SetsOn (E : OrderedType). - Include WSetsOn E <+ HasOrdOps <+ HasLt <+ IsStrOrder. - - Section Spec. - Variable s s': t. - Variable x y : elt. - - Parameter compare_spec : CompSpec eq lt s s' (compare s s'). - - (** Additional specification of [elements] *) - Parameter elements_spec2 : sort E.lt (elements s). - - (** Remark: since [fold] is specified via [elements], this stronger - specification of [elements] has an indirect impact on [fold], - which can now be proved to receive elements in increasing order. - *) - - Parameter min_elt_spec1 : min_elt s = Some x -> In x s. - Parameter min_elt_spec2 : min_elt s = Some x -> In y s -> ~ E.lt y x. - Parameter min_elt_spec3 : min_elt s = None -> Empty s. - - Parameter max_elt_spec1 : max_elt s = Some x -> In x s. - Parameter max_elt_spec2 : max_elt s = Some x -> In y s -> ~ E.lt x y. - Parameter max_elt_spec3 : max_elt s = None -> Empty s. - - (** Additional specification of [choose] *) - Parameter choose_spec3 : choose s = Some x -> choose s' = Some y -> - Equal s s' -> E.eq x y. - - End Spec. - -End SetsOn. - - -(** ** Static signature for sets on ordered elements - - Similar to the functorial signature [SetsOn], except that the - module [E] of base elements is incorporated in the signature. *) - -Module Type Sets. - Declare Module E : OrderedType. - Include SetsOn E. -End Sets. - -Module Type S := Sets. - - -(** ** Some subtyping tests -<< -WSetsOn ---> WSets - | | - | | - V V -SetsOn ---> Sets - -Module S_WS (M : Sets) <: WSets := M. -Module Sfun_WSfun (E:OrderedType)(M : SetsOn E) <: WSetsOn E := M. -Module S_Sfun (M : Sets) <: SetsOn M.E := M. -Module WS_WSfun (M : WSets) <: WSetsOn M.E := M. ->> -*) - - - -(** ** Signatures for set representations with ill-formed values. - - Motivation: - - For many implementation of finite sets (AVL trees, sorted - lists, lists without duplicates), we use the same two-layer - approach: - - - A first module deals with the datatype (eg. list or tree) without - any restriction on the values we consider. In this module (named - "Raw" in the past), some results are stated under the assumption - that some invariant (e.g. sortedness) holds for the input sets. We - also prove that this invariant is preserved by set operators. - - - A second module implements the exact Sets interface by - using a subtype, for instance [{ l : list A | sorted l }]. - This module is a mere wrapper around the first Raw module. - - With the interfaces below, we give some respectability to - the "Raw" modules. This allows the interested users to directly - access them via the interfaces. Even better, we can build once - and for all a functor doing the transition between Raw and usual Sets. - - Description: - - The type [t] of sets may contain ill-formed values on which our - set operators may give wrong answers. In particular, [mem] - may not see a element in a ill-formed set (think for instance of a - unsorted list being given to an optimized [mem] that stops - its search as soon as a strictly larger element is encountered). - - Unlike optimized operators, the [In] predicate is supposed to - always be correct, even on ill-formed sets. Same for [Equal] and - other logical predicates. - - A predicate parameter [Ok] is used to discriminate between - well-formed and ill-formed values. Some lemmas hold only on sets - validating [Ok]. This predicate [Ok] is required to be - preserved by set operators. Moreover, a boolean function [isok] - should exist for identifying (at least some of) the well-formed sets. - -*) - - -Module Type WRawSets (E : DecidableType). - (** First, we ask for all the functions *) - Include WOps E. - - (** Is a set well-formed or ill-formed ? *) - - Parameter IsOk : t -> Prop. - Class Ok (s:t) : Prop := ok : IsOk s. - - (** In order to be able to validate (at least some) particular sets as - well-formed, we ask for a boolean function for (semi-)deciding - predicate [Ok]. If [Ok] isn't decidable, [isok] may be the - always-false function. *) - Parameter isok : t -> bool. - (** MS: - Dangerous instance, the [isok s = true] hypothesis cannot be discharged - with typeclass resolution. Is it really an instance? *) -#[global] - Declare Instance isok_Ok s `(isok s = true) : Ok s | 10. - - (** Logical predicates *) - Parameter In : elt -> t -> Prop. -#[global] - Declare Instance In_compat : Proper (E.eq==>eq==>iff) In. - - Definition Equal s s' := forall a : elt, In a s <-> In a s'. - Definition Subset s s' := forall a : elt, In a s -> In a s'. - Definition Empty s := forall a : elt, ~ In a s. - Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x. - Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x. - - Notation "s [=] t" := (Equal s t) (at level 70, no associativity). - Notation "s [<=] t" := (Subset s t) (at level 70, no associativity). - - Definition eq : t -> t -> Prop := Equal. -#[global] - Declare Instance eq_equiv : Equivalence eq. - - (** First, all operations are compatible with the well-formed predicate. *) - -#[global] - Declare Instance empty_ok : Ok empty. -#[global] - Declare Instance add_ok s x `(Ok s) : Ok (add x s). -#[global] - Declare Instance remove_ok s x `(Ok s) : Ok (remove x s). -#[global] - Declare Instance singleton_ok x : Ok (singleton x). -#[global] - Declare Instance union_ok s s' `(Ok s, Ok s') : Ok (union s s'). -#[global] - Declare Instance inter_ok s s' `(Ok s, Ok s') : Ok (inter s s'). -#[global] - Declare Instance diff_ok s s' `(Ok s, Ok s') : Ok (diff s s'). -#[global] - Declare Instance filter_ok s f `(Ok s) : Ok (filter f s). -#[global] - Declare Instance partition_ok1 s f `(Ok s) : Ok (fst (partition f s)). -#[global] - Declare Instance partition_ok2 s f `(Ok s) : Ok (snd (partition f s)). - - (** Now, the specifications, with constraints on the input sets. *) - - Section Spec. - Variable s s': t. - Variable x y : elt. - Variable f : elt -> bool. - Notation compatb := (Proper (E.eq==>Logic.eq)) (only parsing). - - Parameter mem_spec : forall `{Ok s}, mem x s = true <-> In x s. - Parameter equal_spec : forall `{Ok s, Ok s'}, - equal s s' = true <-> s[=]s'. - Parameter subset_spec : forall `{Ok s, Ok s'}, - subset s s' = true <-> s[<=]s'. - Parameter empty_spec : Empty empty. - Parameter is_empty_spec : is_empty s = true <-> Empty s. - Parameter add_spec : forall `{Ok s}, - In y (add x s) <-> E.eq y x \/ In y s. - Parameter remove_spec : forall `{Ok s}, - In y (remove x s) <-> In y s /\ ~E.eq y x. - Parameter singleton_spec : In y (singleton x) <-> E.eq y x. - Parameter union_spec : forall `{Ok s, Ok s'}, - In x (union s s') <-> In x s \/ In x s'. - Parameter inter_spec : forall `{Ok s, Ok s'}, - In x (inter s s') <-> In x s /\ In x s'. - Parameter diff_spec : forall `{Ok s, Ok s'}, - In x (diff s s') <-> In x s /\ ~In x s'. - Parameter fold_spec : forall (A : Type) (i : A) (f : elt -> A -> A), - fold f s i = fold_left (flip f) (elements s) i. - Parameter cardinal_spec : forall `{Ok s}, - cardinal s = length (elements s). - Parameter filter_spec : compatb f -> - (In x (filter f s) <-> In x s /\ f x = true). - Parameter for_all_spec : compatb f -> - (for_all f s = true <-> For_all (fun x => f x = true) s). - Parameter exists_spec : compatb f -> - (exists_ f s = true <-> Exists (fun x => f x = true) s). - Parameter partition_spec1 : compatb f -> - fst (partition f s) [=] filter f s. - Parameter partition_spec2 : compatb f -> - snd (partition f s) [=] filter (fun x => negb (f x)) s. - Parameter elements_spec1 : InA E.eq x (elements s) <-> In x s. - Parameter elements_spec2w : forall `{Ok s}, NoDupA E.eq (elements s). - Parameter choose_spec1 : choose s = Some x -> In x s. - Parameter choose_spec2 : choose s = None -> Empty s. - - End Spec. - -End WRawSets. - -(** From weak raw sets to weak usual sets *) - -Module WRaw2SetsOn (E:DecidableType)(M:WRawSets E) <: WSetsOn E. - - (** We avoid creating induction principles for the Record *) - Local Unset Elimination Schemes. - - Definition elt := E.t. - - Record t_ := Mkt {this :> M.t; is_ok : M.Ok this}. - Definition t := t_. - Arguments Mkt this {is_ok}. - #[global] - Hint Resolve is_ok : typeclass_instances. - - Definition In (x : elt)(s : t) := M.In x (this s). - Definition Equal (s s' : t) := forall a : elt, In a s <-> In a s'. - Definition Subset (s s' : t) := forall a : elt, In a s -> In a s'. - Definition Empty (s : t) := forall a : elt, ~ In a s. - Definition For_all (P : elt -> Prop)(s : t) := forall x, In x s -> P x. - Definition Exists (P : elt -> Prop)(s : t) := exists x, In x s /\ P x. - - Definition mem (x : elt)(s : t) := M.mem x s. - Definition add (x : elt)(s : t) : t := Mkt (M.add x s). - Definition remove (x : elt)(s : t) : t := Mkt (M.remove x s). - Definition singleton (x : elt) : t := Mkt (M.singleton x). - Definition union (s s' : t) : t := Mkt (M.union s s'). - Definition inter (s s' : t) : t := Mkt (M.inter s s'). - Definition diff (s s' : t) : t := Mkt (M.diff s s'). - Definition equal (s s' : t) := M.equal s s'. - Definition subset (s s' : t) := M.subset s s'. - Definition empty : t := Mkt M.empty. - Definition is_empty (s : t) := M.is_empty s. - Definition elements (s : t) : list elt := M.elements s. - Definition choose (s : t) : option elt := M.choose s. - Definition fold (A : Type)(f : elt -> A -> A)(s : t) : A -> A := M.fold f s. - Definition cardinal (s : t) := M.cardinal s. - Definition filter (f : elt -> bool)(s : t) : t := Mkt (M.filter f s). - Definition for_all (f : elt -> bool)(s : t) := M.for_all f s. - Definition exists_ (f : elt -> bool)(s : t) := M.exists_ f s. - Definition partition (f : elt -> bool)(s : t) : t * t := - let p := M.partition f s in (Mkt (fst p), Mkt (snd p)). - -#[global] - Instance In_compat : Proper (E.eq==>eq==>iff) In. - Proof. repeat red. intros; apply M.In_compat; congruence. Qed. - - Definition eq : t -> t -> Prop := Equal. - -#[global] - Instance eq_equiv : Equivalence eq. - Proof. firstorder. Qed. - - Definition eq_dec : forall (s s':t), { eq s s' }+{ ~eq s s' }. - Proof. - intros (s,Hs) (s',Hs'). - change ({M.Equal s s'}+{~M.Equal s s'}). - destruct (M.equal s s') eqn:H; [left|right]; - rewrite <- M.equal_spec; congruence. - Defined. - - - Section Spec. - Variable s s' : t. - Variable x y : elt. - Variable f : elt -> bool. - Notation compatb := (Proper (E.eq==>Logic.eq)) (only parsing). - - Lemma mem_spec : mem x s = true <-> In x s. - Proof. exact (@M.mem_spec _ _ _). Qed. - Lemma equal_spec : equal s s' = true <-> Equal s s'. - Proof. exact (@M.equal_spec _ _ _ _). Qed. - Lemma subset_spec : subset s s' = true <-> Subset s s'. - Proof. exact (@M.subset_spec _ _ _ _). Qed. - Lemma empty_spec : Empty empty. - Proof. exact M.empty_spec. Qed. - Lemma is_empty_spec : is_empty s = true <-> Empty s. - Proof. exact (@M.is_empty_spec _). Qed. - Lemma add_spec : In y (add x s) <-> E.eq y x \/ In y s. - Proof. exact (@M.add_spec _ _ _ _). Qed. - Lemma remove_spec : In y (remove x s) <-> In y s /\ ~E.eq y x. - Proof. exact (@M.remove_spec _ _ _ _). Qed. - Lemma singleton_spec : In y (singleton x) <-> E.eq y x. - Proof. exact (@M.singleton_spec _ _). Qed. - Lemma union_spec : In x (union s s') <-> In x s \/ In x s'. - Proof. exact (@M.union_spec _ _ _ _ _). Qed. - Lemma inter_spec : In x (inter s s') <-> In x s /\ In x s'. - Proof. exact (@M.inter_spec _ _ _ _ _). Qed. - Lemma diff_spec : In x (diff s s') <-> In x s /\ ~In x s'. - Proof. exact (@M.diff_spec _ _ _ _ _). Qed. - Lemma fold_spec : forall (A : Type) (i : A) (f : elt -> A -> A), - fold f s i = fold_left (fun a e => f e a) (elements s) i. - Proof. exact (@M.fold_spec _). Qed. - Lemma cardinal_spec : cardinal s = length (elements s). - Proof. exact (@M.cardinal_spec s _). Qed. - Lemma filter_spec : compatb f -> - (In x (filter f s) <-> In x s /\ f x = true). - Proof. exact (@M.filter_spec _ _ _). Qed. - Lemma for_all_spec : compatb f -> - (for_all f s = true <-> For_all (fun x => f x = true) s). - Proof. exact (@M.for_all_spec _ _). Qed. - Lemma exists_spec : compatb f -> - (exists_ f s = true <-> Exists (fun x => f x = true) s). - Proof. exact (@M.exists_spec _ _). Qed. - Lemma partition_spec1 : compatb f -> Equal (fst (partition f s)) (filter f s). - Proof. exact (@M.partition_spec1 _ _). Qed. - Lemma partition_spec2 : compatb f -> - Equal (snd (partition f s)) (filter (fun x => negb (f x)) s). - Proof. exact (@M.partition_spec2 _ _). Qed. - Lemma elements_spec1 : InA E.eq x (elements s) <-> In x s. - Proof. exact (@M.elements_spec1 _ _). Qed. - Lemma elements_spec2w : NoDupA E.eq (elements s). - Proof. exact (@M.elements_spec2w _ _). Qed. - Lemma choose_spec1 : choose s = Some x -> In x s. - Proof. exact (@M.choose_spec1 _ _). Qed. - Lemma choose_spec2 : choose s = None -> Empty s. - Proof. exact (@M.choose_spec2 _). Qed. - - End Spec. - -End WRaw2SetsOn. - -Module WRaw2Sets (D:DecidableType)(M:WRawSets D) <: WSets with Module E := D. - Module E := D. - Include WRaw2SetsOn D M. -End WRaw2Sets. - -(** Same approach for ordered sets *) - -Module Type RawSets (E : OrderedType). - Include WRawSets E <+ HasOrdOps <+ HasLt <+ IsStrOrder. - - Section Spec. - Variable s s': t. - Variable x y : elt. - - (** Specification of [compare] *) - Parameter compare_spec : forall `{Ok s, Ok s'}, CompSpec eq lt s s' (compare s s'). - - (** Additional specification of [elements] *) - Parameter elements_spec2 : forall `{Ok s}, sort E.lt (elements s). - - (** Specification of [min_elt] *) - Parameter min_elt_spec1 : min_elt s = Some x -> In x s. - Parameter min_elt_spec2 : forall `{Ok s}, min_elt s = Some x -> In y s -> ~ E.lt y x. - Parameter min_elt_spec3 : min_elt s = None -> Empty s. - - (** Specification of [max_elt] *) - Parameter max_elt_spec1 : max_elt s = Some x -> In x s. - Parameter max_elt_spec2 : forall `{Ok s}, max_elt s = Some x -> In y s -> ~ E.lt x y. - Parameter max_elt_spec3 : max_elt s = None -> Empty s. - - (** Additional specification of [choose] *) - Parameter choose_spec3 : forall `{Ok s, Ok s'}, - choose s = Some x -> choose s' = Some y -> Equal s s' -> E.eq x y. - - End Spec. - -End RawSets. - -(** From Raw to usual sets *) - -Module Raw2SetsOn (O:OrderedType)(M:RawSets O) <: SetsOn O. - Include WRaw2SetsOn O M. - - Definition compare (s s':t) := M.compare s s'. - Definition min_elt (s:t) : option elt := M.min_elt s. - Definition max_elt (s:t) : option elt := M.max_elt s. - Definition lt (s s':t) := M.lt s s'. - - (** Specification of [lt] *) -#[global] - Instance lt_strorder : StrictOrder lt. -Proof. - constructor ; unfold lt; red. - - unfold complement. red. intros. apply (irreflexivity H). - - intros. transitivity y; auto. - Qed. - -#[global] - Instance lt_compat : Proper (eq==>eq==>iff) lt. - Proof. - repeat red. unfold eq, lt. - intros (s1,p1) (s2,p2) E (s1',p1') (s2',p2') E'; simpl. - change (M.eq s1 s2) in E. - change (M.eq s1' s2') in E'. - rewrite E,E'; intuition. - Qed. - - Section Spec. - Variable s s' s'' : t. - Variable x y : elt. - - Lemma compare_spec : CompSpec eq lt s s' (compare s s'). - Proof. unfold compare; destruct (@M.compare_spec s s' _ _); auto. Qed. - - (** Additional specification of [elements] *) - Lemma elements_spec2 : sort O.lt (elements s). - Proof. exact (@M.elements_spec2 _ _). Qed. - - (** Specification of [min_elt] *) - Lemma min_elt_spec1 : min_elt s = Some x -> In x s. - Proof. exact (@M.min_elt_spec1 _ _). Qed. - Lemma min_elt_spec2 : min_elt s = Some x -> In y s -> ~ O.lt y x. - Proof. exact (@M.min_elt_spec2 _ _ _ _). Qed. - Lemma min_elt_spec3 : min_elt s = None -> Empty s. - Proof. exact (@M.min_elt_spec3 _). Qed. - - (** Specification of [max_elt] *) - Lemma max_elt_spec1 : max_elt s = Some x -> In x s. - Proof. exact (@M.max_elt_spec1 _ _). Qed. - Lemma max_elt_spec2 : max_elt s = Some x -> In y s -> ~ O.lt x y. - Proof. exact (@M.max_elt_spec2 _ _ _ _). Qed. - Lemma max_elt_spec3 : max_elt s = None -> Empty s. - Proof. exact (@M.max_elt_spec3 _). Qed. - - (** Additional specification of [choose] *) - Lemma choose_spec3 : - choose s = Some x -> choose s' = Some y -> Equal s s' -> O.eq x y. - Proof. exact (@M.choose_spec3 _ _ _ _ _ _). Qed. - - End Spec. - -End Raw2SetsOn. - -Module Raw2Sets (O:OrderedType)(M:RawSets O) <: Sets with Module E := O. - Module E := O. - Include Raw2SetsOn O M. -End Raw2Sets. - - -(** It is in fact possible to provide an ordering on sets with - very little information on them (more or less only the [In] - predicate). This generic build of ordering is in fact not - used for the moment, we rather use a simpler version - dedicated to sets-as-sorted-lists, see [MakeListOrdering]. -*) - -Module Type IN (O:OrderedType). - Parameter Inline t : Type. - Parameter Inline In : O.t -> t -> Prop. -#[global] - Declare Instance In_compat : Proper (O.eq==>eq==>iff) In. - Definition Equal s s' := forall x, In x s <-> In x s'. - Definition Empty s := forall x, ~In x s. -End IN. - -Module MakeSetOrdering (O:OrderedType)(Import M:IN O). - Module Import MO := OrderedTypeFacts O. - - Definition eq : t -> t -> Prop := Equal. - -#[global] - Instance eq_equiv : Equivalence eq. - Proof. firstorder. Qed. - -#[global] - Instance : Proper (O.eq==>eq==>iff) In. - Proof. - intros x x' Ex s s' Es. rewrite Ex. apply Es. - Qed. - - Definition Below x s := forall y, In y s -> O.lt y x. - Definition Above x s := forall y, In y s -> O.lt x y. - - Definition EquivBefore x s s' := - forall y, O.lt y x -> (In y s <-> In y s'). - - Definition EmptyBetween x y s := - forall z, In z s -> O.lt z y -> O.lt z x. - - Definition lt s s' := exists x, EquivBefore x s s' /\ - ((In x s' /\ Below x s) \/ - (In x s /\ exists y, In y s' /\ O.lt x y /\ EmptyBetween x y s')). - -#[global] - Instance : Proper (O.eq==>eq==>eq==>iff) EquivBefore. - Proof. - unfold EquivBefore. intros x x' E s1 s1' E1 s2 s2' E2. - setoid_rewrite E; setoid_rewrite E1; setoid_rewrite E2; intuition. - Qed. - -#[global] - Instance : Proper (O.eq==>eq==>iff) Below. - Proof. - unfold Below. intros x x' Ex s s' Es. - setoid_rewrite Ex; setoid_rewrite Es; intuition. - Qed. - -#[global] - Instance : Proper (O.eq==>eq==>iff) Above. - Proof. - unfold Above. intros x x' Ex s s' Es. - setoid_rewrite Ex; setoid_rewrite Es; intuition. - Qed. - -#[global] - Instance : Proper (O.eq==>O.eq==>eq==>iff) EmptyBetween. - Proof. - unfold EmptyBetween. intros x x' Ex y y' Ey s s' Es. - setoid_rewrite Ex; setoid_rewrite Ey; setoid_rewrite Es; intuition. - Qed. - -#[global] - Instance lt_compat : Proper (eq==>eq==>iff) lt. - Proof. - unfold lt. intros s1 s1' E1 s2 s2' E2. - setoid_rewrite E1; setoid_rewrite E2; intuition. - Qed. - -#[global] - Instance lt_strorder : StrictOrder lt. - Proof. - split. - - (* irreflexive *) - intros s (x & _ & [(IN,Em)|(IN & y & IN' & LT & Be)]). - + specialize (Em x IN); order. - + specialize (Be x IN LT); order. - - (* transitive *) - intros s1 s2 s3 (x & EQ & [(IN,Pre)|(IN,Lex)]) - (x' & EQ' & [(IN',Pre')|(IN',Lex')]). - + (* 1) Pre / Pre --> Pre *) - assert (O.lt x x') by (specialize (Pre' x IN); auto). - exists x; split. - * intros y Hy; rewrite <- (EQ' y); auto; order. - * left; split; auto. - rewrite <- (EQ' x); auto. - + (* 2) Pre / Lex *) - elim_compare x x'. - * (* 2a) x=x' --> Pre *) - destruct Lex' as (y & INy & LT & Be). - exists y; split. - -- intros z Hz. split; intros INz. - ++ specialize (Pre z INz). rewrite <- (EQ' z), <- (EQ z); auto; order. - ++ specialize (Be z INz Hz). rewrite (EQ z), (EQ' z); auto; order. - -- left; split; auto. - intros z Hz. transitivity x; auto; order. - * (* 2b) x Pre *) - exists x; split. - -- intros z Hz. rewrite <- (EQ' z) by order; auto. - -- left; split; auto. - rewrite <- (EQ' x); auto. - * (* 2c) x>x' --> Lex *) - exists x'; split. - -- intros z Hz. rewrite (EQ z) by order; auto. - -- right; split; auto. - rewrite (EQ x'); auto. - + (* 3) Lex / Pre --> Lex *) - destruct Lex as (y & INy & LT & Be). - specialize (Pre' y INy). - exists x; split. - * intros z Hz. rewrite <- (EQ' z) by order; auto. - * right; split; auto. - exists y; repeat split; auto. - -- rewrite <- (EQ' y); auto. - -- intros z Hz LTz; apply Be; auto. rewrite (EQ' z); auto; order. - + (* 4) Lex / Lex *) - elim_compare x x'. - * (* 4a) x=x' --> impossible *) - destruct Lex as (y & INy & LT & Be). - setoid_replace x with x' in LT; auto. - specialize (Be x' IN' LT); order. - * (* 4b) x Lex *) - exists x; split. - -- intros z Hz. rewrite <- (EQ' z) by order; auto. - -- right; split; auto. - destruct Lex as (y & INy & LT & Be). - elim_compare y x'. - ++ (* 4ba *) - destruct Lex' as (y' & Iny' & LT' & Be'). - exists y'; repeat split; auto. - ** order. - ** intros z Hz LTz. specialize (Be' z Hz LTz). - rewrite <- (EQ' z) in Hz by order. - apply Be; auto. order. - ++ (* 4bb *) - exists y; repeat split; auto. - ** rewrite <- (EQ' y); auto. - ** intros z Hz LTz. apply Be; auto. rewrite (EQ' z); auto; order. - ++ (* 4bc*) - assert (O.lt x' x) by auto. order. - * (* 4c) x>x' --> Lex *) - exists x'; split. - -- intros z Hz. rewrite (EQ z) by order; auto. - -- right; split; auto. - rewrite (EQ x'); auto. - Qed. - - Lemma lt_empty_r : forall s s', Empty s' -> ~ lt s s'. - Proof. - intros s s' Hs' (x & _ & [(IN,_)|(_ & y & IN & _)]). - - elim (Hs' x IN). - - elim (Hs' y IN). - Qed. - - Definition Add x s s' := forall y, In y s' <-> O.eq x y \/ In y s. - - Lemma lt_empty_l : forall x s1 s2 s2', - Empty s1 -> Above x s2 -> Add x s2 s2' -> lt s1 s2'. - Proof. - intros x s1 s2 s2' Em Ab Ad. - exists x; split. - - intros y Hy; split; intros IN. - + elim (Em y IN). - + rewrite (Ad y) in IN; destruct IN as [EQ|IN]. - * order. - * specialize (Ab y IN). order. - - left; split. - + rewrite (Ad x). now left. - + intros y Hy. elim (Em y Hy). - Qed. - - Lemma lt_add_lt : forall x1 x2 s1 s1' s2 s2', - Above x1 s1 -> Above x2 s2 -> Add x1 s1 s1' -> Add x2 s2 s2' -> - O.lt x1 x2 -> lt s1' s2'. - Proof. - intros x1 x2 s1 s1' s2 s2' Ab1 Ab2 Ad1 Ad2 LT. - exists x1; split; [ | right; split]; auto. - - intros y Hy. rewrite (Ad1 y), (Ad2 y). - split; intros [U|U]; try order. - + specialize (Ab1 y U). order. - + specialize (Ab2 y U). order. - - rewrite (Ad1 x1); auto with *. - - exists x2; repeat split; auto. - + rewrite (Ad2 x2); now left. - + intros y. rewrite (Ad2 y). intros [U|U]. - * order. - * specialize (Ab2 y U). order. - Qed. - - Lemma lt_add_eq : forall x1 x2 s1 s1' s2 s2', - Above x1 s1 -> Above x2 s2 -> Add x1 s1 s1' -> Add x2 s2 s2' -> - O.eq x1 x2 -> lt s1 s2 -> lt s1' s2'. - Proof. - intros x1 x2 s1 s1' s2 s2' Ab1 Ab2 Ad1 Ad2 Hx (x & EQ & Disj). - assert (O.lt x1 x). - - destruct Disj as [(IN,_)|(IN,_)]; auto. rewrite Hx; auto. - - exists x; split. - + intros z Hz. rewrite (Ad1 z), (Ad2 z). - split; intros [U|U]; try (left; order); right. - * rewrite <- (EQ z); auto. - * rewrite (EQ z); auto. - + destruct Disj as [(IN,Em)|(IN & y & INy & LTy & Be)]. - * left; split; auto. - -- rewrite (Ad2 x); auto. - -- intros z. rewrite (Ad1 z); intros [U|U]; try specialize (Ab1 z U); auto; order. - * right; split; auto. - -- rewrite (Ad1 x); auto. - -- exists y; repeat split; auto. - ++ rewrite (Ad2 y); auto. - ++ intros z. rewrite (Ad2 z). intros [U|U]; try specialize (Ab2 z U); auto; order. - Qed. - -End MakeSetOrdering. - - -Module MakeListOrdering (O:OrderedType). - Module MO:=OrderedTypeFacts O. - - Local Notation t := (list O.t). - Local Notation In := (InA O.eq). - - Definition eq s s' := forall x, In x s <-> In x s'. - -#[global] - Instance eq_equiv : Equivalence eq := _. - - Inductive lt_list : t -> t -> Prop := - | lt_nil : forall x s, lt_list nil (x :: s) - | lt_cons_lt : forall x y s s', - O.lt x y -> lt_list (x :: s) (y :: s') - | lt_cons_eq : forall x y s s', - O.eq x y -> lt_list s s' -> lt_list (x :: s) (y :: s'). - #[global] - Hint Constructors lt_list : core. - - Definition lt := lt_list. - #[global] - Hint Unfold lt : core. - - #[global] - Instance lt_strorder : StrictOrder lt. - Proof. - split. - - (* irreflexive *) - assert (forall s s', s=s' -> ~lt s s'). { - red; induction 2. - - discriminate. - - inversion H; subst. - apply (StrictOrder_Irreflexive y); auto. - - inversion H; subst; auto. - } - intros s Hs; exact (H s s (eq_refl s) Hs). - - (* transitive *) - intros s s' s'' H; generalize s''; clear s''; elim H. - + intros x l s'' H'; inversion_clear H'; auto. - + intros x x' l l' E s'' H'; inversion_clear H'; auto. - * constructor 2. transitivity x'; auto. - * constructor 2. rewrite <- H0; auto. - + intros. - inversion_clear H3. - * constructor 2. rewrite H0; auto. - * constructor 3; auto. - -- transitivity y; auto. - -- unfold lt in *; auto. - Qed. - -#[global] - Instance lt_compat' : - Proper (eqlistA O.eq==>eqlistA O.eq==>iff) lt. - Proof. - apply proper_sym_impl_iff_2; auto with *. - intros s1 s1' E1 s2 s2' E2 H. - revert s1' E1 s2' E2. - induction H; intros; inversion_clear E1; inversion_clear E2. - - constructor 1. - - constructor 2. MO.order. - - constructor 3. - + MO.order. - + unfold lt in *; auto. - Qed. - - Lemma eq_cons : - forall l1 l2 x y, - O.eq x y -> eq l1 l2 -> eq (x :: l1) (y :: l2). - Proof. - unfold eq; intros l1 l2 x y Exy E12 z. - split; inversion_clear 1. - - left; MO.order. - - right; rewrite <- E12; auto. - - left; MO.order. - - right; rewrite E12; auto. - Qed. - #[global] - Hint Resolve eq_cons : core. - - Lemma cons_CompSpec : forall c x1 x2 l1 l2, O.eq x1 x2 -> - CompSpec eq lt l1 l2 c -> CompSpec eq lt (x1::l1) (x2::l2) c. - Proof. - destruct c; simpl; inversion_clear 2; auto with relations. - Qed. - #[global] - Hint Resolve cons_CompSpec : core. - -End MakeListOrdering. diff --git a/stdlib/theories/MSets/MSetList.v b/stdlib/theories/MSets/MSetList.v deleted file mode 100644 index 653463b0d738..000000000000 --- a/stdlib/theories/MSets/MSetList.v +++ /dev/null @@ -1,935 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* false - | y :: l => - match X.compare x y with - | Lt => false - | Eq => true - | Gt => mem x l - end - end. - - Fixpoint add x s := - match s with - | nil => x :: nil - | y :: l => - match X.compare x y with - | Lt => x :: s - | Eq => s - | Gt => y :: add x l - end - end. - - Definition singleton (x : elt) := x :: nil. - - Fixpoint remove x s : t := - match s with - | nil => nil - | y :: l => - match X.compare x y with - | Lt => s - | Eq => l - | Gt => y :: remove x l - end - end. - - Fixpoint union (s : t) : t -> t := - match s with - | nil => fun s' => s' - | x :: l => - (fix union_aux (s' : t) : t := - match s' with - | nil => s - | x' :: l' => - match X.compare x x' with - | Lt => x :: union l s' - | Eq => x :: union l l' - | Gt => x' :: union_aux l' - end - end) - end. - - Fixpoint inter (s : t) : t -> t := - match s with - | nil => fun _ => nil - | x :: l => - (fix inter_aux (s' : t) : t := - match s' with - | nil => nil - | x' :: l' => - match X.compare x x' with - | Lt => inter l s' - | Eq => x :: inter l l' - | Gt => inter_aux l' - end - end) - end. - - Fixpoint diff (s : t) : t -> t := - match s with - | nil => fun _ => nil - | x :: l => - (fix diff_aux (s' : t) : t := - match s' with - | nil => s - | x' :: l' => - match X.compare x x' with - | Lt => x :: diff l s' - | Eq => diff l l' - | Gt => diff_aux l' - end - end) - end. - - Fixpoint equal (s : t) : t -> bool := - fun s' : t => - match s, s' with - | nil, nil => true - | x :: l, x' :: l' => - match X.compare x x' with - | Eq => equal l l' - | _ => false - end - | _, _ => false - end. - - Fixpoint subset s s' := - match s, s' with - | nil, _ => true - | x :: l, x' :: l' => - match X.compare x x' with - | Lt => false - | Eq => subset l l' - | Gt => subset s l' - end - | _, _ => false - end. - - Definition fold (B : Type) (f : elt -> B -> B) (s : t) (i : B) : B := - fold_left (flip f) s i. - - Fixpoint filter (f : elt -> bool) (s : t) : t := - match s with - | nil => nil - | x :: l => if f x then x :: filter f l else filter f l - end. - - Fixpoint for_all (f : elt -> bool) (s : t) : bool := - match s with - | nil => true - | x :: l => if f x then for_all f l else false - end. - - Fixpoint exists_ (f : elt -> bool) (s : t) : bool := - match s with - | nil => false - | x :: l => if f x then true else exists_ f l - end. - - Fixpoint partition (f : elt -> bool) (s : t) : t * t := - match s with - | nil => (nil, nil) - | x :: l => - let (s1, s2) := partition f l in - if f x then (x :: s1, s2) else (s1, x :: s2) - end. - - Definition cardinal (s : t) : nat := length s. - - Definition elements (x : t) : list elt := x. - - Definition min_elt (s : t) : option elt := - match s with - | nil => None - | x :: _ => Some x - end. - - Fixpoint max_elt (s : t) : option elt := - match s with - | nil => None - | x :: nil => Some x - | _ :: l => max_elt l - end. - - Definition choose := min_elt. - - Fixpoint compare s s' := - match s, s' with - | nil, nil => Eq - | nil, _ => Lt - | _, nil => Gt - | x::s, x'::s' => - match X.compare x x' with - | Eq => compare s s' - | Lt => Lt - | Gt => Gt - end - end. - -End Ops. - -Module MakeRaw (X: OrderedType) <: RawSets X. - Module Import MX := OrderedTypeFacts X. - Module Import ML := OrderedTypeLists X. - - Include Ops X. - - (** ** Proofs of set operation specifications. *) - - Section ForNotations. - - Definition inf x l := - match l with - | nil => true - | y::_ => match X.compare x y with Lt => true | _ => false end - end. - - Fixpoint isok l := - match l with - | nil => true - | x::l => inf x l && isok l - end. - - Notation Sort l := (isok l = true). - Notation Inf := (lelistA X.lt). - Notation In := (InA X.eq). - - Existing Instance X.eq_equiv. - #[local] - Hint Extern 20 => solve [order] : core. - - Definition IsOk s := Sort s. - - Class Ok (s:t) : Prop := ok : Sort s. - - #[local] - Hint Resolve ok : core. - #[local] - Hint Unfold Ok : core. - - Instance Sort_Ok s `(Hs : Sort s) : Ok s := { ok := Hs }. - - Lemma inf_iff : forall x l, Inf x l <-> inf x l = true. - Proof. - intros x l; split; intro H. - - (* -> *) - destruct H; simpl in *. - + reflexivity. - + rewrite <- compare_lt_iff in H; rewrite H; reflexivity. - - (* <- *) - destruct l as [|y ys]; simpl in *. - + constructor; fail. - + revert H; case_eq (X.compare x y); try discriminate; []. - intros Ha _. - rewrite compare_lt_iff in Ha. - constructor; assumption. - Qed. - - Lemma isok_iff : forall l, sort X.lt l <-> Ok l. - Proof. - intro l; split; intro H. - - (* -> *) - elim H. - + constructor; fail. - + intros y ys Ha Hb Hc. - change (inf y ys && isok ys = true). - rewrite inf_iff in Hc. - rewrite andb_true_iff; tauto. - - (* <- *) - induction l as [|x xs]. - + constructor. - + change (inf x xs && isok xs = true) in H. - rewrite andb_true_iff, <- inf_iff in H. - destruct H; constructor; tauto. - Qed. - - #[local] - Hint Extern 1 (Ok _) => rewrite <- isok_iff : core. - - Ltac inv_ok := match goal with - | H:sort X.lt (_ :: _) |- _ => inversion_clear H; inv_ok - | H:sort X.lt nil |- _ => clear H; inv_ok - | H:sort X.lt ?l |- _ => change (Ok l) in H; inv_ok - | H:Ok _ |- _ => rewrite <- isok_iff in H; inv_ok - | |- Ok _ => rewrite <- isok_iff - | _ => idtac - end. - - Ltac inv := invlist InA; inv_ok; invlist lelistA. - Ltac constructors := repeat constructor. - - Ltac sort_inf_in := match goal with - | H:Inf ?x ?l, H':In ?y ?l |- _ => - cut (X.lt x y); [ intro | apply Sort_Inf_In with l; auto] - | _ => fail - end. - - Global Instance isok_Ok s `(isok s = true) : Ok s | 10. - Proof. - intros. assumption. - Qed. - - Definition Equal s s' := forall a : elt, In a s <-> In a s'. - Definition Subset s s' := forall a : elt, In a s -> In a s'. - Definition Empty s := forall a : elt, ~ In a s. - Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x. - Definition Exists (P : elt -> Prop) (s : t) := exists x, In x s /\ P x. - - Lemma mem_spec : - forall (s : t) (x : elt) (Hs : Ok s), mem x s = true <-> In x s. - Proof. - induction s; intros x Hs; inv; simpl. - - intuition. - + discriminate. - + inv. - - elim_compare x a; rewrite InA_cons; intuition; try order. - + discriminate. - + sort_inf_in. order. - + rewrite <- IHs; auto. - + rewrite IHs; auto. - Qed. - - Lemma add_inf : - forall (s : t) (x a : elt), Inf a s -> X.lt a x -> Inf a (add x s). - Proof. - simple induction s; simpl. - - intuition. - - intros; elim_compare x a; inv; intuition. - Qed. - #[local] - Hint Resolve add_inf : core. - - Global Instance add_ok s x : forall `(Ok s), Ok (add x s). - Proof. - repeat rewrite <- isok_iff; revert s x. - simple induction s; simpl. - - intuition. - - intros; elim_compare x a; inv; auto. - Qed. - - Lemma add_spec : - forall (s : t) (x y : elt) (Hs : Ok s), - In y (add x s) <-> X.eq y x \/ In y s. - Proof. - induction s; simpl; intros. - - intuition. inv; auto. - - elim_compare x a; inv; rewrite !InA_cons, ?IHs; intuition. - Qed. - - Lemma remove_inf : - forall (s : t) (x a : elt) (Hs : Ok s), Inf a s -> Inf a (remove x s). - Proof. - induction s; simpl. - - intuition. - - intros; elim_compare x a; inv; auto. - apply Inf_lt with a; auto. - Qed. - #[local] - Hint Resolve remove_inf : core. - - Global Instance remove_ok s x : forall `(Ok s), Ok (remove x s). - Proof. - repeat rewrite <- isok_iff; revert s x. - induction s; simpl. - - intuition. - - intros; elim_compare x a; inv; auto. - Qed. - - Lemma remove_spec : - forall (s : t) (x y : elt) (Hs : Ok s), - In y (remove x s) <-> In y s /\ ~X.eq y x. - Proof. - induction s; simpl; intros. - - intuition; inv; auto. - - elim_compare x a; inv; rewrite !InA_cons, ?IHs; intuition; - try sort_inf_in; try order. - Qed. - - Global Instance singleton_ok x : Ok (singleton x). - Proof. - unfold singleton; simpl; auto. - Qed. - - Lemma singleton_spec : forall x y : elt, In y (singleton x) <-> X.eq y x. - Proof. - unfold singleton; simpl; split; intros; inv; auto. - Qed. - - Ltac induction2 := - simple induction s; - [ simpl; auto; try solve [ intros; inv ] - | intros x l Hrec; simple induction s'; - [ simpl; auto; try solve [ intros; inv ] - | intros x' l' Hrec'; simpl; elim_compare x x'; intros; inv; auto ]]. - - Lemma union_inf : - forall (s s' : t) (a : elt) (Hs : Ok s) (Hs' : Ok s'), - Inf a s -> Inf a s' -> Inf a (union s s'). - Proof. - induction2. - Qed. - #[local] - Hint Resolve union_inf : core. - - Global Instance union_ok s s' : forall `(Ok s, Ok s'), Ok (union s s'). - Proof. - repeat rewrite <- isok_iff; revert s s'. - induction2; constructors; try apply @ok; auto. - - apply Inf_eq with x'; auto; apply union_inf; auto; apply Inf_eq with x; auto; order. - - change (Inf x' (union (x :: l) l')); auto. - Qed. - - Lemma union_spec : - forall (s s' : t) (x : elt) (Hs : Ok s) (Hs' : Ok s'), - In x (union s s') <-> In x s \/ In x s'. - Proof. - induction2; try rewrite ?InA_cons, ?Hrec, ?Hrec'; intuition; inv; auto. - Qed. - - Lemma inter_inf : - forall (s s' : t) (a : elt) (Hs : Ok s) (Hs' : Ok s'), - Inf a s -> Inf a s' -> Inf a (inter s s'). - Proof. - induction2. - - apply Inf_lt with x; auto. - - apply Hrec'; auto. - apply Inf_lt with x'; auto. - Qed. - #[local] - Hint Resolve inter_inf : core. - - Global Instance inter_ok s s' : forall `(Ok s, Ok s'), Ok (inter s s'). - Proof. - repeat rewrite <- isok_iff; revert s s'. - induction2. - constructors; auto. - apply Inf_eq with x'; auto; apply inter_inf; auto; apply Inf_eq with x; auto. - Qed. - - Lemma inter_spec : - forall (s s' : t) (x : elt) (Hs : Ok s) (Hs' : Ok s'), - In x (inter s s') <-> In x s /\ In x s'. - Proof. - induction2; try rewrite ?InA_cons, ?Hrec, ?Hrec'; intuition; inv; auto; - try sort_inf_in; try order. - Qed. - - Lemma diff_inf : - forall (s s' : t) (Hs : Ok s) (Hs' : Ok s') (a : elt), - Inf a s -> Inf a s' -> Inf a (diff s s'). - Proof. - intros s s'; repeat rewrite <- isok_iff; revert s s'. - induction2. - - apply Hrec; trivial. - + apply Inf_lt with x; auto. - + apply Inf_lt with x'; auto. - - apply Hrec'; auto. - apply Inf_lt with x'; auto. - Qed. - #[local] - Hint Resolve diff_inf : core. - - Global Instance diff_ok s s' : forall `(Ok s, Ok s'), Ok (diff s s'). - Proof. - repeat rewrite <- isok_iff; revert s s'. - induction2. - Qed. - - Lemma diff_spec : - forall (s s' : t) (x : elt) (Hs : Ok s) (Hs' : Ok s'), - In x (diff s s') <-> In x s /\ ~In x s'. - Proof. - induction2; try rewrite ?InA_cons, ?Hrec, ?Hrec'; intuition; inv; auto; - try sort_inf_in; try order. - right; intuition; inv; auto. - Qed. - - Lemma equal_spec : - forall (s s' : t) (Hs : Ok s) (Hs' : Ok s'), - equal s s' = true <-> Equal s s'. - Proof. - induction s as [ | x s IH]; intros [ | x' s'] Hs Hs'; simpl. - - intuition reflexivity. - - split; intros H. - + discriminate. - + assert (In x' nil) by (rewrite H; auto). inv. - - split; intros H. - + discriminate. - + assert (In x nil) by (rewrite <-H; auto). inv. - - inv. - elim_compare x x' as C; try discriminate. - + (* x=x' *) - rewrite IH; auto. - split; intros E y; specialize (E y). - * rewrite !InA_cons, E, C; intuition. - * rewrite !InA_cons, C in E. intuition; try sort_inf_in; order. - + (* xx' *) - split; intros E. - * discriminate. - * assert (In x' (x::s)) by (rewrite E; auto). - inv; try sort_inf_in; order. - Qed. - - Lemma subset_spec : - forall (s s' : t) (Hs : Ok s) (Hs' : Ok s'), - subset s s' = true <-> Subset s s'. - Proof. - intros s s'; revert s. - induction s' as [ | x' s' IH]; intros [ | x s] Hs Hs'; simpl; auto. - - split; try red; intros; auto. - - split; intros H. - + discriminate. - + assert (In x nil) by (apply H; auto). inv. - - split; try red; intros; auto. inv. - - inv. elim_compare x x' as C. - + (* x=x' *) - rewrite IH; auto. - split; intros S y; specialize (S y). - * rewrite !InA_cons, C. intuition. - * rewrite !InA_cons, C in S. intuition; try sort_inf_in; order. - + (* xx' *) - rewrite IH; auto. - split; intros S y; specialize (S y). - * rewrite !InA_cons. intuition. - * rewrite !InA_cons in S. rewrite !InA_cons. intuition; try sort_inf_in; order. - Qed. - - Global Instance empty_ok : Ok empty. - Proof. - constructors. - Qed. - - Lemma empty_spec : Empty empty. - Proof. - unfold Empty, empty; intuition; inv. - Qed. - - Lemma is_empty_spec : forall s : t, is_empty s = true <-> Empty s. - Proof. - intros [ | x s]; simpl. - - split; auto. intros _ x H. inv. - - split. - + discriminate. - + intros H. elim (H x); auto. - Qed. - - Lemma elements_spec1 : forall (s : t) (x : elt), In x (elements s) <-> In x s. - Proof. - intuition. - Qed. - - Lemma elements_spec2 : forall (s : t) (Hs : Ok s), sort X.lt (elements s). - Proof. - intro s; repeat rewrite <- isok_iff; auto. - Qed. - - Lemma elements_spec2w : forall (s : t) (Hs : Ok s), NoDupA X.eq (elements s). - Proof. - intro s; repeat rewrite <- isok_iff; auto. - Qed. - - Lemma min_elt_spec1 : forall (s : t) (x : elt), min_elt s = Some x -> In x s. - Proof. - destruct s; simpl; inversion 1; auto. - Qed. - - Lemma min_elt_spec2 : - forall (s : t) (x y : elt) (Hs : Ok s), - min_elt s = Some x -> In y s -> ~ X.lt y x. - Proof. - induction s as [ | x s IH]; simpl; inversion 2; subst. - intros; inv; try sort_inf_in; order. - Qed. - - Lemma min_elt_spec3 : forall s : t, min_elt s = None -> Empty s. - Proof. - destruct s; simpl; red; intuition. - - inv. - - discriminate. - Qed. - - Lemma max_elt_spec1 : forall (s : t) (x : elt), max_elt s = Some x -> In x s. - Proof. - induction s as [ | x s IH]. - - inversion 1. - - destruct s as [ | y s]. - + simpl. inversion 1; subst; auto. - + right; apply IH; auto. - Qed. - - Lemma max_elt_spec2 : - forall (s : t) (x y : elt) (Hs : Ok s), - max_elt s = Some x -> In y s -> ~ X.lt x y. - Proof. - induction s as [ | a s IH]. - - inversion 2. - - destruct s as [ | b s]. - + inversion 2; subst. intros; inv; order. - + intros. inv; auto. - assert (~X.lt x b) by (apply IH; auto). - assert (X.lt a b) by auto. - order. - Qed. - - Lemma max_elt_spec3 : forall s : t, max_elt s = None -> Empty s. - Proof. - induction s as [ | a s IH]. - - red; intuition; inv. - - destruct s as [ | b s]. - + inversion 1. - + intros; elim IH with b; auto. - Qed. - - Definition choose_spec1 : - forall (s : t) (x : elt), choose s = Some x -> In x s := min_elt_spec1. - - Definition choose_spec2 : - forall s : t, choose s = None -> Empty s := min_elt_spec3. - - Lemma choose_spec3: forall s s' x x', Ok s -> Ok s' -> - choose s = Some x -> choose s' = Some x' -> Equal s s' -> X.eq x x'. - Proof. - unfold choose; intros s s' x x' Hs Hs' Hx Hx' H. - assert (~X.lt x x'). { - apply min_elt_spec2 with s'; auto. - rewrite <-H; auto using min_elt_spec1. - } - assert (~X.lt x' x). { - apply min_elt_spec2 with s; auto. - rewrite H; auto using min_elt_spec1. - } - order. - Qed. - - Lemma fold_spec : - forall (s : t) (A : Type) (i : A) (f : elt -> A -> A), - fold f s i = fold_left (flip f) (elements s) i. - Proof. - reflexivity. - Qed. - - Lemma cardinal_spec : - forall (s : t) (Hs : Ok s), - cardinal s = length (elements s). - Proof. - auto. - Qed. - - Lemma filter_inf : - forall (s : t) (x : elt) (f : elt -> bool) (Hs : Ok s), - Inf x s -> Inf x (filter f s). - Proof. - simple induction s; simpl. - - intuition. - - intros x l Hrec a f Hs Ha; inv. - case (f x); auto. - apply Hrec; auto. - apply Inf_lt with x; auto. - Qed. - - Global Instance filter_ok s f : forall `(Ok s), Ok (filter f s). - Proof. - repeat rewrite <- isok_iff; revert s f. - simple induction s; simpl. - - auto. - - intros x l Hrec f Hs; inv. - case (f x); auto. - constructors; auto. - apply filter_inf; auto. - Qed. - - Lemma filter_spec : - forall (s : t) (x : elt) (f : elt -> bool), - Proper (X.eq==>eq) f -> - (In x (filter f s) <-> In x s /\ f x = true). - Proof. - induction s; simpl; intros. - - split; intuition; inv. - - destruct (f a) eqn:F; rewrite !InA_cons, ?IHs; intuition. - + setoid_replace x with a; auto. - + setoid_replace a with x in F; auto; congruence. - Qed. - - Lemma for_all_spec : - forall (s : t) (f : elt -> bool), - Proper (X.eq==>eq) f -> - (for_all f s = true <-> For_all (fun x => f x = true) s). - Proof. - unfold For_all; induction s; simpl; intros. - - split; intros; auto. inv. - - destruct (f a) eqn:F. - + rewrite IHs; auto. firstorder. inv; auto. - setoid_replace x with a; auto. - + split; intros H'. - * discriminate. - * rewrite H' in F; auto. - Qed. - - Lemma exists_spec : - forall (s : t) (f : elt -> bool), - Proper (X.eq==>eq) f -> - (exists_ f s = true <-> Exists (fun x => f x = true) s). - Proof. - unfold Exists; induction s; simpl; intros. - - firstorder. - + discriminate. - + inv. - - destruct (f a) eqn:F. - + firstorder. - + rewrite IHs; auto. - firstorder. - inv. - * setoid_replace a with x in F; auto; congruence. - * exists x; auto. - Qed. - - Lemma partition_inf1 : - forall (s : t) (f : elt -> bool) (x : elt) (Hs : Ok s), - Inf x s -> Inf x (fst (partition f s)). - Proof. - intros s f x; repeat rewrite <- isok_iff; revert s f x. - simple induction s; simpl. - - intuition. - - intros x l Hrec f a Hs Ha; inv. - generalize (Hrec f a H). - case (f x); case (partition f l); simpl. - + auto. - + intros; apply H2; apply Inf_lt with x; auto. - Qed. - - Lemma partition_inf2 : - forall (s : t) (f : elt -> bool) (x : elt) (Hs : Ok s), - Inf x s -> Inf x (snd (partition f s)). - Proof. - intros s f x; repeat rewrite <- isok_iff; revert s f x. - simple induction s; simpl. - - intuition. - - intros x l Hrec f a Hs Ha; inv. - generalize (Hrec f a H). - case (f x); case (partition f l); simpl. - + intros; apply H2; apply Inf_lt with x; auto. - + auto. - Qed. - - Global Instance partition_ok1 s f : forall `(Ok s), Ok (fst (partition f s)). - Proof. - repeat rewrite <- isok_iff; revert s f. - simple induction s; simpl. - - auto. - - intros x l Hrec f Hs; inv. - generalize (Hrec f H); generalize (@partition_inf1 l f x). - case (f x); case (partition f l); simpl; auto. - Qed. - - Global Instance partition_ok2 s f : forall `(Ok s), Ok (snd (partition f s)). - Proof. - repeat rewrite <- isok_iff; revert s f. - simple induction s; simpl. - - auto. - - intros x l Hrec f Hs; inv. - generalize (Hrec f H); generalize (@partition_inf2 l f x). - case (f x); case (partition f l); simpl; auto. - Qed. - - Lemma partition_spec1 : - forall (s : t) (f : elt -> bool), - Proper (X.eq==>eq) f -> Equal (fst (partition f s)) (filter f s). - Proof. - simple induction s; simpl; auto; unfold Equal. - - split; auto. - - intros x l Hrec f Hf. - generalize (Hrec f Hf); clear Hrec. - destruct (partition f l) as [s1 s2]; simpl; intros. - case (f x); simpl; auto. - split; inversion_clear 1; auto. - + constructor 2; rewrite <- H; auto. - + constructor 2; rewrite H; auto. - Qed. - - Lemma partition_spec2 : - forall (s : t) (f : elt -> bool), - Proper (X.eq==>eq) f -> - Equal (snd (partition f s)) (filter (fun x => negb (f x)) s). - Proof. - simple induction s; simpl; auto; unfold Equal. - - split; auto. - - intros x l Hrec f Hf. - generalize (Hrec f Hf); clear Hrec. - destruct (partition f l) as [s1 s2]; simpl; intros. - case (f x); simpl; auto. - split; inversion_clear 1; auto. - + constructor 2; rewrite <- H; auto. - + constructor 2; rewrite H; auto. - Qed. - - End ForNotations. - - Definition In := InA X.eq. -#[global] - Instance In_compat : Proper (X.eq==>eq==> iff) In. - Proof. repeat red; intros; rewrite H, H0; auto. Qed. - - Module L := MakeListOrdering X. - Definition eq := L.eq. - Definition eq_equiv := L.eq_equiv. - Definition lt l1 l2 := - exists l1' l2', Ok l1' /\ Ok l2' /\ eq l1 l1' /\ eq l2 l2' /\ L.lt l1' l2'. - -#[global] - Instance lt_strorder : StrictOrder lt. - Proof. - split. - - intros s (s1 & s2 & B1 & B2 & E1 & E2 & L). - repeat rewrite <- isok_iff in *. - assert (eqlistA X.eq s1 s2). { - apply SortA_equivlistA_eqlistA with (ltA:=X.lt); auto using @ok with *. - transitivity s; auto. symmetry; auto. - } - rewrite H in L. - apply (StrictOrder_Irreflexive s2); auto. - - intros s1 s2 s3 (s1' & s2' & B1 & B2 & E1 & E2 & L12) - (s2'' & s3' & B2' & B3 & E2' & E3 & L23). - exists s1', s3'. - repeat rewrite <- isok_iff in *. - do 4 (split; trivial). - assert (eqlistA X.eq s2' s2''). - + apply SortA_equivlistA_eqlistA with (ltA:=X.lt); auto using @ok with *. - transitivity s2; auto. symmetry; auto. - + transitivity s2'; auto. - rewrite H; auto. - Qed. - -#[global] - Instance lt_compat : Proper (eq==>eq==>iff) lt. - Proof. - intros s1 s2 E12 s3 s4 E34. split. - - intros (s1' & s3' & B1 & B3 & E1 & E3 & LT). - exists s1', s3'; do 2 (split; trivial). - split. - + transitivity s1; auto. symmetry; auto. - + split; auto. transitivity s3; auto. symmetry; auto. - - intros (s1' & s3' & B1 & B3 & E1 & E3 & LT). - exists s1', s3'; do 2 (split; trivial). - split. - + transitivity s2; auto. - + split; auto. transitivity s4; auto. - Qed. - - Lemma compare_spec_aux : forall s s', CompSpec eq L.lt s s' (compare s s'). - Proof. - induction s as [|x s IH]; intros [|x' s']; simpl; intuition auto with relations. - elim_compare x x'; auto. - Qed. - - Lemma compare_spec : forall s s', Ok s -> Ok s' -> - CompSpec eq lt s s' (compare s s'). - Proof. - intros s s' Hs Hs'. - destruct (compare_spec_aux s s'); constructor; auto. - - exists s, s'; repeat split; auto using @ok. - - exists s', s; repeat split; auto using @ok. - Qed. - -End MakeRaw. - -(** * Encapsulation - - Now, in order to really provide a functor implementing [S], we - need to encapsulate everything into a type of strictly ordered lists. *) - -Module Make (X: OrderedType) <: S with Module E := X. - Module Raw := MakeRaw X. - Include Raw2Sets X Raw. -End Make. - -(** For this specific implementation, eq coincides with Leibniz equality *) - -Require Eqdep_dec. - -Module Type OrderedTypeWithLeibniz. - Include OrderedType. - Parameter eq_leibniz : forall x y, eq x y -> x = y. -End OrderedTypeWithLeibniz. - -Module Type SWithLeibniz. - Declare Module E : OrderedTypeWithLeibniz. - Include SetsOn E. - Parameter eq_leibniz : forall x y, eq x y -> x = y. -End SWithLeibniz. - -Module MakeWithLeibniz (X: OrderedTypeWithLeibniz) <: SWithLeibniz with Module E := X. - Module E := X. - Module Raw := MakeRaw X. - Include Raw2SetsOn X Raw. - - Lemma eq_leibniz_list : forall xs ys, eqlistA X.eq xs ys -> xs = ys. - Proof. - induction xs as [|x xs]; intros [|y ys] H; inversion H; [ | ]. - - reflexivity. - - f_equal. - + apply X.eq_leibniz; congruence. - + apply IHxs; subst; assumption. - Qed. - - Lemma eq_leibniz : forall s s', eq s s' -> s = s'. - Proof. - intros [xs Hxs] [ys Hys] Heq. - change (equivlistA X.eq xs ys) in Heq. - assert (H : eqlistA X.eq xs ys). { - rewrite <- Raw.isok_iff in Hxs, Hys. - apply SortA_equivlistA_eqlistA with X.lt; auto with *. - } - apply eq_leibniz_list in H. - subst ys. - f_equal. - apply Eqdep_dec.eq_proofs_unicity. - intros x y; destruct (bool_dec x y); tauto. - Qed. - -End MakeWithLeibniz. diff --git a/stdlib/theories/MSets/MSetPositive.v b/stdlib/theories/MSets/MSetPositive.v deleted file mode 100644 index 2f19dd5f38ee..000000000000 --- a/stdlib/theories/MSets/MSetPositive.v +++ /dev/null @@ -1,1100 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* bool -> tree -> tree. - - Scheme tree_ind := Induction for tree Sort Prop. - - Definition t := tree : Type. - - Definition empty : t := Leaf. - - Fixpoint is_empty (m : t) : bool := - match m with - | Leaf => true - | Node l b r => negb b &&& is_empty l &&& is_empty r - end. - - Fixpoint mem (i : positive) (m : t) {struct m} : bool := - match m with - | Leaf => false - | Node l o r => - match i with - | 1 => o - | i~0 => mem i l - | i~1 => mem i r - end - end. - - Fixpoint add (i : positive) (m : t) : t := - match m with - | Leaf => - match i with - | 1 => Node Leaf true Leaf - | i~0 => Node (add i Leaf) false Leaf - | i~1 => Node Leaf false (add i Leaf) - end - | Node l o r => - match i with - | 1 => Node l true r - | i~0 => Node (add i l) o r - | i~1 => Node l o (add i r) - end - end. - - Definition singleton i := add i empty. - - (** helper function to avoid creating empty trees that are not leaves *) - - Definition node (l : t) (b: bool) (r : t) : t := - if b then Node l b r else - match l,r with - | Leaf,Leaf => Leaf - | _,_ => Node l false r end. - - Fixpoint remove (i : positive) (m : t) {struct m} : t := - match m with - | Leaf => Leaf - | Node l o r => - match i with - | 1 => node l false r - | i~0 => node (remove i l) o r - | i~1 => node l o (remove i r) - end - end. - - Fixpoint union (m m': t) : t := - match m with - | Leaf => m' - | Node l o r => - match m' with - | Leaf => m - | Node l' o' r' => Node (union l l') (o||o') (union r r') - end - end. - - Fixpoint inter (m m': t) : t := - match m with - | Leaf => Leaf - | Node l o r => - match m' with - | Leaf => Leaf - | Node l' o' r' => node (inter l l') (o&&o') (inter r r') - end - end. - - Fixpoint diff (m m': t) : t := - match m with - | Leaf => Leaf - | Node l o r => - match m' with - | Leaf => m - | Node l' o' r' => node (diff l l') (o&&negb o') (diff r r') - end - end. - - Fixpoint equal (m m': t): bool := - match m with - | Leaf => is_empty m' - | Node l o r => - match m' with - | Leaf => is_empty m - | Node l' o' r' => eqb o o' &&& equal l l' &&& equal r r' - end - end. - - Fixpoint subset (m m': t): bool := - match m with - | Leaf => true - | Node l o r => - match m' with - | Leaf => is_empty m - | Node l' o' r' => (negb o ||| o') &&& subset l l' &&& subset r r' - end - end. - - (** reverses [y] and concatenate it with [x] *) - - Fixpoint rev_append (y x : elt) : elt := - match y with - | 1 => x - | y~1 => rev_append y x~1 - | y~0 => rev_append y x~0 - end. - Infix "@" := rev_append (at level 60). - Definition rev x := x@1. - - Section Fold. - - Variables B : Type. - Variable f : positive -> B -> B. - - (** the additional argument, [i], records the current path, in - reverse order (this should be more efficient: we reverse this argument - only at present nodes only, rather than at each node of the tree). - we also use this convention in all functions below - *) - - Fixpoint xfold (m : t) (v : B) (i : positive) := - match m with - | Leaf => v - | Node l true r => - xfold r (f (rev i) (xfold l v i~0)) i~1 - | Node l false r => - xfold r (xfold l v i~0) i~1 - end. - Definition fold m i := xfold m i 1. - - End Fold. - - Section Quantifiers. - - Variable f : positive -> bool. - - Fixpoint xforall (m : t) (i : positive) := - match m with - | Leaf => true - | Node l o r => - (negb o ||| f (rev i)) &&& xforall r i~1 &&& xforall l i~0 - end. - Definition for_all m := xforall m 1. - - Fixpoint xexists (m : t) (i : positive) := - match m with - | Leaf => false - | Node l o r => (o &&& f (rev i)) ||| xexists r i~1 ||| xexists l i~0 - end. - Definition exists_ m := xexists m 1. - - Fixpoint xfilter (m : t) (i : positive) : t := - match m with - | Leaf => Leaf - | Node l o r => node (xfilter l i~0) (o &&& f (rev i)) (xfilter r i~1) - end. - Definition filter m := xfilter m 1. - - Fixpoint xpartition (m : t) (i : positive) : t * t := - match m with - | Leaf => (Leaf,Leaf) - | Node l o r => - let (lt,lf) := xpartition l i~0 in - let (rt,rf) := xpartition r i~1 in - if o then - let fi := f (rev i) in - (node lt fi rt, node lf (negb fi) rf) - else - (node lt false rt, node lf false rf) - end. - Definition partition m := xpartition m 1. - - End Quantifiers. - - (** uses [a] to accumulate values rather than doing a lot of concatenations *) - - Fixpoint xelements (m : t) (i : positive) (a: list positive) := - match m with - | Leaf => a - | Node l false r => xelements l i~0 (xelements r i~1 a) - | Node l true r => xelements l i~0 (rev i :: xelements r i~1 a) - end. - - Definition elements (m : t) := xelements m 1 nil. - - Fixpoint cardinal (m : t) : nat := - match m with - | Leaf => O - | Node l false r => (cardinal l + cardinal r)%nat - | Node l true r => S (cardinal l + cardinal r) - end. - - (** would it be more efficient to use a path like in the above functions ? *) - - Fixpoint choose (m: t) : option elt := - match m with - | Leaf => None - | Node l o r => if o then Some 1 else - match choose l with - | None => option_map xI (choose r) - | Some i => Some i~0 - end - end. - - Fixpoint min_elt (m: t) : option elt := - match m with - | Leaf => None - | Node l o r => - match min_elt l with - | None => if o then Some 1 else option_map xI (min_elt r) - | Some i => Some i~0 - end - end. - - Fixpoint max_elt (m: t) : option elt := - match m with - | Leaf => None - | Node l o r => - match max_elt r with - | None => if o then Some 1 else option_map xO (max_elt l) - | Some i => Some i~1 - end - end. - - (** lexicographic product, defined using a notation to keep things lazy *) - - Notation lex u v := match u with Eq => v | Lt => Lt | Gt => Gt end. - - Definition compare_bool a b := - match a,b with - | false, true => Lt - | true, false => Gt - | _,_ => Eq - end. - - Fixpoint compare (m m': t): comparison := - match m,m' with - | Leaf,_ => if is_empty m' then Eq else Lt - | _,Leaf => if is_empty m then Eq else Gt - | Node l o r,Node l' o' r' => - lex (compare_bool o o') (lex (compare l l') (compare r r')) - end. - - - Definition In i t := mem i t = true. - Definition Equal s s' := forall a : elt, In a s <-> In a s'. - Definition Subset s s' := forall a : elt, In a s -> In a s'. - Definition Empty s := forall a : elt, ~ In a s. - Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x. - Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x. - - Notation "s [=] t" := (Equal s t) (at level 70, no associativity). - Notation "s [<=] t" := (Subset s t) (at level 70, no associativity). - - Definition eq := Equal. - Definition lt m m' := compare m m' = Lt. - - (** Specification of [In] *) - -#[global] - Instance In_compat : Proper (E.eq==>Logic.eq==>iff) In. - Proof. - intros s s' Hs x x' Hx. rewrite Hs, Hx; intuition. - Qed. - - (** Specification of [eq] *) - - Local Instance eq_equiv : Equivalence eq. - Proof. firstorder. Qed. - - (** Specification of [mem] *) - - Lemma mem_spec: forall s x, mem x s = true <-> In x s. - Proof. unfold In. intuition. Qed. - - (** Additional lemmas for mem *) - - Lemma mem_Leaf: forall x, mem x Leaf = false. - Proof. destruct x; trivial. Qed. - - (** Specification of [empty] *) - - Lemma empty_spec : Empty empty. - Proof. unfold Empty, In. intro. rewrite mem_Leaf. discriminate. Qed. - - (** Specification of node *) - - Lemma mem_node: forall x l o r, mem x (node l o r) = mem x (Node l o r). - Proof. - intros x l o r. - case o; trivial. - destruct l; trivial. - destruct r; trivial. - destruct x; reflexivity. - Qed. - Local Opaque node. - - (** Specification of [is_empty] *) - - Lemma is_empty_spec: forall s, is_empty s = true <-> Empty s. - Proof. - unfold Empty, In. - induction s as [|l IHl o r IHr]; simpl. - - firstorder. - - rewrite <- 2andb_lazy_alt, 2andb_true_iff, IHl, IHr. clear IHl IHr. - destruct o; simpl; split. - + intuition discriminate. - + intro H. elim (H 1). reflexivity. - + intros H [a|a|]; apply H || intro; discriminate. - + intro H. split. - * split. - -- reflexivity. - -- intro a. apply (H a~0). - * intro a. apply (H a~1). - Qed. - - (** Specification of [subset] *) - - Lemma subset_Leaf_s: forall s, Leaf [<=] s. - Proof. intros s i Hi. apply empty_spec in Hi. elim Hi. Qed. - - Lemma subset_spec: forall s s', subset s s' = true <-> s [<=] s'. - Proof. - induction s as [|l IHl o r IHr]; intros [|l' o' r']; simpl. - - split; intros. - + apply subset_Leaf_s. - + reflexivity. - - - split; intros. - + apply subset_Leaf_s. - + reflexivity. - - - rewrite <- 2andb_lazy_alt, 2andb_true_iff, 2is_empty_spec. - destruct o; simpl. - + split. - * intuition discriminate. - * intro H. elim (@empty_spec 1). apply H. reflexivity. - + split; intro H. - * destruct H as [[_ Hl] Hr]. - intros [i|i|] Hi. - -- elim (Hr i Hi). - -- elim (Hl i Hi). - -- discriminate. - * split. - -- split. - ++ reflexivity. - ++ unfold Empty. intros a H1. apply (@empty_spec (a~0)), H. assumption. - -- unfold Empty. intros a H1. apply (@empty_spec (a~1)), H. assumption. - - - rewrite <- 2andb_lazy_alt, 2andb_true_iff, IHl, IHr. clear. - destruct o; simpl. - + split; intro H. - * destruct H as [[Ho' Hl] Hr]. rewrite Ho'. - intros i Hi. destruct i. - -- apply (Hr i). assumption. - -- apply (Hl i). assumption. - -- assumption. - * split. - -- split. - ++ destruct o'; trivial. - specialize (H 1). unfold In in H. simpl in H. apply H. reflexivity. - ++ intros i Hi. apply (H i~0). apply Hi. - -- intros i Hi. apply (H i~1). apply Hi. - + split; intros. - * intros i Hi. destruct i; destruct H as [[H Hl] Hr]. - -- apply (Hr i). assumption. - -- apply (Hl i). assumption. - -- discriminate Hi. - * split. - -- split. - ++ reflexivity. - ++ intros i Hi. apply (H i~0). apply Hi. - -- intros i Hi. apply (H i~1). apply Hi. - Qed. - - (** Specification of [equal] (via subset) *) - - Lemma equal_subset: forall s s', equal s s' = subset s s' && subset s' s. - Proof. - induction s as [|l IHl o r IHr]; intros [|l' o' r']; simpl; trivial. - - destruct o. - + reflexivity. - + rewrite andb_comm. reflexivity. - - rewrite <- 6andb_lazy_alt. rewrite eq_iff_eq_true. - rewrite 7andb_true_iff, eqb_true_iff. - rewrite IHl, IHr, 2andb_true_iff. clear IHl IHr. intuition subst. - + destruct o'; reflexivity. - + destruct o'; reflexivity. - + destruct o; auto. destruct o'; trivial. - Qed. - - Lemma equal_spec: forall s s', equal s s' = true <-> Equal s s'. - Proof. - intros. rewrite equal_subset. rewrite andb_true_iff. - rewrite 2subset_spec. unfold Equal, Subset. firstorder. - Qed. - - Lemma eq_dec : forall s s', { eq s s' } + { ~ eq s s' }. - Proof. - unfold eq. - intros. case_eq (equal s s'); intro H. - - left. apply equal_spec, H. - - right. rewrite <- equal_spec. congruence. - Defined. - - (** (Specified) definition of [compare] *) - - Lemma lex_Opp: forall u v u' v', u = CompOpp u' -> v = CompOpp v' -> - lex u v = CompOpp (lex u' v'). - Proof. intros ? ? u' ? -> ->. case u'; reflexivity. Qed. - - Lemma compare_bool_inv: forall b b', - compare_bool b b' = CompOpp (compare_bool b' b). - Proof. intros [|] [|]; reflexivity. Qed. - - Lemma compare_inv: forall s s', compare s s' = CompOpp (compare s' s). - Proof. - induction s as [|l IHl o r IHr]; destruct s' as [|l' o' r']; trivial. - - unfold compare. case is_empty; reflexivity. - - unfold compare. case is_empty; reflexivity. - - simpl. rewrite compare_bool_inv. - case compare_bool; simpl; trivial; apply lex_Opp; auto. - Qed. - - Lemma lex_Eq: forall u v, lex u v = Eq <-> u=Eq /\ v=Eq. - Proof. intros u v; destruct u; intuition discriminate. Qed. - - Lemma compare_bool_Eq: forall b1 b2, - compare_bool b1 b2 = Eq <-> eqb b1 b2 = true. - Proof. intros [|] [|]; intuition discriminate. Qed. - - Lemma compare_equal: forall s s', compare s s' = Eq <-> equal s s' = true. - Proof. - induction s as [|l IHl o r IHr]; destruct s' as [|l' o' r']. - - simpl. tauto. - - unfold compare, equal. case is_empty; intuition discriminate. - - unfold compare, equal. case is_empty; intuition discriminate. - - simpl. rewrite <- 2andb_lazy_alt, 2andb_true_iff. - rewrite <- IHl, <- IHr, <- compare_bool_Eq. clear IHl IHr. - rewrite and_assoc. rewrite <- 2lex_Eq. reflexivity. - Qed. - - - Lemma compare_gt: forall s s', compare s s' = Gt -> lt s' s. - Proof. - unfold lt. intros s s'. rewrite compare_inv. - case compare; trivial; intros; discriminate. - Qed. - - Lemma compare_eq: forall s s', compare s s' = Eq -> eq s s'. - Proof. - unfold eq. intros s s'. rewrite compare_equal, equal_spec. trivial. - Qed. - - Lemma compare_spec : forall s s' : t, CompSpec eq lt s s' (compare s s'). - Proof. - intros. case_eq (compare s s'); intro H; constructor. - - apply compare_eq, H. - - assumption. - - apply compare_gt, H. - Qed. - - Section lt_spec. - - Inductive ct: comparison -> comparison -> comparison -> Prop := - | ct_xxx: forall x, ct x x x - | ct_xex: forall x, ct x Eq x - | ct_exx: forall x, ct Eq x x - | ct_glx: forall x, ct Gt Lt x - | ct_lgx: forall x, ct Lt Gt x. - - Lemma ct_cxe: forall x, ct (CompOpp x) x Eq. - Proof. destruct x; constructor. Qed. - - Lemma ct_xce: forall x, ct x (CompOpp x) Eq. - Proof. destruct x; constructor. Qed. - - Lemma ct_lxl: forall x, ct Lt x Lt. - Proof. destruct x; constructor. Qed. - - Lemma ct_gxg: forall x, ct Gt x Gt. - Proof. destruct x; constructor. Qed. - - Lemma ct_xll: forall x, ct x Lt Lt. - Proof. destruct x; constructor. Qed. - - Lemma ct_xgg: forall x, ct x Gt Gt. - Proof. destruct x; constructor. Qed. - - Local Hint Constructors ct: ct. - Local Hint Resolve ct_cxe ct_xce ct_lxl ct_xll ct_gxg ct_xgg: ct. - Ltac ct := trivial with ct. - - Lemma ct_lex: forall u v w u' v' w', - ct u v w -> ct u' v' w' -> ct (lex u u') (lex v v') (lex w w'). - Proof. - intros u v w u' v' w' H H'. - inversion_clear H; inversion_clear H'; ct; destruct w; ct; destruct w'; ct. - Qed. - - Lemma ct_compare_bool: - forall a b c, ct (compare_bool a b) (compare_bool b c) (compare_bool a c). - Proof. - intros [|] [|] [|]; constructor. - Qed. - - Lemma compare_x_Leaf: forall s, - compare s Leaf = if is_empty s then Eq else Gt. - Proof. - intros. rewrite compare_inv. simpl. case (is_empty s); reflexivity. - Qed. - - Lemma compare_empty_x: forall a, is_empty a = true -> - forall b, compare a b = if is_empty b then Eq else Lt. - Proof. - induction a as [|l IHl o r IHr]; trivial. - destruct o. - - intro; discriminate. - - simpl is_empty. rewrite <- andb_lazy_alt, andb_true_iff. - intros [Hl Hr]. - destruct b as [|l' [|] r']; simpl compare; trivial. - + rewrite Hl, Hr. trivial. - + rewrite (IHl Hl), (IHr Hr). simpl. - case (is_empty l'); case (is_empty r'); trivial. - Qed. - - Lemma compare_x_empty: forall a, is_empty a = true -> - forall b, compare b a = if is_empty b then Eq else Gt. - Proof. - setoid_rewrite <- compare_x_Leaf. - intros. rewrite 2(compare_inv b), (compare_empty_x _ H). reflexivity. - Qed. - - Lemma ct_compare: - forall a b c, ct (compare a b) (compare b c) (compare a c). - Proof. - induction a as [|l IHl o r IHr]; intros s' s''. - - destruct s' as [|l' o' r']; destruct s'' as [|l'' o'' r'']; ct. - + rewrite compare_inv. ct. - + unfold compare at 1. case_eq (is_empty (Node l' o' r')); intro H'. - * rewrite (compare_empty_x _ H'). ct. - * unfold compare at 2. case_eq (is_empty (Node l'' o'' r'')); intro H''. - -- rewrite (compare_x_empty _ H''), H'. ct. - -- ct. - - - destruct s' as [|l' o' r']; destruct s'' as [|l'' o'' r'']. - + ct. - + unfold compare at 2. rewrite compare_x_Leaf. - case_eq (is_empty (Node l o r)); intro H. - * rewrite (compare_empty_x _ H). ct. - * case_eq (is_empty (Node l'' o'' r'')); intro H''. - -- rewrite (compare_x_empty _ H''), H. ct. - -- ct. - - + rewrite 2 compare_x_Leaf. - case_eq (is_empty (Node l o r)); intro H. - * rewrite compare_inv, (compare_x_empty _ H). ct. - * case_eq (is_empty (Node l' o' r')); intro H'. - -- rewrite (compare_x_empty _ H'), H. ct. - -- ct. - - + simpl compare. apply ct_lex. - * apply ct_compare_bool. - * apply ct_lex; trivial. - Qed. - - End lt_spec. - -#[global] - Instance lt_strorder : StrictOrder lt. - Proof. - unfold lt. split. - - intros x H. - assert (compare x x = Eq). - + apply compare_equal, equal_spec. reflexivity. - + congruence. - - intros a b c. assert (H := ct_compare a b c). - inversion_clear H; trivial; intros; discriminate. - Qed. - - Local Instance compare_compat_1 : Proper (eq==>Logic.eq==>Logic.eq) compare. - Proof. - intros x x' Hx y y' Hy. subst y'. - unfold eq in *. rewrite <- equal_spec, <- compare_equal in *. - assert (C:=ct_compare x x' y). rewrite Hx in C. inversion C; auto. - Qed. - -#[global] - Instance compare_compat : Proper (eq==>eq==>Logic.eq) compare. - Proof. - intros x x' Hx y y' Hy. rewrite Hx. - rewrite compare_inv, Hy, <- compare_inv. reflexivity. - Qed. - - Local Instance lt_compat : Proper (eq==>eq==>iff) lt. - Proof. - intros x x' Hx y y' Hy. unfold lt. rewrite Hx, Hy. intuition. - Qed. - - (** Specification of [add] *) - - Lemma add_spec: forall s x y, In y (add x s) <-> y=x \/ In y s. - Proof. - unfold In. intros s x y; revert x y s. - induction x; intros [y|y|] [|l o r]; simpl mem; - try (rewrite IHx; clear IHx); rewrite ?mem_Leaf; intuition congruence. - Qed. - - (** Specification of [remove] *) - - Lemma remove_spec: forall s x y, In y (remove x s) <-> In y s /\ y<>x. - Proof. - unfold In. intros s x y; revert x y s. - induction x; intros [y|y|] [|l o r]; simpl remove; rewrite ?mem_node; - simpl mem; try (rewrite IHx; clear IHx); rewrite ?mem_Leaf; - intuition congruence. - Qed. - - (** Specification of [singleton] *) - - Lemma singleton_spec : forall x y, In y (singleton x) <-> y=x. - Proof. - unfold singleton. intros x y. rewrite add_spec. intuition. - unfold In in *. rewrite mem_Leaf in *. discriminate. - Qed. - - (** Specification of [union] *) - - Lemma union_spec: forall s s' x, In x (union s s') <-> In x s \/ In x s'. - Proof. - unfold In. intros s s' x; revert x s s'. - induction x; destruct s; destruct s'; simpl union; simpl mem; - try (rewrite IHx; clear IHx); try intuition congruence. - apply orb_true_iff. - Qed. - - (** Specification of [inter] *) - - Lemma inter_spec: forall s s' x, In x (inter s s') <-> In x s /\ In x s'. - Proof. - unfold In. intros s s' x; revert x s s'. - induction x; destruct s; destruct s'; simpl inter; rewrite ?mem_node; - simpl mem; try (rewrite IHx; clear IHx); try intuition congruence. - apply andb_true_iff. - Qed. - - (** Specification of [diff] *) - - Lemma diff_spec: forall s s' x, In x (diff s s') <-> In x s /\ ~ In x s'. - Proof. - unfold In. intros s s' x; revert x s s'. - induction x; destruct s; destruct s' as [|l' o' r']; simpl diff; - rewrite ?mem_node; simpl mem; - try (rewrite IHx; clear IHx); try intuition congruence. - rewrite andb_true_iff. destruct o'; intuition discriminate. - Qed. - - (** Specification of [fold] *) - - Lemma fold_spec: forall s (A : Type) (i : A) (f : elt -> A -> A), - fold f s i = fold_left (fun a e => f e a) (elements s) i. - Proof. - unfold fold, elements. intros s A i f. revert s i. - set (f' := fun a e => f e a). - assert (H: forall s i j acc, - fold_left f' acc (xfold f s i j) = - fold_left f' (xelements s j acc) i). - - - induction s as [|l IHl o r IHr]; intros; trivial. - destruct o; simpl xelements; simpl xfold. - + rewrite IHr, <- IHl. reflexivity. - + rewrite IHr. apply IHl. - - - intros. exact (H s i 1 nil). - Qed. - - (** Specification of [cardinal] *) - - Lemma cardinal_spec: forall s, cardinal s = length (elements s). - Proof. - unfold elements. - assert (H: forall s j acc, - (cardinal s + length acc)%nat = length (xelements s j acc)). - - - induction s as [|l IHl b r IHr]; intros j acc; simpl; trivial. destruct b. - + rewrite <- IHl. simpl. rewrite <- IHr. - rewrite <- plus_n_Sm, Nat.add_assoc. reflexivity. - + rewrite <- IHl, <- IHr. rewrite Nat.add_assoc. reflexivity. - - - intros. rewrite <- H. simpl. rewrite Nat.add_comm. reflexivity. - Qed. - - (** Specification of [filter] *) - - Lemma xfilter_spec: forall f s x i, - In x (xfilter f s i) <-> In x s /\ f (i@x) = true. - Proof. - intro f. unfold In. - induction s as [|l IHl o r IHr]; intros x i; simpl xfilter. - - rewrite mem_Leaf. intuition discriminate. - - rewrite mem_node. destruct x; simpl. - + rewrite IHr. reflexivity. - + rewrite IHl. reflexivity. - + rewrite <- andb_lazy_alt. apply andb_true_iff. - Qed. - - Lemma filter_spec: forall s x f, @compat_bool elt E.eq f -> - (In x (filter f s) <-> In x s /\ f x = true). - Proof. intros. apply xfilter_spec. Qed. - - (** Specification of [for_all] *) - - Lemma xforall_spec: forall f s i, - xforall f s i = true <-> For_all (fun x => f (i@x) = true) s. - Proof. - unfold For_all, In. intro f. - induction s as [|l IHl o r IHr]; intros i; simpl. - - intuition discriminate. - - rewrite <- 2andb_lazy_alt, <- orb_lazy_alt, 2 andb_true_iff. - rewrite IHl, IHr. clear IHl IHr. - split. - + intros [[Hi Hr] Hl] x. destruct x; simpl; intro H. - * apply Hr, H. - * apply Hl, H. - * rewrite H in Hi. assumption. - + intro H; intuition. - * specialize (H 1). destruct o. - -- apply H. reflexivity. - -- reflexivity. - * apply H. assumption. - * apply H. assumption. - Qed. - - Lemma for_all_spec: forall s f, @compat_bool elt E.eq f -> - (for_all f s = true <-> For_all (fun x => f x = true) s). - Proof. intros. apply xforall_spec. Qed. - - (** Specification of [exists] *) - - Lemma xexists_spec: forall f s i, - xexists f s i = true <-> Exists (fun x => f (i@x) = true) s. - Proof. - unfold Exists, In. intro f. - induction s as [|l IHl o r IHr]; intros i; simpl. - - firstorder with bool. - - rewrite <- 2orb_lazy_alt, 2orb_true_iff, <- andb_lazy_alt, andb_true_iff. - rewrite IHl, IHr. clear IHl IHr. - split. - + intros [[Hi|[x Hr]]|[x Hl]]. - * exists 1. exact Hi. - * exists x~1. exact Hr. - * exists x~0. exact Hl. - + intros [[x|x|] H]; eauto. - Qed. - - Lemma exists_spec : forall s f, @compat_bool elt E.eq f -> - (exists_ f s = true <-> Exists (fun x => f x = true) s). - Proof. intros. apply xexists_spec. Qed. - - - (** Specification of [partition] *) - - Lemma partition_filter : forall s f, - partition f s = (filter f s, filter (fun x => negb (f x)) s). - Proof. - unfold partition, filter. intros s f. generalize 1 as j. - induction s as [|l IHl o r IHr]; intro j. - - reflexivity. - - destruct o; simpl; rewrite IHl, IHr; reflexivity. - Qed. - - Lemma partition_spec1 : forall s f, @compat_bool elt E.eq f -> - Equal (fst (partition f s)) (filter f s). - Proof. intros. rewrite partition_filter. reflexivity. Qed. - - Lemma partition_spec2 : forall s f, @compat_bool elt E.eq f -> - Equal (snd (partition f s)) (filter (fun x => negb (f x)) s). - Proof. intros. rewrite partition_filter. reflexivity. Qed. - - - (** Specification of [elements] *) - - Notation InL := (InA E.eq). - - Lemma xelements_spec: forall s j acc y, - InL y (xelements s j acc) - <-> - InL y acc \/ exists x, y=(j@x) /\ mem x s = true. - Proof. - induction s as [|l IHl o r IHr]; simpl. - - intros. split; intro H. - + left. assumption. - + destruct H as [H|[x [Hx Hx']]]. - * assumption. - * discriminate. - - - intros j acc y. case o. - + rewrite IHl. rewrite InA_cons. rewrite IHr. clear IHl IHr. split. - * intros [[H|[H|[x [-> H]]]]|[x [-> H]]]; eauto. - -- right. exists x~1. auto. - -- right. exists x~0. auto. - * intros [H|[x [-> H]]]. - -- eauto. - -- destruct x. - ++ left. right. right. exists x; auto. - ++ right. exists x; auto. - ++ left. left. reflexivity. - - + rewrite IHl, IHr. clear IHl IHr. split. - * intros [[H|[x [-> H]]]|[x [-> H]]]. - -- eauto. - -- right. exists x~1. auto. - -- right. exists x~0. auto. - * intros [H|[x [-> H]]]. - -- eauto. - -- destruct x. - ++ left. right. exists x; auto. - ++ right. exists x; auto. - ++ discriminate. - Qed. - - Lemma elements_spec1: forall s x, InL x (elements s) <-> In x s. - Proof. - unfold elements. intros. rewrite xelements_spec. - split; [ intros [A|(y & B & C)] | intros IN ]. - - inversion A. - - simpl in *. congruence. - - right. exists x. auto. - Qed. - - Lemma lt_rev_append: forall j x y, E.lt x y -> E.lt (j@x) (j@y). - Proof. induction j; intros; simpl; auto. Qed. - - Lemma elements_spec2: forall s, sort E.lt (elements s). - Proof. - unfold elements. - assert (H: forall s j acc, - sort E.lt acc -> - (forall x y, In x s -> InL y acc -> E.lt (j@x) y) -> - sort E.lt (xelements s j acc)). - - - induction s as [|l IHl o r IHr]; simpl; trivial. - intros j acc Hacc Hsacc. destruct o. - + apply IHl. - * constructor. - -- apply IHr. - ++ apply Hacc. - ++ intros x y Hx Hy. apply Hsacc; assumption. - -- case_eq (xelements r j~1 acc). - ++ constructor. - ++ intros z q H. constructor. - assert (H': InL z (xelements r j~1 acc)). - ** rewrite H. constructor. reflexivity. - ** { clear H q. rewrite xelements_spec in H'. destruct H' as [Hy|[x [-> Hx]]]. - - apply (Hsacc 1 z); trivial. reflexivity. - - simpl. apply lt_rev_append. exact I. - } - * intros x y Hx Hy. inversion_clear Hy. - -- rewrite H. simpl. apply lt_rev_append. exact I. - -- rewrite xelements_spec in H. destruct H as [Hy|[z [-> Hy]]]. - ++ apply Hsacc; assumption. - ++ simpl. apply lt_rev_append. exact I. - - + apply IHl. - * apply IHr. - -- apply Hacc. - -- intros x y Hx Hy. apply Hsacc; assumption. - * intros x y Hx Hy. rewrite xelements_spec in Hy. - destruct Hy as [Hy|[z [-> Hy]]]. - -- apply Hsacc; assumption. - -- simpl. apply lt_rev_append. exact I. - - - intros. apply H. - + constructor. - + intros x y _ H'. inversion H'. - Qed. - - Lemma elements_spec2w: forall s, NoDupA E.eq (elements s). - Proof. - intro. apply SortA_NoDupA with E.lt; auto with *. - apply elements_spec2. - Qed. - - - (** Specification of [choose] *) - - Lemma choose_spec1: forall s x, choose s = Some x -> In x s. - Proof. - induction s as [| l IHl o r IHr]; simpl. - - intros. discriminate. - - destruct o. - + intros x H. injection H; intros; subst. reflexivity. - + revert IHl. case choose. - * intros p Hp x [= <-]. apply Hp. - reflexivity. - * intros _ x. revert IHr. case choose. - -- intros p Hp [= <-]. apply Hp. - reflexivity. - -- intros. discriminate. - Qed. - - Lemma choose_spec2: forall s, choose s = None -> Empty s. - Proof. - unfold Empty, In. intros s H. - induction s as [|l IHl o r IHr]. - - intro. apply empty_spec. - - destruct o. - + discriminate. - + simpl in H. destruct (choose l). - * discriminate. - * destruct (choose r). - -- discriminate. - -- intros [a|a|]. - ++ apply IHr. reflexivity. - ++ apply IHl. reflexivity. - ++ discriminate. - Qed. - - Lemma choose_empty: forall s, is_empty s = true -> choose s = None. - Proof. - intros s Hs. case_eq (choose s); trivial. - intros p Hp. apply choose_spec1 in Hp. apply is_empty_spec in Hs. - elim (Hs _ Hp). - Qed. - - Lemma choose_spec3': forall s s', Equal s s' -> choose s = choose s'. - Proof. - setoid_rewrite <- equal_spec. - induction s as [|l IHl o r IHr]. - - intros. symmetry. apply choose_empty. assumption. - - - destruct s' as [|l' o' r']. - + generalize (Node l o r) as s. simpl. intros. apply choose_empty. - rewrite equal_spec in H. symmetry in H. rewrite <- equal_spec in H. - assumption. - - + simpl. rewrite <- 2andb_lazy_alt, 2andb_true_iff, eqb_true_iff. - intros [[<- Hl] Hr]. rewrite (IHl _ Hl), (IHr _ Hr). reflexivity. - Qed. - - Lemma choose_spec3: forall s s' x y, - choose s = Some x -> choose s' = Some y -> Equal s s' -> E.eq x y. - Proof. intros s s' x y Hx Hy H. apply choose_spec3' in H. congruence. Qed. - - - (** Specification of [min_elt] *) - - Lemma min_elt_spec1: forall s x, min_elt s = Some x -> In x s. - Proof. - unfold In. - induction s as [| l IHl o r IHr]; simpl. - - intros. discriminate. - - intros x. destruct (min_elt l); intros. - + injection H as [= <-]. apply IHl. reflexivity. - + destruct o; simpl. - * injection H as [= <-]. reflexivity. - * destruct (min_elt r); simpl in *. - -- injection H as [= <-]. apply IHr. reflexivity. - -- discriminate. - Qed. - - Lemma min_elt_spec3: forall s, min_elt s = None -> Empty s. - Proof. - unfold Empty, In. intros s H. - induction s as [|l IHl o r IHr]. - - intro. apply empty_spec. - - intros [a|a|]. - + apply IHr. revert H. clear. simpl. destruct (min_elt r); trivial. - case min_elt; intros; try discriminate. destruct o; discriminate. - + apply IHl. revert H. clear. simpl. destruct (min_elt l); trivial. - intro; discriminate. - + revert H. clear. simpl. case min_elt; intros; try discriminate. - destruct o; discriminate. - Qed. - - Lemma min_elt_spec2: forall s x y, min_elt s = Some x -> In y s -> ~ E.lt y x. - Proof. - unfold In. - induction s as [|l IHl o r IHr]; intros x y H H'. - - discriminate. - - simpl in H. case_eq (min_elt l). - + intros p Hp. rewrite Hp in H. injection H as [= <-]. - destruct y as [z|z|]; simpl; intro; trivial. apply (IHl p z); trivial. - + intro Hp; rewrite Hp in H. apply min_elt_spec3 in Hp. - destruct o. - * injection H as [= <-]. intros Hl. - destruct y as [z|z|]; simpl; trivial. elim (Hp _ H'). - - * destruct (min_elt r). - -- injection H as [= <-]. - destruct y as [z|z|]. - ++ apply (IHr e z); trivial. - ++ elim (Hp _ H'). - ++ discriminate. - -- discriminate. - Qed. - - - (** Specification of [max_elt] *) - - Lemma max_elt_spec1: forall s x, max_elt s = Some x -> In x s. - Proof. - unfold In. - induction s as [| l IHl o r IHr]; simpl. - - intros. discriminate. - - intros x. destruct (max_elt r); intros. - + injection H as [= <-]. apply IHr. reflexivity. - + destruct o; simpl. - * injection H as [= <-]. reflexivity. - * destruct (max_elt l); simpl in *. - -- injection H as [= <-]. apply IHl. reflexivity. - -- discriminate. - Qed. - - Lemma max_elt_spec3: forall s, max_elt s = None -> Empty s. - Proof. - unfold Empty, In. intros s H. - induction s as [|l IHl o r IHr]. - - intro. apply empty_spec. - - intros [a|a|]. - + apply IHr. revert H. clear. simpl. destruct (max_elt r); trivial. - intro; discriminate. - + apply IHl. revert H. clear. simpl. destruct (max_elt l); trivial. - case max_elt; intros; try discriminate. destruct o; discriminate. - + revert H. clear. simpl. case max_elt; intros; try discriminate. - destruct o; discriminate. - Qed. - - Lemma max_elt_spec2: forall s x y, max_elt s = Some x -> In y s -> ~ E.lt x y. - Proof. - unfold In. - induction s as [|l IHl o r IHr]; intros x y H H'. - - discriminate. - - simpl in H. case_eq (max_elt r). - + intros p Hp. rewrite Hp in H. injection H as [= <-]. - destruct y as [z|z|]; simpl; intro; trivial. apply (IHr p z); trivial. - + intro Hp; rewrite Hp in H. apply max_elt_spec3 in Hp. - destruct o. - * injection H as [= <-]. intros Hl. - destruct y as [z|z|]; simpl; trivial. elim (Hp _ H'). - - * destruct (max_elt l). - -- injection H as [= <-]. - destruct y as [z|z|]. - ++ elim (Hp _ H'). - ++ apply (IHl e z); trivial. - ++ discriminate. - -- discriminate. - Qed. - -End PositiveSet. diff --git a/stdlib/theories/MSets/MSetProperties.v b/stdlib/theories/MSets/MSetProperties.v deleted file mode 100644 index 907a9be68fae..000000000000 --- a/stdlib/theories/MSets/MSetProperties.v +++ /dev/null @@ -1,1199 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* E.eq x y \/ In y s. - - Lemma Add_Equal : forall x s s', Add x s s' <-> s' [=] add x s. - Proof. - unfold Add. - split; intros. - - red; intros. - rewrite H; clear H. - fsetdec. - - fsetdec. - Qed. - - Ltac expAdd := repeat rewrite Add_Equal. - - Section BasicProperties. - - Variable s s' s'' s1 s2 s3 : t. - Variable x x' : elt. - - Lemma equal_refl : s[=]s. - Proof. fsetdec. Qed. - - Lemma equal_sym : s[=]s' -> s'[=]s. - Proof. fsetdec. Qed. - - Lemma equal_trans : s1[=]s2 -> s2[=]s3 -> s1[=]s3. - Proof. fsetdec. Qed. - - Lemma subset_refl : s[<=]s. - Proof. fsetdec. Qed. - - Lemma subset_trans : s1[<=]s2 -> s2[<=]s3 -> s1[<=]s3. - Proof. fsetdec. Qed. - - Lemma subset_antisym : s[<=]s' -> s'[<=]s -> s[=]s'. - Proof. fsetdec. Qed. - - Lemma subset_equal : s[=]s' -> s[<=]s'. - Proof. fsetdec. Qed. - - Lemma subset_empty : empty[<=]s. - Proof. fsetdec. Qed. - - Lemma subset_remove_3 : s1[<=]s2 -> remove x s1 [<=] s2. - Proof. fsetdec. Qed. - - Lemma subset_diff : s1[<=]s3 -> diff s1 s2 [<=] s3. - Proof. fsetdec. Qed. - - Lemma subset_add_3 : In x s2 -> s1[<=]s2 -> add x s1 [<=] s2. - Proof. fsetdec. Qed. - - Lemma subset_add_2 : s1[<=]s2 -> s1[<=] add x s2. - Proof. fsetdec. Qed. - - Lemma in_subset : In x s1 -> s1[<=]s2 -> In x s2. - Proof. fsetdec. Qed. - - Lemma double_inclusion : s1[=]s2 <-> s1[<=]s2 /\ s2[<=]s1. - Proof. intuition fsetdec. Qed. - - Lemma empty_is_empty_1 : Empty s -> s[=]empty. - Proof. fsetdec. Qed. - - Lemma empty_is_empty_2 : s[=]empty -> Empty s. - Proof. fsetdec. Qed. - - Lemma add_equal : In x s -> add x s [=] s. - Proof. fsetdec. Qed. - - Lemma add_add : add x (add x' s) [=] add x' (add x s). - Proof. fsetdec. Qed. - - Lemma remove_equal : ~ In x s -> remove x s [=] s. - Proof. fsetdec. Qed. - - Lemma Equal_remove : s[=]s' -> remove x s [=] remove x s'. - Proof. fsetdec. Qed. - - Lemma add_remove : In x s -> add x (remove x s) [=] s. - Proof. fsetdec. Qed. - - Lemma remove_add : ~In x s -> remove x (add x s) [=] s. - Proof. fsetdec. Qed. - - Lemma singleton_equal_add : singleton x [=] add x empty. - Proof. fsetdec. Qed. - - Lemma remove_singleton_empty : - In x s -> remove x s [=] empty -> singleton x [=] s. - Proof. fsetdec. Qed. - - Lemma union_sym : union s s' [=] union s' s. - Proof. fsetdec. Qed. - - Lemma union_subset_equal : s[<=]s' -> union s s' [=] s'. - Proof. fsetdec. Qed. - - Lemma union_equal_1 : s[=]s' -> union s s'' [=] union s' s''. - Proof. fsetdec. Qed. - - Lemma union_equal_2 : s'[=]s'' -> union s s' [=] union s s''. - Proof. fsetdec. Qed. - - Lemma union_assoc : union (union s s') s'' [=] union s (union s' s''). - Proof. fsetdec. Qed. - - Lemma add_union_singleton : add x s [=] union (singleton x) s. - Proof. fsetdec. Qed. - - Lemma union_add : union (add x s) s' [=] add x (union s s'). - Proof. fsetdec. Qed. - - Lemma union_remove_add_1 : - union (remove x s) (add x s') [=] union (add x s) (remove x s'). - Proof. fsetdec. Qed. - - Lemma union_remove_add_2 : In x s -> - union (remove x s) (add x s') [=] union s s'. - Proof. fsetdec. Qed. - - Lemma union_subset_1 : s [<=] union s s'. - Proof. fsetdec. Qed. - - Lemma union_subset_2 : s' [<=] union s s'. - Proof. fsetdec. Qed. - - Lemma union_subset_3 : s[<=]s'' -> s'[<=]s'' -> union s s' [<=] s''. - Proof. fsetdec. Qed. - - Lemma union_subset_4 : s[<=]s' -> union s s'' [<=] union s' s''. - Proof. fsetdec. Qed. - - Lemma union_subset_5 : s[<=]s' -> union s'' s [<=] union s'' s'. - Proof. fsetdec. Qed. - - Lemma empty_union_1 : Empty s -> union s s' [=] s'. - Proof. fsetdec. Qed. - - Lemma empty_union_2 : Empty s -> union s' s [=] s'. - Proof. fsetdec. Qed. - - Lemma not_in_union : ~In x s -> ~In x s' -> ~In x (union s s'). - Proof. fsetdec. Qed. - - Lemma inter_sym : inter s s' [=] inter s' s. - Proof. fsetdec. Qed. - - Lemma inter_subset_equal : s[<=]s' -> inter s s' [=] s. - Proof. fsetdec. Qed. - - Lemma inter_equal_1 : s[=]s' -> inter s s'' [=] inter s' s''. - Proof. fsetdec. Qed. - - Lemma inter_equal_2 : s'[=]s'' -> inter s s' [=] inter s s''. - Proof. fsetdec. Qed. - - Lemma inter_assoc : inter (inter s s') s'' [=] inter s (inter s' s''). - Proof. fsetdec. Qed. - - Lemma union_inter_1 : inter (union s s') s'' [=] union (inter s s'') (inter s' s''). - Proof. fsetdec. Qed. - - Lemma union_inter_2 : union (inter s s') s'' [=] inter (union s s'') (union s' s''). - Proof. fsetdec. Qed. - - Lemma inter_add_1 : In x s' -> inter (add x s) s' [=] add x (inter s s'). - Proof. fsetdec. Qed. - - Lemma inter_add_2 : ~ In x s' -> inter (add x s) s' [=] inter s s'. - Proof. fsetdec. Qed. - - Lemma empty_inter_1 : Empty s -> Empty (inter s s'). - Proof. fsetdec. Qed. - - Lemma empty_inter_2 : Empty s' -> Empty (inter s s'). - Proof. fsetdec. Qed. - - Lemma inter_subset_1 : inter s s' [<=] s. - Proof. fsetdec. Qed. - - Lemma inter_subset_2 : inter s s' [<=] s'. - Proof. fsetdec. Qed. - - Lemma inter_subset_3 : - s''[<=]s -> s''[<=]s' -> s''[<=] inter s s'. - Proof. fsetdec. Qed. - - Lemma empty_diff_1 : Empty s -> Empty (diff s s'). - Proof. fsetdec. Qed. - - Lemma empty_diff_2 : Empty s -> diff s' s [=] s'. - Proof. fsetdec. Qed. - - Lemma diff_subset : diff s s' [<=] s. - Proof. fsetdec. Qed. - - Lemma diff_subset_equal : s[<=]s' -> diff s s' [=] empty. - Proof. fsetdec. Qed. - - Lemma remove_diff_singleton : - remove x s [=] diff s (singleton x). - Proof. fsetdec. Qed. - - Lemma diff_inter_empty : inter (diff s s') (inter s s') [=] empty. - Proof. fsetdec. Qed. - - Lemma diff_inter_all : union (diff s s') (inter s s') [=] s. - Proof. fsetdec. Qed. - - Lemma Add_add : Add x s (add x s). - Proof. expAdd; fsetdec. Qed. - - Lemma Add_remove : In x s -> Add x (remove x s) s. - Proof. expAdd; fsetdec. Qed. - - Lemma union_Add : Add x s s' -> Add x (union s s'') (union s' s''). - Proof. expAdd; fsetdec. Qed. - - Lemma inter_Add : - In x s'' -> Add x s s' -> Add x (inter s s'') (inter s' s''). - Proof. expAdd; fsetdec. Qed. - - Lemma union_Equal : - In x s'' -> Add x s s' -> union s s'' [=] union s' s''. - Proof. expAdd; fsetdec. Qed. - - Lemma inter_Add_2 : - ~In x s'' -> Add x s s' -> inter s s'' [=] inter s' s''. - Proof. expAdd; fsetdec. Qed. - - End BasicProperties. - - #[global] - Hint Immediate equal_sym add_remove remove_add union_sym inter_sym: set. - #[global] - Hint Resolve equal_refl equal_trans subset_refl subset_equal subset_antisym - subset_trans subset_empty subset_remove_3 subset_diff subset_add_3 - subset_add_2 in_subset empty_is_empty_1 empty_is_empty_2 add_equal - remove_equal singleton_equal_add union_subset_equal union_equal_1 - union_equal_2 union_assoc add_union_singleton union_add union_subset_1 - union_subset_2 union_subset_3 inter_subset_equal inter_equal_1 inter_equal_2 - inter_assoc union_inter_1 union_inter_2 inter_add_1 inter_add_2 - empty_inter_1 empty_inter_2 empty_union_1 empty_union_2 empty_diff_1 - empty_diff_2 union_Add inter_Add union_Equal inter_Add_2 not_in_union - inter_subset_1 inter_subset_2 inter_subset_3 diff_subset diff_subset_equal - remove_diff_singleton diff_inter_empty diff_inter_all Add_add Add_remove - Equal_remove add_add : set. - - (** * Properties of elements *) - - Lemma elements_Empty : forall s, Empty s <-> elements s = nil. - Proof. - intros. - unfold Empty. - split; intros. - - assert (forall a, ~ List.In a (elements s)). { - red; intros. - apply (H a). - rewrite elements_iff. - rewrite InA_alt; exists a; auto with relations. - } - destruct (elements s); auto. - elim (H0 e); simpl; auto. - - red; intros. - rewrite elements_iff in H0. - rewrite InA_alt in H0; destruct H0. - rewrite H in H0; destruct H0 as (_,H0); inversion H0. - Qed. - - Lemma elements_empty : elements empty = nil. - Proof. - rewrite <-elements_Empty; auto with set. - Qed. - - (** * Conversions between lists and sets *) - - Definition of_list (l : list elt) := List.fold_right add empty l. - - Definition to_list := elements. - - Lemma of_list_1 : forall l x, In x (of_list l) <-> InA E.eq x l. - Proof. - induction l; simpl; intro x. - - rewrite empty_iff, InA_nil. intuition. - - rewrite add_iff, InA_cons, IHl. intuition. - Qed. - - Lemma of_list_2 : forall l, equivlistA E.eq (to_list (of_list l)) l. - Proof. - unfold to_list; red; intros. - rewrite <- elements_iff; apply of_list_1. - Qed. - - Lemma of_list_3 : forall s, of_list (to_list s) [=] s. - Proof. - unfold to_list; red; intros. - rewrite of_list_1; symmetry; apply elements_iff. - Qed. - - (** * Fold *) - - Section Fold. - - Notation NoDup := (NoDupA E.eq). - Notation InA := (InA E.eq). - - (** Alternative specification via [fold_right] *) - - Lemma fold_spec_right (s:t)(A:Type)(i:A)(f : elt -> A -> A) : - fold f s i = List.fold_right f i (rev (elements s)). - Proof. - rewrite fold_spec. symmetry. apply fold_left_rev_right. - Qed. - - (** ** Induction principles for fold (contributed by S. Lescuyer) *) - - (** In the following lemma, the step hypothesis is deliberately restricted - to the precise set s we are considering. *) - - Theorem fold_rec : - forall (A:Type)(P : t -> A -> Type)(f : elt -> A -> A)(i:A)(s:t), - (forall s', Empty s' -> P s' i) -> - (forall x a s' s'', In x s -> ~In x s' -> Add x s' s'' -> - P s' a -> P s'' (f x a)) -> - P s (fold f s i). - Proof. - intros A P f i s Pempty Pstep. - rewrite fold_spec_right. set (l:=rev (elements s)). - 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 *. - } - 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 - (unfold l; intros; rewrite elements_iff, InA_rev; intuition). - clear Pstep; clearbody l; revert s Hsame; induction l. - - (* empty *) - intros s Hsame; simpl. - apply Pempty. intro x. rewrite Hsame, InA_nil; intuition. - - (* step *) - intros s Hsame; simpl. - apply Pstep' with (of_list l); auto with relations. - + inversion_clear Hdup; rewrite of_list_1; auto. - + red. intros. rewrite Hsame, of_list_1, InA_cons; intuition. - + apply IHl. - * intros; eapply Pstep'; eauto. - * inversion_clear Hdup; auto. - * exact (of_list_1 l). - Qed. - - (** Same, with [empty] and [add] instead of [Empty] and [Add]. In this - case, [P] must be compatible with equality of sets *) - - Theorem fold_rec_bis : - forall (A:Type)(P : t -> A -> Type)(f : elt -> A -> A)(i:A)(s:t), - (forall s s' a, s[=]s' -> P s a -> P s' a) -> - (P empty i) -> - (forall x a s', In x s -> ~In x s' -> P s' a -> P (add x s') (f x a)) -> - P s (fold f s i). - Proof. - intros A P f i s Pmorphism Pempty Pstep. - apply fold_rec; intros. - - apply Pmorphism with empty; auto with set. - - rewrite Add_Equal in H1; auto with set. - apply Pmorphism with (add x s'); auto with set. - Qed. - - Lemma fold_rec_nodep : - forall (A:Type)(P : A -> Type)(f : elt -> A -> A)(i:A)(s:t), - P i -> (forall x a, In x s -> P a -> P (f x a)) -> - P (fold f s i). - Proof. - intros; apply fold_rec_bis with (P:=fun _ => P); auto. - Qed. - - (** [fold_rec_weak] is a weaker principle than [fold_rec_bis] : - the step hypothesis must here be applicable to any [x]. - At the same time, it looks more like an induction principle, - and hence can be easier to use. *) - - Lemma fold_rec_weak : - forall (A:Type)(P : t -> A -> Type)(f : elt -> A -> A)(i:A), - (forall s s' a, s[=]s' -> P s a -> P s' a) -> - P empty i -> - (forall x a s, ~In x s -> P s a -> P (add x s) (f x a)) -> - forall s, P s (fold f s i). - Proof. - intros; apply fold_rec_bis; auto. - Qed. - - Lemma fold_rel : - forall (A B:Type)(R : A -> B -> Type) - (f : elt -> A -> A)(g : elt -> B -> B)(i : A)(j : B)(s : t), - R i j -> - (forall x a b, In x s -> R a b -> R (f x a) (g x b)) -> - R (fold f s i) (fold g s j). - Proof. - 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 *). - clearbody l; clear Rstep s. - induction l; simpl; auto with relations. - Qed. - - (** From the induction principle on [fold], we can deduce some general - induction principles on sets. *) - - Lemma set_induction : - forall P : t -> Type, - (forall s, Empty s -> P s) -> - (forall s s', P s -> forall x, ~In x s -> Add x s s' -> P s') -> - forall s, P s. - Proof. - intros. apply (@fold_rec _ (fun s _ => P s) (fun _ _ => tt) tt s); eauto. - Qed. - - Lemma set_induction_bis : - forall P : t -> Type, - (forall s s', s [=] s' -> P s -> P s') -> - P empty -> - (forall x s, ~In x s -> P s -> P (add x s)) -> - forall s, P s. - Proof. - intros. - apply (@fold_rec_bis _ (fun s _ => P s) (fun _ _ => tt) tt s); eauto. - Qed. - - (** [fold] can be used to reconstruct the same initial set. *) - - Lemma fold_identity : forall s, fold add s empty [=] s. - Proof. - intros. - apply fold_rec with (P:=fun s acc => acc[=]s); auto with set. - intros. rewrite H2; rewrite Add_Equal in H1; auto with set. - Qed. - - (** ** Alternative (weaker) specifications for [fold] *) - - (** When [MSets] was first designed, the order in which Ocaml's [Set.fold] - takes the set elements was unspecified. This specification reflects - this fact: - *) - - Lemma fold_0 : - forall s (A : Type) (i : A) (f : elt -> A -> A), - exists l : list elt, - NoDup l /\ - (forall x : elt, In x s <-> InA x l) /\ - fold f s i = fold_right f i l. - Proof. - intros; exists (rev (elements s)); split. - - apply NoDupA_rev; auto with *. - - split; intros. - + rewrite elements_iff; do 2 rewrite InA_alt. - split; destruct 1; generalize (In_rev (elements s) x0); exists x0; intuition. - + apply fold_spec_right. - Qed. - - (** An alternate (and previous) specification for [fold] was based on - the recursive structure of a set. It is now lemmas [fold_1] and - [fold_2]. *) - - Lemma fold_1 : - forall s (A : Type) (eqA : A -> A -> Prop) - (st : Equivalence eqA) (i : A) (f : elt -> A -> A), - Empty s -> eqA (fold f s i) i. - Proof. - unfold Empty; intros; destruct (fold_0 s i f) as (l,(H1, (H2, H3))). - rewrite H3; clear H3. - generalize H H2; clear H H2; case l; simpl; intros. - - reflexivity. - - elim (H e). - elim (H2 e); intuition. - Qed. - - Lemma fold_2 : - forall s s' x (A : Type) (eqA : A -> A -> Prop) - (st : Equivalence eqA) (i : A) (f : elt -> A -> A), - Proper (E.eq==>eqA==>eqA) f -> - transpose eqA f -> - ~ In x s -> Add x s s' -> eqA (fold f s' i) (f x (fold f s i)). - Proof. - 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. - - eauto with *. - - rewrite <- Hl1; auto. - - intros a; rewrite InA_cons; rewrite <- Hl1; rewrite <- Hl'1; - rewrite (H2 a); intuition. - Qed. - - (** In fact, [fold] on empty sets is more than equivalent to - the initial element, it is Leibniz-equal to it. *) - - Lemma fold_1b : - forall s (A : Type)(i : A) (f : elt -> A -> A), - Empty s -> (fold f s i) = i. - Proof. - intros. - rewrite FM.fold_1. - rewrite elements_Empty in H; rewrite H; simpl; auto. - Qed. - - Section Fold_More. - - Variables (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA). - Variables (f:elt->A->A)(Comp:Proper (E.eq==>eqA==>eqA) f)(Ass:transpose eqA f). - - Lemma fold_commutes : forall i s x, - eqA (fold f s (f x i)) (f x (fold f s i)). - Proof. - 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 relations. - Qed. - - (** ** Fold is a morphism *) - - Lemma fold_init : forall i i' s, eqA i i' -> - eqA (fold f s i) (fold f s i'). - Proof. - intros. apply fold_rel with (R:=eqA); auto. - intros; apply Comp; auto with relations. - Qed. - - Lemma fold_equal : - forall i s s', s[=]s' -> eqA (fold f s i) (fold f s' i). - Proof. - intros i s; pattern s; apply set_induction; clear s; intros. - - transitivity i. - + apply fold_1; auto. - + symmetry; apply fold_1; auto. - rewrite <- H0; auto. - - transitivity (f x (fold f s i)). - + apply fold_2 with (eqA := eqA); auto. - + symmetry; apply fold_2 with (eqA := eqA); auto. - unfold Add in *; intros. - rewrite <- H2; auto. - Qed. - - (** ** Fold and other set operators *) - - Lemma fold_empty : forall i, fold f empty i = i. - Proof. - intros i; apply fold_1b; auto with set. - Qed. - - Lemma fold_add : forall i s x, ~In x s -> - eqA (fold f (add x s) i) (f x (fold f s i)). - Proof. - intros; apply fold_2 with (eqA := eqA); auto with set. - Qed. - - Lemma add_fold : forall i s x, In x s -> - eqA (fold f (add x s) i) (fold f s i). - Proof. - intros; apply fold_equal; auto with set. - Qed. - - Lemma remove_fold_1: forall i s x, In x s -> - eqA (f x (fold f (remove x s) i)) (fold f s i). - Proof. - intros. - symmetry. - apply fold_2 with (eqA:=eqA); auto with set relations. - Qed. - - Lemma remove_fold_2: forall i s x, ~In x s -> - eqA (fold f (remove x s) i) (fold f s i). - Proof. - intros. - apply fold_equal; auto with set. - Qed. - - Lemma fold_union_inter : forall i s s', - eqA (fold f (union s s') (fold f (inter s s') i)) - (fold f s (fold f s' i)). - Proof. - intros; pattern s; apply set_induction; clear s; intros. - - transitivity (fold f s' (fold f (inter s s') i)). - { apply fold_equal; auto with set. } - transitivity (fold f s' i). - { apply fold_init; auto. - apply fold_1; auto with set. } - symmetry; apply fold_1; auto. - - rename s'0 into s''. - destruct (In_dec x s'). - + (* In x s' *) - transitivity (fold f (union s'' s') (f x (fold f (inter s s') i))); auto with set. - { apply fold_init; auto. - apply fold_2 with (eqA:=eqA); auto with set. - rewrite inter_iff; intuition. } - transitivity (f x (fold f s (fold f s' i))). - 1:transitivity (fold f (union s s') (f x (fold f (inter s s') i))). - 2:transitivity (f x (fold f (union s s') (fold f (inter s s') i))). - * apply fold_equal; auto. - apply equal_sym; apply union_Equal with x; auto with set. - * apply fold_commutes; auto. - * apply Comp; auto with relations. - * symmetry; apply fold_2 with (eqA:=eqA); auto. - + (* ~(In x s') *) - transitivity (f x (fold f (union s s') (fold f (inter s'' s') i))). - { apply fold_2 with (eqA:=eqA); auto with set. } - transitivity (f x (fold f (union s s') (fold f (inter s s') i))). - { apply Comp;auto with relations. - apply fold_init;auto. - apply fold_equal;auto. - apply equal_sym; apply inter_Add_2 with x; auto with set. } - transitivity (f x (fold f s (fold f s' i))). - * apply Comp; auto with relations. - * symmetry; apply fold_2 with (eqA:=eqA); auto. - Qed. - - Lemma fold_diff_inter : forall i s s', - eqA (fold f (diff s s') (fold f (inter s s') i)) (fold f s i). - Proof. - intros. - transitivity (fold f (union (diff s s') (inter s s')) - (fold f (inter (diff s s') (inter s s')) i)). - 1:symmetry; apply fold_union_inter; auto. - transitivity (fold f s (fold f (inter (diff s s') (inter s s')) i)). - - apply fold_equal; auto with set. - - apply fold_init; auto. - apply fold_1; auto with set. - Qed. - - Lemma fold_union: forall i s s', - (forall x, ~(In x s/\In x s')) -> - eqA (fold f (union s s') i) (fold f s (fold f s' i)). - Proof. - intros. - transitivity (fold f (union s s') (fold f (inter s s') i)). - { apply fold_init; auto. - symmetry; apply fold_1; auto with set. - unfold Empty; intro a; generalize (H a); set_iff; tauto. } - apply fold_union_inter; auto. - Qed. - - End Fold_More. - - Lemma fold_plus : - forall s p, fold (fun _ => S) s p = fold (fun _ => S) s 0 + p. - Proof. - intros. apply fold_rel with (R:=fun u v => u = v + p); simpl; auto. - Qed. - - End Fold. - - (** * Cardinal *) - - (** ** Characterization of cardinal in terms of fold *) - - Lemma cardinal_fold : forall s, cardinal s = fold (fun _ => S) s 0. - Proof. - intros; rewrite cardinal_1; rewrite FM.fold_1. - symmetry; apply fold_left_S_0; auto. - Qed. - - (** ** Old specifications for [cardinal]. *) - - Lemma cardinal_0 : - forall s, exists l : list elt, - NoDupA E.eq l /\ - (forall x : elt, In x s <-> InA E.eq x l) /\ - cardinal s = length l. - Proof. - intros; exists (elements s); intuition auto with set; apply cardinal_1. - Qed. - - Lemma cardinal_1 : forall s, Empty s -> cardinal s = 0. - Proof. - intros; rewrite cardinal_fold; apply fold_1; auto with *. - Qed. - - Lemma cardinal_2 : - forall s s' x, ~ In x s -> Add x s s' -> cardinal s' = S (cardinal s). - Proof. - intros; do 2 rewrite cardinal_fold. - change S with ((fun _ => S) x). - apply fold_2; auto. - - split; congruence. - - congruence. - Qed. - - (** ** Cardinal and (non-)emptiness *) - - Lemma cardinal_Empty : forall s, Empty s <-> cardinal s = 0. - Proof. - intros. - rewrite elements_Empty, FM.cardinal_1. - destruct (elements s); intuition; discriminate. - Qed. - - Lemma cardinal_inv_1 : forall s, cardinal s = 0 -> Empty s. - Proof. - intros; rewrite cardinal_Empty; auto. - Qed. - #[global] - Hint Resolve cardinal_inv_1 : core. - - Lemma cardinal_inv_2 : - forall s n, cardinal s = S n -> { x : elt | In x s }. - Proof. - intros; rewrite FM.cardinal_1 in H. - generalize (elements_2 (s:=s)). - destruct (elements s); try discriminate. - exists e; auto with relations. - Qed. - - Lemma cardinal_inv_2b : - forall s, cardinal s <> 0 -> { x : elt | In x s }. - Proof. - intro; generalize (@cardinal_inv_2 s); destruct cardinal; - [intuition|eauto]. - Qed. - - (** ** Cardinal is a morphism *) - - Lemma Equal_cardinal : forall s s', s[=]s' -> cardinal s = cardinal s'. - Proof. - symmetry. - remember (cardinal s) as n; symmetry in Heqn; revert s s' Heqn H. - induction n; intros. - - apply cardinal_1; rewrite <- H; auto. - - destruct (cardinal_inv_2 Heqn) as (x,H2). - revert Heqn. - rewrite (cardinal_2 (s:=remove x s) (s':=s) (x:=x)); - auto with set relations. - rewrite (cardinal_2 (s:=remove x s') (s':=s') (x:=x)); - eauto with set relations. - Qed. - -#[global] - Instance cardinal_m : Proper (Equal==>Logic.eq) cardinal. - Proof. - exact Equal_cardinal. - Qed. - - #[global] - Hint Resolve Add_add Add_remove Equal_remove cardinal_inv_1 Equal_cardinal : core. - - (** ** Cardinal and set operators *) - - Lemma empty_cardinal : cardinal empty = 0. - Proof. - rewrite cardinal_fold; apply fold_1; auto with *. - Qed. - - #[global] - Hint Immediate empty_cardinal cardinal_1 : set. - - Lemma singleton_cardinal : forall x, cardinal (singleton x) = 1. - Proof. - intros. - rewrite (singleton_equal_add x). - replace 0 with (cardinal empty); auto with set. - apply cardinal_2 with x; auto with set. - Qed. - - #[global] - Hint Resolve singleton_cardinal: set. - - Lemma diff_inter_cardinal : - forall s s', cardinal (diff s s') + cardinal (inter s s') = cardinal s . - Proof. - intros; do 3 rewrite cardinal_fold. - rewrite <- fold_plus. - apply fold_diff_inter with (eqA:=@Logic.eq nat); auto with *. - congruence. - Qed. - - Lemma union_cardinal: - forall s s', (forall x, ~(In x s/\In x s')) -> - cardinal (union s s')=cardinal s+cardinal s'. - Proof. - intros; do 3 rewrite cardinal_fold. - rewrite <- fold_plus. - apply fold_union; auto. - - split; congruence. - - congruence. - Qed. - - Lemma subset_cardinal : - forall s s', s[<=]s' -> cardinal s <= cardinal s' . - Proof. - intros. - rewrite <- (diff_inter_cardinal s' s). - rewrite (inter_sym s' s). - rewrite (inter_subset_equal H). - apply Nat.le_add_l. - Qed. - - Lemma subset_cardinal_lt : - forall s s' x, s[<=]s' -> In x s' -> ~In x s -> cardinal s < cardinal s'. - Proof. - intros. - rewrite <- (diff_inter_cardinal s' s). - rewrite (inter_sym s' s). - rewrite (inter_subset_equal H). - generalize (@cardinal_inv_1 (diff s' s)). - destruct (cardinal (diff s' s)). - - intro H2; destruct (H2 (eq_refl _) x). - set_iff; auto. - - intros _. - change (0 + cardinal s < S n + cardinal s). - apply Nat.add_lt_le_mono; [ apply Nat.lt_0_succ | reflexivity ]. - Qed. - - Theorem union_inter_cardinal : - forall s s', cardinal (union s s') + cardinal (inter s s') = cardinal s + cardinal s' . - Proof. - intros. - do 4 rewrite cardinal_fold. - do 2 rewrite <- fold_plus. - apply fold_union_inter with (eqA:=@Logic.eq nat); auto with *. - congruence. - Qed. - - Lemma union_cardinal_inter : - forall s s', cardinal (union s s') = cardinal s + cardinal s' - cardinal (inter s s'). - Proof. - intros. - rewrite <- union_inter_cardinal, Nat.add_sub. - reflexivity. - Qed. - - Lemma union_cardinal_le : - forall s s', cardinal (union s s') <= cardinal s + cardinal s'. - Proof. - intros; generalize (union_inter_cardinal s s'). - intros; rewrite <- H; auto with arith. - Qed. - - Lemma add_cardinal_1 : - forall s x, In x s -> cardinal (add x s) = cardinal s. - Proof. - auto with set. - Qed. - - Lemma add_cardinal_2 : - forall s x, ~In x s -> cardinal (add x s) = S (cardinal s). - Proof. - intros. - do 2 rewrite cardinal_fold. - change S with ((fun _ => S) x); - apply fold_add with (eqA:=@Logic.eq nat); auto with *. - congruence. - Qed. - - Lemma remove_cardinal_1 : - forall s x, In x s -> S (cardinal (remove x s)) = cardinal s. - Proof. - intros. - do 2 rewrite cardinal_fold. - change S with ((fun _ =>S) x). - apply remove_fold_1 with (eqA:=@Logic.eq nat); auto with *. - congruence. - Qed. - - Lemma remove_cardinal_2 : - forall s x, ~In x s -> cardinal (remove x s) = cardinal s. - Proof. - auto with set. - Qed. - - #[global] - Hint Resolve subset_cardinal union_cardinal add_cardinal_1 add_cardinal_2 : core. - -End WPropertiesOn. - -(** Now comes variants for self-contained weak sets and for full sets. - For these variants, only one argument is necessary. Thanks to - the subtyping [WS<=S], the [Properties] functor which is meant to be - used on modules [(M:S)] can simply be an alias of [WProperties]. *) - -Module WProperties (M:WSets) := WPropertiesOn M.E M. -Module Properties := WProperties. - - -(** Now comes some properties specific to the element ordering, - invalid for Weak Sets. *) - -Module OrdProperties (M:Sets). - Module Import ME:=OrderedTypeFacts(M.E). - Module Import ML:=OrderedTypeLists(M.E). - Module Import P := Properties M. - Import FM. - Import M.E. - Import M. - - #[global] - Hint Resolve elements_spec2 : core. - #[global] - Hint Immediate - min_elt_spec1 min_elt_spec2 min_elt_spec3 - max_elt_spec1 max_elt_spec2 max_elt_spec3 : set. - - (** First, a specialized version of SortA_equivlistA_eqlistA: *) - 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 *. - Qed. - - Definition gtb x y := match E.compare x y with Gt => true | _ => false end. - Definition leb x := fun y => negb (gtb x y). - - Definition elements_lt x s := List.filter (gtb x) (elements s). - Definition elements_ge x s := List.filter (leb x) (elements s). - - Lemma gtb_1 : forall x y, gtb x y = true <-> E.lt y x. - Proof. - intros; rewrite <- compare_gt_iff. unfold gtb. - destruct E.compare; intuition; try discriminate. - Qed. - - Lemma leb_1 : forall x y, leb x y = true <-> ~E.lt y x. - Proof. - intros; rewrite <- compare_gt_iff. unfold leb, gtb. - destruct E.compare; intuition; try discriminate. - Qed. - -#[global] - Instance gtb_compat x : Proper (E.eq==>Logic.eq) (gtb x). - Proof. - intros a b H. unfold gtb. rewrite H; auto. - Qed. - -#[global] - Instance leb_compat x : Proper (E.eq==>Logic.eq) (leb x). - Proof. - intros a b H; unfold leb. rewrite H; auto. - Qed. - #[global] - Hint Resolve gtb_compat leb_compat : core. - - Lemma elements_split : forall x s, - elements s = elements_lt x s ++ elements_ge x s. - Proof. - unfold elements_lt, elements_ge, leb; intros. - eapply (@filter_split _ E.eq); eauto with *. - intros. - rewrite gtb_1 in H. - assert (~E.lt y x). { - unfold gtb in *; elim_compare x y; intuition; - try discriminate; order. - } - order. - Qed. - - Lemma elements_Add : forall s s' x, ~In x s -> Add x s s' -> - eqlistA E.eq (elements s') (elements_lt x s ++ x :: elements_ge x 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 *; eauto with *. - + constructor; auto. - * apply (@filter_sort _ E.eq); auto with *; eauto with *. - * rewrite Inf_alt by (apply (@filter_sort _ E.eq); eauto with *). - intros. - rewrite filter_InA in H1; auto with *; destruct H1. - rewrite leb_1 in H2. - rewrite <- elements_iff in H1. - assert (~E.eq x y). - { contradict H; rewrite H; auto. } - order. - + intros. - rewrite filter_InA in H1; auto with *; destruct H1. - rewrite gtb_1 in H3. - inversion_clear H2. - * order. - * rewrite filter_InA in H4; auto with *; destruct H4. - rewrite leb_1 in H4. - order. - - red; intros a. - rewrite InA_app_iff, InA_cons, !filter_InA, <-!elements_iff, - leb_1, gtb_1, (H0 a) by (auto with *). - intuition. - elim_compare a x; intuition. - right; right; split; auto. - order. - Qed. - - Definition Above x s := forall y, In y s -> E.lt y x. - Definition Below x s := forall y, In y s -> E.lt x y. - - Lemma elements_Add_Above : forall s s' x, - Above x s -> Add x s s' -> - eqlistA E.eq (elements s') (elements s ++ x::nil). - Proof. - intros. - apply sort_equivlistA_eqlistA; auto with set. - - apply (@SortA_app _ E.eq); auto with *. - intros. - invlist InA. - rewrite <- elements_iff in H1. - setoid_replace y with x; auto. - - red; intros a. - rewrite InA_app_iff, InA_cons, InA_nil, <-!elements_iff, (H0 a) - by (auto with *). - intuition. - Qed. - - Lemma elements_Add_Below : forall s s' x, - Below x s -> Add x s s' -> - eqlistA E.eq (elements s') (x::elements s). - Proof. - intros. - apply sort_equivlistA_eqlistA; auto with set. - - change (sort E.lt ((x::nil) ++ elements s)). - apply (@SortA_app _ E.eq); auto with *. - intros. - invlist InA. - rewrite <- elements_iff in H2. - setoid_replace x0 with x; auto. - - red; intros a. - rewrite InA_cons, <- !elements_iff, (H0 a); intuition. - Qed. - - (** Two other induction principles on sets: we can be more restrictive - on the element we add at each step. *) - - Lemma set_induction_max : - forall P : t -> Type, - (forall s : t, Empty s -> P s) -> - (forall s s', P s -> forall x, Above x s -> Add x s s' -> P s') -> - forall s : t, P s. - Proof. - intros; remember (cardinal s) as n; revert s Heqn; induction n; intros; auto. - case_eq (max_elt s); intros. - - apply X0 with (remove e s) e; auto with set. - + apply IHn. - assert (S n = S (cardinal (remove e s))). { - rewrite Heqn; apply cardinal_2 with e; auto with set relations. - } - inversion H0; auto. - + red; intros. - rewrite remove_iff in H0; destruct H0. - generalize (@max_elt_spec2 s e y H H0); order. - - - assert (H0:=max_elt_spec3 H). - rewrite cardinal_Empty in H0; rewrite H0 in Heqn; inversion Heqn. - Qed. - - Lemma set_induction_min : - forall P : t -> Type, - (forall s : t, Empty s -> P s) -> - (forall s s', P s -> forall x, Below x s -> Add x s s' -> P s') -> - forall s : t, P s. - Proof. - intros; remember (cardinal s) as n; revert s Heqn; induction n; intros; auto. - case_eq (min_elt s); intros. - - apply X0 with (remove e s) e; auto with set. - + apply IHn. - assert (S n = S (cardinal (remove e s))). - { rewrite Heqn; apply cardinal_2 with e; auto with set relations. } - inversion H0; auto. - + red; intros. - rewrite remove_iff in H0; destruct H0. - generalize (@min_elt_spec2 s e y H H0); order. - - - assert (H0:=min_elt_spec3 H). - rewrite cardinal_Empty in H0; auto; rewrite H0 in Heqn; inversion Heqn. - Qed. - - (** More properties of [fold] : behavior with respect to Above/Below *) - - Lemma fold_3 : - forall s s' x (A : Type) (eqA : A -> A -> Prop) - (st : Equivalence eqA) (i : A) (f : elt -> A -> A), - Proper (E.eq==>eqA==>eqA) f -> - Above x s -> Add x s s' -> eqA (fold f s' i) (f x (fold f s i)). - Proof. - intros. - rewrite 2 fold_spec_right. - change (f x (fold_right f i (rev (elements s)))) with - (fold_right f i (rev (x::nil)++rev (elements s))). - apply (@fold_right_eqlistA E.t E.eq A eqA st); auto with *. - rewrite <- distr_rev. - apply eqlistA_rev. - apply elements_Add_Above; auto. - Qed. - - Lemma fold_4 : - forall s s' x (A : Type) (eqA : A -> A -> Prop) - (st : Equivalence eqA) (i : A) (f : elt -> A -> A), - Proper (E.eq==>eqA==>eqA) f -> - Below x s -> Add x s s' -> eqA (fold f s' i) (fold f s (f x i)). - Proof. - intros. - rewrite !fold_spec. - change (eqA (fold_left (flip f) (elements s') i) - (fold_left (flip f) (x::elements s) i)). - unfold flip; rewrite <-!fold_left_rev_right. - apply (@fold_right_eqlistA E.t E.eq A eqA st); auto. - apply eqlistA_rev. - apply elements_Add_Below; auto. - Qed. - - (** The following results have already been proved earlier, - but we can now prove them with one hypothesis less: - no need for [(transpose eqA f)]. *) - - Section FoldOpt. - Variables (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA). - Variables (f:elt->A->A)(Comp:Proper (E.eq==>eqA==>eqA) f). - - Lemma fold_equal : - forall i s s', s[=]s' -> eqA (fold f s i) (fold f s' i). - Proof. - intros. - rewrite 2 fold_spec_right. - apply (@fold_right_eqlistA E.t E.eq A eqA st); auto. - apply eqlistA_rev. - apply sort_equivlistA_eqlistA; auto with set. - red; intro a; do 2 rewrite <- elements_iff; auto. - Qed. - - Lemma add_fold : forall i s x, In x s -> - eqA (fold f (add x s) i) (fold f s i). - Proof. - intros; apply fold_equal; auto with set. - Qed. - - Lemma remove_fold_2: forall i s x, ~In x s -> - eqA (fold f (remove x s) i) (fold f s i). - Proof. - intros. - apply fold_equal; auto with set. - Qed. - - End FoldOpt. - - (** An alternative version of [choose_3] *) - - Lemma choose_equal : forall s s', Equal s s' -> - match choose s, choose s' with - | Some x, Some x' => E.eq x x' - | None, None => True - | _, _ => False - end. - Proof. - intros s s' H; - generalize (@choose_spec1 s)(@choose_spec2 s) - (@choose_spec1 s')(@choose_spec2 s')(@choose_spec3 s s'); - destruct (choose s); destruct (choose s'); simpl; intuition. - - apply H5 with e; rewrite <-H; auto. - - apply H5 with e; rewrite H; auto. - Qed. - -End OrdProperties. diff --git a/stdlib/theories/MSets/MSetRBT.v b/stdlib/theories/MSets/MSetRBT.v deleted file mode 100644 index f7fcae9a2e04..000000000000 --- a/stdlib/theories/MSets/MSetRBT.v +++ /dev/null @@ -1,1999 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* option (elt * t). - - Axiom remove_min_spec1 : forall s k s', - remove_min s = Some (k,s') -> - min_elt s = Some k /\ remove k s [=] s'. - - Axiom remove_min_spec2 : forall s, remove_min s = None -> Empty s. - -End MSetRemoveMin. - -(** The type of color annotation. *) - -Inductive color := Red | Black. - -Module Color. - Definition t := color. -End Color. - -(** * Ops : the pure functions *) - -Module Ops (X:Orders.OrderedType) <: MSetInterface.Ops X. - -(** ** Generic trees instantiated with color *) - -(** We reuse a generic definition of trees where the information - parameter is a color. Functions like mem or fold are also - provided by this generic functor. *) - -Include MSetGenTree.Ops X Color. - -Definition t := tree. -Local Notation Rd := (Node Red). -Local Notation Bk := (Node Black). - -(** ** Basic tree *) - -Definition singleton (k: elt) : tree := Bk Leaf k Leaf. - -(** ** Changing root color *) - -Definition makeBlack t := - match t with - | Leaf => Leaf - | Node _ a x b => Bk a x b - end. - -Definition makeRed t := - match t with - | Leaf => Leaf - | Node _ a x b => Rd a x b - end. - -(** ** Balancing *) - -(** We adapt when one side is not a true red-black tree. - Both sides have the same black depth. *) - -Definition lbal l k r := - match l with - | Rd (Rd a x b) y c => Rd (Bk a x b) y (Bk c k r) - | Rd a x (Rd b y c) => Rd (Bk a x b) y (Bk c k r) - | _ => Bk l k r - end. - -Definition rbal l k r := - match r with - | Rd (Rd b y c) z d => Rd (Bk l k b) y (Bk c z d) - | Rd b y (Rd c z d) => Rd (Bk l k b) y (Bk c z d) - | _ => Bk l k r - end. - -(** A variant of [rbal], with reverse pattern order. - Is it really useful ? Should we always use it ? *) - -Definition rbal' l k r := - match r with - | Rd b y (Rd c z d) => Rd (Bk l k b) y (Bk c z d) - | Rd (Rd b y c) z d => Rd (Bk l k b) y (Bk c z d) - | _ => Bk l k r - end. - -(** Balancing with different black depth. - One side is almost a red-black tree, while the other is - a true red-black tree, but with black depth + 1. - Used in deletion. *) - -Definition lbalS l k r := - match l with - | Rd a x b => Rd (Bk a x b) k r - | _ => - match r with - | Bk a y b => rbal' l k (Rd a y b) - | Rd (Bk a y b) z c => Rd (Bk l k a) y (rbal' b z (makeRed c)) - | _ => Rd l k r (* impossible *) - end - end. - -Definition rbalS l k r := - match r with - | Rd b y c => Rd l k (Bk b y c) - | _ => - match l with - | Bk a x b => lbal (Rd a x b) k r - | Rd a x (Bk b y c) => Rd (lbal (makeRed a) x b) y (Bk c k r) - | _ => Rd l k r (* impossible *) - end - end. - -(** ** Insertion *) - -Fixpoint ins x s := - match s with - | Leaf => Rd Leaf x Leaf - | Node c l y r => - match X.compare x y with - | Eq => s - | Lt => - match c with - | Red => Rd (ins x l) y r - | Black => lbal (ins x l) y r - end - | Gt => - match c with - | Red => Rd l y (ins x r) - | Black => rbal l y (ins x r) - end - end - end. - -Definition add x s := makeBlack (ins x s). - -(** ** Deletion *) - -Fixpoint append (l:tree) : tree -> tree := - match l with - | Leaf => fun r => r - | Node lc ll lx lr => - fix append_l (r:tree) : tree := - match r with - | Leaf => l - | Node rc rl rx rr => - match lc, rc with - | Red, Red => - let lrl := append lr rl in - match lrl with - | Rd lr' x rl' => Rd (Rd ll lx lr') x (Rd rl' rx rr) - | _ => Rd ll lx (Rd lrl rx rr) - end - | Black, Black => - let lrl := append lr rl in - match lrl with - | Rd lr' x rl' => Rd (Bk ll lx lr') x (Bk rl' rx rr) - | _ => lbalS ll lx (Bk lrl rx rr) - end - | Black, Red => Rd (append_l rl) rx rr - | Red, Black => Rd ll lx (append lr r) - end - end - end. - -Fixpoint del x t := - match t with - | Leaf => Leaf - | Node _ a y b => - match X.compare x y with - | Eq => append a b - | Lt => - match a with - | Bk _ _ _ => lbalS (del x a) y b - | _ => Rd (del x a) y b - end - | Gt => - match b with - | Bk _ _ _ => rbalS a y (del x b) - | _ => Rd a y (del x b) - end - end - end. - -Definition remove x t := makeBlack (del x t). - -(** ** Removing minimal element *) - -Fixpoint delmin l x r : (elt * tree) := - match l with - | Leaf => (x,r) - | Node lc ll lx lr => - let (k,l') := delmin ll lx lr in - match lc with - | Black => (k, lbalS l' x r) - | Red => (k, Rd l' x r) - end - end. - -Definition remove_min t : option (elt * tree) := - match t with - | Leaf => None - | Node _ l x r => - let (k,t) := delmin l x r in - Some (k, makeBlack t) - end. - -(** ** Tree-ification - - We rebuild a tree of size [if pred then n-1 else n] as soon - as the list [l] has enough elements *) - -Definition bogus : tree * list elt := (Leaf, nil). - -Notation treeify_t := (list elt -> tree * list elt). - -Definition treeify_zero : treeify_t := - fun acc => (Leaf,acc). - -Definition treeify_one : treeify_t := - fun acc => match acc with - | x::acc => (Rd Leaf x Leaf, acc) - | _ => bogus - end. - -Definition treeify_cont (f g : treeify_t) : treeify_t := - fun acc => - match f acc with - | (l, x::acc) => - match g acc with - | (r, acc) => (Bk l x r, acc) - end - | _ => bogus - end. - -Fixpoint treeify_aux (pred:bool)(n: positive) : treeify_t := - match n with - | xH => if pred then treeify_zero else treeify_one - | xO n => treeify_cont (treeify_aux pred n) (treeify_aux true n) - | xI n => treeify_cont (treeify_aux false n) (treeify_aux pred n) - end. - -Fixpoint plength_aux (l:list elt)(p:positive) := match l with - | nil => p - | _::l => plength_aux l (Pos.succ p) -end. - -Definition plength l := plength_aux l 1. - -Definition treeify (l:list elt) := - fst (treeify_aux true (plength l) l). - -(** ** Filtering *) - -Fixpoint filter_aux (f: elt -> bool) s acc := - match s with - | Leaf => acc - | Node _ l k r => - let acc := filter_aux f r acc in - if f k then filter_aux f l (k::acc) - else filter_aux f l acc - end. - -Definition filter (f: elt -> bool) (s: t) : t := - treeify (filter_aux f s nil). - -Fixpoint partition_aux (f: elt -> bool) s acc1 acc2 := - match s with - | Leaf => (acc1,acc2) - | Node _ sl k sr => - let (acc1, acc2) := partition_aux f sr acc1 acc2 in - if f k then partition_aux f sl (k::acc1) acc2 - else partition_aux f sl acc1 (k::acc2) - end. - -Definition partition (f: elt -> bool) (s:t) : t*t := - let (ok,ko) := partition_aux f s nil nil in - (treeify ok, treeify ko). - -(** ** Union, intersection, difference *) - -(** union of the elements of [l1] and [l2] into a third [acc] list. *) - -Fixpoint union_list l1 : list elt -> list elt -> list elt := - match l1 with - | nil => @rev_append _ - | x::l1' => - fix union_l1 l2 acc := - match l2 with - | nil => rev_append l1 acc - | y::l2' => - match X.compare x y with - | Eq => union_list l1' l2' (x::acc) - | Lt => union_l1 l2' (y::acc) - | Gt => union_list l1' l2 (x::acc) - end - end - end. - -Definition linear_union s1 s2 := - treeify (union_list (rev_elements s1) (rev_elements s2) nil). - -Fixpoint inter_list l1 : list elt -> list elt -> list elt := - match l1 with - | nil => fun _ acc => acc - | x::l1' => - fix inter_l1 l2 acc := - match l2 with - | nil => acc - | y::l2' => - match X.compare x y with - | Eq => inter_list l1' l2' (x::acc) - | Lt => inter_l1 l2' acc - | Gt => inter_list l1' l2 acc - end - end - end. - -Definition linear_inter s1 s2 := - treeify (inter_list (rev_elements s1) (rev_elements s2) nil). - -Fixpoint diff_list l1 : list elt -> list elt -> list elt := - match l1 with - | nil => fun _ acc => acc - | x::l1' => - fix diff_l1 l2 acc := - match l2 with - | nil => rev_append l1 acc - | y::l2' => - match X.compare x y with - | Eq => diff_list l1' l2' acc - | Lt => diff_l1 l2' acc - | Gt => diff_list l1' l2 (x::acc) - end - end - end. - -Definition linear_diff s1 s2 := - treeify (diff_list (rev_elements s1) (rev_elements s2) nil). - -(** [compare_height] returns: - - [Lt] if [height s2] is at least twice [height s1]; - - [Gt] if [height s1] is at least twice [height s2]; - - [Eq] if heights are approximately equal. - Warning: this is not an equivalence relation! but who cares.... *) - -Definition skip_red t := - match t with - | Rd t' _ _ => t' - | _ => t - end. - -Definition skip_black t := - match skip_red t with - | Bk t' _ _ => t' - | t' => t' - end. - -Fixpoint compare_height (s1x s1 s2 s2x: tree) : comparison := - match skip_red s1x, skip_red s1, skip_red s2, skip_red s2x with - | Node _ s1x' _ _, Node _ s1' _ _, Node _ s2' _ _, Node _ s2x' _ _ => - compare_height (skip_black s1x') s1' s2' (skip_black s2x') - | _, Leaf, _, Node _ _ _ _ => Lt - | Node _ _ _ _, _, Leaf, _ => Gt - | Node _ s1x' _ _, Node _ s1' _ _, Node _ s2' _ _, Leaf => - compare_height (skip_black s1x') s1' s2' Leaf - | Leaf, Node _ s1' _ _, Node _ s2' _ _, Node _ s2x' _ _ => - compare_height Leaf s1' s2' (skip_black s2x') - | _, _, _, _ => Eq - end. - -(** When one tree is quite smaller than the other, we simply - adds repeatively all its elements in the big one. - For trees of comparable height, we rather use [linear_union]. *) - -Definition union (t1 t2: t) : t := - match compare_height t1 t1 t2 t2 with - | Lt => fold add t1 t2 - | Gt => fold add t2 t1 - | Eq => linear_union t1 t2 - end. - -Definition diff (t1 t2: t) : t := - match compare_height t1 t1 t2 t2 with - | Lt => filter (fun k => negb (mem k t2)) t1 - | Gt => fold remove t2 t1 - | Eq => linear_diff t1 t2 - end. - -Definition inter (t1 t2: t) : t := - match compare_height t1 t1 t2 t2 with - | Lt => filter (fun k => mem k t2) t1 - | Gt => filter (fun k => mem k t1) t2 - | Eq => linear_inter t1 t2 - end. - -End Ops. - -(** * MakeRaw : the pure functions and their specifications *) - -Module Type MakeRaw (X:Orders.OrderedType) <: MSetInterface.RawSets X. -Include Ops X. - -(** Generic definition of binary-search-trees and proofs of - specifications for generic functions such as mem or fold. *) - -Include MSetGenTree.Props X Color. - -Local Notation Rd := (Node Red). -Local Notation Bk := (Node Black). - -Local Hint Immediate MX.eq_sym : core. -Local Hint Unfold In lt_tree gt_tree Ok : core. -Local Hint Constructors InT bst : core. -Local Hint Resolve MX.eq_refl MX.eq_trans MX.lt_trans ok : core. -Local Hint Resolve lt_leaf gt_leaf lt_tree_node gt_tree_node : core. -Local Hint Resolve lt_tree_not_in lt_tree_trans gt_tree_not_in gt_tree_trans : core. -Local Hint Resolve elements_spec2 : core. - -(** ** Singleton set *) - -Lemma singleton_spec x y : InT y (singleton x) <-> X.eq y x. -Proof. - unfold singleton; intuition_in. -Qed. - -#[global] -Instance singleton_ok x : Ok (singleton x). -Proof. - unfold singleton; auto. -Qed. - -(** ** makeBlack, MakeRed *) - -Lemma makeBlack_spec s x : InT x (makeBlack s) <-> InT x s. -Proof. - destruct s; simpl; intuition_in. -Qed. - -Lemma makeRed_spec s x : InT x (makeRed s) <-> InT x s. -Proof. - destruct s; simpl; intuition_in. -Qed. - -#[global] -Instance makeBlack_ok s `{Ok s} : Ok (makeBlack s). -Proof. - destruct s; simpl; ok. -Qed. - -#[global] -Instance makeRed_ok s `{Ok s} : Ok (makeRed s). -Proof. - destruct s; simpl; ok. -Qed. - -(** ** Generic handling for red-matching and red-red-matching *) - -Definition isblack t := - match t with Bk _ _ _ => True | _ => False end. - -Definition notblack t := - match t with Bk _ _ _ => False | _ => True end. - -Definition notred t := - match t with Rd _ _ _ => False | _ => True end. - -Definition rcase {A} f g t : A := - match t with - | Rd a x b => f a x b - | _ => g t - end. - -Inductive rspec {A} f g : tree -> A -> Prop := - | rred a x b : rspec f g (Rd a x b) (f a x b) - | relse t : notred t -> rspec f g t (g t). - -Fact rmatch {A} f g t : rspec (A:=A) f g t (rcase f g t). -Proof. -destruct t as [|[|] l x r]; simpl; now constructor. -Qed. - -Definition rrcase {A} f g t : A := - match t with - | Rd (Rd a x b) y c => f a x b y c - | Rd a x (Rd b y c) => f a x b y c - | _ => g t - end. - -Notation notredred := (rrcase (fun _ _ _ _ _ => False) (fun _ => True)). - -Inductive rrspec {A} f g : tree -> A -> Prop := - | rrleft a x b y c : rrspec f g (Rd (Rd a x b) y c) (f a x b y c) - | rrright a x b y c : rrspec f g (Rd a x (Rd b y c)) (f a x b y c) - | rrelse t : notredred t -> rrspec f g t (g t). - -Fact rrmatch {A} f g t : rrspec (A:=A) f g t (rrcase f g t). -Proof. -destruct t as [|[|] l x r]; simpl; try now constructor. -destruct l as [|[|] ll lx lr], r as [|[|] rl rx rr]; now constructor. -Qed. - -Definition rrcase' {A} f g t : A := - match t with - | Rd a x (Rd b y c) => f a x b y c - | Rd (Rd a x b) y c => f a x b y c - | _ => g t - end. - -Fact rrmatch' {A} f g t : rrspec (A:=A) f g t (rrcase' f g t). -Proof. -destruct t as [|[|] l x r]; simpl; try now constructor. -destruct l as [|[|] ll lx lr], r as [|[|] rl rx rr]; now constructor. -Qed. - -(** Balancing operations are instances of generic match *) - -Fact lbal_match l k r : - rrspec - (fun a x b y c => Rd (Bk a x b) y (Bk c k r)) - (fun l => Bk l k r) - l - (lbal l k r). -Proof. - exact (rrmatch _ _ _). -Qed. - -Fact rbal_match l k r : - rrspec - (fun a x b y c => Rd (Bk l k a) x (Bk b y c)) - (fun r => Bk l k r) - r - (rbal l k r). -Proof. - exact (rrmatch _ _ _). -Qed. - -Fact rbal'_match l k r : - rrspec - (fun a x b y c => Rd (Bk l k a) x (Bk b y c)) - (fun r => Bk l k r) - r - (rbal' l k r). -Proof. - exact (rrmatch' _ _ _). -Qed. - -Fact lbalS_match l x r : - rspec - (fun a y b => Rd (Bk a y b) x r) - (fun l => - match r with - | Bk a y b => rbal' l x (Rd a y b) - | Rd (Bk a y b) z c => Rd (Bk l x a) y (rbal' b z (makeRed c)) - | _ => Rd l x r - end) - l - (lbalS l x r). -Proof. - exact (rmatch _ _ _). -Qed. - -Fact rbalS_match l x r : - rspec - (fun a y b => Rd l x (Bk a y b)) - (fun r => - match l with - | Bk a y b => lbal (Rd a y b) x r - | Rd a y (Bk b z c) => Rd (lbal (makeRed a) y b) z (Bk c x r) - | _ => Rd l x r - end) - r - (rbalS l x r). -Proof. - exact (rmatch _ _ _). -Qed. - -(** ** Balancing for insertion *) - -Lemma lbal_spec l x r y : - InT y (lbal l x r) <-> X.eq y x \/ InT y l \/ InT y r. -Proof. - case lbal_match; intuition_in. -Qed. - -#[global] -Instance lbal_ok l x r `(Ok l, Ok r, lt_tree x l, gt_tree x r) : - Ok (lbal l x r). -Proof. - destruct (lbal_match l x r); ok. -Qed. - -Lemma rbal_spec l x r y : - InT y (rbal l x r) <-> X.eq y x \/ InT y l \/ InT y r. -Proof. - case rbal_match; intuition_in. -Qed. - -#[global] -Instance rbal_ok l x r `(Ok l, Ok r, lt_tree x l, gt_tree x r) : - Ok (rbal l x r). -Proof. - destruct (rbal_match l x r); ok. -Qed. - -Lemma rbal'_spec l x r y : - InT y (rbal' l x r) <-> X.eq y x \/ InT y l \/ InT y r. -Proof. - case rbal'_match; intuition_in. -Qed. - -#[global] -Instance rbal'_ok l x r `(Ok l, Ok r, lt_tree x l, gt_tree x r) : - Ok (rbal' l x r). -Proof. - destruct (rbal'_match l x r); ok. -Qed. - -Global Hint Rewrite In_node_iff In_leaf_iff - makeRed_spec makeBlack_spec lbal_spec rbal_spec rbal'_spec : rb. - -Ltac descolor := destruct_all Color.t. -Ltac destree t := destruct t as [|[|] ? ? ?]. -Ltac autorew := autorewrite with rb. -Tactic Notation "autorew" "in" ident(H) := autorewrite with rb in H. - -(** ** Insertion *) - -Lemma ins_spec : forall s x y, - InT y (ins x s) <-> X.eq y x \/ InT y s. -Proof. - induct s x. - - intuition_in. - - intuition_in. setoid_replace y with x; eauto. - - descolor; autorew; rewrite IHl; intuition_in. - - descolor; autorew; rewrite IHr; intuition_in. -Qed. -Global Hint Rewrite ins_spec : rb. - -#[global] -Instance ins_ok s x `{Ok s} : Ok (ins x s). -Proof. - induct s x; auto; descolor; - (apply lbal_ok || apply rbal_ok || ok); auto; - intros y; autorew; intuition; order. -Qed. - -Lemma add_spec' s x y : - InT y (add x s) <-> X.eq y x \/ InT y s. -Proof. - unfold add. now autorew. -Qed. - -Global Hint Rewrite add_spec' : rb. - -Lemma add_spec s x y `{Ok s} : - InT y (add x s) <-> X.eq y x \/ InT y s. -Proof. - apply add_spec'. -Qed. - -#[global] -Instance add_ok s x `{Ok s} : Ok (add x s). -Proof. - unfold add; auto_tc. -Qed. - -(** ** Balancing for deletion *) - -Lemma lbalS_spec l x r y : - InT y (lbalS l x r) <-> X.eq y x \/ InT y l \/ InT y r. -Proof. - case lbalS_match. - - intros; autorew; intuition_in. - - clear l. intros l _. - destruct r as [|[|] rl rx rr]. - * autorew. intuition_in. - * destree rl; autorew; intuition_in. - * autorew. intuition_in. -Qed. - -#[global] -Instance lbalS_ok l x r : - forall `(Ok l, Ok r, lt_tree x l, gt_tree x r), Ok (lbalS l x r). -Proof. - case lbalS_match; intros. - - ok. - - destruct r as [|[|] rl rx rr]. - * ok. - * destruct rl as [|[|] rll rlx rlr]; intros; ok. - + apply rbal'_ok; ok. - intros w; autorew; auto. - + intros w; autorew. - destruct 1 as [Hw|[Hw|Hw]]; try rewrite Hw; eauto. - * ok. autorew. apply rbal'_ok; ok. -Qed. - -Lemma rbalS_spec l x r y : - InT y (rbalS l x r) <-> X.eq y x \/ InT y l \/ InT y r. -Proof. - case rbalS_match. - - intros; autorew; intuition_in. - - intros t _. - destruct l as [|[|] ll lx lr]. - * autorew. intuition_in. - * destruct lr as [|[|] lrl lrx lrr]; autorew; intuition_in. - * autorew. intuition_in. -Qed. - -#[global] -Instance rbalS_ok l x r : - forall `(Ok l, Ok r, lt_tree x l, gt_tree x r), Ok (rbalS l x r). -Proof. - case rbalS_match; intros. - - ok. - - destruct l as [|[|] ll lx lr]. - * ok. - * destruct lr as [|[|] lrl lrx lrr]; intros; ok. - + apply lbal_ok; ok. - intros w; autorew; auto. - + intros w; autorew. - destruct 1 as [Hw|[Hw|Hw]]; try rewrite Hw; eauto. - * ok. apply lbal_ok; ok. -Qed. - -Global Hint Rewrite lbalS_spec rbalS_spec : rb. - -(** ** Append for deletion *) - -Ltac append_tac l r := - induction l as [| lc ll _ lx lr IHlr]; - [intro r; simpl - |induction r as [| rc rl IHrl rx rr _]; - [simpl - |destruct lc, rc; - [specialize (IHlr rl); clear IHrl - |simpl; - assert (Hr:notred (Bk rl rx rr)) by (simpl; trivial); - set (r:=Bk rl rx rr) in *; clearbody r; clear IHrl rl rx rr; - specialize (IHlr r) - |change (append _ _) with (Rd (append (Bk ll lx lr) rl) rx rr); - assert (Hl:notred (Bk ll lx lr)) by (simpl; trivial); - set (l:=Bk ll lx lr) in *; clearbody l; clear IHlr ll lx lr - |specialize (IHlr rl); clear IHrl]]]. - -Fact append_rr_match ll lx lr rl rx rr : - rspec - (fun a x b => Rd (Rd ll lx a) x (Rd b rx rr)) - (fun t => Rd ll lx (Rd t rx rr)) - (append lr rl) - (append (Rd ll lx lr) (Rd rl rx rr)). -Proof. - exact (rmatch _ _ _). -Qed. - -Fact append_bb_match ll lx lr rl rx rr : - rspec - (fun a x b => Rd (Bk ll lx a) x (Bk b rx rr)) - (fun t => lbalS ll lx (Bk t rx rr)) - (append lr rl) - (append (Bk ll lx lr) (Bk rl rx rr)). -Proof. - exact (rmatch _ _ _). -Qed. - -Lemma append_spec l r x : - InT x (append l r) <-> InT x l \/ InT x r. -Proof. - revert r. - append_tac l r; autorew; try tauto. - - (* Red / Red *) - revert IHlr; case append_rr_match; - [intros a y b | intros t Ht]; autorew; tauto. - - (* Black / Black *) - revert IHlr; case append_bb_match; - [intros a y b | intros t Ht]; autorew; tauto. -Qed. - -Global Hint Rewrite append_spec : rb. - -Lemma append_ok : forall x l r `{Ok l, Ok r}, - lt_tree x l -> gt_tree x r -> Ok (append l r). -Proof. - append_tac l r. - - (* Leaf / _ *) - trivial. - - (* _ / Leaf *) - trivial. - - (* Red / Red *) - intros; inv. - assert (IH : Ok (append lr rl)) by (apply IHlr; eauto). clear IHlr. - assert (X.lt lx rx) by (transitivity x; eauto). - assert (G : gt_tree lx (append lr rl)). - { intros w. autorew. destruct 1; [|transitivity x]; eauto. } - assert (L : lt_tree rx (append lr rl)). - { intros w. autorew. destruct 1; [transitivity x|]; eauto. } - revert IH G L; case append_rr_match; intros; ok. - - (* Red / Black *) - intros; ok. - intros w; autorew; destruct 1; eauto. - - (* Black / Red *) - intros; ok. - intros w; autorew; destruct 1; eauto. - - (* Black / Black *) - intros; inv. - assert (IH : Ok (append lr rl)) by (apply IHlr; eauto). clear IHlr. - assert (X.lt lx rx) by (transitivity x; eauto). - assert (G : gt_tree lx (append lr rl)). - { intros w. autorew. destruct 1; [|transitivity x]; eauto. } - assert (L : lt_tree rx (append lr rl)). - { intros w. autorew. destruct 1; [transitivity x|]; eauto. } - revert IH G L; case append_bb_match; intros; ok. - apply lbalS_ok; ok. -Qed. - -(** ** Deletion *) - -Lemma del_spec : forall s x y `{Ok s}, - InT y (del x s) <-> InT y s /\ ~X.eq y x. -Proof. -induct s x. -- intuition_in. -- autorew; intuition_in. - + assert (X.lt y x') by eauto. order. - + assert (X.lt x' y) by eauto. order. - + order. -- destruct l as [|[|] ll lx lr]; autorew; - rewrite ?IHl by trivial; intuition_in; order. -- destruct r as [|[|] rl rx rr]; autorew; - rewrite ?IHr by trivial; intuition_in; order. -Qed. - -Global Hint Rewrite del_spec : rb. - -#[global] -Instance del_ok s x `{Ok s} : Ok (del x s). -Proof. -induct s x. -- trivial. -- eapply append_ok; eauto. -- assert (lt_tree x' (del x l)). - { intro w. autorew; trivial. destruct 1. eauto. } - destruct l as [|[|] ll lx lr]; auto_tc. -- assert (gt_tree x' (del x r)). - { intro w. autorew; trivial. destruct 1. eauto. } - destruct r as [|[|] rl rx rr]; auto_tc. -Qed. - -Lemma remove_spec s x y `{Ok s} : - InT y (remove x s) <-> InT y s /\ ~X.eq y x. -Proof. -unfold remove. now autorew. -Qed. - -Global Hint Rewrite remove_spec : rb. - -#[global] -Instance remove_ok s x `{Ok s} : Ok (remove x s). -Proof. -unfold remove; auto_tc. -Qed. - -(** ** Removing the minimal element *) - -Lemma delmin_spec l y r c x s' `{O : Ok (Node c l y r)} : - delmin l y r = (x,s') -> - min_elt (Node c l y r) = Some x /\ del x (Node c l y r) = s'. -Proof. - revert y r c x s' O. - induction l as [|lc ll IH ly lr _]. - - simpl. intros y r _ x s' _. injection 1; intros; subst. - now rewrite MX.compare_refl. - - intros y r c x s' O. - simpl delmin. - specialize (IH ly lr). destruct delmin as (x0,s0). - destruct (IH lc x0 s0); clear IH; [ok|trivial|]. - remember (Node lc ll ly lr) as l. - simpl min_elt in *. - intros E. - replace x0 with x in * by (destruct lc; now injection E). - split. - * subst l; intuition. - * assert (X.lt x y). - { inversion_clear O. - assert (InT x l) by now apply min_elt_spec1. auto. } - simpl. case X.compare_spec; try order. - destruct lc; injection E; subst l s0; auto. -Qed. - -Lemma remove_min_spec1 s x s' `{Ok s}: - remove_min s = Some (x,s') -> - min_elt s = Some x /\ remove x s = s'. -Proof. - unfold remove_min. - destruct s as [|c l y r]; try easy. - generalize (delmin_spec l y r c). - destruct delmin as (x0,s0). intros D. - destruct (D x0 s0) as (->,<-); auto. - fold (remove x0 (Node c l y r)). - inversion_clear 1; auto. -Qed. - -Lemma remove_min_spec2 s : remove_min s = None -> Empty s. -Proof. - unfold remove_min. - destruct s as [|c l y r]. - - easy. - - now destruct delmin. -Qed. - -Lemma remove_min_ok (s:t) `{Ok s}: - match remove_min s with - | Some (_,s') => Ok s' - | None => True - end. -Proof. - generalize (remove_min_spec1 s). - destruct remove_min as [(x0,s0)|]; auto. - intros R. destruct (R x0 s0); auto. subst s0. auto_tc. -Qed. - -(** ** Treeify *) - -Notation ifpred p n := (if p then pred n else n%nat). - -Definition treeify_invariant size (f:treeify_t) := - forall acc, - size <= length acc -> - let (t,acc') := f acc in - cardinal t = size /\ acc = elements t ++ acc'. - -Lemma treeify_zero_spec : treeify_invariant 0 treeify_zero. -Proof. - intro. simpl. auto. -Qed. - -Lemma treeify_one_spec : treeify_invariant 1 treeify_one. -Proof. - intros [|x acc]; simpl; auto; inversion 1. -Qed. - -Lemma treeify_cont_spec f g size1 size2 size : - treeify_invariant size1 f -> - treeify_invariant size2 g -> - size = S (size1 + size2) -> - treeify_invariant size (treeify_cont f g). -Proof. - intros Hf Hg EQ acc LE. unfold treeify_cont. - specialize (Hf acc). - destruct (f acc) as (t1,acc1). - destruct Hf as (Hf1,Hf2). - { transitivity size; trivial. subst. rewrite <- Nat.add_succ_r. apply Nat.le_add_r. } - destruct acc1 as [|x acc1]. - { exfalso. revert LE. apply Nat.lt_nge. subst. - rewrite app_nil_r, <- elements_cardinal. - apply (Nat.succ_le_mono (cardinal t1)), Nat.le_add_r. } - specialize (Hg acc1). - destruct (g acc1) as (t2,acc2). - destruct Hg as (Hg1,Hg2). - { revert LE. subst. - rewrite length_app, <- elements_cardinal. simpl. - rewrite Nat.add_succ_r, <- Nat.succ_le_mono. - apply Nat.add_le_mono_l. } - rewrite elements_node, <- app_assoc. now subst. -Qed. - -Lemma treeify_aux_spec n (p:bool) : - treeify_invariant (ifpred p (Pos.to_nat n)) (treeify_aux p n). -Proof. - revert p. - induction n as [n|n|]; intros p; simpl treeify_aux. - - eapply treeify_cont_spec; [ apply (IHn false) | apply (IHn p) | ]. - rewrite Pos2Nat.inj_xI. - assert (H := Pos2Nat.is_pos n). apply Nat.neq_0_lt_0 in H. - destruct p; simpl; intros; rewrite Nat.add_0_r; trivial. - now rewrite <- Nat.add_succ_r, Nat.succ_pred; trivial. - - eapply treeify_cont_spec; [ apply (IHn p) | apply (IHn true) | ]. - rewrite Pos2Nat.inj_xO. - assert (H := Pos2Nat.is_pos n). apply Nat.neq_0_lt_0 in H. - rewrite <- Nat.add_succ_r, Nat.succ_pred by trivial. - destruct p; simpl; intros; rewrite Nat.add_0_r; trivial. - symmetry. now apply Nat.add_pred_l. - - destruct p; [ apply treeify_zero_spec | apply treeify_one_spec ]. -Qed. - -Lemma plength_aux_spec l p : - Pos.to_nat (plength_aux l p) = length l + Pos.to_nat p. -Proof. - revert p. induction l; trivial. simpl plength_aux. - intros. now rewrite IHl, Pos2Nat.inj_succ, Nat.add_succ_r. -Qed. - -Lemma plength_spec l : Pos.to_nat (plength l) = S (length l). -Proof. - unfold plength. rewrite plength_aux_spec. apply Nat.add_1_r. -Qed. - -Lemma treeify_elements l : elements (treeify l) = l. -Proof. - assert (H := treeify_aux_spec (plength l) true l). - unfold treeify. destruct treeify_aux as (t,acc); simpl in *. - destruct H as (H,H'). { now rewrite plength_spec. } - subst l. rewrite plength_spec, length_app, <- elements_cardinal in *. - destruct acc. - * now rewrite app_nil_r. - * exfalso. revert H. simpl. - rewrite Nat.add_succ_r, Nat.add_comm. - apply Nat.succ_add_discr. -Qed. - -Lemma treeify_spec x l : InT x (treeify l) <-> InA X.eq x l. -Proof. - intros. now rewrite <- elements_spec1, treeify_elements. -Qed. - -Lemma treeify_ok l : sort X.lt l -> Ok (treeify l). -Proof. - intros. apply elements_sort_ok. rewrite treeify_elements; auto. -Qed. - - -(** ** Filter *) - -Lemma filter_aux_elements s f acc : - filter_aux f s acc = List.filter f (elements s) ++ acc. -Proof. - revert acc. - induction s as [|c l IHl x r IHr]; trivial. - intros acc. - rewrite elements_node, List.filter_app. simpl. - destruct (f x); now rewrite IHl, IHr, <- app_assoc. -Qed. - -Lemma filter_elements s f : - elements (filter f s) = List.filter f (elements s). -Proof. - unfold filter. - now rewrite treeify_elements, filter_aux_elements, app_nil_r. -Qed. - -Lemma filter_spec s x f : - Proper (X.eq==>Logic.eq) f -> - (InT x (filter f s) <-> InT x s /\ f x = true). -Proof. - intros Hf. - rewrite <- elements_spec1, filter_elements, filter_InA, elements_spec1; - now auto_tc. -Qed. - -#[global] -Instance filter_ok s f `(Ok s) : Ok (filter f s). -Proof. - apply elements_sort_ok. - rewrite filter_elements. - apply filter_sort with X.eq; auto_tc. -Qed. - -(** ** Partition *) - -Lemma partition_aux_spec s f acc1 acc2 : - partition_aux f s acc1 acc2 = - (filter_aux f s acc1, filter_aux (fun x => negb (f x)) s acc2). -Proof. - revert acc1 acc2. - induction s as [ | c l Hl x r Hr ]; simpl. - - trivial. - - intros acc1 acc2. - destruct (f x); simpl; now rewrite Hr, Hl. -Qed. - -Lemma partition_spec s f : - partition f s = (filter f s, filter (fun x => negb (f x)) s). -Proof. - unfold partition, filter. now rewrite partition_aux_spec. -Qed. - -Lemma partition_spec1 s f : - Proper (X.eq==>Logic.eq) f -> - Equal (fst (partition f s)) (filter f s). -Proof. now rewrite partition_spec. Qed. - -Lemma partition_spec2 s f : - Proper (X.eq==>Logic.eq) f -> - Equal (snd (partition f s)) (filter (fun x => negb (f x)) s). -Proof. now rewrite partition_spec. Qed. - -#[global] -Instance partition_ok1 s f `(Ok s) : Ok (fst (partition f s)). -Proof. rewrite partition_spec; now apply filter_ok. Qed. - -#[global] -Instance partition_ok2 s f `(Ok s) : Ok (snd (partition f s)). -Proof. rewrite partition_spec; now apply filter_ok. Qed. - - -(** ** An invariant for binary list functions with accumulator. *) - -Ltac inA := - rewrite ?InA_app_iff, ?InA_cons, ?InA_nil, ?InA_rev in *; auto_tc. - -Record INV l1 l2 acc : Prop := { - l1_sorted : sort X.lt (rev l1); - l2_sorted : sort X.lt (rev l2); - acc_sorted : sort X.lt acc; - l1_lt_acc x y : InA X.eq x l1 -> InA X.eq y acc -> X.lt x y; - l2_lt_acc x y : InA X.eq x l2 -> InA X.eq y acc -> X.lt x y}. -Local Hint Resolve l1_sorted l2_sorted acc_sorted : core. - -Lemma INV_init s1 s2 `(Ok s1, Ok s2) : - INV (rev_elements s1) (rev_elements s2) nil. -Proof. - rewrite !rev_elements_rev. - split; rewrite ?rev_involutive; auto; intros; now inA. -Qed. - -Lemma INV_sym l1 l2 acc : INV l1 l2 acc -> INV l2 l1 acc. -Proof. - destruct 1; now split. -Qed. - -Lemma INV_drop x1 l1 l2 acc : - INV (x1 :: l1) l2 acc -> INV l1 l2 acc. -Proof. - intros (l1s,l2s,accs,l1a,l2a). simpl in *. - destruct (sorted_app_inv _ _ l1s) as (U & V & W); auto. - split; auto. -Qed. - -Lemma INV_eq x1 x2 l1 l2 acc : - INV (x1 :: l1) (x2 :: l2) acc -> X.eq x1 x2 -> - INV l1 l2 (x1 :: acc). -Proof. - intros (U,V,W,X,Y) EQ. simpl in *. - destruct (sorted_app_inv _ _ U) as (U1 & U2 & U3); auto. - destruct (sorted_app_inv _ _ V) as (V1 & V2 & V3); auto. - split; auto. - - constructor; auto. apply InA_InfA with X.eq; auto_tc. - - intros x y; inA; intros Hx [Hy|Hy]. - + apply U3; inA. - + apply X; inA. - - intros x y; inA; intros Hx [Hy|Hy]. - + rewrite Hy, EQ; apply V3; inA. - + apply Y; inA. -Qed. - -Lemma INV_lt x1 x2 l1 l2 acc : - INV (x1 :: l1) (x2 :: l2) acc -> X.lt x1 x2 -> - INV (x1 :: l1) l2 (x2 :: acc). -Proof. - intros (U,V,W,X,Y) EQ. simpl in *. - destruct (sorted_app_inv _ _ U) as (U1 & U2 & U3); auto. - destruct (sorted_app_inv _ _ V) as (V1 & V2 & V3); auto. - split; auto. - - constructor; auto. apply InA_InfA with X.eq; auto_tc. - - intros x y; inA; intros Hx [Hy|Hy]. - + rewrite Hy; clear Hy. destruct Hx; [order|]. - transitivity x1; auto. apply U3; inA. - + apply X; inA. - - intros x y; inA; intros Hx [Hy|Hy]. - + rewrite Hy. apply V3; inA. - + apply Y; inA. -Qed. - -Lemma INV_rev l1 l2 acc : - INV l1 l2 acc -> Sorted X.lt (rev_append l1 acc). -Proof. - intros. rewrite rev_append_rev. - apply SortA_app with X.eq; eauto with *. - intros x y. inA. eapply @l1_lt_acc; eauto. -Qed. - -(** ** union *) - -Lemma union_list_ok l1 l2 acc : - INV l1 l2 acc -> sort X.lt (union_list l1 l2 acc). -Proof. - revert l2 acc. - induction l1 as [|x1 l1 IH1]; - [intro l2|induction l2 as [|x2 l2 IH2]]; - intros acc inv. - - eapply INV_rev, INV_sym; eauto. - - eapply INV_rev; eauto. - - simpl. case X.compare_spec; intro C. - * apply IH1. eapply INV_eq; eauto. - * apply (IH2 (x2::acc)). eapply INV_lt; eauto. - * apply IH1. eapply INV_sym, INV_lt; eauto. now apply INV_sym. -Qed. - -#[global] -Instance linear_union_ok s1 s2 `(Ok s1, Ok s2) : - Ok (linear_union s1 s2). -Proof. - unfold linear_union. now apply treeify_ok, union_list_ok, INV_init. -Qed. - -#[global] -Instance fold_add_ok s1 s2 `(Ok s1, Ok s2) : - Ok (fold add s1 s2). -Proof. - rewrite fold_spec, <- fold_left_rev_right. - unfold elt in *. - induction (rev (elements s1)); simpl; unfold flip in *; auto_tc. -Qed. - -#[global] -Instance union_ok s1 s2 `(Ok s1, Ok s2) : Ok (union s1 s2). -Proof. - unfold union. destruct compare_height; auto_tc. -Qed. - -Lemma union_list_spec x l1 l2 acc : - InA X.eq x (union_list l1 l2 acc) <-> - InA X.eq x l1 \/ InA X.eq x l2 \/ InA X.eq x acc. -Proof. - revert l2 acc. - induction l1 as [|x1 l1 IH1]. - - intros l2 acc; simpl. rewrite rev_append_rev. inA. tauto. - - induction l2 as [|x2 l2 IH2]; intros acc; simpl. - * rewrite rev_append_rev. inA. tauto. - * case X.compare_spec; intro C. - + rewrite IH1, !InA_cons, C; tauto. - + rewrite (IH2 (x2::acc)), !InA_cons. tauto. - + rewrite IH1, !InA_cons; tauto. -Qed. - -Lemma linear_union_spec s1 s2 x : - InT x (linear_union s1 s2) <-> InT x s1 \/ InT x s2. -Proof. - unfold linear_union. - rewrite treeify_spec, union_list_spec, !rev_elements_rev. - rewrite !InA_rev, InA_nil, !elements_spec1 by auto_tc. - tauto. -Qed. - -Lemma fold_add_spec s1 s2 x : - InT x (fold add s1 s2) <-> InT x s1 \/ InT x s2. -Proof. - rewrite fold_spec, <- fold_left_rev_right. - rewrite <- (elements_spec1 s1), <- InA_rev by auto_tc. - unfold elt in *. - induction (rev (elements s1)); simpl. - - rewrite InA_nil. tauto. - - unfold flip. rewrite add_spec', IHl, InA_cons. tauto. -Qed. - -Lemma union_spec' s1 s2 x : - InT x (union s1 s2) <-> InT x s1 \/ InT x s2. -Proof. - unfold union. destruct compare_height. - - apply linear_union_spec. - - apply fold_add_spec. - - rewrite fold_add_spec. tauto. -Qed. - -Lemma union_spec : forall s1 s2 y `{Ok s1, Ok s2}, - (InT y (union s1 s2) <-> InT y s1 \/ InT y s2). -Proof. - intros; apply union_spec'. -Qed. - -(** ** inter *) - -Lemma inter_list_ok l1 l2 acc : - INV l1 l2 acc -> sort X.lt (inter_list l1 l2 acc). -Proof. - revert l2 acc. - induction l1 as [|x1 l1 IH1]; [|induction l2 as [|x2 l2 IH2]]; simpl. - - eauto. - - eauto. - - intros acc inv. - case X.compare_spec; intro C. - * apply IH1. eapply INV_eq; eauto. - * apply (IH2 acc). eapply INV_sym, INV_drop, INV_sym; eauto. - * apply IH1. eapply INV_drop; eauto. -Qed. - -#[global] -Instance linear_inter_ok s1 s2 `(Ok s1, Ok s2) : - Ok (linear_inter s1 s2). -Proof. - unfold linear_inter. now apply treeify_ok, inter_list_ok, INV_init. -Qed. - -#[global] -Instance inter_ok s1 s2 `(Ok s1, Ok s2) : Ok (inter s1 s2). -Proof. - unfold inter. destruct compare_height; auto_tc. -Qed. - -Lemma inter_list_spec x l1 l2 acc : - sort X.lt (rev l1) -> - sort X.lt (rev l2) -> - (InA X.eq x (inter_list l1 l2 acc) <-> - (InA X.eq x l1 /\ InA X.eq x l2) \/ InA X.eq x acc). -Proof. - revert l2 acc. - induction l1 as [|x1 l1 IH1]. - - intros l2 acc; simpl. inA. tauto. - - induction l2 as [|x2 l2 IH2]; intros acc. - * simpl. inA. tauto. - * simpl. intros U V. - destruct (sorted_app_inv _ _ U) as (U1 & U2 & U3); auto. - destruct (sorted_app_inv _ _ V) as (V1 & V2 & V3); auto. - case X.compare_spec; intro C. - + rewrite IH1, !InA_cons, C; tauto. - + rewrite (IH2 acc); auto. inA. intuition; try order. - assert (X.lt x x1) by (apply U3; inA). order. - + rewrite IH1; auto. inA. intuition; try order. - assert (X.lt x x2) by (apply V3; inA). order. -Qed. - -Lemma linear_inter_spec s1 s2 x `(Ok s1, Ok s2) : - InT x (linear_inter s1 s2) <-> InT x s1 /\ InT x s2. -Proof. - unfold linear_inter. - rewrite !rev_elements_rev, treeify_spec, inter_list_spec - by (rewrite rev_involutive; auto_tc). - rewrite !InA_rev, InA_nil, !elements_spec1 by auto_tc. tauto. -Qed. - -Local Instance mem_proper s `(Ok s) : - Proper (X.eq ==> Logic.eq) (fun k => mem k s). -Proof. - intros x y EQ. apply Bool.eq_iff_eq_true; rewrite !mem_spec; auto. - now rewrite EQ. -Qed. - -Lemma inter_spec s1 s2 y `{Ok s1, Ok s2} : - InT y (inter s1 s2) <-> InT y s1 /\ InT y s2. -Proof. - unfold inter. destruct compare_height. - - now apply linear_inter_spec. - - rewrite filter_spec, mem_spec by auto_tc; tauto. - - rewrite filter_spec, mem_spec by auto_tc; tauto. -Qed. - -(** ** difference *) - -Lemma diff_list_ok l1 l2 acc : - INV l1 l2 acc -> sort X.lt (diff_list l1 l2 acc). -Proof. - revert l2 acc. - induction l1 as [|x1 l1 IH1]; - [intro l2|induction l2 as [|x2 l2 IH2]]; - intros acc inv. - - eauto. - - unfold diff_list. eapply INV_rev; eauto. - - simpl. case X.compare_spec; intro C. - * apply IH1. eapply INV_drop, INV_sym, INV_drop, INV_sym; eauto. - * apply (IH2 acc). eapply INV_sym, INV_drop, INV_sym; eauto. - * apply IH1. eapply INV_sym, INV_lt; eauto. now apply INV_sym. -Qed. - -#[global] -Instance diff_inter_ok s1 s2 `(Ok s1, Ok s2) : - Ok (linear_diff s1 s2). -Proof. - unfold linear_inter. now apply treeify_ok, diff_list_ok, INV_init. -Qed. - -#[global] -Instance fold_remove_ok s1 s2 `(Ok s2) : - Ok (fold remove s1 s2). -Proof. - rewrite fold_spec, <- fold_left_rev_right. - unfold elt in *. - induction (rev (elements s1)); simpl; unfold flip in *; auto_tc. -Qed. - -#[global] -Instance diff_ok s1 s2 `(Ok s1, Ok s2) : Ok (diff s1 s2). -Proof. - unfold diff. destruct compare_height; auto_tc. -Qed. - -Lemma diff_list_spec x l1 l2 acc : - sort X.lt (rev l1) -> - sort X.lt (rev l2) -> - (InA X.eq x (diff_list l1 l2 acc) <-> - (InA X.eq x l1 /\ ~InA X.eq x l2) \/ InA X.eq x acc). -Proof. - revert l2 acc. - induction l1 as [|x1 l1 IH1]. - - intros l2 acc; simpl. inA. tauto. - - induction l2 as [|x2 l2 IH2]; intros acc. - + intros; simpl. rewrite rev_append_rev. inA. tauto. - + simpl. intros U V. - destruct (sorted_app_inv _ _ U) as (U1 & U2 & U3); auto. - destruct (sorted_app_inv _ _ V) as (V1 & V2 & V3); auto. - case X.compare_spec; intro C. - * rewrite IH1; auto. f_equiv. inA. intuition; try order. - assert (X.lt x x1) by (apply U3; inA). order. - * rewrite (IH2 acc); auto. f_equiv. inA. intuition; try order. - assert (X.lt x x1) by (apply U3; inA). order. - * rewrite IH1; auto. inA. intuition; try order. - left; split; auto. destruct 1. - -- order. - -- assert (X.lt x x2) by (apply V3; inA). order. -Qed. - -Lemma linear_diff_spec s1 s2 x `(Ok s1, Ok s2) : - InT x (linear_diff s1 s2) <-> InT x s1 /\ ~InT x s2. -Proof. - unfold linear_diff. - rewrite !rev_elements_rev, treeify_spec, diff_list_spec - by (rewrite rev_involutive; auto_tc). - rewrite !InA_rev, InA_nil, !elements_spec1 by auto_tc. tauto. -Qed. - -Lemma fold_remove_spec s1 s2 x `(Ok s2) : - InT x (fold remove s1 s2) <-> InT x s2 /\ ~InT x s1. -Proof. - rewrite fold_spec, <- fold_left_rev_right. - rewrite <- (elements_spec1 s1), <- InA_rev by auto_tc. - unfold elt in *. - induction (rev (elements s1)); simpl; intros. - - rewrite InA_nil. intuition. - - unfold flip in *. rewrite remove_spec, IHl, InA_cons. - + tauto. - + clear IHl. induction l; simpl; auto_tc. -Qed. - -Lemma diff_spec s1 s2 y `{Ok s1, Ok s2} : - InT y (diff s1 s2) <-> InT y s1 /\ ~InT y s2. -Proof. - unfold diff. destruct compare_height. - - now apply linear_diff_spec. - - rewrite filter_spec, Bool.negb_true_iff, - <- Bool.not_true_iff_false, mem_spec; - intuition. - intros x1 x2 EQ. f_equal. now apply mem_proper. - - now apply fold_remove_spec. -Qed. - -End MakeRaw. - -(** * Balancing properties - - We now prove that all operations preserve a red-black invariant, - and that trees have hence a logarithmic depth. -*) - -Module BalanceProps(X:Orders.OrderedType)(Import M : MakeRaw X). - -Local Notation Rd := (Node Red). -Local Notation Bk := (Node Black). -Import M.MX. - -(** ** Red-Black invariants *) - -(** In a red-black tree : - - a red node has no red children - - the black depth at each node is the same along all paths. - The black depth is here an argument of the predicate. *) - -Inductive rbt : nat -> tree -> Prop := - | RB_Leaf : rbt 0 Leaf - | RB_Rd n l k r : - notred l -> notred r -> rbt n l -> rbt n r -> rbt n (Rd l k r) - | RB_Bk n l k r : rbt n l -> rbt n r -> rbt (S n) (Bk l k r). - -(** A red-red tree is almost a red-black tree, except that it has - a _red_ root node which _may_ have red children. Note that a - red-red tree is hence non-empty, and all its strict subtrees - are red-black. *) - -Inductive rrt (n:nat) : tree -> Prop := - | RR_Rd l k r : rbt n l -> rbt n r -> rrt n (Rd l k r). - -(** An almost-red-black tree is almost a red-black tree, except that - it's permitted to have two red nodes in a row at the very root (only). - We implement this notion by saying that a quasi-red-black tree - is either a red-black tree or a red-red tree. *) - -Inductive arbt (n:nat)(t:tree) : Prop := - | ARB_RB : rbt n t -> arbt n t - | ARB_RR : rrt n t -> arbt n t. - -(** The main exported invariant : being a red-black tree for some - black depth. *) - -Class Rbt (t:tree) := RBT : exists d, rbt d t. - -(** ** Basic tactics and results about red-black *) - -Scheme rbt_ind := Induction for rbt Sort Prop. -Local Hint Constructors rbt rrt arbt : core. -Local Hint Extern 0 (notred _) => (exact I) : core. -Ltac invrb := intros; invtree rrt; invtree rbt; try contradiction. -Ltac desarb := match goal with H:arbt _ _ |- _ => destruct H end. -Ltac nonzero n := destruct n as [|n]; [try split; invrb|]. - -Lemma rr_nrr_rb n t : - rrt n t -> notredred t -> rbt n t. -Proof. - destruct 1 as [l x r Hl Hr]. - destruct l, r; descolor; invrb; auto. -Qed. - -Local Hint Resolve rr_nrr_rb : core. - -Lemma arb_nrr_rb n t : - arbt n t -> notredred t -> rbt n t. -Proof. - destruct 1; auto. -Qed. - -Lemma arb_nr_rb n t : - arbt n t -> notred t -> rbt n t. -Proof. - destruct 1; destruct t; descolor; invrb; auto. -Qed. - -Local Hint Resolve arb_nrr_rb arb_nr_rb : core. - -(** ** A Red-Black tree has indeed a logarithmic depth *) - -Definition redcarac s := rcase (fun _ _ _ => 1) (fun _ => 0) s. - -Lemma rb_maxdepth s n : rbt n s -> maxdepth s <= 2*n + redcarac s. -Proof. - induction 1. - - simpl; auto. - - replace (redcarac l) with 0 in * by now destree l. - replace (redcarac r) with 0 in * by now destree r. - simpl maxdepth. simpl redcarac. - rewrite Nat.add_succ_r, <- Nat.succ_le_mono. - now apply Nat.max_lub. - - simpl. rewrite <- Nat.succ_le_mono. - apply Nat.max_lub; eapply Nat.le_trans; eauto; - [destree l | destree r]; simpl; - rewrite !Nat.add_0_r, ?Nat.add_1_r, ?Nat.add_succ_r; auto. -Qed. - -Lemma rb_mindepth s n : rbt n s -> n + redcarac s <= mindepth s. -Proof. - induction 1; simpl. - - trivial. - - rewrite Nat.add_succ_r. - apply -> Nat.succ_le_mono. - replace (redcarac l) with 0 in * by now destree l. - replace (redcarac r) with 0 in * by now destree r. - now apply Nat.min_glb. - - apply -> Nat.succ_le_mono. rewrite Nat.add_0_r. - apply Nat.min_glb. - + refine (Nat.le_trans _ _ _ _ IHrbt1). - apply Nat.le_add_r. - + refine (Nat.le_trans _ _ _ _ IHrbt2). - apply Nat.le_add_r. -Qed. - -Lemma maxdepth_upperbound s : Rbt s -> - maxdepth s <= 2 * Nat.log2 (S (cardinal s)). -Proof. - intros (n,H). - eapply Nat.le_trans; [eapply rb_maxdepth; eauto|]. - transitivity (2*(n+redcarac s)). - - rewrite Nat.mul_add_distr_l. apply Nat.add_le_mono_l. - rewrite <- Nat.mul_1_l at 1. apply Nat.mul_le_mono_r. - auto. - - apply Nat.mul_le_mono_l. - transitivity (mindepth s). - + now apply rb_mindepth. - + apply mindepth_log_cardinal. -Qed. - -Lemma maxdepth_lowerbound s : s<>Leaf -> - Nat.log2 (cardinal s) < maxdepth s. -Proof. - apply maxdepth_log_cardinal. -Qed. - - -(** ** Singleton *) - -Lemma singleton_rb x : Rbt (singleton x). -Proof. - unfold singleton. exists 1; auto. -Qed. - -(** ** [makeBlack] and [makeRed] *) - -Lemma makeBlack_rb n t : arbt n t -> Rbt (makeBlack t). -Proof. - destruct t as [|[|] l x r]. - - exists 0; auto. - - destruct 1; invrb; exists (S n); simpl; auto. - - exists n; auto. -Qed. - -Lemma makeRed_rr t n : - rbt (S n) t -> notred t -> rrt n (makeRed t). -Proof. - destruct t as [|[|] l x r]; invrb; simpl; auto. -Qed. - -(** ** Balancing *) - -Lemma lbal_rb n l k r : - arbt n l -> rbt n r -> rbt (S n) (lbal l k r). -Proof. -case lbal_match; intros; desarb; invrb; auto. -Qed. - -Lemma rbal_rb n l k r : - rbt n l -> arbt n r -> rbt (S n) (rbal l k r). -Proof. -case rbal_match; intros; desarb; invrb; auto. -Qed. - -Lemma rbal'_rb n l k r : - rbt n l -> arbt n r -> rbt (S n) (rbal' l k r). -Proof. -case rbal'_match; intros; desarb; invrb; auto. -Qed. - -Lemma lbalS_rb n l x r : - arbt n l -> rbt (S n) r -> notred r -> rbt (S n) (lbalS l x r). -Proof. - intros Hl Hr Hr'. - destruct r as [|[|] rl rx rr]; invrb. clear Hr'. - revert Hl. - case lbalS_match. - - destruct 1; invrb; auto. - - intros. apply rbal'_rb; auto. -Qed. - -Lemma lbalS_arb n l x r : - arbt n l -> rbt (S n) r -> arbt (S n) (lbalS l x r). -Proof. - case lbalS_match. - - destruct 1; invrb; auto. - - clear l. intros l Hl Hl' Hr. - destruct r as [|[|] rl rx rr]; invrb. - * destruct rl as [|[|] rll rlx rlr]; invrb. - right; auto using rbal'_rb, makeRed_rr. - * left; apply rbal'_rb; auto. -Qed. - -Lemma rbalS_rb n l x r : - rbt (S n) l -> notred l -> arbt n r -> rbt (S n) (rbalS l x r). -Proof. - intros Hl Hl' Hr. - destruct l as [|[|] ll lx lr]; invrb. clear Hl'. - revert Hr. - case rbalS_match. - - destruct 1; invrb; auto. - - intros. apply lbal_rb; auto. -Qed. - -Lemma rbalS_arb n l x r : - rbt (S n) l -> arbt n r -> arbt (S n) (rbalS l x r). -Proof. - case rbalS_match. - - destruct 2; invrb; auto. - - clear r. intros r Hr Hr' Hl. - destruct l as [|[|] ll lx lr]; invrb. - * destruct lr as [|[|] lrl lrx lrr]; invrb. - right; auto using lbal_rb, makeRed_rr. - * left; apply lbal_rb; auto. -Qed. - - -(** ** Insertion *) - -(** The next lemmas combine simultaneous results about rbt and arbt. - A first solution here: statement with [if ... then ... else] *) - -Definition ifred s (A B:Prop) := rcase (fun _ _ _ => A) (fun _ => B) s. - -Lemma ifred_notred s A B : notred s -> (ifred s A B <-> B). -Proof. - destruct s; descolor; simpl; intuition. -Qed. - -Lemma ifred_or s A B : ifred s A B -> A\/B. -Proof. - destruct s; descolor; simpl; intuition. -Qed. - -Lemma ins_rr_rb x s n : rbt n s -> - ifred s (rrt n (ins x s)) (rbt n (ins x s)). -Proof. -induction 1 as [ | n l k r | n l k r Hl IHl Hr IHr ]. -- simpl; auto. -- simpl. rewrite ifred_notred in * by trivial. - elim_compare x k; auto. -- rewrite ifred_notred by trivial. - unfold ins; fold ins. (* simpl is too much here ... *) - elim_compare x k. - * auto. - * apply lbal_rb; trivial. apply ifred_or in IHl; intuition. - * apply rbal_rb; trivial. apply ifred_or in IHr; intuition. -Qed. - -Lemma ins_arb x s n : rbt n s -> arbt n (ins x s). -Proof. - intros H. apply (ins_rr_rb x), ifred_or in H. intuition. -Qed. - -#[global] -Instance add_rb x s : Rbt s -> Rbt (add x s). -Proof. - intros (n,H). unfold add. now apply (makeBlack_rb n), ins_arb. -Qed. - -(** ** Deletion *) - -(** A second approach here: statement with ... /\ ... *) - -Lemma append_arb_rb n l r : rbt n l -> rbt n r -> - (arbt n (append l r)) /\ - (notred l -> notred r -> rbt n (append l r)). -Proof. -revert r n. -append_tac l r. -- split; auto. -- split; auto. -- (* Red / Red *) - intros n. invrb. - case (IHlr n); auto; clear IHlr. - case append_rr_match. - + intros a x b _ H; split; invrb. - assert (rbt n (Rd a x b)) by auto. invrb. auto. - + split; invrb; auto. -- (* Red / Black *) - split; invrb. destruct (IHlr n) as (_,IH); auto. -- (* Black / Red *) - split; invrb. destruct (IHrl n) as (_,IH); auto. -- (* Black / Black *) - nonzero n. - invrb. - destruct (IHlr n) as (IH,_); auto; clear IHlr. - revert IH. - case append_bb_match. - + intros a x b IH; split; destruct IH; invrb; auto. - + split; [left | invrb]; auto using lbalS_rb. -Qed. - -(** A third approach : Lemma ... with ... *) - -Lemma del_arb s x n : rbt (S n) s -> isblack s -> arbt n (del x s) -with del_rb s x n : rbt n s -> notblack s -> rbt n (del x s). -Proof. -{ revert n. - induct s x; try destruct c; try contradiction; invrb. - - apply append_arb_rb; assumption. - - assert (IHl' := del_rb l x). clear IHr del_arb del_rb. - destruct l as [|[|] ll lx lr]; auto. - nonzero n. apply lbalS_arb; auto. - - assert (IHr' := del_rb r x). clear IHl del_arb del_rb. - destruct r as [|[|] rl rx rr]; auto. - nonzero n. apply rbalS_arb; auto. } -{ revert n. - induct s x; try assumption; try destruct c; try contradiction; invrb. - - apply append_arb_rb; assumption. - - assert (IHl' := del_arb l x). clear IHr del_arb del_rb. - destruct l as [|[|] ll lx lr]; auto. - nonzero n. destruct n as [|n]; [invrb|]; apply lbalS_rb; auto. - - assert (IHr' := del_arb r x). clear IHl del_arb del_rb. - destruct r as [|[|] rl rx rr]; auto. - nonzero n. apply rbalS_rb; auto. } -Qed. - -#[global] -Instance remove_rb s x : Rbt s -> Rbt (remove x s). -Proof. - intros (n,H). unfold remove. - destruct s as [|[|] l y r]. - - apply (makeBlack_rb n). auto. - - apply (makeBlack_rb n). left. apply del_rb; simpl; auto. - - nonzero n. apply (makeBlack_rb n). apply del_arb; simpl; auto. -Qed. - -(** ** Treeify *) - -Definition treeify_rb_invariant size depth (f:treeify_t) := - forall acc, - size <= length acc -> - rbt depth (fst (f acc)) /\ - size + length (snd (f acc)) = length acc. - -Lemma treeify_zero_rb : treeify_rb_invariant 0 0 treeify_zero. -Proof. - intros acc _; simpl; auto. -Qed. - -Lemma treeify_one_rb : treeify_rb_invariant 1 0 treeify_one. -Proof. - intros [|x acc]; simpl; auto; inversion 1. -Qed. - -Lemma treeify_cont_rb f g size1 size2 size d : - treeify_rb_invariant size1 d f -> - treeify_rb_invariant size2 d g -> - size = S (size1 + size2) -> - treeify_rb_invariant size (S d) (treeify_cont f g). -Proof. - intros Hf Hg H acc Hacc. - unfold treeify_cont. - specialize (Hf acc). - destruct (f acc) as (l, acc1). simpl in *. - destruct Hf as (Hf1, Hf2). - { subst. refine (Nat.le_trans _ _ _ _ Hacc). - rewrite <- Nat.add_succ_r. apply Nat.le_add_r. } - destruct acc1 as [|x acc2]; simpl in *. - - exfalso. revert Hacc. apply Nat.lt_nge. rewrite H, <- Hf2. - rewrite Nat.add_0_r. apply (Nat.succ_le_mono size1), Nat.le_add_r. - - specialize (Hg acc2). - destruct (g acc2) as (r, acc3). simpl in *. - destruct Hg as (Hg1, Hg2). - { revert Hacc. - rewrite H, <- Hf2, Nat.add_succ_r, <- Nat.succ_le_mono. - apply Nat.add_le_mono_l. } - split; auto. - now rewrite H, <- Hf2, <- Hg2, Nat.add_succ_r, Nat.add_assoc. -Qed. - -Lemma treeify_aux_rb n : - exists d, forall (b:bool), - treeify_rb_invariant (ifpred b (Pos.to_nat n)) d (treeify_aux b n). -Proof. - induction n as [n (d,IHn)|n (d,IHn)| ]. - - exists (S d). intros b. - eapply treeify_cont_rb; [ apply (IHn false) | apply (IHn b) | ]. - rewrite Pos2Nat.inj_xI. - assert (H := Pos2Nat.is_pos n). apply Nat.neq_0_lt_0 in H. - destruct b; simpl; intros; rewrite Nat.add_0_r; trivial. - now rewrite <- Nat.add_succ_r, Nat.succ_pred; trivial. - - exists (S d). intros b. - eapply treeify_cont_rb; [ apply (IHn b) | apply (IHn true) | ]. - rewrite Pos2Nat.inj_xO. - assert (H := Pos2Nat.is_pos n). apply Nat.neq_0_lt_0 in H. - rewrite <- Nat.add_succ_r, Nat.succ_pred by trivial. - destruct b; simpl; intros; rewrite Nat.add_0_r; trivial. - symmetry. now apply Nat.add_pred_l. - - exists 0; destruct b; - [ apply treeify_zero_rb | apply treeify_one_rb ]. -Qed. - -(** The black depth of [treeify l] is actually a log2, but - we don't need to mention that. *) - -#[global] -Instance treeify_rb l : Rbt (treeify l). -Proof. - unfold treeify. - destruct (treeify_aux_rb (plength l)) as (d,H). - exists d. - apply H. - now rewrite plength_spec. -Qed. - -(** ** Filtering *) - -#[global] -Instance filter_rb f s : Rbt (filter f s). -Proof. - unfold filter; auto_tc. -Qed. - -#[global] -Instance partition_rb1 f s : Rbt (fst (partition f s)). -Proof. - unfold partition. destruct partition_aux. simpl. auto_tc. -Qed. - -#[global] -Instance partition_rb2 f s : Rbt (snd (partition f s)). -Proof. - unfold partition. destruct partition_aux. simpl. auto_tc. -Qed. - -(** ** Union, intersection, difference *) - -#[global] -Instance fold_add_rb s1 s2 : Rbt s2 -> Rbt (fold add s1 s2). -Proof. - intros. rewrite fold_spec, <- fold_left_rev_right. unfold elt in *. - induction (rev (elements s1)); simpl; unfold flip in *; auto_tc. -Qed. - -#[global] -Instance fold_remove_rb s1 s2 : Rbt s2 -> Rbt (fold remove s1 s2). -Proof. - intros. rewrite fold_spec, <- fold_left_rev_right. unfold elt in *. - induction (rev (elements s1)); simpl; unfold flip in *; auto_tc. -Qed. - -Lemma union_rb s1 s2 : Rbt s1 -> Rbt s2 -> Rbt (union s1 s2). -Proof. - intros. unfold union, linear_union. destruct compare_height; auto_tc. -Qed. - -Lemma inter_rb s1 s2 : Rbt s1 -> Rbt s2 -> Rbt (inter s1 s2). -Proof. - intros. unfold inter, linear_inter. destruct compare_height; auto_tc. -Qed. - -Lemma diff_rb s1 s2 : Rbt s1 -> Rbt s2 -> Rbt (diff s1 s2). -Proof. - intros. unfold diff, linear_diff. destruct compare_height; auto_tc. -Qed. - -End BalanceProps. - -(** * Final Encapsulation - - Now, in order to really provide a functor implementing [S], we - need to encapsulate everything into a type of binary search trees. - They also happen to be well-balanced, but this has no influence - on the correctness of operations, so we won't state this here, - see [BalanceProps] if you need more than just the MSet interface. -*) - -Module Type MSetInterface_S_Ext := MSetInterface.S <+ MSetRemoveMin. - -Module Make (X: Orders.OrderedType) <: - MSetInterface_S_Ext with Module E := X. - Module Raw. Include MakeRaw X. End Raw. - Include MSetInterface.Raw2Sets X Raw. - - Definition opt_ok (x:option (elt * Raw.t)) := - match x with Some (_,s) => Raw.Ok s | None => True end. - - Definition mk_opt_t (x: option (elt * Raw.t))(P: opt_ok x) : - option (elt * t) := - match x as o return opt_ok o -> option (elt * t) with - | Some (k,s') => fun P : Raw.Ok s' => Some (k, Mkt s') - | None => fun _ => None - end P. - - Definition remove_min s : option (elt * t) := - mk_opt_t (Raw.remove_min (this s)) (Raw.remove_min_ok s). - - Lemma remove_min_spec1 s x s' : - remove_min s = Some (x,s') -> - min_elt s = Some x /\ Equal (remove x s) s'. - Proof. - destruct s as (s,Hs). - unfold remove_min, mk_opt_t, min_elt, remove, Equal, In; simpl. - generalize (fun x s' => @Raw.remove_min_spec1 s x s' Hs). - set (P := Raw.remove_min_ok s). clearbody P. - destruct (Raw.remove_min s) as [(x0,s0)|]; try easy. - intros H [= -> <-]. simpl. - destruct (H x s0); auto. subst; intuition. - Qed. - - Lemma remove_min_spec2 s : remove_min s = None -> Empty s. - Proof. - destruct s as (s,Hs). - unfold remove_min, mk_opt_t, Empty, In; simpl. - generalize (Raw.remove_min_spec2 s). - set (P := Raw.remove_min_ok s). clearbody P. - destruct (Raw.remove_min s) as [(x0,s0)|]; now intuition. - Qed. - -End Make. diff --git a/stdlib/theories/MSets/MSetToFiniteSet.v b/stdlib/theories/MSets/MSetToFiniteSet.v deleted file mode 100644 index cc5161922c71..000000000000 --- a/stdlib/theories/MSets/MSetToFiniteSet.v +++ /dev/null @@ -1,156 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* Ensemble M.elt := - fun s x => M.In x s. - - Notation " !! " := mkEns. - - Lemma In_In : forall s x, M.In x s <-> In _ (!!s) x. - Proof. - unfold In; compute; auto with extcore. - Qed. - - Lemma Subset_Included : forall s s', s[<=]s' <-> Included _ (!!s) (!!s'). - Proof. - unfold Subset, Included, In, mkEns; intuition. - Qed. - - Notation " a === b " := (Same_set M.elt a b) (at level 70, no associativity). - - Lemma Equal_Same_set : forall s s', s[=]s' <-> !!s === !!s'. - Proof. - intros. - rewrite double_inclusion. - unfold Subset, Included, Same_set, In, mkEns; intuition. - Qed. - - Lemma empty_Empty_Set : !!M.empty === Empty_set _. - Proof. - unfold Same_set, Included, mkEns, In. - split; intro; set_iff; inversion 1. - Qed. - - Lemma Empty_Empty_set : forall s, Empty s -> !!s === Empty_set _. - Proof. - unfold Same_set, Included, mkEns, In. - split; intros. - - destruct(H x H0). - - inversion H0. - Qed. - - Lemma singleton_Singleton : forall x, !!(M.singleton x) === Singleton _ x . - Proof. - unfold Same_set, Included, mkEns, In. - split; intro; set_iff; inversion 1; try constructor; auto. - Qed. - - Lemma union_Union : forall s s', !!(union s s') === Union _ (!!s) (!!s'). - Proof. - unfold Same_set, Included, mkEns, In. - split; intro; set_iff; inversion 1; [ constructor 1 | constructor 2 | | ]; auto. - Qed. - - Lemma inter_Intersection : forall s s', !!(inter s s') === Intersection _ (!!s) (!!s'). - Proof. - unfold Same_set, Included, mkEns, In. - split; intro; set_iff; inversion 1; try constructor; auto. - Qed. - - Lemma add_Add : forall x s, !!(add x s) === Add _ (!!s) x. - Proof. - unfold Same_set, Included, mkEns, In. - split; intro; set_iff; inversion 1; auto with sets. - - inversion H0. - constructor 2; constructor. - - constructor 1; auto. - Qed. - - Lemma Add_Add : forall x s s', MP.Add x s s' -> !!s' === Add _ (!!s) x. - Proof. - unfold Same_set, Included, mkEns, In. - split; intros. - - red in H; rewrite H in H0. - destruct H0. - + inversion H0. - constructor 2; constructor. - + constructor 1; auto. - - red in H; rewrite H. - inversion H0; auto. - inversion H1; auto. - Qed. - - Lemma remove_Subtract : forall x s, !!(remove x s) === Subtract _ (!!s) x. - Proof. - unfold Same_set, Included, mkEns, In. - split; intro; set_iff; inversion 1; auto with sets. - split; auto. - contradict H1. - inversion H1; auto. - Qed. - - Lemma mkEns_Finite : forall s, Finite _ (!!s). - Proof. - intro s; pattern s; apply set_induction; clear s; intros. - - intros; replace (!!s) with (Empty_set elt); auto with sets. - symmetry; apply Extensionality_Ensembles. - apply Empty_Empty_set; auto. - - replace (!!s') with (Add _ (!!s) x). - + constructor 2; auto. - + symmetry; apply Extensionality_Ensembles. - apply Add_Add; auto. - Qed. - - Lemma mkEns_cardinal : forall s, cardinal _ (!!s) (M.cardinal s). - Proof. - intro s; pattern s; apply set_induction; clear s; intros. - - intros; replace (!!s) with (Empty_set elt); auto with sets. - + rewrite MP.cardinal_1; auto with sets. - + symmetry; apply Extensionality_Ensembles. - apply Empty_Empty_set; auto. - - replace (!!s') with (Add _ (!!s) x). - + rewrite (cardinal_2 H0 H1); auto with sets. - + symmetry; apply Extensionality_Ensembles. - apply Add_Add; auto. - Qed. - - (** we can even build a function from Finite Ensemble to MSet - ... at least in Prop. *) - - Lemma Ens_to_MSet : forall e : Ensemble M.elt, Finite _ e -> - exists s:M.t, !!s === e. - Proof. - induction 1. - - exists M.empty. - apply empty_Empty_Set. - - destruct IHFinite as (s,Hs). - exists (M.add x s). - apply Extensionality_Ensembles in Hs. - rewrite <- Hs. - apply add_Add. - Qed. - -End WS_to_Finite_set. - - -Module S_to_Finite_set (U:UsualOrderedType)(M: SetsOn U) := - WS_to_Finite_set U M. diff --git a/stdlib/theories/MSets/MSetWeakList.v b/stdlib/theories/MSets/MSetWeakList.v deleted file mode 100644 index 4e4342c146de..000000000000 --- a/stdlib/theories/MSets/MSetWeakList.v +++ /dev/null @@ -1,547 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* false - | y :: l => - if X.eq_dec x y then true else mem x l - end. - - Fixpoint add (x : elt) (s : t) : t := - match s with - | nil => x :: nil - | y :: l => - if X.eq_dec x y then s else y :: add x l - end. - - Definition singleton (x : elt) : t := x :: nil. - - Fixpoint remove (x : elt) (s : t) : t := - match s with - | nil => nil - | y :: l => - if X.eq_dec x y then l else y :: remove x l - end. - - Definition fold (B : Type) (f : elt -> B -> B) : t -> B -> B := - fold_left (flip f). - - Definition union (s : t) : t -> t := fold add s. - - Definition diff (s s' : t) : t := fold remove s' s. - - Definition inter (s s': t) : t := - fold (fun x s => if mem x s' then add x s else s) s nil. - - Definition subset (s s' : t) : bool := is_empty (diff s s'). - - Definition equal (s s' : t) : bool := andb (subset s s') (subset s' s). - - Fixpoint filter (f : elt -> bool) (s : t) : t := - match s with - | nil => nil - | x :: l => if f x then x :: filter f l else filter f l - end. - - Fixpoint for_all (f : elt -> bool) (s : t) : bool := - match s with - | nil => true - | x :: l => if f x then for_all f l else false - end. - - Fixpoint exists_ (f : elt -> bool) (s : t) : bool := - match s with - | nil => false - | x :: l => if f x then true else exists_ f l - end. - - Fixpoint partition (f : elt -> bool) (s : t) : t * t := - match s with - | nil => (nil, nil) - | x :: l => - let (s1, s2) := partition f l in - if f x then (x :: s1, s2) else (s1, x :: s2) - end. - - Definition cardinal (s : t) : nat := length s. - - Definition elements (s : t) : list elt := s. - - Definition choose (s : t) : option elt := - match s with - | nil => None - | x::_ => Some x - end. - -End Ops. - -(** ** Proofs of set operation specifications. *) - -Module MakeRaw (X:DecidableType) <: WRawSets X. - Include Ops X. - - Section ForNotations. - Notation NoDup := (NoDupA X.eq). - Notation In := (InA X.eq). - - (* TODO: modify proofs in order to avoid these hints *) - Let eqr:= (@Equivalence_Reflexive _ _ X.eq_equiv). - Let eqsym:= (@Equivalence_Symmetric _ _ X.eq_equiv). - Let eqtrans:= (@Equivalence_Transitive _ _ X.eq_equiv). - #[local] - Hint Resolve eqr eqtrans : core. - #[local] - Hint Immediate eqsym : core. - - Definition IsOk := NoDup. - - Class Ok (s:t) : Prop := ok : NoDup s. - - #[local] - Hint Unfold Ok : core. - #[local] - Hint Resolve ok : core. - - Instance NoDup_Ok s (nd : NoDup s) : Ok s := { ok := nd }. - - Ltac inv_ok := match goal with - | H:Ok (_ :: _) |- _ => inversion_clear H; inv_ok - | H:Ok nil |- _ => clear H; inv_ok - | H:NoDup ?l |- _ => change (Ok l) in H; inv_ok - | _ => idtac - end. - - Ltac inv := invlist InA; inv_ok. - Ltac constructors := repeat constructor. - - Fixpoint isok l := match l with - | nil => true - | a::l => negb (mem a l) && isok l - end. - - Definition Equal s s' := forall a : elt, In a s <-> In a s'. - Definition Subset s s' := forall a : elt, In a s -> In a s'. - Definition Empty s := forall a : elt, ~ In a s. - Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x. - Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x. - - Lemma In_compat : Proper (X.eq==>eq==>iff) In. - Proof. - repeat red; intros. subst. rewrite H; auto. - Qed. - - Lemma mem_spec : forall s x `{Ok s}, - mem x s = true <-> In x s. - Proof. - induction s; intros. - - split; intros; inv. discriminate. - - simpl; destruct (X.eq_dec x a); split; intros; inv; auto. - + right; rewrite <- IHs; auto. - + rewrite IHs; auto. - Qed. - - Lemma isok_iff : forall l, Ok l <-> isok l = true. - Proof. - induction l. - - intuition. - - simpl. - rewrite andb_true_iff. - rewrite negb_true_iff. - rewrite <- IHl. - split; intros H. - + inv. - split; auto. - apply not_true_is_false. rewrite mem_spec; auto. - + destruct H; constructors; auto. - rewrite <- mem_spec; auto; congruence. - Qed. - - Global Instance isok_Ok l : isok l = true -> Ok l | 10. - Proof. - intros. apply <- isok_iff; auto. - Qed. - - Lemma add_spec : - forall (s : t) (x y : elt) {Hs : Ok s}, - In y (add x s) <-> X.eq y x \/ In y s. - Proof. - induction s; simpl; intros. - - intuition; inv; auto. - - destruct X.eq_dec; inv; rewrite InA_cons, ?IHs; intuition. - + left; eauto. - + inv; auto. - Qed. - - Global Instance add_ok s x `(Ok s) : Ok (add x s). - Proof. - induction s. - - simpl; intuition. - - intros; inv. simpl. - destruct X.eq_dec; auto. - constructors; auto. - intro; inv; auto. - rewrite add_spec in *; intuition. - Qed. - - Lemma remove_spec : - forall (s : t) (x y : elt) {Hs : Ok s}, - In y (remove x s) <-> In y s /\ ~X.eq y x. - Proof. - induction s; simpl; intros. - - intuition; inv; auto. - - destruct X.eq_dec as [|Hnot]; inv; rewrite !InA_cons, ?IHs; intuition. - + elim H. setoid_replace a with y; eauto. - + elim H3. setoid_replace x with y; eauto. - + elim Hnot. eauto. - Qed. - - Global Instance remove_ok s x `(Ok s) : Ok (remove x s). - Proof. - induction s; simpl; intros. - - auto. - - destruct X.eq_dec; inv; auto. - constructors; auto. - rewrite remove_spec; intuition. - Qed. - - Lemma singleton_ok : forall x : elt, Ok (singleton x). - Proof. - unfold singleton; simpl; constructors; auto. intro; inv. - Qed. - - Lemma singleton_spec : forall x y : elt, In y (singleton x) <-> X.eq y x. - Proof. - unfold singleton; simpl; split; intros. - - inv; auto. - - left; auto. - Qed. - - Lemma empty_ok : Ok empty. - Proof. - unfold empty; constructors. - Qed. - - Lemma empty_spec : Empty empty. - Proof. - unfold Empty, empty; red; intros; inv. - Qed. - - Lemma is_empty_spec : forall s : t, is_empty s = true <-> Empty s. - Proof. - unfold Empty; destruct s; simpl; split; intros; auto. - - intro; inv. - - discriminate. - - elim (H e); auto. - Qed. - - Lemma elements_spec1 : forall (s : t) (x : elt), In x (elements s) <-> In x s. - Proof. - unfold elements; intuition. - Qed. - - Lemma elements_spec2w : forall (s : t) {Hs : Ok s}, NoDup (elements s). - Proof. - unfold elements; auto. - Qed. - - Lemma fold_spec : - forall (s : t) (A : Type) (i : A) (f : elt -> A -> A), - fold f s i = fold_left (flip f) (elements s) i. - Proof. - reflexivity. - Qed. - - Global Instance union_ok : forall s s' `(Ok s, Ok s'), Ok (union s s'). - Proof. - induction s; simpl; auto; intros; inv; unfold flip; auto with *. - Qed. - - Lemma union_spec : - forall (s s' : t) (x : elt) {Hs : Ok s} {Hs' : Ok s'}, - In x (union s s') <-> In x s \/ In x s'. - Proof. - induction s; simpl in *; unfold flip; intros; auto; inv. - - intuition; inv. - - rewrite IHs, add_spec, InA_cons; intuition. - Qed. - - Global Instance inter_ok s s' `(Ok s, Ok s') : Ok (inter s s'). - Proof. - unfold inter, fold, flip. - set (acc := nil (A:=elt)). - assert (Hacc : Ok acc) by constructors. - clearbody acc; revert acc Hacc. - induction s; simpl; auto; intros. inv. - apply IHs; auto. - destruct (mem a s'); auto with *. - Qed. - - Lemma inter_spec : - forall (s s' : t) (x : elt) {Hs : Ok s} {Hs' : Ok s'}, - In x (inter s s') <-> In x s /\ In x s'. - Proof. - unfold inter, fold, flip; intros. - set (acc := nil (A:=elt)) in *. - assert (Hacc : Ok acc) by constructors. - assert (IFF : (In x s /\ In x s') <-> (In x s /\ In x s') \/ In x acc). { - intuition; unfold acc in *; inv. - } - rewrite IFF; clear IFF. clearbody acc. - revert acc Hacc x s' Hs Hs'. - induction s; simpl; intros. - - intuition; inv. - - inv. - case_eq (mem a s'); intros Hm. - + rewrite IHs, add_spec, InA_cons; intuition. - rewrite mem_spec in Hm; auto. - left; split; auto. rewrite H1; auto. - + rewrite IHs, InA_cons; intuition. - rewrite H2, <- mem_spec in H3; auto. congruence. - Qed. - - Global Instance diff_ok : forall s s' `(Ok s, Ok s'), Ok (diff s s'). - Proof. - unfold diff; intros s s'; revert s. - induction s'; simpl; unfold flip; auto; intros. inv; auto with *. - Qed. - - Lemma diff_spec : - forall (s s' : t) (x : elt) {Hs : Ok s} {Hs' : Ok s'}, - In x (diff s s') <-> In x s /\ ~In x s'. - Proof. - unfold diff; intros s s'; revert s. - induction s'; simpl; unfold flip. - - intuition; inv. - - intros. inv. - rewrite IHs', remove_spec, InA_cons; intuition. - Qed. - - Lemma subset_spec : - forall (s s' : t) {Hs : Ok s} {Hs' : Ok s'}, - subset s s' = true <-> Subset s s'. - Proof. - unfold subset, Subset; intros. - rewrite is_empty_spec. - unfold Empty; intros. - intuition. - - specialize (H a). rewrite diff_spec in H; intuition. - rewrite <- (mem_spec a) in H |- *. destruct (mem a s'); intuition auto with bool. - - rewrite diff_spec in H0; intuition. - Qed. - - Lemma equal_spec : - forall (s s' : t) {Hs : Ok s} {Hs' : Ok s'}, - equal s s' = true <-> Equal s s'. - Proof. - unfold Equal, equal; intros. - rewrite andb_true_iff, !subset_spec. - unfold Subset; intuition. - - rewrite <- H; auto. - - rewrite H; auto. - Qed. - - Lemma choose_spec1 : - forall (s : t) (x : elt), choose s = Some x -> In x s. - Proof. - destruct s; simpl; intros; inversion H; auto. - Qed. - - Lemma choose_spec2 : forall s : t, choose s = None -> Empty s. - Proof. - destruct s; simpl; intros. - - intros x H0; inversion H0. - - inversion H. - Qed. - - Lemma cardinal_spec : - forall (s : t) {Hs : Ok s}, cardinal s = length (elements s). - Proof. - auto. - Qed. - - Lemma filter_spec' : forall s x f, - In x (filter f s) -> In x s. - Proof. - induction s; simpl. - - intuition; inv. - - intros; destruct (f a); inv; intuition; right; eauto. - Qed. - - Lemma filter_spec : - forall (s : t) (x : elt) (f : elt -> bool), - Proper (X.eq==>eq) f -> - (In x (filter f s) <-> In x s /\ f x = true). - Proof. - induction s; simpl. - - intuition; inv. - - intros. - destruct (f a) eqn:E; rewrite ?InA_cons, IHs; intuition. - + setoid_replace x with a; auto. - + setoid_replace a with x in E; auto. congruence. - Qed. - - Global Instance filter_ok s f `(Ok s) : Ok (filter f s). - Proof. - induction s; simpl. - - auto. - - intros; inv. - case (f a); auto. - constructors; auto. - contradict H0. - eapply filter_spec'; eauto. - Qed. - - Lemma for_all_spec : - forall (s : t) (f : elt -> bool), - Proper (X.eq==>eq) f -> - (for_all f s = true <-> For_all (fun x => f x = true) s). - Proof. - unfold For_all; induction s; simpl. - - intuition. inv. - - intros; inv. - destruct (f a) eqn:F. - + rewrite IHs; intuition. inv; auto. - setoid_replace x with a; auto. - + split; intros H'; try discriminate. - intros. - rewrite <- F, <- (H' a); auto. - Qed. - - Lemma exists_spec : - forall (s : t) (f : elt -> bool), - Proper (X.eq==>eq) f -> - (exists_ f s = true <-> Exists (fun x => f x = true) s). - Proof. - unfold Exists; induction s; simpl. - - split; [discriminate| intros (x & Hx & _); inv]. - - intros. - destruct (f a) eqn:F. - + split; auto. - exists a; auto. - + rewrite IHs; firstorder. - inv. - * setoid_replace a with x in F; auto; congruence. - * exists x; auto. - Qed. - - Lemma partition_spec1 : - forall (s : t) (f : elt -> bool), - Proper (X.eq==>eq) f -> - Equal (fst (partition f s)) (filter f s). - Proof. - simple induction s; simpl; auto; unfold Equal. - - firstorder. - - intros x l Hrec f Hf. - generalize (Hrec f Hf); clear Hrec. - case (partition f l); intros s1 s2; simpl; intros. - case (f x); simpl; firstorder; inversion H0; intros; firstorder. - Qed. - - Lemma partition_spec2 : - forall (s : t) (f : elt -> bool), - Proper (X.eq==>eq) f -> - Equal (snd (partition f s)) (filter (fun x => negb (f x)) s). - Proof. - simple induction s; simpl; auto; unfold Equal. - - firstorder. - - intros x l Hrec f Hf. - generalize (Hrec f Hf); clear Hrec. - case (partition f l); intros s1 s2; simpl; intros. - case (f x); simpl; firstorder; inversion H0; intros; firstorder. - Qed. - - Lemma partition_ok1' : - forall (s : t) {Hs : Ok s} (f : elt -> bool)(x:elt), - In x (fst (partition f s)) -> In x s. - Proof. - induction s; simpl; auto; intros. inv. - generalize (IHs H1 f x). - destruct (f a); destruct (partition f s); simpl in *; auto. - inversion_clear H; auto. - Qed. - - Lemma partition_ok2' : - forall (s : t) {Hs : Ok s} (f : elt -> bool)(x:elt), - In x (snd (partition f s)) -> In x s. - Proof. - induction s; simpl; auto; intros. inv. - generalize (IHs H1 f x). - destruct (f a); destruct (partition f s); simpl in *; auto. - inversion_clear H; auto. - Qed. - - Global Instance partition_ok1 : forall s f `(Ok s), Ok (fst (partition f s)). - Proof. - simple induction s; simpl. - - auto. - - intros x l Hrec f Hs; inv. - generalize (@partition_ok1' _ _ f x). - generalize (Hrec f H0). - case (f x); case (partition f l); simpl; constructors; auto. - Qed. - - Global Instance partition_ok2 : forall s f `(Ok s), Ok (snd (partition f s)). - Proof. - simple induction s; simpl. - - auto. - - intros x l Hrec f Hs; inv. - generalize (@partition_ok2' _ _ f x). - generalize (Hrec f H0). - case (f x); case (partition f l); simpl; constructors; auto. - Qed. - - End ForNotations. - - Definition In := InA X.eq. - Definition eq := Equal. -#[global] - Instance eq_equiv : Equivalence eq := _. - -End MakeRaw. - -(** * Encapsulation - - Now, in order to really provide a functor implementing [S], we - need to encapsulate everything into a type of lists without redundancy. *) - -Module Make (X: DecidableType) <: WSets with Module E := X. - Module Raw := MakeRaw X. - Include WRaw2Sets X Raw. -End Make. diff --git a/stdlib/theories/MSets/MSets.v b/stdlib/theories/MSets/MSets.v deleted file mode 100644 index 506b01846bb5..000000000000 --- a/stdlib/theories/MSets/MSets.v +++ /dev/null @@ -1,23 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* Gt. -Definition ge x y := (x ?= y) <> Lt. - -Infix "<=" := le : N_scope. -Infix "<" := lt : N_scope. -Infix ">=" := ge : N_scope. -Infix ">" := gt : N_scope. - -Notation "x <= y <= z" := (x <= y /\ y <= z) : N_scope. -Notation "x <= y < z" := (x <= y /\ y < z) : N_scope. -Notation "x < y < z" := (x < y /\ y < z) : N_scope. -Notation "x < y <= z" := (x < y /\ y <= z) : N_scope. - -Definition divide p q := exists r, q = r*p. -Notation "( p | q )" := (divide p q) (at level 0) : N_scope. - -Definition Even n := exists m, n = 2*m. -Definition Odd n := exists m, n = 2*m+1. - -(** Proofs of morphisms, obvious since eq is Leibniz *) - -Local Obligation Tactic := simpl_relation. -Program Definition succ_wd : Proper (eq==>eq) succ := _. -Program Definition pred_wd : Proper (eq==>eq) pred := _. -Program Definition add_wd : Proper (eq==>eq==>eq) add := _. -Program Definition sub_wd : Proper (eq==>eq==>eq) sub := _. -Program Definition mul_wd : Proper (eq==>eq==>eq) mul := _. -Program Definition lt_wd : Proper (eq==>eq==>iff) lt := _. -Program Definition div_wd : Proper (eq==>eq==>eq) div := _. -Program Definition mod_wd : Proper (eq==>eq==>eq) modulo := _. -Program Definition pow_wd : Proper (eq==>eq==>eq) pow := _. -Program Definition testbit_wd : Proper (eq==>eq==>Logic.eq) testbit := _. - -(** Decidability of equality. *) - -Definition eq_dec : forall n m : N, { n = m } + { n <> m }. -Proof. - decide equality. - apply Pos.eq_dec. -Defined. - -(** Discrimination principle *) - -Definition discr n : { p:positive | n = pos p } + { n = 0 }. -Proof. - destruct n as [|p]; auto. - left; exists p; auto. -Defined. - -(** Convenient induction principles *) - -Definition binary_rect (P:N -> Type) (f0 : P 0) - (f2 : forall n, P n -> P (double n)) - (fS2 : forall n, P n -> P (succ_double n)) (n : N) : P n := - let P' p := P (pos p) in - let f2' p := f2 (pos p) in - let fS2' p := fS2 (pos p) in - match n with - | 0 => f0 - | pos p => positive_rect P' fS2' f2' (fS2 0 f0) p - end. - -Definition binary_rec (P:N -> Set) := binary_rect P. -Definition binary_ind (P:N -> Prop) := binary_rect P. - -(** Peano induction on binary natural numbers *) - -Definition peano_rect - (P : N -> Type) (f0 : P 0) - (f : forall n : N, P n -> P (succ n)) (n : N) : P n := -let P' p := P (pos p) in -let f' p := f (pos p) in -match n with -| 0 => f0 -| pos p => Pos.peano_rect P' (f 0 f0) f' p -end. - -Theorem peano_rect_base P a f : peano_rect P a f 0 = a. -Proof. -reflexivity. -Qed. - -Theorem peano_rect_succ P a f n : - peano_rect P a f (succ n) = f n (peano_rect P a f n). -Proof. -destruct n; simpl. -- trivial. -- now rewrite Pos.peano_rect_succ. -Qed. - -Definition peano_ind (P : N -> Prop) := peano_rect P. - -Definition peano_rec (P : N -> Set) := peano_rect P. - -Theorem peano_rec_base P a f : peano_rec P a f 0 = a. -Proof. -apply peano_rect_base. -Qed. - -Theorem peano_rec_succ P a f n : - peano_rec P a f (succ n) = f n (peano_rec P a f n). -Proof. -apply peano_rect_succ. -Qed. - -(** Generic induction / recursion *) - -Theorem bi_induction : - forall A : N -> Prop, Proper (Logic.eq==>iff) A -> - A 0 -> (forall n, A n <-> A (succ n)) -> forall n : N, A n. -Proof. - intros A A_wd A0 AS. apply peano_rect. - - assumption. - - intros; now apply -> AS. -Qed. - -Definition recursion {A} : A -> (N -> A -> A) -> N -> A := - peano_rect (fun _ => A). - -#[global] -Instance recursion_wd {A} (Aeq : relation A) : - Proper (Aeq==>(Logic.eq==>Aeq==>Aeq)==>Logic.eq==>Aeq) recursion. -Proof. -intros a a' Ea f f' Ef x x' Ex. subst x'. -induction x using peano_ind. -- trivial. -- unfold recursion in *. rewrite 2 peano_rect_succ. now apply Ef. -Qed. - -Theorem recursion_0 {A} (a:A) (f:N->A->A) : recursion a f 0 = a. -Proof. reflexivity. Qed. - -Theorem recursion_succ {A} (Aeq : relation A) (a : A) (f : N -> A -> A): - Aeq a a -> Proper (Logic.eq==>Aeq==>Aeq) f -> - forall n : N, Aeq (recursion a f (succ n)) (f n (recursion a f n)). -Proof. -unfold recursion; intros a_wd f_wd n. induction n using peano_ind. -- rewrite peano_rect_succ. now apply f_wd. -- rewrite !peano_rect_succ in *. now apply f_wd. -Qed. - -(** Specification of constants *) - -Lemma one_succ : 1 = succ 0. -Proof. reflexivity. Qed. - -Lemma two_succ : 2 = succ 1. -Proof. reflexivity. Qed. - -Lemma pred_0 : pred 0 = 0. -Proof. reflexivity. Qed. - -(** Properties of mixed successor and predecessor. *) - -Lemma pos_pred_spec p : Pos.pred_N p = pred (pos p). -Proof. - now destruct p. -Qed. - -Lemma succ_pos_spec n : pos (succ_pos n) = succ n. -Proof. - now destruct n. -Qed. - -Lemma pos_pred_succ n : Pos.pred_N (succ_pos n) = n. -Proof. - destruct n. - - trivial. - - apply Pos.pred_N_succ. -Qed. - -Lemma succ_pos_pred p : succ (Pos.pred_N p) = pos p. -Proof. - destruct p; simpl; trivial. f_equal. apply Pos.succ_pred_double. -Qed. - -(** Properties of successor and predecessor *) - -Theorem pred_succ n : pred (succ n) = n. -Proof. -destruct n; trivial. simpl. apply Pos.pred_N_succ. -Qed. - -Theorem pred_sub n : pred n = sub n 1. -Proof. - now destruct n as [|[p|p|]]. -Qed. - -Theorem succ_0_discr n : succ n <> 0. -Proof. -now destruct n. -Qed. - -(** Specification of addition *) - -Theorem add_0_l n : 0 + n = n. -Proof. -reflexivity. -Qed. - -Theorem add_succ_l n m : succ n + m = succ (n + m). -Proof. -destruct n, m; unfold succ, add; now rewrite ?Pos.add_1_l, ?Pos.add_succ_l. -Qed. - -(** Specification of subtraction. *) - -Theorem sub_0_r n : n - 0 = n. -Proof. -now destruct n. -Qed. - -Theorem sub_succ_r n m : n - succ m = pred (n - m). -Proof. -destruct n as [|p], m as [|q]; trivial. -- now destruct p. -- simpl. rewrite Pos.sub_mask_succ_r, Pos.sub_mask_carry_spec. - now destruct (Pos.sub_mask p q) as [|[r|r|]|]. -Qed. - -(** Specification of multiplication *) - -Theorem mul_0_l n : 0 * n = 0. -Proof. -reflexivity. -Qed. - -Theorem mul_succ_l n m : (succ n) * m = n * m + m. -Proof. -destruct n, m; simpl; trivial. f_equal. rewrite Pos.add_comm. -apply Pos.mul_succ_l. -Qed. - -(** Specification of boolean comparisons. *) - -Lemma eqb_eq n m : eqb n m = true <-> n=m. -Proof. -destruct n as [|n], m as [|m]; simpl; try easy'. -rewrite Pos.eqb_eq. split; intro H. -- now subst. -- now destr_eq H. -Qed. - -Lemma ltb_lt n m : (n n < m. -Proof. - unfold ltb, lt. destruct compare; easy'. -Qed. - -Lemma leb_le n m : (n <=? m) = true <-> n <= m. -Proof. - unfold leb, le. destruct compare; easy'. -Qed. - -(** Basic properties of comparison *) - -Theorem compare_eq_iff n m : (n ?= m) = Eq <-> n = m. -Proof. -destruct n, m; simpl; rewrite ?Pos.compare_eq_iff; split; congruence. -Qed. - -Theorem compare_lt_iff n m : (n ?= m) = Lt <-> n < m. -Proof. -reflexivity. -Qed. - -Theorem compare_le_iff n m : (n ?= m) <> Gt <-> n <= m. -Proof. -reflexivity. -Qed. - -Theorem compare_antisym n m : (m ?= n) = CompOpp (n ?= m). -Proof. -destruct n, m; simpl; trivial. apply Pos.compare_antisym. -Qed. - -(** Some more advanced properties of comparison and orders, - including [compare_spec] and [lt_irrefl] and [lt_eq_cases]. *) - -Include BoolOrderFacts. - -(** Specification of minimum and maximum *) - -Theorem min_l n m : n <= m -> min n m = n. -Proof. -unfold min, le. case compare; trivial. now destruct 1. -Qed. - -Theorem min_r n m : m <= n -> min n m = m. -Proof. -unfold min, le. rewrite compare_antisym. -case compare_spec; trivial. now destruct 2. -Qed. - -Theorem max_l n m : m <= n -> max n m = n. -Proof. -unfold max, le. rewrite compare_antisym. -case compare_spec; auto. now destruct 2. -Qed. - -Theorem max_r n m : n <= m -> max n m = m. -Proof. -unfold max, le. case compare; trivial. now destruct 1. -Qed. - -(** Specification of lt and le. *) - -Lemma lt_succ_r n m : n < succ m <-> n<=m. -Proof. -destruct n as [|p], m as [|q]; simpl; try easy'. -- split. - + now destruct p. - + now destruct 1. -- apply Pos.lt_succ_r. -Qed. - -(** We can now derive all properties of basic functions and orders, - and use these properties for proving the specs of more advanced - functions. *) - -Include NBasicProp <+ UsualMinMaxLogicalProperties <+ UsualMinMaxDecProperties. - -Lemma strong_induction_le (A : N -> Prop) : - A 0 -> (forall n, (forall m, m <= n -> A m) -> A (succ n)) -> forall n, A n. -Proof. apply Private_strong_induction_le; intros x y ->; reflexivity. Qed. - -(** Properties of [double] and [succ_double] *) - -Lemma double_spec n : double n = 2 * n. -Proof. - reflexivity. -Qed. - -Lemma succ_double_spec n : succ_double n = 2 * n + 1. -Proof. - now destruct n. -Qed. - -Lemma double_add n m : double (n+m) = double n + double m. -Proof. - now destruct n, m. -Qed. - -Lemma succ_double_add n m : succ_double (n+m) = double n + succ_double m. -Proof. - now destruct n, m. -Qed. - -Lemma double_mul n m : double (n*m) = double n * m. -Proof. - now destruct n, m. -Qed. - -Lemma succ_double_mul n m : - succ_double n * m = double n * m + m. -Proof. - destruct n; simpl; destruct m; trivial. - now rewrite Pos.add_comm. -Qed. - -Lemma div2_double n : div2 (double n) = n. -Proof. -now destruct n. -Qed. - -Lemma div2_succ_double n : div2 (succ_double n) = n. -Proof. -now destruct n. -Qed. - -Lemma double_inj n m : double n = double m -> n = m. -Proof. -intro H. rewrite <- (div2_double n), H. apply div2_double. -Qed. - -Lemma succ_double_inj n m : succ_double n = succ_double m -> n = m. -Proof. -intro H. rewrite <- (div2_succ_double n), H. apply div2_succ_double. -Qed. - -Lemma succ_double_lt n m : n succ_double n < double m. -Proof. - destruct n as [|n], m as [|m]; intros H; try easy. - unfold lt in *; simpl in *. now rewrite Pos.compare_xI_xO, H. -Qed. - -Lemma double_lt_mono n m : n < m -> double n < double m. -Proof. - destruct n as [|n], m as [|m]; intros H; try easy. -Qed. - -Lemma double_le_mono n m : n <= m -> double n <= double m. -Proof. - destruct n as [|n], m as [|m]; intros H; try easy. -Qed. - -Lemma succ_double_lt_mono n m : n < m -> succ_double n < succ_double m. -Proof. - destruct n as [|n], m as [|m]; intros H; try easy. -Qed. - -Lemma succ_double_le_mono n m : n <= m -> succ_double n <= succ_double m. -Proof. - destruct n as [|n], m as [|m]; intros H; try easy. -Qed. - -(** 0 is the least natural number *) - -Theorem compare_0_r n : (n ?= 0) <> Lt. -Proof. -now destruct n. -Qed. - -(** Specifications of power *) - -Lemma pow_0_r n : n ^ 0 = 1. -Proof. reflexivity. Qed. - -Lemma pow_succ_r n p : 0<=p -> n^(succ p) = n * n^p. -Proof. - intros _. - destruct n, p; simpl; trivial; f_equal. apply Pos.pow_succ_r. -Qed. - -Lemma pow_neg_r n p : p<0 -> n^p = 0. -Proof. - now destruct p. -Qed. - -(** Specification of square *) - -Lemma square_spec n : square n = n * n. -Proof. - destruct n; trivial. simpl. f_equal. apply Pos.square_spec. -Qed. - -(** Specification of Base-2 logarithm *) - -Lemma size_log2 n : n<>0 -> size n = succ (log2 n). -Proof. - destruct n as [|[n|n| ]]; trivial. now destruct 1. -Qed. - -Lemma size_gt n : n < 2^(size n). -Proof. - destruct n. - - reflexivity. - - simpl. apply Pos.size_gt. -Qed. - -Lemma size_le n : 2^(size n) <= succ_double n. -Proof. - destruct n as [|p]. - - discriminate. - - simpl. - change (2^Pos.size p <= Pos.succ (p~0))%positive. - apply Pos.lt_le_incl, Pos.lt_succ_r, Pos.size_le. -Qed. - -Lemma log2_spec n : 0 < n -> - 2^(log2 n) <= n < 2^(succ (log2 n)). -Proof. - destruct n as [|[p|p|]]; discriminate || intros _; simpl; split. - - apply (size_le (pos p)). - - apply Pos.size_gt. - - apply Pos.size_le. - - apply Pos.size_gt. - - discriminate. - - reflexivity. -Qed. - -Lemma log2_nonpos n : n<=0 -> log2 n = 0. -Proof. - destruct n; intros Hn. - - reflexivity. - - now destruct Hn. -Qed. - -(** Specification of parity functions *) - -Lemma even_spec n : even n = true <-> Even n. -Proof. - destruct n as [|p]. - - split. - + now exists 0. - + trivial. - - destruct p as [p|p|]; simpl; split; try easy. - + intros (m,H). now destruct m. - + now exists (pos p). - + intros (m,H). now destruct m. -Qed. - -Lemma odd_spec n : odd n = true <-> Odd n. -Proof. - destruct n as [|p]. - - split. - + discriminate. - + intros (m,H). now destruct m. - - destruct p as [p|p|]; simpl; split; try easy. - + now exists (pos p). - + intros (m,H). now destruct m. - + now exists 0. -Qed. - -(** Specification of the euclidean division *) - -Theorem pos_div_eucl_spec (a:positive)(b:N) : - let (q,r) := pos_div_eucl a b in pos a = q * b + r. -Proof. - induction a as [a IHa|a IHa|]; - cbv beta iota delta [pos_div_eucl]; fold pos_div_eucl; cbv zeta. - - (* a~1 *) - destruct pos_div_eucl as (q,r). - change (pos a~1) with (succ_double (pos a)). - rewrite IHa, succ_double_add, double_mul. - case leb_spec; intros H; trivial. - rewrite succ_double_mul, <- add_assoc. f_equal. - now rewrite (add_comm b), sub_add. - - (* a~0 *) - destruct pos_div_eucl as (q,r). - change (pos a~0) with (double (pos a)). - rewrite IHa, double_add, double_mul. - case leb_spec; intros H; trivial. - rewrite succ_double_mul, <- add_assoc. f_equal. - now rewrite (add_comm b), sub_add. - - (* 1 *) - now destruct b as [|[ | | ]]. -Qed. - -Theorem div_eucl_spec a b : - let (q,r) := div_eucl a b in a = b * q + r. -Proof. - destruct a as [|a], b as [|b]; unfold div_eucl; trivial. - generalize (pos_div_eucl_spec a (pos b)). - destruct pos_div_eucl. now rewrite mul_comm. -Qed. - -Theorem div_mod' a b : a = b * (a/b) + (a mod b). -Proof. - generalize (div_eucl_spec a b). - unfold div, modulo. now destruct div_eucl. -Qed. - -Theorem div_mod a b : b<>0 -> a = b * (a/b) + (a mod b). -Proof. - intros _. apply div_mod'. -Qed. - -Theorem pos_div_eucl_remainder (a:positive) (b:N) : - b<>0 -> snd (pos_div_eucl a b) < b. -Proof. - intros Hb. - induction a as [a IHa|a IHa|]; - cbv beta iota delta [pos_div_eucl]; fold pos_div_eucl; cbv zeta. - - (* a~1 *) - destruct pos_div_eucl as (q,r); simpl in *. - case leb_spec; intros H; simpl; trivial. - apply add_lt_mono_l with b. rewrite add_comm, sub_add by trivial. - destruct b as [|b]; [now destruct Hb| simpl; rewrite Pos.add_diag ]. - apply (succ_double_lt _ _ IHa). - - (* a~0 *) - destruct pos_div_eucl as (q,r); simpl in *. - case leb_spec; intros H; simpl; trivial. - apply add_lt_mono_l with b. rewrite add_comm, sub_add by trivial. - destruct b as [|b]; [now destruct Hb| simpl; rewrite Pos.add_diag ]. - now destruct r. - - (* 1 *) - destruct b as [|[ | | ]]; easy || (now destruct Hb). -Qed. - -Theorem mod_lt a b : b<>0 -> a mod b < b. -Proof. - destruct b as [ |b]. { now destruct 1. } - destruct a as [ |a]. { reflexivity. } - unfold modulo. simpl. apply pos_div_eucl_remainder. -Qed. - -Theorem mod_bound_pos a b : 0<=a -> 0 0 <= a mod b < b. -Proof. - intros _ H. split. - - apply le_0_l. - - apply mod_lt. now destruct b. -Qed. - -(** Specification of square root *) - -Lemma sqrtrem_sqrt n : fst (sqrtrem n) = sqrt n. -Proof. - destruct n as [|p]. - - reflexivity. - - unfold sqrtrem, sqrt, Pos.sqrt. - destruct (Pos.sqrtrem p) as (s,r). now destruct r. -Qed. - -Lemma sqrtrem_spec n : - let (s,r) := sqrtrem n in n = s*s + r /\ r <= 2*s. -Proof. - destruct n as [|p]. - - now split. - - generalize (Pos.sqrtrem_spec p). simpl. - destruct 1; simpl; subst; now split. -Qed. - -Lemma sqrt_spec n : 0<=n -> - let s := sqrt n in s*s <= n < (succ s)*(succ s). -Proof. - intros _. destruct n as [|p]. - - now split. - - apply (Pos.sqrt_spec p). -Qed. - -Lemma sqrt_neg n : n<0 -> sqrt n = 0. -Proof. - now destruct n. -Qed. - -(** Specification of gcd *) - -(** The first component of ggcd is gcd *) - -Lemma ggcd_gcd a b : fst (ggcd a b) = gcd a b. -Proof. - destruct a as [|p], b as [|q]; simpl; auto. - assert (H := Pos.ggcd_gcd p q). - destruct Pos.ggcd as (g,(aa,bb)); simpl; now f_equal. -Qed. - -(** The other components of ggcd are indeed the correct factors. *) - -Lemma ggcd_correct_divisors a b : - let '(g,(aa,bb)) := ggcd a b in - a=g*aa /\ b=g*bb. -Proof. - destruct a as [|p], b as [|q]; simpl; auto. - - now rewrite Pos.mul_1_r. - - now rewrite Pos.mul_1_r. - - generalize (Pos.ggcd_correct_divisors p q). - destruct Pos.ggcd as (g,(aa,bb)); simpl. - destruct 1; split; now f_equal. -Qed. - -(** We can use this fact to prove a part of the gcd correctness *) - -Lemma gcd_divide_l a b : (gcd a b | a). -Proof. - rewrite <- ggcd_gcd. generalize (ggcd_correct_divisors a b). - destruct ggcd as (g,(aa,bb)); simpl. intros (H,_). exists aa. - now rewrite mul_comm. -Qed. - -Lemma gcd_divide_r a b : (gcd a b | b). -Proof. - rewrite <- ggcd_gcd. generalize (ggcd_correct_divisors a b). - destruct ggcd as (g,(aa,bb)); simpl. intros (_,H). exists bb. - now rewrite mul_comm. -Qed. - -(** We now prove directly that gcd is the greatest amongst common divisors *) - -Lemma gcd_greatest a b c : (c|a) -> (c|b) -> (c|gcd a b). -Proof. - destruct a as [ |p], b as [ |q]; simpl; trivial. - destruct c as [ |r]. - - intros (s,H). destruct s; discriminate. - - intros ([ |s],Hs) ([ |t],Ht); try discriminate; simpl in *. - destruct (Pos.gcd_greatest p q r) as (u,H). - + exists s. now inversion Hs. - + exists t. now inversion Ht. - + exists (pos u). simpl; now f_equal. -Qed. - -Lemma gcd_nonneg a b : 0 <= gcd a b. -Proof. apply le_0_l. Qed. - -(** Specification of bitwise functions *) - -(** Correctness proofs for [testbit]. *) - -Lemma testbit_even_0 a : testbit (2*a) 0 = false. -Proof. - now destruct a. -Qed. - -Lemma testbit_odd_0 a : testbit (2*a+1) 0 = true. -Proof. - now destruct a. -Qed. - -Lemma testbit_succ_r_div2 a n : 0<=n -> - testbit a (succ n) = testbit (div2 a) n. -Proof. - intros _. destruct a as [|[a|a| ]], n as [|n]; simpl; trivial; - f_equal; apply Pos.pred_N_succ. -Qed. - -Lemma testbit_odd_succ a n : 0<=n -> - testbit (2*a+1) (succ n) = testbit a n. -Proof. - intros H. rewrite testbit_succ_r_div2 by trivial. f_equal. now destruct a. -Qed. - -Lemma testbit_even_succ a n : 0<=n -> - testbit (2*a) (succ n) = testbit a n. -Proof. - intros H. rewrite testbit_succ_r_div2 by trivial. f_equal. now destruct a. -Qed. - -Lemma testbit_neg_r a n : n<0 -> testbit a n = false. -Proof. - now destruct n. -Qed. - -(** Correctness proofs for shifts *) - -Lemma shiftr_succ_r a n : - shiftr a (succ n) = div2 (shiftr a n). -Proof. - destruct n; simpl; trivial. apply Pos.iter_succ. -Qed. - -Lemma shiftl_succ_r a n : - shiftl a (succ n) = double (shiftl a n). -Proof. - destruct n, a; simpl; trivial. f_equal. apply Pos.iter_succ. -Qed. - -Lemma shiftr_spec a n m : 0<=m -> - testbit (shiftr a n) m = testbit a (m+n). -Proof. - intros _. revert a m. - induction n as [|n IHn] using peano_ind; intros a m. - - now rewrite add_0_r. - - rewrite add_comm, add_succ_l, add_comm, <- add_succ_l. - now rewrite <- IHn, testbit_succ_r_div2, shiftr_succ_r by apply le_0_l. -Qed. - -Lemma shiftl_spec_high a n m : 0<=m -> n<=m -> - testbit (shiftl a n) m = testbit a (m-n). -Proof. - intros _ H. - rewrite <- (sub_add n m H) at 1. - set (m' := m-n). clearbody m'. clear H m. revert a m'. - induction n using peano_ind; intros a m. - - rewrite add_0_r; now destruct a. - - rewrite shiftl_succ_r. - rewrite add_comm, add_succ_l, add_comm. - now rewrite testbit_succ_r_div2, div2_double by apply le_0_l. -Qed. - -Lemma shiftl_spec_low a n m : m - testbit (shiftl a n) m = false. -Proof. - revert a m. - induction n as [|n IHn] using peano_ind; intros a m H. - - elim (le_0_l m). now rewrite compare_antisym, H. - - rewrite shiftl_succ_r. - destruct m as [|p]. - + now destruct (shiftl a n). - + rewrite <- (succ_pos_pred p), testbit_succ_r_div2, div2_double by apply le_0_l. - apply IHn. - apply add_lt_mono_l with 1. rewrite 2 (add_succ_l 0). simpl. - now rewrite succ_pos_pred. -Qed. - -Lemma div2_spec a : div2 a = shiftr a 1. -Proof. - reflexivity. -Qed. - -(** Semantics of bitwise operations *) - -Lemma pos_lxor_spec p p' n : - testbit (Pos.lxor p p') n = xorb (Pos.testbit p n) (Pos.testbit p' n). -Proof. - revert p' n. - induction p as [p IH|p IH|]; intros [p'|p'|] [|n]; trivial; simpl; - (specialize (IH p'); destruct Pos.lxor; trivial; now rewrite <-IH) || - (now destruct Pos.testbit). -Qed. - -Lemma lxor_spec a a' n : - testbit (lxor a a') n = xorb (testbit a n) (testbit a' n). -Proof. - destruct a, a'; simpl; trivial. - - now destruct Pos.testbit. - - apply pos_lxor_spec. -Qed. - -Lemma pos_lor_spec p p' n : - Pos.testbit (Pos.lor p p') n = (Pos.testbit p n) || (Pos.testbit p' n). -Proof. - revert p' n. - induction p as [p IH|p IH|]; intros [p'|p'|] [|n]; trivial; simpl; - apply IH || now rewrite orb_false_r. -Qed. - -Lemma lor_spec a a' n : - testbit (lor a a') n = (testbit a n) || (testbit a' n). -Proof. - destruct a, a'; simpl; trivial. - - now rewrite orb_false_r. - - apply pos_lor_spec. -Qed. - -Lemma pos_land_spec p p' n : - testbit (Pos.land p p') n = (Pos.testbit p n) && (Pos.testbit p' n). -Proof. - revert p' n. - induction p as [p IH|p IH|]; intros [p'|p'|] [|n]; trivial; simpl; - (specialize (IH p'); destruct Pos.land; trivial; now rewrite <-IH) || - (now rewrite andb_false_r). -Qed. - -Lemma land_spec a a' n : - testbit (land a a') n = (testbit a n) && (testbit a' n). -Proof. - destruct a, a'; simpl; trivial. - - now rewrite andb_false_r. - - apply pos_land_spec. -Qed. - -Lemma pos_ldiff_spec p p' n : - testbit (Pos.ldiff p p') n = (Pos.testbit p n) && negb (Pos.testbit p' n). -Proof. - revert p' n. - induction p as [p IH|p IH|]; intros [p'|p'|] [|n]; trivial; simpl; - (specialize (IH p'); destruct Pos.ldiff; trivial; now rewrite <-IH) || - (now rewrite andb_true_r). -Qed. - -Lemma ldiff_spec a a' n : - testbit (ldiff a a') n = (testbit a n) && negb (testbit a' n). -Proof. - destruct a, a'; simpl; trivial. - - now rewrite andb_true_r. - - apply pos_ldiff_spec. -Qed. - -Lemma div_0_r a : a / 0 = 0. -Proof. now destruct a. Qed. - -Lemma mod_0_r a : a mod 0 = a. -Proof. now destruct a. Qed. - -(** Instantiation of generic properties of advanced functions - (pow, sqrt, log2, div, gcd, ...) *) - -Include NExtraPreProp <+ NExtraProp0. - -Lemma binary_induction (A : N -> Prop) : - A 0 -> (forall n, A n -> A (2 * n)) -> (forall n, A n -> A (2 * n + 1)) - -> forall n, A n. -Proof. apply Private_binary_induction; intros x y ->; reflexivity. Qed. - -(** In generic statements, the predicates [lt] and [le] have been - favored, whereas [gt] and [ge] don't even exist in the abstract - layers. The use of [gt] and [ge] is hence not recommended. We provide - here the bare minimal results to related them with [lt] and [le]. *) - -Lemma gt_lt_iff n m : n > m <-> m < n. -Proof. - unfold lt, gt. now rewrite compare_antisym, CompOpp_iff. -Qed. - -Lemma gt_lt n m : n > m -> m < n. -Proof. - apply gt_lt_iff. -Qed. - -Lemma lt_gt n m : n < m -> m > n. -Proof. - apply gt_lt_iff. -Qed. - -Lemma ge_le_iff n m : n >= m <-> m <= n. -Proof. - unfold le, ge. now rewrite compare_antisym, CompOpp_iff. -Qed. - -Lemma ge_le n m : n >= m -> m <= n. -Proof. - apply ge_le_iff. -Qed. - -Lemma le_ge n m : n <= m -> m >= n. -Proof. - apply ge_le_iff. -Qed. - -(** Auxiliary results about right shift on positive numbers, - used in BinInt *) - -Lemma pos_pred_shiftl_low : forall p n m, m - testbit (Pos.pred_N (Pos.shiftl p n)) m = true. -Proof. - intros p n; induction n as [|n IHn] using peano_ind. - - now intro m; destruct m. - - intros m H. unfold Pos.shiftl. - destruct n as [|n]; simpl in *. - + destruct m. - * now destruct p. - * elim (Pos.nlt_1_r _ H). - + rewrite Pos.iter_succ. simpl. - set (u:=Pos.iter xO p n) in *; clearbody u. - destruct m as [|m]. - * now destruct u. - * rewrite <- (IHn (Pos.pred_N m)). - -- rewrite <- (testbit_odd_succ _ (Pos.pred_N m)). - ++ rewrite succ_pos_pred. now destruct u. - ++ apply le_0_l. - -- apply succ_lt_mono. now rewrite succ_pos_pred. -Qed. - -Lemma pos_pred_shiftl_high : forall p n m, n<=m -> - testbit (Pos.pred_N (Pos.shiftl p n)) m = - testbit (shiftl (Pos.pred_N p) n) m. -Proof. - intros p n; induction n as [|n IHn] using peano_ind; intros m H. - - unfold shiftl. simpl. now destruct (Pos.pred_N p). - - rewrite shiftl_succ_r. - destruct n as [|n]. - + destruct m as [|m]. - * now destruct H. - * now destruct p. - + destruct m as [|m]. - * now destruct H. - * rewrite <- (succ_pos_pred m). - rewrite double_spec, testbit_even_succ by apply le_0_l. - rewrite <- IHn. - -- rewrite testbit_succ_r_div2 by apply le_0_l. - f_equal. simpl. rewrite Pos.iter_succ. - now destruct (Pos.iter xO p n). - -- apply succ_le_mono. now rewrite succ_pos_pred. -Qed. - -Lemma pred_div2_up p : Pos.pred_N (Pos.div2_up p) = div2 (Pos.pred_N p). -Proof. - destruct p as [p|p| ]; trivial. - - simpl. apply Pos.pred_N_succ. - - destruct p; simpl; trivial. -Qed. - -(** ** Properties of [iter] *) - -Lemma iter_swap_gen A B (f:A -> B) (g:A -> A) (h:B -> B) : - (forall a, f (g a) = h (f a)) -> forall n a, - f (iter n g a) = iter n h (f a). -Proof. - intros H n; destruct n; simpl; intros; rewrite ?H; trivial. - now apply Pos.iter_swap_gen. -Qed. - -Theorem iter_swap : - forall n (A:Type) (f:A -> A) (x:A), - iter n f (f x) = f (iter n f x). -Proof. - intros. symmetry. now apply iter_swap_gen. -Qed. - -Theorem iter_succ : - forall n (A:Type) (f:A -> A) (x:A), - iter (succ n) f x = f (iter n f x). -Proof. - intro n; destruct n; intros; simpl; trivial. - now apply Pos.iter_succ. -Qed. - -Theorem iter_succ_r : - forall n (A:Type) (f:A -> A) (x:A), - iter (succ n) f x = iter n f (f x). -Proof. - intros; now rewrite iter_succ, iter_swap. -Qed. - -Theorem iter_add : - forall p q (A:Type) (f:A -> A) (x:A), - iter (p+q) f x = iter p f (iter q f x). -Proof. - intro p; induction p as [|p IHp] using peano_ind; intros; trivial. - now rewrite add_succ_l, !iter_succ, IHp. -Qed. - -Theorem iter_ind (A:Type) (f:A -> A) (a:A) (P:N -> A -> Prop) : - P 0 a -> - (forall n a', P n a' -> P (succ n) (f a')) -> - forall n, P n (iter n f a). -Proof. - intros ? ? n; induction n using peano_ind; trivial. - rewrite iter_succ; auto. -Qed. - -Theorem iter_invariant : - forall (n:N) (A:Type) (f:A -> A) (Inv:A -> Prop), - (forall x:A, Inv x -> Inv (f x)) -> - forall x:A, Inv x -> Inv (iter n f x). -Proof. - intros; apply iter_ind; trivial. -Qed. - -End N. - -Bind Scope N_scope with N.t N. - -(** Exportation of notations *) - -Number Notation N N.of_num_uint N.to_num_uint : N_scope. - -Infix "+" := N.add : N_scope. -Infix "-" := N.sub : N_scope. -Infix "*" := N.mul : N_scope. -Infix "^" := N.pow : N_scope. - -Infix "?=" := N.compare (at level 70, no associativity) : N_scope. - -Infix "<=" := N.le : N_scope. -Infix "<" := N.lt : N_scope. -Infix ">=" := N.ge : N_scope. -Infix ">" := N.gt : N_scope. - -Notation "x <= y <= z" := (x <= y /\ y <= z) : N_scope. -Notation "x <= y < z" := (x <= y /\ y < z) : N_scope. -Notation "x < y < z" := (x < y /\ y < z) : N_scope. -Notation "x < y <= z" := (x < y /\ y <= z) : N_scope. - -Infix "=?" := N.eqb (at level 70, no associativity) : N_scope. -Infix "<=?" := N.leb (at level 70, no associativity) : N_scope. -Infix " m = p. -Proof (proj1 (N.add_cancel_l m p n)). -Lemma Nmult_Sn_m n m : N.succ n * m = m + n * m. -Proof (eq_trans (N.mul_succ_l n m) (N.add_comm _ _)). -Lemma Nmult_plus_distr_l n m p : p * (n + m) = p * n + p * m. -Proof (N.mul_add_distr_l p n m). -Lemma Nmult_reg_r n m p : p <> 0 -> n * p = m * p -> n = m. -Proof (fun H => proj1 (N.mul_cancel_r n m p H)). -Lemma Ncompare_antisym n m : CompOpp (n ?= m) = (m ?= n). -Proof (eq_sym (N.compare_antisym n m)). - -Definition N_ind_double a P f0 f2 fS2 := N.binary_ind P f0 f2 fS2 a. -Definition N_rec_double a P f0 f2 fS2 := N.binary_rec P f0 f2 fS2 a. - -(** Not kept : Ncompare_n_Sm Nplus_lt_cancel_l *) - -(** Re-export the notation for those who just [Import BinNat] *) -Number Notation N N.of_num_uint N.to_num_hex_uint : hex_N_scope. -Number Notation N N.of_num_uint N.to_num_uint : N_scope. diff --git a/stdlib/theories/NArith/BinNatDef.v b/stdlib/theories/NArith/BinNatDef.v deleted file mode 100644 index d36f04510972..000000000000 --- a/stdlib/theories/NArith/BinNatDef.v +++ /dev/null @@ -1,347 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* 1 - | pos p => pos (Pos.succ p) - end. - -(** ** Predecessor *) - -Definition pred n := - match n with - | 0 => 0 - | pos p => Pos.pred_N p - end. - -(** ** Addition *) - -Definition add n m := - match n, m with - | 0, _ => m - | _, 0 => n - | pos p, pos q => pos (p + q) - end. - -Infix "+" := add : N_scope. - -Infix "-" := sub : N_scope. - -(** Multiplication *) - -Definition mul n m := - match n, m with - | 0, _ => 0 - | _, 0 => 0 - | pos p, pos q => pos (p * q) - end. - -Infix "*" := mul : N_scope. - -Infix "?=" := compare (at level 70, no associativity) : N_scope. - -(** Boolean equality and comparison *) - -Definition eqb n m := - match n, m with - | 0, 0 => true - | pos p, pos q => Pos.eqb p q - | _, _ => false - end. - -Definition ltb x y := - match x ?= y with Lt => true | _ => false end. - -Infix "=?" := eqb (at level 70, no associativity) : N_scope. -Infix "<=?" := leb (at level 70, no associativity) : N_scope. -Infix " n - | Gt => n' - end. - -Definition max n n' := match n ?= n' with - | Lt | Eq => n' - | Gt => n - end. - -(** Dividing by 2 *) - -Definition div2 n := - match n with - | 0 => 0 - | 1 => 0 - | pos (p~0) => pos p - | pos (p~1) => pos p - end. - -(** Parity *) - -Definition even n := - match n with - | 0 => true - | pos (xO _) => true - | _ => false - end. - -Definition odd n := negb (even n). - -(** Power *) - -Definition pow n p := - match p, n with - | 0, _ => 1 - | _, 0 => 0 - | pos p, pos q => pos (q^p) - end. - -Infix "^" := pow : N_scope. - -(** Square *) - -Definition square n := - match n with - | 0 => 0 - | pos p => pos (Pos.square p) - end. - -(** Base-2 logarithm *) - -Definition log2 n := - match n with - | 0 => 0 - | 1 => 0 - | pos (p~0) => pos (Pos.size p) - | pos (p~1) => pos (Pos.size p) - end. - -(** How many digits in a number ? - Number 0 is said to have no digits at all. -*) - -Definition size n := - match n with - | 0 => 0 - | pos p => pos (Pos.size p) - end. - -Definition size_nat n := - match n with - | 0 => O - | pos p => Pos.size_nat p - end. - -(** Euclidean division *) - -Definition div_eucl (a b:N) : N * N := - match a, b with - | 0, _ => (0, 0) - | _, 0 => (0, a) - | pos na, _ => pos_div_eucl na b - end. - -Definition div a b := fst (div_eucl a b). -Definition modulo a b := snd (div_eucl a b). - -Infix "/" := div : N_scope. -Infix "mod" := modulo (at level 40, no associativity) : N_scope. - -(** Greatest common divisor *) - -Definition gcd a b := - match a, b with - | 0, _ => b - | _, 0 => a - | pos p, pos q => pos (Pos.gcd p q) - end. - -(** Generalized Gcd, also computing rests of [a] and [b] after - division by gcd. *) - -Definition ggcd a b := - match a, b with - | 0, _ => (b,(0,1)) - | _, 0 => (a,(1,0)) - | pos p, pos q => - let '(g,(aa,bb)) := Pos.ggcd p q in - (pos g, (pos aa, pos bb)) - end. - -(** Square root *) - -Definition sqrtrem n := - match n with - | 0 => (0, 0) - | pos p => - match Pos.sqrtrem p with - | (s, IsPos r) => (pos s, pos r) - | (s, _) => (pos s, 0) - end - end. - -Definition sqrt n := - match n with - | 0 => 0 - | pos p => pos (Pos.sqrt p) - end. - -(** Shifts *) - -Definition shiftl_nat (a:N) := nat_rect _ a (fun _ => double). -Definition shiftr_nat (a:N) := nat_rect _ a (fun _ => div2). - -Definition shiftl a n := - match a with - | 0 => 0 - | pos a => pos (Pos.shiftl a n) - end. - -Definition shiftr a n := - match n with - | 0 => a - | pos p => Pos.iter div2 a p - end. - -(** Checking whether a particular bit is set or not *) - -Definition testbit_nat (a:N) := - match a with - | 0 => fun _ => false - | pos p => Pos.testbit_nat p - end. - -(** Same, but with index in N *) - -Definition testbit a n := - match a with - | 0 => false - | pos p => Pos.testbit p n - end. - -(** Translation from [N] to [nat] and back. *) - -Definition to_nat (a:N) := - match a with - | 0 => O - | pos p => Pos.to_nat p - end. - -Definition of_nat (n:nat) := - match n with - | O => 0 - | S n' => pos (Pos.of_succ_nat n') - end. - -(** Iteration of a function *) - -Definition iter (n:N) {A} (f:A->A) (x:A) : A := - match n with - | 0 => x - | pos p => Pos.iter f x p - end. - -(** Conversion with a decimal representation for printing/parsing *) - -Definition of_uint (d:Decimal.uint) := Pos.of_uint d. - -Definition of_hex_uint (d:Hexadecimal.uint) := Pos.of_hex_uint d. - -Definition of_num_uint (d:Number.uint) := - match d with - | Number.UIntDecimal d => of_uint d - | Number.UIntHexadecimal d => of_hex_uint d - end. - -Definition of_int (d:Decimal.int) := - match Decimal.norm d with - | Decimal.Pos d => Some (Pos.of_uint d) - | Decimal.Neg _ => None - end. - -Definition of_hex_int (d:Hexadecimal.int) := - match Hexadecimal.norm d with - | Hexadecimal.Pos d => Some (Pos.of_hex_uint d) - | Hexadecimal.Neg _ => None - end. - -Definition of_num_int (d:Number.int) := - match d with - | Number.IntDecimal d => of_int d - | Number.IntHexadecimal d => of_hex_int d - end. - -Definition to_uint n := - match n with - | 0 => Decimal.zero - | pos p => Pos.to_uint p - end. - -Definition to_hex_uint n := - match n with - | 0 => Hexadecimal.zero - | pos p => Pos.to_hex_uint p - end. - -Definition to_num_uint n := Number.UIntDecimal (to_uint n). - -Definition to_num_hex_uint n := Number.UIntHexadecimal (to_hex_uint n). - -Definition to_int n := Decimal.Pos (to_uint n). - -Definition to_hex_int n := Hexadecimal.Pos (to_hex_uint n). - -Definition to_num_int n := Number.IntDecimal (to_int n). - -Definition to_num_hex_int n := Number.IntHexadecimal (to_hex_int n). - -Number Notation N of_num_uint to_num_hex_uint : hex_N_scope. -Number Notation N of_num_uint to_num_uint : N_scope. - -End N. - -(** Re-export the notation for those who just [Import NatIntDef] *) -Number Notation N N.of_num_uint N.to_num_hex_uint : hex_N_scope. -Number Notation N N.of_num_uint N.to_num_uint : N_scope. diff --git a/stdlib/theories/NArith/NArith.v b/stdlib/theories/NArith/NArith.v deleted file mode 100644 index e4058ebc29b5..000000000000 --- a/stdlib/theories/NArith/NArith.v +++ /dev/null @@ -1,34 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* y<=x -> x=y]. *) - -Local Open Scope N_scope. - -Section TestOrder. - Let test : forall x y, x<=y -> y<=x -> x=y. - Proof. - N.order. - Defined. -End TestOrder. diff --git a/stdlib/theories/NArith/Ndec.v b/stdlib/theories/NArith/Ndec.v deleted file mode 100644 index d2190e864301..000000000000 --- a/stdlib/theories/NArith/Ndec.v +++ /dev/null @@ -1,311 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* p = p'. -Proof. now apply Pos.eqb_eq. Qed. - -Lemma Peqb_Pcompare p p' : Pos.eqb p p' = true -> Pos.compare p p' = Eq. -Proof. now rewrite Pos.compare_eq_iff, <- Pos.eqb_eq. Qed. - -Lemma Pcompare_Peqb p p' : Pos.compare p p' = Eq -> Pos.eqb p p' = true. -Proof. now rewrite Pos.eqb_eq, <- Pos.compare_eq_iff. Qed. - -Lemma Neqb_Ncompare n n' : N.eqb n n' = true -> N.compare n n' = Eq. -Proof. now rewrite N.compare_eq_iff, <- N.eqb_eq. Qed. - -Lemma Ncompare_Neqb n n' : N.compare n n' = Eq -> N.eqb n n' = true. -Proof. now rewrite N.eqb_eq, <- N.compare_eq_iff. Qed. - -Lemma Neqb_complete n n' : N.eqb n n' = true -> n = n'. -Proof. now apply N.eqb_eq. Qed. - -Lemma Nxor_eq_true n n' : N.lxor n n' = 0 -> N.eqb n n' = true. -Proof. - intro H. apply N.lxor_eq in H. subst. apply N.eqb_refl. -Qed. - -Ltac eqb2eq := rewrite <- ?not_true_iff_false in *; rewrite ?N.eqb_eq in *. - -Lemma Nxor_eq_false n n' p : - N.lxor n n' = N.pos p -> N.eqb n n' = false. -Proof. - intros. eqb2eq. intro. subst. now rewrite N.lxor_nilpotent in *. -Qed. - -Lemma Nodd_not_double a : - N.odd a = true -> forall a0, N.eqb (N.double a0) a = false. -Proof. - intros H **; eqb2eq. - rewrite N.double_spec; intro; subst. - rewrite N.odd_mul, N.odd_2 in *; discriminate. -Qed. - -Lemma Nnot_div2_not_double a a0 : - N.eqb (N.div2 a) a0 = false -> N.eqb a (N.double a0) = false. -Proof. - intros H. eqb2eq. contradict H. subst. apply N.div2_double. -Qed. - -Lemma Neven_not_double_plus_one a : - N.even a = true -> forall a0, N.eqb (N.succ_double a0) a = false. -Proof. - intros H **; eqb2eq. - rewrite N.succ_double_spec; intro; subst. - rewrite N.add_comm, N.even_add_mul_2 in *; discriminate. -Qed. - -Lemma Nnot_div2_not_double_plus_one a a0 : - N.eqb (N.div2 a) a0 = false -> N.eqb (N.succ_double a0) a = false. -Proof. - intros H. eqb2eq. contradict H. subst. apply N.div2_succ_double. -Qed. - -Lemma Nbit0_neq a a' : - N.odd a = false -> N.odd a' = true -> N.eqb a a' = false. -Proof. - intros. eqb2eq. now intros <-. -Qed. - -Lemma Ndiv2_eq a a' : - N.eqb a a' = true -> N.eqb (N.div2 a) (N.div2 a') = true. -Proof. - intros. eqb2eq. now subst. -Qed. - -Lemma Ndiv2_neq a a' : - N.eqb (N.div2 a) (N.div2 a') = false -> N.eqb a a' = false. -Proof. - intros H. eqb2eq. contradict H. now subst. -Qed. - -Lemma Ndiv2_bit_eq a a' : - N.odd a = N.odd a' -> N.div2 a = N.div2 a' -> a = a'. -Proof. - intros H H'; now rewrite (N.div2_odd a), (N.div2_odd a'), H, H'. -Qed. - -Lemma Ndiv2_bit_neq a a' : - N.eqb a a' = false -> - N.odd a = N.odd a' -> N.eqb (N.div2 a) (N.div2 a') = false. -Proof. - intros H H'. eqb2eq. contradict H. now apply Ndiv2_bit_eq. -Qed. - -Lemma Nneq_elim a a' : - N.eqb a a' = false -> - N.odd a = negb (N.odd a') \/ - N.eqb (N.div2 a) (N.div2 a') = false. -Proof. - intros. - enough (N.odd a = N.odd a' \/ N.odd a = negb (N.odd a')) as []. - - right. apply Ndiv2_bit_neq; assumption. - - left. assumption. - - case (N.odd a), (N.odd a'); auto. -Qed. - -Lemma Ndouble_or_double_plus_un a : - {a0 : N | a = N.double a0} + {a1 : N | a = N.succ_double a1}. -Proof. - elim (sumbool_of_bool (N.odd a)); intros H; [right|left]; - exists (N.div2 a); symmetry; - rewrite ?N.succ_double_spec, ?N.double_spec, N.div2_odd, H, ?N.add_0_r; trivial. -Qed. - -(** An inefficient boolean order on [N]. Please use [N.leb] instead now. *) - -Definition Nleb (a b:N) := leb (N.to_nat a) (N.to_nat b). - -Lemma Nleb_alt a b : Nleb a b = N.leb a b. -Proof. - unfold Nleb. - now rewrite eq_iff_eq_true, N.leb_le, leb_compare, <- N2Nat.inj_compare. -Qed. - -Lemma Nleb_Nle a b : Nleb a b = true <-> a <= b. -Proof. now rewrite Nleb_alt, N.leb_le. Qed. - -Lemma Nleb_refl a : Nleb a a = true. -Proof. rewrite Nleb_Nle; apply N.le_refl. Qed. - -Lemma Nleb_antisym a b : Nleb a b = true -> Nleb b a = true -> a = b. -Proof. rewrite !Nleb_Nle. apply N.le_antisymm. Qed. - -Lemma Nleb_trans a b c : Nleb a b = true -> Nleb b c = true -> Nleb a c = true. -Proof. rewrite !Nleb_Nle. apply N.le_trans. Qed. - -Lemma Nleb_ltb_trans a b c : - Nleb a b = true -> Nleb c b = false -> Nleb c a = false. -Proof. - unfold Nleb. intros. apply leb_correct_conv. - apply Nat.le_lt_trans with (m := N.to_nat b). - - apply leb_complete. assumption. - - apply leb_complete_conv. assumption. -Qed. - -Lemma Nltb_leb_trans a b c : - Nleb b a = false -> Nleb b c = true -> Nleb c a = false. -Proof. - unfold Nleb. intros. apply leb_correct_conv. - apply Nat.lt_le_trans with (m := N.to_nat b). - - apply leb_complete_conv. assumption. - - apply leb_complete. assumption. -Qed. - -Lemma Nltb_trans a b c : - Nleb b a = false -> Nleb c b = false -> Nleb c a = false. -Proof. - unfold Nleb. intros. apply leb_correct_conv. - apply Nat.lt_trans with (m := N.to_nat b). - - apply leb_complete_conv. assumption. - - apply leb_complete_conv. assumption. -Qed. - -Lemma Nltb_leb_weak a b : Nleb b a = false -> Nleb a b = true. -Proof. - unfold Nleb. intros. apply leb_correct. apply Nat.lt_le_incl. - apply leb_complete_conv. assumption. -Qed. - -Lemma Nleb_double_mono a b : - Nleb a b = true -> Nleb (N.double a) (N.double b) = true. -Proof. - unfold Nleb. intros. rewrite !N2Nat.inj_double. apply leb_correct. - apply Nat.mul_le_mono_l. now apply leb_complete. -Qed. - -Lemma Nleb_double_plus_one_mono a b : - Nleb a b = true -> - Nleb (N.succ_double a) (N.succ_double b) = true. -Proof. - unfold Nleb. intros. rewrite !N2Nat.inj_succ_double. apply leb_correct. - apply le_n_S, Nat.mul_le_mono_l. now apply leb_complete. -Qed. - -Lemma Nleb_double_mono_conv a b : - Nleb (N.double a) (N.double b) = true -> Nleb a b = true. -Proof. - unfold Nleb. rewrite !N2Nat.inj_double. intro. apply leb_correct. - apply <- (Nat.mul_le_mono_pos_l (N.to_nat a) (N.to_nat b) 2); auto. - now apply leb_complete. -Qed. - -Lemma Nleb_double_plus_one_mono_conv a b : - Nleb (N.succ_double a) (N.succ_double b) = true -> - Nleb a b = true. -Proof. - unfold Nleb. rewrite !N2Nat.inj_succ_double. intro. apply leb_correct. - apply <- (Nat.mul_le_mono_pos_l (N.to_nat a) (N.to_nat b) 2); auto. - now apply leb_complete. -Qed. - -Lemma Nltb_double_mono a b : - Nleb a b = false -> Nleb (N.double a) (N.double b) = false. -Proof. - intros. elim (sumbool_of_bool (Nleb (N.double a) (N.double b))). - - intro H0. - rewrite (Nleb_double_mono_conv _ _ H0) in H. discriminate H. - - trivial. -Qed. - -Lemma Nltb_double_plus_one_mono a b : - Nleb a b = false -> - Nleb (N.succ_double a) (N.succ_double b) = false. -Proof. - intros. elim (sumbool_of_bool (Nleb (N.succ_double a) (N.succ_double b))). - - intro H0. - rewrite (Nleb_double_plus_one_mono_conv _ _ H0) in H. discriminate H. - - trivial. -Qed. - -Lemma Nltb_double_mono_conv a b : - Nleb (N.double a) (N.double b) = false -> Nleb a b = false. -Proof. - intros. elim (sumbool_of_bool (Nleb a b)). - - intro H0. - rewrite (Nleb_double_mono _ _ H0) in H. discriminate H. - - trivial. -Qed. - -Lemma Nltb_double_plus_one_mono_conv a b : - Nleb (N.succ_double a) (N.succ_double b) = false -> - Nleb a b = false. -Proof. - intros. elim (sumbool_of_bool (Nleb a b)). - - intro H0. - rewrite (Nleb_double_plus_one_mono _ _ H0) in H. discriminate H. - - trivial. -Qed. - -(* Nleb and N.compare *) - -(* NB: No need to prove that Nleb a b = true <-> N.compare a b <> Gt, - this statement is in fact Nleb_Nle! *) - -Lemma Nltb_Ncompare a b : Nleb a b = false <-> N.compare a b = Gt. -Proof. - now rewrite N.compare_nle_iff, <- Nleb_Nle, not_true_iff_false. -Qed. - -Lemma Ncompare_Gt_Nltb a b : N.compare a b = Gt -> Nleb a b = false. -Proof. apply <- Nltb_Ncompare; auto. Qed. - -Lemma Ncompare_Lt_Nltb a b : N.compare a b = Lt -> Nleb b a = false. -Proof. - intros H. rewrite Nltb_Ncompare, N.compare_antisym, H; auto. -Qed. - -(* Old results about [N.min] *) - -Notation Nmin_choice := N.min_dec (only parsing). - -Lemma Nmin_le_1 a b : Nleb (N.min a b) a = true. -Proof. rewrite Nleb_Nle. apply N.le_min_l. Qed. - -Lemma Nmin_le_2 a b : Nleb (N.min a b) b = true. -Proof. rewrite Nleb_Nle. apply N.le_min_r. Qed. - -Lemma Nmin_le_3 a b c : Nleb a (N.min b c) = true -> Nleb a b = true. -Proof. rewrite !Nleb_Nle. apply N.min_glb_l. Qed. - -Lemma Nmin_le_4 a b c : Nleb a (N.min b c) = true -> Nleb a c = true. -Proof. rewrite !Nleb_Nle. apply N.min_glb_r. Qed. - -Lemma Nmin_le_5 a b c : - Nleb a b = true -> Nleb a c = true -> Nleb a (N.min b c) = true. -Proof. rewrite !Nleb_Nle. apply N.min_glb. Qed. - -Lemma Nmin_lt_3 a b c : Nleb (N.min b c) a = false -> Nleb b a = false. -Proof. - rewrite <- !not_true_iff_false, !Nleb_Nle. - rewrite N.min_le_iff; auto. -Qed. - -Lemma Nmin_lt_4 a b c : Nleb (N.min b c) a = false -> Nleb c a = false. -Proof. - rewrite <- !not_true_iff_false, !Nleb_Nle. - rewrite N.min_le_iff; auto. -Qed. diff --git a/stdlib/theories/NArith/Ndiv_def.v b/stdlib/theories/NArith/Ndiv_def.v deleted file mode 100644 index 1a7f90cd8d21..000000000000 --- a/stdlib/theories/NArith/Ndiv_def.v +++ /dev/null @@ -1,30 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* a = a'. -Proof. - intro H. rewrite <- (id a), <- (id a'). now f_equal. -Qed. - -Lemma inj_iff a a' : N.to_nat a = N.to_nat a' <-> a = a'. -Proof. - split. - - apply inj. - - intros; now subst. -Qed. - -(** Interaction of this translation and usual operations. *) - -Lemma inj_0 : N.to_nat 0 = 0. -Proof. reflexivity. Qed. - -Lemma inj_double a : N.to_nat (N.double a) = 2*(N.to_nat a). -Proof. - destruct a; simpl N.to_nat; trivial. apply Pos2Nat.inj_xO. -Qed. - -Lemma inj_succ_double a : N.to_nat (N.succ_double a) = S (2*(N.to_nat a)). -Proof. - destruct a; simpl N.to_nat; trivial. apply Pos2Nat.inj_xI. -Qed. - -Lemma inj_succ a : N.to_nat (N.succ a) = S (N.to_nat a). -Proof. - destruct a; simpl; trivial. apply Pos2Nat.inj_succ. -Qed. - -Lemma inj_add a a' : - N.to_nat (a + a') = N.to_nat a + N.to_nat a'. -Proof. - destruct a, a'; simpl; trivial. apply Pos2Nat.inj_add. -Qed. - -Lemma inj_mul a a' : - N.to_nat (a * a') = N.to_nat a * N.to_nat a'. -Proof. - destruct a, a'; simpl; trivial. apply Pos2Nat.inj_mul. -Qed. - -Lemma inj_sub a a' : - N.to_nat (a - a') = N.to_nat a - N.to_nat a'. -Proof. - destruct a as [|a], a' as [|a']; simpl; rewrite ?Nat.sub_0_r; trivial. - destruct (Pos.compare_spec a a') as [H|H|H]. - - subst. now rewrite Pos.sub_mask_diag, Nat.sub_diag. - - rewrite Pos.sub_mask_neg; trivial. apply Pos2Nat.inj_lt in H. - simpl; symmetry; apply Nat.sub_0_le. now apply Nat.lt_le_incl. - - destruct (Pos.sub_mask_pos' _ _ H) as (q & -> & Hq). - simpl; symmetry; apply Nat.add_sub_eq_l. now rewrite <- Hq, Pos2Nat.inj_add. -Qed. - -Lemma inj_pred a : N.to_nat (N.pred a) = Nat.pred (N.to_nat a). -Proof. - rewrite <- Nat.sub_1_r, N.pred_sub. apply inj_sub. -Qed. - -Lemma inj_div2 a : N.to_nat (N.div2 a) = Nat.div2 (N.to_nat a). -Proof. - destruct a as [|[p|p| ]]; trivial. - - unfold N.div2, N.to_nat. now rewrite Pos2Nat.inj_xI, Nat.div2_succ_double. - - unfold N.div2, N.to_nat. now rewrite Pos2Nat.inj_xO, Nat.div2_double. -Qed. - -Lemma inj_compare a a' : - (a ?= a')%N = (N.to_nat a ?= N.to_nat a'). -Proof. - destruct a as [|p], a' as [|p']; simpl; trivial. - - now destruct (Pos2Nat.is_succ p') as (n,->). - - now destruct (Pos2Nat.is_succ p) as (n,->). - - apply Pos2Nat.inj_compare. -Qed. - -Lemma inj_div n m : - N.to_nat (n / m) = N.to_nat n / N.to_nat m. -Proof. - destruct m as [|m]; [now destruct n|]. - apply Nat.div_unique with (N.to_nat (n mod (N.pos m))). - - apply Nat.compare_lt_iff. rewrite <- inj_compare. - now apply N.mod_lt. - - now rewrite <- inj_mul, <- inj_add, <- N.div_mod. -Qed. - -Lemma inj_mod a a' : - N.to_nat (a mod a') = N.to_nat a mod N.to_nat a'. -Proof. - destruct a' as [|a']; [now destruct a|]. - apply Nat.mod_unique with (N.to_nat (a / (N.pos a'))). - - apply Nat.compare_lt_iff. rewrite <- inj_compare. - now apply N.mod_lt. - - now rewrite <- inj_mul, <- inj_add, <- N.div_mod. -Qed. - -Lemma inj_pow a a' : - N.to_nat (a ^ a') = N.to_nat a ^ N.to_nat a'. -Proof. - destruct a, a'; [easy| |easy|apply Pos2Nat.inj_pow]. - now rewrite N.pow_0_l, Nat.pow_0_l; [|rewrite <- inj_0; intros ? %inj|]. -Qed. - -Lemma inj_max a a' : - N.to_nat (N.max a a') = Nat.max (N.to_nat a) (N.to_nat a'). -Proof. - unfold N.max. rewrite inj_compare; symmetry. - case Nat.compare_spec; intros. - - now apply Nat.max_r, Nat.eq_le_incl. - - now apply Nat.max_r, Nat.lt_le_incl. - - now apply Nat.max_l, Nat.lt_le_incl. -Qed. - -Lemma inj_min a a' : - N.to_nat (N.min a a') = Nat.min (N.to_nat a) (N.to_nat a'). -Proof. - unfold N.min; rewrite inj_compare. symmetry. - case Nat.compare_spec; intros. - - now apply Nat.min_l, Nat.eq_le_incl. - - now apply Nat.min_l, Nat.lt_le_incl. - - now apply Nat.min_r, Nat.lt_le_incl. -Qed. - -Lemma inj_iter a {A} (f:A->A) (x:A) : - N.iter a f x = Nat.iter (N.to_nat a) f x. -Proof. - destruct a as [|a]. - - trivial. - - apply Pos2Nat.inj_iter. -Qed. - -End N2Nat. - -Global Hint Rewrite N2Nat.inj_div N2Nat.inj_mod N2Nat.inj_pow - N2Nat.inj_double N2Nat.inj_succ_double - N2Nat.inj_succ N2Nat.inj_add N2Nat.inj_mul N2Nat.inj_sub - N2Nat.inj_pred N2Nat.inj_div2 N2Nat.inj_max N2Nat.inj_min - N2Nat.id - : Nnat. - - -(** * Conversions from [nat] to [N] *) - -Module Nat2N. - -(** [N.of_nat] is an bijection between [nat] and [N], - with [N.to_nat] as reciprocal. - See [N2Nat.id] above for the dual equation. *) - -Lemma id n : N.to_nat (N.of_nat n) = n. -Proof. - induction n; simpl; trivial. apply SuccNat2Pos.id_succ. -Qed. - -Global Hint Rewrite id : Nnat. -Ltac nat2N := apply N2Nat.inj; now autorewrite with Nnat. - -(** [N.of_nat] is hence injective *) - -Lemma inj n n' : N.of_nat n = N.of_nat n' -> n = n'. -Proof. - intros H. rewrite <- (id n), <- (id n'). now f_equal. -Qed. - -Lemma inj_iff n n' : N.of_nat n = N.of_nat n' <-> n = n'. -Proof. - split. - - apply inj. - - intros; now subst. -Qed. - -(** Interaction of this translation and usual operations. *) - -Lemma inj_double n : N.of_nat (2*n) = N.double (N.of_nat n). -Proof. nat2N. Qed. - -Lemma inj_succ_double n : N.of_nat (S (2*n)) = N.succ_double (N.of_nat n). -Proof. nat2N. Qed. - -Lemma inj_succ n : N.of_nat (S n) = N.succ (N.of_nat n). -Proof. nat2N. Qed. - -Lemma inj_pred n : N.of_nat (Nat.pred n) = N.pred (N.of_nat n). -Proof. nat2N. Qed. - -Lemma inj_add n n' : N.of_nat (n+n') = (N.of_nat n + N.of_nat n')%N. -Proof. nat2N. Qed. - -Lemma inj_sub n n' : N.of_nat (n-n') = (N.of_nat n - N.of_nat n')%N. -Proof. nat2N. Qed. - -Lemma inj_mul n n' : N.of_nat (n*n') = (N.of_nat n * N.of_nat n')%N. -Proof. nat2N. Qed. - -Lemma inj_div2 n : N.of_nat (Nat.div2 n) = N.div2 (N.of_nat n). -Proof. nat2N. Qed. - -Lemma inj_compare n n' : - (n ?= n') = (N.of_nat n ?= N.of_nat n')%N. -Proof. now rewrite N2Nat.inj_compare, !id. Qed. - -Lemma inj_div n n' : - N.of_nat (n / n') = (N.of_nat n / N.of_nat n')%N. -Proof. nat2N. Qed. - -Lemma inj_mod n n' : - N.of_nat (n mod n') = (N.of_nat n mod N.of_nat n')%N. -Proof. nat2N. Qed. - -Lemma inj_pow n n' : - N.of_nat (n ^ n') = (N.of_nat n ^ N.of_nat n')%N. -Proof. nat2N. Qed. - -Lemma inj_min n n' : - N.of_nat (Nat.min n n') = N.min (N.of_nat n) (N.of_nat n'). -Proof. nat2N. Qed. - -Lemma inj_max n n' : - N.of_nat (Nat.max n n') = N.max (N.of_nat n) (N.of_nat n'). -Proof. nat2N. Qed. - -Lemma inj_iter n {A} (f:A->A) (x:A) : - Nat.iter n f x = N.iter (N.of_nat n) f x. -Proof. now rewrite N2Nat.inj_iter, !id. Qed. - -End Nat2N. - -Global Hint Rewrite Nat2N.id : Nnat. - -(** Compatibility notations *) - -Notation nat_of_N_inj := N2Nat.inj (only parsing). -Notation N_of_nat_of_N := N2Nat.id (only parsing). -Notation nat_of_Ndouble := N2Nat.inj_double (only parsing). -Notation nat_of_Ndouble_plus_one := N2Nat.inj_succ_double (only parsing). -Notation nat_of_Nsucc := N2Nat.inj_succ (only parsing). -Notation nat_of_Nplus := N2Nat.inj_add (only parsing). -Notation nat_of_Nmult := N2Nat.inj_mul (only parsing). -Notation nat_of_Nminus := N2Nat.inj_sub (only parsing). -Notation nat_of_Npred := N2Nat.inj_pred (only parsing). -Notation nat_of_Ndiv2 := N2Nat.inj_div2 (only parsing). -Notation nat_of_Ncompare := N2Nat.inj_compare (only parsing). -Notation nat_of_Ndiv := N2Nat.inj_div (only parsing). -Notation nat_of_Nmod := N2Nat.inj_mod (only parsing). -Notation nat_of_Npow := N2Nat.inj_pow (only parsing). -Notation nat_of_Nmax := N2Nat.inj_max (only parsing). -Notation nat_of_Nmin := N2Nat.inj_min (only parsing). - -Notation nat_of_N_of_nat := Nat2N.id (only parsing). -Notation N_of_nat_inj := Nat2N.inj (only parsing). -Notation N_of_double := Nat2N.inj_double (only parsing). -Notation N_of_double_plus_one := Nat2N.inj_succ_double (only parsing). -Notation N_of_S := Nat2N.inj_succ (only parsing). -Notation N_of_pred := Nat2N.inj_pred (only parsing). -Notation N_of_plus := Nat2N.inj_add (only parsing). -Notation N_of_minus := Nat2N.inj_sub (only parsing). -Notation N_of_mult := Nat2N.inj_mul (only parsing). -Notation N_of_div2 := Nat2N.inj_div2 (only parsing). -Notation N_of_nat_compare := Nat2N.inj_compare (only parsing). -Notation N_of_nat_div := Nat2N.inj_div (only parsing). -Notation N_of_nat_mod := Nat2N.inj_mod (only parsing). -Notation N_of_nat_pow := Nat2N.inj_pow (only parsing). -Notation N_of_min := Nat2N.inj_min (only parsing). -Notation N_of_max := Nat2N.inj_max (only parsing). diff --git a/stdlib/theories/NArith/Nsqrt_def.v b/stdlib/theories/NArith/Nsqrt_def.v deleted file mode 100644 index 0197423b725e..000000000000 --- a/stdlib/theories/NArith/Nsqrt_def.v +++ /dev/null @@ -1,16 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* N.sqrt_spec n (N.le_0_l n)) (only parsing). diff --git a/stdlib/theories/Numbers/AltBinNotations.v b/stdlib/theories/Numbers/AltBinNotations.v deleted file mode 100644 index e5b388f85e63..000000000000 --- a/stdlib/theories/Numbers/AltBinNotations.v +++ /dev/null @@ -1,69 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* Some p - | _ => None - end. - -Definition pos_to_z p := Zpos p. - -Number Notation positive pos_of_z pos_to_z : positive_scope. - -(** [N] *) - -Definition n_of_z z := - match z with - | Z0 => Some N0 - | Zpos p => Some (Npos p) - | Zneg _ => None - end. - -Definition n_to_z n := - match n with - | N0 => Z0 - | Npos p => Zpos p - end. - -Number Notation N n_of_z n_to_z : N_scope. - -(** [Z] *) - -Definition z_of_z (z:Z) := z. - -Number Notation Z z_of_z z_of_z : Z_scope. diff --git a/stdlib/theories/Numbers/BinNums.v b/stdlib/theories/Numbers/BinNums.v deleted file mode 100644 index 836a6d07a2d3..000000000000 --- a/stdlib/theories/Numbers/BinNums.v +++ /dev/null @@ -1 +0,0 @@ -From Corelib Require Export BinNums. diff --git a/stdlib/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v b/stdlib/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v deleted file mode 100644 index 111e466fabea..000000000000 --- a/stdlib/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v +++ /dev/null @@ -1,437 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* Z; - of_pos : positive -> N * t; (* Euclidean division by [2^digits] *) - head0 : t -> t; (* number of digits 0 in front of the number *) - tail0 : t -> t; (* number of digits 0 at the bottom of the number *) - - (* Basic numbers *) - zero : t; - one : t; - minus_one : t; (* [2^digits-1], which is equivalent to [-1] *) - - (* Comparison *) - compare : t -> t -> comparison; - eq0 : t -> bool; - - (* Basic arithmetic operations *) - opp_c : t -> carry t; - opp : t -> t; - opp_carry : t -> t; (* the carry is known to be -1 *) - - succ_c : t -> carry t; - add_c : t -> t -> carry t; - add_carry_c : t -> t -> carry t; - succ : t -> t; - add : t -> t -> t; - add_carry : t -> t -> t; - - pred_c : t -> carry t; - sub_c : t -> t -> carry t; - sub_carry_c : t -> t -> carry t; - pred : t -> t; - sub : t -> t -> t; - sub_carry : t -> t -> t; - - mul_c : t -> t -> zn2z t; - mul : t -> t -> t; - square_c : t -> zn2z t; - - (* Special divisions operations *) - div21 : t -> t -> t -> t*t; - div_gt : t -> t -> t * t; (* specialized version of [div] *) - div : t -> t -> t * t; - - modulo_gt : t -> t -> t; (* specialized version of [mod] *) - modulo : t -> t -> t; - - gcd_gt : t -> t -> t; (* specialized version of [gcd] *) - gcd : t -> t -> t; - (* [add_mul_div p i j] is a combination of the [(digits-p)] - low bits of [i] above the [p] high bits of [j]: - [add_mul_div p i j = i*2^p+j/2^(digits-p)] *) - add_mul_div : t -> t -> t -> t; - (* [pos_mod p i] is [i mod 2^p] *) - pos_mod : t -> t -> t; - - is_even : t -> bool; - (* square root *) - sqrt2 : t -> t -> t * carry t; - sqrt : t -> t; - (* bitwise operations *) - lor : t -> t -> t; - land : t -> t -> t; - lxor : t -> t -> t }. - - Section Specs. - Context {t : Set}{ops : Ops t}. - - Notation "[| x |]" := (to_Z x) (at level 0, x at level 99). - - Let wB := base digits. - - Notation "[+| c |]" := - (interp_carry 1 wB to_Z c) (at level 0, c at level 99). - - Notation "[-| c |]" := - (interp_carry (-1) wB to_Z c) (at level 0, c at level 99). - - Notation "[|| x ||]" := - (zn2z_to_Z wB to_Z x) (at level 0, x at level 99). - - Class Specs := MkSpecs { - - (* Conversion functions with Z *) - spec_to_Z : forall x, 0 <= [| x |] < wB; - spec_of_pos : forall p, - Zpos p = (Z.of_N (fst (of_pos p)))*wB + [|(snd (of_pos p))|]; - spec_zdigits : [| zdigits |] = Zpos digits; - spec_more_than_1_digit: 1 < Zpos digits; - - (* Basic numbers *) - spec_0 : [|zero|] = 0; - spec_1 : [|one|] = 1; - spec_m1 : [|minus_one|] = wB - 1; - - (* Comparison *) - spec_compare : forall x y, compare x y = ([|x|] ?= [|y|]); - (* NB: the spec of [eq0] is deliberately partial, - see DoubleCyclic where [eq0 x = true <-> x = W0] *) - spec_eq0 : forall x, eq0 x = true -> [|x|] = 0; - (* Basic arithmetic operations *) - spec_opp_c : forall x, [-|opp_c x|] = -[|x|]; - spec_opp : forall x, [|opp x|] = (-[|x|]) mod wB; - spec_opp_carry : forall x, [|opp_carry x|] = wB - [|x|] - 1; - - spec_succ_c : forall x, [+|succ_c x|] = [|x|] + 1; - spec_add_c : forall x y, [+|add_c x y|] = [|x|] + [|y|]; - spec_add_carry_c : forall x y, [+|add_carry_c x y|] = [|x|] + [|y|] + 1; - spec_succ : forall x, [|succ x|] = ([|x|] + 1) mod wB; - spec_add : forall x y, [|add x y|] = ([|x|] + [|y|]) mod wB; - spec_add_carry : - forall x y, [|add_carry x y|] = ([|x|] + [|y|] + 1) mod wB; - - spec_pred_c : forall x, [-|pred_c x|] = [|x|] - 1; - spec_sub_c : forall x y, [-|sub_c x y|] = [|x|] - [|y|]; - spec_sub_carry_c : forall x y, [-|sub_carry_c x y|] = [|x|] - [|y|] - 1; - spec_pred : forall x, [|pred x|] = ([|x|] - 1) mod wB; - spec_sub : forall x y, [|sub x y|] = ([|x|] - [|y|]) mod wB; - spec_sub_carry : - forall x y, [|sub_carry x y|] = ([|x|] - [|y|] - 1) mod wB; - - spec_mul_c : forall x y, [|| mul_c x y ||] = [|x|] * [|y|]; - spec_mul : forall x y, [|mul x y|] = ([|x|] * [|y|]) mod wB; - spec_square_c : forall x, [|| square_c x||] = [|x|] * [|x|]; - - (* Special divisions operations *) - spec_div21 : forall a1 a2 b, - wB/2 <= [|b|] -> - [|a1|] < [|b|] -> - let (q,r) := div21 a1 a2 b in - [|a1|] *wB+ [|a2|] = [|q|] * [|b|] + [|r|] /\ - 0 <= [|r|] < [|b|]; - spec_div_gt : forall a b, [|a|] > [|b|] -> 0 < [|b|] -> - let (q,r) := div_gt a b in - [|a|] = [|q|] * [|b|] + [|r|] /\ - 0 <= [|r|] < [|b|]; - spec_div : forall a b, 0 < [|b|] -> - let (q,r) := div a b in - [|a|] = [|q|] * [|b|] + [|r|] /\ - 0 <= [|r|] < [|b|]; - - spec_modulo_gt : forall a b, [|a|] > [|b|] -> 0 < [|b|] -> - [|modulo_gt a b|] = [|a|] mod [|b|]; - spec_modulo : forall a b, 0 < [|b|] -> - [|modulo a b|] = [|a|] mod [|b|]; - - spec_gcd_gt : forall a b, [|a|] > [|b|] -> - Zis_gcd [|a|] [|b|] [|gcd_gt a b|]; - spec_gcd : forall a b, Zis_gcd [|a|] [|b|] [|gcd a b|]; - - - (* shift operations *) - spec_head00: forall x, [|x|] = 0 -> [|head0 x|] = Zpos digits; - spec_head0 : forall x, 0 < [|x|] -> - wB/ 2 <= 2 ^ ([|head0 x|]) * [|x|] < wB; - spec_tail00: forall x, [|x|] = 0 -> [|tail0 x|] = Zpos digits; - spec_tail0 : forall x, 0 < [|x|] -> - exists y, 0 <= y /\ [|x|] = (2 * y + 1) * (2 ^ [|tail0 x|]) ; - spec_add_mul_div : forall x y p, - [|p|] <= Zpos digits -> - [| add_mul_div p x y |] = - ([|x|] * (2 ^ [|p|]) + - [|y|] / (2 ^ ((Zpos digits) - [|p|]))) mod wB; - spec_pos_mod : forall w p, - [|pos_mod p w|] = [|w|] mod (2 ^ [|p|]); - (* sqrt *) - spec_is_even : forall x, - if is_even x then [|x|] mod 2 = 0 else [|x|] mod 2 = 1; - spec_sqrt2 : forall x y, - wB/ 4 <= [|x|] -> - let (s,r) := sqrt2 x y in - [||WW x y||] = [|s|] ^ 2 + [+|r|] /\ - [+|r|] <= 2 * [|s|]; - spec_sqrt : forall x, - [|sqrt x|] ^ 2 <= [|x|] < ([|sqrt x|] + 1) ^ 2; - spec_lor : forall x y, [|lor x y|] = Z.lor [|x|] [|y|]; - spec_land : forall x y, [|land x y|] = Z.land [|x|] [|y|]; - spec_lxor : forall x y, [|lxor x y|] = Z.lxor [|x|] [|y|] - }. - - End Specs. - - Arguments Specs {t} ops. - - (** Generic construction of double words *) - - Section WW. - - Context {t : Set}{ops : Ops t}{specs : Specs ops}. - - Let wB := base digits. - - Definition WO' (eq0:t->bool) zero h := - if eq0 h then W0 else WW h zero. - - Definition WO := Eval lazy beta delta [WO'] in - let eq0 := ZnZ.eq0 in - let zero := ZnZ.zero in - WO' eq0 zero. - - Definition OW' (eq0:t->bool) zero l := - if eq0 l then W0 else WW zero l. - - Definition OW := Eval lazy beta delta [OW'] in - let eq0 := ZnZ.eq0 in - let zero := ZnZ.zero in - OW' eq0 zero. - - Definition WW' (eq0:t->bool) zero h l := - if eq0 h then OW' eq0 zero l else WW h l. - - Definition WW := Eval lazy beta delta [WW' OW'] in - let eq0 := ZnZ.eq0 in - let zero := ZnZ.zero in - WW' eq0 zero. - - Lemma spec_WO : forall h, - zn2z_to_Z wB to_Z (WO h) = (to_Z h)*wB. - Proof. - unfold zn2z_to_Z, WO; simpl; intros. - case_eq (eq0 h); intros. - - rewrite (spec_eq0 _ H); auto. - - rewrite spec_0; auto with zarith. - Qed. - - Lemma spec_OW : forall l, - zn2z_to_Z wB to_Z (OW l) = to_Z l. - Proof. - unfold zn2z_to_Z, OW; simpl; intros. - case_eq (eq0 l); intros. - - rewrite (spec_eq0 _ H); auto. - - rewrite spec_0; auto with zarith. - Qed. - - Lemma spec_WW : forall h l, - zn2z_to_Z wB to_Z (WW h l) = (to_Z h)*wB + to_Z l. - Proof. - unfold WW; simpl; intros. - case_eq (eq0 h); intros. - - rewrite (spec_eq0 _ H); auto. - fold (OW l). - rewrite spec_OW; auto. - - simpl; auto. - Qed. - - End WW. - - (** Injecting [Z] numbers into a cyclic structure *) - - Section Of_Z. - - Context {t : Set}{ops : Ops t}{specs : Specs ops}. - - Notation "[| x |]" := (to_Z x) (at level 0, x at level 99). - - Theorem of_pos_correct: - forall p, Zpos p < base digits -> [|(snd (of_pos p))|] = Zpos p. - Proof. - intros p Hp. - generalize (spec_of_pos p). - case (of_pos p); intros n w1; simpl. - case n; auto with zarith. - intros p1 Hp1; contradict Hp; apply Z.le_ngt. - replace (base digits) with (1 * base digits + 0) by ring. - rewrite Hp1. - apply Z.add_le_mono. - - apply Z.mul_le_mono_nonneg. 1-2, 4: lia. - unfold base; auto with zarith. - - case (spec_to_Z w1); auto with zarith. - Qed. - - Definition of_Z z := - match z with - | Zpos p => snd (of_pos p) - | _ => zero - end. - - Theorem of_Z_correct: - forall p, 0 <= p < base digits -> [|of_Z p|] = p. - Proof. - intros p; case p; simpl; try rewrite spec_0; auto. - - intros; rewrite of_pos_correct; lia. - - intros p1 (H1, _); contradict H1; apply Z.lt_nge; red; simpl; auto. - Qed. - - End Of_Z. - -End ZnZ. - -(** A modular specification grouping the earlier records. *) - -Module Type CyclicType. - Parameter t : Set. -#[global] - Declare Instance ops : ZnZ.Ops t. -#[global] - Declare Instance specs : ZnZ.Specs ops. -End CyclicType. - - -(** A Cyclic structure can be seen as a ring *) - -Module CyclicRing (Import Cyclic : CyclicType). - -Local Notation "[| x |]" := (ZnZ.to_Z x) (at level 0, x at level 99). - -Definition eq (n m : t) := [| n |] = [| m |]. - -Local Infix "==" := eq (at level 70). -Local Notation "0" := ZnZ.zero. -Local Notation "1" := ZnZ.one. -Local Infix "+" := ZnZ.add. -Local Infix "-" := ZnZ.sub. -Local Notation "- x" := (ZnZ.opp x). -Local Infix "*" := ZnZ.mul. -Local Notation wB := (base ZnZ.digits). - -Global Hint Rewrite ZnZ.spec_0 ZnZ.spec_1 ZnZ.spec_add ZnZ.spec_mul - ZnZ.spec_opp ZnZ.spec_sub - : cyclic. - -Ltac zify := unfold eq in *; autorewrite with cyclic. - -Lemma add_0_l : forall x, 0 + x == x. -Proof. -intros. zify. rewrite Z.add_0_l. -apply Zmod_small. apply ZnZ.spec_to_Z. -Qed. - -Lemma add_comm : forall x y, x + y == y + x. -Proof. -intros. zify. now rewrite Z.add_comm. -Qed. - -Lemma add_assoc : forall x y z, x + (y + z) == x + y + z. -Proof. -intros. zify. now rewrite Zplus_mod_idemp_r, Zplus_mod_idemp_l, Z.add_assoc. -Qed. - -Lemma mul_1_l : forall x, 1 * x == x. -Proof. -intros. zify. rewrite Z.mul_1_l. -apply Zmod_small. apply ZnZ.spec_to_Z. -Qed. - -Lemma mul_comm : forall x y, x * y == y * x. -Proof. -intros. zify. now rewrite Z.mul_comm. -Qed. - -Lemma mul_assoc : forall x y z, x * (y * z) == x * y * z. -Proof. -intros. zify. now rewrite Zmult_mod_idemp_r, Zmult_mod_idemp_l, Z.mul_assoc. -Qed. - -Lemma mul_add_distr_r : forall x y z, (x+y)*z == x*z + y*z. -Proof. -intros. zify. now rewrite <- Zplus_mod, Zmult_mod_idemp_l, Z.mul_add_distr_r. -Qed. - -Lemma add_opp_r : forall x y, x + - y == x-y. -Proof. -intros. zify. rewrite <- Zminus_mod_idemp_r. unfold Z.sub. -destruct (Z.eq_dec ([|y|] mod wB) 0) as [EQ|NEQ]. -- rewrite Z_mod_zero_opp_full, EQ, 2 Z.add_0_r; auto. -- rewrite Z_mod_nz_opp_full by auto. - rewrite <- Zplus_mod_idemp_r, <- Zminus_mod_idemp_l. - rewrite Z_mod_same_full. simpl. now rewrite Zplus_mod_idemp_r. -Qed. - -Lemma add_opp_diag_r : forall x, x + - x == 0. -Proof. -intros. red. rewrite add_opp_r. zify. now rewrite Z.sub_diag, Zmod_0_l. -Qed. - -Lemma CyclicRing : ring_theory 0 1 ZnZ.add ZnZ.mul ZnZ.sub ZnZ.opp eq. -Proof. -constructor. -- exact add_0_l. -- exact add_comm. -- exact add_assoc. -- exact mul_1_l. -- exact mul_comm. -- exact mul_assoc. -- exact mul_add_distr_r. -- symmetry. apply add_opp_r. -- exact add_opp_diag_r. -Qed. - -Definition eqb x y := - match ZnZ.compare x y with Eq => true | _ => false end. - -Lemma eqb_eq : forall x y, eqb x y = true <-> x == y. -Proof. - intros. unfold eqb, eq. - rewrite ZnZ.spec_compare. - case Z.compare_spec; split; (easy || lia). -Qed. - -Lemma eqb_correct : forall x y, eqb x y = true -> x==y. -Proof. now apply eqb_eq. Qed. - -End CyclicRing. diff --git a/stdlib/theories/Numbers/Cyclic/Abstract/DoubleType.v b/stdlib/theories/Numbers/Cyclic/Abstract/DoubleType.v deleted file mode 100644 index 8be7f448f8a1..000000000000 --- a/stdlib/theories/Numbers/Cyclic/Abstract/DoubleType.v +++ /dev/null @@ -1,61 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* Z) c := - match c with - | C0 x => interp x - | C1 x => sign*B + interp x - end. - -(** From a type [znz] representing a cyclic structure Z/nZ, - we produce a representation of Z/2nZ by pairs of elements of [znz] - (plus a special case for zero). High half of the new number comes - first. - *) -#[universes(template)] -Variant zn2z {znz : Type} := -| W0 : zn2z -| WW : znz -> znz -> zn2z. -Arguments zn2z : clear implicits. - -Definition zn2z_to_Z znz (wB:Z) (w_to_Z:znz->Z) (x:zn2z znz) := - match x with - | W0 => 0 - | WW xh xl => w_to_Z xh * wB + w_to_Z xl - end. - -Arguments W0 {znz}. - -(** From a cyclic representation [w], we iterate the [zn2z] construct - [n] times, gaining the type of binary trees of depth at most [n], - whose leafs are either W0 (if depth < n) or elements of w - (if depth = n). -*) - -Fixpoint word (w:Set) (n:nat) : Set := - match n with - | O => w - | S n => zn2z (word w n) - end. diff --git a/stdlib/theories/Numbers/Cyclic/Abstract/NZCyclic.v b/stdlib/theories/Numbers/Cyclic/Abstract/NZCyclic.v deleted file mode 100644 index 44d38c300038..000000000000 --- a/stdlib/theories/Numbers/Cyclic/Abstract/NZCyclic.v +++ /dev/null @@ -1,242 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* eq) succ. -#[global] -Program Instance pred_wd : Proper (eq ==> eq) pred. -#[global] -Program Instance add_wd : Proper (eq ==> eq ==> eq) add. -#[global] -Program Instance sub_wd : Proper (eq ==> eq ==> eq) sub. -#[global] -Program Instance mul_wd : Proper (eq ==> eq ==> eq) mul. - -Theorem gt_wB_1 : 1 < wB. -Proof. -unfold base. apply Zpower_gt_1; unfold Z.lt; auto with zarith. -Qed. - -Theorem gt_wB_0 : 0 < wB. -Proof. -pose proof gt_wB_1; lia. -Qed. - -Lemma one_mod_wB : 1 mod wB = 1. -Proof. - rewrite Zmod_small. - - reflexivity. - - split. - + auto with zarith. - + apply gt_wB_1. -Qed. - -Lemma succ_mod_wB : forall n : Z, (n + 1) mod wB = ((n mod wB) + 1) mod wB. -Proof. -intro n. rewrite <- one_mod_wB at 2. now rewrite <- Zplus_mod. -Qed. - -Lemma pred_mod_wB : forall n : Z, (n - 1) mod wB = ((n mod wB) - 1) mod wB. -Proof. -intro n. rewrite <- one_mod_wB at 2. now rewrite Zminus_mod. -Qed. - -Lemma NZ_to_Z_mod : forall n, [| n |] mod wB = [| n |]. -Proof. - intro n; rewrite Zmod_small. - - reflexivity. - - apply ZnZ.spec_to_Z. -Qed. - -Theorem pred_succ : forall n, P (S n) == n. -Proof. -intro n. zify. -rewrite <- pred_mod_wB. -replace ([| n |] + 1 - 1)%Z with [| n |] by ring. apply NZ_to_Z_mod. -Qed. - -Theorem one_succ : one == succ zero. -Proof. -zify; simpl Z.add. now rewrite one_mod_wB. -Qed. - -Theorem two_succ : two == succ one. -Proof. -reflexivity. -Qed. - -Section Induction. - -Variable A : t -> Prop. -Hypothesis A_wd : Proper (eq ==> iff) A. -Hypothesis A0 : A 0. -Hypothesis AS : forall n, A n <-> A (S n). - (* Below, we use only -> direction *) - -Let B (n : Z) := A (ZnZ.of_Z n). - -Lemma B0 : B 0. -Proof. -unfold B. apply A0. -Qed. - -Lemma BS : forall n : Z, 0 <= n -> n < wB - 1 -> B n -> B (n + 1). -Proof. -intros n H1 H2 H3. -unfold B in *. apply AS in H3. -setoid_replace (ZnZ.of_Z (n + 1)) with (S (ZnZ.of_Z n)). -- assumption. -- zify. - rewrite 2 ZnZ.of_Z_correct. 2-3: lia. - symmetry; apply Zmod_small; lia. -Qed. - -Theorem Zbounded_induction : - (forall Q : Z -> Prop, forall b : Z, - Q 0 -> - (forall n, 0 <= n -> n < b - 1 -> Q n -> Q (n + 1)) -> - forall n, 0 <= n -> n < b -> Q n)%Z. -Proof. -intros Q b Q0 QS. -set (Q' := fun n => (n < b /\ Q n) \/ (b <= n)). -assert (H : forall n, 0 <= n -> Q' n). -- apply natlike_rec2; unfold Q'. - + destruct (Z.le_gt_cases b 0) as [H | H]. - * now right. - * left; now split. - + intros n H IH. destruct IH as [[IH1 IH2] | IH]. - * destruct (Z.le_gt_cases (b - 1) n) as [H1 | H1]. - -- right; lia. - -- left. split; [ lia | now apply (QS n)]. - * right; auto with zarith. -- unfold Q' in *; intros n H1 H2. destruct (H n H1) as [[H3 H4] | H3]. - + assumption. - + now apply Z.le_ngt in H3. -Qed. - -Lemma B_holds : forall n : Z, 0 <= n < wB -> B n. -Proof. -intros n [H1 H2]. -apply Zbounded_induction with wB. -- apply B0. -- apply BS. -- assumption. -- assumption. -Qed. - -Theorem bi_induction : forall n, A n. -Proof. -intro n. setoid_replace n with (ZnZ.of_Z (ZnZ.to_Z n)). -- apply B_holds. apply ZnZ.spec_to_Z. -- red. symmetry. apply ZnZ.of_Z_correct. - apply ZnZ.spec_to_Z. -Qed. - -End Induction. - -Theorem add_0_l : forall n, 0 + n == n. -Proof. -intro n. zify. -rewrite Z.add_0_l. apply Zmod_small. apply ZnZ.spec_to_Z. -Qed. - -Theorem add_succ_l : forall n m, (S n) + m == S (n + m). -Proof. -intros n m. zify. -rewrite succ_mod_wB. repeat rewrite Zplus_mod_idemp_l; try apply gt_wB_0. -rewrite <- (Z.add_assoc ([| n |] mod wB) 1 [| m |]). rewrite Zplus_mod_idemp_l. -rewrite (Z.add_comm 1 [| m |]); now rewrite Z.add_assoc. -Qed. - -Theorem sub_0_r : forall n, n - 0 == n. -Proof. -intro n. zify. rewrite Z.sub_0_r. apply NZ_to_Z_mod. -Qed. - -Theorem sub_succ_r : forall n m, n - (S m) == P (n - m). -Proof. -intros n m. zify. rewrite Zminus_mod_idemp_r, Zminus_mod_idemp_l. -now replace ([|n|] - ([|m|] + 1))%Z with ([|n|] - [|m|] - 1)%Z - by ring. -Qed. - -Theorem mul_0_l : forall n, 0 * n == 0. -Proof. -intro n. now zify. -Qed. - -Theorem mul_succ_l : forall n m, (S n) * m == n * m + m. -Proof. -intros n m. zify. rewrite Zplus_mod_idemp_l, Zmult_mod_idemp_l. -now rewrite Z.mul_add_distr_r, Z.mul_1_l. -Qed. - -Definition t := t. - -End NZCyclicAxiomsMod. diff --git a/stdlib/theories/Numbers/Cyclic/Int63/CarryType.v b/stdlib/theories/Numbers/Cyclic/Int63/CarryType.v deleted file mode 100644 index c027a1fd951e..000000000000 --- a/stdlib/theories/Numbers/Cyclic/Int63/CarryType.v +++ /dev/null @@ -1 +0,0 @@ -From Corelib Require Export CarryType. diff --git a/stdlib/theories/Numbers/Cyclic/Int63/Cyclic63.v b/stdlib/theories/Numbers/Cyclic/Int63/Cyclic63.v deleted file mode 100644 index 34cca4c9f148..000000000000 --- a/stdlib/theories/Numbers/Cyclic/Int63/Cyclic63.v +++ /dev/null @@ -1,323 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* (Npos p, 0) - | S n, xH => (0%N, 1) - | S n, xO p => - let (N,i) := positive_to_int_rec n p in - (N, i << 1) - | S n, xI p => - let (N,i) := positive_to_int_rec n p in - (N, (i << 1) + 1) - end. - -Definition positive_to_int := positive_to_int_rec size. - -Definition mulc_WW x y := - let (h, l) := mulc x y in - if is_zero h then - if is_zero l then W0 - else WW h l - else WW h l. -Notation "n '*c' m" := (mulc_WW n m) (at level 40, no associativity) : uint63_scope. - -Definition pos_mod p x := - if p <=? digits then - let p := digits - p in - (x << p) >> p - else x. - -Notation pos_mod_int := pos_mod. - -Import ZnZ. - -#[global] -Instance int_ops : ZnZ.Ops int := -{| - digits := Pdigits; (* number of digits *) - zdigits := Uint63Axioms.digits; (* number of digits *) - to_Z := Uint63Axioms.to_Z; (* conversion to Z *) - of_pos := positive_to_int; (* positive -> N*int63 : p => N,i - where p = N*2^31+phi i *) - head0 := Uint63.head0; (* number of head 0 *) - tail0 := Uint63.tail0; (* number of tail 0 *) - zero := 0; - one := 1; - minus_one := Uint63Axioms.max_int; - compare := Uint63.compare; - eq0 := Uint63Axioms.is_zero; - opp_c := Uint63.oppc; - opp := Uint63.opp; - opp_carry := Uint63.oppcarry; - succ_c := Uint63.succc; - add_c := Uint63.addc; - add_carry_c := Uint63.addcarryc; - succ := Uint63.succ; - add := Uint63.add; - add_carry := Uint63Axioms.addcarry; - pred_c := Uint63.predc; - sub_c := Uint63.subc; - sub_carry_c := Uint63.subcarryc; - pred := Uint63.pred; - sub := Uint63.sub; - sub_carry := Uint63.subcarry; - mul_c := mulc_WW; - mul := Uint63.mul; - square_c := fun x => mulc_WW x x; - div21 := diveucl_21; - div_gt := diveucl; (* this is supposed to be the special case of - division a/b where a > b *) - div := diveucl; - modulo_gt := Uint63.mod; - modulo := Uint63.mod; - gcd_gt := Uint63.gcd; - gcd := Uint63.gcd; - add_mul_div := Uint63.addmuldiv; - pos_mod := pos_mod_int; - is_even := Uint63Axioms.is_even; - sqrt2 := Uint63.sqrt2; - sqrt := Uint63.sqrt; - ZnZ.lor := Uint63.lor; - ZnZ.land := Uint63.land; - ZnZ.lxor := Uint63.lxor -|}. - -Local Open Scope Z_scope. - -Lemma is_zero_spec_aux : forall x : int, is_zero x = true -> Ļ† x = 0%Z. -Proof. - intros x;rewrite is_zero_spec;intros H;rewrite H;trivial. -Qed. - -Lemma positive_to_int_spec : - forall p : positive, - Zpos p = - Z_of_N (fst (positive_to_int p)) * wB + to_Z (snd (positive_to_int p)). -Proof. - assert (H: (wB <= wB) -> forall p : positive, - Zpos p = Z_of_N (fst (positive_to_int p)) * wB + Ļ† (snd (positive_to_int p)) /\ - Ļ† (snd (positive_to_int p)) < wB). - 2: intros p; case (H (Z.le_refl wB) p); auto. - unfold positive_to_int, wB at 1 3 4. - elim size. - - intros _ p; simpl; - rewrite to_Z_0, Pmult_1_r; split; auto with zarith; apply refl_equal. - - intros n; rewrite inj_S; unfold Z.succ; rewrite Zpower_exp, Z.pow_1_r; auto with zarith. - intros IH Hle p. - assert (F1: 2 ^ Z_of_nat n <= wB); auto with zarith. - assert (0 <= 2 ^ Z_of_nat n); auto with zarith. - case p; simpl. - + intros p1. - generalize (IH F1 p1); case positive_to_int_rec; simpl. - intros n1 i (H1,H2). - rewrite Zpos_xI, H1. - replace (Ļ† (i << 1 + 1)) with (Ļ† i * 2 + 1). - * split; auto with zarith; ring. - * rewrite add_spec, lsl_spec, Zplus_mod_idemp_l, to_Z_1, Z.pow_1_r, Zmod_small; auto. - case (to_Z_bounded i); split; auto with zarith. - + intros p1. - generalize (IH F1 p1); case positive_to_int_rec; simpl. - intros n1 i (H1,H2). - rewrite Zpos_xO, H1. - replace (Ļ† (i << 1)) with (Ļ† i * 2). - * split; auto with zarith; ring. - * rewrite lsl_spec, to_Z_1, Z.pow_1_r, Zmod_small; auto. - case (to_Z_bounded i); split; auto with zarith. - + rewrite to_Z_1; assert (0 < 2^ Z_of_nat n); auto with zarith. -Qed. - -Lemma mulc_WW_spec : - forall x y, Ī¦ ( x *c y ) = Ļ† x * Ļ† y. -Proof. - intros x y;unfold mulc_WW. - generalize (mulc_spec x y);destruct (mulc x y);simpl;intros Heq;rewrite Heq. - case_eq (is_zero i);intros;trivial. - apply is_zero_spec in H;rewrite H, to_Z_0. - case_eq (is_zero i0);intros;trivial. - apply is_zero_spec in H0;rewrite H0, to_Z_0, Zmult_comm;trivial. -Qed. - -Lemma squarec_spec : - forall x, - Ī¦(x *c x) = Ļ† x * Ļ† x. -Proof (fun x => mulc_WW_spec x x). - -Lemma diveucl_spec_aux : forall a b, 0 < Ļ† b -> - let (q,r) := diveucl a b in - Ļ† a = Ļ† q * Ļ† b + Ļ† r /\ - 0 <= Ļ† r < Ļ† b. -Proof. - intros a b H;assert (W:= diveucl_spec a b). - assert (Ļ† b>0) by (auto with zarith). - generalize (Z_div_mod Ļ† a Ļ† b H0). - destruct (diveucl a b);destruct (Z.div_eucl Ļ† a Ļ† b). - inversion W;rewrite Zmult_comm;trivial. -Qed. - -Lemma shift_unshift_mod_2 : forall n p a, 0 <= p <= n -> - ((a * 2 ^ (n - p)) mod (2^n) / 2 ^ (n - p)) mod (2^n) = - a mod 2 ^ p. - Proof. - intros n p a H. - rewrite Zmod_small. - - rewrite Zmod_eq by auto with zarith. - unfold Zminus at 1. - rewrite Zdiv.Z_div_plus_full_l by auto with zarith. - replace (2 ^ n) with (2 ^ (n - p) * 2 ^ p) by (rewrite <- Zpower_exp; [ f_equal | | ]; lia). - rewrite <- Zdiv_Zdiv, Z_div_mult by auto with zarith. - rewrite (Zmult_comm (2^(n-p))), Zmult_assoc. - rewrite Zopp_mult_distr_l. - rewrite Z_div_mult by auto with zarith. - symmetry; apply Zmod_eq; auto with zarith. - - remember (a * 2 ^ (n - p)) as b. - destruct (Z_mod_lt b (2^n)); auto with zarith. - split. - + apply Z_div_pos; auto with zarith. - + apply Zdiv_lt_upper_bound; auto with zarith. - apply Z.lt_le_trans with (2^n); auto with zarith. - generalize (pow2_pos (n - p)); nia. - Qed. - -Lemma div_le_0 : forall p x, 0 <= x -> 0 <= x / 2 ^ p. - Proof. - intros p x Hle;destruct (Z_le_gt_dec 0 p). - - apply Zdiv_le_lower_bound;auto with zarith. - - replace (2^p) with 0. - + destruct x;compute;intro;discriminate. - + destruct p;trivial;discriminate. - Qed. - -Lemma div_lt : forall p x y, 0 <= x < y -> x / 2^p < y. - Proof. - intros p x y H;destruct (Z_le_gt_dec 0 p). - - apply Zdiv_lt_upper_bound;auto with zarith. - apply Z.lt_le_trans with y;auto with zarith. - rewrite <- (Zmult_1_r y);apply Zmult_le_compat;auto with zarith. - - replace (2^p) with 0. - + destruct x;change (0 - (a * 2 ^ (n - p)) mod 2 ^ n / 2 ^ (n - p) = a mod 2 ^ p. -Proof. - intros;rewrite <- (shift_unshift_mod_2 n p a);[ | auto with zarith]. - symmetry;apply Zmod_small. - generalize (a * 2 ^ (n - p));intros w. - generalize (2 ^ (n - p)) (pow2_pos (n - p)); intros x; apply P. - - lia. - - intros hx. - generalize (2 ^ n) (pow2_pos n); intros y; apply P. - + lia. - + intros hy. - elim_div. intros q r. apply P. - * lia. - * elim_div. intros z t. refine (P _ _ _ _ _). - -- lia. - -- intros [ ? [ ht | ] ]; [ | lia ]; subst w. - intros [ ? [ hr | ] ]; [ | lia ]; subst t. - nia. -Qed. - -Lemma pos_mod_spec w p : Ļ†(pos_mod p w) = Ļ†(w) mod (2 ^ Ļ†(p)). -Proof. - simpl. unfold pos_mod_int. - assert (W:=to_Z_bounded p);assert (W':=to_Z_bounded Uint63Axioms.digits);assert (W'' := to_Z_bounded w). - case lebP; intros hle. - 2: { - symmetry; apply Zmod_small. - assert (2 ^ Ļ† Uint63Axioms.digits < 2 ^ Ļ† p); [ apply Zpower_lt_monotone; auto with zarith | ]. - change wB with (2 ^ Ļ† Uint63Axioms.digits) in *; auto with zarith. } - rewrite <- (shift_unshift_mod_3 Ļ† Uint63Axioms.digits Ļ† p Ļ† w) by auto with zarith. - replace (Ļ† Uint63Axioms.digits - Ļ† p) with (Ļ† (Uint63Axioms.digits - p)) by (rewrite sub_spec, Zmod_small; auto with zarith). - rewrite lsr_spec, lsl_spec; reflexivity. -Qed. - -(** {2 Specification and proof} **) -Global Instance int_specs : ZnZ.Specs int_ops := { - spec_to_Z := to_Z_bounded; - spec_of_pos := positive_to_int_spec; - spec_zdigits := refl_equal _; - spec_more_than_1_digit:= refl_equal _; - spec_0 := to_Z_0; - spec_1 := to_Z_1; - spec_m1 := refl_equal _; - spec_compare := compare_spec; - spec_eq0 := is_zero_spec_aux; - spec_opp_c := oppc_spec; - spec_opp := opp_spec; - spec_opp_carry := oppcarry_spec; - spec_succ_c := succc_spec; - spec_add_c := addc_spec; - spec_add_carry_c := addcarryc_spec; - spec_succ := succ_spec; - spec_add := add_spec; - spec_add_carry := addcarry_spec; - spec_pred_c := predc_spec; - spec_sub_c := subc_spec; - spec_sub_carry_c := subcarryc_spec; - spec_pred := pred_spec; - spec_sub := sub_spec; - spec_sub_carry := subcarry_spec; - spec_mul_c := mulc_WW_spec; - spec_mul := mul_spec; - spec_square_c := squarec_spec; - spec_div21 := diveucl_21_spec_aux; - spec_div_gt := fun a b _ => diveucl_spec_aux a b; - spec_div := diveucl_spec_aux; - spec_modulo_gt := fun a b _ _ => mod_spec a b; - spec_modulo := fun a b _ => mod_spec a b; - spec_gcd_gt := fun a b _ => gcd_spec a b; - spec_gcd := gcd_spec; - spec_head00 := head00_spec; - spec_head0 := head0_spec; - spec_tail00 := tail00_spec; - spec_tail0 := tail0_spec; - spec_add_mul_div := addmuldiv_spec; - spec_pos_mod := pos_mod_spec; - spec_is_even := is_even_spec; - spec_sqrt2 := sqrt2_spec; - spec_sqrt := sqrt_spec; - spec_land := land_spec'; - spec_lor := lor_spec'; - spec_lxor := lxor_spec' }. - - - -Module Uint63Cyclic <: CyclicType. - Definition t := int. - Definition ops := int_ops. - Definition specs := int_specs. -End Uint63Cyclic. diff --git a/stdlib/theories/Numbers/Cyclic/Int63/PrimInt63.v b/stdlib/theories/Numbers/Cyclic/Int63/PrimInt63.v deleted file mode 100644 index b8fc0bdab51b..000000000000 --- a/stdlib/theories/Numbers/Cyclic/Int63/PrimInt63.v +++ /dev/null @@ -1 +0,0 @@ -From Corelib Require Export PrimInt63. diff --git a/stdlib/theories/Numbers/Cyclic/Int63/Ring63.v b/stdlib/theories/Numbers/Cyclic/Int63/Ring63.v deleted file mode 100644 index 8c815f907362..000000000000 --- a/stdlib/theories/Numbers/Cyclic/Int63/Ring63.v +++ /dev/null @@ -1,67 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* constr:(false) - | _ => constr:(true) - end. - -Ltac Uint63cst t := - match eval lazy delta [add] in (t + 1)%uint63 with - | add _ _ => constr:(NotConstant) - | _ => constr:(t) - end. - -(** The generic ring structure inferred from the Cyclic structure *) - -Module Uint63ring := CyclicRing Uint63Cyclic. - -(** Unlike in the generic [CyclicRing], we can use Leibniz here. *) - -Lemma Uint63_canonic : forall x y, to_Z x = to_Z y -> x = y. -Proof to_Z_inj. - -Lemma ring_theory_switch_eq : - forall A (R R':A->A->Prop) zero one add mul sub opp, - (forall x y : A, R x y -> R' x y) -> - ring_theory zero one add mul sub opp R -> - ring_theory zero one add mul sub opp R'. -Proof. -intros A R R' zero one add mul sub opp Impl Ring. -constructor; intros; apply Impl; apply Ring. -Qed. - -Lemma Uint63Ring : ring_theory 0 1 add mul sub opp Logic.eq. -Proof. -exact (ring_theory_switch_eq _ _ _ _ _ _ _ _ _ Uint63_canonic Uint63ring.CyclicRing). -Qed. - -Lemma eq31_correct : forall x y, eqb x y = true -> x=y. -Proof. now apply eqb_spec. Qed. - -Add Ring Uint63Ring : Uint63Ring - (decidable eq31_correct, - constants [Uint63cst]). - -Section TestRing. -Let test : forall x y, 1 + x*y + x*x + 1 = 1*1 + 1 + y*x + 1*x*x. -intros. ring. -Defined. -End TestRing. diff --git a/stdlib/theories/Numbers/Cyclic/Int63/Sint63.v b/stdlib/theories/Numbers/Cyclic/Int63/Sint63.v deleted file mode 100644 index 25588758415a..000000000000 --- a/stdlib/theories/Numbers/Cyclic/Int63/Sint63.v +++ /dev/null @@ -1,440 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* if (p if (n <=? 4611686018427387904)%uint63 - then Some ((n - 1) lxor max_int)%uint63 else None - end. -Number Notation int parser printer : sint63_scope. - - -Module Import Sint63NotationsInternalA. -Delimit Scope sint63_scope with sint63. -Bind Scope sint63_scope with int. -End Sint63NotationsInternalA. - -Module Import Sint63NotationsInternalB. -Infix "<<" := PrimInt63.lsl (at level 30, no associativity) : sint63_scope. -(* TODO do we want >> to be asr or lsr? And is there a notation for the other one? *) -Infix ">>" := asr (at level 30, no associativity) : sint63_scope. -Infix "land" := PrimInt63.land (at level 40, left associativity) : sint63_scope. -Infix "lor" := PrimInt63.lor (at level 40, left associativity) : sint63_scope. -Infix "lxor" := PrimInt63.lxor (at level 40, left associativity) : sint63_scope. -Infix "+" := PrimInt63.add : sint63_scope. -Infix "-" := PrimInt63.sub : sint63_scope. -Infix "*" := PrimInt63.mul : sint63_scope. -Infix "/" := divs : sint63_scope. -Infix "mod" := mods (at level 40, no associativity) : sint63_scope. -Infix "=?" := PrimInt63.eqb (at level 70, no associativity) : sint63_scope. -Infix " lia | intros _]. - case (ltbP max_int); [> intros _ | now intros H; exfalso; apply H]. - rewrite opp_spec. - rewrite Z_mod_nz_opp_full by easy. - rewrite Z.mod_small by apply Uint63.to_Z_bounded. - case ltbP. - - intros ltxmin; split. - + now transitivity 0%Z; [>| now apply Uint63.to_Z_bounded]. - + replace (Ļ† min_int%uint63) with (Ļ† max_int%uint63 + 1)%Z in ltxmin. - * lia. - * now compute. - - rewrite Z.nlt_ge; intros leminx. - rewrite opp_spec. - rewrite Z_mod_nz_opp_full. - + rewrite Z.mod_small by apply Uint63.to_Z_bounded. - split. - * rewrite <- Z.opp_le_mono. - now rewrite <- Z.sub_le_mono_l. - * transitivity 0%Z; [>| now apply Uint63.to_Z_bounded]. - rewrite Z.opp_nonpos_nonneg. - apply Zle_minus_le_0. - apply Z.lt_le_incl. - now apply Uint63.to_Z_bounded. - + rewrite Z.mod_small by apply Uint63.to_Z_bounded. - now intros eqx0; rewrite eqx0 in leminx. -Qed. - -Lemma of_to_Z : forall x, of_Z (to_Z x) = x. -Proof. - unfold to_Z, of_Z. - intros x. - generalize (Uint63.to_Z_bounded x). - case ltbP. - - intros ltxmin [leq0x _]. - generalize (Uint63Axioms.of_to_Z x). - destruct (Ļ† x%uint63). - + now intros <-. - + now intros <-; unfold Uint63Axioms.of_Z. - + now intros _. - - intros nltxmin leq0xltwB. - fold (- x)%sint63; rewrite (opp_spec x). - rewrite Z_mod_nz_opp_full. - + rewrite Zmod_small by easy. - destruct (wB - Ļ† x%uint63) eqn: iswbmx. - * lia. - * simpl. - apply to_Z_inj. - rewrite opp_spec. - generalize (of_Z_spec (Z.pos p)). - simpl Uint63Axioms.of_Z; intros ->. - rewrite <- iswbmx. - rewrite <- Z.sub_0_l. - rewrite <- (Zmod_0_l wB). - rewrite <- Zminus_mod. - replace (0 - _) with (Ļ† x%uint63 - wB) by ring. - rewrite <- Zminus_mod_idemp_r. - rewrite Z_mod_same_full. - rewrite Z.sub_0_r. - now rewrite Z.mod_small. - * lia. - + rewrite Z.mod_small by easy. - intros eqx0; revert nltxmin; rewrite eqx0. - now compute. -Qed. - -Lemma to_Z_inj (x y : int) : to_Z x = to_Z y -> x = y. -Proof. exact (fun e => can_inj of_to_Z e). Qed. - -Lemma to_Z_mod_Uint63to_Z (x : int) : to_Z x mod wB = Ļ† x%uint63. -Proof. - unfold to_Z. - case ltbP; [> now rewrite Z.mod_small by now apply Uint63.to_Z_bounded |]. - rewrite Z.nlt_ge; intros gexmin. - rewrite opp_to_Z_opp; rewrite Z.mod_small by now apply Uint63.to_Z_bounded. - - easy. - - now intros neqx0; rewrite neqx0 in gexmin. -Qed. - - -(** Centered modulo *) -Definition cmod (x d : Z) : Z := - (x + d / 2) mod d - (d / 2). - -Lemma cmod_mod (x d : Z) : - cmod (x mod d) d = cmod x d. -Proof. - now unfold cmod; rewrite Zplus_mod_idemp_l. -Qed. - -Lemma cmod_small (x d : Z) : - - (d / 2) <= x < d / 2 -> cmod x d = x. -Proof. - intros bound. - unfold cmod. - rewrite Zmod_small; [> lia |]. - split; [> lia |]. - rewrite Z.lt_add_lt_sub_r. - apply (Z.lt_le_trans _ (d / 2)); [> easy |]. - now rewrite <- Z.le_add_le_sub_r, Z.add_diag, Z.mul_div_le. -Qed. - -Lemma to_Z_cmodwB (x : int) : - to_Z x = cmod (Ļ† x%uint63) wB. -Proof. - unfold to_Z, cmod. - case ltbP; change Ļ† (min_int)%uint63 with (wB / 2). - - intros ltxmin. - rewrite Z.mod_small; [> lia |]. - split. - + now apply Z.add_nonneg_nonneg; try apply Uint63.to_Z_bounded. - + change wB with (wB / 2 + wB / 2) at 2; lia. - - rewrite Z.nlt_ge; intros gexmin. - rewrite Uint63.opp_spec. - rewrite Z_mod_nz_opp_full. - + rewrite Z.mod_small by apply Uint63.to_Z_bounded. - rewrite <- (Z_mod_plus_full _ (-1)). - change (-1 * wB) with (- (wB / 2) - wB / 2). - rewrite <- Z.add_assoc, Zplus_minus. - rewrite Z.mod_small. - * change wB with (wB / 2 + wB / 2) at 1; lia. - * split; [> lia |]. - apply Z.lt_sub_lt_add_r. - transitivity wB; [>| easy]. - now apply Uint63.to_Z_bounded. - + rewrite Z.mod_small by now apply Uint63.to_Z_bounded. - now intros not0; rewrite not0 in gexmin. -Qed. - -Lemma of_Z_spec (z : Z) : to_Z (of_Z z) = cmod z wB. -Proof. now rewrite to_Z_cmodwB, Uint63.of_Z_spec, cmod_mod. Qed. - -Lemma of_Z_cmod (z : Z) : of_Z (cmod z wB) = of_Z z. -Proof. now rewrite <- of_Z_spec, of_to_Z. Qed. - -Lemma is_int (z : Z) : - to_Z min_int <= z <= to_Z max_int -> - z = to_Z (of_Z z). -Proof. - rewrite to_Z_min, to_Z_max. - intros bound; rewrite of_Z_spec, cmod_small; lia. -Qed. - -Lemma of_pos_spec (p : positive) : - to_Z (of_pos p) = cmod (Zpos p) wB. -Proof. rewrite <- of_Z_spec; simpl; reflexivity. Qed. - -(** Specification of operations that coincide on signed and unsigned ints *) - -Lemma add_spec (x y : int) : - to_Z (x + y)%sint63 = cmod (to_Z x + to_Z y) wB. -Proof. - rewrite to_Z_cmodwB, Uint63Axioms.add_spec. - rewrite <- 2!to_Z_mod_Uint63to_Z, <- Z.add_mod by easy. - now rewrite cmod_mod. -Qed. - -Lemma sub_spec (x y : int) : - to_Z (x - y)%sint63 = cmod (to_Z x - to_Z y) wB. -Proof. - rewrite to_Z_cmodwB, Uint63Axioms.sub_spec. - rewrite <- 2!to_Z_mod_Uint63to_Z, <- Zminus_mod by easy. - now rewrite cmod_mod. -Qed. - -Lemma mul_spec (x y : int) : - to_Z (x * y)%sint63 = cmod (to_Z x * to_Z y) wB. -Proof. - rewrite to_Z_cmodwB, Uint63Axioms.mul_spec. - rewrite <- 2!to_Z_mod_Uint63to_Z, <- Zmult_mod by easy. - now rewrite cmod_mod. -Qed. - -Lemma succ_spec (x : int) : - to_Z (succ x)%sint63 = cmod (to_Z x + 1) wB. -Proof. now unfold succ; rewrite add_spec. Qed. - -Lemma pred_spec (x : int) : - to_Z (pred x)%sint63 = cmod (to_Z x - 1) wB. -Proof. now unfold pred; rewrite sub_spec. Qed. - -Lemma opp_spec (x : int) : - to_Z (- x)%sint63 = cmod (- to_Z x) wB. -Proof. - rewrite to_Z_cmodwB, Uint63.opp_spec. - rewrite <- Z.sub_0_l, <- to_Z_mod_Uint63to_Z, Zminus_mod_idemp_r. - now rewrite cmod_mod. -Qed. - -(** Behaviour when there is no under or overflow *) - -Lemma to_Z_add (x y : int) : - to_Z min_int <= to_Z x + to_Z y <= to_Z max_int -> - to_Z (x + y) = to_Z x + to_Z y. -Proof. - rewrite to_Z_min, to_Z_max; intros bound. - now rewrite add_spec, cmod_small; [>| lia]. -Qed. - -Lemma to_Z_sub (x y : int) : - to_Z min_int <= to_Z x - to_Z y <= to_Z max_int -> - to_Z (x - y) = to_Z x - to_Z y. -Proof. - rewrite to_Z_min, to_Z_max; intros bound. - now rewrite sub_spec, cmod_small; [>| lia]. -Qed. - -Lemma to_Z_mul (x y : int) : - to_Z min_int <= to_Z x * to_Z y <= to_Z max_int -> - to_Z (x * y) = to_Z x * to_Z y. -Proof. - rewrite to_Z_min, to_Z_max; intros bound. - now rewrite mul_spec, cmod_small; [>| lia]. -Qed. - -Lemma to_Z_succ (x : int) : - x <> max_int -> to_Z (succ x) = to_Z x + 1. -Proof. - intros neq_x_max. - rewrite succ_spec, cmod_small; [> easy |]. - assert (to_Z x <> to_Z max_int) by now intros ?; apply neq_x_max, to_Z_inj. - rewrite <- to_Z_min; change (wB / 2) with (to_Z max_int + 1). - generalize (to_Z_bounded x); lia. -Qed. - -Lemma to_Z_pred (x : int) : - x <> min_int -> to_Z (pred x) = to_Z x - 1. -Proof. - intros neq_x_min. - rewrite pred_spec, cmod_small; [> easy |]. - assert (to_Z x <> to_Z min_int) by now intros ?; apply neq_x_min, to_Z_inj. - rewrite <- to_Z_min; change (wB / 2) with (to_Z max_int + 1). - generalize (to_Z_bounded x); lia. -Qed. - -Lemma to_Z_opp (x : int) : - x <> min_int -> to_Z (- x) = - to_Z x. -Proof. - intros neq_x_min. - rewrite opp_spec, cmod_small; [> easy |]. - rewrite <- to_Z_min; change (wB / 2) with (to_Z max_int + 1). - pose proof (to_Z_bounded x) as bound. - split. - - now rewrite Z.opp_le_mono, Z.opp_involutive; transitivity (to_Z max_int). - - rewrite Z.opp_lt_mono, Z.opp_involutive. - assert (to_Z x <> to_Z min_int) by now intros ?; apply neq_x_min, to_Z_inj. - change (- (to_Z max_int + 1)) with (to_Z min_int); lia. -Qed. - -(** Relationship with of_Z *) - -Lemma add_of_Z (x y : int) : - (x + y)%sint63 = of_Z (to_Z x + to_Z y). -Proof. now rewrite <- of_Z_cmod, <- add_spec, of_to_Z. Qed. - -Lemma sub_of_Z (x y : int) : - (x - y)%sint63 = of_Z (to_Z x - to_Z y). -Proof. now rewrite <- of_Z_cmod, <- sub_spec, of_to_Z. Qed. - -Lemma mul_of_Z (x y : int) : - (x * y)%sint63 = of_Z (to_Z x * to_Z y). -Proof. now rewrite <- of_Z_cmod, <- mul_spec, of_to_Z. Qed. - -Lemma succ_of_Z (x : int) : - (succ x)%sint63 = of_Z (to_Z x + 1). -Proof. now rewrite <- of_Z_cmod, <- succ_spec, of_to_Z. Qed. - -Lemma pred_of_Z (x : int) : - (pred x)%sint63 = of_Z (to_Z x - 1). -Proof. now rewrite <- of_Z_cmod, <- pred_spec, of_to_Z. Qed. - -Lemma opp_of_Z (x : int) : - (- x)%sint63 = of_Z (- to_Z x). -Proof. now rewrite <- of_Z_cmod, <- opp_spec, of_to_Z. Qed. - -(** Comparison *) -Import Bool. - -Lemma eqbP x y : reflect (to_Z x = to_Z y) (x =? y)%sint63. -Proof. - apply iff_reflect; rewrite Uint63.eqb_spec. - now split; [> apply to_Z_inj | apply f_equal]. -Qed. - -Lemma ltbP x y : reflect (to_Z x < to_Z y) (x min_int -> to_Z (abs x) = Z.abs (to_Z x). -Proof. - intros neq_x_min. - unfold abs; case lebP. - - now intros leq_0_x; rewrite Z.abs_eq. - - rewrite to_Z_opp by easy. - intros nleq_0_x; rewrite Z.abs_neq; [> easy |]. - change 0 with (to_Z 0); lia. -Qed. - -Remark abs_min_int : abs min_int = min_int. -Proof. easy. Qed. - -Lemma abs_of_Z (x : int) : - abs x = of_Z (Z.abs (to_Z x)). -Proof. now rewrite <- of_Z_cmod, <- abs_spec, of_to_Z. Qed. - -(** ASR *) -Lemma asr_0 (i : int) : (0 >> i)%sint63 = 0%sint63. -Proof. now apply to_Z_inj; rewrite asr_spec. Qed. - -Lemma asr_0_r (i : int) : (i >> 0)%sint63 = i. -Proof. now apply to_Z_inj; rewrite asr_spec, Zdiv_1_r. Qed. - -Lemma asr_neg_r (i n : int) : to_Z n < 0 -> (i >> n)%sint63 = 0%sint63. -Proof. - intros ltn0. - apply to_Z_inj. - rewrite asr_spec, Z.pow_neg_r by assumption. - now rewrite Zdiv_0_r. -Qed. - -Lemma asr_1 (n : int) : (1 >> n)%sint63 = (n =? 0)%sint63. -Proof. - apply to_Z_inj; rewrite asr_spec. - case eqbP; [> now intros -> | intros neqn0]. - case (lebP 0 n). - - intros le0n. - apply Z.div_1_l; apply Z.pow_gt_1; [> easy |]. - rewrite to_Z_0 in *; lia. - - rewrite Z.nle_gt; intros ltn0. - now rewrite Z.pow_neg_r. -Qed. - - -Notation asr := asr (only parsing). -Notation div := divs (only parsing). -Notation rem := mods (only parsing). -Notation ltb := ltsb (only parsing). -Notation leb := lesb (only parsing). -Notation compare := compares (only parsing). - -Module Export Sint63Notations. - Export Sint63NotationsInternalA. - Export Sint63NotationsInternalB. -End Sint63Notations. diff --git a/stdlib/theories/Numbers/Cyclic/Int63/Sint63Axioms.v b/stdlib/theories/Numbers/Cyclic/Int63/Sint63Axioms.v deleted file mode 100644 index ebe1a32d9d85..000000000000 --- a/stdlib/theories/Numbers/Cyclic/Int63/Sint63Axioms.v +++ /dev/null @@ -1 +0,0 @@ -From Corelib Require Export Sint63Axioms. diff --git a/stdlib/theories/Numbers/Cyclic/Int63/Uint63.v b/stdlib/theories/Numbers/Cyclic/Int63/Uint63.v deleted file mode 100644 index de3b4533704d..000000000000 --- a/stdlib/theories/Numbers/Cyclic/Int63/Uint63.v +++ /dev/null @@ -1,1855 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* >" := lsr (at level 30, no associativity) : uint63_scope. -Infix "land" := land (at level 40, left associativity) : uint63_scope. -Infix "lor" := lor (at level 40, left associativity) : uint63_scope. -Infix "lxor" := lxor (at level 40, left associativity) : uint63_scope. -Infix "+" := add : uint63_scope. -Infix "-" := sub : uint63_scope. -Infix "*" := mul : uint63_scope. -Infix "/" := div : uint63_scope. -Infix "mod" := mod (at level 40, no associativity) : uint63_scope. -Infix "=?" := eqb (at level 70, no associativity) : uint63_scope. -Infix "> 1)%uint63). - rewrite Z.pow_succ_r; auto with zarith. - destruct (is_even x). - + rewrite Zdouble_mult; auto with zarith. - + rewrite Zdouble_plus_one_mult; auto with zarith. -Qed. - -Corollary to_Z_bounded : forall x, (0 <= Ļ† x < wB)%Z. -Proof. apply to_Z_rec_bounded. Qed. - - -(* =================================================== *) -Local Open Scope Z_scope. -(* General arithmetic results *) - -Theorem Zmod_distr: forall a b r t, 0 <= a <= b -> 0 <= r -> 0 <= t < 2 ^a -> - (2 ^a * r + t) mod (2 ^ b) = (2 ^a * r) mod (2 ^ b) + t. -Proof. - intros a b r t ? ? ?. - replace (2^b) with (2^a * 2^(b-a)) by (rewrite <-Zpower_exp; [f_equal| |]; lia). - assert (0 < 2 ^ (b - a)) by (apply Z.pow_pos_nonneg; lia). - rewrite Z.add_mul_mod_distr_l, <- Z.mul_mod_distr_l; lia. -Qed. - -(* Results about pow2 *) -Lemma pow2_pos n : 0 <= n ā†’ 2 ^ n > 0. -Proof. intros h; apply Z.lt_gt, Zpower_gt_0; lia. Qed. - -Lemma pow2_nz n : 0 <= n ā†’ 2 ^ n ā‰  0. -Proof. intros h; generalize (pow2_pos _ h); lia. Qed. - -#[global] -Hint Resolve pow2_pos pow2_nz : zarith. - -(* =================================================== *) - -(** Trivial lemmas without axiom *) - -Lemma wB_diff_0 : wB <> 0. -Proof. exact (fun x => let 'eq_refl := x in idProp). Qed. - -Lemma wB_pos : 0 < wB. -Proof. reflexivity. Qed. - -Lemma to_Z_0 : Ļ† 0 = 0. -Proof. reflexivity. Qed. - -Lemma to_Z_1 : Ļ† 1 = 1. -Proof. reflexivity. Qed. - -(* Notations *) -Local Open Scope Z_scope. - -Local Notation "[+| c |]" := - (interp_carry 1 wB to_Z c) (at level 0, c at level 99) : uint63_scope. - -Local Notation "[-| c |]" := - (interp_carry (-1) wB to_Z c) (at level 0, c at level 99) : uint63_scope. - -Lemma can_inj {rT aT} {f: aT -> rT} {g: rT -> aT} (K: forall a, g (f a) = a) {a a'} (e: f a = f a') : a = a'. -Proof. generalize (K a) (K a'). congruence. Qed. - -Lemma to_Z_inj x y : Ļ† x = Ļ† y ā†’ x = y. -Proof. exact (Ī» e, can_inj of_to_Z e). Qed. - -(** I should add the definition (like for compare) *) -Notation head0 := head0 (only parsing). -Notation tail0 := tail0 (only parsing). - -(** Square root functions using newton iteration **) -Local Open Scope uint63_scope. - -Definition sqrt_step (rec: int -> int -> int) (i j: int) := - let quo := i / j in - if quo > 1) - else j. - -Definition iter_sqrt := - Eval lazy beta delta [sqrt_step] in - fix iter_sqrt (n: nat) (rec: int -> int -> int) - (i j: int) {struct n} : int := - sqrt_step - (fun i j => match n with - O => rec i j - | S n => (iter_sqrt n (iter_sqrt n rec)) i j - end) i j. - -Definition sqrt i := - match compare 1 i with - Gt => 0 - | Eq => 1 - | Lt => iter_sqrt size (fun i j => j) i (i >> 1) - end. - -Definition high_bit := 1 << (digits - 1). - -Definition sqrt2_step (rec: int -> int -> int -> int) - (ih il j: int) := - if ih rec ih il (m1 >> 1) - | C1 m1 => rec ih il ((m1 >> 1) + high_bit) - end - else j - else j. - -Definition iter2_sqrt := - Eval lazy beta delta [sqrt2_step] in - fix iter2_sqrt (n: nat) - (rec: int -> int -> int -> int) - (ih il j: int) {struct n} : int := - sqrt2_step - (fun ih il j => - match n with - | O => rec ih il j - | S n => (iter2_sqrt n (iter2_sqrt n rec)) ih il j - end) ih il j. - -Definition sqrt2 ih il := - let s := iter2_sqrt size (fun ih il j => j) ih il max_int in - let (ih1, il1) := mulc s s in - match il -c il1 with - | C0 il2 => - if ih1 - if ih1 1 - | S p => if j =? 0 then i else gcd_rec p j (i mod j) - end. - -Definition gcd := gcd_rec (2*size). - -(** equality *) -Lemma eqb_complete : forall x y, x = y -> (x =? y) = true. -Proof. - now intros x y H; rewrite H, Uint63Axioms.eqb_refl. -Qed. - -Lemma eqb_spec : forall x y, (x =? y) = true <-> x = y. -Proof. - split;auto using eqb_correct, eqb_complete. -Qed. - -Lemma eqb_false_spec : forall x y, (x =? y) = false <-> x <> y. -Proof. - intros;rewrite <- not_true_iff_false, eqb_spec;split;trivial. -Qed. - -Lemma eqb_false_complete : forall x y, x <> y -> (x =? y) = false. -Proof. - intros x y;rewrite eqb_false_spec;trivial. -Qed. - -Lemma eqb_false_correct : forall x y, (x =? y) = false -> x <> y. -Proof. - intros x y;rewrite eqb_false_spec;trivial. -Qed. - -Definition eqs (i j : int) : {i = j} + { i <> j } := - (if i =? j as b return ((b = true -> i = j) -> (b = false -> i <> j) -> {i=j} + {i <> j} ) - then fun (Heq : true = true -> i = j) _ => left _ (Heq (eq_refl true)) - else fun _ (Hdiff : false = false -> i <> j) => right _ (Hdiff (eq_refl false))) - (eqb_correct i j) - (eqb_false_correct i j). - -Lemma eq_dec : forall i j:int, i = j \/ i <> j. -Proof. - intros i j;destruct (eqs i j);auto. -Qed. - -(* Extra function on equality *) - -Definition cast i j := - (if i =? j as b return ((b = true -> i = j) -> option (forall P : int -> Type, P i -> P j)) - then fun Heq : true = true -> i = j => - Some - (fun (P : int -> Type) (Hi : P i) => - match Heq (eq_refl true) in (_ = y) return (P y) with - | eq_refl => Hi - end) - else fun _ : false = true -> i = j => None) (eqb_correct i j). - -Lemma cast_refl : forall i, cast i i = Some (fun P H => H). -Proof. - unfold cast;intros i. - generalize (eqb_correct i i). - rewrite Uint63Axioms.eqb_refl;intros e. - rewrite (Eqdep_dec.eq_proofs_unicity eq_dec (e (eq_refl true)) (eq_refl i));trivial. -Qed. - -Lemma cast_diff : forall i j, i =? j = false -> cast i j = None. -Proof. - intros i j H;unfold cast;intros; generalize (eqb_correct i j). - rewrite H;trivial. -Qed. - -Definition eqo i j := - (if i =? j as b return ((b = true -> i = j) -> option (i=j)) - then fun Heq : true = true -> i = j => - Some (Heq (eq_refl true)) - else fun _ : false = true -> i = j => None) (eqb_correct i j). - -Lemma eqo_refl : forall i, eqo i i = Some (eq_refl i). -Proof. - unfold eqo;intros i. - generalize (eqb_correct i i). - rewrite Uint63Axioms.eqb_refl;intros e. - rewrite (Eqdep_dec.eq_proofs_unicity eq_dec (e (eq_refl true)) (eq_refl i));trivial. -Qed. - -Lemma eqo_diff : forall i j, i =? j = false -> eqo i j = None. -Proof. - unfold eqo;intros i j H; generalize (eqb_correct i j). - rewrite H;trivial. -Qed. - -(** Comparison *) - -Lemma eqbP x y : reflect (Ļ† x = Ļ† y ) (x =? y). -Proof. apply iff_reflect; rewrite eqb_spec; split; [ apply to_Z_inj | apply f_equal ]. Qed. - -Lemma ltbP x y : reflect (Ļ† x < Ļ† y )%Z (x x = 0%uint63. -Proof. apply eqb_spec. Qed. - -Lemma diveucl_spec x y : - let (q,r) := diveucl x y in - (Ļ† q , Ļ† r ) = Z.div_eucl Ļ† x Ļ† y . -Proof. - rewrite diveucl_def_spec; unfold diveucl_def; rewrite div_spec, mod_spec; unfold Z.div, Z.modulo. - destruct (Z.div_eucl Ļ† x Ļ† y ); trivial. -Qed. - -Local Open Scope Z_scope. -(** Addition *) -Lemma addc_spec x y : [+| x +c y |] = Ļ† x + Ļ† y . -Proof. - rewrite addc_def_spec; unfold addc_def, interp_carry. - pose proof (to_Z_bounded x); pose proof (to_Z_bounded y). - case ltbP; rewrite add_spec. - - case (Z_lt_ge_dec (Ļ† x + Ļ† y ) wB). - + intros k; rewrite Zmod_small; lia. - + intros hge; rewrite <- (Zmod_unique _ _ 1 (Ļ† x + Ļ† y - wB)); lia. - - case (Z_lt_ge_dec (Ļ† x + Ļ† y ) wB). - + intros k; rewrite Zmod_small; lia. - + intros hge; rewrite <- (Zmod_unique _ _ 1 (Ļ† x + Ļ† y - wB)); lia. -Qed. - -Lemma succ_spec x : Ļ† (succ x) = (Ļ† x + 1) mod wB. -Proof. apply add_spec. Qed. - -Lemma succc_spec x : [+| succc x |] = Ļ† x + 1. -Proof. apply addc_spec. Qed. - -Lemma addcarry_spec x y : Ļ† (addcarry x y) = (Ļ† x + Ļ† y + 1) mod wB. -Proof. unfold addcarry; rewrite -> !add_spec, Zplus_mod_idemp_l; trivial. Qed. - -Lemma addcarryc_spec x y : [+| addcarryc x y |] = Ļ† x + Ļ† y + 1. -Proof. - rewrite addcarryc_def_spec; unfold addcarryc_def, interp_carry. - pose proof (to_Z_bounded x); pose proof (to_Z_bounded y). - case lebP; rewrite addcarry_spec. - - case (Z_lt_ge_dec (Ļ† x + Ļ† y + 1) wB). - + intros hlt; rewrite Zmod_small; lia. - + intros hge; rewrite <- (Zmod_unique _ _ 1 (Ļ† x + Ļ† y + 1 - wB)); lia. - - case (Z_lt_ge_dec (Ļ† x + Ļ† y + 1) wB). - + intros hlt; rewrite Zmod_small; lia. - + intros hge; rewrite <- (Zmod_unique _ _ 1 (Ļ† x + Ļ† y + 1 - wB)); lia. -Qed. - -(** Subtraction *) -Lemma subc_spec x y : [-| x -c y |] = Ļ† x - Ļ† y . -Proof. - rewrite subc_def_spec; unfold subc_def; unfold interp_carry. - pose proof (to_Z_bounded x); pose proof (to_Z_bounded y). - case lebP. - - intros hle; rewrite sub_spec, Z.mod_small; lia. - - intros hgt; rewrite sub_spec, <- (Zmod_unique _ wB (-1) (Ļ† x - Ļ† y + wB)); lia. -Qed. - -Lemma pred_spec x : Ļ† (pred x) = (Ļ† x - 1) mod wB. -Proof. apply sub_spec. Qed. - -Lemma predc_spec x : [-| predc x |] = Ļ† x - 1. -Proof. apply subc_spec. Qed. - -Lemma oppc_spec x : [-| oppc x |] = - Ļ† x . -Proof. unfold oppc; rewrite -> subc_spec, to_Z_0; trivial. Qed. - -Lemma opp_spec x : Ļ† (- x) = - Ļ† x mod wB. -Proof. unfold opp; rewrite -> sub_spec, to_Z_0; trivial. Qed. - -Lemma oppcarry_spec x : Ļ† (oppcarry x) = wB - Ļ† x - 1. -Proof. - unfold oppcarry; rewrite sub_spec. - rewrite <- Zminus_plus_distr, Zplus_comm, Zminus_plus_distr. - apply Zmod_small. - generalize (to_Z_bounded x); auto with zarith. -Qed. - -Lemma subcarry_spec x y : Ļ† (subcarry x y) = (Ļ† x - Ļ† y - 1) mod wB. -Proof. unfold subcarry; rewrite !sub_spec, Zminus_mod_idemp_l; trivial. Qed. - -Lemma subcarryc_spec x y : [-| subcarryc x y |] = Ļ† x - Ļ† y - 1. -Proof. - rewrite subcarryc_def_spec; unfold subcarryc_def, interp_carry; fold (subcarry x y). - pose proof (to_Z_bounded x); pose proof (to_Z_bounded y). - case ltbP; rewrite subcarry_spec. - - intros hlt; rewrite Zmod_small; lia. - - intros hge; rewrite <- (Zmod_unique _ _ (-1) (Ļ† x - Ļ† y - 1 + wB)); lia. -Qed. - -(** GCD *) -Lemma to_Z_gcd : forall i j, Ļ† (gcd i j) = Zgcdn (2 * size) (Ļ† j) (Ļ† i). -Proof. - unfold gcd. - elim (2*size)%nat. - - reflexivity. - - intros n ih i j; simpl. - pose proof (to_Z_bounded j) as hj; pose proof (to_Z_bounded i). - case eqbP; rewrite to_Z_0. - + intros ->; rewrite Z.abs_eq; lia. - + intros hne; rewrite ih; clear ih. - rewrite <- mod_spec. - revert hj hne; case Ļ† j ; intros; lia. -Qed. - -Lemma gcd_spec a b : Zis_gcd (Ļ† a) (Ļ† b) (Ļ† (gcd a b)). -Proof. - rewrite to_Z_gcd. - apply Zis_gcd_sym. - apply Zgcdn_is_gcd. - unfold Zgcd_bound. - generalize (to_Z_bounded b). - destruct Ļ† b as [|p|p]. - - unfold size; auto with zarith. - - intros (_,H). - cut (Psize p <= size)%nat; [ lia | rewrite <- Zpower2_Psize; auto]. - - intros (H,_); compute in H; elim H; auto. -Qed. - -(** Head0, Tail0 *) -Lemma head00_spec x : Ļ† x = 0 -> Ļ† (head0 x) = Ļ† digits . -Proof. now intros h; rewrite (to_Z_inj _ 0 h). Qed. - -Lemma tail00_spec x : Ļ† x = 0 -> Ļ† (tail0 x) = Ļ† digits. -Proof. now intros h; rewrite (to_Z_inj _ 0 h). Qed. - -Infix "ā‰”" := (eqm wB) (at level 70, no associativity) : uint63_scope. - -Lemma eqm_mod x y : x mod wB ā‰” y mod wB ā†’ x ā‰” y. -Proof. - intros h. - eapply (eqm_trans). - - apply eqm_sym; apply Zmod_eqm. - - apply (eqm_trans _ _ _ _ h). - apply Zmod_eqm. -Qed. - -Lemma eqm_sub x y : x ā‰” y ā†’ x - y ā‰” 0. -Proof. intros h; unfold eqm; rewrite Zminus_mod, h, Z.sub_diag; reflexivity. Qed. - -Lemma eqmE x y : x ā‰” y ā†’ āˆƒ k, x - y = k * wB. -Proof. - intros h. - exact (Zmod_divide (x - y) wB (Ī» e, let 'eq_refl := e in I) (eqm_sub _ _ h)). -Qed. - -Lemma eqm_subE x y : x ā‰” y ā†” x - y ā‰” 0. -Proof. - split. - - apply eqm_sub. - - intros h; case (eqmE _ _ h); clear h; intros q h. - assert (y = x - q * wB) by lia. - clear h; subst y. - unfold eqm; rewrite Zminus_mod, Z_mod_mult, Z.sub_0_r, Zmod_mod; reflexivity. -Qed. - -Lemma int_eqm x y : x = y ā†’ Ļ† x ā‰” Ļ† y. -Proof. unfold eqm; intros ->; reflexivity. Qed. - -Lemma eqmI x y : Ļ† x ā‰” Ļ† y ā†’ x = y. -Proof. - unfold eqm. - repeat rewrite Zmod_small by apply to_Z_bounded. - apply to_Z_inj. -Qed. - -(* ADD *) -Lemma add_assoc x y z: (x + (y + z) = (x + y) + z)%uint63. -Proof. - apply to_Z_inj; rewrite !add_spec. - rewrite -> Zplus_mod_idemp_l, Zplus_mod_idemp_r, Zplus_assoc; auto. -Qed. - -Lemma add_comm x y: (x + y = y + x)%uint63. -Proof. - apply to_Z_inj; rewrite -> !add_spec, Zplus_comm; auto. -Qed. - -Lemma add_le_r m n: - if (n <=? m + n)%uint63 then (Ļ† m + Ļ† n < wB)%Z else (wB <= Ļ† m + Ļ† n)%Z. -Proof. - case (to_Z_bounded m); intros H1m H2m. - case (to_Z_bounded n); intros H1n H2n. - case (Zle_or_lt wB (Ļ† m + Ļ† n)); intros H. - - assert (H1: (Ļ† (m + n) = Ļ† m + Ļ† n - wB)%Z). { - rewrite add_spec. - replace ((Ļ† m + Ļ† n) mod wB)%Z with ((((Ļ† m + Ļ† n) - wB) + wB) mod wB)%Z. - - rewrite -> Zplus_mod, Z_mod_same_full, Zplus_0_r, !Zmod_small; auto with zarith. - rewrite !Zmod_small; auto with zarith. - - apply (f_equal2 Z.modulo); auto with zarith. - } - case_eq (n <=? m + n)%uint63; auto. - rewrite leb_spec, H1; auto with zarith. - - assert (H1: (Ļ† (m + n) = Ļ† m + Ļ† n)%Z). - { rewrite add_spec, Zmod_small; auto with zarith. } - replace (n <=? m + n)%uint63 with true; auto. - apply sym_equal; rewrite leb_spec, H1; auto with zarith. -Qed. - -Lemma add_cancel_l x y z : (x + y = x + z)%uint63 -> y = z. -Proof. - intros h; apply int_eqm in h; rewrite !add_spec in h; apply eqm_mod, eqm_sub in h. - replace (_ + _ - _) with (Ļ†(y) - Ļ†(z)) in h by lia. - rewrite <- eqm_subE in h. - apply eqmI, h. -Qed. - -Lemma add_cancel_r x y z : (y + x = z + x)%uint63 -> y = z. -Proof. - rewrite !(fun t => add_comm t x); intros Hl; apply (add_cancel_l x); auto. -Qed. - -Coercion b2i (b: bool) : int := if b then 1%uint63 else 0%uint63. - -(* LSR *) -Lemma lsr0 i : 0 >> i = 0%uint63. -Proof. apply to_Z_inj; rewrite lsr_spec; reflexivity. Qed. - -Lemma lsr_0_r i: i >> 0 = i. -Proof. apply to_Z_inj; rewrite lsr_spec, Zdiv_1_r; exact eq_refl. Qed. - -Lemma lsr_1 n : 1 >> n = (n =? 0)%uint63. -Proof. - case eqbP. - - intros h; rewrite (to_Z_inj _ _ h), lsr_0_r; reflexivity. - - intros Hn. - assert (H1n : (1 >> n = 0)%uint63); auto. - apply to_Z_inj; rewrite lsr_spec. - apply Zdiv_small; rewrite to_Z_1; split; auto with zarith. - change 1%Z with (2^0)%Z. - apply Zpower_lt_monotone; split; auto with zarith. - rewrite to_Z_0 in Hn. - generalize (to_Z_bounded n). - lia. -Qed. - -Lemma lsr_add i m n: ((i >> m) >> n = if n <=? m + n then i >> (m + n) else 0)%uint63. -Proof. - case (to_Z_bounded m); intros H1m H2m. - case (to_Z_bounded n); intros H1n H2n. - case (to_Z_bounded i); intros H1i H2i. - generalize (add_le_r m n); case (n <=? m + n)%uint63; intros H. - - apply to_Z_inj; rewrite -> !lsr_spec, Zdiv_Zdiv, <- Zpower_exp; auto with zarith. - rewrite add_spec, Zmod_small; auto with zarith. - - apply to_Z_inj; rewrite -> !lsr_spec, Zdiv_Zdiv, <- Zpower_exp; auto with zarith. - apply Zdiv_small. split; [ auto with zarith | ]. - eapply Z.lt_le_trans; [ | apply Zpower2_le_lin ]; auto with zarith. -Qed. - -(* LSL *) -Lemma lsl0 i: 0 << i = 0%uint63. -Proof. - apply to_Z_inj. - generalize (lsl_spec 0 i). - rewrite to_Z_0, Zmult_0_l, Zmod_0_l; auto. -Qed. - -Lemma lsl0_r i : i << 0 = i. -Proof. - apply to_Z_inj. - rewrite -> lsl_spec, to_Z_0, Z.mul_1_r. - apply Zmod_small; apply (to_Z_bounded i). -Qed. - -Lemma lsl_add_distr x y n: (x + y) << n = ((x << n) + (y << n))%uint63. -Proof. - apply to_Z_inj; rewrite -> !lsl_spec, !add_spec, Zmult_mod_idemp_l. - rewrite -> !lsl_spec, <-Zplus_mod. - apply (f_equal2 Z.modulo); auto with zarith. -Qed. - -Lemma lsr_M_r x i (H: (digits <=? i = true)%uint63) : x >> i = 0%uint63. -Proof. - apply to_Z_inj. - rewrite lsr_spec, to_Z_0. - case (to_Z_bounded x); intros H1x H2x. - case (to_Z_bounded digits); intros H1d H2d. - rewrite -> leb_spec in H. - apply Zdiv_small; split; [ auto | ]. - apply (Z.lt_le_trans _ _ _ H2x). - unfold wB; change (Z_of_nat size) with Ļ† digits. - apply Zpower_le_monotone; auto with zarith. -Qed. - -(* BIT *) -Lemma bit_0_spec i: Ļ† (bit i 0) = Ļ† i mod 2. -Proof. - unfold bit, is_zero. rewrite lsr_0_r. - assert (Hbi: (Ļ† i mod 2 < 2)%Z). - { apply Z_mod_lt; auto with zarith. } - case (to_Z_bounded i); intros H1i H2i. - case (Z.mod_bound_pos_le (Ļ† i) 2); auto with zarith; intros H3i H4i. - assert (H2b: (0 < 2 ^ Ļ† (digits - 1))%Z). { - apply Zpower_gt_0; auto with zarith. - case (to_Z_bounded (digits -1)); auto with zarith. - } - assert (H: Ļ† (i << (digits -1)) = (Ļ† i mod 2 * 2^ Ļ† (digits -1))%Z). { - rewrite lsl_spec. - rewrite -> (Z_div_mod_eq_full Ļ† i 2) at 1. - rewrite -> Zmult_plus_distr_l, <-Zplus_mod_idemp_l. - rewrite -> (Zmult_comm 2), <-Zmult_assoc. - replace (2 * 2 ^ Ļ† (digits - 1))%Z with wB; auto. - rewrite Z_mod_mult, Zplus_0_l; apply Zmod_small. - split; auto with zarith. - replace wB with (2 * 2 ^ Ļ† (digits -1))%Z; auto. - apply Zmult_lt_compat_r; auto with zarith. - } - case (Zle_lt_or_eq 0 (Ļ† i mod 2)); auto with zarith; intros Hi. - 2: generalize H; rewrite <-Hi, Zmult_0_l. - 2: replace 0%Z with Ļ† 0; auto. - 2: now case eqbP. - generalize H; replace (Ļ† i mod 2) with 1%Z; auto with zarith. - rewrite Zmult_1_l. - intros H1. - assert (H2: Ļ† (i << (digits - 1)) <> Ļ† 0). - { replace Ļ† 0 with 0%Z; auto with zarith. } - now case eqbP. -Qed. - -Lemma bit_split i : ( i = (i >> 1 ) << 1 + bit i 0)%uint63. -Proof. - apply to_Z_inj. - rewrite -> add_spec, lsl_spec, lsr_spec, bit_0_spec, Zplus_mod_idemp_l. - replace (2 ^ Ļ† 1) with 2%Z; auto with zarith. - rewrite -> Zmult_comm, <-Z_div_mod_eq_full. - rewrite Zmod_small; auto; case (to_Z_bounded i); auto. -Qed. - -Lemma bit_lsr x i j : - (bit (x >> i) j = if j <=? i + j then bit x (i + j) else false)%uint63. -Proof. - unfold bit; rewrite lsr_add; case (_ ā‰¤? _); auto. -Qed. - -Lemma bit_b2i (b: bool) i : bit b i = (i =? 0)%uint63 && b. -Proof. - case b; unfold bit; simpl b2i. - - rewrite lsr_1; case (i =? 0)%uint63; auto. - - rewrite lsr0, lsl0, andb_false_r; auto. -Qed. - -Lemma bit_1 n : bit 1 n = (n =? 0)%uint63. -Proof. - unfold bit; rewrite lsr_1. - case (_ =? _)%uint63; simpl; auto. -Qed. - -Local Hint Resolve Z.lt_gt Z.div_pos : zarith. - -Lemma to_Z_split x : Ļ† x = Ļ† (x >> 1) * 2 + Ļ† (bit x 0). -Proof. - case (to_Z_bounded x); intros H1x H2x. - case (to_Z_bounded (bit x 0)); intros H1b H2b. - assert (F1: 0 <= Ļ† (x >> 1) < wB/2). { - rewrite -> lsr_spec, to_Z_1, Z.pow_1_r. split; auto with zarith. - apply Zdiv_lt_upper_bound; auto with zarith. - } - rewrite -> (bit_split x) at 1. - rewrite -> add_spec, Zmod_small, lsl_spec, to_Z_1, Z.pow_1_r, Zmod_small; - split; auto with zarith. - - change wB with ((wB/2)*2); auto with zarith. - - rewrite -> lsl_spec, to_Z_1, Z.pow_1_r, Zmod_small; auto with zarith. - change wB with ((wB/2)*2); auto with zarith. - - rewrite -> lsl_spec, to_Z_1, Z.pow_1_r, Zmod_small; auto with zarith. - 2: change wB with ((wB/2)*2); auto with zarith. - change wB with (((wB/2 - 1) * 2 + 1) + 1). - assert (Ļ† (bit x 0) <= 1); auto with zarith. - case bit; discriminate. -Qed. - -Lemma bit_M i n (H: (digits <=? n = true)%uint63): bit i n = false. -Proof. unfold bit; rewrite lsr_M_r; auto. Qed. - -Lemma bit_half i n (H: (n >1) n = bit i (n+1). -Proof. - unfold bit. - rewrite lsr_add. - case_eq (n <=? (1 + n))%uint63. - - replace (1+n)%uint63 with (n+1)%uint63; [auto|idtac]. - apply to_Z_inj; rewrite !add_spec, Zplus_comm; auto. - - intros H1; assert (H2: n = max_int). - 2: generalize H; rewrite H2; discriminate. - case (to_Z_bounded n); intros H1n H2n. - case (Zle_lt_or_eq Ļ† n (wB - 1)); auto with zarith; - intros H2; apply to_Z_inj; auto. - generalize (add_le_r 1 n); rewrite H1. - change Ļ† max_int with (wB - 1)%Z. - replace Ļ† 1 with 1%Z; auto with zarith. -Qed. - -Lemma bit_ext i j : (forall n, bit i n = bit j n) -> i = j. -Proof. - case (to_Z_bounded j); case (to_Z_bounded i). - unfold wB; revert i j; elim size. - - simpl; intros i j ???? _; apply to_Z_inj; lia. - - intros n ih i j. - rewrite Nat2Z.inj_succ, Z.pow_succ_r by auto with zarith. - intros hi1 hi2 hj1 hj2 hext. - rewrite (bit_split i), (bit_split j), hext. - do 2 f_equal; apply ih; clear ih. - 1, 3: apply to_Z_bounded. - 1, 2: now rewrite lsr_spec; apply Z.div_lt_upper_bound. - intros b. - case (Zle_or_lt Ļ† digits Ļ† b). - + rewrite <- leb_spec; intros; rewrite !bit_M; auto. - + rewrite <- ltb_spec; intros; rewrite !bit_half; auto. -Qed. - -Lemma bit_lsl x i j : bit (x << i) j = - (if (j = 0) by discriminate. - case_eq (digits <=? j)%uint63; intros H. - - rewrite orb_true_r, bit_M; auto. - - set (d := Ļ† digits). - case (Zle_or_lt d (Ļ† j)); intros H1. - 1:case (leb_spec digits j); rewrite H; auto with zarith. - 1:intros _ HH; generalize (HH H1); discriminate. - clear H. - generalize (ltb_spec j i); case ltb; intros H2; unfold bit; simpl. - + change 62%uint63 with (digits - 1)%uint63. - assert (F2: (Ļ† j < Ļ† i)%Z) by (case H2; auto); clear H2. - replace (is_zero (((x << i) >> j) << (digits - 1))) with true; auto. - case (to_Z_bounded j); intros H1j H2j. - apply sym_equal; rewrite is_zero_spec; apply to_Z_inj. - rewrite lsl_spec, lsr_spec, lsl_spec. - replace wB with (2^d); auto. - pattern d at 1; replace d with ((d - (Ļ† j + 1)) + (Ļ† j + 1))%Z by ring. - rewrite Zpower_exp; auto with zarith. - replace Ļ† i with ((Ļ† i - (Ļ† j + 1)) + (Ļ† j + 1))%Z by ring. - rewrite -> Zpower_exp, Zmult_assoc; auto with zarith. - rewrite Zmult_mod_distr_r. - rewrite -> Zplus_comm, Zpower_exp, !Zmult_assoc; auto with zarith. - rewrite -> Z_div_mult_full; auto with zarith. - rewrite <-Zmult_assoc, <-Zpower_exp; auto with zarith. - replace (1 + Ļ† digits - 1)%Z with d; auto with zarith. - rewrite Z_mod_mult; auto. - + case H2; intros _ H3; case (Zle_or_lt Ļ† i Ļ† j); intros F2. - 2: generalize (H3 F2); discriminate. - clear H2 H3. - apply (f_equal negb). - apply (f_equal is_zero). - apply to_Z_inj. - rewrite -> !lsl_spec, !lsr_spec, !lsl_spec. - pattern wB at 2 3; replace wB with (2^(1+ Ļ† (digits - 1))); auto. - rewrite -> Zpower_exp, Z.pow_1_r; auto with zarith. - rewrite !Zmult_mod_distr_r. - apply (f_equal2 Zmult); auto. - replace wB with (2^ d); auto with zarith. - replace d with ((d - Ļ† i) + Ļ† i)%Z by ring. - case (to_Z_bounded i); intros H1i H2i. - rewrite Zpower_exp; auto with zarith. - rewrite Zmult_mod_distr_r. - case (to_Z_bounded j); intros H1j H2j. - replace Ļ† (j - i) with (Ļ† j - Ļ† i)%Z. - 2: rewrite sub_spec, Zmod_small; auto with zarith. - set (d1 := (d - Ļ† i)%Z). - set (d2 := (Ļ† j - Ļ† i)%Z). - pattern Ļ† j at 1; - replace Ļ† j with (d2 + Ļ† i)%Z. - 2: unfold d2; ring. - rewrite -> Zpower_exp; auto with zarith. - rewrite -> Zdiv_mult_cancel_r. - 2: generalize (Zpower2_lt_lin Ļ† i H1i); auto with zarith. - rewrite -> (Z_div_mod_eq_full Ļ† x (2^d1)) at 2. - pattern d1 at 2; - replace d1 with (d2 + (1+ (d - Ļ† j - 1)))%Z - by (unfold d1, d2; ring). - rewrite Zpower_exp; auto with zarith. - rewrite <-Zmult_assoc, Zmult_comm. - rewrite Zdiv.Z_div_plus_full_l; auto with zarith. - rewrite Zpower_exp, Z.pow_1_r; auto with zarith. - rewrite <-Zplus_mod_idemp_l. - rewrite <-!Zmult_assoc, Zmult_comm, Z_mod_mult, Zplus_0_l; auto. -Qed. - -(* LOR *) -Lemma lor_lsr i1 i2 i: (i1 lor i2) >> i = (i1 >> i) lor (i2 >> i). -Proof. - apply bit_ext; intros n. - rewrite -> lor_spec, !bit_lsr, lor_spec. - case (_ <=? _)%uint63; auto. -Qed. - -Lemma lor_le x y : (y <=? x lor y)%uint63 = true. -Proof. - generalize x y (to_Z_bounded x) (to_Z_bounded y); clear x y. - unfold wB; elim size. - - replace (2^Z_of_nat 0) with 1%Z; auto with zarith. - intros x y Hx Hy; replace x with 0%uint63. - + replace y with 0%uint63; auto. - apply to_Z_inj; rewrite to_Z_0; auto with zarith. - + apply to_Z_inj; rewrite to_Z_0; auto with zarith. - - intros n IH x y; rewrite inj_S. - unfold Z.succ; rewrite -> Zpower_exp, Z.pow_1_r; auto with zarith. - intros Hx Hy. - rewrite leb_spec. - rewrite -> (to_Z_split y) at 1; rewrite (to_Z_split (x lor y)). - assert (Ļ† (y>>1) <= Ļ† ((x lor y) >> 1)). - + rewrite -> lor_lsr, <-leb_spec; apply IH. - * rewrite -> lsr_spec, to_Z_1, Z.pow_1_r; split; auto with zarith. - apply Zdiv_lt_upper_bound; auto with zarith. - * rewrite -> lsr_spec, to_Z_1, Z.pow_1_r; split; auto with zarith. - apply Zdiv_lt_upper_bound; auto with zarith. - + assert (Ļ† (bit y 0) <= Ļ† (bit (x lor y) 0)); auto with zarith. - rewrite lor_spec; do 2 case bit; try discriminate. -Qed. - -Lemma bit_0 n : bit 0 n = false. -Proof. unfold bit; rewrite lsr0; auto. Qed. - -Lemma bit_add_or x y: - (forall n, bit x n = true -> bit y n = true -> False) <-> (x + y)%uint63= x lor y. -Proof. - generalize x y (to_Z_bounded x) (to_Z_bounded y); clear x y. - unfold wB; elim size. - - replace (2^Z_of_nat 0) with 1%Z; auto with zarith. - intros x y Hx Hy; replace x with 0%uint63. - + replace y with 0%uint63. - { split; auto; intros _ n; rewrite !bit_0; discriminate. } - apply to_Z_inj; rewrite to_Z_0; auto with zarith. - + apply to_Z_inj; rewrite to_Z_0; auto with zarith. - - intros n IH x y; rewrite inj_S. - unfold Z.succ; rewrite Zpower_exp, Z.pow_1_r; auto with zarith. - intros Hx Hy. - split. - + intros Hn. - assert (F1: ((x >> 1) + (y >> 1))%uint63 = (x >> 1) lor (y >> 1)). { - apply IH. - - rewrite lsr_spec, Z.pow_1_r; split; auto with zarith. - apply Zdiv_lt_upper_bound; auto with zarith. - - rewrite lsr_spec, Z.pow_1_r; split; auto with zarith. - apply Zdiv_lt_upper_bound; auto with zarith. - - intros m H1 H2. - case_eq (digits <=? m)%uint63; [idtac | rewrite <- not_true_iff_false]; - intros Heq. - + rewrite bit_M in H1; auto; discriminate. - + rewrite leb_spec in Heq. - apply (Hn (m + 1)%uint63); - rewrite <-bit_half; auto; rewrite ltb_spec; auto with zarith. - } - rewrite (bit_split (x lor y)), lor_lsr, <- F1, lor_spec. - replace (b2i (bit x 0 || bit y 0)) with (bit x 0 + bit y 0)%uint63. - 2: generalize (Hn 0%uint63); do 2 case bit; auto; intros [ ]; auto. - rewrite lsl_add_distr. - rewrite (bit_split x) at 1; rewrite (bit_split y) at 1. - rewrite <-!add_assoc; apply (f_equal2 add); auto. - rewrite add_comm, <-!add_assoc; apply (f_equal2 add); auto. - rewrite add_comm; auto. - + intros Heq. - generalize (add_le_r x y); rewrite Heq, lor_le; intro Hb. - generalize Heq; rewrite (bit_split x) at 1; rewrite (bit_split y )at 1; clear Heq. - rewrite (fun y => add_comm y (bit x 0)), <-!add_assoc, add_comm, - <-!add_assoc, (add_comm (bit y 0)), add_assoc, <-lsl_add_distr. - rewrite (bit_split (x lor y)), lor_spec. - intros Heq. - assert (F: (bit x 0 + bit y 0)%uint63 = (bit x 0 || bit y 0)). { - assert (F1: (2 | wB)) by (apply Zpower_divide; apply refl_equal). - assert (F2: 0 < wB) by (apply refl_equal). - assert (F3: Ļ† (bit x 0 + bit y 0) mod 2 = Ļ† (bit x 0 || bit y 0) mod 2). { - apply trans_equal with ((Ļ† ((x>>1 + y>>1) << 1) + Ļ† (bit x 0 + bit y 0)) mod 2). - - rewrite lsl_spec, Zplus_mod, <-Zmod_div_mod; auto with zarith. - rewrite Z.pow_1_r, Z_mod_mult, Zplus_0_l, Zmod_mod; auto with zarith. - - rewrite (Zmod_div_mod 2 wB), <-add_spec, Heq; auto with zarith. - rewrite add_spec, <-Zmod_div_mod; auto with zarith. - rewrite lsl_spec, Zplus_mod, <-Zmod_div_mod; auto with zarith. - rewrite Z.pow_1_r, Z_mod_mult, Zplus_0_l, Zmod_mod; auto with zarith. - } - generalize F3; do 2 case bit; try discriminate; auto. - } - case (IH (x >> 1) (y >> 1)). - * rewrite lsr_spec, to_Z_1, Z.pow_1_r; split; auto with zarith. - apply Zdiv_lt_upper_bound; auto with zarith. - * rewrite lsr_spec, to_Z_1, Z.pow_1_r; split; auto with zarith. - apply Zdiv_lt_upper_bound; auto with zarith. - * intros _ HH m; case (to_Z_bounded m); intros H1m H2m. - case_eq (digits <=? m)%uint63. - -- intros Hlm; rewrite bit_M; auto; discriminate. - -- rewrite <- not_true_iff_false, leb_spec; intros Hlm. - case (Zle_lt_or_eq 0 Ļ† m); auto; intros Hm. - ++ replace m with ((m -1) + 1)%uint63. { - rewrite <-(bit_half x), <-(bit_half y); auto with zarith. - - apply HH. - rewrite <-lor_lsr. - assert (0 <= Ļ† (bit (x lor y) 0) <= 1) by (case bit; split; discriminate). - rewrite F in Heq; generalize (add_cancel_r _ _ _ Heq). - intros Heq1; apply to_Z_inj. - generalize (f_equal to_Z Heq1); rewrite lsl_spec, to_Z_1, Z.pow_1_r, Zmod_small. - + rewrite lsl_spec, to_Z_1, Z.pow_1_r, Zmod_small; auto with zarith. - case (to_Z_bounded (x lor y)); intros H1xy H2xy. - rewrite lsr_spec, to_Z_1, Z.pow_1_r; auto with zarith. - change wB with ((wB/2)*2); split; auto with zarith. - assert (Ļ† (x lor y) / 2 < wB / 2); auto with zarith. - apply Zdiv_lt_upper_bound; auto with zarith. - + split. - * case (to_Z_bounded (x >> 1 + y >> 1)); auto with zarith. - * rewrite add_spec. - apply Z.le_lt_trans with ((Ļ† (x >> 1) + Ļ† (y >> 1)) * 2); auto with zarith. - -- case (Z.mod_bound_pos_le (Ļ† (x >> 1) + Ļ† (y >> 1)) wB); auto with zarith. - case (to_Z_bounded (x >> 1)); case (to_Z_bounded (y >> 1)); auto with zarith. - -- generalize Hb; rewrite (to_Z_split x) at 1; rewrite (to_Z_split y) at 1. - case (to_Z_bounded (bit x 0)); case (to_Z_bounded (bit y 0)); auto with zarith. - - rewrite ltb_spec, sub_spec, to_Z_1, Zmod_small; auto with zarith. - - rewrite ltb_spec, sub_spec, to_Z_1, Zmod_small; auto with zarith. - } - apply to_Z_inj. - rewrite add_spec, sub_spec, Zplus_mod_idemp_l, to_Z_1, Zmod_small; auto with zarith. - ++ pose proof (to_Z_inj 0 _ Hm); clear Hm; subst m. - intros hx hy; revert F; rewrite hx, hy; intros F. - generalize (f_equal to_Z F). vm_compute. lia. -Qed. - -Lemma addmuldiv_spec x y p : - Ļ† p <= Ļ† digits -> - Ļ† (addmuldiv p x y) = (Ļ† x * (2 ^ Ļ† p) + Ļ† y / (2 ^ (Ļ† digits - Ļ† p))) mod wB. -Proof. - intros H. - assert (Fp := to_Z_bounded p); assert (Fd := to_Z_bounded digits). - rewrite addmuldiv_def_spec; unfold addmuldiv_def. - case (bit_add_or (x << p) (y >> (digits - p))); intros HH _. - rewrite <-HH, add_spec, lsl_spec, lsr_spec, Zplus_mod_idemp_l, sub_spec. - - rewrite (fun x y => Zmod_small (x - y)); auto with zarith. - - intros n; rewrite -> bit_lsl, bit_lsr. - generalize (add_le_r (digits - p) n). - case (_ ā‰¤? _); try discriminate. - rewrite -> sub_spec, Zmod_small; auto with zarith; intros H1. - case_eq (n leb_spec, add_spec, Zmod_small, sub_spec, Zmod_small; auto with zarith. - rewrite -> sub_spec, Zmod_small; auto with zarith. -Qed. - -(* is_even *) -Lemma is_even_bit i : is_even i = negb (bit i 0). -Proof. - unfold is_even. - replace (i land 1) with (b2i (bit i 0)). - - case bit; auto. - - apply bit_ext; intros n. - rewrite bit_b2i, land_spec, bit_1. - generalize (eqb_spec n 0). - case (n =? 0)%uint63; auto. - + intros(H,_); rewrite andb_true_r, H; auto. - + rewrite andb_false_r; auto. -Qed. - -Lemma is_even_spec x : if is_even x then Ļ† x mod 2 = 0 else Ļ† x mod 2 = 1. -Proof. -rewrite is_even_bit. -generalize (bit_0_spec x); case bit; simpl; auto. -Qed. - -Lemma is_even_0 : is_even 0 = true. -Proof. apply refl_equal. Qed. - -Lemma is_even_lsl_1 i : is_even (i << 1) = true. -Proof. - rewrite is_even_bit, bit_lsl; auto. -Qed. - -(* Sqrt *) - - (* Direct transcription of an old proof - of a fortran program in boyer-moore *) - -Ltac elim_div := - unfold Z.div, Z.modulo; - match goal with - | H : context[ Z.div_eucl ?X ?Y ] |- _ => - generalize dependent H; generalize (Z_div_mod_full X Y) ; case (Z.div_eucl X Y) - | |- context[ Z.div_eucl ?X ?Y ] => - generalize (Z_div_mod_full X Y) ; case (Z.div_eucl X Y) - end; unfold Remainder. - -Lemma quotient_by_2 a: a - 1 <= (a/2) + (a/2). -Proof. - case (Z_mod_lt a 2); auto with zarith. - intros H1; rewrite Zmod_eq_full; auto with zarith. -Qed. - -Lemma sqrt_main_trick j k: 0 <= j -> 0 <= k -> - (j * k) + j <= ((j + k)/2 + 1) ^ 2. -Proof. - intros Hj; generalize Hj k; pattern j; apply natlike_ind; - auto; clear k j Hj. - - intros _ k Hk; repeat rewrite Zplus_0_l. - apply Zmult_le_0_compat; generalize (Z_div_pos k 2); auto with zarith. - - intros j Hj Hrec _ k Hk; pattern k; apply natlike_ind; auto; clear k Hk. - + rewrite -> Zmult_0_r, Zplus_0_r, Zplus_0_l. - generalize (sqr_pos (Z.succ j / 2)) (quotient_by_2 (Z.succ j)); - unfold Z.succ. - rewrite Z.pow_2_r, Zmult_plus_distr_l; repeat rewrite Zmult_plus_distr_r. - auto with zarith. - + intros k Hk _. - replace ((Z.succ j + Z.succ k) / 2) with ((j + k)/2 + 1). - * generalize (Hrec Hj k Hk) (quotient_by_2 (j + k)). - unfold Z.succ; repeat rewrite Z.pow_2_r; - repeat rewrite Zmult_plus_distr_l; repeat rewrite Zmult_plus_distr_r. - repeat rewrite Zmult_1_l; repeat rewrite Zmult_1_r. - auto with zarith. - * rewrite -> Zplus_comm, <- Z_div_plus_full_l; auto with zarith. - apply f_equal2; auto with zarith. -Qed. - -Lemma sqrt_main i j: 0 <= i -> 0 < j -> i < ((j + (i/j))/2 + 1) ^ 2. -Proof. - intros Hi Hj. - assert (Hij: 0 <= i/j) by (apply Z_div_pos; auto with zarith). - refine (Z.lt_le_trans _ _ _ _ (sqrt_main_trick _ _ (Zlt_le_weak _ _ Hj) Hij)). - pattern i at 1; rewrite -> (Z_div_mod_eq_full i j); case (Z_mod_lt i j); auto with zarith. -Qed. - -Lemma sqrt_test_false i j: 0 <= i -> 0 < j -> i/j < j -> (j + (i/j))/2 < j. -Proof. - intros Hi Hj; elim_div; intros q r [ ? hr ]; [ lia | subst i ]. - elim_div; intros a b [ h [ hb | ] ]; lia. -Qed. - -Lemma sqrt_test_true i j: 0 <= i -> 0 < j -> i/j >= j -> j ^ 2 <= i. -Proof. - intros Hi Hj Hd; rewrite Z.pow_2_r. - apply Z.le_trans with (j * (i/j)); auto with zarith. - apply Z_mult_div_ge; auto with zarith. -Qed. - -Lemma sqrt_step_correct rec i j: - 0 < Ļ† i -> 0 < Ļ† j -> Ļ† i < (Ļ† j + 1) ^ 2 -> - 2 * Ļ† j < wB -> - (forall j1 : int, - 0 < Ļ† j1 < Ļ† j -> Ļ† i < (Ļ† j1 + 1) ^ 2 -> - Ļ† (rec i j1) ^ 2 <= Ļ† i < (Ļ† (rec i j1) + 1) ^ 2) -> - Ļ† (sqrt_step rec i j) ^ 2 <= Ļ† i < (Ļ† (sqrt_step rec i j) + 1) ^ 2. -Proof. - assert (Hp2: 0 < Ļ† 2) by exact (refl_equal Lt). - intros Hi Hj Hij H31 Hrec. - unfold sqrt_step. - case ltbP; rewrite div_spec. - - intros hlt. - assert (Ļ† (j + i / j) = Ļ† j + Ļ† i/Ļ† j) as hj. - { rewrite add_spec, Zmod_small;rewrite div_spec; auto with zarith. } - apply Hrec; rewrite lsr_spec, hj, to_Z_1; change (2 ^ 1) with 2. - + split; [ | apply sqrt_test_false;auto with zarith]. - replace (Ļ† j + Ļ† i/Ļ† j) with (1 * 2 + ((Ļ† j - 2) + Ļ† i / Ļ† j)) by ring. - rewrite Z_div_plus_full_l; auto with zarith. - assert (0 <= Ļ† i/ Ļ† j) by (apply Z_div_pos; auto with zarith). - assert (0 <= (Ļ† j - 2 + Ļ† i / Ļ† j) / 2) ; auto with zarith. - apply Z.div_pos; [ | lia ]. - case (Zle_lt_or_eq 1 Ļ† j); auto with zarith; intros Hj1. - rewrite <- Hj1, Zdiv_1_r; lia. - + apply sqrt_main;auto with zarith. - - split;[apply sqrt_test_true | ];auto with zarith. -Qed. - -Lemma iter_sqrt_correct n rec i j: 0 < Ļ† i -> 0 < Ļ† j -> - Ļ† i < (Ļ† j + 1) ^ 2 -> 2 * Ļ† j < wB -> - (forall j1, 0 < Ļ† j1 -> 2^(Z_of_nat n) + Ļ† j1 <= Ļ† j -> - Ļ† i < (Ļ† j1 + 1) ^ 2 -> 2 * Ļ† j1 < wB -> - Ļ† (rec i j1) ^ 2 <= Ļ† i < (Ļ† (rec i j1) + 1) ^ 2) -> - Ļ† (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. 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. - intros j2 Hj2 H2j2 Hjp2 Hj31; apply Hrec; auto with zarith. - intros j3 Hj3 Hpj3. - apply HHrec; auto. - rewrite -> inj_S, Z.pow_succ_r. - + apply Z.le_trans with (2 ^Z_of_nat n + Ļ† j2); auto with zarith. - + apply Zle_0_nat. -Qed. - -Lemma sqrt_init i: 1 < i -> i < (i/2 + 1) ^ 2. -Proof. - intros Hi. - assert (H1: 0 <= i - 2) by auto with zarith. - assert (H2: 1 <= (i / 2) ^ 2); auto with zarith. { - replace i with (1* 2 + (i - 2)); auto with zarith. - rewrite Z.pow_2_r, Z_div_plus_full_l; [|auto with zarith]. - generalize (sqr_pos ((i - 2)/ 2)) (Z_div_pos (i - 2) 2). - rewrite Zmult_plus_distr_l; repeat rewrite Zmult_plus_distr_r. - auto with zarith. - } - generalize (quotient_by_2 i). - rewrite -> Z.pow_2_r in H2 |- *; - repeat (rewrite Zmult_plus_distr_l || - rewrite Zmult_plus_distr_r || - rewrite Zmult_1_l || rewrite Zmult_1_r). - auto with zarith. -Qed. - -Lemma sqrt_spec : forall x, - Ļ† (sqrt x) ^ 2 <= Ļ† x < (Ļ† (sqrt x) + 1) ^ 2. -Proof. - intros i; unfold sqrt. - rewrite compare_spec. case Z.compare_spec; rewrite to_Z_1; - intros Hi. - - lia. - - apply iter_sqrt_correct; auto with zarith; - rewrite lsr_spec, to_Z_1; change (2^1) with 2; auto with zarith. - + replace Ļ† i with (1 * 2 + (Ļ† i - 2))%Z; try ring. - assert (0 <= (Ļ† i - 2)/2)%Z by (apply Z_div_pos; auto with zarith). - rewrite Z_div_plus_full_l; auto with zarith. - + apply sqrt_init; auto. - + assert (W:= Z_mult_div_ge Ļ† i 2);assert (W':= to_Z_bounded i);auto with zarith. - + intros j2 H1 H2; contradict H2; apply Zlt_not_le. - fold wB;assert (W:=to_Z_bounded i). - apply Z.le_lt_trans with (Ļ† i); auto with zarith. - assert (0 <= Ļ† i/2)%Z by (apply Z_div_pos; auto with zarith). - apply Z.le_trans with (2 * (Ļ† i/2)); auto with zarith. - apply Z_mult_div_ge; auto with zarith. - - case (to_Z_bounded i); repeat rewrite Z.pow_2_r; auto with zarith. -Qed. - -(* sqrt2 *) -Lemma sqrt2_step_def rec ih il j: - sqrt2_step rec ih il j = - if (ih m1 >> 1 - | C1 m1 => (m1 >> 1 + 1 << (digits -1))%uint63 - end in - rec ih il m - else j - else j. -Proof. - unfold sqrt2_step; case diveucl_21; intros i j';simpl. - case (j +c i);trivial. -Qed. - -Lemma sqrt2_lower_bound ih il j: - Ī¦ (WW ih il) < (Ļ† j + 1) ^ 2 -> Ļ† ih <= Ļ† j. -Proof. - intros H1. - case (to_Z_bounded j); intros Hbj _. - case (to_Z_bounded il); intros Hbil _. - case (to_Z_bounded ih); intros Hbih Hbih1. - assert ((Ļ† ih < Ļ† j + 1)%Z); auto with zarith. - apply Zlt_square_simpl; auto with zarith. - simpl zn2z_to_Z in H1. - repeat rewrite <-Z.pow_2_r. - refine (Z.le_lt_trans _ _ _ _ H1). - apply Z.le_trans with (Ļ† ih * wB)%Z;try rewrite Z.pow_2_r; auto with zarith. -Qed. - -Lemma diveucl_21_spec_aux : forall a1 a2 b, - wB/2 <= Ļ† b -> - Ļ† a1 < Ļ† b -> - let (q,r) := diveucl_21 a1 a2 b in - Ļ† a1 *wB+ Ļ† a2 = Ļ† q * Ļ† b + Ļ† r /\ - 0 <= Ļ† r < Ļ† b. -Proof. - intros a1 a2 b H1 H2;assert (W:= diveucl_21_spec a1 a2 b). - assert (W1:= to_Z_bounded a1). - assert (W2:= to_Z_bounded a2). - assert (Wb:= to_Z_bounded b). - assert (Ļ† b>0) as H by (auto with zarith). - generalize (Z_div_mod (Ļ† a1*wB+Ļ† a2) Ļ† b H). - revert W. - destruct (diveucl_21 a1 a2 b); destruct (Z.div_eucl (Ļ† a1*wB+Ļ† a2) Ļ† b). - intros (H', H''); auto; rewrite H', H''; clear H' H''. - intros (H', H''); split; [ |exact H'']. - now rewrite H', Zmult_comm. -Qed. - -Lemma div2_phi ih il j: (2^62 <= Ļ† j -> Ļ† ih < Ļ† j -> - Ļ† (fst (diveucl_21 ih il j)) = Ī¦ (WW ih il) / Ļ† j)%Z. -Proof. - intros Hj Hj1. - generalize (diveucl_21_spec_aux ih il j Hj Hj1). - case diveucl_21; intros q r (Hq, Hr). - apply Zdiv_unique with Ļ† r; auto with zarith. - simpl @fst; apply eq_trans with (1 := Hq); ring. -Qed. - -Lemma sqrt2_step_correct rec ih il j: - 2 ^ (Z_of_nat (size - 2)) <= Ļ† ih -> - 0 < Ļ† j -> Ī¦ (WW ih il) < (Ļ† j + 1) ^ 2 -> - (forall j1, 0 < Ļ† j1 < Ļ† j -> Ī¦ (WW ih il) < (Ļ† j1 + 1) ^ 2 -> - Ļ† (rec ih il j1) ^ 2 <= Ī¦ (WW ih il) < (Ļ† (rec ih il j1) + 1) ^ 2) -> - Ļ† (sqrt2_step rec ih il j) ^ 2 <= Ī¦ (WW ih il) - < (Ļ† (sqrt2_step rec ih il j) + 1) ^ 2. -Proof. - assert (Hp2: (0 < Ļ† 2)%Z) by exact (refl_equal Lt). - intros Hih Hj Hij Hrec; rewrite sqrt2_step_def. - assert (H1: (Ļ† ih <= Ļ† j)%Z) by (apply sqrt2_lower_bound with il; auto). - case (to_Z_bounded ih); intros Hih1 _. - case (to_Z_bounded il); intros Hil1 _. - case (to_Z_bounded j); intros _ Hj1. - assert (Hp3: (0 < Ī¦ (WW ih il))). - {simpl zn2z_to_Z;apply Z.lt_le_trans with (Ļ† ih * wB)%Z; auto with zarith. - apply Zmult_lt_0_compat; auto with zarith. - } - cbv zeta. - case_eq (ih ltb_spec in Heq. - case (Zle_or_lt (2^(Z_of_nat size -1)) Ļ† j); intros Hjj. - 1: case_eq (fst (diveucl_21 ih il j) ltb_spec, (div2_phi _ _ _ Hjj Heq) in Heq0. - match goal with |- context[rec _ _ ?X] => - set (u := X) - end. - assert (H: Ļ† u = (Ļ† j + (Ī¦ (WW ih il))/(Ļ† j))/2). - { unfold u; generalize (addc_spec j (fst (diveucl_21 ih il j))); - case addc;unfold interp_carry;rewrite (div2_phi _ _ _ Hjj Heq);simpl zn2z_to_Z. - { intros i H;rewrite lsr_spec, H;trivial. } - intros i H;rewrite <- H. - case (to_Z_bounded i); intros H1i H2i. - rewrite -> add_spec, Zmod_small, lsr_spec. - { change (1 * wB) with (Ļ† (1 << (digits -1)) * 2)%Z. - rewrite Z_div_plus_full_l; auto with zarith. } - change wB with (2 * (wB/2))%Z; auto. - replace Ļ† (1 << (digits - 1)) with (wB/2); auto. - rewrite lsr_spec; auto. - replace (2^Ļ† 1) with 2%Z; auto. - split; auto with zarith. - assert (Ļ† i/2 < wB/2); auto with zarith. - apply Zdiv_lt_upper_bound; auto with zarith. } - apply Hrec; rewrite H; clear u H. - + assert (Hf1: 0 <= Ī¦ (WW ih il) / Ļ† j) by (apply Z_div_pos; auto with zarith). - case (Zle_lt_or_eq 1 (Ļ† j)); auto with zarith; intros Hf2. - split. - * replace (Ļ† j + Ī¦ (WW ih il) / Ļ† j)%Z with - (1 * 2 + ((Ļ† j - 2) + Ī¦ (WW ih il) / Ļ† j)) by lia. - rewrite Z_div_plus_full_l; auto with zarith. - assert (0 <= (Ļ† j - 2 + Ī¦ (WW ih il) / Ļ† j) / 2) ; auto with zarith. - * apply sqrt_test_false; auto with zarith. - + apply sqrt_main; auto with zarith. - - contradict Hij; apply Zle_not_lt. - assert ((1 + Ļ† j) <= 2 ^ (Z_of_nat size - 1)); auto with zarith. - apply Z.le_trans with ((2 ^ (Z_of_nat size - 1)) ^2); auto with zarith. - + assert (0 <= 1 + Ļ† j); auto with zarith. - apply Zmult_le_compat; auto with zarith. - + change ((2 ^ (Z_of_nat size - 1))^2) with (2 ^ (Z_of_nat size - 2) * wB). - apply Z.le_trans with (Ļ† ih * wB); auto with zarith. - unfold zn2z_to_Z, wB; auto with zarith. -Qed. - -Lemma iter2_sqrt_correct n rec ih il j: - 2^(Z_of_nat (size - 2)) <= Ļ† ih -> 0 < Ļ† j -> Ī¦ (WW ih il) < (Ļ† j + 1) ^ 2 -> - (forall j1, 0 < Ļ† j1 -> 2^(Z_of_nat n) + Ļ† j1 <= Ļ† j -> - Ī¦ (WW ih il) < (Ļ† j1 + 1) ^ 2 -> - Ļ† (rec ih il j1) ^ 2 <= Ī¦ (WW ih il) < (Ļ† (rec ih il j1) + 1) ^ 2) -> - Ļ† (iter2_sqrt n rec ih il j) ^ 2 <= Ī¦ (WW ih il) - < (Ļ† (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. 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. - intros j2 Hj2 H2j2 Hjp2; apply Hrec; auto with zarith. - intros j3 Hj3 Hpj3. - apply HHrec; auto. - rewrite -> inj_S, Z.pow_succ_r. - + apply Z.le_trans with (2 ^Z_of_nat n + Ļ† j2)%Z; auto with zarith. - + apply Zle_0_nat. -Qed. - -Lemma sqrt2_spec : forall x y, - wB/ 4 <= Ļ† x -> - let (s,r) := sqrt2 x y in - Ī¦ (WW x y) = Ļ† s ^ 2 + [+|r|] /\ - [+|r|] <= 2 * Ļ† s. - Proof. - intros ih il Hih; unfold sqrt2. - change Ī¦ (WW ih il) with (Ī¦(WW ih il)). - assert (Hbin: forall s, s * s + 2* s + 1 = (s + 1) ^ 2) by - (intros s; ring). - assert (Hb: 0 <= wB) by (red; intros HH; discriminate). - assert (Hi2: Ī¦(WW ih il ) < (Ļ† max_int + 1) ^ 2). { - apply Z.le_lt_trans with ((wB - 1) * wB + (wB - 1)); auto with zarith. - case (to_Z_bounded ih); case (to_Z_bounded il); intros H1 H2 H3 H4. - unfold zn2z_to_Z; auto with zarith. - } - case (iter2_sqrt_correct size (fun _ _ j => j) ih il max_int); auto with zarith. - - apply refl_equal. - - intros j1 _ HH; contradict HH. - apply Zlt_not_le. - case (to_Z_bounded j1); auto with zarith. - change (2 ^ Z_of_nat size) with (Ļ† max_int+1)%Z; auto with zarith. - - set (s := iter2_sqrt size (fun _ _ j : int=> j) ih il max_int). - intros Hs1 Hs2. - generalize (mulc_spec s s); case mulc. - simpl fst; simpl snd; intros ih1 il1 Hihl1. - generalize (subc_spec il il1). - case subc; intros il2 Hil2. - + simpl interp_carry in Hil2. - case_eq (ih1 Z.pow_2_r, Hihl1, Hil2. - case (Zle_lt_or_eq (Ļ† ih1 + 1) (Ļ† ih)); auto with zarith. - -- intros H2; contradict Hs2; apply Zle_not_lt. - replace ((Ļ† s + 1) ^ 2) with (Ī¦(WW ih1 il1) + 2 * Ļ† s + 1). - ++ unfold zn2z_to_Z. - case (to_Z_bounded il); intros Hpil _. - assert (Hl1l: Ļ† il1 <= Ļ† il). - ** case (to_Z_bounded il2); rewrite Hil2; auto with zarith. - ** enough (Ļ† ih1 * wB + 2 * Ļ† s + 1 <= Ļ† ih * wB) by lia. - case (to_Z_bounded s); intros _ Hps. - case (to_Z_bounded ih1); intros Hpih1 _. - apply Z.le_trans with ((Ļ† ih1 + 2) * wB). { lia. } - auto with zarith. - ++ unfold zn2z_to_Z; rewrite <-Hihl1, Hbin; auto. - -- intros H2; split. - ++ unfold zn2z_to_Z; rewrite <- H2; ring. - ++ replace (wB + (Ļ† il - Ļ† il1)) with (Ī¦(WW ih il) - (Ļ† s * Ļ† s)). - { rewrite <-Hbin in Hs2; auto with zarith. } - rewrite Hihl1; unfold zn2z_to_Z; rewrite <- H2; ring. - * unfold interp_carry. - case (Zle_lt_or_eq Ļ† ih Ļ† ih1); auto with zarith; intros H. - -- contradict Hs1. - apply Zlt_not_le; rewrite Z.pow_2_r, Hihl1. - unfold zn2z_to_Z. - case (to_Z_bounded il); intros _ H2. - apply Z.lt_le_trans with ((Ļ† ih + 1) * wB + 0). - ++ rewrite Zmult_plus_distr_l, Zplus_0_r; auto with zarith. - ++ case (to_Z_bounded il1); intros H3 _. - apply Zplus_le_compat; auto with zarith. - -- split. - ++ rewrite Z.pow_2_r, Hihl1. - unfold zn2z_to_Z; ring[Hil2 H]. - ++ replace Ļ† il2 with (Ī¦(WW ih il) - Ī¦(WW ih1 il1)). - { unfold zn2z_to_Z at 2; rewrite <-Hihl1. - rewrite <-Hbin in Hs2; auto with zarith. } - unfold zn2z_to_Z; rewrite H, Hil2; ring. - + unfold interp_carry in Hil2 |- *. - assert (Hsih: Ļ† (ih - 1) = Ļ† ih - 1). - { rewrite sub_spec, Zmod_small; auto; replace Ļ† 1 with 1; auto. - case (to_Z_bounded ih); intros H1 H2. - split; auto with zarith. - apply Z.le_trans with (wB/4 - 1); auto with zarith. } - case_eq (ih1 ; auto; destruct 1; reflexivity. -Qed. - -(* bit *) -Lemma bitE i j : bit i j = Z.testbit Ļ†(i) Ļ†(j). -Proof. - symmetry; apply negb_sym; rewrite is_zeroE, lsl_spec, lsr_spec. - generalize (Ļ† i) (to_Z_bounded i) (Ļ† j) (to_Z_bounded j); clear i j; - intros i [hi hi'] j [hj hj']. - rewrite Z.testbit_eqb by auto; rewrite <- Z_oddE, Z.negb_odd, Z_evenE. - remember (i / 2 ^ j) as k. - change wB with (2 * 2 ^ Ļ† (digits - 1)). - unfold Z.modulo at 2. - generalize (Z_div_mod_full k 2 (Ī» k, let 'eq_refl := k in I)); unfold Remainder. - destruct Z.div_eucl as [ p q ]; intros [hk [ hq | ]]. 2: lia. - rewrite hk. - remember Ļ† (digits - 1) as m. - replace ((_ + _) * _) with (q * 2 ^ m + p * (2 * 2 ^ m)) by ring. - rewrite Z_mod_plus by (subst m; reflexivity). - assert (q = 0 āˆØ q = 1) as D by lia. - destruct D; subst; reflexivity. -Qed. - -(* land, lor, lxor *) -Lemma lt_pow_lt_log d k n : - 0 < d <= n ā†’ - 0 <= k < 2 ^ d ā†’ - Z.log2 k < n. -Proof. - intros [hd hdn] [hk hkd]. - assert (k = 0 āˆØ 0 < k) as D by lia. - clear hk; destruct D as [ hk | hk ]. - - subst k; simpl; lia. - - apply Z.log2_lt_pow2. - + lia. - + eapply Z.lt_le_trans. - * eassumption. - * apply Z.pow_le_mono_r; lia. -Qed. - -Lemma land_spec' x y : Ļ† (x land y) = Z.land Ļ†(x) Ļ†(y). -Proof. - apply Z.bits_inj'; intros n hn. - destruct (to_Z_bounded (x land y)) as [ hxy hxy' ]. - destruct (to_Z_bounded x) as [ hx hx' ]. - destruct (to_Z_bounded y) as [ hy hy' ]. - case (Z_lt_le_dec n (Ļ† digits)); intros hd. - 2: { - rewrite !Z.bits_above_log2; auto. - - apply Z.land_nonneg; auto. - - eapply Z.le_lt_trans. - { apply Z.log2_land; assumption. } - apply Z.min_lt_iff. - left. apply (lt_pow_lt_log Ļ† digits). - + exact (conj eq_refl hd). - + split; assumption. - - apply (lt_pow_lt_log Ļ† digits). - + exact (conj eq_refl hd). - + split; assumption. - } - rewrite (is_int n). - { rewrite Z.land_spec, <- !bitE, land_spec; reflexivity. } - apply (conj hn). - apply (Z.lt_trans _ _ _ hd). - apply Zpower2_lt_lin. lia. -Qed. - -Lemma lor_spec' x y : Ļ† (x lor y) = Z.lor Ļ†(x) Ļ†(y). -Proof. - apply Z.bits_inj'; intros n hn. - destruct (to_Z_bounded (x lor y)) as [ hxy hxy' ]. - destruct (to_Z_bounded x) as [ hx hx' ]. - destruct (to_Z_bounded y) as [ hy hy' ]. - case (Z_lt_le_dec n (Ļ† digits)); intros hd. - 2: { - rewrite !Z.bits_above_log2; auto. - - apply Z.lor_nonneg; auto. - - rewrite Z.log2_lor by assumption. - apply Z.max_lub_lt; apply (lt_pow_lt_log Ļ† digits); split; assumption || reflexivity. - - apply (lt_pow_lt_log Ļ† digits); split; assumption || reflexivity. - } - rewrite (is_int n). - { rewrite Z.lor_spec, <- !bitE, lor_spec; reflexivity. } - apply (conj hn). - apply (Z.lt_trans _ _ _ hd). - apply Zpower2_lt_lin. lia. -Qed. - -Lemma lxor_spec' x y : Ļ† (x lxor y) = Z.lxor Ļ†(x) Ļ†(y). -Proof. - apply Z.bits_inj'; intros n hn. - destruct (to_Z_bounded (x lxor y)) as [ hxy hxy' ]. - destruct (to_Z_bounded x) as [ hx hx' ]. - destruct (to_Z_bounded y) as [ hy hy' ]. - case (Z_lt_le_dec n (Ļ† digits)); intros hd. - 2: { - rewrite !Z.bits_above_log2; auto. - - apply Z.lxor_nonneg; split; auto. - - eapply Z.le_lt_trans. - { apply Z.log2_lxor; assumption. } - apply Z.max_lub_lt; apply (lt_pow_lt_log Ļ† digits); split; assumption || reflexivity. - - apply (lt_pow_lt_log Ļ† digits); split; assumption || reflexivity. - } - rewrite (is_int n). - { rewrite Z.lxor_spec, <- !bitE, lxor_spec; reflexivity. } - apply (conj hn). - apply (Z.lt_trans _ _ _ hd). - apply Zpower2_lt_lin. lia. -Qed. - -Lemma landC i j : i land j = j land i. -Proof. - apply bit_ext; intros n. - rewrite !land_spec, andb_comm; auto. -Qed. - -Lemma landA i j k : i land (j land k) = i land j land k. -Proof. - apply bit_ext; intros n. - rewrite !land_spec, andb_assoc; auto. -Qed. - -Lemma land0 i : 0 land i = 0%uint63. -Proof. - apply bit_ext; intros n. - rewrite land_spec, bit_0; auto. -Qed. - -Lemma land0_r i : i land 0 = 0%uint63. -Proof. rewrite landC; exact (land0 i). Qed. - -Lemma lorC i j : i lor j = j lor i. -Proof. - apply bit_ext; intros n. - rewrite !lor_spec, orb_comm; auto. -Qed. - -Lemma lorA i j k : i lor (j lor k) = i lor j lor k. -Proof. - apply bit_ext; intros n. - rewrite !lor_spec, orb_assoc; auto. -Qed. - -Lemma lor0 i : 0 lor i = i. -Proof. - apply bit_ext; intros n. - rewrite lor_spec, bit_0; auto. -Qed. - -Lemma lor0_r i : i lor 0 = i. -Proof. rewrite lorC; exact (lor0 i). Qed. - -Lemma lxorC i j : i lxor j = j lxor i. -Proof. - apply bit_ext; intros n. - rewrite !lxor_spec, xorb_comm; auto. -Qed. - -Lemma lxorA i j k : i lxor (j lxor k) = i lxor j lxor k. -Proof. - apply bit_ext; intros n. - rewrite !lxor_spec, xorb_assoc; auto. -Qed. - -Lemma lxor0 i : 0 lxor i = i. -Proof. - apply bit_ext; intros n. - rewrite lxor_spec, bit_0, xorb_false_l; auto. -Qed. - -Lemma lxor0_r i : i lxor 0 = i. -Proof. rewrite lxorC; exact (lxor0 i). Qed. - -Lemma opp_to_Z_opp (x : int) : - Ļ† x mod wB <> 0 -> - (- Ļ† (- x)) mod wB = (Ļ† x) mod wB. -Proof. - intros neqx0. - rewrite opp_spec. - rewrite (Z_mod_nz_opp_full (Ļ† x%uint63)) by assumption. - rewrite (Z.mod_small (Ļ† x%uint63)) by apply to_Z_bounded. - rewrite <- Z.add_opp_l. - rewrite Z.opp_add_distr, Z.opp_involutive. - replace (- wB) with (-1 * wB) by easy. - rewrite Z_mod_plus by easy. - now rewrite Z.mod_small by apply to_Z_bounded. -Qed. - -(** Minimum / maximum *) - -Definition min (i1 i2 : int) := - if (i1 <=? i2)%uint63 then i1 else i2. - -Definition max (i1 i2 : int) := - if (i1 <=? i2)%uint63 then i2 else i1. - -Lemma min_spec (x y : int) : - Ļ† (min x y) = Z.min (Ļ† x) (Ļ† y). -Proof. - unfold min. destruct (lebP x y). - - rewrite Z.min_l; [reflexivity | assumption]. - - rewrite Z.min_r; [reflexivity | lia]. -Qed. - -Lemma max_spec (x y : int) : - Ļ† (max x y) = Z.max (Ļ† x) (Ļ† y). -Proof. - unfold max. destruct (lebP x y). - - rewrite Z.max_r; [reflexivity | assumption]. - - rewrite Z.max_l; [reflexivity | lia]. -Qed. - -Lemma min_add_min_n_same (m i1 i2 : int) : - to_Z i1 + to_Z i2 < wB -> - Uint63.min m (Uint63.min m i1 + i2) = Uint63.min m (i1 + i2). -Proof. - intros H. apply to_Z_inj. - pose proof (to_Z_bounded m) as Hm. - pose proof (to_Z_bounded i1) as Hi1. - pose proof (to_Z_bounded i2) as Hi2. - rewrite !min_spec, !add_spec, !min_spec, !Z.mod_small; lia. -Qed. - -Lemma min_add_n_min_same (m i1 i2 : int) : - to_Z i1 + to_Z i2 < wB -> - Uint63.min m (i1 + Uint63.min m i2) = Uint63.min m (i1 + i2). -Proof. - intros H. apply to_Z_inj. - pose proof (to_Z_bounded m) as Hm. - pose proof (to_Z_bounded i1) as Hi1. - pose proof (to_Z_bounded i2) as Hi2. - rewrite !min_spec, !add_spec, !min_spec, !Z.mod_small; lia. -Qed. - -Module Export Uint63Notations. - Local Open Scope uint63_scope. - Export Uint63NotationsInternalB. - Export Uint63NotationsInternalC. - Export Uint63NotationsInternalD. -End Uint63Notations. diff --git a/stdlib/theories/Numbers/Cyclic/Int63/Uint63Axioms.v b/stdlib/theories/Numbers/Cyclic/Int63/Uint63Axioms.v deleted file mode 100644 index cb70db7bf820..000000000000 --- a/stdlib/theories/Numbers/Cyclic/Int63/Uint63Axioms.v +++ /dev/null @@ -1 +0,0 @@ -From Corelib Require Export Uint63Axioms. diff --git a/stdlib/theories/Numbers/DecimalFacts.v b/stdlib/theories/Numbers/DecimalFacts.v deleted file mode 100644 index 059a82f5db36..000000000000 --- a/stdlib/theories/Numbers/DecimalFacts.v +++ /dev/null @@ -1,703 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* nil - | D0 u => cons d0 (to_list u) - | D1 u => cons d1 (to_list u) - | D2 u => cons d2 (to_list u) - | D3 u => cons d3 (to_list u) - | D4 u => cons d4 (to_list u) - | D5 u => cons d5 (to_list u) - | D6 u => cons d6 (to_list u) - | D7 u => cons d7 (to_list u) - | D8 u => cons d8 (to_list u) - | D9 u => cons d9 (to_list u) - end. - -Fixpoint of_list (l : list digits) : uint := - match l with - | nil => Nil - | cons d0 l => D0 (of_list l) - | cons d1 l => D1 (of_list l) - | cons d2 l => D2 (of_list l) - | cons d3 l => D3 (of_list l) - | cons d4 l => D4 (of_list l) - | cons d5 l => D5 (of_list l) - | cons d6 l => D6 (of_list l) - | cons d7 l => D7 (of_list l) - | cons d8 l => D8 (of_list l) - | cons d9 l => D9 (of_list l) - end. - -Lemma of_list_to_list u : of_list (to_list u) = u. -Proof. now induction u; [|simpl; rewrite IHu..]. Qed. - -Lemma to_list_of_list l : to_list (of_list l) = l. -Proof. now induction l as [|h t IHl]; [|case h; simpl; rewrite IHl]. Qed. - -Lemma to_list_inj u u' : to_list u = to_list u' -> u = u'. -Proof. - now intro H; rewrite <-(of_list_to_list u), <-(of_list_to_list u'), H. -Qed. - -Lemma of_list_inj u u' : of_list u = of_list u' -> u = u'. -Proof. - now intro H; rewrite <-(to_list_of_list u), <-(to_list_of_list u'), H. -Qed. - -Lemma nb_digits_spec u : nb_digits u = length (to_list u). -Proof. now induction u; [|simpl; rewrite IHu..]. Qed. - -Fixpoint lnzhead l := - match l with - | nil => nil - | cons d l' => - match d with - | d0 => lnzhead l' - | _ => l - end - end. - -Lemma nzhead_spec u : to_list (nzhead u) = lnzhead (to_list u). -Proof. now induction u; [|simpl; rewrite IHu|..]. Qed. - -Definition lzero := cons d0 nil. - -Definition lunorm l := - match lnzhead l with - | nil => lzero - | d => d - end. - -Lemma unorm_spec u : to_list (unorm u) = lunorm (to_list u). -Proof. now unfold unorm, lunorm; rewrite <-nzhead_spec; case (nzhead u). Qed. - -Lemma revapp_spec d d' : - to_list (revapp d d') = List.rev_append (to_list d) (to_list d'). -Proof. now revert d'; induction d; intro d'; [|simpl; rewrite IHd..]. Qed. - -Lemma rev_spec d : to_list (rev d) = List.rev (to_list d). -Proof. now unfold rev; rewrite revapp_spec, List.rev_alt; simpl. Qed. - -Lemma app_spec d d' : - to_list (app d d') = Datatypes.app (to_list d) (to_list d'). -Proof. - unfold app. - now rewrite revapp_spec, List.rev_append_rev, rev_spec, List.rev_involutive. -Qed. - -Definition lnztail l := - let fix aux l_rev := - match l_rev with - | cons d0 l_rev => let (r, n) := aux l_rev in pair r (S n) - | _ => pair l_rev O - end in - let (r, n) := aux (List.rev l) in pair (List.rev r) n. - -Lemma nztail_spec d : - let (r, n) := nztail d in - let (r', n') := lnztail (to_list d) in - to_list r = r' /\ n = n'. -Proof. - unfold nztail, lnztail. - set (f := fix aux d_rev := match d_rev with - | D0 d_rev => let (r, n) := aux d_rev in (r, S n) - | _ => (d_rev, 0) end). - set (f' := fix aux (l_rev : list digits) : list digits * nat := - match l_rev with - | cons d0 l_rev => let (r, n) := aux l_rev in (r, S n) - | _ => (l_rev, 0) - end). - rewrite <-(of_list_to_list (rev d)), rev_spec. - induction (List.rev _) as [|h t IHl]; [now simpl|]. - case h; simpl; [|now rewrite rev_spec; simpl; rewrite to_list_of_list..]. - now revert IHl; case f; intros r n; case f'; intros r' n' [-> ->]. -Qed. - -Lemma del_head_spec_0 d : del_head 0 d = d. -Proof. now simpl. Qed. - -Lemma del_head_spec_small n d : - n <= length (to_list d) -> to_list (del_head n d) = List.skipn n (to_list d). -Proof. - revert d; induction n as [|n IHn]; intro d; [now simpl|]. - now case d; [|intros d' H; apply IHn, le_S_n..]. -Qed. - -Lemma del_head_spec_large n d : length (to_list d) < n -> del_head n d = zero. -Proof. - revert d; induction n; intro d; [now case d|]. - now case d; [|intro d'; simpl; intro H; rewrite (IHn _ (proj2 (Nat.succ_lt_mono _ _) H))..]. -Qed. - -Lemma nb_digits_0 d : nb_digits d = 0 -> d = Nil. -Proof. - rewrite nb_digits_spec, <-(of_list_to_list d). - now case (to_list d) as [|h t]; [|rewrite to_list_of_list]. -Qed. - -Lemma nb_digits_n0 d : nb_digits d <> 0 -> d <> Nil. -Proof. now case d; [|intros u _..]. Qed. - -Lemma nb_digits_iter_D0 n d : - nb_digits (Nat.iter n D0 d) = n + nb_digits d. -Proof. now induction n; simpl; [|rewrite IHn]. Qed. - -Lemma length_lnzhead l : length (lnzhead l) <= length l. -Proof. now induction l as [|h t IHl]; [|case h; [apply le_S|..]]. Qed. - -Lemma nb_digits_nzhead u : nb_digits (nzhead u) <= nb_digits u. -Proof. now induction u; [|apply le_S|..]. Qed. - -Lemma unorm_nzhead u : nzhead u <> Nil -> unorm u = nzhead u. -Proof. now unfold unorm; case nzhead. Qed. - -Lemma nb_digits_unorm u : u <> Nil -> nb_digits (unorm u) <= nb_digits u. -Proof. - intro Hu; case (uint_eq_dec (nzhead u) Nil). - { unfold unorm; intros ->; simpl. - now revert Hu; case u; [|intros u' _; apply le_n_S, Nat.le_0_l..]. } - intro H; rewrite (unorm_nzhead _ H); apply nb_digits_nzhead. -Qed. - -Lemma nb_digits_rev d : nb_digits (rev d) = nb_digits d. -Proof. now rewrite !nb_digits_spec, rev_spec, List.length_rev. Qed. - -Lemma nb_digits_del_head_sub d n : - n <= nb_digits d -> - nb_digits (del_head (nb_digits d - n) d) = n. -Proof. - rewrite !nb_digits_spec; intro Hn. - rewrite del_head_spec_small; [|now apply Nat.le_sub_l]. - rewrite List.length_skipn, <-(Nat2Z.id (_ - _)). - rewrite Nat2Z.inj_sub; [|now apply Nat.le_sub_l]. - rewrite (Nat2Z.inj_sub _ _ Hn). - rewrite Z.sub_sub_distr, Z.sub_diag; apply Nat2Z.id. -Qed. - -Lemma unorm_D0 u : unorm (D0 u) = unorm u. -Proof. reflexivity. Qed. - -Lemma app_nil_l d : app Nil d = d. -Proof. now simpl. Qed. - -Lemma app_nil_r d : app d Nil = d. -Proof. now apply to_list_inj; rewrite app_spec, List.app_nil_r. Qed. - -Lemma abs_app_int d d' : abs (app_int d d') = app (abs d) d'. -Proof. now case d. Qed. - -Lemma abs_norm d : abs (norm d) = unorm (abs d). -Proof. now case d as [u|u]; [|simpl; unfold unorm; case nzhead]. Qed. - -Lemma iter_D0_nzhead d : - Nat.iter (nb_digits d - nb_digits (nzhead d)) D0 (nzhead d) = d. -Proof. - induction d; [now simpl| |now rewrite Nat.sub_diag..]. - simpl nzhead; simpl nb_digits. - rewrite (Nat.sub_succ_l _ _ (nb_digits_nzhead _)). - now rewrite <-IHd at 4. -Qed. - -Lemma iter_D0_unorm d : - d <> Nil -> - Nat.iter (nb_digits d - nb_digits (unorm d)) D0 (unorm d) = d. -Proof. - case (uint_eq_dec (nzhead d) Nil); intro Hn. - { unfold unorm; rewrite Hn; simpl; intro H. - revert H Hn; induction d; [now simpl|intros _|now intros _..]. - case (uint_eq_dec d Nil); simpl; intros H Hn; [now rewrite H|]. - rewrite Nat.sub_0_r, <- (Nat.sub_add 1 (nb_digits d)), Nat.add_comm. - { now simpl; rewrite IHd. } - revert H; case d; [now simpl|intros u _; apply le_n_S, Nat.le_0_l..]. } - intros _; rewrite (unorm_nzhead _ Hn); apply iter_D0_nzhead. -Qed. - -Lemma nzhead_app_l d d' : - nb_digits d' < nb_digits (nzhead (app d d')) -> - nzhead (app d d') = app (nzhead d) d'. -Proof. - intro Hl; apply to_list_inj; revert Hl. - rewrite !nb_digits_spec, app_spec, !nzhead_spec, app_spec. - induction (to_list d) as [|h t IHl]. - { now simpl; intro H; exfalso; revert H; apply Nat.le_ngt, length_lnzhead. } - rewrite <-List.app_comm_cons. - now case h; [simpl; intro Hl; apply IHl|..]. -Qed. - -Lemma nzhead_app_r d d' : - nb_digits (nzhead (app d d')) <= nb_digits d' -> - nzhead (app d d') = nzhead d'. -Proof. - intro Hl; apply to_list_inj; revert Hl. - rewrite !nb_digits_spec, !nzhead_spec, app_spec. - induction (to_list d) as [|h t IHl]; [now simpl|]. - rewrite <-List.app_comm_cons. - now case h; [| simpl; rewrite List.length_app; intro Hl; exfalso; revert Hl; - apply Nat.le_ngt, Nat.le_add_l..]. -Qed. - -Lemma nzhead_app_nil_r d d' : nzhead (app d d') = Nil -> nzhead d' = Nil. -Proof. -now intro H; generalize H; rewrite nzhead_app_r; [|rewrite H; apply Nat.le_0_l]. -Qed. - -Lemma nzhead_app_nil d d' : - nb_digits (nzhead (app d d')) <= nb_digits d' -> nzhead d = Nil. -Proof. - intro H; apply to_list_inj; revert H. - rewrite !nb_digits_spec, !nzhead_spec, app_spec. - induction (to_list d) as [|h t IHl]; [now simpl|]. - now case h; [now simpl|..]; - simpl;intro H; exfalso; revert H; apply Nat.le_ngt; - rewrite List.length_app; apply Nat.le_add_l. -Qed. - -Lemma nzhead_app_nil_l d d' : nzhead (app d d') = Nil -> nzhead d = Nil. -Proof. - intro H; apply to_list_inj; generalize (f_equal to_list H); clear H. - rewrite !nzhead_spec, app_spec. - induction (to_list d) as [|h t IHl]; [now simpl|]. - now rewrite <-List.app_comm_cons; case h. -Qed. - -Lemma unorm_app_zero d d' : - nb_digits (unorm (app d d')) <= nb_digits d' -> unorm d = zero. -Proof. - unfold unorm. - case (uint_eq_dec (nzhead (app d d')) Nil). - { now intro Hn; rewrite Hn, (nzhead_app_nil_l _ _ Hn). } - intro H; fold (unorm (app d d')); rewrite (unorm_nzhead _ H); intro H'. - case (uint_eq_dec (nzhead d) Nil); [now intros->|]. - intro H''; fold (unorm d); rewrite (unorm_nzhead _ H''). - exfalso; apply H''; revert H'; apply nzhead_app_nil. -Qed. - -Lemma app_int_nil_r d : app_int d Nil = d. -Proof. - now case d; intro d'; simpl; - rewrite <-(of_list_to_list (app _ _)), app_spec; - rewrite List.app_nil_r, of_list_to_list. -Qed. - -Lemma unorm_app_l d d' : - nb_digits d' < nb_digits (unorm (app d d')) -> - unorm (app d d') = app (unorm d) d'. -Proof. - case (uint_eq_dec d' Nil); [now intros->; rewrite !app_nil_r|intro Hd']. - case (uint_eq_dec (nzhead (app d d')) Nil). - { unfold unorm; intros->; simpl; intro H; exfalso; revert H; apply Nat.le_ngt. - now revert Hd'; case d'; [|intros d'' _; apply le_n_S, Peano.le_0_n..]. } - intro Ha; rewrite (unorm_nzhead _ Ha). - intro Hn; generalize Hn; rewrite (nzhead_app_l _ _ Hn). - rewrite !nb_digits_spec, app_spec, List.length_app. - case (uint_eq_dec (nzhead d) Nil). - { intros->; simpl; intro H; exfalso; revert H; apply Nat.lt_irrefl. } - now intro H; rewrite (unorm_nzhead _ H). -Qed. - -Lemma unorm_app_r d d' : - nb_digits (unorm (app d d')) <= nb_digits d' -> - unorm (app d d') = unorm d'. -Proof. - case (uint_eq_dec (nzhead (app d d')) Nil). - { now unfold unorm; intro H; rewrite H, (nzhead_app_nil_r _ _ H). } - intro Ha; rewrite (unorm_nzhead _ Ha). - case (uint_eq_dec (nzhead d') Nil). - { now intros H H'; exfalso; apply Ha; rewrite nzhead_app_r. } - intro Hd'; rewrite (unorm_nzhead _ Hd'); apply nzhead_app_r. -Qed. - -Lemma norm_app_int d d' : - nb_digits d' < nb_digits (unorm (app (abs d) d')) -> - norm (app_int d d') = app_int (norm d) d'. -Proof. - case (uint_eq_dec d' Nil); [now intros->; rewrite !app_int_nil_r|intro Hd']. - case d as [d|d]; [now simpl; intro H; apply f_equal, unorm_app_l|]. - simpl; unfold unorm. - case (uint_eq_dec (nzhead (app d d')) Nil). - { intros->; simpl; intro H; exfalso; revert H; apply Nat.le_ngt. - now revert Hd'; case d'; [|intros d'' _; apply le_n_S, Nat.le_0_l..]. } - set (m := match nzhead _ with Nil => _ | _ => _ end). - intro Ha. - replace m with (nzhead (app d d')). - 2:{ now unfold m; revert Ha; case nzhead. } - intro Hn; generalize Hn; rewrite (nzhead_app_l _ _ Hn). - case (uint_eq_dec (app (nzhead d) d') Nil). - { intros->; simpl; intro H; exfalso; revert H; apply Nat.le_ngt, Nat.le_0_l. } - clear m; set (m := match app _ _ with Nil => _ | _ => _ end). - intro Ha'. - replace m with (Neg (app (nzhead d) d')); [|now unfold m; revert Ha'; case app]. - case (uint_eq_dec (nzhead d) Nil). - { intros->; simpl; intro H; exfalso; revert H; apply Nat.lt_irrefl. } - clear m; set (m := match nzhead _ with Nil => _ | _ => _ end). - intro Hd. - now replace m with (Neg (nzhead d)); [|unfold m; revert Hd; case nzhead]. -Qed. - -Lemma del_head_nb_digits d : del_head (nb_digits d) d = Nil. -Proof. - apply to_list_inj. - rewrite nb_digits_spec, del_head_spec_small; [|now simpl]. - now rewrite List.skipn_all. -Qed. - -Lemma del_tail_nb_digits d : del_tail (nb_digits d) d = Nil. -Proof. now unfold del_tail; rewrite <-nb_digits_rev, del_head_nb_digits. Qed. - -Lemma del_head_app n d d' : - n <= nb_digits d -> del_head n (app d d') = app (del_head n d) d'. -Proof. - rewrite nb_digits_spec; intro Hn. - apply to_list_inj. - rewrite del_head_spec_small. - 2:{ now rewrite app_spec, List.length_app, <- Nat.le_add_r. } - rewrite !app_spec, (del_head_spec_small _ _ Hn). - rewrite List.skipn_app. - now rewrite (proj2 (Nat.sub_0_le _ _) Hn). -Qed. - -Lemma del_tail_app n d d' : - n <= nb_digits d' -> del_tail n (app d d') = app d (del_tail n d'). -Proof. - rewrite nb_digits_spec; intro Hn. - unfold del_tail. - rewrite <-(of_list_to_list (rev (app d d'))), rev_spec, app_spec. - rewrite List.rev_app_distr, <-!rev_spec, <-app_spec, of_list_to_list. - rewrite del_head_app; [|now rewrite nb_digits_spec, rev_spec, List.length_rev]. - apply to_list_inj. - rewrite rev_spec, !app_spec, !rev_spec. - now rewrite List.rev_app_distr, List.rev_involutive. -Qed. - -Lemma del_tail_app_int n d d' : - n <= nb_digits d' -> del_tail_int n (app_int d d') = app_int d (del_tail n d'). -Proof. now case d as [d|d]; simpl; intro H; rewrite del_tail_app. Qed. - -Lemma app_del_tail_head n (d:uint) : - n <= nb_digits d -> app (del_tail n d) (del_head (nb_digits d - n) d) = d. -Proof. - rewrite nb_digits_spec; intro Hn; unfold del_tail. - rewrite <-(of_list_to_list (app _ _)), app_spec, rev_spec. - rewrite del_head_spec_small; [|now rewrite rev_spec, List.length_rev]. - rewrite del_head_spec_small; [|now apply Nat.le_sub_l]. - rewrite rev_spec. - set (n' := _ - n). - assert (Hn' : n = length (to_list d) - n'). - { now rewrite <- (Nat.add_sub (length (to_list d)) n), Nat.add_comm, - <- 2 Nat.add_sub_assoc, Nat.sub_diag; trivial. } - now rewrite Hn', <-List.firstn_skipn_rev, List.firstn_skipn, of_list_to_list. -Qed. - -Lemma app_int_del_tail_head n (d:int) : - n <= nb_digits (abs d) -> - app_int (del_tail_int n d) (del_head (nb_digits (abs d) - n) (abs d)) = d. -Proof. now case d; clear d; simpl; intros u Hu; rewrite app_del_tail_head. Qed. - -Lemma del_head_app_int_exact i f : - nb_digits f < nb_digits (unorm (app (abs i) f)) -> - del_head (nb_digits (unorm (app (abs i) f)) - nb_digits f) (unorm (app (abs i) f)) = f. -Proof. - simpl; intro Hnb; generalize Hnb; rewrite (unorm_app_l _ _ Hnb); clear Hnb. - replace (_ - _) with (nb_digits (unorm (abs i))). - - now rewrite del_head_app; [rewrite del_head_nb_digits|]. - - rewrite !nb_digits_spec, app_spec, List.length_app. - symmetry; apply Nat.add_sub. -Qed. - -Lemma del_tail_app_int_exact i f : - nb_digits f < nb_digits (unorm (app (abs i) f)) -> - del_tail_int (nb_digits f) (norm (app_int i f)) = norm i. -Proof. - simpl; intro Hnb. - rewrite (norm_app_int _ _ Hnb). - rewrite del_tail_app_int; [|now simpl]. - now rewrite del_tail_nb_digits, app_int_nil_r. -Qed. - -(** Normalization on little-endian numbers *) - -Fixpoint nztail d := - match d with - | Nil => Nil - | D0 d => match nztail d with Nil => Nil | d' => D0 d' end - | D1 d => D1 (nztail d) - | D2 d => D2 (nztail d) - | D3 d => D3 (nztail d) - | D4 d => D4 (nztail d) - | D5 d => D5 (nztail d) - | D6 d => D6 (nztail d) - | D7 d => D7 (nztail d) - | D8 d => D8 (nztail d) - | D9 d => D9 (nztail d) - end. - -Definition lnorm d := - match nztail d with - | Nil => zero - | d => d - end. - -Lemma nzhead_revapp_0 d d' : nztail d = Nil -> - nzhead (revapp d d') = nzhead d'. -Proof. - revert d'. induction d; intros d' [=]; simpl; trivial. - destruct (nztail d); now rewrite IHd. -Qed. - -Lemma nzhead_revapp d d' : nztail d <> Nil -> - nzhead (revapp d d') = revapp (nztail d) d'. -Proof. - revert d'. - induction d; intros d' H; simpl in *; - try destruct (nztail d) eqn:E; - (rewrite IHd;[reflexivity|discriminate]) || (now rewrite ?nzhead_revapp_0). -Qed. - -Lemma nzhead_rev d : nztail d <> Nil -> - nzhead (rev d) = rev (nztail d). -Proof. - apply nzhead_revapp. -Qed. - -Lemma rev_rev d : rev (rev d) = d. -Proof. now apply to_list_inj; rewrite !rev_spec, List.rev_involutive. Qed. - -Lemma rev_nztail_rev d : - rev (nztail (rev d)) = nzhead d. -Proof. - destruct (uint_eq_dec (nztail (rev d)) Nil) as [H|H]. - - rewrite H. unfold rev; simpl. - rewrite <- (rev_rev d). symmetry. - now apply nzhead_revapp_0. - - now rewrite <- nzhead_rev, rev_rev. -Qed. - -Lemma nzhead_D0 u : nzhead (D0 u) = nzhead u. -Proof. reflexivity. Qed. - -Lemma nzhead_iter_D0 n u : nzhead (Nat.iter n D0 u) = nzhead u. -Proof. now induction n. Qed. - -Lemma revapp_nil_inv d d' : revapp d d' = Nil -> d = Nil /\ d' = Nil. -Proof. - revert d'. - induction d; simpl; intros d' H; auto; now apply IHd in H. -Qed. - -Lemma rev_nil_inv d : rev d = Nil -> d = Nil. -Proof. - apply revapp_nil_inv. -Qed. - -Lemma rev_lnorm_rev d : - rev (lnorm (rev d)) = unorm d. -Proof. - unfold unorm, lnorm. - rewrite <- rev_nztail_rev. - destruct nztail; simpl; trivial; - destruct rev eqn:E; trivial; now apply rev_nil_inv in E. -Qed. - -Lemma nzhead_nonzero d d' : nzhead d <> D0 d'. -Proof. - induction d; easy. -Qed. - -Lemma unorm_0 d : unorm d = zero <-> nzhead d = Nil. -Proof. - unfold unorm. split. - - generalize (nzhead_nonzero d). - destruct nzhead; intros H [=]; trivial. now destruct (H u). - - now intros ->. -Qed. - -Lemma unorm_nonnil d : unorm d <> Nil. -Proof. - unfold unorm. now destruct nzhead. -Qed. - -Lemma unorm_iter_D0 n u : unorm (Nat.iter n D0 u) = unorm u. -Proof. now induction n. Qed. - -Lemma del_head_nonnil n u : - n < nb_digits u -> del_head n u <> Nil. -Proof. - now revert n; induction u; intro n; - [|case n; [|intro n'; simpl; intro H; apply IHu, Nat.succ_lt_mono]..]. -Qed. - -Lemma del_tail_nonnil n u : - n < nb_digits u -> del_tail n u <> Nil. -Proof. - unfold del_tail. - rewrite <-nb_digits_rev. - generalize (rev u); clear u; intro u. - intros Hu H. - generalize (rev_nil_inv _ H); clear H. - now apply del_head_nonnil. -Qed. - -Lemma nzhead_involutive d : nzhead (nzhead d) = nzhead d. -Proof. - now induction d. -Qed. - -Lemma nztail_involutive d : nztail (nztail d) = nztail d. -Proof. - rewrite <-(rev_rev (nztail _)), <-(rev_rev (nztail d)), <-(rev_rev d). - now rewrite !rev_nztail_rev, nzhead_involutive. -Qed. - -Lemma unorm_involutive d : unorm (unorm d) = unorm d. -Proof. - unfold unorm. - destruct (nzhead d) eqn:E; trivial. - destruct (nzhead_nonzero _ _ E). -Qed. - -Lemma norm_involutive d : norm (norm d) = norm d. -Proof. - unfold norm. - destruct d. - - f_equal. apply unorm_involutive. - - destruct (nzhead d) eqn:E; auto. - destruct (nzhead_nonzero _ _ E). -Qed. - -Lemma lnzhead_neq_d0_head l l' : ~(lnzhead l = cons d0 l'). -Proof. now induction l as [|h t Il]; [|case h]. Qed. - -Lemma lnzhead_head_nd0 h t : h <> d0 -> lnzhead (cons h t) = cons h t. -Proof. now case h. Qed. - -Lemma nzhead_del_tail_nzhead_eq n u : - nzhead u = u -> - n < nb_digits u -> - nzhead (del_tail n u) = del_tail n u. -Proof. - rewrite nb_digits_spec, <-List.length_rev. - intros Hu Hn. - apply to_list_inj; unfold del_tail. - rewrite nzhead_spec, rev_spec. - rewrite del_head_spec_small; [|now rewrite rev_spec; apply Nat.lt_le_incl]. - rewrite rev_spec. - rewrite List.skipn_rev, List.rev_involutive. - generalize (f_equal to_list Hu) Hn; rewrite nzhead_spec; intro Hu'. - case (to_list u) as [|h t]. - { simpl; intro H; exfalso; revert H; apply Nat.le_ngt, Nat.le_0_l. } - intro Hn'; generalize (Nat.sub_gt _ _ Hn'); rewrite List.length_rev. - case (_ - _); [now simpl|]; intros n' _. - rewrite List.firstn_cons, lnzhead_head_nd0; [now simpl|]. - intro Hh; revert Hu'; rewrite Hh; apply lnzhead_neq_d0_head. -Qed. - -Lemma nzhead_del_tail_nzhead n u : - n < nb_digits (nzhead u) -> - nzhead (del_tail n (nzhead u)) = del_tail n (nzhead u). -Proof. apply nzhead_del_tail_nzhead_eq, nzhead_involutive. Qed. - -Lemma unorm_del_tail_unorm n u : - n < nb_digits (unorm u) -> - unorm (del_tail n (unorm u)) = del_tail n (unorm u). -Proof. - case (uint_eq_dec (nzhead u) Nil). - - unfold unorm; intros->; case n; [now simpl|]; intro n'. - now simpl; intro H; exfalso; generalize (proj2 (Nat.succ_lt_mono _ _) H). - - unfold unorm. - set (m := match nzhead u with Nil => zero | _ => _ end). - intros H. - replace m with (nzhead u). - + intros H'. - rewrite (nzhead_del_tail_nzhead _ _ H'). - now generalize (del_tail_nonnil _ _ H'); case del_tail. - + now unfold m; revert H; case nzhead. -Qed. - -Lemma norm_del_tail_int_norm n d : - n < nb_digits (match norm d with Pos d | Neg d => d end) -> - norm (del_tail_int n (norm d)) = del_tail_int n (norm d). -Proof. - case d; clear d; intros u; simpl. - - now intro H; simpl; rewrite unorm_del_tail_unorm. - - case (uint_eq_dec (nzhead u) Nil); intro Hu. - + now rewrite Hu; case n; [|intros n' Hn'; generalize (proj2 (Nat.succ_lt_mono _ _) Hn')]. - + set (m := match nzhead u with Nil => Pos zero | _ => _ end). - replace m with (Neg (nzhead u)); [|now unfold m; revert Hu; case nzhead]. - unfold del_tail_int. - clear m Hu. - simpl. - intro H; generalize (del_tail_nonnil _ _ H). - rewrite (nzhead_del_tail_nzhead _ _ H). - now case del_tail. -Qed. - -Lemma nzhead_app_nzhead d d' : - nzhead (app (nzhead d) d') = nzhead (app d d'). -Proof. - unfold app. - rewrite <-(rev_nztail_rev d), rev_rev. - generalize (rev d); clear d; intro d. - generalize (nzhead_revapp_0 d d'). - generalize (nzhead_revapp d d'). - generalize (nzhead_revapp_0 (nztail d) d'). - generalize (nzhead_revapp (nztail d) d'). - rewrite nztail_involutive. - now case nztail; - [intros _ H _ H'; rewrite (H eq_refl), (H' eq_refl) - |intros d'' H _ H' _; rewrite H; [rewrite H'|]..]. -Qed. - -Lemma unorm_app_unorm d d' : - unorm (app (unorm d) d') = unorm (app d d'). -Proof. - unfold unorm. - rewrite <-(nzhead_app_nzhead d d'). - now case (nzhead d). -Qed. - -Lemma norm_app_int_norm d d' : - unorm d' = zero -> - norm (app_int (norm d) d') = norm (app_int d d'). -Proof. - case d; clear d; intro d; simpl. - - now rewrite unorm_app_unorm. - - unfold app_int, app. - rewrite unorm_0; intro Hd'. - rewrite <-rev_nztail_rev. - generalize (nzhead_revapp (rev d) d'). - generalize (nzhead_revapp_0 (rev d) d'). - now case_eq (nztail (rev d)); - [intros Hd'' H _; rewrite (H eq_refl); simpl; - unfold unorm; simpl; rewrite Hd' - |intros d'' Hd'' _ H; rewrite H; clear H; [|now simpl]; - set (r := rev _); - set (m := match r with Nil => Pos zero | _ => _ end); - assert (H' : m = Neg r); - [now unfold m; case_eq r; unfold r; - [intro H''; generalize (rev_nil_inv _ H'')|..] - |rewrite H'; unfold r; clear m r H']; - unfold norm; - rewrite rev_rev, <-Hd''; - rewrite nzhead_revapp; rewrite nztail_involutive; [|rewrite Hd'']..]. -Qed. - -Lemma unorm_app_l_nil d d' : nzhead d = Nil -> unorm (app d d') = unorm d'. -Proof. - now unfold unorm; rewrite <-nzhead_app_nzhead; intros->; rewrite app_nil_l. -Qed. diff --git a/stdlib/theories/Numbers/DecimalN.v b/stdlib/theories/Numbers/DecimalN.v deleted file mode 100644 index 8d759c15f7a7..000000000000 --- a/stdlib/theories/Numbers/DecimalN.v +++ /dev/null @@ -1,109 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* n = n'. -Proof. - intros E. now rewrite <- (of_to n), <- (of_to n'), E. -Qed. - -Lemma to_uint_surj d : exists p, N.to_uint p = unorm d. -Proof. - exists (N.of_uint d). apply to_of. -Qed. - -Lemma of_uint_norm d : N.of_uint (unorm d) = N.of_uint d. -Proof. - now induction d. -Qed. - -Lemma of_inj d d' : - N.of_uint d = N.of_uint d' -> unorm d = unorm d'. -Proof. - intros. rewrite <- !to_of. now f_equal. -Qed. - -Lemma of_iff d d' : N.of_uint d = N.of_uint d' <-> unorm d = unorm d'. -Proof. - split. - - apply of_inj. - - intros E. rewrite <- of_uint_norm, E. - apply of_uint_norm. -Qed. - -End Unsigned. - -(** Conversion from/to signed decimal numbers *) - -Module Signed. - -Lemma of_to (n:N) : N.of_int (N.to_int n) = Some n. -Proof. - unfold N.to_int, N.of_int, norm. f_equal. - rewrite Unsigned.of_uint_norm. apply Unsigned.of_to. -Qed. - -Lemma to_of (d:int)(n:N) : N.of_int d = Some n -> N.to_int n = norm d. -Proof. - unfold N.of_int. - destruct (norm d) eqn:Hd; intros [= <-]. - unfold N.to_int. rewrite Unsigned.to_of. f_equal. - revert Hd; destruct d; simpl. - - intros [= <-]. apply unorm_involutive. - - destruct (nzhead d); now intros [= <-]. -Qed. - -Lemma to_int_inj n n' : N.to_int n = N.to_int n' -> n = n'. -Proof. - intro E. - assert (E' : Some n = Some n'). - { now rewrite <- (of_to n), <- (of_to n'), E. } - now injection E'. -Qed. - -Lemma to_int_pos_surj d : exists n, N.to_int n = norm (Pos d). -Proof. - exists (N.of_uint d). unfold N.to_int. now rewrite Unsigned.to_of. -Qed. - -Lemma of_int_norm d : N.of_int (norm d) = N.of_int d. -Proof. - unfold N.of_int. now rewrite norm_involutive. -Qed. - -Lemma of_inj_pos d d' : - N.of_int (Pos d) = N.of_int (Pos d') -> unorm d = unorm d'. -Proof. - unfold N.of_int. simpl. intros [= H]. apply Unsigned.of_inj. - change Pos.of_uint with N.of_uint in H. - now rewrite <- Unsigned.of_uint_norm, H, Unsigned.of_uint_norm. -Qed. - -End Signed. diff --git a/stdlib/theories/Numbers/DecimalNat.v b/stdlib/theories/Numbers/DecimalNat.v deleted file mode 100644 index cfd0fb92252a..000000000000 --- a/stdlib/theories/Numbers/DecimalNat.v +++ /dev/null @@ -1,304 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* 0 - | D0 _ => 0 - | D1 _ => 1 - | D2 _ => 2 - | D3 _ => 3 - | D4 _ => 4 - | D5 _ => 5 - | D6 _ => 6 - | D7 _ => 7 - | D8 _ => 8 - | D9 _ => 9 - end. - -Definition tl d := - match d with - | Nil => d - | D0 d | D1 d | D2 d | D3 d | D4 d | D5 d | D6 d | D7 d | D8 d | D9 d => d - end. - -Fixpoint usize (d:uint) : nat := - match d with - | Nil => 0 - | D0 d => S (usize d) - | D1 d => S (usize d) - | D2 d => S (usize d) - | D3 d => S (usize d) - | D4 d => S (usize d) - | D5 d => S (usize d) - | D6 d => S (usize d) - | D7 d => S (usize d) - | D8 d => S (usize d) - | D9 d => S (usize d) - end. - -(** A direct version of [to_little_uint], not tail-recursive *) -Fixpoint to_lu n := - match n with - | 0 => Decimal.zero - | S n => Little.succ (to_lu n) - end. - -(** A direct version of [of_little_uint] *) -Fixpoint of_lu (d:uint) : nat := - match d with - | Nil => 0 - | D0 d => 10 * of_lu d - | D1 d => 1 + 10 * of_lu d - | D2 d => 2 + 10 * of_lu d - | D3 d => 3 + 10 * of_lu d - | D4 d => 4 + 10 * of_lu d - | D5 d => 5 + 10 * of_lu d - | D6 d => 6 + 10 * of_lu d - | D7 d => 7 + 10 * of_lu d - | D8 d => 8 + 10 * of_lu d - | D9 d => 9 + 10 * of_lu d - end. - -(** Properties of [to_lu] *) - -Lemma to_lu_succ n : to_lu (S n) = Little.succ (to_lu n). -Proof. - reflexivity. -Qed. - -Lemma to_little_uint_succ n d : - Nat.to_little_uint n (Little.succ d) = - Little.succ (Nat.to_little_uint n d). -Proof. - revert d; induction n; simpl; trivial. -Qed. - -Lemma to_lu_equiv n : - to_lu n = Nat.to_little_uint n zero. -Proof. - induction n; simpl; trivial. - now rewrite IHn, <- to_little_uint_succ. -Qed. - -Lemma to_uint_alt n : - Nat.to_uint n = rev (to_lu n). -Proof. - unfold Nat.to_uint. f_equal. symmetry. apply to_lu_equiv. -Qed. - -(** Properties of [of_lu] *) - -Lemma of_lu_eqn d : - of_lu d = hd d + 10 * of_lu (tl d). -Proof. - induction d; simpl; trivial. -Qed. - -Ltac simpl_of_lu := - match goal with - | |- context [ of_lu (?f ?x) ] => - rewrite (of_lu_eqn (f x)); simpl hd; simpl tl - end. - -Lemma of_lu_succ d : - of_lu (Little.succ d) = S (of_lu d). -Proof. - induction d; trivial. - simpl_of_lu. rewrite IHd. simpl_of_lu. - now rewrite Nat.mul_succ_r, <- (Nat.add_comm 10). -Qed. - -Lemma of_to_lu n : - of_lu (to_lu n) = n. -Proof. - induction n; simpl; trivial. rewrite of_lu_succ. now f_equal. -Qed. - -Lemma of_lu_revapp d d' : - of_lu (revapp d d') = - of_lu (rev d) + of_lu d' * 10^usize d. -Proof. - revert d'. - induction d; intro d'; simpl usize; - [ simpl; now rewrite Nat.mul_1_r | .. ]; - unfold rev; simpl revapp; rewrite 2 IHd; - rewrite <- Nat.add_assoc; f_equal; simpl_of_lu; simpl of_lu; - rewrite Nat.pow_succ_r'; ring. -Qed. - -Lemma of_uint_acc_spec n d : - Nat.of_uint_acc d n = of_lu (rev d) + n * 10^usize d. -Proof. - revert n. induction d; intros; - simpl Nat.of_uint_acc; rewrite ?Nat.tail_mul_spec, ?IHd; - simpl rev; simpl usize; rewrite ?Nat.pow_succ_r'; - [ simpl; now rewrite Nat.mul_1_r | .. ]; - unfold rev at 2; simpl revapp; rewrite of_lu_revapp; - simpl of_lu; ring. -Qed. - -Lemma of_uint_alt d : Nat.of_uint d = of_lu (rev d). -Proof. - unfold Nat.of_uint. now rewrite of_uint_acc_spec. -Qed. - -(** First main bijection result *) - -Lemma of_to (n:nat) : Nat.of_uint (Nat.to_uint n) = n. -Proof. - rewrite to_uint_alt, of_uint_alt, rev_rev. apply of_to_lu. -Qed. - -(** The other direction *) - -Lemma to_lu_tenfold n : n<>0 -> - to_lu (10 * n) = D0 (to_lu n). -Proof. - induction n. - - simpl. now destruct 1. - - intros _. - destruct (Nat.eq_dec n 0) as [->|H]; simpl; trivial. - rewrite !Nat.add_succ_r. - simpl in *. rewrite (IHn H). now destruct (to_lu n). -Qed. - -Lemma of_lu_0 d : of_lu d = 0 <-> nztail d = Nil. -Proof. - induction d; try simpl_of_lu; try easy. - rewrite Nat.add_0_l. - split; intros H. - - apply Nat.eq_mul_0_r in H; auto. - rewrite IHd in H. simpl. now rewrite H. - - simpl in H. destruct (nztail d); try discriminate. - now destruct IHd as [_ ->]. -Qed. - -Lemma to_of_lu_tenfold d : - to_lu (of_lu d) = lnorm d -> - to_lu (10 * of_lu d) = lnorm (D0 d). -Proof. - intro IH. - destruct (Nat.eq_dec (of_lu d) 0) as [H|H]. - - rewrite H. simpl. rewrite of_lu_0 in H. - unfold lnorm. simpl. now rewrite H. - - rewrite (to_lu_tenfold _ H), IH. - rewrite of_lu_0 in H. - unfold lnorm. simpl. now destruct (nztail d). -Qed. - -Lemma to_of_lu d : to_lu (of_lu d) = lnorm d. -Proof. - induction d; [ reflexivity | .. ]; - simpl_of_lu; - rewrite ?Nat.add_succ_l, Nat.add_0_l, ?to_lu_succ, to_of_lu_tenfold - by assumption; - unfold lnorm; simpl; now destruct nztail. -Qed. - -(** Second bijection result *) - -Lemma to_of (d:uint) : Nat.to_uint (Nat.of_uint d) = unorm d. -Proof. - rewrite to_uint_alt, of_uint_alt, to_of_lu. - apply rev_lnorm_rev. -Qed. - -(** Some consequences *) - -Lemma to_uint_inj n n' : Nat.to_uint n = Nat.to_uint n' -> n = n'. -Proof. - intro EQ. - now rewrite <- (of_to n), <- (of_to n'), EQ. -Qed. - -Lemma to_uint_surj d : exists n, Nat.to_uint n = unorm d. -Proof. - exists (Nat.of_uint d). apply to_of. -Qed. - -Lemma of_uint_norm d : Nat.of_uint (unorm d) = Nat.of_uint d. -Proof. - unfold Nat.of_uint. now induction d. -Qed. - -Lemma of_inj d d' : - Nat.of_uint d = Nat.of_uint d' -> unorm d = unorm d'. -Proof. - intros. rewrite <- !to_of. now f_equal. -Qed. - -Lemma of_iff d d' : Nat.of_uint d = Nat.of_uint d' <-> unorm d = unorm d'. -Proof. - split. - - apply of_inj. - - intros E. rewrite <- of_uint_norm, E. - apply of_uint_norm. -Qed. - -End Unsigned. - -(** Conversion from/to signed decimal numbers *) - -Module Signed. - -Lemma of_to (n:nat) : Nat.of_int (Nat.to_int n) = Some n. -Proof. - unfold Nat.to_int, Nat.of_int, norm. f_equal. - rewrite Unsigned.of_uint_norm. apply Unsigned.of_to. -Qed. - -Lemma to_of (d:int)(n:nat) : Nat.of_int d = Some n -> Nat.to_int n = norm d. -Proof. - unfold Nat.of_int. - destruct (norm d) eqn:Hd; intros [= <-]. - unfold Nat.to_int. rewrite Unsigned.to_of. f_equal. - revert Hd; destruct d; simpl. - - intros [= <-]. apply unorm_involutive. - - destruct (nzhead d); now intros [= <-]. -Qed. - -Lemma to_int_inj n n' : Nat.to_int n = Nat.to_int n' -> n = n'. -Proof. - intro E. - assert (E' : Some n = Some n'). - { now rewrite <- (of_to n), <- (of_to n'), E. } - now injection E'. -Qed. - -Lemma to_int_pos_surj d : exists n, Nat.to_int n = norm (Pos d). -Proof. - exists (Nat.of_uint d). unfold Nat.to_int. now rewrite Unsigned.to_of. -Qed. - -Lemma of_int_norm d : Nat.of_int (norm d) = Nat.of_int d. -Proof. - unfold Nat.of_int. now rewrite norm_involutive. -Qed. - -Lemma of_inj_pos d d' : - Nat.of_int (Pos d) = Nat.of_int (Pos d') -> unorm d = unorm d'. -Proof. - unfold Nat.of_int. simpl. intros [= H]. apply Unsigned.of_inj. - now rewrite <- Unsigned.of_uint_norm, H, Unsigned.of_uint_norm. -Qed. - -End Signed. diff --git a/stdlib/theories/Numbers/DecimalPos.v b/stdlib/theories/Numbers/DecimalPos.v deleted file mode 100644 index 7b7f2d65fc65..000000000000 --- a/stdlib/theories/Numbers/DecimalPos.v +++ /dev/null @@ -1,400 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* 0 - | D0 d => 10 * of_lu d - | D1 d => 1 + 10 * of_lu d - | D2 d => 2 + 10 * of_lu d - | D3 d => 3 + 10 * of_lu d - | D4 d => 4 + 10 * of_lu d - | D5 d => 5 + 10 * of_lu d - | D6 d => 6 + 10 * of_lu d - | D7 d => 7 + 10 * of_lu d - | D8 d => 8 + 10 * of_lu d - | D9 d => 9 + 10 * of_lu d - end. - -Definition hd d := - match d with - | Nil => 0 - | D0 _ => 0 - | D1 _ => 1 - | D2 _ => 2 - | D3 _ => 3 - | D4 _ => 4 - | D5 _ => 5 - | D6 _ => 6 - | D7 _ => 7 - | D8 _ => 8 - | D9 _ => 9 - end. - -Definition tl d := - match d with - | Nil => d - | D0 d | D1 d | D2 d | D3 d | D4 d | D5 d | D6 d | D7 d | D8 d | D9 d => d - end. - -Lemma of_lu_eqn d : - of_lu d = hd d + 10 * (of_lu (tl d)). -Proof. - induction d; simpl; trivial. -Qed. - -Ltac simpl_of_lu := - match goal with - | |- context [ of_lu (?f ?x) ] => - rewrite (of_lu_eqn (f x)); simpl hd; simpl tl - end. - -Fixpoint usize (d:uint) : N := - match d with - | Nil => 0 - | D0 d => N.succ (usize d) - | D1 d => N.succ (usize d) - | D2 d => N.succ (usize d) - | D3 d => N.succ (usize d) - | D4 d => N.succ (usize d) - | D5 d => N.succ (usize d) - | D6 d => N.succ (usize d) - | D7 d => N.succ (usize d) - | D8 d => N.succ (usize d) - | D9 d => N.succ (usize d) - end. - -Lemma of_lu_revapp d d' : - of_lu (revapp d d') = - of_lu (rev d) + of_lu d' * 10^usize d. -Proof. - revert d'. - induction d; simpl; intro d'; [ now rewrite N.mul_1_r | .. ]; - unfold rev; simpl revapp; rewrite 2 IHd; - rewrite <- N.add_assoc; f_equal; simpl_of_lu; simpl of_lu; - rewrite N.pow_succ_r'; ring. -Qed. - -Definition Nadd n p := - match n with - | N0 => p - | Npos p0 => (p0+p)%positive - end. - -Lemma Nadd_simpl n p q : Npos (Nadd n (p * q)) = n + Npos p * Npos q. -Proof. - now destruct n. -Qed. - -Lemma of_uint_acc_eqn d acc : d<>Nil -> - Pos.of_uint_acc d acc = Pos.of_uint_acc (tl d) (Nadd (hd d) (10*acc)). -Proof. - destruct d; simpl; trivial. now destruct 1. -Qed. - -Lemma of_uint_acc_rev d acc : - Npos (Pos.of_uint_acc d acc) = - of_lu (rev d) + (Npos acc) * 10^usize d. -Proof. - revert acc. - induction d; intros; simpl usize; - [ simpl; now rewrite Pos.mul_1_r | .. ]; - rewrite N.pow_succ_r'; - unfold rev; simpl revapp; try rewrite of_lu_revapp; simpl of_lu; - rewrite of_uint_acc_eqn by easy; simpl tl; simpl hd; - rewrite IHd, Nadd_simpl; ring. -Qed. - -Lemma of_uint_alt d : Pos.of_uint d = of_lu (rev d). -Proof. - induction d; simpl; trivial; unfold rev; simpl revapp; - rewrite of_lu_revapp; simpl of_lu; try apply of_uint_acc_rev. - rewrite IHd. ring. -Qed. - -Lemma of_lu_rev d : Pos.of_uint (rev d) = of_lu d. -Proof. - rewrite of_uint_alt. now rewrite rev_rev. -Qed. - -Lemma of_lu_double_gen d : - of_lu (Little.double d) = N.double (of_lu d) /\ - of_lu (Little.succ_double d) = N.succ_double (of_lu d). -Proof. - rewrite N.double_spec, N.succ_double_spec. - induction d; try destruct IHd as (IH1,IH2); - simpl Little.double; simpl Little.succ_double; - repeat (simpl_of_lu; rewrite ?IH1, ?IH2); split; reflexivity || ring. -Qed. - -Lemma of_lu_double d : - of_lu (Little.double d) = N.double (of_lu d). -Proof. - apply of_lu_double_gen. -Qed. - -Lemma of_lu_succ_double d : - of_lu (Little.succ_double d) = N.succ_double (of_lu d). -Proof. - apply of_lu_double_gen. -Qed. - -(** First bijection result *) - -Lemma of_to (p:positive) : Pos.of_uint (Pos.to_uint p) = Npos p. -Proof. - unfold Pos.to_uint. - rewrite of_lu_rev. - induction p; simpl; trivial. - - now rewrite of_lu_succ_double, IHp. - - now rewrite of_lu_double, IHp. -Qed. - -(** The other direction *) - -Definition to_lu n := - match n with - | N0 => Decimal.zero - | Npos p => Pos.to_little_uint p - end. - -Lemma succ_double_alt d : - Little.succ_double d = Little.succ (Little.double d). -Proof. - now induction d. -Qed. - -Lemma double_succ d : - Little.double (Little.succ d) = - Little.succ (Little.succ_double d). -Proof. - induction d; simpl; f_equal; auto using succ_double_alt. -Qed. - -Lemma to_lu_succ n : - to_lu (N.succ n) = Little.succ (to_lu n). -Proof. - destruct n; simpl; trivial. - induction p; simpl; rewrite ?IHp; - auto using succ_double_alt, double_succ. -Qed. - -Lemma nat_iter_S n {A} (f:A->A) i : - Nat.iter (S n) f i = f (Nat.iter n f i). -Proof. - reflexivity. -Qed. - -Lemma nat_iter_0 {A} (f:A->A) i : Nat.iter 0 f i = i. -Proof. - reflexivity. -Qed. - -Lemma to_ldec_tenfold p : - to_lu (10 * Npos p) = D0 (to_lu (Npos p)). -Proof. - induction p using Pos.peano_rect. - - trivial. - - change (N.pos (Pos.succ p)) with (N.succ (N.pos p)). - rewrite N.mul_succ_r. - change 10 with (Nat.iter 10%nat N.succ 0) at 2. - rewrite ?nat_iter_S, nat_iter_0. - rewrite !N.add_succ_r, N.add_0_r, !to_lu_succ, IHp. - destruct (to_lu (N.pos p)); simpl; auto. -Qed. - -Lemma of_lu_0 d : of_lu d = 0 <-> nztail d = Nil. -Proof. - induction d; try simpl_of_lu; split; trivial; try discriminate; - try (intros H; now apply N.eq_add_0 in H). - - rewrite N.add_0_l. intros H. - apply N.eq_mul_0_r in H; [|easy]. rewrite IHd in H. - simpl. now rewrite H. - - simpl. destruct (nztail d); try discriminate. - now destruct IHd as [_ ->]. - Qed. - -Lemma to_of_lu_tenfold d : - to_lu (of_lu d) = lnorm d -> - to_lu (10 * of_lu d) = lnorm (D0 d). -Proof. - intro IH. - destruct (N.eq_dec (of_lu d) 0) as [H|H]. - - rewrite H. simpl. rewrite of_lu_0 in H. - unfold lnorm. simpl. now rewrite H. - - destruct (of_lu d) eqn:Eq; [easy| ]. - rewrite to_ldec_tenfold; auto. rewrite IH. - rewrite <- Eq in H. rewrite of_lu_0 in H. - unfold lnorm. simpl. now destruct (nztail d). -Qed. - -Lemma Nadd_alt n m : n + m = Nat.iter (N.to_nat n) N.succ m. -Proof. - destruct n. 1:trivial. - induction p using Pos.peano_rect. - - now rewrite N.add_1_l. - - change (N.pos (Pos.succ p)) with (N.succ (N.pos p)). - now rewrite N.add_succ_l, IHp, N2Nat.inj_succ. -Qed. - -Ltac simpl_to_nat := simpl N.to_nat; unfold Pos.to_nat; simpl Pos.iter_op. - -Lemma to_of_lu d : to_lu (of_lu d) = lnorm d. -Proof. - induction d; [reflexivity|..]; - simpl_of_lu; rewrite Nadd_alt; simpl_to_nat; - rewrite ?nat_iter_S, nat_iter_0, ?to_lu_succ, to_of_lu_tenfold by assumption; - unfold lnorm; simpl; destruct nztail; auto. -Qed. - -(** Second bijection result *) - -Lemma to_of (d:uint) : N.to_uint (Pos.of_uint d) = unorm d. -Proof. - rewrite of_uint_alt. - unfold N.to_uint, Pos.to_uint. - destruct (of_lu (rev d)) eqn:H. - - rewrite of_lu_0 in H. rewrite <- rev_lnorm_rev. - unfold lnorm. now rewrite H. - - change (Pos.to_little_uint p) with (to_lu (N.pos p)). - rewrite <- H. rewrite to_of_lu. apply rev_lnorm_rev. -Qed. - -(** Some consequences *) - -Lemma to_uint_nonzero p : Pos.to_uint p <> zero. -Proof. - intro E. generalize (of_to p). now rewrite E. -Qed. - -Lemma to_uint_nonnil p : Pos.to_uint p <> Nil. -Proof. - intros E. generalize (of_to p). now rewrite E. -Qed. - -Lemma to_uint_inj p p' : Pos.to_uint p = Pos.to_uint p' -> p = p'. -Proof. - intro E. - assert (E' : N.pos p = N.pos p'). - { now rewrite <- (of_to p), <- (of_to p'), E. } - now injection E'. -Qed. - -Lemma to_uint_pos_surj d : - unorm d<>zero -> exists p, Pos.to_uint p = unorm d. -Proof. - intros. - destruct (Pos.of_uint d) eqn:E. - - destruct H. generalize (to_of d). now rewrite E. - - exists p. generalize (to_of d). now rewrite E. -Qed. - -Lemma of_uint_norm d : Pos.of_uint (unorm d) = Pos.of_uint d. -Proof. - now induction d. -Qed. - -Lemma of_inj d d' : - Pos.of_uint d = Pos.of_uint d' -> unorm d = unorm d'. -Proof. - intros. rewrite <- !to_of. now f_equal. -Qed. - -Lemma of_iff d d' : Pos.of_uint d = Pos.of_uint d' <-> unorm d = unorm d'. -Proof. - split. - - apply of_inj. - - intros E. rewrite <- of_uint_norm, E. - apply of_uint_norm. -Qed. - -Lemma nztail_to_uint p : - let (h, n) := Decimal.nztail (Pos.to_uint p) in - Npos p = Pos.of_uint h * 10^(N.of_nat n). -Proof. - rewrite <-(of_to p), <-(rev_rev (Pos.to_uint p)), of_lu_rev. - unfold Decimal.nztail. - rewrite rev_rev. - induction (rev (Pos.to_uint p)); [reflexivity| | - now simpl N.of_nat; simpl N.pow; rewrite N.mul_1_r, of_lu_rev..]. - revert IHu. - set (t := _ u); case t; clear t; intros u0 n H. - rewrite of_lu_eqn; unfold hd, tl. - rewrite N.add_0_l, H, Nat2N.inj_succ, N.pow_succ_r'; ring. -Qed. - -End Unsigned. - -(** Conversion from/to signed decimal numbers *) - -Module Signed. - -Lemma of_to (p:positive) : Pos.of_int (Pos.to_int p) = Some p. -Proof. - unfold Pos.to_int, Pos.of_int, norm. - now rewrite Unsigned.of_to. -Qed. - -Lemma to_of (d:int)(p:positive) : - Pos.of_int d = Some p -> Pos.to_int p = norm d. -Proof. - unfold Pos.of_int. - destruct d; [ | intros [=]]. - simpl norm. rewrite <- Unsigned.to_of. - destruct (Pos.of_uint d); now intros [= <-]. -Qed. - -Lemma to_int_inj p p' : Pos.to_int p = Pos.to_int p' -> p = p'. -Proof. - intro E. - assert (E' : Some p = Some p'). - { now rewrite <- (of_to p), <- (of_to p'), E. } - now injection E'. -Qed. - -Lemma to_int_pos_surj d : - unorm d <> zero -> exists p, Pos.to_int p = norm (Pos d). -Proof. - simpl. unfold Pos.to_int. intros H. - destruct (Unsigned.to_uint_pos_surj d H) as (p,Hp). - exists p. now f_equal. -Qed. - -Lemma of_int_norm d : Pos.of_int (norm d) = Pos.of_int d. -Proof. - unfold Pos.of_int. - destruct d. - - simpl. now rewrite Unsigned.of_uint_norm. - - simpl. now destruct (nzhead d) eqn:H. -Qed. - -Lemma of_inj_pos d d' : - Pos.of_int (Pos d) = Pos.of_int (Pos d') -> unorm d = unorm d'. -Proof. - unfold Pos.of_int. - destruct (Pos.of_uint d) eqn:Hd, (Pos.of_uint d') eqn:Hd'; - intros [=]. - - apply Unsigned.of_inj; now rewrite Hd, Hd'. - - apply Unsigned.of_inj; rewrite Hd, Hd'; now f_equal. -Qed. - -End Signed. diff --git a/stdlib/theories/Numbers/DecimalQ.v b/stdlib/theories/Numbers/DecimalQ.v deleted file mode 100644 index bc9f0b1b2dab..000000000000 --- a/stdlib/theories/Numbers/DecimalQ.v +++ /dev/null @@ -1,461 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* True - | Some (DecimalExp _ _ _) => False - | Some (Decimal i f) => of_decimal (Decimal i f) = IQmake (IZ_of_Z num) den - end. -Proof. - unfold IQmake_to_decimal. - generalize (Unsigned.nztail_to_uint den). - case Decimal.nztail; intros den' e_den'. - case den'; [now simpl|now simpl| |now simpl..]; clear den'; intro den'. - case den'; [ |now simpl..]; clear den'. - case e_den' as [|e_den']; simpl; injection 1 as ->. - { now unfold of_decimal; simpl; rewrite app_int_nil_r, DecimalZ.of_to. } - replace (10 ^ _)%positive with (Nat.iter (S e_den') (Pos.mul 10) 1%positive). - 2:{ induction e_den' as [|n IHn]; [now simpl| ]. - now rewrite SuccNat2Pos.inj_succ, Pos.pow_succ_r, <-IHn. } - case Nat.ltb_spec; intro He_den'. - - unfold of_decimal; simpl. - rewrite app_int_del_tail_head; [|now apply Nat.lt_le_incl]. - rewrite DecimalZ.of_to. - now rewrite nb_digits_del_head_sub; [|now apply Nat.lt_le_incl]. - - unfold of_decimal; simpl. - rewrite nb_digits_iter_D0. - apply f_equal2. - + apply f_equal, DecimalZ.to_int_inj. - rewrite DecimalZ.to_of. - rewrite <-(DecimalZ.of_to num), DecimalZ.to_of. - case (Z.to_int num); clear He_den' num; intro num; simpl. - * unfold app; simpl. - now rewrite unorm_D0, unorm_iter_D0, unorm_involutive. - * case (uint_eq_dec (nzhead num) Nil); [|intro Hn]. - { intros->; simpl; unfold app; simpl. - now rewrite unorm_D0, unorm_iter_D0. } - replace (match nzhead num with Nil => _ | _ => _ end) - with (Neg (nzhead num)); [|now revert Hn; case nzhead]. - simpl. - rewrite nzhead_iter_D0, nzhead_involutive. - now revert Hn; case nzhead. - + revert He_den'; case nb_digits as [|n]; [now simpl; rewrite Nat.add_0_r|]. - intro Hn. - rewrite Nat.add_succ_r, Nat.sub_add; [|apply le_S_n]; auto. -Qed. - -Lemma IZ_of_Z_IZ_to_Z z z' : IZ_to_Z z = Some z' -> IZ_of_Z z' = z. -Proof. now case z as [| |p|p]; [| injection 1 as <- ..]. Qed. - -Lemma of_IQmake_to_decimal' num den : - match IQmake_to_decimal' num den with - | None => True - | Some (DecimalExp _ _ _) => False - | Some (Decimal i f) => of_decimal (Decimal i f) = IQmake num den - end. -Proof. - unfold IQmake_to_decimal'. - case_eq (IZ_to_Z num); [intros num' Hnum'|now simpl]. - generalize (of_IQmake_to_decimal num' den). - case IQmake_to_decimal as [d|]; [|now simpl]. - case d as [i f|]; [|now simpl]. - now rewrite (IZ_of_Z_IZ_to_Z _ _ Hnum'). -Qed. - -Lemma of_to (q:IQ) : forall d, to_decimal q = Some d -> of_decimal d = q. -Proof. - intro d. - case q as [num den|q q'|q q']; simpl. - - generalize (of_IQmake_to_decimal' num den). - case IQmake_to_decimal' as [d'|]; [|now simpl]. - case d' as [i f|]; [|now simpl]. - now intros H; injection 1 as <-. - - case q as [num den| |]; [|now simpl..]. - case q' as [num' den'| |]; [|now simpl..]. - case num' as [z p| | |]; [|now simpl..]. - case (Z.eq_dec z 10); [intros->|]. - 2:{ case z; [now simpl| |now simpl]; intro pz'. - case pz'; [intros d0..| ]; [now simpl| |now simpl]. - case d0; [intros d1..| ]; [ |now simpl..]. - case d1; [intros d2..| ]; [now simpl| |now simpl]. - now case d2. } - case (Pos.eq_dec den' 1%positive); [intros->|now case den']. - generalize (of_IQmake_to_decimal' num den). - case IQmake_to_decimal' as [d'|]; [|now simpl]. - case d' as [i f|]; [|now simpl]. - intros <-; clear num den. - injection 1 as <-. - unfold of_decimal; simpl. - now unfold Z.of_uint; rewrite DecimalPos.Unsigned.of_to; simpl. - - case q as [num den| |]; [|now simpl..]. - case q' as [num' den'| |]; [|now simpl..]. - case num' as [z p| | |]; [|now simpl..]. - case (Z.eq_dec z 10); [intros->|]. - 2:{ case z; [now simpl| |now simpl]; intro pz'. - case pz'; [intros d0..| ]; [now simpl| |now simpl]. - case d0; [intros d1..| ]; [ |now simpl..]. - case d1; [intros d2..| ]; [now simpl| |now simpl]. - now case d2. } - case (Pos.eq_dec den' 1%positive); [intros->|now case den']. - generalize (of_IQmake_to_decimal' num den). - case IQmake_to_decimal' as [d'|]; [|now simpl]. - case d' as [i f|]; [|now simpl]. - intros <-; clear num den. - injection 1 as <-. - unfold of_decimal; simpl. - now unfold Z.of_uint; rewrite DecimalPos.Unsigned.of_to; simpl. -Qed. - -Definition dnorm (d:decimal) : decimal := - let norm_i i f := - match i with - | Pos i => Pos (unorm i) - | Neg i => match nzhead (app i f) with Nil => Pos zero | _ => Neg (unorm i) end - end in - match d with - | Decimal i f => Decimal (norm_i i f) f - | DecimalExp i f e => - match norm e with - | Pos zero => Decimal (norm_i i f) f - | e => DecimalExp (norm_i i f) f e - end - end. - -Lemma dnorm_spec_i d : - let (i, f) := - match d with Decimal i f => (i, f) | DecimalExp i f _ => (i, f) end in - let i' := match dnorm d with Decimal i _ => i | DecimalExp i _ _ => i end in - match i with - | Pos i => i' = Pos (unorm i) - | Neg i => - (i' = Neg (unorm i) /\ (nzhead i <> Nil \/ nzhead f <> Nil)) - \/ (i' = Pos zero /\ (nzhead i = Nil /\ nzhead f = Nil)) - end. -Proof. - case d as [i f|i f e]; case i as [i|i]. - - now simpl. - - simpl; case (uint_eq_dec (nzhead (app i f)) Nil); intro Ha. - + rewrite Ha; right; split; [now simpl|split]. - * now unfold unorm; rewrite (nzhead_app_nil_l _ _ Ha). - * now unfold unorm; rewrite (nzhead_app_nil_r _ _ Ha). - + left; split; [now revert Ha; case nzhead|]. - case (uint_eq_dec (nzhead i) Nil). - * intro Hi; right; intro Hf; apply Ha. - now rewrite <-nzhead_app_nzhead, Hi, app_nil_l. - * now intro H; left. - - simpl; case (norm e); clear e; intro e; [|now simpl]. - now case e; clear e; [|intro e..]; [|case e|..]. - - simpl. - set (m := match nzhead _ with Nil => _ | _ => _ end). - set (m' := match _ with Decimal _ _ => _ | _ => _ end). - replace m' with m. - 2:{ unfold m'; case (norm e); clear m' e; intro e; [|now simpl]. - now case e; clear e; [|intro e..]; [|case e|..]. } - unfold m; case (uint_eq_dec (nzhead (app i f)) Nil); intro Ha. - + rewrite Ha; right; split; [now simpl|split]. - * now unfold unorm; rewrite (nzhead_app_nil_l _ _ Ha). - * now unfold unorm; rewrite (nzhead_app_nil_r _ _ Ha). - + left; split; [now revert Ha; case nzhead|]. - case (uint_eq_dec (nzhead i) Nil). - * intro Hi; right; intro Hf; apply Ha. - now rewrite <-nzhead_app_nzhead, Hi, app_nil_l. - * now intro H; left. -Qed. - -Lemma dnorm_spec_f d : - let f := match d with Decimal _ f => f | DecimalExp _ f _ => f end in - let f' := match dnorm d with Decimal _ f => f | DecimalExp _ f _ => f end in - f' = f. -Proof. - case d as [i f|i f e]; [now simpl|]. - simpl; case (int_eq_dec (norm e) (Pos zero)); [now intros->|intro He]. - set (i' := match i with Pos _ => _ | _ => _ end). - set (m := match norm e with Pos Nil => _ | _ => _ end). - replace m with (DecimalExp i' f (norm e)); [now simpl|]. - unfold m; revert He; case (norm e); clear m e; intro e; [|now simpl]. - now case e; clear e; [|intro e; case e|..]. -Qed. - -Lemma dnorm_spec_e d : - match d, dnorm d with - | Decimal _ _, Decimal _ _ => True - | DecimalExp _ _ e, Decimal _ _ => norm e = Pos zero - | DecimalExp _ _ e, DecimalExp _ _ e' => e' = norm e /\ e' <> Pos zero - | Decimal _ _, DecimalExp _ _ _ => False - end. -Proof. - case d as [i f|i f e]; [now simpl|]. - simpl; case (int_eq_dec (norm e) (Pos zero)); [now intros->|intro He]. - set (i' := match i with Pos _ => _ | _ => _ end). - set (m := match norm e with Pos Nil => _ | _ => _ end). - replace m with (DecimalExp i' f (norm e)); [now simpl|]. - unfold m; revert He; case (norm e); clear m e; intro e; [|now simpl]. - now case e; clear e; [|intro e; case e|..]. -Qed. - -Lemma dnorm_involutive d : dnorm (dnorm d) = dnorm d. -Proof. - case d as [i f|i f e]; case i as [i|i]. - - now simpl; rewrite unorm_involutive. - - simpl; case (uint_eq_dec (nzhead (app i f)) Nil); [now intros->|intro Ha]. - set (m := match nzhead _ with Nil =>_ | _ => _ end). - replace m with (Neg (unorm i)). - 2:{ now unfold m; revert Ha; case nzhead. } - case (uint_eq_dec (nzhead i) Nil); intro Hi. - + unfold unorm; rewrite Hi; simpl. - case (uint_eq_dec (nzhead f) Nil). - * intro Hf; exfalso; apply Ha. - now rewrite <-nzhead_app_nzhead, Hi, app_nil_l. - * now case nzhead. - + rewrite unorm_involutive, (unorm_nzhead _ Hi), nzhead_app_nzhead. - now revert Ha; case nzhead. - - simpl; case (int_eq_dec (norm e) (Pos zero)); intro He. - + now rewrite He; simpl; rewrite unorm_involutive. - + set (m := match norm e with Pos Nil => _ | _ => _ end). - replace m with (DecimalExp (Pos (unorm i)) f (norm e)). - 2:{ unfold m; revert He; case (norm e); clear m e; intro e; [|now simpl]. - now case e; clear e; [|intro e; case e|..]. } - simpl; rewrite norm_involutive, unorm_involutive. - revert He; case (norm e); clear m e; intro e; [|now simpl]. - now case e; clear e; [|intro e; case e|..]. - - simpl; case (int_eq_dec (norm e) (Pos zero)); intro He. - + rewrite He; simpl. - case (uint_eq_dec (nzhead (app i f)) Nil); [now intros->|intro Ha]. - set (m := match nzhead _ with Nil =>_ | _ => _ end). - replace m with (Neg (unorm i)). - 2:{ now unfold m; revert Ha; case nzhead. } - case (uint_eq_dec (nzhead i) Nil); intro Hi. - * unfold unorm; rewrite Hi; simpl. - case (uint_eq_dec (nzhead f) Nil). - -- intro Hf; exfalso; apply Ha. - now rewrite <-nzhead_app_nzhead, Hi, app_nil_l. - -- now case nzhead. - * rewrite unorm_involutive, (unorm_nzhead _ Hi), nzhead_app_nzhead. - now revert Ha; case nzhead. - + set (m := match norm e with Pos Nil => _ | _ => _ end). - pose (i' := match nzhead (app i f) with Nil => Pos zero | _ => Neg (unorm i) end). - replace m with (DecimalExp i' f (norm e)). - 2:{ unfold m; revert He; case (norm e); clear m e; intro e; [|now simpl]. - now case e; clear e; [|intro e; case e|..]. } - simpl; rewrite norm_involutive. - set (i'' := match i' with Pos _ => _ | _ => _ end). - clear m; set (m := match norm e with Pos Nil => _ | _ => _ end). - replace m with (DecimalExp i'' f (norm e)). - 2:{ unfold m; revert He; case (norm e); clear m e; intro e; [|now simpl]. - now case e; clear e; [|intro e; case e|..]. } - unfold i'', i'. - case (uint_eq_dec (nzhead (app i f)) Nil); [now intros->|intro Ha]. - fold i'; replace i' with (Neg (unorm i)). - 2:{ now unfold i'; revert Ha; case nzhead. } - case (uint_eq_dec (nzhead i) Nil); intro Hi. - * unfold unorm; rewrite Hi; simpl. - case (uint_eq_dec (nzhead f) Nil). - -- intro Hf; exfalso; apply Ha. - now rewrite <-nzhead_app_nzhead, Hi, app_nil_l. - -- now case nzhead. - * rewrite unorm_involutive, (unorm_nzhead _ Hi), nzhead_app_nzhead. - now revert Ha; case nzhead. -Qed. - -Lemma IZ_to_Z_IZ_of_Z z : IZ_to_Z (IZ_of_Z z) = Some z. -Proof. now case z. Qed. - -Lemma dnorm_i_exact i f : - (nb_digits f < nb_digits (unorm (app (abs i) f)))%nat -> - match i with - | Pos i => Pos (unorm i) - | Neg i => - match nzhead (app i f) with - | Nil => Pos zero - | _ => Neg (unorm i) - end - end = norm i. -Proof. - case i as [ni|ni]; [now simpl|]; simpl. - case (uint_eq_dec (nzhead (app ni f)) Nil); intro Ha. - { now rewrite Ha, (nzhead_app_nil_l _ _ Ha). } - rewrite (unorm_nzhead _ Ha). - set (m := match nzhead _ with Nil => _ | _ => _ end). - replace m with (Neg (unorm ni)); [|now unfold m; revert Ha; case nzhead]. - case (uint_eq_dec (nzhead ni) Nil); intro Hni. - { rewrite <-nzhead_app_nzhead, Hni, app_nil_l. - intro H; exfalso; revert H; apply Nat.le_ngt, nb_digits_nzhead. } - clear m; set (m := match nzhead ni with Nil => _ | _ => _ end). - replace m with (Neg (nzhead ni)); [|now unfold m; revert Hni; case nzhead]. - now rewrite (unorm_nzhead _ Hni). -Qed. - -Lemma dnorm_i_exact' i f : - (nb_digits (unorm (app (abs i) f)) <= nb_digits f)%nat -> - match i with - | Pos i => Pos (unorm i) - | Neg i => - match nzhead (app i f) with - | Nil => Pos zero - | _ => Neg (unorm i) - end - end = - match norm (app_int i f) with - | Pos _ => Pos zero - | Neg _ => Neg zero - end. -Proof. - case i as [ni|ni]; simpl. - { now intro Hnb; rewrite (unorm_app_zero _ _ Hnb). } - unfold unorm. - case (uint_eq_dec (nzhead (app ni f)) Nil); intro Hn. - { now rewrite Hn. } - set (m := match nzhead _ with Nil => _ | _ => _ end). - replace m with (nzhead (app ni f)). - 2:{ now unfold m; revert Hn; case nzhead. } - clear m; set (m := match nzhead _ with Nil => _ | _ => _ end). - replace m with (Neg (unorm ni)). - 2:{ now unfold m, unorm; revert Hn; case nzhead. } - clear m; set (m := match nzhead _ with Nil => _ | _ => _ end). - replace m with (Neg (nzhead (app ni f))). - 2:{ now unfold m; revert Hn; case nzhead. } - rewrite <-(unorm_nzhead _ Hn). - now intro H; rewrite (unorm_app_zero _ _ H). -Qed. - -Lemma to_of (d:decimal) : to_decimal (of_decimal d) = Some (dnorm d). -Proof. - case d as [i f|i f e]. - - unfold of_decimal; simpl; unfold IQmake_to_decimal'. - rewrite IZ_to_Z_IZ_of_Z. - unfold IQmake_to_decimal; simpl. - change (fun _ : positive => _) with (Pos.mul 10). - rewrite nztail_to_uint_pow10, to_of. - case_eq (nb_digits f); [|intro nb]; intro Hnb. - + rewrite (nb_digits_0 _ Hnb), app_int_nil_r. - case i as [ni|ni]; [now simpl|]. - rewrite app_nil_r; simpl; unfold unorm. - now case (nzhead ni). - + rewrite <-Hnb. - rewrite abs_norm, abs_app_int. - case Nat.ltb_spec; intro Hnb'. - * rewrite (del_tail_app_int_exact _ _ Hnb'). - rewrite (del_head_app_int_exact _ _ Hnb'). - now rewrite (dnorm_i_exact _ _ Hnb'). - * rewrite (unorm_app_r _ _ Hnb'). - rewrite iter_D0_unorm; [|now apply nb_digits_n0; rewrite Hnb]. - now rewrite dnorm_i_exact'. - - unfold of_decimal; simpl. - rewrite <-to_of. - case (Z.of_int e); clear e; [|intro e..]; simpl. - + unfold IQmake_to_decimal'. - rewrite IZ_to_Z_IZ_of_Z. - unfold IQmake_to_decimal; simpl. - change (fun _ : positive => _) with (Pos.mul 10). - rewrite nztail_to_uint_pow10, to_of. - case_eq (nb_digits f); [|intro nb]; intro Hnb. - * rewrite (nb_digits_0 _ Hnb), app_int_nil_r. - case i as [ni|ni]; [now simpl|]. - rewrite app_nil_r; simpl; unfold unorm. - now case (nzhead ni). - * rewrite <-Hnb. - rewrite abs_norm, abs_app_int. - case Nat.ltb_spec; intro Hnb'. - -- rewrite (del_tail_app_int_exact _ _ Hnb'). - rewrite (del_head_app_int_exact _ _ Hnb'). - now rewrite (dnorm_i_exact _ _ Hnb'). - -- rewrite (unorm_app_r _ _ Hnb'). - rewrite iter_D0_unorm; [|now apply nb_digits_n0; rewrite Hnb]. - now rewrite dnorm_i_exact'. - + unfold IQmake_to_decimal'. - rewrite IZ_to_Z_IZ_of_Z. - unfold IQmake_to_decimal; simpl. - change (fun _ : positive => _) with (Pos.mul 10). - rewrite nztail_to_uint_pow10, to_of. - generalize (Unsigned.to_uint_nonzero e); intro He. - set (dnorm_i := match i with Pos _ => _ | _ => _ end). - set (m := match Pos.to_uint e with Nil => _ | _ => _ end). - replace m with (DecimalExp dnorm_i f (Pos (Pos.to_uint e))). - 2:{ now unfold m; revert He; case (Pos.to_uint e); [|intro u; case u|..]. } - clear m; unfold dnorm_i. - case_eq (nb_digits f); [|intro nb]; intro Hnb. - * rewrite (nb_digits_0 _ Hnb), app_int_nil_r. - case i as [ni|ni]; [now simpl|]. - rewrite app_nil_r; simpl; unfold unorm. - now case (nzhead ni). - * rewrite <-Hnb. - rewrite abs_norm, abs_app_int. - case Nat.ltb_spec; intro Hnb'. - -- rewrite (del_tail_app_int_exact _ _ Hnb'). - rewrite (del_head_app_int_exact _ _ Hnb'). - now rewrite (dnorm_i_exact _ _ Hnb'). - -- rewrite (unorm_app_r _ _ Hnb'). - rewrite iter_D0_unorm; [|now apply nb_digits_n0; rewrite Hnb]. - now rewrite dnorm_i_exact'. - + unfold IQmake_to_decimal'. - rewrite IZ_to_Z_IZ_of_Z. - unfold IQmake_to_decimal; simpl. - change (fun _ : positive => _) with (Pos.mul 10). - rewrite nztail_to_uint_pow10, to_of. - case_eq (nb_digits f); [|intro nb]; intro Hnb. - * rewrite (nb_digits_0 _ Hnb), app_int_nil_r. - case i as [ni|ni]; [now simpl|]. - rewrite app_nil_r; simpl; unfold unorm. - now case (nzhead ni). - * rewrite <-Hnb. - rewrite abs_norm, abs_app_int. - case Nat.ltb_spec; intro Hnb'. - -- rewrite (del_tail_app_int_exact _ _ Hnb'). - rewrite (del_head_app_int_exact _ _ Hnb'). - now rewrite (dnorm_i_exact _ _ Hnb'). - -- rewrite (unorm_app_r _ _ Hnb'). - rewrite iter_D0_unorm; [|now apply nb_digits_n0; rewrite Hnb]. - now rewrite dnorm_i_exact'. -Qed. - -(** Some consequences *) - -Lemma to_decimal_inj q q' : - to_decimal q <> None -> to_decimal q = to_decimal q' -> q = q'. -Proof. - intros Hnone EQ. - generalize (of_to q) (of_to q'). - rewrite <-EQ. - revert Hnone; case to_decimal; [|now simpl]. - now intros d _ H1 H2; rewrite <-(H1 d eq_refl), <-(H2 d eq_refl). -Qed. - -Lemma to_decimal_surj d : exists q, to_decimal q = Some (dnorm d). -Proof. - exists (of_decimal d). apply to_of. -Qed. - -Lemma of_decimal_dnorm d : of_decimal (dnorm d) = of_decimal d. -Proof. now apply to_decimal_inj; rewrite !to_of; [|rewrite dnorm_involutive]. Qed. - -Lemma of_inj d d' : of_decimal d = of_decimal d' -> dnorm d = dnorm d'. -Proof. - intro H. - apply (@f_equal _ _ (fun x => match x with Some x => x | _ => d end) - (Some (dnorm d)) (Some (dnorm d'))). - now rewrite <- !to_of, H. -Qed. - -Lemma of_iff d d' : of_decimal d = of_decimal d' <-> dnorm d = dnorm d'. -Proof. - split. - - apply of_inj. - - intros E. rewrite <- of_decimal_dnorm, E. - apply of_decimal_dnorm. -Qed. diff --git a/stdlib/theories/Numbers/DecimalR.v b/stdlib/theories/Numbers/DecimalR.v deleted file mode 100644 index e34c3efaeef4..000000000000 --- a/stdlib/theories/Numbers/DecimalR.v +++ /dev/null @@ -1,315 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* True - | Some (DecimalExp _ _ _) => False - | Some (Decimal i f) => - of_decimal (Decimal i f) = IRQ (QArith_base.Qmake num den) - end. -Proof. - unfold IQmake_to_decimal. - case (Pos.eq_dec den 1); [now intros->|intro Hden]. - assert (Hf : match QArith_base.IQmake_to_decimal num den with - | Some (Decimal i f) => f <> Nil - | _ => True - end). - { unfold QArith_base.IQmake_to_decimal; simpl. - generalize (Unsigned.nztail_to_uint den). - case Decimal.nztail as [den' e_den']. - case den'; [now simpl|now simpl| |now simpl..]; clear den'; intro den'. - case den'; [ |now simpl..]; clear den'. - case e_den' as [|e_den']; [now simpl; intros H _; apply Hden; injection H|]. - intros _. - case Nat.ltb_spec; intro He_den'. - - apply del_head_nonnil. - revert He_den'; case nb_digits as [|n]; [now simpl|]. - now intro H; simpl; apply Nat.lt_succ_r, Nat.le_sub_l. - - apply nb_digits_n0. - now rewrite nb_digits_iter_D0, Nat.sub_add. } - replace (match den with 1%positive => _ | _ => _ end) - with (QArith_base.IQmake_to_decimal num den); [|now revert Hden; case den]. - generalize (of_IQmake_to_decimal num den). - case QArith_base.IQmake_to_decimal as [d'|]; [|now simpl]. - case d' as [i f|]; [|now simpl]. - unfold of_decimal; simpl. - injection 1 as H <-. - generalize (f_equal QArith_base.IZ_to_Z H); clear H. - rewrite !IZ_to_Z_IZ_of_Z; injection 1 as <-. - now revert Hf; case f. -Qed. - -Lemma of_to (q:IR) : forall d, to_decimal q = Some d -> of_decimal d = q. -Proof. - intro d. - case q as [z|q|r r'|r r']; simpl. - - case z as [z p| |p|p]. - + now simpl. - + now simpl; injection 1 as <-. - + simpl; injection 1 as <-. - now unfold of_decimal; simpl; unfold Z.of_uint; rewrite Unsigned.of_to. - + simpl; injection 1 as <-. - now unfold of_decimal; simpl; unfold Z.of_uint; rewrite Unsigned.of_to. - - case q as [num den]. - generalize (of_IQmake_to_decimal num den). - case IQmake_to_decimal as [d'|]; [|now simpl]. - case d' as [i f|]; [|now simpl]. - now intros H; injection 1 as <-. - - case r as [z|q| |]; [|case q as[num den]|now simpl..]; - (case r' as [z'| | |]; [|now simpl..]); - (case z' as [p e| | |]; [|now simpl..]). - + case (Z.eq_dec p 10); [intros->|intro Hp]. - 2:{ revert Hp; case p; [now simpl|intro d0..]; - (case d0; [intro d1..|]; [now simpl| |now simpl]; - case d1; [intro d2..|]; [|now simpl..]; - case d2; [intro d3..|]; [now simpl| |now simpl]; - now case d3). } - case z as [| |p|p]; [now simpl|..]; injection 1 as <-. - * now unfold of_decimal; simpl; unfold Z.of_uint; rewrite Unsigned.of_to. - * unfold of_decimal; simpl; unfold Z.of_uint; rewrite Unsigned.of_to; simpl. - now rewrite Unsigned.of_to. - * unfold of_decimal; simpl; unfold Z.of_uint; rewrite Unsigned.of_to; simpl. - now rewrite Unsigned.of_to. - + case (Z.eq_dec p 10); [intros->|intro Hp]. - 2:{ revert Hp; case p; [now simpl|intro d0..]; - (case d0; [intro d1..|]; [now simpl| |now simpl]; - case d1; [intro d2..|]; [|now simpl..]; - case d2; [intro d3..|]; [now simpl| |now simpl]; - now case d3). } - generalize (of_IQmake_to_decimal num den). - case IQmake_to_decimal as [d'|]; [|now simpl]. - case d' as [i f|]; [|now simpl]. - intros H; injection 1 as <-. - unfold of_decimal; simpl. - change (match f with Nil => _ | _ => _ end) with (of_decimal (Decimal i f)). - rewrite H; clear H. - now unfold Z.of_uint; rewrite Unsigned.of_to. - - case r as [z|q| |]; [|case q as[num den]|now simpl..]; - (case r' as [z'| | |]; [|now simpl..]); - (case z' as [p e| | |]; [|now simpl..]). - + case (Z.eq_dec p 10); [intros->|intro Hp]. - 2:{ revert Hp; case p; [now simpl|intro d0..]; - (case d0; [intro d1..|]; [now simpl| |now simpl]; - case d1; [intro d2..|]; [|now simpl..]; - case d2; [intro d3..|]; [now simpl| |now simpl]; - now case d3). } - case z as [| |p|p]; [now simpl|..]; injection 1 as <-. - * now unfold of_decimal; simpl; unfold Z.of_uint; rewrite Unsigned.of_to. - * unfold of_decimal; simpl; unfold Z.of_uint; rewrite Unsigned.of_to; simpl. - now rewrite Unsigned.of_to. - * unfold of_decimal; simpl; unfold Z.of_uint; rewrite Unsigned.of_to; simpl. - now rewrite Unsigned.of_to. - + case (Z.eq_dec p 10); [intros->|intro Hp]. - 2:{ revert Hp; case p; [now simpl|intro d0..]; - (case d0; [intro d1..|]; [now simpl| |now simpl]; - case d1; [intro d2..|]; [|now simpl..]; - case d2; [intro d3..|]; [now simpl| |now simpl]; - now case d3). } - generalize (of_IQmake_to_decimal num den). - case IQmake_to_decimal as [d'|]; [|now simpl]. - case d' as [i f|]; [|now simpl]. - intros H; injection 1 as <-. - unfold of_decimal; simpl. - change (match f with Nil => _ | _ => _ end) with (of_decimal (Decimal i f)). - rewrite H; clear H. - now unfold Z.of_uint; rewrite Unsigned.of_to. -Qed. - -Lemma to_of (d:decimal) : to_decimal (of_decimal d) = Some (dnorm d). -Proof. - case d as [i f|i f e]. - - unfold of_decimal; simpl. - case (uint_eq_dec f Nil); intro Hf. - + rewrite Hf; clear f Hf. - unfold to_decimal; simpl. - rewrite IZ_to_Z_IZ_of_Z, DecimalZ.to_of. - case i as [i|i]; [now simpl|]; simpl. - rewrite app_nil_r. - case (uint_eq_dec (nzhead i) Nil); [now intros->|intro Hi]. - now rewrite (unorm_nzhead _ Hi); revert Hi; case nzhead. - + set (r := IRQ _). - set (m := match f with Nil => _ | _ => _ end). - replace m with r; [unfold r|now unfold m; revert Hf; case f]. - unfold to_decimal; simpl. - unfold IQmake_to_decimal; simpl. - set (n := Nat.iter _ _ _). - case (Pos.eq_dec n 1); intro Hn. - { exfalso; apply Hf. - now apply nb_digits_0; revert Hn; unfold n; case nb_digits. } - clear m; set (m := match n with 1%positive | _ => _ end). - replace m with (QArith_base.IQmake_to_decimal (Z.of_int (app_int i f)) n). - 2:{ now unfold m; revert Hn; case n. } - unfold QArith_base.IQmake_to_decimal, n; simpl. - rewrite nztail_to_uint_pow10. - clear r; set (r := if _ _ | _ => _ end). - replace m with r; [unfold r|now unfold m; revert Hf; case f]. - rewrite DecimalZ.to_of, abs_norm, abs_app_int. - case Nat.ltb_spec; intro Hnf. - * rewrite (del_tail_app_int_exact _ _ Hnf). - rewrite (del_head_app_int_exact _ _ Hnf). - now rewrite (dnorm_i_exact _ _ Hnf). - * rewrite (unorm_app_r _ _ Hnf). - rewrite (iter_D0_unorm _ Hf). - now rewrite dnorm_i_exact'. - - unfold of_decimal; simpl. - rewrite <-(DecimalZ.to_of e). - case (Z.of_int e); clear e; [|intro e..]; simpl. - + case (uint_eq_dec f Nil); intro Hf. - * rewrite Hf; clear f Hf. - unfold to_decimal; simpl. - rewrite IZ_to_Z_IZ_of_Z, DecimalZ.to_of. - case i as [i|i]; [now simpl|]; simpl. - rewrite app_nil_r. - case (uint_eq_dec (nzhead i) Nil); [now intros->|intro Hi]. - now rewrite (unorm_nzhead _ Hi); revert Hi; case nzhead. - * set (r := IRQ _). - set (m := match f with Nil => _ | _ => _ end). - replace m with r; [unfold r|now unfold m; revert Hf; case f]. - unfold to_decimal; simpl. - unfold IQmake_to_decimal; simpl. - set (n := Nat.iter _ _ _). - case (Pos.eq_dec n 1); intro Hn. - { exfalso; apply Hf. - now apply nb_digits_0; revert Hn; unfold n; case nb_digits. } - clear m; set (m := match n with 1%positive | _ => _ end). - replace m with (QArith_base.IQmake_to_decimal (Z.of_int (app_int i f)) n). - 2:{ now unfold m; revert Hn; case n. } - unfold QArith_base.IQmake_to_decimal, n; simpl. - rewrite nztail_to_uint_pow10. - clear r; set (r := if _ _ | _ => _ end). - replace m with r; [unfold r|now unfold m; revert Hf; case f]. - rewrite DecimalZ.to_of, abs_norm, abs_app_int. - case Nat.ltb_spec; intro Hnf. - -- rewrite (del_tail_app_int_exact _ _ Hnf). - rewrite (del_head_app_int_exact _ _ Hnf). - now rewrite (dnorm_i_exact _ _ Hnf). - -- rewrite (unorm_app_r _ _ Hnf). - rewrite (iter_D0_unorm _ Hf). - now rewrite dnorm_i_exact'. - + set (i' := match i with Pos _ => _ | _ => _ end). - set (m := match Pos.to_uint e with Nil => _ | _ => _ end). - replace m with (DecimalExp i' f (Pos (Pos.to_uint e))). - 2:{ unfold m; generalize (Unsigned.to_uint_nonzero e). - now case Pos.to_uint; [|intro u; case u|..]. } - unfold i'; clear i' m. - case (uint_eq_dec f Nil); intro Hf. - * rewrite Hf; clear f Hf. - unfold to_decimal; simpl. - rewrite IZ_to_Z_IZ_of_Z, DecimalZ.to_of. - case i as [i|i]; [now simpl|]; simpl. - rewrite app_nil_r. - case (uint_eq_dec (nzhead i) Nil); [now intros->|intro Hi]. - now rewrite (unorm_nzhead _ Hi); revert Hi; case nzhead. - * set (r := IRQ _). - set (m := match f with Nil => _ | _ => _ end). - replace m with r; [unfold r|now unfold m; revert Hf; case f]. - unfold to_decimal; simpl. - unfold IQmake_to_decimal; simpl. - set (n := Nat.iter _ _ _). - case (Pos.eq_dec n 1); intro Hn. - { exfalso; apply Hf. - now apply nb_digits_0; revert Hn; unfold n; case nb_digits. } - clear m; set (m := match n with 1%positive | _ => _ end). - replace m with (QArith_base.IQmake_to_decimal (Z.of_int (app_int i f)) n). - 2:{ now unfold m; revert Hn; case n. } - unfold QArith_base.IQmake_to_decimal, n; simpl. - rewrite nztail_to_uint_pow10. - clear r; set (r := if _ _ | _ => _ end). - replace m with r; [unfold r|now unfold m; revert Hf; case f]. - rewrite DecimalZ.to_of, abs_norm, abs_app_int. - case Nat.ltb_spec; intro Hnf. - -- rewrite (del_tail_app_int_exact _ _ Hnf). - rewrite (del_head_app_int_exact _ _ Hnf). - now rewrite (dnorm_i_exact _ _ Hnf). - -- rewrite (unorm_app_r _ _ Hnf). - rewrite (iter_D0_unorm _ Hf). - now rewrite dnorm_i_exact'. - + case (uint_eq_dec f Nil); intro Hf. - * rewrite Hf; clear f Hf. - unfold to_decimal; simpl. - rewrite IZ_to_Z_IZ_of_Z, DecimalZ.to_of. - case i as [i|i]; [now simpl|]; simpl. - rewrite app_nil_r. - case (uint_eq_dec (nzhead i) Nil); [now intros->|intro Hi]. - now rewrite (unorm_nzhead _ Hi); revert Hi; case nzhead. - * set (r := IRQ _). - set (m := match f with Nil => _ | _ => _ end). - replace m with r; [unfold r|now unfold m; revert Hf; case f]. - unfold to_decimal; simpl. - unfold IQmake_to_decimal; simpl. - set (n := Nat.iter _ _ _). - case (Pos.eq_dec n 1); intro Hn. - { exfalso; apply Hf. - now apply nb_digits_0; revert Hn; unfold n; case nb_digits. } - clear m; set (m := match n with 1%positive | _ => _ end). - replace m with (QArith_base.IQmake_to_decimal (Z.of_int (app_int i f)) n). - 2:{ now unfold m; revert Hn; case n. } - unfold QArith_base.IQmake_to_decimal, n; simpl. - rewrite nztail_to_uint_pow10. - clear r; set (r := if _ _ | _ => _ end). - replace m with r; [unfold r|now unfold m; revert Hf; case f]. - rewrite DecimalZ.to_of, abs_norm, abs_app_int. - case Nat.ltb_spec; intro Hnf. - -- rewrite (del_tail_app_int_exact _ _ Hnf). - rewrite (del_head_app_int_exact _ _ Hnf). - now rewrite (dnorm_i_exact _ _ Hnf). - -- rewrite (unorm_app_r _ _ Hnf). - rewrite (iter_D0_unorm _ Hf). - now rewrite dnorm_i_exact'. -Qed. - -(** Some consequences *) - -Lemma to_decimal_inj q q' : - to_decimal q <> None -> to_decimal q = to_decimal q' -> q = q'. -Proof. - intros Hnone EQ. - generalize (of_to q) (of_to q'). - rewrite <-EQ. - revert Hnone; case to_decimal; [|now simpl]. - now intros d _ H1 H2; rewrite <-(H1 d eq_refl), <-(H2 d eq_refl). -Qed. - -Lemma to_decimal_surj d : exists q, to_decimal q = Some (dnorm d). -Proof. - exists (of_decimal d). apply to_of. -Qed. - -Lemma of_decimal_dnorm d : of_decimal (dnorm d) = of_decimal d. -Proof. now apply to_decimal_inj; rewrite !to_of; [|rewrite dnorm_involutive]. Qed. - -Lemma of_inj d d' : of_decimal d = of_decimal d' -> dnorm d = dnorm d'. -Proof. - intro H. - apply (@f_equal _ _ (fun x => match x with Some x => x | _ => d end) - (Some (dnorm d)) (Some (dnorm d'))). - now rewrite <- !to_of, H. -Qed. - -Lemma of_iff d d' : of_decimal d = of_decimal d' <-> dnorm d = dnorm d'. -Proof. - split. - - apply of_inj. - - intros E. rewrite <- of_decimal_dnorm, E. - apply of_decimal_dnorm. -Qed. diff --git a/stdlib/theories/Numbers/DecimalString.v b/stdlib/theories/Numbers/DecimalString.v deleted file mode 100644 index d058b1dc36de..000000000000 --- a/stdlib/theories/Numbers/DecimalString.v +++ /dev/null @@ -1,265 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* None - | Some d => - match a with - | "0" => Some (D0 d) - | "1" => Some (D1 d) - | "2" => Some (D2 d) - | "3" => Some (D3 d) - | "4" => Some (D4 d) - | "5" => Some (D5 d) - | "6" => Some (D6 d) - | "7" => Some (D7 d) - | "8" => Some (D8 d) - | "9" => Some (D9 d) - | _ => None - end - end%char. - -Lemma uint_of_char_spec c d d' : - uint_of_char c (Some d) = Some d' -> - (c = "0" /\ d' = D0 d \/ - c = "1" /\ d' = D1 d \/ - c = "2" /\ d' = D2 d \/ - c = "3" /\ d' = D3 d \/ - c = "4" /\ d' = D4 d \/ - c = "5" /\ d' = D5 d \/ - c = "6" /\ d' = D6 d \/ - c = "7" /\ d' = D7 d \/ - c = "8" /\ d' = D8 d \/ - c = "9" /\ d' = D9 d)%char. -Proof. - destruct c as [[|] [|] [|] [|] [|] [|] [|] [|]]; - intros [= <-]; intuition. -Qed. - -(** Decimal/String conversion where [Nil] is [""] *) - -Module NilEmpty. - -Fixpoint string_of_uint (d:uint) := - match d with - | Nil => EmptyString - | D0 d => String "0" (string_of_uint d) - | D1 d => String "1" (string_of_uint d) - | D2 d => String "2" (string_of_uint d) - | D3 d => String "3" (string_of_uint d) - | D4 d => String "4" (string_of_uint d) - | D5 d => String "5" (string_of_uint d) - | D6 d => String "6" (string_of_uint d) - | D7 d => String "7" (string_of_uint d) - | D8 d => String "8" (string_of_uint d) - | D9 d => String "9" (string_of_uint d) - end. - -Fixpoint uint_of_string s := - match s with - | EmptyString => Some Nil - | String a s => uint_of_char a (uint_of_string s) - end. - -Definition string_of_int (d:int) := - match d with - | Pos d => string_of_uint d - | Neg d => String "-" (string_of_uint d) - end. - -Definition int_of_string s := - match s with - | EmptyString => Some (Pos Nil) - | String a s' => - if Ascii.eqb a "-" then option_map Neg (uint_of_string s') - else option_map Pos (uint_of_string s) - end. - -(* NB: For the moment whitespace between - and digits are not accepted. - And in this variant [int_of_string "-" = Some (Neg Nil)]. - -Compute int_of_string "-123456890123456890123456890123456890". -Compute string_of_int (-123456890123456890123456890123456890). -*) - -(** Corresponding proofs *) - -Lemma usu d : - uint_of_string (string_of_uint d) = Some d. -Proof. - induction d; simpl; rewrite ?IHd; simpl; auto. -Qed. - -Lemma sus s d : - uint_of_string s = Some d -> string_of_uint d = s. -Proof. - revert d. - induction s; simpl. - - now intros d [= <-]. - - intros d. - destruct (uint_of_string s); [intros H | intros [=]]. - apply uint_of_char_spec in H. - intuition subst; simpl; f_equal; auto. -Qed. - -Lemma isi d : int_of_string (string_of_int d) = Some d. -Proof. - destruct d; simpl. - - unfold int_of_string. - destruct (string_of_uint d) eqn:Hd. - + now destruct d. - + case Ascii.eqb_spec. - * intros ->. now destruct d. - * rewrite <- Hd, usu; auto. - - rewrite usu; auto. -Qed. - -Lemma sis s d : - int_of_string s = Some d -> string_of_int d = s. -Proof. - destruct s; [intros [= <-]| ]; simpl; trivial. - case Ascii.eqb_spec. - - intros ->. destruct (uint_of_string s) eqn:Hs; simpl; intros [= <-]. - simpl; f_equal. now apply sus. - - destruct d; [ | now destruct uint_of_char]. - simpl string_of_int. - intros. apply sus; simpl. - destruct uint_of_char; simpl in *; congruence. -Qed. - -End NilEmpty. - -(** Decimal/String conversions where [Nil] is ["0"] *) - -Module NilZero. - -Definition string_of_uint (d:uint) := - match d with - | Nil => "0" - | _ => NilEmpty.string_of_uint d - end. - -Definition uint_of_string s := - match s with - | EmptyString => None - | _ => NilEmpty.uint_of_string s - end. - -Definition string_of_int (d:int) := - match d with - | Pos d => string_of_uint d - | Neg d => String "-" (string_of_uint d) - end. - -Definition int_of_string s := - match s with - | EmptyString => None - | String a s' => - if Ascii.eqb a "-" then option_map Neg (uint_of_string s') - else option_map Pos (uint_of_string s) - end. - -(** Corresponding proofs *) - -Lemma uint_of_string_nonnil s : uint_of_string s <> Some Nil. -Proof. - destruct s; simpl. - - easy. - - destruct (NilEmpty.uint_of_string s); [intros H | intros [=]]. - apply uint_of_char_spec in H. - now intuition subst. -Qed. - -Lemma sus s d : - uint_of_string s = Some d -> string_of_uint d = s. -Proof. - destruct s; [intros [=] | intros H]. - apply NilEmpty.sus in H. now destruct d. -Qed. - -Lemma usu d : - d<>Nil -> uint_of_string (string_of_uint d) = Some d. -Proof. - destruct d; (now destruct 1) || (intros _; apply NilEmpty.usu). -Qed. - -Lemma usu_nil : - uint_of_string (string_of_uint Nil) = Some Decimal.zero. -Proof. - reflexivity. -Qed. - -Lemma usu_gen d : - uint_of_string (string_of_uint d) = Some d \/ - uint_of_string (string_of_uint d) = Some Decimal.zero. -Proof. - destruct d; (now right) || (left; now apply usu). -Qed. - -Lemma isi d : - d<>Pos Nil -> d<>Neg Nil -> - int_of_string (string_of_int d) = Some d. -Proof. - destruct d; simpl. - - intros H _. - unfold int_of_string. - destruct (string_of_uint d) eqn:Hd. - + now destruct d. - + case Ascii.eqb_spec. - * intros ->. now destruct d. - * rewrite <- Hd, usu; auto. now intros ->. - - intros _ H. - rewrite usu; auto. now intros ->. -Qed. - -Lemma isi_posnil : - int_of_string (string_of_int (Pos Nil)) = Some (Pos Decimal.zero). -Proof. - reflexivity. -Qed. - -(** Warning! (-0) won't parse (compatibility with the behavior of Z). *) - -Lemma isi_negnil : - int_of_string (string_of_int (Neg Nil)) = Some (Neg (D0 Nil)). -Proof. - reflexivity. -Qed. - -Lemma sis s d : - int_of_string s = Some d -> string_of_int d = s. -Proof. - destruct s; [intros [=]| ]; simpl. - case Ascii.eqb_spec. - - intros ->. destruct (uint_of_string s) eqn:Hs; simpl; intros [= <-]. - simpl; f_equal. now apply sus. - - destruct d; [ | now destruct uint_of_char]. - simpl string_of_int. - intros. apply sus; simpl. - destruct uint_of_char; simpl in *; congruence. -Qed. - -End NilZero. diff --git a/stdlib/theories/Numbers/DecimalZ.v b/stdlib/theories/Numbers/DecimalZ.v deleted file mode 100644 index 8228181c0256..000000000000 --- a/stdlib/theories/Numbers/DecimalZ.v +++ /dev/null @@ -1,125 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* n = n'. -Proof. - intro EQ. - now rewrite <- (of_to n), <- (of_to n'), EQ. -Qed. - -Lemma to_int_surj d : exists n, Z.to_int n = norm d. -Proof. - exists (Z.of_int d). apply to_of. -Qed. - -Lemma of_int_norm d : Z.of_int (norm d) = Z.of_int d. -Proof. - unfold Z.of_int, Z.of_uint. - destruct d. - - simpl. now rewrite DecimalPos.Unsigned.of_uint_norm. - - simpl. destruct (nzhead d) eqn:H; - [ induction d; simpl; auto; discriminate | - destruct (nzhead_nonzero _ _ H) | .. ]; - f_equal; f_equal; apply DecimalPos.Unsigned.of_iff; - unfold unorm; now rewrite H. -Qed. - -Lemma of_inj d d' : - Z.of_int d = Z.of_int d' -> norm d = norm d'. -Proof. - intros. rewrite <- !to_of. now f_equal. -Qed. - -Lemma of_iff d d' : Z.of_int d = Z.of_int d' <-> norm d = norm d'. -Proof. - split. - - apply of_inj. - - intros E. rewrite <- of_int_norm, E. - apply of_int_norm. -Qed. - -(** Various lemmas *) - -Lemma of_uint_iter_D0 d n : - Z.of_uint (app d (Nat.iter n D0 Nil)) = Nat.iter n (Z.mul 10) (Z.of_uint d). -Proof. - rewrite <-(rev_rev (app _ _)), <-(of_list_to_list (rev (app _ _))). - rewrite rev_spec, app_spec, List.rev_app_distr. - rewrite <-!rev_spec, <-app_spec, of_list_to_list. - unfold Z.of_uint; rewrite Unsigned.of_lu_rev. - unfold app; rewrite Unsigned.of_lu_revapp, !rev_rev. - rewrite <-!Unsigned.of_lu_rev, !rev_rev. - assert (H' : Pos.of_uint (Nat.iter n D0 Nil) = 0%N). - { now induction n; [|rewrite Unsigned.nat_iter_S]. } - rewrite H', N.add_0_l; clear H'. - induction n; [now simpl; rewrite N.mul_1_r|]. - rewrite !Unsigned.nat_iter_S, <-IHn. - simpl Unsigned.usize; rewrite N.pow_succ_r'. - rewrite !N2Z.inj_mul; simpl Z.of_N; ring. -Qed. - -Lemma of_int_iter_D0 d n : - Z.of_int (app_int d (Nat.iter n D0 Nil)) = Nat.iter n (Z.mul 10) (Z.of_int d). -Proof. - case d; clear d; intro d; simpl. - - now rewrite of_uint_iter_D0. - - rewrite of_uint_iter_D0; induction n; [now simpl|]. - rewrite !Unsigned.nat_iter_S, <-IHn; ring. -Qed. - -Lemma nztail_to_uint_pow10 n : - Decimal.nztail (Pos.to_uint (Nat.iter n (Pos.mul 10) 1%positive)) - = (D1 Nil, n). -Proof. - case n as [|n]; [now simpl|]. - rewrite <-(Nat2Pos.id (S n)); [|now simpl]. - generalize (Pos.of_nat (S n)); clear n; intro p. - induction (Pos.to_nat p); [now simpl|]. - rewrite Unsigned.nat_iter_S. - unfold Pos.to_uint. - change (Pos.to_little_uint _) - with (Unsigned.to_lu (10 * N.pos (Nat.iter n (Pos.mul 10) 1%positive))). - rewrite Unsigned.to_ldec_tenfold. - revert IHn; unfold Pos.to_uint. - unfold Decimal.nztail; rewrite !rev_rev; simpl. - set (f'' := _ (Pos.to_little_uint _)). - now case f''; intros r n' H; inversion H. -Qed. diff --git a/stdlib/theories/Numbers/HexadecimalFacts.v b/stdlib/theories/Numbers/HexadecimalFacts.v deleted file mode 100644 index 9a211809fb94..000000000000 --- a/stdlib/theories/Numbers/HexadecimalFacts.v +++ /dev/null @@ -1,718 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* nil - | D0 u => cons d0 (to_list u) - | D1 u => cons d1 (to_list u) - | D2 u => cons d2 (to_list u) - | D3 u => cons d3 (to_list u) - | D4 u => cons d4 (to_list u) - | D5 u => cons d5 (to_list u) - | D6 u => cons d6 (to_list u) - | D7 u => cons d7 (to_list u) - | D8 u => cons d8 (to_list u) - | D9 u => cons d9 (to_list u) - | Da u => cons da (to_list u) - | Db u => cons db (to_list u) - | Dc u => cons dc (to_list u) - | Dd u => cons dd (to_list u) - | De u => cons de (to_list u) - | Df u => cons df (to_list u) - end. - -Fixpoint of_list (l : list digits) : uint := - match l with - | nil => Nil - | cons d0 l => D0 (of_list l) - | cons d1 l => D1 (of_list l) - | cons d2 l => D2 (of_list l) - | cons d3 l => D3 (of_list l) - | cons d4 l => D4 (of_list l) - | cons d5 l => D5 (of_list l) - | cons d6 l => D6 (of_list l) - | cons d7 l => D7 (of_list l) - | cons d8 l => D8 (of_list l) - | cons d9 l => D9 (of_list l) - | cons da l => Da (of_list l) - | cons db l => Db (of_list l) - | cons dc l => Dc (of_list l) - | cons dd l => Dd (of_list l) - | cons de l => De (of_list l) - | cons df l => Df (of_list l) - end. - -Lemma of_list_to_list u : of_list (to_list u) = u. -Proof. now induction u; [|simpl; rewrite IHu..]. Qed. - -Lemma to_list_of_list l : to_list (of_list l) = l. -Proof. now induction l as [|h t IHl]; [|case h; simpl; rewrite IHl]. Qed. - -Lemma to_list_inj u u' : to_list u = to_list u' -> u = u'. -Proof. - now intro H; rewrite <-(of_list_to_list u), <-(of_list_to_list u'), H. -Qed. - -Lemma of_list_inj u u' : of_list u = of_list u' -> u = u'. -Proof. - now intro H; rewrite <-(to_list_of_list u), <-(to_list_of_list u'), H. -Qed. - -Lemma nb_digits_spec u : nb_digits u = length (to_list u). -Proof. now induction u; [|simpl; rewrite IHu..]. Qed. - -Fixpoint lnzhead l := - match l with - | nil => nil - | cons d l' => - match d with - | d0 => lnzhead l' - | _ => l - end - end. - -Lemma nzhead_spec u : to_list (nzhead u) = lnzhead (to_list u). -Proof. now induction u; [|simpl; rewrite IHu|..]. Qed. - -Definition lzero := cons d0 nil. - -Definition lunorm l := - match lnzhead l with - | nil => lzero - | d => d - end. - -Lemma unorm_spec u : to_list (unorm u) = lunorm (to_list u). -Proof. now unfold unorm, lunorm; rewrite <-nzhead_spec; case (nzhead u). Qed. - -Lemma revapp_spec d d' : - to_list (revapp d d') = List.rev_append (to_list d) (to_list d'). -Proof. now revert d'; induction d; intro d'; [|simpl; rewrite IHd..]. Qed. - -Lemma rev_spec d : to_list (rev d) = List.rev (to_list d). -Proof. now unfold rev; rewrite revapp_spec, List.rev_alt; simpl. Qed. - -Lemma app_spec d d' : - to_list (app d d') = Datatypes.app (to_list d) (to_list d'). -Proof. - unfold app. - now rewrite revapp_spec, List.rev_append_rev, rev_spec, List.rev_involutive. -Qed. - -Definition lnztail l := - let fix aux l_rev := - match l_rev with - | cons d0 l_rev => let (r, n) := aux l_rev in pair r (S n) - | _ => pair l_rev O - end in - let (r, n) := aux (List.rev l) in pair (List.rev r) n. - -Lemma nztail_spec d : - let (r, n) := nztail d in - let (r', n') := lnztail (to_list d) in - to_list r = r' /\ n = n'. -Proof. - unfold nztail, lnztail. - set (f := fix aux d_rev := match d_rev with - | D0 d_rev => let (r, n) := aux d_rev in (r, S n) - | _ => (d_rev, 0) end). - set (f' := fix aux (l_rev : list digits) : list digits * nat := - match l_rev with - | cons d0 l_rev => let (r, n) := aux l_rev in (r, S n) - | _ => (l_rev, 0) - end). - rewrite <-(of_list_to_list (rev d)), rev_spec. - induction (List.rev _) as [|h t IHl]; [now simpl|]. - case h; simpl; [|now rewrite rev_spec; simpl; rewrite to_list_of_list..]. - now revert IHl; case f; intros r n; case f'; intros r' n' [-> ->]. -Qed. - -Lemma del_head_spec_0 d : del_head 0 d = d. -Proof. now simpl. Qed. - -Lemma del_head_spec_small n d : - n <= length (to_list d) -> to_list (del_head n d) = List.skipn n (to_list d). -Proof. - revert d; induction n as [|n IHn]; intro d; [now simpl|]. - now case d; [|intros d' H; apply IHn, le_S_n..]. -Qed. - -Lemma del_head_spec_large n d : length (to_list d) < n -> del_head n d = zero. -Proof. - revert d; induction n; intro d; [now case d|]. - now case d; [|intro d'; simpl; intro H; rewrite (IHn _ (proj2 (Nat.succ_lt_mono _ _) H))..]. -Qed. - -Lemma nb_digits_0 d : nb_digits d = 0 -> d = Nil. -Proof. - rewrite nb_digits_spec, <-(of_list_to_list d). - now case (to_list d) as [|h t]; [|rewrite to_list_of_list]. -Qed. - -Lemma nb_digits_n0 d : nb_digits d <> 0 -> d <> Nil. -Proof. now case d; [|intros u _..]. Qed. - -Lemma nb_digits_iter_D0 n d : - nb_digits (Nat.iter n D0 d) = n + nb_digits d. -Proof. now induction n; simpl; [|rewrite IHn]. Qed. - -Lemma length_lnzhead l : length (lnzhead l) <= length l. -Proof. now induction l as [|h t IHl]; [|case h; [apply le_S|..]]. Qed. - -Lemma nb_digits_nzhead u : nb_digits (nzhead u) <= nb_digits u. -Proof. now induction u; [|apply le_S|..]. Qed. - -Lemma unorm_nzhead u : nzhead u <> Nil -> unorm u = nzhead u. -Proof. now unfold unorm; case nzhead. Qed. - -Lemma nb_digits_unorm u : u <> Nil -> nb_digits (unorm u) <= nb_digits u. -Proof. - intro Hu; case (uint_eq_dec (nzhead u) Nil). - { unfold unorm; intros ->; simpl. - now revert Hu; case u; [|intros u' _; apply le_n_S, Nat.le_0_l..]. } - intro H; rewrite (unorm_nzhead _ H); apply nb_digits_nzhead. -Qed. - -Lemma nb_digits_rev d : nb_digits (rev d) = nb_digits d. -Proof. now rewrite !nb_digits_spec, rev_spec, List.length_rev. Qed. - -Lemma nb_digits_del_head_sub d n : - n <= nb_digits d -> - nb_digits (del_head (nb_digits d - n) d) = n. -Proof. - rewrite !nb_digits_spec; intro Hn. - rewrite del_head_spec_small; [|now apply Nat.le_sub_l]. - rewrite List.length_skipn, <-(Nat2Z.id (_ - _)). - rewrite Nat2Z.inj_sub; [|now apply Nat.le_sub_l]. - rewrite (Nat2Z.inj_sub _ _ Hn). - rewrite Z.sub_sub_distr, Z.sub_diag; apply Nat2Z.id. -Qed. - -Lemma unorm_D0 u : unorm (D0 u) = unorm u. -Proof. reflexivity. Qed. - -Lemma app_nil_l d : app Nil d = d. -Proof. now simpl. Qed. - -Lemma app_nil_r d : app d Nil = d. -Proof. now apply to_list_inj; rewrite app_spec, List.app_nil_r. Qed. - -Lemma abs_app_int d d' : abs (app_int d d') = app (abs d) d'. -Proof. now case d. Qed. - -Lemma abs_norm d : abs (norm d) = unorm (abs d). -Proof. now case d as [u|u]; [|simpl; unfold unorm; case nzhead]. Qed. - -Lemma iter_D0_nzhead d : - Nat.iter (nb_digits d - nb_digits (nzhead d)) D0 (nzhead d) = d. -Proof. - induction d; [now simpl| |now rewrite Nat.sub_diag..]. - simpl nzhead; simpl nb_digits. - rewrite (Nat.sub_succ_l _ _ (nb_digits_nzhead _)). - now rewrite <-IHd at 4. -Qed. - -Lemma iter_D0_unorm d : - d <> Nil -> - Nat.iter (nb_digits d - nb_digits (unorm d)) D0 (unorm d) = d. -Proof. - case (uint_eq_dec (nzhead d) Nil); intro Hn. - { unfold unorm; rewrite Hn; simpl; intro H. - revert H Hn; induction d; [now simpl|intros _|now intros _..]. - case (uint_eq_dec d Nil); simpl; intros H Hn; [now rewrite H|]. - rewrite Nat.sub_0_r, <- (Nat.sub_add 1 (nb_digits d)), Nat.add_comm. - { now simpl; rewrite IHd. } - revert H; case d; [now simpl|intros u _; apply le_n_S, Nat.le_0_l..]. } - intros _; rewrite (unorm_nzhead _ Hn); apply iter_D0_nzhead. -Qed. - -Lemma nzhead_app_l d d' : - nb_digits d' < nb_digits (nzhead (app d d')) -> - nzhead (app d d') = app (nzhead d) d'. -Proof. - intro Hl; apply to_list_inj; revert Hl. - rewrite !nb_digits_spec, app_spec, !nzhead_spec, app_spec. - induction (to_list d) as [|h t IHl]. - { now simpl; intro H; exfalso; revert H; apply Nat.le_ngt, length_lnzhead. } - rewrite <-List.app_comm_cons. - now case h; [simpl; intro Hl; apply IHl|..]. -Qed. - -Lemma nzhead_app_r d d' : - nb_digits (nzhead (app d d')) <= nb_digits d' -> - nzhead (app d d') = nzhead d'. -Proof. - intro Hl; apply to_list_inj; revert Hl. - rewrite !nb_digits_spec, !nzhead_spec, app_spec. - induction (to_list d) as [|h t IHl]; [now simpl|]. - rewrite <-List.app_comm_cons. - now case h; [| simpl; rewrite List.length_app; intro Hl; exfalso; revert Hl; - apply Nat.le_ngt, Nat.le_add_l..]. -Qed. - -Lemma nzhead_app_nil_r d d' : nzhead (app d d') = Nil -> nzhead d' = Nil. -Proof. -now intro H; generalize H; rewrite nzhead_app_r; [|rewrite H; apply Nat.le_0_l]. -Qed. - -Lemma nzhead_app_nil d d' : - nb_digits (nzhead (app d d')) <= nb_digits d' -> nzhead d = Nil. -Proof. - intro H; apply to_list_inj; revert H. - rewrite !nb_digits_spec, !nzhead_spec, app_spec. - induction (to_list d) as [|h t IHl]; [now simpl|]. - now case h; [now simpl|..]; - simpl;intro H; exfalso; revert H; apply Nat.le_ngt; - rewrite List.length_app; apply Nat.le_add_l. -Qed. - -Lemma nzhead_app_nil_l d d' : nzhead (app d d') = Nil -> nzhead d = Nil. -Proof. - intro H; apply to_list_inj; generalize (f_equal to_list H); clear H. - rewrite !nzhead_spec, app_spec. - induction (to_list d) as [|h t IHl]; [now simpl|]. - now rewrite <-List.app_comm_cons; case h. -Qed. - -Lemma unorm_app_zero d d' : - nb_digits (unorm (app d d')) <= nb_digits d' -> unorm d = zero. -Proof. - unfold unorm. - case (uint_eq_dec (nzhead (app d d')) Nil). - { now intro Hn; rewrite Hn, (nzhead_app_nil_l _ _ Hn). } - intro H; fold (unorm (app d d')); rewrite (unorm_nzhead _ H); intro H'. - case (uint_eq_dec (nzhead d) Nil); [now intros->|]. - intro H''; fold (unorm d); rewrite (unorm_nzhead _ H''). - exfalso; apply H''; revert H'; apply nzhead_app_nil. -Qed. - -Lemma app_int_nil_r d : app_int d Nil = d. -Proof. - now case d; intro d'; simpl; - rewrite <-(of_list_to_list (app _ _)), app_spec; - rewrite List.app_nil_r, of_list_to_list. -Qed. - -Lemma unorm_app_l d d' : - nb_digits d' < nb_digits (unorm (app d d')) -> - unorm (app d d') = app (unorm d) d'. -Proof. - case (uint_eq_dec d' Nil); [now intros->; rewrite !app_nil_r|intro Hd']. - case (uint_eq_dec (nzhead (app d d')) Nil). - { unfold unorm; intros->; simpl; intro H; exfalso; revert H; apply Nat.le_ngt. - now revert Hd'; case d'; [|intros d'' _; apply le_n_S, Peano.le_0_n..]. } - intro Ha; rewrite (unorm_nzhead _ Ha). - intro Hn; generalize Hn; rewrite (nzhead_app_l _ _ Hn). - rewrite !nb_digits_spec, app_spec, List.length_app. - case (uint_eq_dec (nzhead d) Nil). - { intros->; simpl; intro H; exfalso; revert H; apply Nat.lt_irrefl. } - now intro H; rewrite (unorm_nzhead _ H). -Qed. - -Lemma unorm_app_r d d' : - nb_digits (unorm (app d d')) <= nb_digits d' -> - unorm (app d d') = unorm d'. -Proof. - case (uint_eq_dec (nzhead (app d d')) Nil). - { now unfold unorm; intro H; rewrite H, (nzhead_app_nil_r _ _ H). } - intro Ha; rewrite (unorm_nzhead _ Ha). - case (uint_eq_dec (nzhead d') Nil). - { now intros H H'; exfalso; apply Ha; rewrite nzhead_app_r. } - intro Hd'; rewrite (unorm_nzhead _ Hd'); apply nzhead_app_r. -Qed. - -Lemma norm_app_int d d' : - nb_digits d' < nb_digits (unorm (app (abs d) d')) -> - norm (app_int d d') = app_int (norm d) d'. -Proof. - case (uint_eq_dec d' Nil); [now intros->; rewrite !app_int_nil_r|intro Hd']. - case d as [d|d]; [now simpl; intro H; apply f_equal, unorm_app_l|]. - simpl; unfold unorm. - case (uint_eq_dec (nzhead (app d d')) Nil). - { intros->; simpl; intro H; exfalso; revert H; apply Nat.le_ngt. - now revert Hd'; case d'; [|intros d'' _; apply -> Nat.succ_le_mono; apply Nat.le_0_l..]. } - set (m := match nzhead _ with Nil => _ | _ => _ end). - intro Ha. - replace m with (nzhead (app d d')). - 2:{ now unfold m; revert Ha; case nzhead. } - intro Hn; generalize Hn; rewrite (nzhead_app_l _ _ Hn). - case (uint_eq_dec (app (nzhead d) d') Nil). - { intros->; simpl; intro H; exfalso; revert H; apply Nat.le_ngt, Nat.le_0_l. } - clear m; set (m := match app _ _ with Nil => _ | _ => _ end). - intro Ha'. - replace m with (Neg (app (nzhead d) d')); [|now unfold m; revert Ha'; case app]. - case (uint_eq_dec (nzhead d) Nil). - { intros->; simpl; intro H; exfalso; revert H; apply Nat.lt_irrefl. } - clear m; set (m := match nzhead _ with Nil => _ | _ => _ end). - intro Hd. - now replace m with (Neg (nzhead d)); [|unfold m; revert Hd; case nzhead]. -Qed. - -Lemma del_head_nb_digits d : del_head (nb_digits d) d = Nil. -Proof. - apply to_list_inj. - rewrite nb_digits_spec, del_head_spec_small; [|now simpl]. - now rewrite List.skipn_all. -Qed. - -Lemma del_tail_nb_digits d : del_tail (nb_digits d) d = Nil. -Proof. now unfold del_tail; rewrite <-nb_digits_rev, del_head_nb_digits. Qed. - -Lemma del_head_app n d d' : - n <= nb_digits d -> del_head n (app d d') = app (del_head n d) d'. -Proof. - rewrite nb_digits_spec; intro Hn. - apply to_list_inj. - rewrite del_head_spec_small. - 2:{ now rewrite app_spec, List.length_app, <- Nat.le_add_r. } - rewrite !app_spec, (del_head_spec_small _ _ Hn). - rewrite List.skipn_app. - now rewrite (proj2 (Nat.sub_0_le _ _) Hn). -Qed. - -Lemma del_tail_app n d d' : - n <= nb_digits d' -> del_tail n (app d d') = app d (del_tail n d'). -Proof. - rewrite nb_digits_spec; intro Hn. - unfold del_tail. - rewrite <-(of_list_to_list (rev (app d d'))), rev_spec, app_spec. - rewrite List.rev_app_distr, <-!rev_spec, <-app_spec, of_list_to_list. - rewrite del_head_app; [|now rewrite nb_digits_spec, rev_spec, List.length_rev]. - apply to_list_inj. - rewrite rev_spec, !app_spec, !rev_spec. - now rewrite List.rev_app_distr, List.rev_involutive. -Qed. - -Lemma del_tail_app_int n d d' : - n <= nb_digits d' -> del_tail_int n (app_int d d') = app_int d (del_tail n d'). -Proof. now case d as [d|d]; simpl; intro H; rewrite del_tail_app. Qed. - -Lemma app_del_tail_head n (d:uint) : - n <= nb_digits d -> app (del_tail n d) (del_head (nb_digits d - n) d) = d. -Proof. - rewrite nb_digits_spec; intro Hn; unfold del_tail. - rewrite <-(of_list_to_list (app _ _)), app_spec, rev_spec. - rewrite del_head_spec_small; [|now rewrite rev_spec, List.length_rev]. - rewrite del_head_spec_small; [|now apply Nat.le_sub_l]. - rewrite rev_spec. - set (n' := _ - n). - assert (Hn' : n = length (to_list d) - n'). - { now rewrite <- (Nat.add_sub (length (to_list d)) n), Nat.add_comm, - <- 2 Nat.add_sub_assoc, Nat.sub_diag; trivial. } - now rewrite Hn', <-List.firstn_skipn_rev, List.firstn_skipn, of_list_to_list. -Qed. - -Lemma app_int_del_tail_head n (d:int) : - n <= nb_digits (abs d) -> - app_int (del_tail_int n d) (del_head (nb_digits (abs d) - n) (abs d)) = d. -Proof. now case d; clear d; simpl; intros u Hu; rewrite app_del_tail_head. Qed. - -Lemma del_head_app_int_exact i f : - nb_digits f < nb_digits (unorm (app (abs i) f)) -> - del_head (nb_digits (unorm (app (abs i) f)) - nb_digits f) (unorm (app (abs i) f)) = f. -Proof. - simpl; intro Hnb; generalize Hnb; rewrite (unorm_app_l _ _ Hnb); clear Hnb. - replace (_ - _) with (nb_digits (unorm (abs i))). - - now rewrite del_head_app; [rewrite del_head_nb_digits|]. - - rewrite !nb_digits_spec, app_spec, List.length_app. - symmetry; apply Nat.add_sub. -Qed. - -Lemma del_tail_app_int_exact i f : - nb_digits f < nb_digits (unorm (app (abs i) f)) -> - del_tail_int (nb_digits f) (norm (app_int i f)) = norm i. -Proof. - simpl; intro Hnb. - rewrite (norm_app_int _ _ Hnb). - rewrite del_tail_app_int; [|now simpl]. - now rewrite del_tail_nb_digits, app_int_nil_r. -Qed. - -(** Normalization on little-endian numbers *) - -Fixpoint nztail d := - match d with - | Nil => Nil - | D0 d => match nztail d with Nil => Nil | d' => D0 d' end - | D1 d => D1 (nztail d) - | D2 d => D2 (nztail d) - | D3 d => D3 (nztail d) - | D4 d => D4 (nztail d) - | D5 d => D5 (nztail d) - | D6 d => D6 (nztail d) - | D7 d => D7 (nztail d) - | D8 d => D8 (nztail d) - | D9 d => D9 (nztail d) - | Da d => Da (nztail d) - | Db d => Db (nztail d) - | Dc d => Dc (nztail d) - | Dd d => Dd (nztail d) - | De d => De (nztail d) - | Df d => Df (nztail d) - end. - -Definition lnorm d := - match nztail d with - | Nil => zero - | d => d - end. - -Lemma nzhead_revapp_0 d d' : nztail d = Nil -> - nzhead (revapp d d') = nzhead d'. -Proof. - revert d'. induction d; intros d' [=]; simpl; trivial. - destruct (nztail d); now rewrite IHd. -Qed. - -Lemma nzhead_revapp d d' : nztail d <> Nil -> - nzhead (revapp d d') = revapp (nztail d) d'. -Proof. - revert d'. - induction d; intros d' H; simpl in *; - try destruct (nztail d) eqn:E; - (rewrite IHd;[reflexivity|discriminate]) || (now rewrite ?nzhead_revapp_0). -Qed. - -Lemma nzhead_rev d : nztail d <> Nil -> - nzhead (rev d) = rev (nztail d). -Proof. - apply nzhead_revapp. -Qed. - -Lemma rev_rev d : rev (rev d) = d. -Proof. now apply to_list_inj; rewrite !rev_spec, List.rev_involutive. Qed. - -Lemma rev_nztail_rev d : - rev (nztail (rev d)) = nzhead d. -Proof. - destruct (uint_eq_dec (nztail (rev d)) Nil) as [H|H]. - - rewrite H. unfold rev; simpl. - rewrite <- (rev_rev d). symmetry. - now apply nzhead_revapp_0. - - now rewrite <- nzhead_rev, rev_rev. -Qed. - -Lemma nzhead_D0 u : nzhead (D0 u) = nzhead u. -Proof. reflexivity. Qed. - -Lemma nzhead_iter_D0 n u : nzhead (Nat.iter n D0 u) = nzhead u. -Proof. now induction n. Qed. - -Lemma revapp_nil_inv d d' : revapp d d' = Nil -> d = Nil /\ d' = Nil. -Proof. - revert d'. - induction d; simpl; intros d' H; auto; now apply IHd in H. -Qed. - -Lemma rev_nil_inv d : rev d = Nil -> d = Nil. -Proof. - apply revapp_nil_inv. -Qed. - -Lemma rev_lnorm_rev d : - rev (lnorm (rev d)) = unorm d. -Proof. - unfold unorm, lnorm. - rewrite <- rev_nztail_rev. - destruct nztail; simpl; trivial; - destruct rev eqn:E; trivial; now apply rev_nil_inv in E. -Qed. - -Lemma nzhead_nonzero d d' : nzhead d <> D0 d'. -Proof. - induction d; easy. -Qed. - -Lemma unorm_0 d : unorm d = zero <-> nzhead d = Nil. -Proof. - unfold unorm. split. - - generalize (nzhead_nonzero d). - destruct nzhead; intros H [=]; trivial. now destruct (H u). - - now intros ->. -Qed. - -Lemma unorm_nonnil d : unorm d <> Nil. -Proof. - unfold unorm. now destruct nzhead. -Qed. - -Lemma unorm_iter_D0 n u : unorm (Nat.iter n D0 u) = unorm u. -Proof. now induction n. Qed. - -Lemma del_head_nonnil n u : - n < nb_digits u -> del_head n u <> Nil. -Proof. - now revert n; induction u; intro n; - [|case n; [|intro n'; simpl; intro H; apply IHu, Nat.succ_lt_mono]..]. -Qed. - -Lemma del_tail_nonnil n u : - n < nb_digits u -> del_tail n u <> Nil. -Proof. - unfold del_tail. - rewrite <-nb_digits_rev. - generalize (rev u); clear u; intro u. - intros Hu H. - generalize (rev_nil_inv _ H); clear H. - now apply del_head_nonnil. -Qed. - -Lemma nzhead_involutive d : nzhead (nzhead d) = nzhead d. -Proof. - now induction d. -Qed. - -Lemma nztail_involutive d : nztail (nztail d) = nztail d. -Proof. - rewrite <-(rev_rev (nztail _)), <-(rev_rev (nztail d)), <-(rev_rev d). - now rewrite !rev_nztail_rev, nzhead_involutive. -Qed. - -Lemma unorm_involutive d : unorm (unorm d) = unorm d. -Proof. - unfold unorm. - destruct (nzhead d) eqn:E; trivial. - destruct (nzhead_nonzero _ _ E). -Qed. - -Lemma norm_involutive d : norm (norm d) = norm d. -Proof. - unfold norm. - destruct d. - - f_equal. apply unorm_involutive. - - destruct (nzhead d) eqn:E; auto. - destruct (nzhead_nonzero _ _ E). -Qed. - -Lemma lnzhead_neq_d0_head l l' : ~(lnzhead l = cons d0 l'). -Proof. now induction l as [|h t Il]; [|case h]. Qed. - -Lemma lnzhead_head_nd0 h t : h <> d0 -> lnzhead (cons h t) = cons h t. -Proof. now case h. Qed. - -Lemma nzhead_del_tail_nzhead_eq n u : - nzhead u = u -> - n < nb_digits u -> - nzhead (del_tail n u) = del_tail n u. -Proof. - rewrite nb_digits_spec, <-List.length_rev. - intros Hu Hn. - apply to_list_inj; unfold del_tail. - rewrite nzhead_spec, rev_spec. - rewrite del_head_spec_small; [|now rewrite rev_spec; apply Nat.lt_le_incl]. - rewrite rev_spec. - rewrite List.skipn_rev, List.rev_involutive. - generalize (f_equal to_list Hu) Hn; rewrite nzhead_spec; intro Hu'. - case (to_list u) as [|h t]. - { simpl; intro H; exfalso; revert H; apply Nat.le_ngt, Nat.le_0_l. } - intro Hn'; generalize (Nat.sub_gt _ _ Hn'); rewrite List.length_rev. - case (_ - _); [now simpl|]; intros n' _. - rewrite List.firstn_cons, lnzhead_head_nd0; [now simpl|]. - intro Hh; revert Hu'; rewrite Hh; apply lnzhead_neq_d0_head. -Qed. - -Lemma nzhead_del_tail_nzhead n u : - n < nb_digits (nzhead u) -> - nzhead (del_tail n (nzhead u)) = del_tail n (nzhead u). -Proof. apply nzhead_del_tail_nzhead_eq, nzhead_involutive. Qed. - -Lemma unorm_del_tail_unorm n u : - n < nb_digits (unorm u) -> - unorm (del_tail n (unorm u)) = del_tail n (unorm u). -Proof. - case (uint_eq_dec (nzhead u) Nil). - - unfold unorm; intros->; case n; [now simpl|]; intro n'. - now simpl; intro H; exfalso; generalize (proj2 (Nat.succ_lt_mono _ _) H). - - unfold unorm. - set (m := match nzhead u with Nil => zero | _ => _ end). - intros H. - replace m with (nzhead u). - + intros H'. - rewrite (nzhead_del_tail_nzhead _ _ H'). - now generalize (del_tail_nonnil _ _ H'); case del_tail. - + now unfold m; revert H; case nzhead. -Qed. - -Lemma norm_del_tail_int_norm n d : - n < nb_digits (match norm d with Pos d | Neg d => d end) -> - norm (del_tail_int n (norm d)) = del_tail_int n (norm d). -Proof. - case d; clear d; intros u; simpl. - - now intro H; simpl; rewrite unorm_del_tail_unorm. - - case (uint_eq_dec (nzhead u) Nil); intro Hu. - + now rewrite Hu; case n; [|intros n' Hn'; generalize (proj2 (Nat.succ_lt_mono _ _) Hn')]. - + set (m := match nzhead u with Nil => Pos zero | _ => _ end). - replace m with (Neg (nzhead u)); [|now unfold m; revert Hu; case nzhead]. - unfold del_tail_int. - clear m Hu. - simpl. - intro H; generalize (del_tail_nonnil _ _ H). - rewrite (nzhead_del_tail_nzhead _ _ H). - now case del_tail. -Qed. - -Lemma nzhead_app_nzhead d d' : - nzhead (app (nzhead d) d') = nzhead (app d d'). -Proof. - unfold app. - rewrite <-(rev_nztail_rev d), rev_rev. - generalize (rev d); clear d; intro d. - generalize (nzhead_revapp_0 d d'). - generalize (nzhead_revapp d d'). - generalize (nzhead_revapp_0 (nztail d) d'). - generalize (nzhead_revapp (nztail d) d'). - rewrite nztail_involutive. - now case nztail; - [intros _ H _ H'; rewrite (H eq_refl), (H' eq_refl) - |intros d'' H _ H' _; rewrite H; [rewrite H'|]..]. -Qed. - -Lemma unorm_app_unorm d d' : - unorm (app (unorm d) d') = unorm (app d d'). -Proof. - unfold unorm. - rewrite <-(nzhead_app_nzhead d d'). - now case (nzhead d). -Qed. - -Lemma norm_app_int_norm d d' : - unorm d' = zero -> - norm (app_int (norm d) d') = norm (app_int d d'). -Proof. - case d; clear d; intro d; simpl. - - now rewrite unorm_app_unorm. - - unfold app_int, app. - rewrite unorm_0; intro Hd'. - rewrite <-rev_nztail_rev. - generalize (nzhead_revapp (rev d) d'). - generalize (nzhead_revapp_0 (rev d) d'). - now case_eq (nztail (rev d)); - [intros Hd'' H _; rewrite (H eq_refl); simpl; - unfold unorm; simpl; rewrite Hd' - |intros d'' Hd'' _ H; rewrite H; clear H; [|now simpl]; - set (r := rev _); - set (m := match r with Nil => Pos zero | _ => _ end); - assert (H' : m = Neg r); - [now unfold m; case_eq r; unfold r; - [intro H''; generalize (rev_nil_inv _ H'')|..] - |rewrite H'; unfold r; clear m r H']; - unfold norm; - rewrite rev_rev, <-Hd''; - rewrite nzhead_revapp; rewrite nztail_involutive; [|rewrite Hd'']..]. -Qed. diff --git a/stdlib/theories/Numbers/HexadecimalN.v b/stdlib/theories/Numbers/HexadecimalN.v deleted file mode 100644 index b5336fb55133..000000000000 --- a/stdlib/theories/Numbers/HexadecimalN.v +++ /dev/null @@ -1,109 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* n = n'. -Proof. - intros E. now rewrite <- (of_to n), <- (of_to n'), E. -Qed. - -Lemma to_uint_surj d : exists p, N.to_hex_uint p = unorm d. -Proof. - exists (N.of_hex_uint d). apply to_of. -Qed. - -Lemma of_uint_norm d : N.of_hex_uint (unorm d) = N.of_hex_uint d. -Proof. - now induction d. -Qed. - -Lemma of_inj d d' : - N.of_hex_uint d = N.of_hex_uint d' -> unorm d = unorm d'. -Proof. - intros. rewrite <- !to_of. now f_equal. -Qed. - -Lemma of_iff d d' : N.of_hex_uint d = N.of_hex_uint d' <-> unorm d = unorm d'. -Proof. - split. - - apply of_inj. - - intros E. rewrite <- of_uint_norm, E. - apply of_uint_norm. -Qed. - -End Unsigned. - -(** Conversion from/to signed hexadecimal numbers *) - -Module Signed. - -Lemma of_to (n:N) : N.of_hex_int (N.to_hex_int n) = Some n. -Proof. - unfold N.to_hex_int, N.of_hex_int, norm. f_equal. - rewrite Unsigned.of_uint_norm. apply Unsigned.of_to. -Qed. - -Lemma to_of (d:int)(n:N) : N.of_hex_int d = Some n -> N.to_hex_int n = norm d. -Proof. - unfold N.of_hex_int. - destruct (norm d) eqn:Hd; intros [= <-]. - unfold N.to_hex_int. rewrite Unsigned.to_of. f_equal. - revert Hd; destruct d; simpl. - - intros [= <-]. apply unorm_involutive. - - destruct (nzhead d); now intros [= <-]. -Qed. - -Lemma to_int_inj n n' : N.to_hex_int n = N.to_hex_int n' -> n = n'. -Proof. - intro E. - assert (E' : Some n = Some n'). - { now rewrite <- (of_to n), <- (of_to n'), E. } - now injection E'. -Qed. - -Lemma to_int_pos_surj d : exists n, N.to_hex_int n = norm (Pos d). -Proof. - exists (N.of_hex_uint d). unfold N.to_hex_int. now rewrite Unsigned.to_of. -Qed. - -Lemma of_int_norm d : N.of_hex_int (norm d) = N.of_hex_int d. -Proof. - unfold N.of_hex_int. now rewrite norm_involutive. -Qed. - -Lemma of_inj_pos d d' : - N.of_hex_int (Pos d) = N.of_hex_int (Pos d') -> unorm d = unorm d'. -Proof. - unfold N.of_hex_int. simpl. intros [= H]. apply Unsigned.of_inj. - change Pos.of_hex_uint with N.of_hex_uint in H. - now rewrite <- Unsigned.of_uint_norm, H, Unsigned.of_uint_norm. -Qed. - -End Signed. diff --git a/stdlib/theories/Numbers/HexadecimalNat.v b/stdlib/theories/Numbers/HexadecimalNat.v deleted file mode 100644 index a64391558675..000000000000 --- a/stdlib/theories/Numbers/HexadecimalNat.v +++ /dev/null @@ -1,323 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* 0x0 - | D0 _ => 0x0 - | D1 _ => 0x1 - | D2 _ => 0x2 - | D3 _ => 0x3 - | D4 _ => 0x4 - | D5 _ => 0x5 - | D6 _ => 0x6 - | D7 _ => 0x7 - | D8 _ => 0x8 - | D9 _ => 0x9 - | Da _ => 0xa - | Db _ => 0xb - | Dc _ => 0xc - | Dd _ => 0xd - | De _ => 0xe - | Df _ => 0xf - end. - -Definition tl d := - match d with - | Nil => d - | D0 d | D1 d | D2 d | D3 d | D4 d | D5 d | D6 d | D7 d | D8 d | D9 d - | Da d | Db d | Dc d | Dd d | De d | Df d => d - end. - -Fixpoint usize (d:uint) : nat := - match d with - | Nil => 0 - | D0 d => S (usize d) - | D1 d => S (usize d) - | D2 d => S (usize d) - | D3 d => S (usize d) - | D4 d => S (usize d) - | D5 d => S (usize d) - | D6 d => S (usize d) - | D7 d => S (usize d) - | D8 d => S (usize d) - | D9 d => S (usize d) - | Da d => S (usize d) - | Db d => S (usize d) - | Dc d => S (usize d) - | Dd d => S (usize d) - | De d => S (usize d) - | Df d => S (usize d) - end. - -(** A direct version of [to_little_uint], not tail-recursive *) -Fixpoint to_lu n := - match n with - | 0 => Hexadecimal.zero - | S n => Little.succ (to_lu n) - end. - -(** A direct version of [of_little_uint] *) -Fixpoint of_lu (d:uint) : nat := - match d with - | Nil => 0x0 - | D0 d => 0x10 * of_lu d - | D1 d => 0x1 + 0x10 * of_lu d - | D2 d => 0x2 + 0x10 * of_lu d - | D3 d => 0x3 + 0x10 * of_lu d - | D4 d => 0x4 + 0x10 * of_lu d - | D5 d => 0x5 + 0x10 * of_lu d - | D6 d => 0x6 + 0x10 * of_lu d - | D7 d => 0x7 + 0x10 * of_lu d - | D8 d => 0x8 + 0x10 * of_lu d - | D9 d => 0x9 + 0x10 * of_lu d - | Da d => 0xa + 0x10 * of_lu d - | Db d => 0xb + 0x10 * of_lu d - | Dc d => 0xc + 0x10 * of_lu d - | Dd d => 0xd + 0x10 * of_lu d - | De d => 0xe + 0x10 * of_lu d - | Df d => 0xf + 0x10 * of_lu d - end. - -(** Properties of [to_lu] *) - -Lemma to_lu_succ n : to_lu (S n) = Little.succ (to_lu n). -Proof. - reflexivity. -Qed. - -Lemma to_little_uint_succ n d : - Nat.to_little_hex_uint n (Little.succ d) = - Little.succ (Nat.to_little_hex_uint n d). -Proof. - revert d; induction n; simpl; trivial. -Qed. - -Lemma to_lu_equiv n : - to_lu n = Nat.to_little_hex_uint n zero. -Proof. - induction n; simpl; trivial. - now rewrite IHn, <- to_little_uint_succ. -Qed. - -Lemma to_uint_alt n : - Nat.to_hex_uint n = rev (to_lu n). -Proof. - unfold Nat.to_hex_uint. f_equal. symmetry. apply to_lu_equiv. -Qed. - -(** Properties of [of_lu] *) - -Lemma of_lu_eqn d : - of_lu d = hd d + 0x10 * of_lu (tl d). -Proof. - induction d; simpl; trivial. -Qed. - -Ltac simpl_of_lu := - match goal with - | |- context [ of_lu (?f ?x) ] => - rewrite (of_lu_eqn (f x)); simpl hd; simpl tl - end. - -Lemma of_lu_succ d : - of_lu (Little.succ d) = S (of_lu d). -Proof. - induction d; trivial. - simpl_of_lu. rewrite IHd. simpl_of_lu. - now rewrite Nat.mul_succ_r, <- (Nat.add_comm 0x10). -Qed. - -Lemma of_to_lu n : - of_lu (to_lu n) = n. -Proof. - induction n; simpl; trivial. rewrite of_lu_succ. now f_equal. -Qed. - -Lemma of_lu_revapp d d' : - of_lu (revapp d d') = - of_lu (rev d) + of_lu d' * 0x10^usize d. -Proof. - revert d'. - induction d; intro d'; simpl usize; - [ simpl; now rewrite Nat.mul_1_r | .. ]; - unfold rev; simpl revapp; rewrite 2 IHd; - rewrite <- Nat.add_assoc; f_equal; simpl_of_lu; simpl of_lu; - rewrite Nat.pow_succ_r'; ring. -Qed. - -Lemma of_uint_acc_spec n d : - Nat.of_hex_uint_acc d n = of_lu (rev d) + n * 0x10^usize d. -Proof. - revert n. induction d; intros; - simpl Nat.of_hex_uint_acc; rewrite ?Nat.tail_mul_spec, ?IHd; - simpl rev; simpl usize; rewrite ?Nat.pow_succ_r'; - [ simpl; now rewrite Nat.mul_1_r | .. ]; - unfold rev at 2; simpl revapp; rewrite of_lu_revapp; - simpl of_lu; ring. -Qed. - -Lemma of_uint_alt d : Nat.of_hex_uint d = of_lu (rev d). -Proof. - unfold Nat.of_hex_uint. now rewrite of_uint_acc_spec. -Qed. - -(** First main bijection result *) - -Lemma of_to (n:nat) : Nat.of_hex_uint (Nat.to_hex_uint n) = n. -Proof. - rewrite to_uint_alt, of_uint_alt, rev_rev. apply of_to_lu. -Qed. - -(** The other direction *) - -Lemma to_lu_sixteenfold n : n<>0 -> - to_lu (0x10 * n) = D0 (to_lu n). -Proof. - induction n. - - simpl. now destruct 1. - - intros _. - destruct (Nat.eq_dec n 0) as [->|H]; simpl; trivial. - rewrite !Nat.add_succ_r. - simpl in *. rewrite (IHn H). now destruct (to_lu n). -Qed. - -Lemma of_lu_0 d : of_lu d = 0 <-> nztail d = Nil. -Proof. - induction d; try simpl_of_lu; try easy. - rewrite Nat.add_0_l. - split; intros H. - - apply Nat.eq_mul_0_r in H; auto. - rewrite IHd in H. simpl. now rewrite H. - - simpl in H. destruct (nztail d); try discriminate. - now destruct IHd as [_ ->]. -Qed. - -Lemma to_of_lu_sixteenfold d : - to_lu (of_lu d) = lnorm d -> - to_lu (0x10 * of_lu d) = lnorm (D0 d). -Proof. - intro IH. - destruct (Nat.eq_dec (of_lu d) 0) as [H|H]. - - rewrite H. simpl. rewrite of_lu_0 in H. - unfold lnorm. simpl. now rewrite H. - - rewrite (to_lu_sixteenfold _ H), IH. - rewrite of_lu_0 in H. - unfold lnorm. simpl. now destruct (nztail d). -Qed. - -Lemma to_of_lu d : to_lu (of_lu d) = lnorm d. -Proof. - induction d; [ reflexivity | .. ]; - simpl_of_lu; - rewrite ?Nat.add_succ_l, Nat.add_0_l, ?to_lu_succ, to_of_lu_sixteenfold - by assumption; - unfold lnorm; cbn; now destruct nztail. -Qed. - -(** Second bijection result *) - -Lemma to_of (d:uint) : Nat.to_hex_uint (Nat.of_hex_uint d) = unorm d. -Proof. - rewrite to_uint_alt, of_uint_alt, to_of_lu. - apply rev_lnorm_rev. -Qed. - -(** Some consequences *) - -Lemma to_uint_inj n n' : Nat.to_hex_uint n = Nat.to_hex_uint n' -> n = n'. -Proof. - intro EQ. - now rewrite <- (of_to n), <- (of_to n'), EQ. -Qed. - -Lemma to_uint_surj d : exists n, Nat.to_hex_uint n = unorm d. -Proof. - exists (Nat.of_hex_uint d). apply to_of. -Qed. - -Lemma of_uint_norm d : Nat.of_hex_uint (unorm d) = Nat.of_hex_uint d. -Proof. - unfold Nat.of_hex_uint. now induction d. -Qed. - -Lemma of_inj d d' : - Nat.of_hex_uint d = Nat.of_hex_uint d' -> unorm d = unorm d'. -Proof. - intros. rewrite <- !to_of. now f_equal. -Qed. - -Lemma of_iff d d' : Nat.of_hex_uint d = Nat.of_hex_uint d' <-> unorm d = unorm d'. -Proof. - split. - - apply of_inj. - - intros E. rewrite <- of_uint_norm, E. - apply of_uint_norm. -Qed. - -End Unsigned. - -(** Conversion from/to signed hexadecimal numbers *) - -Module Signed. - -Lemma of_to (n:nat) : Nat.of_hex_int (Nat.to_hex_int n) = Some n. -Proof. - unfold Nat.to_hex_int, Nat.of_hex_int, norm. f_equal. - rewrite Unsigned.of_uint_norm. apply Unsigned.of_to. -Qed. - -Lemma to_of (d:int)(n:nat) : Nat.of_hex_int d = Some n -> Nat.to_hex_int n = norm d. -Proof. - unfold Nat.of_hex_int. - destruct (norm d) eqn:Hd; intros [= <-]. - unfold Nat.to_hex_int. rewrite Unsigned.to_of. f_equal. - revert Hd; destruct d; simpl. - - intros [= <-]. apply unorm_involutive. - - destruct (nzhead d); now intros [= <-]. -Qed. - -Lemma to_int_inj n n' : Nat.to_hex_int n = Nat.to_hex_int n' -> n = n'. -Proof. - intro E. - assert (E' : Some n = Some n'). - { now rewrite <- (of_to n), <- (of_to n'), E. } - now injection E'. -Qed. - -Lemma to_int_pos_surj d : exists n, Nat.to_hex_int n = norm (Pos d). -Proof. - exists (Nat.of_hex_uint d). unfold Nat.to_hex_int. now rewrite Unsigned.to_of. -Qed. - -Lemma of_int_norm d : Nat.of_hex_int (norm d) = Nat.of_hex_int d. -Proof. - unfold Nat.of_hex_int. now rewrite norm_involutive. -Qed. - -Lemma of_inj_pos d d' : - Nat.of_hex_int (Pos d) = Nat.of_hex_int (Pos d') -> unorm d = unorm d'. -Proof. - unfold Nat.of_hex_int. simpl. intros [= H]. apply Unsigned.of_inj. - now rewrite <- Unsigned.of_uint_norm, H, Unsigned.of_uint_norm. -Qed. - -End Signed. diff --git a/stdlib/theories/Numbers/HexadecimalPos.v b/stdlib/theories/Numbers/HexadecimalPos.v deleted file mode 100644 index 3621a063de21..000000000000 --- a/stdlib/theories/Numbers/HexadecimalPos.v +++ /dev/null @@ -1,448 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* 0 - | D0 d => 0x10 * of_lu d - | D1 d => 0x1 + 0x10 * of_lu d - | D2 d => 0x2 + 0x10 * of_lu d - | D3 d => 0x3 + 0x10 * of_lu d - | D4 d => 0x4 + 0x10 * of_lu d - | D5 d => 0x5 + 0x10 * of_lu d - | D6 d => 0x6 + 0x10 * of_lu d - | D7 d => 0x7 + 0x10 * of_lu d - | D8 d => 0x8 + 0x10 * of_lu d - | D9 d => 0x9 + 0x10 * of_lu d - | Da d => 0xa + 0x10 * of_lu d - | Db d => 0xb + 0x10 * of_lu d - | Dc d => 0xc + 0x10 * of_lu d - | Dd d => 0xd + 0x10 * of_lu d - | De d => 0xe + 0x10 * of_lu d - | Df d => 0xf + 0x10 * of_lu d - end. - -Definition hd d := - match d with - | Nil => 0x0 - | D0 _ => 0x0 - | D1 _ => 0x1 - | D2 _ => 0x2 - | D3 _ => 0x3 - | D4 _ => 0x4 - | D5 _ => 0x5 - | D6 _ => 0x6 - | D7 _ => 0x7 - | D8 _ => 0x8 - | D9 _ => 0x9 - | Da _ => 0xa - | Db _ => 0xb - | Dc _ => 0xc - | Dd _ => 0xd - | De _ => 0xe - | Df _ => 0xf - end. - -Definition tl d := - match d with - | Nil => d - | D0 d | D1 d | D2 d | D3 d | D4 d | D5 d | D6 d | D7 d | D8 d | D9 d - | Da d | Db d | Dc d | Dd d | De d | Df d => d - end. - -Lemma of_lu_eqn d : - of_lu d = hd d + 0x10 * (of_lu (tl d)). -Proof. - induction d; simpl; trivial. -Qed. - -Ltac simpl_of_lu := - match goal with - | |- context [ of_lu (?f ?x) ] => - rewrite (of_lu_eqn (f x)); simpl hd; simpl tl - end. - -Fixpoint usize (d:uint) : N := - match d with - | Nil => 0 - | D0 d => N.succ (usize d) - | D1 d => N.succ (usize d) - | D2 d => N.succ (usize d) - | D3 d => N.succ (usize d) - | D4 d => N.succ (usize d) - | D5 d => N.succ (usize d) - | D6 d => N.succ (usize d) - | D7 d => N.succ (usize d) - | D8 d => N.succ (usize d) - | D9 d => N.succ (usize d) - | Da d => N.succ (usize d) - | Db d => N.succ (usize d) - | Dc d => N.succ (usize d) - | Dd d => N.succ (usize d) - | De d => N.succ (usize d) - | Df d => N.succ (usize d) - end. - -Lemma of_lu_revapp d d' : - of_lu (revapp d d') = - of_lu (rev d) + of_lu d' * 0x10^usize d. -Proof. - revert d'. - induction d; simpl; intro d'; [ now rewrite N.mul_1_r | .. ]; - unfold rev; simpl revapp; rewrite 2 IHd; - rewrite <- N.add_assoc; f_equal; simpl_of_lu; simpl of_lu; - rewrite N.pow_succ_r'; ring. -Qed. - -Definition Nadd n p := - match n with - | N0 => p - | Npos p0 => (p0+p)%positive - end. - -Lemma Nadd_simpl n p q : Npos (Nadd n (p * q)) = n + Npos p * Npos q. -Proof. - now destruct n. -Qed. - -Lemma of_uint_acc_eqn d acc : d<>Nil -> - Pos.of_hex_uint_acc d acc = Pos.of_hex_uint_acc (tl d) (Nadd (hd d) (0x10*acc)). -Proof. - destruct d; simpl; trivial. now destruct 1. -Qed. - -Lemma of_uint_acc_rev d acc : - Npos (Pos.of_hex_uint_acc d acc) = - of_lu (rev d) + (Npos acc) * 0x10^usize d. -Proof. - revert acc. - induction d; intros; simpl usize; - [ simpl; now rewrite Pos.mul_1_r | .. ]; - rewrite N.pow_succ_r'; - unfold rev; simpl revapp; try rewrite of_lu_revapp; simpl of_lu; - rewrite of_uint_acc_eqn by easy; simpl tl; simpl hd; - rewrite IHd, Nadd_simpl; ring. -Qed. - -Lemma of_uint_alt d : Pos.of_hex_uint d = of_lu (rev d). -Proof. - induction d; simpl; trivial; unfold rev; simpl revapp; - rewrite of_lu_revapp; simpl of_lu; try apply of_uint_acc_rev. - rewrite IHd. ring. -Qed. - -Lemma of_lu_rev d : Pos.of_hex_uint (rev d) = of_lu d. -Proof. - rewrite of_uint_alt. now rewrite rev_rev. -Qed. - -Lemma of_lu_double_gen d : - of_lu (Little.double d) = N.double (of_lu d) /\ - of_lu (Little.succ_double d) = N.succ_double (of_lu d). -Proof. - rewrite N.double_spec, N.succ_double_spec. - induction d; try destruct IHd as (IH1,IH2); - simpl Little.double; simpl Little.succ_double; - repeat (simpl_of_lu; rewrite ?IH1, ?IH2); split; reflexivity || ring. -Qed. - -Lemma of_lu_double d : - of_lu (Little.double d) = N.double (of_lu d). -Proof. - apply of_lu_double_gen. -Qed. - -Lemma of_lu_succ_double d : - of_lu (Little.succ_double d) = N.succ_double (of_lu d). -Proof. - apply of_lu_double_gen. -Qed. - -(** First bijection result *) - -Lemma of_to (p:positive) : Pos.of_hex_uint (Pos.to_hex_uint p) = Npos p. -Proof. - unfold Pos.to_hex_uint. - rewrite of_lu_rev. - induction p; simpl; trivial. - - now rewrite of_lu_succ_double, IHp. - - now rewrite of_lu_double, IHp. -Qed. - -(** The other direction *) - -Definition to_lu n := - match n with - | N0 => Hexadecimal.zero - | Npos p => Pos.to_little_hex_uint p - end. - -Lemma succ_double_alt d : - Little.succ_double d = Little.succ (Little.double d). -Proof. - now induction d. -Qed. - -Lemma double_succ d : - Little.double (Little.succ d) = - Little.succ (Little.succ_double d). -Proof. - induction d; simpl; f_equal; auto using succ_double_alt. -Qed. - -Lemma to_lu_succ n : - to_lu (N.succ n) = Little.succ (to_lu n). -Proof. - destruct n; simpl; trivial. - induction p; simpl; rewrite ?IHp; - auto using succ_double_alt, double_succ. -Qed. - -Lemma nat_iter_S n {A} (f:A->A) i : - Nat.iter (S n) f i = f (Nat.iter n f i). -Proof. - reflexivity. -Qed. - -Lemma nat_iter_0 {A} (f:A->A) i : Nat.iter 0 f i = i. -Proof. - reflexivity. -Qed. - -Lemma to_lhex_tenfold p : - to_lu (0x10 * Npos p) = D0 (to_lu (Npos p)). -Proof. - induction p using Pos.peano_rect. - - trivial. - - change (N.pos (Pos.succ p)) with (N.succ (N.pos p)). - rewrite N.mul_succ_r. - change 0x10 with (Nat.iter 0x10%nat N.succ 0) at 2. - rewrite ?nat_iter_S, nat_iter_0. - rewrite !N.add_succ_r, N.add_0_r, !to_lu_succ, IHp. - destruct (to_lu (N.pos p)); simpl; auto. -Qed. - -Lemma of_lu_0 d : of_lu d = 0 <-> nztail d = Nil. -Proof. - induction d; try simpl_of_lu; split; trivial; try discriminate; - try (intros H; now apply N.eq_add_0 in H). - - rewrite N.add_0_l. intros H. - apply N.eq_mul_0_r in H; [|easy]. rewrite IHd in H. - simpl. now rewrite H. - - simpl. destruct (nztail d); try discriminate. - now destruct IHd as [_ ->]. -Qed. - -Lemma to_of_lu_tenfold d : - to_lu (of_lu d) = lnorm d -> - to_lu (0x10 * of_lu d) = lnorm (D0 d). -Proof. - intro IH. - destruct (N.eq_dec (of_lu d) 0) as [H|H]. - - rewrite H. simpl. rewrite of_lu_0 in H. - unfold lnorm. simpl. now rewrite H. - - destruct (of_lu d) eqn:Eq; [easy| ]. - rewrite to_lhex_tenfold; auto. rewrite IH. - rewrite <- Eq in H. rewrite of_lu_0 in H. - unfold lnorm. simpl. now destruct (nztail d). -Qed. - -Lemma Nadd_alt n m : n + m = Nat.iter (N.to_nat n) N.succ m. -Proof. - destruct n. 1:trivial. - induction p using Pos.peano_rect. - - now rewrite N.add_1_l. - - change (N.pos (Pos.succ p)) with (N.succ (N.pos p)). - now rewrite N.add_succ_l, IHp, N2Nat.inj_succ. -Qed. - -Ltac simpl_to_nat := simpl N.to_nat; unfold Pos.to_nat; simpl Pos.iter_op. - -Lemma to_of_lu d : to_lu (of_lu d) = lnorm d. -Proof. - induction d; [reflexivity|..]; - simpl_of_lu; rewrite Nadd_alt; simpl_to_nat; - rewrite ?nat_iter_S, nat_iter_0, ?to_lu_succ, to_of_lu_tenfold by assumption; - unfold lnorm; simpl nztail; destruct nztail; reflexivity. -Qed. - -(** Second bijection result *) - -Lemma to_of (d:uint) : N.to_hex_uint (Pos.of_hex_uint d) = unorm d. -Proof. - rewrite of_uint_alt. - unfold N.to_hex_uint, Pos.to_hex_uint. - destruct (of_lu (rev d)) eqn:H. - - rewrite of_lu_0 in H. rewrite <- rev_lnorm_rev. - unfold lnorm. now rewrite H. - - change (Pos.to_little_hex_uint p) with (to_lu (N.pos p)). - rewrite <- H. rewrite to_of_lu. apply rev_lnorm_rev. -Qed. - -(** Some consequences *) - -Lemma to_uint_nonzero p : Pos.to_hex_uint p <> zero. -Proof. - intro E. generalize (of_to p). now rewrite E. -Qed. - -Lemma to_uint_nonnil p : Pos.to_hex_uint p <> Nil. -Proof. - intros E. generalize (of_to p). now rewrite E. -Qed. - -Lemma to_uint_inj p p' : Pos.to_hex_uint p = Pos.to_hex_uint p' -> p = p'. -Proof. - intro E. - assert (E' : N.pos p = N.pos p'). - { now rewrite <- (of_to p), <- (of_to p'), E. } - now injection E'. -Qed. - -Lemma to_uint_pos_surj d : - unorm d<>zero -> exists p, Pos.to_hex_uint p = unorm d. -Proof. - intros. - destruct (Pos.of_hex_uint d) eqn:E. - - destruct H. generalize (to_of d). now rewrite E. - - exists p. generalize (to_of d). now rewrite E. -Qed. - -Lemma of_uint_norm d : Pos.of_hex_uint (unorm d) = Pos.of_hex_uint d. -Proof. - now induction d. -Qed. - -Lemma of_inj d d' : - Pos.of_hex_uint d = Pos.of_hex_uint d' -> unorm d = unorm d'. -Proof. - intros. rewrite <- !to_of. now f_equal. -Qed. - -Lemma of_iff d d' : Pos.of_hex_uint d = Pos.of_hex_uint d' <-> unorm d = unorm d'. -Proof. - split. - - apply of_inj. - - intros E. rewrite <- of_uint_norm, E. - apply of_uint_norm. -Qed. - -(* various lemmas *) - -Lemma nztail_to_hex_uint p : - let (h, n) := Hexadecimal.nztail (Pos.to_hex_uint p) in - Npos p = Pos.of_hex_uint h * 0x10^(N.of_nat n). -Proof. - rewrite <-(of_to p), <-(rev_rev (Pos.to_hex_uint p)), of_lu_rev. - unfold Hexadecimal.nztail. - rewrite rev_rev. - induction (rev (Pos.to_hex_uint p)); [reflexivity| | - now simpl N.of_nat; simpl N.pow; rewrite N.mul_1_r, of_lu_rev..]. - revert IHu. - set (t := _ u); case t; clear t; intros u0 n H. - rewrite of_lu_eqn; unfold hd, tl. - rewrite N.add_0_l, H, Nat2N.inj_succ, N.pow_succ_r'; ring. -Qed. - -Definition double d := rev (Little.double (rev d)). - -Lemma double_unorm d : double (unorm d) = unorm (double d). -Proof. - unfold double. - rewrite <-!rev_lnorm_rev, !rev_rev, <-!to_of_lu, of_lu_double. - now case of_lu; [now simpl|]; intro p; induction p. -Qed. - -Lemma double_nzhead d : double (nzhead d) = nzhead (double d). -Proof. - unfold double. - rewrite <-!rev_nztail_rev, !rev_rev. - apply f_equal; generalize (rev d); clear d; intro d. - cut (Little.double (nztail d) = nztail (Little.double d) - /\ Little.succ_double (nztail d) = nztail (Little.succ_double d)). - { now simpl. } - now induction d; - [|split; simpl; rewrite <-?(proj1 IHd), <-?(proj2 IHd); case nztail..]. -Qed. - -Lemma of_hex_uint_double d : - Pos.of_hex_uint (double d) = N.double (Pos.of_hex_uint d). -Proof. - now unfold double; rewrite of_lu_rev, of_lu_double, <-of_lu_rev, rev_rev. -Qed. - -End Unsigned. - -(** Conversion from/to signed decimal numbers *) - -Module Signed. - -Lemma of_to (p:positive) : Pos.of_hex_int (Pos.to_hex_int p) = Some p. -Proof. - unfold Pos.to_hex_int, Pos.of_hex_int, norm. - now rewrite Unsigned.of_to. -Qed. - -Lemma to_of (d:int)(p:positive) : - Pos.of_hex_int d = Some p -> Pos.to_hex_int p = norm d. -Proof. - unfold Pos.of_hex_int. - destruct d; [ | intros [=]]. - simpl norm. rewrite <- Unsigned.to_of. - destruct (Pos.of_hex_uint d); now intros [= <-]. -Qed. - -Lemma to_int_inj p p' : Pos.to_hex_int p = Pos.to_hex_int p' -> p = p'. -Proof. - intro E. - assert (E' : Some p = Some p'). - { now rewrite <- (of_to p), <- (of_to p'), E. } - now injection E'. -Qed. - -Lemma to_int_pos_surj d : - unorm d <> zero -> exists p, Pos.to_hex_int p = norm (Pos d). -Proof. - simpl. unfold Pos.to_hex_int. intros H. - destruct (Unsigned.to_uint_pos_surj d H) as (p,Hp). - exists p. now f_equal. -Qed. - -Lemma of_int_norm d : Pos.of_hex_int (norm d) = Pos.of_hex_int d. -Proof. - unfold Pos.of_int. - destruct d. - - simpl. now rewrite Unsigned.of_uint_norm. - - simpl. now destruct (nzhead d) eqn:H. -Qed. - -Lemma of_inj_pos d d' : - Pos.of_hex_int (Pos d) = Pos.of_hex_int (Pos d') -> unorm d = unorm d'. -Proof. - unfold Pos.of_hex_int. - destruct (Pos.of_hex_uint d) eqn:Hd, (Pos.of_hex_uint d') eqn:Hd'; - intros [=]. - - apply Unsigned.of_inj; now rewrite Hd, Hd'. - - apply Unsigned.of_inj; rewrite Hd, Hd'; now f_equal. -Qed. - -End Signed. diff --git a/stdlib/theories/Numbers/HexadecimalQ.v b/stdlib/theories/Numbers/HexadecimalQ.v deleted file mode 100644 index 7c57fb8f21f9..000000000000 --- a/stdlib/theories/Numbers/HexadecimalQ.v +++ /dev/null @@ -1,461 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* True - | Some (HexadecimalExp _ _ _) => False - | Some (Hexadecimal i f) => of_hexadecimal (Hexadecimal i f) = IQmake (IZ_of_Z num) den - end. -Proof. - unfold IQmake_to_hexadecimal. - generalize (Unsigned.nztail_to_hex_uint den). - case Hexadecimal.nztail; intros den' e_den'. - case den'; [now simpl|now simpl| |now simpl..]; clear den'; intro den'. - case den'; [ |now simpl..]; clear den'. - case e_den' as [|e_den']; simpl; injection 1 as ->. - { now unfold of_hexadecimal; simpl; rewrite app_int_nil_r, HexadecimalZ.of_to. } - replace (16 ^ _)%positive with (Nat.iter (S e_den') (Pos.mul 16) 1%positive). - 2:{ induction e_den' as [|n IHn]; [now simpl| ]. - now rewrite SuccNat2Pos.inj_succ, Pos.pow_succ_r, <-IHn. } - case Nat.ltb_spec; intro He_den'. - - unfold of_hexadecimal; simpl. - rewrite app_int_del_tail_head; [|now apply Nat.lt_le_incl]. - rewrite HexadecimalZ.of_to. - now rewrite nb_digits_del_head_sub; [|now apply Nat.lt_le_incl]. - - unfold of_hexadecimal; simpl. - rewrite nb_digits_iter_D0. - apply f_equal2. - + apply f_equal, HexadecimalZ.to_int_inj. - rewrite HexadecimalZ.to_of. - rewrite <-(HexadecimalZ.of_to num), HexadecimalZ.to_of. - case (Z.to_hex_int num); clear He_den' num; intro num; simpl. - * unfold app; simpl. - now rewrite unorm_D0, unorm_iter_D0, unorm_involutive. - * case (uint_eq_dec (nzhead num) Nil); [|intro Hn]. - { intros->; simpl; unfold app; simpl. - now rewrite unorm_D0, unorm_iter_D0. } - replace (match nzhead num with Nil => _ | _ => _ end) - with (Neg (nzhead num)); [|now revert Hn; case nzhead]. - simpl. - rewrite nzhead_iter_D0, nzhead_involutive. - now revert Hn; case nzhead. - + revert He_den'; case nb_digits as [|n]; [now simpl; rewrite Nat.add_0_r|]. - intro Hn. - rewrite Nat.add_succ_r, Nat.sub_add; [|apply le_S_n]; auto. -Qed. - -Lemma IZ_of_Z_IZ_to_Z z z' : IZ_to_Z z = Some z' -> IZ_of_Z z' = z. -Proof. now case z as [| |p|p]; [| injection 1 as <- ..]. Qed. - -Lemma of_IQmake_to_hexadecimal' num den : - match IQmake_to_hexadecimal' num den with - | None => True - | Some (HexadecimalExp _ _ _) => False - | Some (Hexadecimal i f) => of_hexadecimal (Hexadecimal i f) = IQmake num den - end. -Proof. - unfold IQmake_to_hexadecimal'. - case_eq (IZ_to_Z num); [intros num' Hnum'|now simpl]. - generalize (of_IQmake_to_hexadecimal num' den). - case IQmake_to_hexadecimal as [d|]; [|now simpl]. - case d as [i f|]; [|now simpl]. - now rewrite (IZ_of_Z_IZ_to_Z _ _ Hnum'). -Qed. - -Lemma of_to (q:IQ) : forall d, to_hexadecimal q = Some d -> of_hexadecimal d = q. -Proof. - intro d. - case q as [num den|q q'|q q']; simpl. - - generalize (of_IQmake_to_hexadecimal' num den). - case IQmake_to_hexadecimal' as [d'|]; [|now simpl]. - case d' as [i f|]; [|now simpl]. - now intros H; injection 1 as <-. - - case q as [num den| |]; [|now simpl..]. - case q' as [num' den'| |]; [|now simpl..]. - case num' as [z p| | |]; [|now simpl..]. - case (Z.eq_dec z 2); [intros->|]. - 2:{ case z; [now simpl| |now simpl]; intro pz'. - case pz'; [intros d0..| ]; [now simpl| |now simpl]. - now case d0. } - case (Pos.eq_dec den' 1%positive); [intros->|now case den']. - generalize (of_IQmake_to_hexadecimal' num den). - case IQmake_to_hexadecimal' as [d'|]; [|now simpl]. - case d' as [i f|]; [|now simpl]. - intros <-; clear num den. - injection 1 as <-. - unfold of_hexadecimal; simpl. - now unfold Z.of_uint; rewrite DecimalPos.Unsigned.of_to; simpl. - - case q as [num den| |]; [|now simpl..]. - case q' as [num' den'| |]; [|now simpl..]. - case num' as [z p| | |]; [|now simpl..]. - case (Z.eq_dec z 2); [intros->|]. - 2:{ case z; [now simpl| |now simpl]; intro pz'. - case pz'; [intros d0..| ]; [now simpl| |now simpl]. - now case d0. } - case (Pos.eq_dec den' 1%positive); [intros->|now case den']. - generalize (of_IQmake_to_hexadecimal' num den). - case IQmake_to_hexadecimal' as [d'|]; [|now simpl]. - case d' as [i f|]; [|now simpl]. - intros <-; clear num den. - injection 1 as <-. - unfold of_hexadecimal; simpl. - now unfold Z.of_uint; rewrite DecimalPos.Unsigned.of_to; simpl. -Qed. - - -Definition dnorm (d:hexadecimal) : hexadecimal := - let norm_i i f := - match i with - | Pos i => Pos (unorm i) - | Neg i => match nzhead (app i f) with Nil => Pos zero | _ => Neg (unorm i) end - end in - match d with - | Hexadecimal i f => Hexadecimal (norm_i i f) f - | HexadecimalExp i f e => - match Decimal.norm e with - | Decimal.Pos Decimal.zero => Hexadecimal (norm_i i f) f - | e => HexadecimalExp (norm_i i f) f e - end - end. - -Lemma dnorm_spec_i d : - let (i, f) := - match d with Hexadecimal i f => (i, f) | HexadecimalExp i f _ => (i, f) end in - let i' := match dnorm d with Hexadecimal i _ => i | HexadecimalExp i _ _ => i end in - match i with - | Pos i => i' = Pos (unorm i) - | Neg i => - (i' = Neg (unorm i) /\ (nzhead i <> Nil \/ nzhead f <> Nil)) - \/ (i' = Pos zero /\ (nzhead i = Nil /\ nzhead f = Nil)) - end. -Proof. - case d as [i f|i f e]; case i as [i|i]. - - now simpl. - - simpl; case (uint_eq_dec (nzhead (app i f)) Nil); intro Ha. - + rewrite Ha; right; split; [now simpl|split]. - * now unfold unorm; rewrite (nzhead_app_nil_l _ _ Ha). - * now unfold unorm; rewrite (nzhead_app_nil_r _ _ Ha). - + left; split; [now revert Ha; case nzhead|]. - case (uint_eq_dec (nzhead i) Nil). - * intro Hi; right; intro Hf; apply Ha. - now rewrite <-nzhead_app_nzhead, Hi, app_nil_l. - * now intro H; left. - - simpl; case (Decimal.norm e); clear e; intro e; [|now simpl]. - now case e; clear e; [|intro e..]; [|case e|..]. - - simpl. - set (m := match nzhead _ with Nil => _ | _ => _ end). - set (m' := match _ with Hexadecimal _ _ => _ | _ => _ end). - replace m' with m. - 2:{ unfold m'; case (Decimal.norm e); clear m' e; intro e; [|now simpl]. - now case e; clear e; [|intro e..]; [|case e|..]. } - unfold m; case (uint_eq_dec (nzhead (app i f)) Nil); intro Ha. - + rewrite Ha; right; split; [now simpl|split]. - * now unfold unorm; rewrite (nzhead_app_nil_l _ _ Ha). - * now unfold unorm; rewrite (nzhead_app_nil_r _ _ Ha). - + left; split; [now revert Ha; case nzhead|]. - case (uint_eq_dec (nzhead i) Nil). - * intro Hi; right; intro Hf; apply Ha. - now rewrite <-nzhead_app_nzhead, Hi, app_nil_l. - * now intro H; left. -Qed. - -Lemma dnorm_spec_f d : - let f := match d with Hexadecimal _ f => f | HexadecimalExp _ f _ => f end in - let f' := match dnorm d with Hexadecimal _ f => f | HexadecimalExp _ f _ => f end in - f' = f. -Proof. - case d as [i f|i f e]; [now simpl|]. - simpl; case (Decimal.int_eq_dec (Decimal.norm e) (Decimal.Pos Decimal.zero)); [now intros->|intro He]. - set (i' := match i with Pos _ => _ | _ => _ end). - set (m := match Decimal.norm e with Decimal.Pos _ => _ | _ => _ end). - replace m with (HexadecimalExp i' f (Decimal.norm e)); [now simpl|]. - unfold m; revert He; case (Decimal.norm e); clear m e; intro e; [|now simpl]. - now case e; clear e; [|intro e; case e|..]. -Qed. - -Lemma dnorm_spec_e d : - match d, dnorm d with - | Hexadecimal _ _, Hexadecimal _ _ => True - | HexadecimalExp _ _ e, Hexadecimal _ _ => - Decimal.norm e = Decimal.Pos Decimal.zero - | HexadecimalExp _ _ e, HexadecimalExp _ _ e' => - e' = Decimal.norm e /\ e' <> Decimal.Pos Decimal.zero - | Hexadecimal _ _, HexadecimalExp _ _ _ => False - end. -Proof. - case d as [i f|i f e]; [now simpl|]. - simpl; case (Decimal.int_eq_dec (Decimal.norm e) (Decimal.Pos Decimal.zero)); [now intros->|intro He]. - set (i' := match i with Pos _ => _ | _ => _ end). - set (m := match Decimal.norm e with Decimal.Pos _ => _ | _ => _ end). - replace m with (HexadecimalExp i' f (Decimal.norm e)); [now simpl|]. - unfold m; revert He; case (Decimal.norm e); clear m e; intro e; [|now simpl]. - now case e; clear e; [|intro e; case e|..]. -Qed. - -Lemma dnorm_involutive d : dnorm (dnorm d) = dnorm d. -Proof. - case d as [i f|i f e]; case i as [i|i]. - - now simpl; rewrite unorm_involutive. - - simpl; case (uint_eq_dec (nzhead (app i f)) Nil); [now intros->|intro Ha]. - set (m := match nzhead _ with Nil =>_ | _ => _ end). - replace m with (Neg (unorm i)). - 2:{ now unfold m; revert Ha; case nzhead. } - case (uint_eq_dec (nzhead i) Nil); intro Hi. - + unfold unorm; rewrite Hi; simpl. - case (uint_eq_dec (nzhead f) Nil). - * intro Hf; exfalso; apply Ha. - now rewrite <-nzhead_app_nzhead, Hi, app_nil_l. - * now case nzhead. - + rewrite unorm_involutive, (unorm_nzhead _ Hi), nzhead_app_nzhead. - now revert Ha; case nzhead. - - simpl; case (Decimal.int_eq_dec (Decimal.norm e) (Decimal.Pos Decimal.zero)); intro He. - + now rewrite He; simpl; rewrite unorm_involutive. - + set (m := match Decimal.norm e with Decimal.Pos _ => _ | _ => _ end). - replace m with (HexadecimalExp (Pos (unorm i)) f (Decimal.norm e)). - 2:{ unfold m; revert He; case (Decimal.norm e); clear m e; intro e; [|now simpl]. - now case e; clear e; [|intro e; case e|..]. } - simpl; rewrite DecimalFacts.norm_involutive, unorm_involutive. - revert He; case (Decimal.norm e); clear m e; intro e; [|now simpl]. - now case e; clear e; [|intro e; case e|..]. - - simpl; case (Decimal.int_eq_dec (Decimal.norm e) (Decimal.Pos Decimal.zero)); intro He. - + rewrite He; simpl. - case (uint_eq_dec (nzhead (app i f)) Nil); [now intros->|intro Ha]. - set (m := match nzhead _ with Nil =>_ | _ => _ end). - replace m with (Neg (unorm i)). - 2:{ now unfold m; revert Ha; case nzhead. } - case (uint_eq_dec (nzhead i) Nil); intro Hi. - * unfold unorm; rewrite Hi; simpl. - case (uint_eq_dec (nzhead f) Nil). - -- intro Hf; exfalso; apply Ha. - now rewrite <-nzhead_app_nzhead, Hi, app_nil_l. - -- now case nzhead. - * rewrite unorm_involutive, (unorm_nzhead _ Hi), nzhead_app_nzhead. - now revert Ha; case nzhead. - + set (m := match Decimal.norm e with Decimal.Pos _ => _ | _ => _ end). - pose (i' := match nzhead (app i f) with Nil => Pos zero | _ => Neg (unorm i) end). - replace m with (HexadecimalExp i' f (Decimal.norm e)). - 2:{ unfold m; revert He; case (Decimal.norm e); clear m e; intro e; [|now simpl]. - now case e; clear e; [|intro e; case e|..]. } - simpl; rewrite DecimalFacts.norm_involutive. - set (i'' := match i' with Pos _ => _ | _ => _ end). - clear m; set (m := match Decimal.norm e with Decimal.Pos _ => _ | _ => _ end). - replace m with (HexadecimalExp i'' f (Decimal.norm e)). - 2:{ unfold m; revert He; case (Decimal.norm e); clear m e; intro e; [|now simpl]. - now case e; clear e; [|intro e; case e|..]. } - unfold i'', i'. - case (uint_eq_dec (nzhead (app i f)) Nil); [now intros->|intro Ha]. - fold i'; replace i' with (Neg (unorm i)). - 2:{ now unfold i'; revert Ha; case nzhead. } - case (uint_eq_dec (nzhead i) Nil); intro Hi. - * unfold unorm; rewrite Hi; simpl. - case (uint_eq_dec (nzhead f) Nil). - -- intro Hf; exfalso; apply Ha. - now rewrite <-nzhead_app_nzhead, Hi, app_nil_l. - -- now case nzhead. - * rewrite unorm_involutive, (unorm_nzhead _ Hi), nzhead_app_nzhead. - now revert Ha; case nzhead. -Qed. - -Lemma IZ_to_Z_IZ_of_Z z : IZ_to_Z (IZ_of_Z z) = Some z. -Proof. now case z. Qed. - -Lemma dnorm_i_exact i f : - (nb_digits f < nb_digits (unorm (app (abs i) f)))%nat -> - match i with - | Pos i => Pos (unorm i) - | Neg i => - match nzhead (app i f) with - | Nil => Pos zero - | _ => Neg (unorm i) - end - end = norm i. -Proof. - case i as [ni|ni]; [now simpl|]; simpl. - case (uint_eq_dec (nzhead (app ni f)) Nil); intro Ha. - { now rewrite Ha, (nzhead_app_nil_l _ _ Ha). } - rewrite (unorm_nzhead _ Ha). - set (m := match nzhead _ with Nil => _ | _ => _ end). - replace m with (Neg (unorm ni)); [|now unfold m; revert Ha; case nzhead]. - case (uint_eq_dec (nzhead ni) Nil); intro Hni. - { rewrite <-nzhead_app_nzhead, Hni, app_nil_l. - intro H; exfalso; revert H; apply Nat.le_ngt, nb_digits_nzhead. } - clear m; set (m := match nzhead ni with Nil => _ | _ => _ end). - replace m with (Neg (nzhead ni)); [|now unfold m; revert Hni; case nzhead]. - now rewrite (unorm_nzhead _ Hni). -Qed. - -Lemma dnorm_i_exact' i f : - (nb_digits (unorm (app (abs i) f)) <= nb_digits f)%nat -> - match i with - | Pos i => Pos (unorm i) - | Neg i => - match nzhead (app i f) with - | Nil => Pos zero - | _ => Neg (unorm i) - end - end = - match norm (app_int i f) with - | Pos _ => Pos zero - | Neg _ => Neg zero - end. -Proof. - case i as [ni|ni]; simpl. - { now intro Hnb; rewrite (unorm_app_zero _ _ Hnb). } - unfold unorm. - case (uint_eq_dec (nzhead (app ni f)) Nil); intro Hn. - { now rewrite Hn. } - set (m := match nzhead _ with Nil => _ | _ => _ end). - replace m with (nzhead (app ni f)). - 2:{ now unfold m; revert Hn; case nzhead. } - clear m; set (m := match nzhead _ with Nil => _ | _ => _ end). - replace m with (Neg (unorm ni)). - 2:{ now unfold m, unorm; revert Hn; case nzhead. } - clear m; set (m := match nzhead _ with Nil => _ | _ => _ end). - replace m with (Neg (nzhead (app ni f))). - 2:{ now unfold m; revert Hn; case nzhead. } - rewrite <-(unorm_nzhead _ Hn). - now intro H; rewrite (unorm_app_zero _ _ H). -Qed. - -Lemma to_of (d:hexadecimal) : to_hexadecimal (of_hexadecimal d) = Some (dnorm d). -Proof. - case d as [i f|i f e]. - - unfold of_hexadecimal; simpl; unfold IQmake_to_hexadecimal'. - rewrite IZ_to_Z_IZ_of_Z. - unfold IQmake_to_hexadecimal; simpl. - change (fun _ : positive => _) with (Pos.mul 16). - rewrite nztail_to_hex_uint_pow16, to_of. - case_eq (nb_digits f); [|intro nb]; intro Hnb. - + rewrite (nb_digits_0 _ Hnb), app_int_nil_r. - case i as [ni|ni]; [now simpl|]. - rewrite app_nil_r; simpl; unfold unorm. - now case (nzhead ni). - + rewrite <-Hnb. - rewrite abs_norm, abs_app_int. - case Nat.ltb_spec; intro Hnb'. - * rewrite (del_tail_app_int_exact _ _ Hnb'). - rewrite (del_head_app_int_exact _ _ Hnb'). - now rewrite (dnorm_i_exact _ _ Hnb'). - * rewrite (unorm_app_r _ _ Hnb'). - rewrite iter_D0_unorm; [|now apply nb_digits_n0; rewrite Hnb]. - now rewrite dnorm_i_exact'. - - unfold of_hexadecimal; simpl. - rewrite <-DecimalZ.to_of. - case (Z.of_int e); clear e; [|intro e..]; simpl. - + unfold IQmake_to_hexadecimal'. - rewrite IZ_to_Z_IZ_of_Z. - unfold IQmake_to_hexadecimal; simpl. - change (fun _ : positive => _) with (Pos.mul 16). - rewrite nztail_to_hex_uint_pow16, to_of. - case_eq (nb_digits f); [|intro nb]; intro Hnb. - * rewrite (nb_digits_0 _ Hnb), app_int_nil_r. - case i as [ni|ni]; [now simpl|]. - rewrite app_nil_r; simpl; unfold unorm. - now case (nzhead ni). - * rewrite <-Hnb. - rewrite abs_norm, abs_app_int. - case Nat.ltb_spec; intro Hnb'. - -- rewrite (del_tail_app_int_exact _ _ Hnb'). - rewrite (del_head_app_int_exact _ _ Hnb'). - now rewrite (dnorm_i_exact _ _ Hnb'). - -- rewrite (unorm_app_r _ _ Hnb'). - rewrite iter_D0_unorm; [|now apply nb_digits_n0; rewrite Hnb]. - now rewrite dnorm_i_exact'. - + unfold IQmake_to_hexadecimal'. - rewrite IZ_to_Z_IZ_of_Z. - unfold IQmake_to_hexadecimal; simpl. - change (fun _ : positive => _) with (Pos.mul 16). - rewrite nztail_to_hex_uint_pow16, to_of. - generalize (DecimalPos.Unsigned.to_uint_nonzero e); intro He. - set (dnorm_i := match i with Pos _ => _ | _ => _ end). - set (m := match Pos.to_uint e with Decimal.Nil => _ | _ => _ end). - replace m with (HexadecimalExp dnorm_i f (Decimal.Pos (Pos.to_uint e))). - 2:{ now unfold m; revert He; case (Pos.to_uint e); [|intro u; case u|..]. } - clear m; unfold dnorm_i. - case_eq (nb_digits f); [|intro nb]; intro Hnb. - * rewrite (nb_digits_0 _ Hnb), app_int_nil_r. - case i as [ni|ni]; [now simpl|]. - rewrite app_nil_r; simpl; unfold unorm. - now case (nzhead ni). - * rewrite <-Hnb. - rewrite abs_norm, abs_app_int. - case Nat.ltb_spec; intro Hnb'. - -- rewrite (del_tail_app_int_exact _ _ Hnb'). - rewrite (del_head_app_int_exact _ _ Hnb'). - now rewrite (dnorm_i_exact _ _ Hnb'). - -- rewrite (unorm_app_r _ _ Hnb'). - rewrite iter_D0_unorm; [|now apply nb_digits_n0; rewrite Hnb]. - now rewrite dnorm_i_exact'. - + unfold IQmake_to_hexadecimal'. - rewrite IZ_to_Z_IZ_of_Z. - unfold IQmake_to_hexadecimal; simpl. - change (fun _ : positive => _) with (Pos.mul 16). - rewrite nztail_to_hex_uint_pow16, to_of. - case_eq (nb_digits f); [|intro nb]; intro Hnb. - * rewrite (nb_digits_0 _ Hnb), app_int_nil_r. - case i as [ni|ni]; [now simpl|]. - rewrite app_nil_r; simpl; unfold unorm. - now case (nzhead ni). - * rewrite <-Hnb. - rewrite abs_norm, abs_app_int. - case Nat.ltb_spec; intro Hnb'. - -- rewrite (del_tail_app_int_exact _ _ Hnb'). - rewrite (del_head_app_int_exact _ _ Hnb'). - now rewrite (dnorm_i_exact _ _ Hnb'). - -- rewrite (unorm_app_r _ _ Hnb'). - rewrite iter_D0_unorm; [|now apply nb_digits_n0; rewrite Hnb]. - now rewrite dnorm_i_exact'. -Qed. - -(** Some consequences *) - -Lemma to_hexadecimal_inj q q' : - to_hexadecimal q <> None -> to_hexadecimal q = to_hexadecimal q' -> q = q'. -Proof. - intros Hnone EQ. - generalize (of_to q) (of_to q'). - rewrite <-EQ. - revert Hnone; case to_hexadecimal; [|now simpl]. - now intros d _ H1 H2; rewrite <-(H1 d eq_refl), <-(H2 d eq_refl). -Qed. - -Lemma to_hexadecimal_surj d : exists q, to_hexadecimal q = Some (dnorm d). -Proof. - exists (of_hexadecimal d). apply to_of. -Qed. - -Lemma of_hexadecimal_dnorm d : of_hexadecimal (dnorm d) = of_hexadecimal d. -Proof. now apply to_hexadecimal_inj; rewrite !to_of; [|rewrite dnorm_involutive]. Qed. - -Lemma of_inj d d' : of_hexadecimal d = of_hexadecimal d' -> dnorm d = dnorm d'. -Proof. - intro H. - apply (@f_equal _ _ (fun x => match x with Some x => x | _ => d end) - (Some (dnorm d)) (Some (dnorm d'))). - now rewrite <- !to_of, H. -Qed. - -Lemma of_iff d d' : of_hexadecimal d = of_hexadecimal d' <-> dnorm d = dnorm d'. -Proof. - split. - - apply of_inj. - - intros E. rewrite <- of_hexadecimal_dnorm, E. - apply of_hexadecimal_dnorm. -Qed. diff --git a/stdlib/theories/Numbers/HexadecimalR.v b/stdlib/theories/Numbers/HexadecimalR.v deleted file mode 100644 index 8293e848a1a5..000000000000 --- a/stdlib/theories/Numbers/HexadecimalR.v +++ /dev/null @@ -1,305 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* True - | Some (HexadecimalExp _ _ _) => False - | Some (Hexadecimal i f) => - of_hexadecimal (Hexadecimal i f) = IRQ (QArith_base.Qmake num den) - end. -Proof. - unfold IQmake_to_hexadecimal. - case (Pos.eq_dec den 1); [now intros->|intro Hden]. - assert (Hf : match QArith_base.IQmake_to_hexadecimal num den with - | Some (Hexadecimal i f) => f <> Nil - | _ => True - end). - { unfold QArith_base.IQmake_to_hexadecimal; simpl. - generalize (Unsigned.nztail_to_hex_uint den). - case Hexadecimal.nztail as [den' e_den']. - case den'; [now simpl|now simpl| |now simpl..]; clear den'; intro den'. - case den'; [ |now simpl..]; clear den'. - case e_den' as [|e_den']; [now simpl; intros H _; apply Hden; injection H|]. - intros _. - case Nat.ltb_spec; intro He_den'. - - apply del_head_nonnil. - revert He_den'; case nb_digits as [|n]; [now simpl|]. - now intro H; simpl; apply Nat.lt_succ_r, Nat.le_sub_l. - - apply nb_digits_n0. - now rewrite nb_digits_iter_D0, Nat.sub_add. } - replace (match den with 1%positive => _ | _ => _ end) - with (QArith_base.IQmake_to_hexadecimal num den); [|now revert Hden; case den]. - generalize (of_IQmake_to_hexadecimal num den). - case QArith_base.IQmake_to_hexadecimal as [d'|]; [|now simpl]. - case d' as [i f|]; [|now simpl]. - unfold of_hexadecimal; simpl. - injection 1 as H <-. - generalize (f_equal QArith_base.IZ_to_Z H); clear H. - rewrite !IZ_to_Z_IZ_of_Z; injection 1 as <-. - now revert Hf; case f. -Qed. - -Lemma of_to (q:IR) : forall d, to_hexadecimal q = Some d -> of_hexadecimal d = q. -Proof. - intro d. - case q as [z|q|r r'|r r']; simpl. - - case z as [z p| |p|p]. - + now simpl. - + now simpl; injection 1 as <-. - + simpl; injection 1 as <-. - now unfold of_hexadecimal; simpl; unfold Z.of_hex_uint; rewrite Unsigned.of_to. - + simpl; injection 1 as <-. - now unfold of_hexadecimal; simpl; unfold Z.of_hex_uint; rewrite Unsigned.of_to. - - case q as [num den]. - generalize (of_IQmake_to_hexadecimal num den). - case IQmake_to_hexadecimal as [d'|]; [|now simpl]. - case d' as [i f|]; [|now simpl]. - now intros H; injection 1 as <-. - - case r as [z|q| |]; [|case q as[num den]|now simpl..]; - (case r' as [z'| | |]; [|now simpl..]); - (case z' as [p e| | |]; [|now simpl..]). - + case (Z.eq_dec p 2); [intros->|intro Hp]. - 2:{ now revert Hp; case p; - [|intro d0; case d0; [intro d1..|]; [|case d1|]..]. } - case z as [| |p|p]; [now simpl|..]; injection 1 as <-. - * now unfold of_hexadecimal; simpl; unfold Z.of_uint; rewrite DecimalPos.Unsigned.of_to. - * unfold of_hexadecimal; simpl; unfold Z.of_uint; rewrite DecimalPos.Unsigned.of_to; simpl. - now unfold Z.of_hex_uint; rewrite Unsigned.of_to. - * unfold of_hexadecimal; simpl; unfold Z.of_uint; rewrite DecimalPos.Unsigned.of_to; simpl. - now unfold Z.of_hex_uint; rewrite Unsigned.of_to. - + case (Z.eq_dec p 2); [intros->|intro Hp]. - 2:{ now revert Hp; case p; - [|intro d0; case d0; [intro d1..|]; [|case d1|]..]. } - generalize (of_IQmake_to_hexadecimal num den). - case IQmake_to_hexadecimal as [d'|]; [|now simpl]. - case d' as [i f|]; [|now simpl]. - intros H; injection 1 as <-. - unfold of_hexadecimal; simpl. - change (match f with Nil => _ | _ => _ end) with (of_hexadecimal (Hexadecimal i f)). - rewrite H; clear H. - now unfold Z.of_uint; rewrite DecimalPos.Unsigned.of_to. - - case r as [z|q| |]; [|case q as[num den]|now simpl..]; - (case r' as [z'| | |]; [|now simpl..]); - (case z' as [p e| | |]; [|now simpl..]). - + case (Z.eq_dec p 2); [intros->|intro Hp]. - 2:{ now revert Hp; case p; - [|intro d0; case d0; [intro d1..|]; [|case d1|]..]. } - case z as [| |p|p]; [now simpl|..]; injection 1 as <-. - * now unfold of_hexadecimal; simpl; unfold Z.of_uint; rewrite DecimalPos.Unsigned.of_to. - * unfold of_hexadecimal; simpl; unfold Z.of_uint; rewrite DecimalPos.Unsigned.of_to; simpl. - now unfold Z.of_hex_uint; rewrite Unsigned.of_to. - * unfold of_hexadecimal; simpl; unfold Z.of_uint; rewrite DecimalPos.Unsigned.of_to; simpl. - now unfold Z.of_hex_uint; rewrite Unsigned.of_to. - + case (Z.eq_dec p 2); [intros->|intro Hp]. - 2:{ now revert Hp; case p; - [|intro d0; case d0; [intro d1..|]; [|case d1|]..]. } - generalize (of_IQmake_to_hexadecimal num den). - case IQmake_to_hexadecimal as [d'|]; [|now simpl]. - case d' as [i f|]; [|now simpl]. - intros H; injection 1 as <-. - unfold of_hexadecimal; simpl. - change (match f with Nil => _ | _ => _ end) with (of_hexadecimal (Hexadecimal i f)). - rewrite H; clear H. - now unfold Z.of_uint; rewrite DecimalPos.Unsigned.of_to. -Qed. - -Lemma to_of (d:hexadecimal) : to_hexadecimal (of_hexadecimal d) = Some (dnorm d). -Proof. - case d as [i f|i f e]. - - unfold of_hexadecimal; simpl. - case (uint_eq_dec f Nil); intro Hf. - + rewrite Hf; clear f Hf. - unfold to_hexadecimal; simpl. - rewrite IZ_to_Z_IZ_of_Z, HexadecimalZ.to_of. - case i as [i|i]; [now simpl|]; simpl. - rewrite app_nil_r. - case (uint_eq_dec (nzhead i) Nil); [now intros->|intro Hi]. - now rewrite (unorm_nzhead _ Hi); revert Hi; case nzhead. - + set (r := IRQ _). - set (m := match f with Nil => _ | _ => _ end). - replace m with r; [unfold r|now unfold m; revert Hf; case f]. - unfold to_hexadecimal; simpl. - unfold IQmake_to_hexadecimal; simpl. - set (n := Nat.iter _ _ _). - case (Pos.eq_dec n 1); intro Hn. - * exfalso; apply Hf. - { now apply nb_digits_0; revert Hn; unfold n; case nb_digits. } - * clear m; set (m := match n with 1%positive | _ => _ end). - replace m with (QArith_base.IQmake_to_hexadecimal (Z.of_hex_int (app_int i f)) n). - 2:{ now unfold m; revert Hn; case n. } - unfold QArith_base.IQmake_to_hexadecimal, n; simpl. - rewrite nztail_to_hex_uint_pow16. - clear r; set (r := if _ _ | _ => _ end). - replace m with r; [unfold r|now unfold m; revert Hf; case f]. - rewrite HexadecimalZ.to_of, abs_norm, abs_app_int. - case Nat.ltb_spec; intro Hnf. - -- rewrite (del_tail_app_int_exact _ _ Hnf). - rewrite (del_head_app_int_exact _ _ Hnf). - now rewrite (dnorm_i_exact _ _ Hnf). - -- rewrite (unorm_app_r _ _ Hnf). - rewrite (iter_D0_unorm _ Hf). - now rewrite dnorm_i_exact'. - - unfold of_hexadecimal; simpl. - rewrite <-(DecimalZ.to_of e). - case (Z.of_int e); clear e; [|intro e..]; simpl. - + case (uint_eq_dec f Nil); intro Hf. - * rewrite Hf; clear f Hf. - unfold to_hexadecimal; simpl. - rewrite IZ_to_Z_IZ_of_Z, HexadecimalZ.to_of. - case i as [i|i]; [now simpl|]; simpl. - rewrite app_nil_r. - case (uint_eq_dec (nzhead i) Nil); [now intros->|intro Hi]. - now rewrite (unorm_nzhead _ Hi); revert Hi; case nzhead. - * set (r := IRQ _). - set (m := match f with Nil => _ | _ => _ end). - replace m with r; [unfold r|now unfold m; revert Hf; case f]. - unfold to_hexadecimal; simpl. - unfold IQmake_to_hexadecimal; simpl. - set (n := Nat.iter _ _ _). - case (Pos.eq_dec n 1); intro Hn. - -- exfalso; apply Hf. - { now apply nb_digits_0; revert Hn; unfold n; case nb_digits. } - -- clear m; set (m := match n with 1%positive | _ => _ end). - replace m with (QArith_base.IQmake_to_hexadecimal (Z.of_hex_int (app_int i f)) n). - 2:{ now unfold m; revert Hn; case n. } - unfold QArith_base.IQmake_to_hexadecimal, n; simpl. - rewrite nztail_to_hex_uint_pow16. - clear r; set (r := if _ _ | _ => _ end). - replace m with r; [unfold r|now unfold m; revert Hf; case f]. - rewrite HexadecimalZ.to_of, abs_norm, abs_app_int. - case Nat.ltb_spec; intro Hnf. - ++ rewrite (del_tail_app_int_exact _ _ Hnf). - rewrite (del_head_app_int_exact _ _ Hnf). - now rewrite (dnorm_i_exact _ _ Hnf). - ++ rewrite (unorm_app_r _ _ Hnf). - rewrite (iter_D0_unorm _ Hf). - now rewrite dnorm_i_exact'. - + set (i' := match i with Pos _ => _ | _ => _ end). - set (m := match Pos.to_uint e with Decimal.Nil => _ | _ => _ end). - replace m with (HexadecimalExp i' f (Decimal.Pos (Pos.to_uint e))). - 2:{ unfold m; generalize (DecimalPos.Unsigned.to_uint_nonzero e). - now case Pos.to_uint; [|intro u; case u|..]. } - unfold i'; clear i' m. - case (uint_eq_dec f Nil); intro Hf. - * rewrite Hf; clear f Hf. - unfold to_hexadecimal; simpl. - rewrite IZ_to_Z_IZ_of_Z, HexadecimalZ.to_of. - case i as [i|i]; [now simpl|]; simpl. - rewrite app_nil_r. - case (uint_eq_dec (nzhead i) Nil); [now intros->|intro Hi]. - now rewrite (unorm_nzhead _ Hi); revert Hi; case nzhead. - * set (r := IRQ _). - set (m := match f with Nil => _ | _ => _ end). - replace m with r; [unfold r|now unfold m; revert Hf; case f]. - unfold to_hexadecimal; simpl. - unfold IQmake_to_hexadecimal; simpl. - set (n := Nat.iter _ _ _). - case (Pos.eq_dec n 1); intro Hn. - { exfalso; apply Hf. - now apply nb_digits_0; revert Hn; unfold n; case nb_digits. } - clear m; set (m := match n with 1%positive | _ => _ end). - replace m with (QArith_base.IQmake_to_hexadecimal (Z.of_hex_int (app_int i f)) n). - 2:{ now unfold m; revert Hn; case n. } - unfold QArith_base.IQmake_to_hexadecimal, n; simpl. - rewrite nztail_to_hex_uint_pow16. - clear r; set (r := if _ _ | _ => _ end). - replace m with r; [unfold r|now unfold m; revert Hf; case f]. - rewrite HexadecimalZ.to_of, abs_norm, abs_app_int. - case Nat.ltb_spec; intro Hnf. - -- rewrite (del_tail_app_int_exact _ _ Hnf). - rewrite (del_head_app_int_exact _ _ Hnf). - now rewrite (dnorm_i_exact _ _ Hnf). - -- rewrite (unorm_app_r _ _ Hnf). - rewrite (iter_D0_unorm _ Hf). - now rewrite dnorm_i_exact'. - + case (uint_eq_dec f Nil); intro Hf. - * rewrite Hf; clear f Hf. - unfold to_hexadecimal; simpl. - rewrite IZ_to_Z_IZ_of_Z, HexadecimalZ.to_of. - case i as [i|i]; [now simpl|]; simpl. - rewrite app_nil_r. - case (uint_eq_dec (nzhead i) Nil); [now intros->|intro Hi]. - now rewrite (unorm_nzhead _ Hi); revert Hi; case nzhead. - * set (r := IRQ _). - set (m := match f with Nil => _ | _ => _ end). - replace m with r; [unfold r|now unfold m; revert Hf; case f]. - unfold to_hexadecimal; simpl. - unfold IQmake_to_hexadecimal; simpl. - set (n := Nat.iter _ _ _). - case (Pos.eq_dec n 1); intro Hn. - { exfalso; apply Hf. - now apply nb_digits_0; revert Hn; unfold n; case nb_digits. } - clear m; set (m := match n with 1%positive | _ => _ end). - replace m with (QArith_base.IQmake_to_hexadecimal (Z.of_hex_int (app_int i f)) n). - 2:{ now unfold m; revert Hn; case n. } - unfold QArith_base.IQmake_to_hexadecimal, n; simpl. - rewrite nztail_to_hex_uint_pow16. - clear r; set (r := if _ _ | _ => _ end). - replace m with r; [unfold r|now unfold m; revert Hf; case f]. - rewrite HexadecimalZ.to_of, abs_norm, abs_app_int. - case Nat.ltb_spec; intro Hnf. - -- rewrite (del_tail_app_int_exact _ _ Hnf). - rewrite (del_head_app_int_exact _ _ Hnf). - now rewrite (dnorm_i_exact _ _ Hnf). - -- rewrite (unorm_app_r _ _ Hnf). - rewrite (iter_D0_unorm _ Hf). - now rewrite dnorm_i_exact'. -Qed. - -(** Some consequences *) - -Lemma to_hexadecimal_inj q q' : - to_hexadecimal q <> None -> to_hexadecimal q = to_hexadecimal q' -> q = q'. -Proof. - intros Hnone EQ. - generalize (of_to q) (of_to q'). - rewrite <-EQ. - revert Hnone; case to_hexadecimal; [|now simpl]. - now intros d _ H1 H2; rewrite <-(H1 d eq_refl), <-(H2 d eq_refl). -Qed. - -Lemma to_hexadecimal_surj d : exists q, to_hexadecimal q = Some (dnorm d). -Proof. - exists (of_hexadecimal d). apply to_of. -Qed. - -Lemma of_hexadecimal_dnorm d : of_hexadecimal (dnorm d) = of_hexadecimal d. -Proof. now apply to_hexadecimal_inj; rewrite !to_of; [|rewrite dnorm_involutive]. Qed. - -Lemma of_inj d d' : of_hexadecimal d = of_hexadecimal d' -> dnorm d = dnorm d'. -Proof. - intro H. - apply (@f_equal _ _ (fun x => match x with Some x => x | _ => d end) - (Some (dnorm d)) (Some (dnorm d'))). - now rewrite <- !to_of, H. -Qed. - -Lemma of_iff d d' : of_hexadecimal d = of_hexadecimal d' <-> dnorm d = dnorm d'. -Proof. - split. - - apply of_inj. - - intros E. rewrite <- of_hexadecimal_dnorm, E. - apply of_hexadecimal_dnorm. -Qed. diff --git a/stdlib/theories/Numbers/HexadecimalString.v b/stdlib/theories/Numbers/HexadecimalString.v deleted file mode 100644 index bb851be727a6..000000000000 --- a/stdlib/theories/Numbers/HexadecimalString.v +++ /dev/null @@ -1,286 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* None - | Some d => - match a with - | "0" => Some (D0 d) - | "1" => Some (D1 d) - | "2" => Some (D2 d) - | "3" => Some (D3 d) - | "4" => Some (D4 d) - | "5" => Some (D5 d) - | "6" => Some (D6 d) - | "7" => Some (D7 d) - | "8" => Some (D8 d) - | "9" => Some (D9 d) - | "a" => Some (Da d) - | "b" => Some (Db d) - | "c" => Some (Dc d) - | "d" => Some (Dd d) - | "e" => Some (De d) - | "f" => Some (Df d) - | _ => None - end - end%char. - -Lemma uint_of_char_spec c d d' : - uint_of_char c (Some d) = Some d' -> - (c = "0" /\ d' = D0 d \/ - c = "1" /\ d' = D1 d \/ - c = "2" /\ d' = D2 d \/ - c = "3" /\ d' = D3 d \/ - c = "4" /\ d' = D4 d \/ - c = "5" /\ d' = D5 d \/ - c = "6" /\ d' = D6 d \/ - c = "7" /\ d' = D7 d \/ - c = "8" /\ d' = D8 d \/ - c = "9" /\ d' = D9 d \/ - c = "a" /\ d' = Da d \/ - c = "b" /\ d' = Db d \/ - c = "c" /\ d' = Dc d \/ - c = "d" /\ d' = Dd d \/ - c = "e" /\ d' = De d \/ - c = "f" /\ d' = Df d)%char. -Proof. - destruct c as [[|] [|] [|] [|] [|] [|] [|] [|]]; - intros [= <-]; intuition. -Qed. - -(** Hexadecimal/String conversion where [Nil] is [""] *) - -Module NilEmpty. - -Fixpoint string_of_uint (d:uint) := - match d with - | Nil => EmptyString - | D0 d => String "0" (string_of_uint d) - | D1 d => String "1" (string_of_uint d) - | D2 d => String "2" (string_of_uint d) - | D3 d => String "3" (string_of_uint d) - | D4 d => String "4" (string_of_uint d) - | D5 d => String "5" (string_of_uint d) - | D6 d => String "6" (string_of_uint d) - | D7 d => String "7" (string_of_uint d) - | D8 d => String "8" (string_of_uint d) - | D9 d => String "9" (string_of_uint d) - | Da d => String "a" (string_of_uint d) - | Db d => String "b" (string_of_uint d) - | Dc d => String "c" (string_of_uint d) - | Dd d => String "d" (string_of_uint d) - | De d => String "e" (string_of_uint d) - | Df d => String "f" (string_of_uint d) - end. - -Fixpoint uint_of_string s := - match s with - | EmptyString => Some Nil - | String a s => uint_of_char a (uint_of_string s) - end. - -Definition string_of_int (d:int) := - match d with - | Pos d => string_of_uint d - | Neg d => String "-" (string_of_uint d) - end. - -Definition int_of_string s := - match s with - | EmptyString => Some (Pos Nil) - | String a s' => - if Ascii.eqb a "-" then option_map Neg (uint_of_string s') - else option_map Pos (uint_of_string s) - end. - -(* NB: For the moment whitespace between - and digits are not accepted. - And in this variant [int_of_string "-" = Some (Neg Nil)]. - -Compute int_of_string "-123456890123456890123456890123456890". -Compute string_of_int (-123456890123456890123456890123456890). -*) - -(** Corresponding proofs *) - -Lemma usu d : - uint_of_string (string_of_uint d) = Some d. -Proof. - induction d; simpl; rewrite ?IHd; simpl; auto. -Qed. - -Lemma sus s d : - uint_of_string s = Some d -> string_of_uint d = s. -Proof. - revert d. - induction s; simpl. - - now intros d [= <-]. - - intros d. - destruct (uint_of_string s); [intros H | intros [=]]. - apply uint_of_char_spec in H. - intuition subst; simpl; f_equal; auto. -Qed. - -Lemma isi d : int_of_string (string_of_int d) = Some d. -Proof. - destruct d; simpl. - - unfold int_of_string. - destruct (string_of_uint d) eqn:Hd. - + now destruct d. - + case Ascii.eqb_spec. - * intros ->. now destruct d. - * rewrite <- Hd, usu; auto. - - rewrite usu; auto. -Qed. - -Lemma sis s d : - int_of_string s = Some d -> string_of_int d = s. -Proof. - destruct s; [intros [= <-]| ]; simpl; trivial. - case Ascii.eqb_spec. - - intros ->. destruct (uint_of_string s) eqn:Hs; simpl; intros [= <-]. - simpl; f_equal. now apply sus. - - destruct d; [ | now destruct uint_of_char]. - simpl string_of_int. - intros. apply sus; simpl. - destruct uint_of_char; simpl in *; congruence. -Qed. - -End NilEmpty. - -(** Hexadecimal/String conversions where [Nil] is ["0"] *) - -Module NilZero. - -Definition string_of_uint (d:uint) := - match d with - | Nil => "0" - | _ => NilEmpty.string_of_uint d - end. - -Definition uint_of_string s := - match s with - | EmptyString => None - | _ => NilEmpty.uint_of_string s - end. - -Definition string_of_int (d:int) := - match d with - | Pos d => string_of_uint d - | Neg d => String "-" (string_of_uint d) - end. - -Definition int_of_string s := - match s with - | EmptyString => None - | String a s' => - if Ascii.eqb a "-" then option_map Neg (uint_of_string s') - else option_map Pos (uint_of_string s) - end. - -(** Corresponding proofs *) - -Lemma uint_of_string_nonnil s : uint_of_string s <> Some Nil. -Proof. - destruct s; simpl. - - easy. - - destruct (NilEmpty.uint_of_string s); [intros H | intros [=]]. - apply uint_of_char_spec in H. - now intuition subst. -Qed. - -Lemma sus s d : - uint_of_string s = Some d -> string_of_uint d = s. -Proof. - destruct s; [intros [=] | intros H]. - apply NilEmpty.sus in H. now destruct d. -Qed. - -Lemma usu d : - d<>Nil -> uint_of_string (string_of_uint d) = Some d. -Proof. - destruct d; (now destruct 1) || (intros _; apply NilEmpty.usu). -Qed. - -Lemma usu_nil : - uint_of_string (string_of_uint Nil) = Some Hexadecimal.zero. -Proof. - reflexivity. -Qed. - -Lemma usu_gen d : - uint_of_string (string_of_uint d) = Some d \/ - uint_of_string (string_of_uint d) = Some Hexadecimal.zero. -Proof. - destruct d; (now right) || (left; now apply usu). -Qed. - -Lemma isi d : - d<>Pos Nil -> d<>Neg Nil -> - int_of_string (string_of_int d) = Some d. -Proof. - destruct d; simpl. - - intros H _. - unfold int_of_string. - destruct (string_of_uint d) eqn:Hd. - + now destruct d. - + case Ascii.eqb_spec. - * intros ->. now destruct d. - * rewrite <- Hd, usu; auto. now intros ->. - - intros _ H. - rewrite usu; auto. now intros ->. -Qed. - -Lemma isi_posnil : - int_of_string (string_of_int (Pos Nil)) = Some (Pos Hexadecimal.zero). -Proof. - reflexivity. -Qed. - -(** Warning! (-0) won't parse (compatibility with the behavior of Z). *) - -Lemma isi_negnil : - int_of_string (string_of_int (Neg Nil)) = Some (Neg (D0 Nil)). -Proof. - reflexivity. -Qed. - -Lemma sis s d : - int_of_string s = Some d -> string_of_int d = s. -Proof. - destruct s; [intros [=]| ]; simpl. - case Ascii.eqb_spec. - - intros ->. destruct (uint_of_string s) eqn:Hs; simpl; intros [= <-]. - simpl; f_equal. now apply sus. - - destruct d; [ | now destruct uint_of_char]. - simpl string_of_int. - intros. apply sus; simpl. - destruct uint_of_char; simpl in *; congruence. -Qed. - -End NilZero. diff --git a/stdlib/theories/Numbers/HexadecimalZ.v b/stdlib/theories/Numbers/HexadecimalZ.v deleted file mode 100644 index 19d1079bcbe1..000000000000 --- a/stdlib/theories/Numbers/HexadecimalZ.v +++ /dev/null @@ -1,165 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* n = n'. -Proof. - intro EQ. - now rewrite <- (of_to n), <- (of_to n'), EQ. -Qed. - -Lemma to_int_surj d : exists n, Z.to_hex_int n = norm d. -Proof. - exists (Z.of_hex_int d). apply to_of. -Qed. - -Lemma of_int_norm d : Z.of_hex_int (norm d) = Z.of_hex_int d. -Proof. - unfold Z.of_hex_int, Z.of_hex_uint. - destruct d. - - simpl. now rewrite HexadecimalPos.Unsigned.of_uint_norm. - - simpl. destruct (nzhead d) eqn:H; - [ induction d; simpl; auto; discriminate | - destruct (nzhead_nonzero _ _ H) | .. ]; - f_equal; f_equal; apply HexadecimalPos.Unsigned.of_iff; - unfold unorm; now rewrite H. -Qed. - -Lemma of_inj d d' : - Z.of_hex_int d = Z.of_hex_int d' -> norm d = norm d'. -Proof. - intros. rewrite <- !to_of. now f_equal. -Qed. - -Lemma of_iff d d' : Z.of_hex_int d = Z.of_hex_int d' <-> norm d = norm d'. -Proof. - split. - - apply of_inj. - - intros E. rewrite <- of_int_norm, E. - apply of_int_norm. -Qed. - -(** Various lemmas *) - -Lemma of_hex_uint_iter_D0 d n : - Z.of_hex_uint (app d (Nat.iter n D0 Nil)) - = Nat.iter n (Z.mul 0x10) (Z.of_hex_uint d). -Proof. - rewrite <-(rev_rev (app _ _)), <-(of_list_to_list (rev (app _ _))). - rewrite rev_spec, app_spec, List.rev_app_distr. - rewrite <-!rev_spec, <-app_spec, of_list_to_list. - unfold Z.of_hex_uint; rewrite Unsigned.of_lu_rev. - unfold app; rewrite Unsigned.of_lu_revapp, !rev_rev. - rewrite <-!Unsigned.of_lu_rev, !rev_rev. - assert (H' : Pos.of_hex_uint (Nat.iter n D0 Nil) = 0%N). - { now induction n; [|rewrite Unsigned.nat_iter_S]. } - rewrite H', N.add_0_l; clear H'. - induction n; [now simpl; rewrite N.mul_1_r|]. - rewrite !Unsigned.nat_iter_S, <-IHn. - simpl Unsigned.usize; rewrite N.pow_succ_r'. - rewrite !N2Z.inj_mul; simpl Z.of_N; ring. -Qed. - -Lemma of_hex_int_iter_D0 d n : - Z.of_hex_int (app_int d (Nat.iter n D0 Nil)) - = Nat.iter n (Z.mul 0x10) (Z.of_hex_int d). -Proof. - case d; clear d; intro d; simpl. - - now rewrite of_hex_uint_iter_D0. - - rewrite of_hex_uint_iter_D0; induction n; [now simpl|]. - rewrite !Unsigned.nat_iter_S, <-IHn; ring. -Qed. - -Definition double d := - match d with - | Pos u => Pos (Unsigned.double u) - | Neg u => Neg (Unsigned.double u) - end. - -Lemma double_norm d : double (norm d) = norm (double d). -Proof. - destruct d. - - now simpl; rewrite Unsigned.double_unorm. - - simpl; rewrite <-Unsigned.double_nzhead. - case (uint_eq_dec (nzhead d) Nil); intro Hnzd. - + now rewrite Hnzd. - + assert (H : Unsigned.double (nzhead d) <> Nil). - { unfold Unsigned.double. - intro H; apply Hnzd, rev_nil_inv. - now generalize (rev_nil_inv _ H); case rev. } - revert H. - set (r := Unsigned.double _). - set (m := match r with Nil => Pos zero | _ => _ end). - intro H. - assert (H' : m = Neg r). - { now unfold m; clear m; revert H; case r. } - rewrite H'; unfold r; clear m r H H'. - now revert Hnzd; case nzhead. -Qed. - -Lemma of_hex_int_double d : - Z.of_hex_int (double d) = Z.double (Z.of_hex_int d). -Proof. - now destruct d; simpl; unfold Z.of_hex_uint; - rewrite Unsigned.of_hex_uint_double; case Pos.of_hex_uint. -Qed. - -Lemma double_to_hex_int n : - double (Z.to_hex_int n) = Z.to_hex_int (Z.double n). -Proof. now rewrite <-(of_to n), <-of_hex_int_double, !to_of, double_norm. Qed. - -Lemma nztail_to_hex_uint_pow16 n : - Hexadecimal.nztail (Pos.to_hex_uint (Nat.iter n (Pos.mul 16) 1%positive)) - = (D1 Nil, n). -Proof. - case n as [|n]; [now simpl|]. - rewrite <-(Nat2Pos.id (S n)); [|now simpl]. - generalize (Pos.of_nat (S n)); clear n; intro p. - induction (Pos.to_nat p); [now simpl|]. - rewrite Unsigned.nat_iter_S. - unfold Pos.to_hex_uint. - change (Pos.to_little_hex_uint _) - with (Unsigned.to_lu (16 * N.pos (Nat.iter n (Pos.mul 16) 1%positive))). - rewrite Unsigned.to_lhex_tenfold. - revert IHn; unfold Pos.to_hex_uint. - unfold Hexadecimal.nztail; rewrite !rev_rev; simpl. - set (f'' := _ (Pos.to_little_hex_uint _)). - now case f''; intros r n' H; inversion H. -Qed. diff --git a/stdlib/theories/Numbers/Integer/Abstract/ZAdd.v b/stdlib/theories/Numbers/Integer/Abstract/ZAdd.v deleted file mode 100644 index e8841f6e8fab..000000000000 --- a/stdlib/theories/Numbers/Integer/Abstract/ZAdd.v +++ /dev/null @@ -1,295 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* n == m. -Proof. -intros H. apply opp_wd in H. now rewrite 2 opp_involutive in H. -Qed. - -Theorem opp_inj_wd n m : - n == - m <-> n == m. -Proof. -split; [apply opp_inj | intros; now f_equiv]. -Qed. - -Theorem eq_opp_l n m : - n == m <-> n == - m. -Proof. -now rewrite <- (opp_inj_wd (- n) m), opp_involutive. -Qed. - -Theorem eq_opp_r n m : n == - m <-> - n == m. -Proof. -symmetry; apply eq_opp_l. -Qed. - -Theorem sub_add_distr n m p : n - (m + p) == (n - m) - p. -Proof. -rewrite <- add_opp_r, opp_add_distr, add_assoc. -now rewrite 2 add_opp_r. -Qed. - -Theorem sub_sub_distr n m p : n - (m - p) == (n - m) + p. -Proof. -rewrite <- add_opp_r, opp_sub_distr, add_assoc. -now rewrite add_opp_r. -Qed. - -Theorem sub_opp_l n m : - n - m == - m - n. -Proof. -rewrite <- 2 add_opp_r. now rewrite add_comm. -Qed. - -Theorem sub_opp_r n m : n - (- m) == n + m. -Proof. -rewrite <- add_opp_r; now rewrite opp_involutive. -Qed. - -Theorem add_sub_swap n m p : n + m - p == n - p + m. -Proof. -rewrite <- add_sub_assoc, <- (add_opp_r n p), <- add_assoc. -now rewrite add_opp_l. -Qed. - -Theorem sub_cancel_l n m p : n - m == n - p <-> m == p. -Proof. -rewrite <- (add_cancel_l (n - m) (n - p) (- n)). -rewrite 2 add_sub_assoc. rewrite add_opp_diag_l; rewrite 2 sub_0_l. -apply opp_inj_wd. -Qed. - -Theorem sub_cancel_r n m p : n - p == m - p <-> n == m. -Proof. -stepl (n - p + p == m - p + p) by apply add_cancel_r. -now do 2 rewrite <- sub_sub_distr, sub_diag, sub_0_r. -Qed. - -(** The next several theorems are devoted to moving terms from one - side of an equation to the other. The name contains the operation - in the original equation ([add] or [sub]) and the indication - whether the left or right term is moved. *) - -Theorem add_move_l n m p : n + m == p <-> m == p - n. -Proof. -stepl (n + m - n == p - n) by apply sub_cancel_r. -now rewrite add_comm, <- add_sub_assoc, sub_diag, add_0_r. -Qed. - -Theorem add_move_r n m p : n + m == p <-> n == p - m. -Proof. -rewrite add_comm; now apply add_move_l. -Qed. - -(** The two theorems above do not allow rewriting subformulas of the - form [n - m == p] to [n == p + m] since subtraction is in the - right-hand side of the equation. Hence the following two - theorems. *) - -Theorem sub_move_l n m p : n - m == p <-> - m == p - n. -Proof. -rewrite <- (add_opp_r n m); apply add_move_l. -Qed. - -Theorem sub_move_r n m p : n - m == p <-> n == p + m. -Proof. -rewrite <- (add_opp_r n m). now rewrite add_move_r, sub_opp_r. -Qed. - -Theorem add_move_0_l n m : n + m == 0 <-> m == - n. -Proof. -now rewrite add_move_l, sub_0_l. -Qed. - -Theorem add_move_0_r n m : n + m == 0 <-> n == - m. -Proof. -now rewrite add_move_r, sub_0_l. -Qed. - -Theorem sub_move_0_l n m : n - m == 0 <-> - m == - n. -Proof. -now rewrite sub_move_l, sub_0_l. -Qed. - -Theorem sub_move_0_r n m : n - m == 0 <-> n == m. -Proof. -now rewrite sub_move_r, add_0_l. -Qed. - -(** The following section is devoted to cancellation of like - terms. The name includes the first operator and the position of - the term being canceled. *) - -Theorem add_simpl_l n m : n + m - n == m. -Proof. -now rewrite add_sub_swap, sub_diag, add_0_l. -Qed. - -Theorem add_simpl_r n m : n + m - m == n. -Proof. -now rewrite <- add_sub_assoc, sub_diag, add_0_r. -Qed. - -Theorem sub_simpl_l n m : - n - m + n == - m. -Proof. -now rewrite <- add_sub_swap, add_opp_diag_l, sub_0_l. -Qed. - -Theorem sub_simpl_r n m : n - m + m == n. -Proof. -now rewrite <- sub_sub_distr, sub_diag, sub_0_r. -Qed. - -Theorem sub_add n m : m - n + n == m. -Proof. -now rewrite <- add_sub_swap, add_simpl_r. -Qed. - -(** Now we have two sums or differences; the name includes the two - operators and the position of the terms being canceled *) - -Theorem add_add_simpl_l_l n m p : (n + m) - (n + p) == m - p. -Proof. -now rewrite (add_comm n m), <- add_sub_assoc, -sub_add_distr, sub_diag, sub_0_l, add_opp_r. -Qed. - -Theorem add_add_simpl_l_r n m p : (n + m) - (p + n) == m - p. -Proof. -rewrite (add_comm p n); apply add_add_simpl_l_l. -Qed. - -Theorem add_add_simpl_r_l n m p : (n + m) - (m + p) == n - p. -Proof. -rewrite (add_comm n m); apply add_add_simpl_l_l. -Qed. - -Theorem add_add_simpl_r_r n m p : (n + m) - (p + m) == n - p. -Proof. -rewrite (add_comm p m); apply add_add_simpl_r_l. -Qed. - -Theorem sub_add_simpl_r_l n m p : (n - m) + (m + p) == n + p. -Proof. -now rewrite <- sub_sub_distr, sub_add_distr, sub_diag, -sub_0_l, sub_opp_r. -Qed. - -Theorem sub_add_simpl_r_r n m p : (n - m) + (p + m) == n + p. -Proof. -rewrite (add_comm p m); apply sub_add_simpl_r_l. -Qed. - -(** Of course, there are many other variants *) - -End ZAddProp. diff --git a/stdlib/theories/Numbers/Integer/Abstract/ZAddOrder.v b/stdlib/theories/Numbers/Integer/Abstract/ZAddOrder.v deleted file mode 100644 index afc66e94e785..000000000000 --- a/stdlib/theories/Numbers/Integer/Abstract/ZAddOrder.v +++ /dev/null @@ -1,285 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* m < 0 -> n + m < 0. -Proof. -intros. rewrite <- (add_0_l 0). now apply add_lt_mono. -Qed. - -Theorem add_neg_nonpos : forall n m, n < 0 -> m <= 0 -> n + m < 0. -Proof. -intros. rewrite <- (add_0_l 0). now apply add_lt_le_mono. -Qed. - -Theorem add_nonpos_neg : forall n m, n <= 0 -> m < 0 -> n + m < 0. -Proof. -intros. rewrite <- (add_0_l 0). now apply add_le_lt_mono. -Qed. - -Theorem add_nonpos_nonpos : forall n m, n <= 0 -> m <= 0 -> n + m <= 0. -Proof. -intros. rewrite <- (add_0_l 0). now apply add_le_mono. -Qed. - -(** Sub and order *) - -Theorem lt_0_sub : forall n m, 0 < m - n <-> n < m. -Proof. -intros n m. now rewrite (add_lt_mono_r _ _ n), add_0_l, sub_simpl_r. -Qed. - -Notation sub_pos := lt_0_sub (only parsing). - -Theorem le_0_sub : forall n m, 0 <= m - n <-> n <= m. -Proof. -intros n m. now rewrite (add_le_mono_r _ _ n), add_0_l, sub_simpl_r. -Qed. - -Notation sub_nonneg := le_0_sub (only parsing). - -Theorem lt_sub_0 : forall n m, n - m < 0 <-> n < m. -Proof. -intros n m. now rewrite (add_lt_mono_r _ _ m), add_0_l, sub_simpl_r. -Qed. - -Notation sub_neg := lt_sub_0 (only parsing). - -Theorem le_sub_0 : forall n m, n - m <= 0 <-> n <= m. -Proof. -intros n m. now rewrite (add_le_mono_r _ _ m), add_0_l, sub_simpl_r. -Qed. - -Notation sub_nonpos := le_sub_0 (only parsing). - -Theorem opp_lt_mono : forall n m, n < m <-> - m < - n. -Proof. -intros n m. now rewrite <- lt_0_sub, <- add_opp_l, <- sub_opp_r, lt_0_sub. -Qed. - -Theorem opp_le_mono : forall n m, n <= m <-> - m <= - n. -Proof. -intros n m. now rewrite <- le_0_sub, <- add_opp_l, <- sub_opp_r, le_0_sub. -Qed. - -Theorem opp_pos_neg : forall n, 0 < - n <-> n < 0. -Proof. -intro n; now rewrite (opp_lt_mono n 0), opp_0. -Qed. - -Theorem opp_neg_pos : forall n, - n < 0 <-> 0 < n. -Proof. -intro n. now rewrite (opp_lt_mono 0 n), opp_0. -Qed. - -Theorem opp_nonneg_nonpos : forall n, 0 <= - n <-> n <= 0. -Proof. -intro n; now rewrite (opp_le_mono n 0), opp_0. -Qed. - -Theorem opp_nonpos_nonneg : forall n, - n <= 0 <-> 0 <= n. -Proof. -intro n. now rewrite (opp_le_mono 0 n), opp_0. -Qed. - -Theorem lt_m1_0 : -1 < 0. -Proof. -apply opp_neg_pos, lt_0_1. -Qed. - -Theorem sub_lt_mono_l : forall n m p, n < m <-> p - m < p - n. -Proof. -intros. now rewrite <- 2 add_opp_r, <- add_lt_mono_l, opp_lt_mono. -Qed. - -Theorem sub_lt_mono_r : forall n m p, n < m <-> n - p < m - p. -Proof. -intros. now rewrite <- 2 add_opp_r, add_lt_mono_r. -Qed. - -Theorem sub_lt_mono : forall n m p q, n < m -> q < p -> n - p < m - q. -Proof. -intros n m p q H1 H2. -apply lt_trans with (m - p); -[now apply sub_lt_mono_r | now apply sub_lt_mono_l]. -Qed. - -Theorem sub_le_mono_l : forall n m p, n <= m <-> p - m <= p - n. -Proof. -intros. now rewrite <- 2 add_opp_r, <- add_le_mono_l, opp_le_mono. -Qed. - -Theorem sub_le_mono_r : forall n m p, n <= m <-> n - p <= m - p. -Proof. -intros. now rewrite <- 2 add_opp_r, add_le_mono_r. -Qed. - -Theorem sub_le_mono : forall n m p q, n <= m -> q <= p -> n - p <= m - q. -Proof. -intros n m p q H1 H2. -apply le_trans with (m - p); -[now apply sub_le_mono_r | now apply sub_le_mono_l]. -Qed. - -Theorem sub_lt_le_mono : forall n m p q, n < m -> q <= p -> n - p < m - q. -Proof. -intros n m p q H1 H2. -apply lt_le_trans with (m - p); -[now apply sub_lt_mono_r | now apply sub_le_mono_l]. -Qed. - -Theorem sub_le_lt_mono : forall n m p q, n <= m -> q < p -> n - p < m - q. -Proof. -intros n m p q H1 H2. -apply le_lt_trans with (m - p); -[now apply sub_le_mono_r | now apply sub_lt_mono_l]. -Qed. - -Theorem le_lt_sub_lt : forall n m p q, n <= m -> p - n < q - m -> p < q. -Proof. -intros n m p q H1 H2. apply (le_lt_add_lt (- m) (- n)); -[now apply -> opp_le_mono | now rewrite 2 add_opp_r]. -Qed. - -Theorem lt_le_sub_lt : forall n m p q, n < m -> p - n <= q - m -> p < q. -Proof. -intros n m p q H1 H2. apply (lt_le_add_lt (- m) (- n)); -[now apply -> opp_lt_mono | now rewrite 2 add_opp_r]. -Qed. - -Theorem le_le_sub_lt : forall n m p q, n <= m -> p - n <= q - m -> p <= q. -Proof. -intros n m p q H1 H2. apply (le_le_add_le (- m) (- n)); -[now apply -> opp_le_mono | now rewrite 2 add_opp_r]. -Qed. - -Theorem lt_add_lt_sub_r : forall n m p, n + p < m <-> n < m - p. -Proof. -intros n m p. now rewrite (sub_lt_mono_r _ _ p), add_simpl_r. -Qed. - -Theorem le_add_le_sub_r : forall n m p, n + p <= m <-> n <= m - p. -Proof. -intros n m p. now rewrite (sub_le_mono_r _ _ p), add_simpl_r. -Qed. - -Theorem lt_add_lt_sub_l : forall n m p, n + p < m <-> p < m - n. -Proof. -intros n m p. rewrite add_comm; apply lt_add_lt_sub_r. -Qed. - -Theorem le_add_le_sub_l : forall n m p, n + p <= m <-> p <= m - n. -Proof. -intros n m p. rewrite add_comm; apply le_add_le_sub_r. -Qed. - -Theorem lt_sub_lt_add_r : forall n m p, n - p < m <-> n < m + p. -Proof. -intros n m p. now rewrite (add_lt_mono_r _ _ p), sub_simpl_r. -Qed. - -Theorem le_sub_le_add_r : forall n m p, n - p <= m <-> n <= m + p. -Proof. -intros n m p. now rewrite (add_le_mono_r _ _ p), sub_simpl_r. -Qed. - -Theorem lt_sub_lt_add_l : forall n m p, n - m < p <-> n < m + p. -Proof. -intros n m p. rewrite add_comm; apply lt_sub_lt_add_r. -Qed. - -Theorem le_sub_le_add_l : forall n m p, n - m <= p <-> n <= m + p. -Proof. -intros n m p. rewrite add_comm; apply le_sub_le_add_r. -Qed. - -Theorem lt_sub_lt_add : forall n m p q, n - m < p - q <-> n + q < m + p. -Proof. -intros n m p q. now rewrite lt_sub_lt_add_l, add_sub_assoc, <- lt_add_lt_sub_r. -Qed. - -Theorem le_sub_le_add : forall n m p q, n - m <= p - q <-> n + q <= m + p. -Proof. -intros n m p q. now rewrite le_sub_le_add_l, add_sub_assoc, <- le_add_le_sub_r. -Qed. - -Theorem lt_sub_pos : forall n m, 0 < m <-> n - m < n. -Proof. -intros n m. now rewrite (sub_lt_mono_l _ _ n), sub_0_r. -Qed. - -Theorem le_sub_nonneg : forall n m, 0 <= m <-> n - m <= n. -Proof. -intros n m. now rewrite (sub_le_mono_l _ _ n), sub_0_r. -Qed. - -Theorem sub_lt_cases : forall n m p q, n - m < p - q -> n < m \/ q < p. -Proof. -intros. now apply add_lt_cases, lt_sub_lt_add. -Qed. - -Theorem sub_le_cases : forall n m p q, n - m <= p - q -> n <= m \/ q <= p. -Proof. -intros. now apply add_le_cases, le_sub_le_add. -Qed. - -Theorem sub_neg_cases : forall n m, n - m < 0 -> n < 0 \/ 0 < m. -Proof. -intros n m ?. -rewrite <- (opp_neg_pos m). apply add_neg_cases. now rewrite add_opp_r. -Qed. - -Theorem sub_pos_cases : forall n m, 0 < n - m -> 0 < n \/ m < 0. -Proof. -intros n m ?. -rewrite <- (opp_pos_neg m). apply add_pos_cases. now rewrite add_opp_r. -Qed. - -Theorem sub_nonpos_cases : forall n m, n - m <= 0 -> n <= 0 \/ 0 <= m. -Proof. -intros n m ?. -rewrite <- (opp_nonpos_nonneg m). apply add_nonpos_cases. now rewrite add_opp_r. -Qed. - -Theorem sub_nonneg_cases : forall n m, 0 <= n - m -> 0 <= n \/ m <= 0. -Proof. -intros n m ?. -rewrite <- (opp_nonneg_nonpos m). apply add_nonneg_cases. now rewrite add_opp_r. -Qed. - -Section PosNeg. - -Variable P : Z.t -> Prop. -Hypothesis P_wd : Proper (eq ==> iff) P. - -Theorem zero_pos_neg : - P 0 -> (forall n, 0 < n -> P n /\ P (- n)) -> forall n, P n. -Proof. -intros H1 H2 n. destruct (lt_trichotomy n 0) as [H3 | [H3 | H3]]. -- apply opp_pos_neg, H2 in H3. destruct H3 as [_ H3]. - now rewrite opp_involutive in H3. -- now rewrite H3. -- apply H2 in H3; now destruct H3. -Qed. - -End PosNeg. - -Ltac zero_pos_neg n := induction_maker n ltac:(apply zero_pos_neg). - -End ZAddOrderProp. diff --git a/stdlib/theories/Numbers/Integer/Abstract/ZAxioms.v b/stdlib/theories/Numbers/Integer/Abstract/ZAxioms.v deleted file mode 100644 index 05776e90ac1e..000000000000 --- a/stdlib/theories/Numbers/Integer/Abstract/ZAxioms.v +++ /dev/null @@ -1,127 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* t. -End Opp. - -Module Type OppNotation (T:Typ)(Import O : Opp T). - Notation "- x" := (opp x) (at level 35, right associativity). -End OppNotation. - -Module Type Opp' (T:Typ) := Opp T <+ OppNotation T. - -Module Type IsOpp (Import Z : NZAxiomsSig')(Import O : Opp' Z). -#[global] - Declare Instance opp_wd : Proper (eq==>eq) opp. - Axiom opp_0 : - 0 == 0. - Axiom opp_succ : forall n, - (S n) == P (- n). -End IsOpp. - -Module Type OppCstNotation (Import A : NZAxiomsSig)(Import B : Opp A). - Notation "- 1" := (opp one). - Notation "- 2" := (opp two). -End OppCstNotation. - -Module Type ZAxiomsMiniSig := NZOrdAxiomsSig <+ ZAxiom <+ Opp <+ IsOpp. -Module Type ZAxiomsMiniSig' := NZOrdAxiomsSig' <+ ZAxiom <+ Opp' <+ IsOpp - <+ OppCstNotation. - - -(** Other functions and their specifications *) - -(** Absolute value *) - -Module Type HasAbs(Import Z : ZAxiomsMiniSig'). - Parameter Inline abs : t -> t. - Axiom abs_eq : forall n, 0<=n -> abs n == n. - Axiom abs_neq : forall n, n<=0 -> abs n == -n. -End HasAbs. - -(** A sign function *) - -Module Type HasSgn (Import Z : ZAxiomsMiniSig'). - Parameter Inline sgn : t -> t. - Axiom sgn_null : forall n, n==0 -> sgn n == 0. - Axiom sgn_pos : forall n, 0 sgn n == 1. - Axiom sgn_neg : forall n, n<0 -> sgn n == -1. -End HasSgn. - -(** Divisions *) - -(** First, the usual Coq convention of Truncated-Toward-Bottom - (a.k.a Floor). We simply extend the NZ signature. *) - -Module Type ZDivSpecific (Import A:ZAxiomsMiniSig')(Import B : DivMod' A). - Axiom mod_pos_bound : forall a b, 0 < b -> 0 <= a mod b < b. - Axiom mod_neg_bound : forall a b, b < 0 -> b < a mod b <= 0. -End ZDivSpecific. - -Module Type ZDiv (Z:ZAxiomsMiniSig) := NZDiv.NZDiv Z <+ ZDivSpecific Z. -Module Type ZDiv' (Z:ZAxiomsMiniSig) := NZDiv.NZDiv' Z <+ ZDivSpecific Z. - -(** Then, the Truncated-Toward-Zero convention. - For not colliding with Floor operations, we use different names -*) - -Module Type QuotRem (Import A : Typ). - Parameters Inline quot rem : t -> t -> t. -End QuotRem. - -Module Type QuotRemNotation (A : Typ)(Import B : QuotRem A). - Infix "Ć·" := quot (at level 40, left associativity). - Infix "rem" := rem (at level 40, no associativity). -End QuotRemNotation. - -Module Type QuotRem' (A : Typ) := QuotRem A <+ QuotRemNotation A. - -Module Type QuotRemSpec (Import A : ZAxiomsMiniSig')(Import B : QuotRem' A). -#[global] - Declare Instance quot_wd : Proper (eq==>eq==>eq) quot. -#[global] - Declare Instance rem_wd : Proper (eq==>eq==>eq) B.rem. - Axiom quot_rem : forall a b, b ~= 0 -> a == b*(aĆ·b) + (a rem b). - Axiom rem_bound_pos : forall a b, 0<=a -> 0 0 <= a rem b < b. - Axiom rem_opp_l : forall a b, b ~= 0 -> (-a) rem b == - (a rem b). - Axiom rem_opp_r : forall a b, b ~= 0 -> a rem (-b) == a rem b. -End QuotRemSpec. - -Module Type ZQuot (Z:ZAxiomsMiniSig) := QuotRem Z <+ QuotRemSpec Z. -Module Type ZQuot' (Z:ZAxiomsMiniSig) := QuotRem' Z <+ QuotRemSpec Z. - -(** For all other functions, the NZ axiomatizations are enough. *) - -(** Let's group everything *) - -Module Type ZAxiomsSig := ZAxiomsMiniSig <+ OrderFunctions - <+ HasAbs <+ HasSgn <+ NZParity.NZParity - <+ NZPow.NZPow <+ NZSqrt.NZSqrt <+ NZLog.NZLog2 <+ NZGcd.NZGcd - <+ ZDiv <+ ZQuot <+ NZBits.NZBits <+ NZSquare. - -Module Type ZAxiomsSig' := ZAxiomsMiniSig' <+ OrderFunctions' - <+ HasAbs <+ HasSgn <+ NZParity.NZParity - <+ NZPow.NZPow' <+ NZSqrt.NZSqrt' <+ NZLog.NZLog2 <+ NZGcd.NZGcd' - <+ ZDiv' <+ ZQuot' <+ NZBits.NZBits' <+ NZSquare. diff --git a/stdlib/theories/Numbers/Integer/Abstract/ZBase.v b/stdlib/theories/Numbers/Integer/Abstract/ZBase.v deleted file mode 100644 index b58769348840..000000000000 --- a/stdlib/theories/Numbers/Integer/Abstract/ZBase.v +++ /dev/null @@ -1,37 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* n == m. -Proof. -intros n m H. apply succ_wd in H. now rewrite 2 succ_pred in H. -Qed. - -Theorem pred_inj_wd : forall n1 n2, P n1 == P n2 <-> n1 == n2. -Proof. -intros n1 n2; split; [apply pred_inj | intros; now f_equiv]. -Qed. - -Lemma succ_m1 : S (-1) == 0. -Proof. - now rewrite one_succ, opp_succ, opp_0, succ_pred. -Qed. - -End ZBaseProp. diff --git a/stdlib/theories/Numbers/Integer/Abstract/ZBits.v b/stdlib/theories/Numbers/Integer/Abstract/ZBits.v deleted file mode 100644 index e4ef14bd81ce..000000000000 --- a/stdlib/theories/Numbers/Integer/Abstract/ZBits.v +++ /dev/null @@ -1,2024 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* 0<=c<=b -> a^(b-c) == a^b / a^c. -Proof. - intros a b c Ha (H,H'). rewrite <- (sub_simpl_r b c) at 2. - rewrite pow_add_r; trivial. - - rewrite div_mul. { reflexivity. } - now apply pow_nonzero. - - now apply le_0_sub. -Qed. - -Lemma pow_div_l : forall a b c, b~=0 -> 0<=c -> a mod b == 0 -> - (a/b)^c == a^c / b^c. -Proof. - intros a b c Hb Hc H. rewrite (div_mod a b Hb) at 2. - rewrite H, add_0_r, pow_mul_l, mul_comm, div_mul. { reflexivity. } - now apply pow_nonzero. -Qed. - -(** An injection from bits [true] and [false] to numbers 1 and 0. - We declare it as a (local) coercion for shorter statements. *) - -Definition b2z (b:bool) := if b then 1 else 0. -Local Coercion b2z : bool >-> t. - -#[global] -Instance b2z_wd : Proper (Logic.eq ==> eq) b2z := _. - -Lemma exists_div2 a : exists a' (b:bool), a == 2*a' + b. -Proof. - elim (Even_or_Odd a); [intros (a',H)| intros (a',H)]. - - exists a'. exists false. now nzsimpl. - - exists a'. exists true. now simpl. -Qed. - -(** We can compact [testbit_odd_0] [testbit_even_0] - [testbit_even_succ] [testbit_odd_succ] in only two lemmas. *) - -Lemma testbit_0_r a (b:bool) : testbit (2*a+b) 0 = b. -Proof. - destruct b; simpl; rewrite ?add_0_r. - - apply testbit_odd_0. - - apply testbit_even_0. -Qed. - -Lemma testbit_succ_r a (b:bool) n : 0<=n -> - testbit (2*a+b) (succ n) = testbit a n. -Proof. - destruct b; simpl; rewrite ?add_0_r. - - now apply testbit_odd_succ. - - now apply testbit_even_succ. -Qed. - -(** Alternative characterisations of [testbit] *) - -(** This concise equation could have been taken as specification - for testbit in the interface, but it would have been hard to - implement with little initial knowledge about div and mod *) - -Lemma testbit_spec' a n : 0<=n -> a.[n] == (a / 2^n) mod 2. -Proof. - intro Hn. revert a. apply le_ind with (4:=Hn). - - solve_proper. - - intros a. nzsimpl. - destruct (exists_div2 a) as (a' & b & H). rewrite H at 1. - rewrite testbit_0_r. apply mod_unique with a'; trivial. - left. destruct b; split; simpl; order'. - - clear n Hn. intros n Hn IH a. - destruct (exists_div2 a) as (a' & b & H). rewrite H at 1. - rewrite testbit_succ_r, IH by trivial. f_equiv. - rewrite pow_succ_r, <- div_div by order_pos. f_equiv. - apply div_unique with b; trivial. - left. destruct b; split; simpl; order'. -Qed. - -(** This characterisation that uses only basic operations and - power was initially taken as specification for testbit. - We describe [a] as having a low part and a high part, with - the corresponding bit in the middle. This characterisation - is moderatly complex to implement, but also moderately - usable... *) - -Lemma testbit_spec a n : 0<=n -> - exists l h, 0<=l<2^n /\ a == l + (a.[n] + 2*h)*2^n. -Proof. - intro Hn. exists (a mod 2^n). exists (a / 2^n / 2). split. - - apply mod_pos_bound; order_pos. - - rewrite add_comm, mul_comm, (add_comm a.[n]). - rewrite (div_mod a (2^n)) at 1 by order_nz. do 2 f_equiv. - rewrite testbit_spec' by trivial. apply div_mod. order'. -Qed. - -Lemma testbit_true : forall a n, 0<=n -> - (a.[n] = true <-> (a / 2^n) mod 2 == 1). -Proof. - intros a n Hn. - rewrite <- testbit_spec' by trivial. - destruct a.[n]; split; simpl; now try order'. -Qed. - -Lemma testbit_false : forall a n, 0<=n -> - (a.[n] = false <-> (a / 2^n) mod 2 == 0). -Proof. - intros a n Hn. - rewrite <- testbit_spec' by trivial. - destruct a.[n]; split; simpl; now try order'. -Qed. - -Lemma testbit_eqb : forall a n, 0<=n -> - a.[n] = eqb ((a / 2^n) mod 2) 1. -Proof. - intros a n Hn. - apply eq_true_iff_eq. now rewrite testbit_true, eqb_eq. -Qed. - -(** Results about the injection [b2z] *) - -Lemma b2z_inj : forall (a0 b0:bool), a0 == b0 -> a0 = b0. -Proof. - intros [|] [|]; simpl; trivial; order'. -Qed. - -Lemma add_b2z_double_div2 : forall (a0:bool) a, (a0+2*a)/2 == a. -Proof. - intros a0 a. rewrite mul_comm, div_add by order'. - now rewrite div_small, add_0_l by (destruct a0; split; simpl; order'). -Qed. - -Lemma add_b2z_double_bit0 : forall (a0:bool) a, (a0+2*a).[0] = a0. -Proof. - intros a0 a. apply b2z_inj. - rewrite testbit_spec' by order. - nzsimpl. rewrite mul_comm, mod_add by order'. - now rewrite mod_small by (destruct a0; split; simpl; order'). -Qed. - -Lemma b2z_div2 : forall (a0:bool), a0/2 == 0. -Proof. - intros a0. rewrite <- (add_b2z_double_div2 a0 0). now nzsimpl. -Qed. - -Lemma b2z_bit0 : forall (a0:bool), a0.[0] = a0. -Proof. - intros a0. rewrite <- (add_b2z_double_bit0 a0 0) at 2. now nzsimpl. -Qed. - -(** The specification of testbit by low and high parts is complete *) - -Lemma testbit_unique : forall a n (a0:bool) l h, - 0<=l<2^n -> a == l + (a0 + 2*h)*2^n -> a.[n] = a0. -Proof. - intros a n a0 l h Hl EQ. - assert (0<=n). { - destruct (le_gt_cases 0 n) as [Hn|Hn]; trivial. - rewrite pow_neg_r in Hl by trivial. destruct Hl; order. - } - apply b2z_inj. rewrite testbit_spec' by trivial. - symmetry. apply mod_unique with h. - - left; destruct a0; simpl; split; order'. - - symmetry. apply div_unique with l. - + now left. - + now rewrite add_comm, (add_comm _ a0), mul_comm. -Qed. - -(** All bits of number 0 are 0 *) - -Lemma bits_0 : forall n, 0.[n] = false. -Proof. - intros n. - destruct (le_gt_cases 0 n). - - apply testbit_false; trivial. nzsimpl; order_nz. - - now apply testbit_neg_r. -Qed. - -(** For negative numbers, we are actually doing two's complement *) - -Lemma bits_opp : forall a n, 0<=n -> (-a).[n] = negb (P a).[n]. -Proof. - intros a n Hn. - destruct (testbit_spec (-a) n Hn) as (l & h & Hl & EQ). - fold (b2z (-a).[n]) in EQ. - apply negb_sym. - apply testbit_unique with (2^n-l-1) (-h-1). - - split. - + apply lt_succ_r. rewrite sub_1_r, succ_pred. now apply lt_0_sub. - + apply le_succ_l. rewrite sub_1_r, succ_pred. apply le_sub_le_add_r. - rewrite <- (add_0_r (2^n)) at 1. now apply add_le_mono_l. - - rewrite <- add_sub_swap, sub_1_r. f_equiv. - apply opp_inj. rewrite opp_add_distr, opp_sub_distr. - rewrite (add_comm _ l), <- add_assoc. - rewrite EQ at 1. apply add_cancel_l. - rewrite <- opp_add_distr. - rewrite <- (mul_1_l (2^n)) at 2. rewrite <- mul_add_distr_r. - rewrite <- mul_opp_l. - f_equiv. - rewrite !opp_add_distr. - rewrite <- mul_opp_r. - rewrite opp_sub_distr, opp_involutive. - rewrite (add_comm h). - rewrite mul_add_distr_l. - rewrite !add_assoc. - apply add_cancel_r. - rewrite mul_1_r. - rewrite add_comm, add_assoc, !add_opp_r, sub_1_r, two_succ, pred_succ. - destruct (-a).[n]; simpl. - + now rewrite sub_0_r. - + now nzsimpl'. -Qed. - -(** All bits of number (-1) are 1 *) - -Lemma bits_m1 : forall n, 0<=n -> (-1).[n] = true. -Proof. - intros. now rewrite bits_opp, one_succ, pred_succ, bits_0. -Qed. - -(** Various ways to refer to the lowest bit of a number *) - -Lemma bit0_odd : forall a, a.[0] = odd a. -Proof. - intros a. symmetry. - destruct (exists_div2 a) as (a' & b & EQ). - rewrite EQ, testbit_0_r, add_comm, odd_add_mul_2. - destruct b; simpl; apply odd_1 || apply odd_0. -Qed. - -Lemma bit0_eqb : forall a, a.[0] = eqb (a mod 2) 1. -Proof. - intros a. rewrite testbit_eqb by order. now nzsimpl. -Qed. - -Lemma bit0_mod : forall a, a.[0] == a mod 2. -Proof. - intros a. rewrite testbit_spec' by order. now nzsimpl. -Qed. - -(** Hence testing a bit is equivalent to shifting and testing parity *) - -Lemma testbit_odd : forall a n, a.[n] = odd (a>>n). -Proof. - intros. now rewrite <- bit0_odd, shiftr_spec, add_0_l. -Qed. - -(** [log2] gives the highest nonzero bit of positive numbers *) - -Lemma bit_log2 : forall a, 0 a.[log2 a] = true. -Proof. - intros a Ha. - assert (Ha' := log2_nonneg a). - destruct (log2_spec_alt a Ha) as (r & EQ & Hr). - rewrite EQ at 1. - rewrite testbit_true, add_comm by trivial. - rewrite <- (mul_1_l (2^log2 a)) at 1. - rewrite div_add by order_nz. - rewrite div_small; trivial. - rewrite add_0_l. apply mod_small. split; order'. -Qed. - -Lemma bits_above_log2 : forall a n, 0<=a -> log2 a < n -> - a.[n] = false. -Proof. - intros a n Ha H. - assert (Hn : 0<=n). - { transitivity (log2 a). - apply log2_nonneg. - order'. } - rewrite testbit_false by trivial. - rewrite div_small. { nzsimpl; order'. } - split. - - order. - - apply log2_lt_cancel. now rewrite log2_pow2. -Qed. - -(** Hence the number of bits of [a] is [1+log2 a] - (see [Pos.size_nat] and [Pos.size]). -*) - -(** For negative numbers, things are the other ways around: - log2 gives the highest zero bit (for numbers below -1). -*) - -Lemma bit_log2_neg : forall a, a < -1 -> a.[log2 (P (-a))] = false. -Proof. - intros a Ha. - rewrite <- (opp_involutive a) at 1. - rewrite bits_opp. - - apply negb_false_iff. - apply bit_log2. - apply opp_lt_mono in Ha. rewrite opp_involutive in Ha. - apply lt_succ_lt_pred. now rewrite <- one_succ. - - apply log2_nonneg. -Qed. - -Lemma bits_above_log2_neg : forall a n, a < 0 -> log2 (P (-a)) < n -> - a.[n] = true. -Proof. - intros a n Ha H. - assert (Hn : 0<=n). - { transitivity (log2 (P (-a))). - apply log2_nonneg. - order'. } - rewrite <- (opp_involutive a), bits_opp, negb_true_iff by trivial. - apply bits_above_log2; trivial. - now rewrite <- opp_succ, opp_nonneg_nonpos, le_succ_l. -Qed. - -(** Accessing a high enough bit of a number gives its sign *) - -Lemma bits_iff_nonneg : forall a n, log2 (abs a) < n -> - (0<=a <-> a.[n] = false). -Proof. - intros a n Hn. split; intros H. - - rewrite abs_eq in Hn; trivial. now apply bits_above_log2. - - destruct (le_gt_cases 0 a); trivial. - rewrite abs_neq in Hn by order. - rewrite bits_above_log2_neg in H; try easy. - apply le_lt_trans with (log2 (-a)); trivial. - apply log2_le_mono. apply le_pred_l. -Qed. - -Lemma bits_iff_nonneg' : forall a, - 0<=a <-> a.[S (log2 (abs a))] = false. -Proof. - intros. apply bits_iff_nonneg. apply lt_succ_diag_r. -Qed. - -Lemma bits_iff_nonneg_ex : forall a, - 0<=a <-> (exists k, forall m, k a.[m] = false). -Proof. - intros a. split. - - intros Ha. exists (log2 a). intros m Hm. now apply bits_above_log2. - - intros (k,Hk). destruct (le_gt_cases k (log2 (abs a))). - + now apply bits_iff_nonneg', Hk, lt_succ_r. - + apply (bits_iff_nonneg a (S k)). - * now apply lt_succ_r, lt_le_incl. - * apply Hk. apply lt_succ_diag_r. -Qed. - -Lemma bits_iff_neg : forall a n, log2 (abs a) < n -> - (a<0 <-> a.[n] = true). -Proof. - intros a n Hn. - now rewrite lt_nge, <- not_false_iff_true, (bits_iff_nonneg a n). -Qed. - -Lemma bits_iff_neg' : forall a, a<0 <-> a.[S (log2 (abs a))] = true. -Proof. - intros. apply bits_iff_neg. apply lt_succ_diag_r. -Qed. - -Lemma bits_iff_neg_ex : forall a, - a<0 <-> (exists k, forall m, k a.[m] = true). -Proof. - intros a. split. - - intros Ha. exists (log2 (P (-a))). intros m Hm. now apply bits_above_log2_neg. - - intros (k,Hk). destruct (le_gt_cases k (log2 (abs a))). - + now apply bits_iff_neg', Hk, lt_succ_r. - + apply (bits_iff_neg a (S k)). - * now apply lt_succ_r, lt_le_incl. - * apply Hk. apply lt_succ_diag_r. -Qed. - -(** Testing bits after division or multiplication by a power of two *) - -Lemma div2_bits : forall a n, 0<=n -> (a/2).[n] = a.[S n]. -Proof. - intros a n Hn. - apply eq_true_iff_eq. rewrite 2 testbit_true by order_pos. - rewrite pow_succ_r by trivial. - now rewrite div_div by order_pos. -Qed. - -Lemma div_pow2_bits : forall a n m, 0<=n -> 0<=m -> (a/2^n).[m] = a.[m+n]. -Proof. - intros a n m Hn. revert a m. apply le_ind with (4:=Hn). - - solve_proper. - - intros a m Hm. now nzsimpl. - - clear n Hn. intros n Hn IH a m Hm. nzsimpl; trivial. - rewrite <- div_div by order_pos. - now rewrite IH, div2_bits by order_pos. -Qed. - -Lemma double_bits_succ : forall a n, (2*a).[S n] = a.[n]. -Proof. - intros a n. - destruct (le_gt_cases 0 n) as [Hn|Hn]. - - now rewrite <- div2_bits, mul_comm, div_mul by order'. - - rewrite (testbit_neg_r a n Hn). - apply le_succ_l in Hn. le_elim Hn. - + now rewrite testbit_neg_r. - + now rewrite Hn, bit0_odd, odd_mul, odd_2. -Qed. - -Lemma double_bits : forall a n, (2*a).[n] = a.[P n]. -Proof. - intros a n. rewrite <- (succ_pred n) at 1. apply double_bits_succ. -Qed. - -Lemma mul_pow2_bits_add : forall a n m, 0<=n -> (a*2^n).[n+m] = a.[m]. -Proof. - intros a n m Hn. revert a m. apply le_ind with (4:=Hn). - - solve_proper. - - intros a m. now nzsimpl. - - clear n Hn. intros n Hn IH a m. nzsimpl; trivial. - rewrite mul_assoc, (mul_comm _ 2), <- mul_assoc. - now rewrite double_bits_succ. -Qed. - -Lemma mul_pow2_bits : forall a n m, 0<=n -> (a*2^n).[m] = a.[m-n]. -Proof. - intros a n m ?. - rewrite <- (add_simpl_r m n) at 1. rewrite add_sub_swap, add_comm. - now apply mul_pow2_bits_add. -Qed. - -Lemma mul_pow2_bits_low : forall a n m, m (a*2^n).[m] = false. -Proof. - intros a n m ?. - destruct (le_gt_cases 0 n). - - rewrite mul_pow2_bits by trivial. - apply testbit_neg_r. now apply lt_sub_0. - - now rewrite pow_neg_r, mul_0_r, bits_0. -Qed. - -(** Selecting the low part of a number can be done by a modulo *) - -Lemma mod_pow2_bits_high : forall a n m, 0<=n<=m -> - (a mod 2^n).[m] = false. -Proof. - intros a n m (Hn,H). - destruct (mod_pos_bound a (2^n)) as [LE LT]. { order_pos. } - le_elim LE. - - apply bits_above_log2; try order. - apply lt_le_trans with n; trivial. - apply log2_lt_pow2; trivial. - - now rewrite <- LE, bits_0. -Qed. - -Lemma mod_pow2_bits_low : forall a n m, m - (a mod 2^n).[m] = a.[m]. -Proof. - intros a n m H. - destruct (le_gt_cases 0 m) as [Hm|Hm]; [|now rewrite !testbit_neg_r]. - rewrite testbit_eqb; trivial. - rewrite <- (mod_add _ (2^(P (n-m))*(a/2^n))) by order'. - rewrite <- div_add by order_nz. - rewrite (mul_comm _ 2), mul_assoc, <- pow_succ_r, succ_pred. - - rewrite mul_comm, mul_assoc, <- pow_add_r, (add_comm m), sub_add; trivial. - + rewrite add_comm, <- div_mod by order_nz. - symmetry. apply testbit_eqb; trivial. - + apply le_0_sub; order. - - now apply lt_le_pred, lt_0_sub. -Qed. - -(** We now prove that having the same bits implies equality. - For that we use a notion of equality over functional - streams of bits. *) - -Definition eqf (f g:t -> bool) := forall n:t, f n = g n. - -#[global] -Instance eqf_equiv : Equivalence eqf. -Proof. - split; congruence. -Qed. - -Local Infix "===" := eqf (at level 70, no associativity). - -#[global] -Instance testbit_eqf : Proper (eq==>eqf) testbit. -Proof. - intros a a' Ha n. now rewrite Ha. -Qed. - -(** Only zero corresponds to the always-false stream. *) - -Lemma bits_inj_0 : - forall a, (forall n, a.[n] = false) -> a == 0. -Proof. - intros a H. destruct (lt_trichotomy a 0) as [Ha|[Ha|Ha]]; trivial. - - apply (bits_above_log2_neg a (S (log2 (P (-a))))) in Ha. - + now rewrite H in Ha. - + apply lt_succ_diag_r. - - apply bit_log2 in Ha. now rewrite H in Ha. -Qed. - -(** If two numbers produce the same stream of bits, they are equal. *) - -Lemma bits_inj : forall a b, testbit a === testbit b -> a == b. -Proof. - assert (AUX : forall n, 0<=n -> forall a b, - 0<=a<2^n -> testbit a === testbit b -> a == b). { - intros n Hn. apply le_ind with (4:=Hn). - - solve_proper. - - intros a b Ha H. rewrite pow_0_r, one_succ, lt_succ_r in Ha. - assert (Ha' : a == 0) by (destruct Ha; order). - rewrite Ha' in *. - symmetry. apply bits_inj_0. - intros m. now rewrite <- H, bits_0. - - clear n Hn. intros n Hn IH a b (Ha,Ha') H. - rewrite (div_mod a 2), (div_mod b 2) by order'. - f_equiv; [ | now rewrite <- 2 bit0_mod, H]. - f_equiv. - apply IH. - + split. - * apply div_pos; order'. - * apply div_lt_upper_bound. { order'. } now rewrite <- pow_succ_r. - + intros m. - destruct (le_gt_cases 0 m). - * rewrite 2 div2_bits by trivial. apply H. - * now rewrite 2 testbit_neg_r. - } - intros a b H. - destruct (le_gt_cases 0 a) as [Ha|Ha]. - - apply (AUX a); trivial. split; trivial. - apply pow_gt_lin_r; order'. - - apply succ_inj, opp_inj. - assert (0 <= - S a). { - apply opp_le_mono. now rewrite opp_involutive, opp_0, le_succ_l. - } - apply (AUX (-(S a))); trivial. - + split; trivial. - apply pow_gt_lin_r; order'. - + intros m. destruct (le_gt_cases 0 m). - * now rewrite 2 bits_opp, 2 pred_succ, H. - * now rewrite 2 testbit_neg_r. -Qed. - -Lemma bits_inj_iff : forall a b, testbit a === testbit b <-> a == b. -Proof. - split. - - apply bits_inj. - - intros EQ; now rewrite EQ. -Qed. - -(** In fact, checking the bits at positive indexes is enough. *) - -Lemma bits_inj' : forall a b, - (forall n, 0<=n -> a.[n] = b.[n]) -> a == b. -Proof. - intros a b H. apply bits_inj. - intros n. destruct (le_gt_cases 0 n). - - now apply H. - - now rewrite 2 testbit_neg_r. -Qed. - -Lemma bits_inj_iff' : forall a b, (forall n, 0<=n -> a.[n] = b.[n]) <-> a == b. -Proof. - split. - - apply bits_inj'. - - intros EQ n Hn; now rewrite EQ. -Qed. - -Tactic Notation "bitwise" "as" simple_intropattern(m) simple_intropattern(Hm) - := apply bits_inj'; intros m Hm; autorewrite with bitwise. - -Ltac bitwise := bitwise as ?m ?Hm. - -Global Hint Rewrite lxor_spec lor_spec land_spec ldiff_spec bits_0 : bitwise. - -(** The streams of bits that correspond to a numbers are - exactly the ones which are stationary after some point. *) - -Lemma are_bits : forall (f:t->bool), Proper (eq==>Logic.eq) f -> - ((exists n, forall m, 0<=m -> f m = n.[m]) <-> - (exists k, forall m, k<=m -> f m = f k)). -Proof. - intros f Hf. split. - - intros (a,H). - destruct (le_gt_cases 0 a). - + exists (S (log2 a)). intros m Hm. apply le_succ_l in Hm. - rewrite 2 H, 2 bits_above_log2; trivial using lt_succ_diag_r. - { order_pos. } apply le_trans with (log2 a); order_pos. - + exists (S (log2 (P (-a)))). intros m Hm. apply le_succ_l in Hm. - rewrite 2 H, 2 bits_above_log2_neg; trivial using lt_succ_diag_r. - { order_pos. } apply le_trans with (log2 (P (-a))); order_pos. - - intros (k,Hk). - destruct (lt_ge_cases k 0) as [LT|LE]. - + case_eq (f 0); intros H0. - * exists (-1). intros m Hm. rewrite bits_m1, Hk by order. - symmetry; rewrite <- H0. apply Hk; order. - * exists 0. intros m Hm. rewrite bits_0, Hk by order. - symmetry; rewrite <- H0. apply Hk; order. - + revert f Hf Hk. apply le_ind with (4:=LE). - * (* compat : solve_proper fails here *) - apply proper_sym_impl_iff. { exact eq_sym. } - clear k LE. intros k k' Hk IH f Hf H. apply IH; trivial. - now setoid_rewrite Hk. - * (* /compat *) { - intros f Hf H0. destruct (f 0). - - exists (-1). intros m Hm. now rewrite bits_m1, H0. - - exists 0. intros m Hm. now rewrite bits_0, H0. - } - * { clear k LE. intros k LE IH f Hf Hk. - destruct (IH (fun m => f (S m))) as (n, Hn). - - solve_proper. - - intros m Hm. apply Hk. now rewrite <- succ_le_mono. - - exists (f 0 + 2*n). intros m Hm. - le_elim Hm. - + rewrite <- (succ_pred m), Hn, <- div2_bits. - * rewrite mul_comm, div_add, b2z_div2, add_0_l; trivial. order'. - * now rewrite <- lt_succ_r, succ_pred. - * now rewrite <- lt_succ_r, succ_pred. - + rewrite <- Hm. - symmetry. apply add_b2z_double_bit0. - } -Qed. - -(** * Properties of shifts *) - -(** First, a unified specification for [shiftl] : the [shiftl_spec] - below (combined with [testbit_neg_r]) is equivalent to - [shiftl_spec_low] and [shiftl_spec_high]. *) - -Lemma shiftl_spec : forall a n m, 0<=m -> (a << n).[m] = a.[m-n]. -Proof. - intros a n m ?. - destruct (le_gt_cases n m). - - now apply shiftl_spec_high. - - rewrite shiftl_spec_low, testbit_neg_r; trivial. now apply lt_sub_0. -Qed. - -(** A shiftl by a negative number is a shiftr, and vice-versa *) - -Lemma shiftr_opp_r : forall a n, a >> (-n) == a << n. -Proof. - intros. bitwise. now rewrite shiftr_spec, shiftl_spec, add_opp_r. -Qed. - -Lemma shiftl_opp_r : forall a n, a << (-n) == a >> n. -Proof. - intros. bitwise. now rewrite shiftr_spec, shiftl_spec, sub_opp_r. -Qed. - -(** Shifts correspond to multiplication or division by a power of two *) - -Lemma shiftr_div_pow2 : forall a n, 0<=n -> a >> n == a / 2^n. -Proof. - intros. bitwise. now rewrite shiftr_spec, div_pow2_bits. -Qed. - -Lemma shiftr_mul_pow2 : forall a n, n<=0 -> a >> n == a * 2^(-n). -Proof. - intros. bitwise. rewrite shiftr_spec, mul_pow2_bits; trivial. - - now rewrite sub_opp_r. - - now apply opp_nonneg_nonpos. -Qed. - -Lemma shiftl_mul_pow2 : forall a n, 0<=n -> a << n == a * 2^n. -Proof. - intros. bitwise. now rewrite shiftl_spec, mul_pow2_bits. -Qed. - -Lemma shiftl_div_pow2 : forall a n, n<=0 -> a << n == a / 2^(-n). -Proof. - intros. bitwise. rewrite shiftl_spec, div_pow2_bits; trivial. - - now rewrite add_opp_r. - - now apply opp_nonneg_nonpos. -Qed. - -(** Shifts are morphisms *) - -#[global] -Instance shiftr_wd : Proper (eq==>eq==>eq) shiftr. -Proof. - intros a a' Ha n n' Hn. - destruct (le_ge_cases n 0) as [H|H]; assert (H':=H); rewrite Hn in H'. - - now rewrite 2 shiftr_mul_pow2, Ha, Hn. - - now rewrite 2 shiftr_div_pow2, Ha, Hn. -Qed. - -#[global] -Instance shiftl_wd : Proper (eq==>eq==>eq) shiftl. -Proof. - intros a a' Ha n n' Hn. now rewrite <- 2 shiftr_opp_r, Ha, Hn. -Qed. - -(** We could also have specified shiftl with an addition on the left. *) - -Lemma shiftl_spec_alt : forall a n m, 0<=n -> (a << n).[m+n] = a.[m]. -Proof. - intros. now rewrite shiftl_mul_pow2, mul_pow2_bits, add_simpl_r. -Qed. - -(** Chaining several shifts. The only case for which - there isn't any simple expression is a true shiftr - followed by a true shiftl. -*) - -Lemma shiftl_shiftl : forall a n m, 0<=n -> - (a << n) << m == a << (n+m). -Proof. - intros a n p Hn. bitwise as m Hm. - rewrite 2 (shiftl_spec _ _ m) by trivial. - rewrite add_comm, sub_add_distr. - destruct (le_gt_cases 0 (m-p)) as [H|H]. - - now rewrite shiftl_spec. - - rewrite 2 testbit_neg_r; trivial. - apply lt_sub_0. now apply lt_le_trans with 0. -Qed. - -Lemma shiftr_shiftl_l : forall a n m, 0<=n -> - (a << n) >> m == a << (n-m). -Proof. - intros. now rewrite <- shiftl_opp_r, shiftl_shiftl, add_opp_r. -Qed. - -Lemma shiftr_shiftl_r : forall a n m, 0<=n -> - (a << n) >> m == a >> (m-n). -Proof. - intros. now rewrite <- 2 shiftl_opp_r, shiftl_shiftl, opp_sub_distr, add_comm. -Qed. - -Lemma shiftr_shiftr : forall a n m, 0<=m -> - (a >> n) >> m == a >> (n+m). -Proof. - intros a n p Hn. bitwise. - rewrite 3 shiftr_spec; trivial. - - now rewrite (add_comm n p), add_assoc. - - now apply add_nonneg_nonneg. -Qed. - -(** shifts and constants *) - -Lemma shiftl_1_l : forall n, 1 << n == 2^n. -Proof. - intros n. destruct (le_gt_cases 0 n). - - now rewrite shiftl_mul_pow2, mul_1_l. - - rewrite shiftl_div_pow2, div_1_l, pow_neg_r; try order. - apply pow_gt_1. - + order'. - + now apply opp_pos_neg. -Qed. - -Lemma shiftl_0_r : forall a, a << 0 == a. -Proof. - intros. rewrite shiftl_mul_pow2 by order. now nzsimpl. -Qed. - -Lemma shiftr_0_r : forall a, a >> 0 == a. -Proof. - intros. now rewrite <- shiftl_opp_r, opp_0, shiftl_0_r. -Qed. - -Lemma shiftl_0_l : forall n, 0 << n == 0. -Proof. - intros n. - destruct (le_ge_cases 0 n) as [H|H]. - - rewrite shiftl_mul_pow2 by trivial. now nzsimpl. - - rewrite shiftl_div_pow2 by trivial. - rewrite <- opp_nonneg_nonpos in H. nzsimpl; order_nz. -Qed. - -Lemma shiftr_0_l : forall n, 0 >> n == 0. -Proof. - intros. now rewrite <- shiftl_opp_r, shiftl_0_l. -Qed. - -Lemma shiftl_eq_0_iff : forall a n, 0<=n -> (a << n == 0 <-> a == 0). -Proof. - intros a n Hn. - rewrite shiftl_mul_pow2 by trivial. rewrite eq_mul_0. split. - - intros [H | H]; trivial. contradict H; order_nz. - - intros H. now left. -Qed. - -Lemma shiftr_eq_0_iff : forall a n, - a >> n == 0 <-> a==0 \/ (0 log2 a < n -> a >> n == 0. -Proof. - intros a n Ha H. apply shiftr_eq_0_iff. - le_elim Ha. - - right. now split. - - now left. -Qed. - -(** Properties of [div2]. *) - -Lemma div2_div : forall a, div2 a == a/2. -Proof. - intros. rewrite div2_spec, shiftr_div_pow2. - - now nzsimpl. - - order'. -Qed. - -#[global] -Instance div2_wd : Proper (eq==>eq) div2. -Proof. - intros a a' Ha. now rewrite 2 div2_div, Ha. -Qed. - -Lemma div2_odd : forall a, a == 2*(div2 a) + odd a. -Proof. - intros a. rewrite div2_div, <- bit0_odd, bit0_mod. - apply div_mod. order'. -Qed. - -(** Properties of [lxor] and others, directly deduced - from properties of [xorb] and others. *) - -#[global] -Instance lxor_wd : Proper (eq ==> eq ==> eq) lxor. -Proof. - intros a a' Ha b b' Hb. bitwise. now rewrite Ha, Hb. -Qed. - -#[global] -Instance land_wd : Proper (eq ==> eq ==> eq) land. -Proof. - intros a a' Ha b b' Hb. bitwise. now rewrite Ha, Hb. -Qed. - -#[global] -Instance lor_wd : Proper (eq ==> eq ==> eq) lor. -Proof. - intros a a' Ha b b' Hb. bitwise. now rewrite Ha, Hb. -Qed. - -#[global] -Instance ldiff_wd : Proper (eq ==> eq ==> eq) ldiff. -Proof. - intros a a' Ha b b' Hb. bitwise. now rewrite Ha, Hb. -Qed. - -Lemma lxor_eq : forall a a', lxor a a' == 0 -> a == a'. -Proof. - intros a a' H. bitwise. apply xorb_eq. - now rewrite <- lxor_spec, H, bits_0. -Qed. - -Lemma lxor_nilpotent : forall a, lxor a a == 0. -Proof. - intros. bitwise. apply xorb_nilpotent. -Qed. - -Lemma lxor_eq_0_iff : forall a a', lxor a a' == 0 <-> a == a'. -Proof. - split. - - apply lxor_eq. - - intros EQ; rewrite EQ; apply lxor_nilpotent. -Qed. - -Lemma lxor_0_l : forall a, lxor 0 a == a. -Proof. - intros. bitwise. apply xorb_false_l. -Qed. - -Lemma lxor_0_r : forall a, lxor a 0 == a. -Proof. - intros. bitwise. apply xorb_false_r. -Qed. - -Lemma lxor_comm : forall a b, lxor a b == lxor b a. -Proof. - intros. bitwise. apply xorb_comm. -Qed. - -Lemma lxor_assoc : - forall a b c, lxor (lxor a b) c == lxor a (lxor b c). -Proof. - intros. bitwise. apply xorb_assoc. -Qed. - -Lemma lor_0_l : forall a, lor 0 a == a. -Proof. - intros. bitwise. trivial. -Qed. - -Lemma lor_0_r : forall a, lor a 0 == a. -Proof. - intros. bitwise. apply orb_false_r. -Qed. - -Lemma lor_comm : forall a b, lor a b == lor b a. -Proof. - intros. bitwise. apply orb_comm. -Qed. - -Lemma lor_assoc : - forall a b c, lor a (lor b c) == lor (lor a b) c. -Proof. - intros. bitwise. apply orb_assoc. -Qed. - -Lemma lor_diag : forall a, lor a a == a. -Proof. - intros. bitwise. apply orb_diag. -Qed. - -Lemma lor_eq_0_l : forall a b, lor a b == 0 -> a == 0. -Proof. - intros a b H. bitwise as m ?. - apply (orb_false_iff a.[m] b.[m]). - now rewrite <- lor_spec, H, bits_0. -Qed. - -Lemma lor_eq_0_iff : forall a b, lor a b == 0 <-> a == 0 /\ b == 0. -Proof. - intros a b. split. - - intro H; split. - + now apply lor_eq_0_l in H. - + rewrite lor_comm in H. now apply lor_eq_0_l in H. - - intros (EQ,EQ'). now rewrite EQ, lor_0_l. -Qed. - -Lemma land_0_l : forall a, land 0 a == 0. -Proof. - intros. bitwise. trivial. -Qed. - -Lemma land_0_r : forall a, land a 0 == 0. -Proof. - intros. bitwise. apply andb_false_r. -Qed. - -Lemma land_comm : forall a b, land a b == land b a. -Proof. - intros. bitwise. apply andb_comm. -Qed. - -Lemma land_assoc : - forall a b c, land a (land b c) == land (land a b) c. -Proof. - intros. bitwise. apply andb_assoc. -Qed. - -Lemma land_diag : forall a, land a a == a. -Proof. - intros. bitwise. apply andb_diag. -Qed. - -Lemma ldiff_0_l : forall a, ldiff 0 a == 0. -Proof. - intros. bitwise. trivial. -Qed. - -Lemma ldiff_0_r : forall a, ldiff a 0 == a. -Proof. - intros. bitwise. now rewrite andb_true_r. -Qed. - -Lemma ldiff_diag : forall a, ldiff a a == 0. -Proof. - intros. bitwise. apply andb_negb_r. -Qed. - -Lemma lor_land_distr_l : forall a b c, - lor (land a b) c == land (lor a c) (lor b c). -Proof. - intros. bitwise. apply orb_andb_distrib_l. -Qed. - -Lemma lor_land_distr_r : forall a b c, - lor a (land b c) == land (lor a b) (lor a c). -Proof. - intros. bitwise. apply orb_andb_distrib_r. -Qed. - -Lemma land_lor_distr_l : forall a b c, - land (lor a b) c == lor (land a c) (land b c). -Proof. - intros. bitwise. apply andb_orb_distrib_l. -Qed. - -Lemma land_lor_distr_r : forall a b c, - land a (lor b c) == lor (land a b) (land a c). -Proof. - intros. bitwise. apply andb_orb_distrib_r. -Qed. - -Lemma ldiff_ldiff_l : forall a b c, - ldiff (ldiff a b) c == ldiff a (lor b c). -Proof. - intros. bitwise. now rewrite negb_orb, andb_assoc. -Qed. - -Lemma lor_ldiff_and : forall a b, - lor (ldiff a b) (land a b) == a. -Proof. - intros. bitwise. - now rewrite <- andb_orb_distrib_r, orb_comm, orb_negb_r, andb_true_r. -Qed. - -Lemma land_ldiff : forall a b, - land (ldiff a b) b == 0. -Proof. - intros. bitwise. - now rewrite <-andb_assoc, (andb_comm (negb _)), andb_negb_r, andb_false_r. -Qed. - -(** Properties of [setbit] and [clearbit] *) - -Definition setbit a n := lor a (1 << n). -Definition clearbit a n := ldiff a (1 << n). - -Lemma setbit_spec' : forall a n, setbit a n == lor a (2^n). -Proof. - intros. unfold setbit. now rewrite shiftl_1_l. -Qed. - -Lemma clearbit_spec' : forall a n, clearbit a n == ldiff a (2^n). -Proof. - intros. unfold clearbit. now rewrite shiftl_1_l. -Qed. - -#[global] -Instance setbit_wd : Proper (eq==>eq==>eq) setbit. -Proof. unfold setbit. solve_proper. Qed. - -#[global] -Instance clearbit_wd : Proper (eq==>eq==>eq) clearbit. -Proof. unfold clearbit. solve_proper. Qed. - -Lemma pow2_bits_true : forall n, 0<=n -> (2^n).[n] = true. -Proof. - intros n ?. rewrite <- (mul_1_l (2^n)). - now rewrite mul_pow2_bits, sub_diag, bit0_odd, odd_1. -Qed. - -Lemma pow2_bits_false : forall n m, n~=m -> (2^n).[m] = false. -Proof. - intros n m ?. - destruct (le_gt_cases 0 n); [|now rewrite pow_neg_r, bits_0]. - destruct (le_gt_cases n m). - - rewrite <- (mul_1_l (2^n)), mul_pow2_bits; trivial. - rewrite <- (succ_pred (m-n)), <- div2_bits. - + now rewrite div_small, bits_0 by (split; order'). - + rewrite <- lt_succ_r, succ_pred, lt_0_sub. order. - - rewrite <- (mul_1_l (2^n)), mul_pow2_bits_low; trivial. -Qed. - -Lemma pow2_bits_eqb : forall n m, 0<=n -> (2^n).[m] = eqb n m. -Proof. - intros n m Hn. apply eq_true_iff_eq. rewrite eqb_eq. split. - - destruct (eq_decidable n m) as [H|H]. { trivial. } - now rewrite (pow2_bits_false _ _ H). - - intros EQ. rewrite EQ. apply pow2_bits_true; order. -Qed. - -Lemma setbit_eqb : forall a n m, 0<=n -> - (setbit a n).[m] = eqb n m || a.[m]. -Proof. - intros. now rewrite setbit_spec', lor_spec, pow2_bits_eqb, orb_comm. -Qed. - -Lemma setbit_iff : forall a n m, 0<=n -> - ((setbit a n).[m] = true <-> n==m \/ a.[m] = true). -Proof. - intros. now rewrite setbit_eqb, orb_true_iff, eqb_eq. -Qed. - -Lemma setbit_eq : forall a n, 0<=n -> (setbit a n).[n] = true. -Proof. - intros. apply setbit_iff; trivial. now left. -Qed. - -Lemma setbit_neq : forall a n m, 0<=n -> n~=m -> - (setbit a n).[m] = a.[m]. -Proof. - intros a n m Hn H. rewrite setbit_eqb; trivial. - rewrite <- eqb_eq in H. apply not_true_is_false in H. now rewrite H. -Qed. - -Lemma clearbit_eqb : forall a n m, - (clearbit a n).[m] = a.[m] && negb (eqb n m). -Proof. - intros a n m. - destruct (le_gt_cases 0 m); [| now rewrite 2 testbit_neg_r]. - rewrite clearbit_spec', ldiff_spec. f_equal. f_equal. - destruct (le_gt_cases 0 n) as [Hn|Hn]. - - now apply pow2_bits_eqb. - - symmetry. rewrite pow_neg_r, bits_0, <- not_true_iff_false, eqb_eq; order. -Qed. - -Lemma clearbit_iff : forall a n m, - (clearbit a n).[m] = true <-> a.[m] = true /\ n~=m. -Proof. - intros. rewrite clearbit_eqb, andb_true_iff, <- eqb_eq. - now rewrite negb_true_iff, not_true_iff_false. -Qed. - -Lemma clearbit_eq : forall a n, (clearbit a n).[n] = false. -Proof. - intros a n. rewrite clearbit_eqb, (proj2 (eqb_eq _ _) (eq_refl n)). - apply andb_false_r. -Qed. - -Lemma clearbit_neq : forall a n m, n~=m -> - (clearbit a n).[m] = a.[m]. -Proof. - intros a n m H. rewrite clearbit_eqb. - rewrite <- eqb_eq in H. apply not_true_is_false in H. rewrite H. - apply andb_true_r. -Qed. - -(** Shifts of bitwise operations *) - -Lemma shiftl_lxor : forall a b n, - (lxor a b) << n == lxor (a << n) (b << n). -Proof. - intros. bitwise. now rewrite !shiftl_spec, lxor_spec. -Qed. - -Lemma shiftr_lxor : forall a b n, - (lxor a b) >> n == lxor (a >> n) (b >> n). -Proof. - intros. bitwise. now rewrite !shiftr_spec, lxor_spec. -Qed. - -Lemma shiftl_land : forall a b n, - (land a b) << n == land (a << n) (b << n). -Proof. - intros. bitwise. now rewrite !shiftl_spec, land_spec. -Qed. - -Lemma shiftr_land : forall a b n, - (land a b) >> n == land (a >> n) (b >> n). -Proof. - intros. bitwise. now rewrite !shiftr_spec, land_spec. -Qed. - -Lemma shiftl_lor : forall a b n, - (lor a b) << n == lor (a << n) (b << n). -Proof. - intros. bitwise. now rewrite !shiftl_spec, lor_spec. -Qed. - -Lemma shiftr_lor : forall a b n, - (lor a b) >> n == lor (a >> n) (b >> n). -Proof. - intros. bitwise. now rewrite !shiftr_spec, lor_spec. -Qed. - -Lemma shiftl_ldiff : forall a b n, - (ldiff a b) << n == ldiff (a << n) (b << n). -Proof. - intros. bitwise. now rewrite !shiftl_spec, ldiff_spec. -Qed. - -Lemma shiftr_ldiff : forall a b n, - (ldiff a b) >> n == ldiff (a >> n) (b >> n). -Proof. - intros. bitwise. now rewrite !shiftr_spec, ldiff_spec. -Qed. - -(** For integers, we do have a binary complement function *) - -Definition lnot a := P (-a). - -#[global] -Instance lnot_wd : Proper (eq==>eq) lnot. -Proof. unfold lnot. solve_proper. Qed. - -Lemma lnot_spec : forall a n, 0<=n -> (lnot a).[n] = negb a.[n]. -Proof. - intros a n ?. unfold lnot. rewrite <- (opp_involutive a) at 2. - rewrite bits_opp, negb_involutive; trivial. -Qed. - -Lemma lnot_involutive : forall a, lnot (lnot a) == a. -Proof. - intros a. bitwise. now rewrite 2 lnot_spec, negb_involutive. -Qed. - -Lemma lnot_0 : lnot 0 == -1. -Proof. - unfold lnot. now rewrite opp_0, <- sub_1_r, sub_0_l. -Qed. - -Lemma lnot_m1 : lnot (-1) == 0. -Proof. - unfold lnot. now rewrite opp_involutive, one_succ, pred_succ. -Qed. - -(** Complement and other operations *) - -Lemma lor_m1_r : forall a, lor a (-1) == -1. -Proof. - intros. bitwise. now rewrite bits_m1, orb_true_r. -Qed. - -Lemma lor_m1_l : forall a, lor (-1) a == -1. -Proof. - intros. now rewrite lor_comm, lor_m1_r. -Qed. - -Lemma land_m1_r : forall a, land a (-1) == a. -Proof. - intros. bitwise. now rewrite bits_m1, andb_true_r. -Qed. - -Lemma land_m1_l : forall a, land (-1) a == a. -Proof. - intros. now rewrite land_comm, land_m1_r. -Qed. - -Lemma ldiff_m1_r : forall a, ldiff a (-1) == 0. -Proof. - intros. bitwise. now rewrite bits_m1, andb_false_r. -Qed. - -Lemma ldiff_m1_l : forall a, ldiff (-1) a == lnot a. -Proof. - intros. bitwise. now rewrite lnot_spec, bits_m1. -Qed. - -Lemma lor_lnot_diag : forall a, lor a (lnot a) == -1. -Proof. - intros a. bitwise as m ?. rewrite lnot_spec, bits_m1; trivial. - now destruct a.[m]. -Qed. - -Lemma add_lnot_diag : forall a, a + lnot a == -1. -Proof. - intros a. unfold lnot. - now rewrite add_pred_r, add_opp_r, sub_diag, one_succ, opp_succ, opp_0. -Qed. - -Lemma ldiff_land : forall a b, ldiff a b == land a (lnot b). -Proof. - intros. bitwise. now rewrite lnot_spec. -Qed. - -Lemma land_lnot_diag : forall a, land a (lnot a) == 0. -Proof. - intros. now rewrite <- ldiff_land, ldiff_diag. -Qed. - -Lemma lnot_lor : forall a b, lnot (lor a b) == land (lnot a) (lnot b). -Proof. - intros a b. bitwise. now rewrite !lnot_spec, lor_spec, negb_orb. -Qed. - -Lemma lnot_land : forall a b, lnot (land a b) == lor (lnot a) (lnot b). -Proof. - intros a b. bitwise. now rewrite !lnot_spec, land_spec, negb_andb. -Qed. - -Lemma lnot_ldiff : forall a b, lnot (ldiff a b) == lor (lnot a) b. -Proof. - intros a b. bitwise. - now rewrite !lnot_spec, ldiff_spec, negb_andb, negb_involutive. -Qed. - -Lemma lxor_lnot_lnot : forall a b, lxor (lnot a) (lnot b) == lxor a b. -Proof. - intros a b. bitwise. now rewrite !lnot_spec, xorb_negb_negb. -Qed. - -Lemma lnot_lxor_l : forall a b, lnot (lxor a b) == lxor (lnot a) b. -Proof. - intros a b. bitwise. now rewrite !lnot_spec, !lxor_spec, negb_xorb_l. -Qed. - -Lemma lnot_lxor_r : forall a b, lnot (lxor a b) == lxor a (lnot b). -Proof. - intros a b. bitwise. now rewrite !lnot_spec, !lxor_spec, negb_xorb_r. -Qed. - -Lemma lxor_m1_r : forall a, lxor a (-1) == lnot a. -Proof. - intros a. now rewrite <- (lxor_0_r (lnot a)), <- lnot_m1, lxor_lnot_lnot. -Qed. - -Lemma lxor_m1_l : forall a, lxor (-1) a == lnot a. -Proof. - intros. now rewrite lxor_comm, lxor_m1_r. -Qed. - -Lemma lxor_lor : forall a b, land a b == 0 -> - lxor a b == lor a b. -Proof. - intros a b H. bitwise as m ?. - assert (a.[m] && b.[m] = false) - by now rewrite <- land_spec, H, bits_0. - now destruct a.[m], b.[m]. -Qed. - -Lemma lnot_shiftr : forall a n, 0<=n -> lnot (a >> n) == (lnot a) >> n. -Proof. - intros a n Hn. bitwise. - now rewrite lnot_spec, 2 shiftr_spec, lnot_spec by order_pos. -Qed. - -(** [(ones n)] is [2^n-1], the number with [n] digits 1 *) - -Definition ones n := P (1<eq) ones. -Proof. unfold ones. solve_proper. Qed. - -Lemma ones_equiv : forall n, ones n == P (2^n). -Proof. - intros n. unfold ones. - destruct (le_gt_cases 0 n). - - now rewrite shiftl_mul_pow2, mul_1_l. - - f_equiv. rewrite pow_neg_r; trivial. - rewrite <- shiftr_opp_r. apply shiftr_eq_0_iff. right; split. - { order'. } - rewrite log2_1. now apply opp_pos_neg. -Qed. - -Lemma ones_add : forall n m, 0<=n -> 0<=m -> - ones (m+n) == 2^m * ones n + ones m. -Proof. - intros n m Hn Hm. rewrite !ones_equiv. - rewrite <- !sub_1_r, mul_sub_distr_l, mul_1_r, <- pow_add_r by trivial. - rewrite add_sub_assoc, sub_add. reflexivity. -Qed. - -Lemma ones_div_pow2 : forall n m, 0<=m<=n -> ones n / 2^m == ones (n-m). -Proof. - intros n m (Hm,H). symmetry. apply div_unique with (ones m). - - left. rewrite ones_equiv. split. - + rewrite <- lt_succ_r, succ_pred. order_pos. - + now rewrite <- le_succ_l, succ_pred. - - rewrite <- (sub_add m n) at 1. rewrite (add_comm _ m). - apply ones_add; trivial. now apply le_0_sub. -Qed. - -Lemma ones_mod_pow2 : forall n m, 0<=m<=n -> (ones n) mod (2^m) == ones m. -Proof. - intros n m (Hm,H). symmetry. apply mod_unique with (ones (n-m)). - - left. rewrite ones_equiv. split. - + rewrite <- lt_succ_r, succ_pred. order_pos. - + now rewrite <- le_succ_l, succ_pred. - - rewrite <- (sub_add m n) at 1. rewrite (add_comm _ m). - apply ones_add; trivial. now apply le_0_sub. -Qed. - -Lemma ones_spec_low : forall n m, 0<=m (ones n).[m] = true. -Proof. - intros n m (Hm,H). apply testbit_true; trivial. - rewrite ones_div_pow2 by (split; order). - rewrite <- (pow_1_r 2). rewrite ones_mod_pow2. - - rewrite ones_equiv. now nzsimpl'. - - split. { order'. } apply le_add_le_sub_r. nzsimpl. now apply le_succ_l. -Qed. - -Lemma ones_spec_high : forall n m, 0<=n<=m -> (ones n).[m] = false. -Proof. - intros n m (Hn,H). le_elim Hn. - - apply bits_above_log2; rewrite ones_equiv. - + rewrite <-lt_succ_r, succ_pred; order_pos. - + rewrite log2_pred_pow2; trivial. now rewrite <-le_succ_l, succ_pred. - - rewrite ones_equiv. now rewrite <- Hn, pow_0_r, one_succ, pred_succ, bits_0. -Qed. - -Lemma ones_spec_iff : forall n m, 0<=n -> - ((ones n).[m] = true <-> 0<=m log2 a < n -> - lor a (ones n) == ones n. -Proof. - intros a n Ha H. bitwise as m ?. destruct (le_gt_cases n m). - - rewrite ones_spec_high, bits_above_log2; try split; trivial. - + now apply lt_le_trans with n. - + apply le_trans with (log2 a); order_pos. - - rewrite ones_spec_low, orb_true_r; try split; trivial. -Qed. - -Lemma land_ones : forall a n, 0<=n -> land a (ones n) == a mod 2^n. -Proof. - intros a n Hn. bitwise as m ?. destruct (le_gt_cases n m). - - rewrite ones_spec_high, mod_pow2_bits_high, andb_false_r; - try split; trivial. - - rewrite ones_spec_low, mod_pow2_bits_low, andb_true_r; - try split; trivial. -Qed. - -Lemma land_ones_low : forall a n, 0<=a -> log2 a < n -> - land a (ones n) == a. -Proof. - intros a n Ha H. - assert (Hn : 0<=n) by (generalize (log2_nonneg a); order). - rewrite land_ones; trivial. apply mod_small. - split; trivial. - apply log2_lt_cancel. now rewrite log2_pow2. -Qed. - -Lemma ldiff_ones_r : forall a n, 0<=n -> - ldiff a (ones n) == (a >> n) << n. -Proof. - intros a n Hn. bitwise as m ?. destruct (le_gt_cases n m). - - rewrite ones_spec_high, shiftl_spec_high, shiftr_spec; trivial. - + rewrite sub_add; trivial. apply andb_true_r. - + now apply le_0_sub. - + now split. - - rewrite ones_spec_low, shiftl_spec_low, andb_false_r; - try split; trivial. -Qed. - -Lemma ldiff_ones_r_low : forall a n, 0<=a -> log2 a < n -> - ldiff a (ones n) == 0. -Proof. - intros a n Ha H. bitwise as m ?. destruct (le_gt_cases n m). - - rewrite ones_spec_high, bits_above_log2; trivial. - + now apply lt_le_trans with n. - + split; trivial. now apply le_trans with (log2 a); order_pos. - - rewrite ones_spec_low, andb_false_r; try split; trivial. -Qed. - -Lemma ldiff_ones_l_low : forall a n, 0<=a -> log2 a < n -> - ldiff (ones n) a == lxor a (ones n). -Proof. - intros a n Ha H. bitwise as m ?. destruct (le_gt_cases n m). - - rewrite ones_spec_high, bits_above_log2; trivial. - + now apply lt_le_trans with n. - + split; trivial. now apply le_trans with (log2 a); order_pos. - - rewrite ones_spec_low, xorb_true_r; try split; trivial. -Qed. - -(** Bitwise operations and sign *) - -Lemma shiftl_nonneg : forall a n, 0 <= (a << n) <-> 0 <= a. -Proof. - intros a n. - destruct (le_ge_cases 0 n) as [Hn|Hn]. - - (* 0<=n *) - rewrite 2 bits_iff_nonneg_ex. split; intros (k,Hk). - + exists (k-n). intros m Hm. - destruct (le_gt_cases 0 m); [|now rewrite testbit_neg_r]. - rewrite <- (add_simpl_r m n), <- (shiftl_spec a n) by order_pos. - apply Hk. now apply lt_sub_lt_add_r. - + exists (k+n). intros m Hm. - destruct (le_gt_cases 0 m); [|now rewrite testbit_neg_r]. - rewrite shiftl_spec by trivial. apply Hk. now apply lt_add_lt_sub_r. - - (* n<=0*) - rewrite <- shiftr_opp_r, 2 bits_iff_nonneg_ex. split; intros (k,Hk). - + destruct (le_gt_cases 0 k). - * exists (k-n). intros m Hm. apply lt_sub_lt_add_r in Hm. - rewrite <- (add_simpl_r m n), <- add_opp_r, <- (shiftr_spec a (-n)) by order. - now apply Hk. - * assert (EQ : a >> (-n) == 0). { - apply bits_inj'. intros m Hm. rewrite bits_0. apply Hk; order. - } - apply shiftr_eq_0_iff in EQ. - rewrite <- bits_iff_nonneg_ex. destruct EQ as [EQ|[LT _]]; order. - + exists (k+n). intros m Hm. - destruct (le_gt_cases 0 m); [|now rewrite testbit_neg_r]. - rewrite shiftr_spec by trivial. apply Hk. - rewrite add_opp_r. now apply lt_add_lt_sub_r. -Qed. - -Lemma shiftl_neg : forall a n, (a << n) < 0 <-> a < 0. -Proof. - intros a n. now rewrite 2 lt_nge, shiftl_nonneg. -Qed. - -Lemma shiftr_nonneg : forall a n, 0 <= (a >> n) <-> 0 <= a. -Proof. - intros. rewrite <- shiftl_opp_r. apply shiftl_nonneg. -Qed. - -Lemma shiftr_neg : forall a n, (a >> n) < 0 <-> a < 0. -Proof. - intros a n. now rewrite 2 lt_nge, shiftr_nonneg. -Qed. - -Lemma div2_nonneg : forall a, 0 <= div2 a <-> 0 <= a. -Proof. - intros. rewrite div2_spec. apply shiftr_nonneg. -Qed. - -Lemma div2_neg : forall a, div2 a < 0 <-> a < 0. -Proof. - intros a. now rewrite 2 lt_nge, div2_nonneg. -Qed. - -Lemma lor_nonneg : forall a b, 0 <= lor a b <-> 0<=a /\ 0<=b. -Proof. - intros a b. - rewrite 3 bits_iff_nonneg_ex. split. - - intros (k,Hk). - split; exists k; intros m Hm; apply (orb_false_elim a.[m] b.[m]); - rewrite <- lor_spec; now apply Hk. - - intros ((k,Hk),(k',Hk')). - destruct (le_ge_cases k k'); [ exists k' | exists k ]; - intros m Hm; rewrite lor_spec, Hk, Hk'; trivial; order. -Qed. - -Lemma lor_neg : forall a b, lor a b < 0 <-> a < 0 \/ b < 0. -Proof. - intros a b. rewrite 3 lt_nge, lor_nonneg. split. - - apply not_and. apply le_decidable. - - now intros [H|H] (H',H''). -Qed. - -Lemma lnot_nonneg : forall a, 0 <= lnot a <-> a < 0. -Proof. - intros a; unfold lnot. - now rewrite <- opp_succ, opp_nonneg_nonpos, le_succ_l. -Qed. - -Lemma lnot_neg : forall a, lnot a < 0 <-> 0 <= a. -Proof. - intros a. now rewrite le_ngt, lt_nge, lnot_nonneg. -Qed. - -Lemma land_nonneg : forall a b, 0 <= land a b <-> 0<=a \/ 0<=b. -Proof. - intros a b. - now rewrite <- (lnot_involutive (land a b)), lnot_land, lnot_nonneg, - lor_neg, !lnot_neg. -Qed. - -Lemma land_neg : forall a b, land a b < 0 <-> a < 0 /\ b < 0. -Proof. - intros a b. - now rewrite <- (lnot_involutive (land a b)), lnot_land, lnot_neg, - lor_nonneg, !lnot_nonneg. -Qed. - -Lemma ldiff_nonneg : forall a b, 0 <= ldiff a b <-> 0<=a \/ b<0. -Proof. - intros. now rewrite ldiff_land, land_nonneg, lnot_nonneg. -Qed. - -Lemma ldiff_neg : forall a b, ldiff a b < 0 <-> a<0 /\ 0<=b. -Proof. - intros. now rewrite ldiff_land, land_neg, lnot_neg. -Qed. - -Lemma lxor_nonneg : forall a b, 0 <= lxor a b <-> (0<=a <-> 0<=b). -Proof. - assert (H : forall a b, 0<=a -> 0<=b -> 0<=lxor a b). { - intros a b. rewrite 3 bits_iff_nonneg_ex. intros (k,Hk) (k', Hk'). - destruct (le_ge_cases k k'); [ exists k' | exists k]; - intros m Hm; rewrite lxor_spec, Hk, Hk'; trivial; order. - } - assert (H' : forall a b, 0<=a -> b<0 -> lxor a b<0). { - intros a b. rewrite bits_iff_nonneg_ex, 2 bits_iff_neg_ex. - intros (k,Hk) (k', Hk'). - destruct (le_ge_cases k k'); [ exists k' | exists k]; - intros m Hm; rewrite lxor_spec, Hk, Hk'; trivial; order. - } - intros a b. - split. - - intros Hab. split. - + intros Ha. destruct (le_gt_cases 0 b) as [Hb|Hb]; trivial. - generalize (H' _ _ Ha Hb). order. - + intros Hb. destruct (le_gt_cases 0 a) as [Ha|Ha]; trivial. - generalize (H' _ _ Hb Ha). rewrite lxor_comm. order. - - intros E. - destruct (le_gt_cases 0 a) as [Ha|Ha]. - + apply H; trivial. apply E; trivial. - + destruct (le_gt_cases 0 b) as [Hb|Hb]. - * apply H; trivial. apply E; trivial. - * rewrite <- lxor_lnot_lnot. apply H; now apply lnot_nonneg. -Qed. - -(** Bitwise operations and log2 *) - -Lemma log2_bits_unique : forall a n, - a.[n] = true -> - (forall m, n a.[m] = false) -> - log2 a == n. -Proof. - intros a n H H'. - destruct (lt_trichotomy a 0) as [Ha|[Ha|Ha]]. - - (* a < 0 *) - destruct (proj1 (bits_iff_neg_ex a) Ha) as (k,Hk). - destruct (le_gt_cases n k). - + specialize (Hk (S k) (lt_succ_diag_r _)). - rewrite H' in Hk. - * discriminate. - * apply lt_succ_r; order. - + specialize (H' (S n) (lt_succ_diag_r _)). - rewrite Hk in H'. - * discriminate. - * apply lt_succ_r; order. - - (* a = 0 *) - now rewrite Ha, bits_0 in H. - - (* 0 < a *) - apply le_antisymm; apply le_ngt; intros LT. - + specialize (H' _ LT). now rewrite bit_log2 in H'. - + now rewrite bits_above_log2 in H by order. -Qed. - -Lemma log2_shiftr : forall a n, 0 log2 (a >> n) == max 0 (log2 a - n). -Proof. - intros a n Ha. - destruct (le_gt_cases 0 (log2 a - n)) as [H|H]; - [rewrite max_r | rewrite max_l]; try order. - - apply log2_bits_unique. - + now rewrite shiftr_spec, sub_add, bit_log2. - + intros m Hm. - destruct (le_gt_cases 0 m); [|now rewrite testbit_neg_r]. - rewrite shiftr_spec; trivial. apply bits_above_log2; try order. - now apply lt_sub_lt_add_r. - - rewrite lt_sub_lt_add_r, add_0_l in H. - apply log2_nonpos. apply le_lteq; right. - apply shiftr_eq_0_iff. right. now split. -Qed. - -Lemma log2_shiftl : forall a n, 0 0<=n -> log2 (a << n) == log2 a + n. -Proof. - intros a n Ha Hn. - rewrite shiftl_mul_pow2, add_comm by trivial. - now apply log2_mul_pow2. -Qed. - -Lemma log2_shiftl' : forall a n, 0 log2 (a << n) == max 0 (log2 a + n). -Proof. - intros a n Ha. - rewrite <- shiftr_opp_r, log2_shiftr by trivial. - destruct (le_gt_cases 0 (log2 a + n)); - [rewrite 2 max_r | rewrite 2 max_l]; rewrite ?sub_opp_r; try order. -Qed. - -Lemma log2_lor : forall a b, 0<=a -> 0<=b -> - log2 (lor a b) == max (log2 a) (log2 b). -Proof. - assert (AUX : forall a b, 0<=a -> a<=b -> log2 (lor a b) == log2 b). { - intros a b Ha H. - le_elim Ha; [|now rewrite <- Ha, lor_0_l]. - apply log2_bits_unique. - - now rewrite lor_spec, bit_log2, orb_true_r by order. - - intros m Hm. assert (H' := log2_le_mono _ _ H). - now rewrite lor_spec, 2 bits_above_log2 by order. - } - (* main *) - intros a b Ha Hb. destruct (le_ge_cases a b) as [H|H]. - - rewrite max_r by now apply log2_le_mono. - now apply AUX. - - rewrite max_l by now apply log2_le_mono. - rewrite lor_comm. now apply AUX. -Qed. - -Lemma log2_land : forall a b, 0<=a -> 0<=b -> - log2 (land a b) <= min (log2 a) (log2 b). -Proof. - assert (AUX : forall a b, 0<=a -> a<=b -> log2 (land a b) <= log2 a). { - intros a b Ha Hb. - apply le_ngt. intros LT. - assert (H : 0 <= land a b) by (apply land_nonneg; now left). - le_elim H. - - generalize (bit_log2 (land a b) H). - now rewrite land_spec, bits_above_log2. - - rewrite <- H in LT. apply log2_lt_cancel in LT; order. - } - (* main *) - intros a b Ha Hb. - destruct (le_ge_cases a b) as [H|H]. - - rewrite min_l by now apply log2_le_mono. now apply AUX. - - rewrite min_r by now apply log2_le_mono. rewrite land_comm. now apply AUX. -Qed. - -Lemma log2_lxor : forall a b, 0<=a -> 0<=b -> - log2 (lxor a b) <= max (log2 a) (log2 b). -Proof. - assert (AUX : forall a b, 0<=a -> a<=b -> log2 (lxor a b) <= log2 b). { - intros a b Ha Hb. - apply le_ngt. intros LT. - assert (H : 0 <= lxor a b) by (apply lxor_nonneg; split; order). - le_elim H. - - generalize (bit_log2 (lxor a b) H). - rewrite lxor_spec, 2 bits_above_log2; try order. - + discriminate. - + apply le_lt_trans with (log2 b); trivial. now apply log2_le_mono. - - rewrite <- H in LT. apply log2_lt_cancel in LT; order. - } - (* main *) - intros a b Ha Hb. - destruct (le_ge_cases a b) as [H|H]. - - rewrite max_r by now apply log2_le_mono. now apply AUX. - - rewrite max_l by now apply log2_le_mono. rewrite lxor_comm. now apply AUX. -Qed. - -(** Bitwise operations and arithmetical operations *) - -Local Notation xor3 a b c := (xorb (xorb a b) c). -Local Notation lxor3 a b c := (lxor (lxor a b) c). -Local Notation nextcarry a b c := ((a&&b) || (c && (a||b))). -Local Notation lnextcarry a b c := (lor (land a b) (land c (lor a b))). - -Lemma add_bit0 : forall a b, (a+b).[0] = xorb a.[0] b.[0]. -Proof. - intros. now rewrite !bit0_odd, odd_add. -Qed. - -Lemma add3_bit0 : forall a b c, - (a+b+c).[0] = xor3 a.[0] b.[0] c.[0]. -Proof. - intros. now rewrite !add_bit0. -Qed. - -Lemma add3_bits_div2 : forall (a0 b0 c0 : bool), - (a0 + b0 + c0)/2 == nextcarry a0 b0 c0. -Proof. - assert (H : 1+1 == 2) by now nzsimpl'. - intros [|] [|] [|]; simpl; rewrite ?add_0_l, ?add_0_r, ?H; - (apply div_same; order') || (apply div_small; split; order') || idtac. - symmetry. apply div_unique with 1. - - left; split; order'. - - now nzsimpl'. -Qed. - -Lemma add_carry_div2 : forall a b (c0:bool), - (a + b + c0)/2 == a/2 + b/2 + nextcarry a.[0] b.[0] c0. -Proof. - intros a b c0. - rewrite <- add3_bits_div2. - rewrite (add_comm ((a/2)+_)). - rewrite <- div_add by order'. - f_equiv. - rewrite <- !div2_div, mul_comm, mul_add_distr_l. - rewrite (div2_odd a), <- bit0_odd at 1. - rewrite (div2_odd b), <- bit0_odd at 1. - rewrite add_shuffle1. - rewrite <-(add_assoc _ _ c0). apply add_comm. -Qed. - -(** The main result concerning addition: we express the bits of the sum - in term of bits of [a] and [b] and of some carry stream which is also - recursively determined by another equation. -*) - -Lemma add_carry_bits_aux : forall n, 0<=n -> - forall a b (c0:bool), -(2^n) <= a < 2^n -> -(2^n) <= b < 2^n -> - exists c, - a+b+c0 == lxor3 a b c /\ c/2 == lnextcarry a b c /\ c.[0] = c0. -Proof. - intros n Hn. apply le_ind with (4:=Hn). - - solve_proper. - - (* base *) - intros a b c0. rewrite !pow_0_r, !one_succ, !lt_succ_r, <- !one_succ. - intros (Ha1,Ha2) (Hb1,Hb2). - le_elim Ha1; rewrite <- ?le_succ_l, ?succ_m1 in Ha1; - le_elim Hb1; rewrite <- ?le_succ_l, ?succ_m1 in Hb1. - + (* base, a = 0, b = 0 *) - exists c0. - rewrite (le_antisymm _ _ Ha2 Ha1), (le_antisymm _ _ Hb2 Hb1). - rewrite !add_0_l, !lxor_0_l, !lor_0_r, !land_0_r, !lor_0_r. - rewrite b2z_div2, b2z_bit0; now repeat split. - + (* base, a = 0, b = -1 *) - exists (-c0). rewrite <- Hb1, (le_antisymm _ _ Ha2 Ha1). repeat split. - * rewrite add_0_l, lxor_0_l, lxor_m1_l. - unfold lnot. now rewrite opp_involutive, add_comm, add_opp_r, sub_1_r. - * rewrite land_0_l, !lor_0_l, land_m1_r. - symmetry. apply div_unique with c0. { left; destruct c0; simpl; split; order'. } - now rewrite two_succ, mul_succ_l, mul_1_l, add_opp_r, sub_add. - * rewrite bit0_odd, odd_opp; destruct c0; simpl; apply odd_1 || apply odd_0. - + (* base, a = -1, b = 0 *) - exists (-c0). rewrite <- Ha1, (le_antisymm _ _ Hb2 Hb1). repeat split. - * rewrite add_0_r, lxor_0_r, lxor_m1_l. - unfold lnot. now rewrite opp_involutive, add_comm, add_opp_r, sub_1_r. - * rewrite land_0_r, lor_0_r, lor_0_l, land_m1_r. - symmetry. apply div_unique with c0. { left; destruct c0; simpl; split; order'. } - now rewrite two_succ, mul_succ_l, mul_1_l, add_opp_r, sub_add. - * rewrite bit0_odd, odd_opp; destruct c0; simpl; apply odd_1 || apply odd_0. - + (* base, a = -1, b = -1 *) - exists (c0 + 2*(-1)). rewrite <- Ha1, <- Hb1. repeat split. - * rewrite lxor_m1_l, lnot_m1, lxor_0_l. - now rewrite two_succ, mul_succ_l, mul_1_l, add_comm, add_assoc. - * rewrite land_m1_l, lor_m1_l. - apply add_b2z_double_div2. - * apply add_b2z_double_bit0. - - (* step *) - clear n Hn. intros n Hn IH a b c0 Ha Hb. - set (c1:=nextcarry a.[0] b.[0] c0). - destruct (IH (a/2) (b/2) c1) as (c & IH1 & IH2 & Hc); clear IH. - + split. - * apply div_le_lower_bound. { order'. } now rewrite mul_opp_r, <- pow_succ_r. - * apply div_lt_upper_bound. { order'. } now rewrite <- pow_succ_r. - + split. - * apply div_le_lower_bound. { order'. } now rewrite mul_opp_r, <- pow_succ_r. - * apply div_lt_upper_bound. { order'. } now rewrite <- pow_succ_r. - + exists (c0 + 2*c). repeat split. - * { (* step, add *) - bitwise as m Hm. - le_elim Hm. - - rewrite <- (succ_pred m), lt_succ_r in Hm. - rewrite <- (succ_pred m), <- !div2_bits, <- 2 lxor_spec by trivial. - f_equiv. - rewrite add_b2z_double_div2, <- IH1. apply add_carry_div2. - - rewrite <- Hm. - now rewrite add_b2z_double_bit0, add3_bit0, b2z_bit0. - } - * { (* step, carry *) - rewrite add_b2z_double_div2. - bitwise as m Hm. - le_elim Hm. - - rewrite <- (succ_pred m), lt_succ_r in Hm. - rewrite <- (succ_pred m), <- !div2_bits, IH2 by trivial. - autorewrite with bitwise. now rewrite add_b2z_double_div2. - - rewrite <- Hm. - now rewrite add_b2z_double_bit0. - } - * (* step, carry0 *) - apply add_b2z_double_bit0. -Qed. - -Lemma add_carry_bits : forall a b (c0:bool), exists c, - a+b+c0 == lxor3 a b c /\ c/2 == lnextcarry a b c /\ c.[0] = c0. -Proof. - intros a b c0. - set (n := max (abs a) (abs b)). - apply (add_carry_bits_aux n). - - (* positivity *) - unfold n. - destruct (le_ge_cases (abs a) (abs b)); - [rewrite max_r|rewrite max_l]; order_pos'. - - (* bound for a *) - assert (Ha : abs a < 2^n). - + apply lt_le_trans with (2^(abs a)). - * apply pow_gt_lin_r; order_pos'. - * apply pow_le_mono_r. { order'. } unfold n. - destruct (le_ge_cases (abs a) (abs b)); - [rewrite max_r|rewrite max_l]; try order. - + apply abs_lt in Ha. destruct Ha; split; order. - - (* bound for b *) - assert (Hb : abs b < 2^n). { - apply lt_le_trans with (2^(abs b)). - - apply pow_gt_lin_r; order_pos'. - - apply pow_le_mono_r. { order'. } unfold n. - destruct (le_ge_cases (abs a) (abs b)); - [rewrite max_r|rewrite max_l]; try order. - } - apply abs_lt in Hb. destruct Hb; split; order. -Qed. - -(** Particular case : the second bit of an addition *) - -Lemma add_bit1 : forall a b, - (a+b).[1] = xor3 a.[1] b.[1] (a.[0] && b.[0]). -Proof. - intros a b. - destruct (add_carry_bits a b false) as (c & EQ1 & EQ2 & Hc). - simpl in EQ1; rewrite add_0_r in EQ1. rewrite EQ1. - autorewrite with bitwise. f_equal. - rewrite one_succ, <- div2_bits, EQ2 by order. - autorewrite with bitwise. - rewrite Hc. simpl. apply orb_false_r. -Qed. - -(** In an addition, there will be no carries iff there is - no common bits in the numbers to add *) - -Lemma nocarry_equiv : forall a b c, - c/2 == lnextcarry a b c -> c.[0] = false -> - (c == 0 <-> land a b == 0). -Proof. - intros a b c H H'. - split. - - intros EQ; rewrite EQ in *. - rewrite div_0_l in H by order'. - symmetry in H. now apply lor_eq_0_l in H. - - intros EQ. rewrite EQ, lor_0_l in H. - apply bits_inj'. intros n Hn. rewrite bits_0. - apply le_ind with (4:=Hn). - + solve_proper. - + trivial. - + clear n Hn. intros n Hn IH. - rewrite <- div2_bits, H; trivial. - autorewrite with bitwise. - now rewrite IH. -Qed. - -(** When there is no common bits, the addition is just a xor *) - -Lemma add_nocarry_lxor : forall a b, land a b == 0 -> - a+b == lxor a b. -Proof. - intros a b H. - destruct (add_carry_bits a b false) as (c & EQ1 & EQ2 & Hc). - simpl in EQ1; rewrite add_0_r in EQ1. rewrite EQ1. - apply (nocarry_equiv a b c) in H; trivial. - rewrite H. now rewrite lxor_0_r. -Qed. - -(** A null [ldiff] implies being smaller *) - -Lemma ldiff_le : forall a b, 0<=b -> ldiff a b == 0 -> 0 <= a <= b. -Proof. - assert (AUX : forall n, 0<=n -> - forall a b, 0 <= a < 2^n -> 0<=b -> ldiff a b == 0 -> a <= b). { - intros n Hn. apply le_ind with (4:=Hn); clear n Hn. - - solve_proper. - - intros a b Ha Hb _. rewrite pow_0_r, one_succ, lt_succ_r in Ha. - setoid_replace a with 0 by (destruct Ha; order'); trivial. - - intros n Hn IH a b (Ha,Ha') Hb H. - assert (NEQ : 2 ~= 0) by order'. - rewrite (div_mod a 2 NEQ), (div_mod b 2 NEQ). - apply add_le_mono. - + apply mul_le_mono_pos_l; try order'. - apply IH. - * split. { apply div_pos; order'. } - apply div_lt_upper_bound; try order'. now rewrite <- pow_succ_r. - * apply div_pos; order'. - * rewrite <- (pow_1_r 2), <- 2 shiftr_div_pow2 by order'. - rewrite <- shiftr_ldiff, H, shiftr_div_pow2, pow_1_r, div_0_l; order'. - + rewrite <- 2 bit0_mod. - apply bits_inj_iff in H. specialize (H 0). - rewrite ldiff_spec, bits_0 in H. - destruct a.[0], b.[0]; try discriminate; simpl; order'. - } - (* main *) - intros a b Hb Hd. - assert (Ha : 0<=a). - { apply le_ngt; intros Ha'. apply (lt_irrefl 0). rewrite <- Hd at 1. - apply ldiff_neg. now split. } - split; trivial. apply (AUX a); try split; trivial. apply pow_gt_lin_r; order'. -Qed. - -(** Subtraction can be a ldiff when the opposite ldiff is null. *) - -Lemma sub_nocarry_ldiff : forall a b, ldiff b a == 0 -> - a-b == ldiff a b. -Proof. - intros a b H. - apply add_cancel_r with b. - rewrite sub_add. - symmetry. - rewrite add_nocarry_lxor; trivial. - - bitwise as m ?. - apply bits_inj_iff in H. specialize (H m). - rewrite ldiff_spec, bits_0 in H. - now destruct a.[m], b.[m]. - - apply land_ldiff. -Qed. - -(** Adding numbers with no common bits cannot lead to a much bigger number *) - -Lemma add_nocarry_lt_pow2 : forall a b n, land a b == 0 -> - a < 2^n -> b < 2^n -> a+b < 2^n. -Proof. - intros a b n H Ha Hb. - destruct (le_gt_cases a 0) as [Ha'|Ha']. - - apply le_lt_trans with (0+b). - + now apply add_le_mono_r. - + now nzsimpl. - - destruct (le_gt_cases b 0) as [Hb'|Hb']. - + apply le_lt_trans with (a+0). - * now apply add_le_mono_l. - * now nzsimpl. - + rewrite add_nocarry_lxor by order. - destruct (lt_ge_cases 0 (lxor a b)); [|apply le_lt_trans with 0; order_pos]. - apply log2_lt_pow2; trivial. - apply log2_lt_pow2 in Ha; trivial. - apply log2_lt_pow2 in Hb; trivial. - apply le_lt_trans with (max (log2 a) (log2 b)). - * apply log2_lxor; order. - * destruct (le_ge_cases (log2 a) (log2 b)); - [rewrite max_r|rewrite max_l]; order. -Qed. - -Lemma add_nocarry_mod_lt_pow2 : forall a b n, 0<=n -> land a b == 0 -> - a mod 2^n + b mod 2^n < 2^n. -Proof. - intros a b n Hn H. - apply add_nocarry_lt_pow2. - - bitwise as m ?. - destruct (le_gt_cases n m). - + rewrite mod_pow2_bits_high; now split. - + now rewrite !mod_pow2_bits_low, <- land_spec, H, bits_0. - - apply mod_pos_bound; order_pos. - - apply mod_pos_bound; order_pos. -Qed. - -End ZBitsProp. diff --git a/stdlib/theories/Numbers/Integer/Abstract/ZDivEucl.v b/stdlib/theories/Numbers/Integer/Abstract/ZDivEucl.v deleted file mode 100644 index 9b3d56172c48..000000000000 --- a/stdlib/theories/Numbers/Integer/Abstract/ZDivEucl.v +++ /dev/null @@ -1,640 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* 0 -> exists r q, a = b*q+r /\ 0 <= r < |b| ] - - The outcome of the modulo function is hence always positive. - This corresponds to convention "E" in the following paper: - - R. Boute, "The Euclidean definition of the functions div and mod", - ACM Transactions on Programming Languages and Systems, - Vol. 14, No.2, pp. 127-144, April 1992. - - See files [ZDivTrunc] and [ZDivFloor] for others conventions. - - We simply extend NZDiv with a bound for modulo that holds - regardless of the sign of a and b. This new specification - subsume mod_bound_pos, which nonetheless stays there for - subtyping. Note also that ZAxiomSig now already contain - a div and a modulo (that follow the Floor convention). - We just ignore them here. -*) - -Module Type EuclidSpec (Import A : ZAxiomsSig')(Import B : DivMod A). - Axiom mod_always_pos : forall a b, b ~= 0 -> 0 <= B.modulo a b < abs b. -End EuclidSpec. - -Module Type ZEuclid (Z:ZAxiomsSig) := NZDiv.NZDiv Z <+ EuclidSpec Z. - -Module ZEuclidProp - (Import A : ZAxiomsSig') - (Import B : ZMulOrderProp A) - (Import C : ZSgnAbsProp A B) - (Import D : ZEuclid A). - - (** We put notations in a scope, to avoid warnings about - redefinitions of notations *) - Declare Scope euclid. - Infix "/" := D.div : euclid. - Infix "mod" := D.modulo : euclid. - Local Open Scope euclid. - - Module Import Private_NZDiv := Nop <+ NZDivProp A D B. - -(** Another formulation of the main equation *) - -Lemma mod_eq : - forall a b, b~=0 -> a mod b == a - b*(a/b). -Proof. -intros. -rewrite <- add_move_l. -symmetry. now apply div_mod. -Qed. - -Ltac pos_or_neg a := - let LT := fresh "LT" in - let LE := fresh "LE" in - destruct (le_gt_cases 0 a) as [LE|LT]; [|rewrite <- opp_pos_neg in LT]. - -(** Uniqueness theorems *) - -Theorem div_mod_unique : forall b q1 q2 r1 r2 : t, - 0<=r1 0<=r2 - b*q1+r1 == b*q2+r2 -> q1 == q2 /\ r1 == r2. -Proof. -intros b q1 q2 r1 r2 Hr1 Hr2 EQ. -pos_or_neg b. -- rewrite abs_eq in * by trivial. - apply div_mod_unique with b; trivial. -- rewrite abs_neq' in * by auto using lt_le_incl. - rewrite eq_sym_iff. apply div_mod_unique with (-b); trivial. - rewrite 2 mul_opp_l. - rewrite add_move_l, sub_opp_r. - rewrite <-add_assoc. - symmetry. rewrite add_move_l, sub_opp_r. - now rewrite (add_comm r2), (add_comm r1). -Qed. - -Theorem div_unique: - forall a b q r, 0<=r a == b*q + r -> q == a/b. -Proof. -intros a b q r Hr EQ. -assert (Hb : b~=0). { - pos_or_neg b. - - rewrite abs_eq in Hr; intuition; order. - - rewrite <- opp_0, eq_opp_r. rewrite abs_neq' in Hr; intuition; order. -} -destruct (div_mod_unique b q (a/b) r (a mod b)); trivial. -- now apply mod_always_pos. -- now rewrite <- div_mod. -Qed. - -Theorem mod_unique: - forall a b q r, 0<=r a == b*q + r -> r == a mod b. -Proof. -intros a b q r Hr EQ. -assert (Hb : b~=0). { - pos_or_neg b. - - rewrite abs_eq in Hr; intuition; order. - - rewrite <- opp_0, eq_opp_r. rewrite abs_neq' in Hr; intuition; order. -} -destruct (div_mod_unique b q (a/b) r (a mod b)); trivial. -- now apply mod_always_pos. -- now rewrite <- div_mod. -Qed. - -(** Sign rules *) - -Lemma div_opp_r : forall a b, b~=0 -> a/(-b) == -(a/b). -Proof. -intros. symmetry. -apply div_unique with (a mod b). -- rewrite abs_opp; now apply mod_always_pos. -- rewrite mul_opp_opp; now apply div_mod. -Qed. - -Lemma mod_opp_r : forall a b, b~=0 -> a mod (-b) == a mod b. -Proof. -intros. symmetry. -apply mod_unique with (-(a/b)). -- rewrite abs_opp; now apply mod_always_pos. -- rewrite mul_opp_opp; now apply div_mod. -Qed. - -Lemma div_opp_l_z : forall a b, b~=0 -> a mod b == 0 -> - (-a)/b == -(a/b). -Proof. -intros a b Hb Hab. symmetry. -apply div_unique with (-(a mod b)). -- rewrite Hab, opp_0. split; [order|]. - pos_or_neg b; [rewrite abs_eq | rewrite abs_neq']; order. -- now rewrite mul_opp_r, <-opp_add_distr, <-div_mod. -Qed. - -Lemma div_opp_l_nz : forall a b, b~=0 -> a mod b ~= 0 -> - (-a)/b == -(a/b)-sgn b. -Proof. -intros a b Hb Hab. symmetry. -apply div_unique with (abs b -(a mod b)). -- rewrite lt_sub_lt_add_l. - rewrite <- le_add_le_sub_l. nzsimpl. - rewrite <- (add_0_l (abs b)) at 2. - rewrite <- add_lt_mono_r. - destruct (mod_always_pos a b); intuition order. -- rewrite <- 2 add_opp_r, mul_add_distr_l, 2 mul_opp_r. - rewrite sgn_abs. - rewrite add_shuffle2, add_opp_diag_l; nzsimpl. - rewrite <-opp_add_distr, <-div_mod; order. -Qed. - -Lemma mod_opp_l_z : forall a b, b~=0 -> a mod b == 0 -> - (-a) mod b == 0. -Proof. -intros a b Hb Hab. symmetry. -apply mod_unique with (-(a/b)). -- split; [order|now rewrite abs_pos]. -- now rewrite <-opp_0, <-Hab, mul_opp_r, <-opp_add_distr, <-div_mod. -Qed. - -Lemma mod_opp_l_nz : forall a b, b~=0 -> a mod b ~= 0 -> - (-a) mod b == abs b - (a mod b). -Proof. -intros a b Hb Hab. symmetry. -apply mod_unique with (-(a/b)-sgn b). -- rewrite lt_sub_lt_add_l. - rewrite <- le_add_le_sub_l. nzsimpl. - rewrite <- (add_0_l (abs b)) at 2. - rewrite <- add_lt_mono_r. - destruct (mod_always_pos a b); intuition order. -- rewrite <- 2 add_opp_r, mul_add_distr_l, 2 mul_opp_r. - rewrite sgn_abs. - rewrite add_shuffle2, add_opp_diag_l; nzsimpl. - rewrite <-opp_add_distr, <-div_mod; order. -Qed. - -Lemma div_opp_opp_z : forall a b, b~=0 -> a mod b == 0 -> - (-a)/(-b) == a/b. -Proof. -intros. now rewrite div_opp_r, div_opp_l_z, opp_involutive. -Qed. - -Lemma div_opp_opp_nz : forall a b, b~=0 -> a mod b ~= 0 -> - (-a)/(-b) == a/b + sgn(b). -Proof. -intros. rewrite div_opp_r, div_opp_l_nz by trivial. -now rewrite opp_sub_distr, opp_involutive. -Qed. - -Lemma mod_opp_opp_z : forall a b, b~=0 -> a mod b == 0 -> - (-a) mod (-b) == 0. -Proof. -intros. now rewrite mod_opp_r, mod_opp_l_z. -Qed. - -Lemma mod_opp_opp_nz : forall a b, b~=0 -> a mod b ~= 0 -> - (-a) mod (-b) == abs b - a mod b. -Proof. -intros. now rewrite mod_opp_r, mod_opp_l_nz. -Qed. - -(** A division by itself returns 1 *) - -Lemma div_same : forall a, a~=0 -> a/a == 1. -Proof. -intros. symmetry. apply div_unique with 0. -- split; [order|now rewrite abs_pos]. -- now nzsimpl. -Qed. - -Lemma mod_same : forall a, a~=0 -> a mod a == 0. -Proof. -intros. -rewrite mod_eq, div_same by trivial. nzsimpl. apply sub_diag. -Qed. - -(** A division of a small number by a bigger one yields zero. *) - -Theorem div_small: forall a b, 0<=a a/b == 0. -Proof. exact div_small. Qed. - -(** Same situation, in term of modulo: *) - -Theorem mod_small: forall a b, 0<=a a mod b == a. -Proof. exact mod_small. Qed. - -(** * Basic values of divisions and modulo. *) - -Lemma div_0_l: forall a, a~=0 -> 0/a == 0. -Proof. - intros. pos_or_neg a. - - apply div_0_l; order. - - apply opp_inj. rewrite <- div_opp_r, opp_0 by trivial. now apply div_0_l. -Qed. - -Lemma mod_0_l: forall a, a~=0 -> 0 mod a == 0. -Proof. -intros; rewrite mod_eq, div_0_l; now nzsimpl. -Qed. - -Lemma div_1_r: forall a, a/1 == a. -Proof. -intros. symmetry. apply div_unique with 0. -- assert (H:=lt_0_1); rewrite abs_pos; intuition auto; order. -- now nzsimpl. -Qed. - -Lemma mod_1_r: forall a, a mod 1 == 0. -Proof. -intros. rewrite mod_eq, div_1_r; nzsimpl; auto using sub_diag. -apply neq_sym, lt_neq; apply lt_0_1. -Qed. - -Lemma div_1_l: forall a, 1 1/a == 0. -Proof. exact div_1_l. Qed. - -Lemma mod_1_l: forall a, 1 1 mod a == 1. -Proof. exact mod_1_l. Qed. - -Lemma div_mul : forall a b, b~=0 -> (a*b)/b == a. -Proof. -intros. symmetry. apply div_unique with 0. -- split; [order|now rewrite abs_pos]. -- nzsimpl; apply mul_comm. -Qed. - -Lemma mod_mul : forall a b, b~=0 -> (a*b) mod b == 0. -Proof. -intros. rewrite mod_eq, div_mul by trivial. rewrite mul_comm; apply sub_diag. -Qed. - -Theorem div_unique_exact a b q: b~=0 -> a == b*q -> q == a/b. -Proof. - intros Hb H. rewrite H, mul_comm. symmetry. now apply div_mul. -Qed. - -(** * Order results about mod and div *) - -(** A modulo cannot grow beyond its starting point. *) - -Theorem mod_le: forall a b, 0<=a -> b~=0 -> a mod b <= a. -Proof. - intros. pos_or_neg b. - - apply mod_le; order. - - rewrite <- mod_opp_r by trivial. apply mod_le; order. -Qed. - -Theorem div_pos : forall a b, 0<=a -> 0 0<= a/b. -Proof. exact div_pos. Qed. - -Lemma div_str_pos : forall a b, 0 0 < a/b. -Proof. exact div_str_pos. Qed. - -Lemma div_small_iff : forall a b, b~=0 -> (a/b==0 <-> 0<=a (a mod b == a <-> 0<=a 1 a/b < a. -Proof. exact div_lt. Qed. - -(** [le] is compatible with a positive division. *) - -Lemma div_le_mono : forall a b c, 0 a<=b -> a/c <= b/c. -Proof. -intros a b c Hc Hab. -rewrite lt_eq_cases in Hab. destruct Hab as [LT|EQ]; - [|rewrite EQ; order]. -rewrite <- lt_succ_r. -rewrite (mul_lt_mono_pos_l c) by order. -nzsimpl. -rewrite (add_lt_mono_r _ _ (a mod c)). -rewrite <- div_mod by order. -apply lt_le_trans with b; trivial. -rewrite (div_mod b c) at 1 by order. -rewrite <- add_assoc, <- add_le_mono_l. -apply le_trans with (c+0). -- nzsimpl; destruct (mod_always_pos b c); try order. - rewrite abs_eq in *; order. -- rewrite <- add_le_mono_l. destruct (mod_always_pos a c); order. -Qed. - -(** In this convention, [div] performs Rounding-Toward-Bottom - when divisor is positive, and Rounding-Toward-Top otherwise. - - Since we cannot speak of rational values here, we express this - fact by multiplying back by [b], and this leads to a nice - unique statement. -*) - -Lemma mul_div_le : forall a b, b~=0 -> b*(a/b) <= a. -Proof. -intros. -rewrite (div_mod a b) at 2; trivial. -rewrite <- (add_0_r (b*(a/b))) at 1. -rewrite <- add_le_mono_l. -now destruct (mod_always_pos a b). -Qed. - -(** Giving a reversed bound is slightly more complex *) - -Lemma mul_succ_div_gt: forall a b, 0 a < b*(S (a/b)). -Proof. -intros. -nzsimpl. -rewrite (div_mod a b) at 1; try order. -rewrite <- add_lt_mono_l. -destruct (mod_always_pos a b). { order. } -rewrite abs_eq in *; order. -Qed. - -Lemma mul_pred_div_gt: forall a b, b<0 -> a < b*(P (a/b)). -Proof. -intros a b Hb. -rewrite mul_pred_r, <- add_opp_r. -rewrite (div_mod a b) at 1; try order. -rewrite <- add_lt_mono_l. -destruct (mod_always_pos a b). { order. } -rewrite <- opp_pos_neg in Hb. rewrite abs_neq' in *; order. -Qed. - -(** NB: The three previous properties could be used as - specifications for [div]. *) - -(** Inequality [mul_div_le] is exact iff the modulo is zero. *) - -Lemma div_exact : forall a b, b~=0 -> (a == b*(a/b) <-> a mod b == 0). -Proof. -intros. -rewrite (div_mod a b) at 1; try order. -rewrite <- (add_0_r (b*(a/b))) at 2. -apply add_cancel_l. -Qed. - -(** Some additional inequalities about div. *) - -Theorem div_lt_upper_bound: - forall a b q, 0 a < b*q -> a/b < q. -Proof. -intros. -rewrite (mul_lt_mono_pos_l b) by trivial. -apply le_lt_trans with a; trivial. -apply mul_div_le; order. -Qed. - -Theorem div_le_upper_bound: - forall a b q, 0 a <= b*q -> a/b <= q. -Proof. -intros. -rewrite <- (div_mul q b) by order. -apply div_le_mono; trivial. now rewrite mul_comm. -Qed. - -Theorem div_le_lower_bound: - forall a b q, 0 b*q <= a -> q <= a/b. -Proof. -intros. -rewrite <- (div_mul q b) by order. -apply div_le_mono; trivial. now rewrite mul_comm. -Qed. - -(** A division respects opposite monotonicity for the divisor *) - -Lemma div_le_compat_l: forall p q r, 0<=p -> 0 p/r <= p/q. -Proof. exact div_le_compat_l. Qed. - -(** * Relations between usual operations and mod and div *) - -Lemma mod_add : forall a b c, c~=0 -> - (a + b * c) mod c == a mod c. -Proof. -intros. -symmetry. -apply mod_unique with (a/c+b); trivial. -- now apply mod_always_pos. -- rewrite mul_add_distr_l, add_shuffle0, <- div_mod by order. - now rewrite mul_comm. -Qed. - -Lemma div_add : forall a b c, c~=0 -> - (a + b * c) / c == a / c + b. -Proof. -intros. -apply (mul_cancel_l _ _ c); try order. -apply (add_cancel_r _ _ ((a+b*c) mod c)). -rewrite <- div_mod, mod_add by order. -rewrite mul_add_distr_l, add_shuffle0, <- div_mod by order. -now rewrite mul_comm. -Qed. - -Lemma div_add_l: forall a b c, b~=0 -> - (a * b + c) / b == a + c / b. -Proof. - intros a b c. rewrite (add_comm _ c), (add_comm a). - now apply div_add. -Qed. - -(** Cancellations. *) - -(** With the current convention, the following isn't always true - when [c<0]: [-3*-1 / -2*-1 = 3/2 = 1] while [-3/-2 = 2] *) - -Lemma div_mul_cancel_r : forall a b c, b~=0 -> 0 - (a*c)/(b*c) == a/b. -Proof. -intros. -symmetry. -apply div_unique with ((a mod b)*c). -- (* ineqs *) - rewrite abs_mul, (abs_eq c) by order. - rewrite <-(mul_0_l c), <-mul_lt_mono_pos_r, <-mul_le_mono_pos_r by trivial. - now apply mod_always_pos. -- (* equation *) - rewrite (div_mod a b) at 1 by order. - rewrite mul_add_distr_r. - rewrite add_cancel_r. - rewrite <- 2 mul_assoc. now rewrite (mul_comm c). -Qed. - -Lemma div_mul_cancel_l : forall a b c, b~=0 -> 0 - (c*a)/(c*b) == a/b. -Proof. -intros. rewrite !(mul_comm c); now apply div_mul_cancel_r. -Qed. - -Lemma mul_mod_distr_l: forall a b c, b~=0 -> 0 - (c*a) mod (c*b) == c * (a mod b). -Proof. -intros. -rewrite <- (add_cancel_l _ _ ((c*b)* ((c*a)/(c*b)))). -rewrite <- div_mod. -- rewrite div_mul_cancel_l by trivial. - rewrite <- mul_assoc, <- mul_add_distr_l, mul_cancel_l by order. - apply div_mod; order. -- rewrite <- neq_mul_0; intuition; order. -Qed. - -Lemma mul_mod_distr_r: forall a b c, b~=0 -> 0 - (a*c) mod (b*c) == (a mod b) * c. -Proof. - intros. rewrite !(mul_comm _ c); now rewrite mul_mod_distr_l. -Qed. - - -(** Operations modulo. *) - -Theorem mod_mod: forall a n, n~=0 -> - (a mod n) mod n == a mod n. -Proof. -intros. rewrite mod_small_iff by trivial. -now apply mod_always_pos. -Qed. - -Lemma mul_mod_idemp_l : forall a b n, n~=0 -> - ((a mod n)*b) mod n == (a*b) mod n. -Proof. - intros a b n Hn. symmetry. - rewrite (div_mod a n) at 1 by order. - rewrite add_comm, (mul_comm n), (mul_comm _ b). - rewrite mul_add_distr_l, mul_assoc. - rewrite mod_add by trivial. - now rewrite mul_comm. -Qed. - -Lemma mul_mod_idemp_r : forall a b n, n~=0 -> - (a*(b mod n)) mod n == (a*b) mod n. -Proof. - intros. rewrite !(mul_comm a). now apply mul_mod_idemp_l. -Qed. - -Theorem mul_mod: forall a b n, n~=0 -> - (a * b) mod n == ((a mod n) * (b mod n)) mod n. -Proof. - intros. now rewrite mul_mod_idemp_l, mul_mod_idemp_r. -Qed. - -Lemma add_mod_idemp_l : forall a b n, n~=0 -> - ((a mod n)+b) mod n == (a+b) mod n. -Proof. - intros a b n Hn. symmetry. - rewrite (div_mod a n) at 1 by order. - rewrite <- add_assoc, add_comm, mul_comm. - now rewrite mod_add. -Qed. - -Lemma add_mod_idemp_r : forall a b n, n~=0 -> - (a+(b mod n)) mod n == (a+b) mod n. -Proof. - intros. rewrite !(add_comm a). now apply add_mod_idemp_l. -Qed. - -Theorem add_mod: forall a b n, n~=0 -> - (a+b) mod n == (a mod n + b mod n) mod n. -Proof. - intros. now rewrite add_mod_idemp_l, add_mod_idemp_r. -Qed. - -(** With the current convention, the following result isn't always - true with a negative intermediate divisor. For instance - [ 3/(-2)/(-2) = 1 <> 0 = 3 / (-2*-2) ] and - [ 3/(-2)/2 = -1 <> 0 = 3 / (-2*2) ]. *) - -Lemma div_div : forall a b c, 0 c~=0 -> - (a/b)/c == a/(b*c). -Proof. - intros a b c Hb Hc. - apply div_unique with (b*((a/b) mod c) + a mod b). - - (* begin 0<= ... c~=0 -> - a mod (b*c) == a mod b + b*((a/b) mod c). -Proof. - intros a b c Hb Hc. - apply add_cancel_l with (b*c*(a/(b*c))). - rewrite <- div_mod by (apply neq_mul_0; split; order). - rewrite <- div_div by trivial. - rewrite add_assoc, add_shuffle0, <- mul_assoc, <- mul_add_distr_l. - rewrite <- div_mod by order. - apply div_mod; order. -Qed. - -Lemma mod_div: forall a b, b~=0 -> - a mod b / b == 0. -Proof. - intros a b Hb. - rewrite div_small_iff by assumption. - auto using mod_always_pos. -Qed. - -(** A last inequality: *) - -Theorem div_mul_le: - forall a b c, 0<=a -> 0 0<=c -> c*(a/b) <= (c*a)/b. -Proof. exact div_mul_le. Qed. - -(** mod is related to divisibility *) - -Lemma mod_divides : forall a b, b~=0 -> - (a mod b == 0 <-> (b|a)). -Proof. -intros a b Hb. split. -- intros Hab. exists (a/b). rewrite mul_comm. - rewrite (div_mod a b Hb) at 1. rewrite Hab; now nzsimpl. -- intros (c,Hc). rewrite Hc. now apply mod_mul. -Qed. - -End ZEuclidProp. diff --git a/stdlib/theories/Numbers/Integer/Abstract/ZDivFloor.v b/stdlib/theories/Numbers/Integer/Abstract/ZDivFloor.v deleted file mode 100644 index eb1eb382cca4..000000000000 --- a/stdlib/theories/Numbers/Integer/Abstract/ZDivFloor.v +++ /dev/null @@ -1,686 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* a mod b == a - b*(a/b). -Proof. -intros. -rewrite <- add_move_l. -symmetry. now apply div_mod. -Qed. - -(** We have a general bound for absolute values *) - -Lemma mod_bound_abs : - forall a b, b~=0 -> abs (a mod b) < abs b. -Proof. -intros a b **. -destruct (abs_spec b) as [(LE,EQ)|(LE,EQ)]; rewrite EQ. -- destruct (mod_pos_bound a b). - + order. - + now rewrite abs_eq. -- destruct (mod_neg_bound a b). - + order. - + rewrite abs_neq; trivial. - now rewrite <- opp_lt_mono. -Qed. - -(** Uniqueness theorems *) - -Theorem div_mod_unique : forall b q1 q2 r1 r2 : t, - (0<=r1 (0<=r2 - b*q1+r1 == b*q2+r2 -> q1 == q2 /\ r1 == r2. -Proof. -intros b q1 q2 r1 r2 Hr1 Hr2 EQ. -destruct Hr1; destruct Hr2; try (intuition; order). -- apply div_mod_unique with b; trivial. -- rewrite <- (opp_inj_wd r1 r2). - apply div_mod_unique with (-b); trivial. - + rewrite <- opp_lt_mono, opp_nonneg_nonpos; tauto. - + rewrite <- opp_lt_mono, opp_nonneg_nonpos; tauto. - + now rewrite 2 mul_opp_l, <- 2 opp_add_distr, opp_inj_wd. -Qed. - -Theorem div_unique: - forall a b q r, (0<=r a == b*q + r -> q == a/b. -Proof. -intros a b q r Hr EQ. -assert (Hb : b~=0) by (destruct Hr; intuition; order). -destruct (div_mod_unique b q (a/b) r (a mod b)); trivial. -- destruct Hr; [left; apply mod_pos_bound|right; apply mod_neg_bound]; - intuition order. -- now rewrite <- div_mod. -Qed. - -Theorem div_unique_pos: - forall a b q r, 0<=r a == b*q + r -> q == a/b. -Proof. intros a b q r **; apply div_unique with r; auto. Qed. - -Theorem div_unique_neg: - forall a b q r, b a == b*q + r -> q == a/b. -Proof. intros a b q r **; apply div_unique with r; auto. Qed. - -Theorem mod_unique: - forall a b q r, (0<=r a == b*q + r -> r == a mod b. -Proof. -intros a b q r Hr EQ. -assert (Hb : b~=0) by (destruct Hr; intuition; order). -destruct (div_mod_unique b q (a/b) r (a mod b)); trivial. -- destruct Hr; [left; apply mod_pos_bound|right; apply mod_neg_bound]; - intuition order. -- now rewrite <- div_mod. -Qed. - -Theorem mod_unique_pos: - forall a b q r, 0<=r a == b*q + r -> r == a mod b. -Proof. intros a b q r **; apply mod_unique with q; auto. Qed. - -Theorem mod_unique_neg: - forall a b q r, b a == b*q + r -> r == a mod b. -Proof. intros a b q r **; apply mod_unique with q; auto. Qed. - -(** Sign rules *) - -Ltac pos_or_neg a := - let LT := fresh "LT" in - let LE := fresh "LE" in - destruct (le_gt_cases 0 a) as [LE|LT]; [|rewrite <- opp_pos_neg in LT]. - -Fact mod_bound_or : forall a b, b~=0 -> 0<=a mod b - 0 <= -(a mod b) < -b \/ -b < -(a mod b) <= 0. -Proof. -intros a b **. -destruct (lt_ge_cases 0 b); [right|left]. -- rewrite <- opp_lt_mono, opp_nonpos_nonneg. - destruct (mod_pos_bound a b); intuition; order. -- rewrite <- opp_lt_mono, opp_nonneg_nonpos. - destruct (mod_neg_bound a b); intuition; order. -Qed. - -Lemma div_opp_opp : forall a b, b~=0 -> -a/-b == a/b. -Proof. -intros a b **. symmetry. apply div_unique with (- (a mod b)). -- now apply opp_mod_bound_or. -- rewrite mul_opp_l, <- opp_add_distr, <- div_mod; order. -Qed. - -Lemma mod_opp_opp : forall a b, b~=0 -> (-a) mod (-b) == - (a mod b). -Proof. -intros a b **. symmetry. apply mod_unique with (a/b). -- now apply opp_mod_bound_or. -- rewrite mul_opp_l, <- opp_add_distr, <- div_mod; order. -Qed. - -(** With the current conventions, the other sign rules are rather complex. *) - -Lemma div_opp_l_z : - forall a b, b~=0 -> a mod b == 0 -> (-a)/b == -(a/b). -Proof. -intros a b Hb H. symmetry. apply div_unique with 0. -- destruct (lt_ge_cases 0 b); [left|right]; intuition auto; order. -- rewrite <- opp_0, <- H. - rewrite mul_opp_r, <- opp_add_distr, <- div_mod; order. -Qed. - -Lemma div_opp_l_nz : - forall a b, b~=0 -> a mod b ~= 0 -> (-a)/b == -(a/b)-1. -Proof. -intros a b Hb H. symmetry. apply div_unique with (b - a mod b). -- destruct (lt_ge_cases 0 b); [left|right]. - + rewrite le_0_sub. rewrite <- (sub_0_r b) at 5. rewrite <- sub_lt_mono_l. - destruct (mod_pos_bound a b); intuition; order. - + rewrite le_sub_0. rewrite <- (sub_0_r b) at 1. rewrite <- sub_lt_mono_l. - destruct (mod_neg_bound a b); intuition; order. -- rewrite <- (add_opp_r b), mul_sub_distr_l, mul_1_r, sub_add_simpl_r_l. - rewrite mul_opp_r, <-opp_add_distr, <-div_mod; order. -Qed. - -Lemma mod_opp_l_z : - forall a b, b~=0 -> a mod b == 0 -> (-a) mod b == 0. -Proof. -intros a b Hb H. symmetry. apply mod_unique with (-(a/b)). -- destruct (lt_ge_cases 0 b); [left|right]; intuition auto; order. -- rewrite <- opp_0, <- H. - rewrite mul_opp_r, <- opp_add_distr, <- div_mod; order. -Qed. - -Lemma mod_opp_l_nz : - forall a b, b~=0 -> a mod b ~= 0 -> (-a) mod b == b - a mod b. -Proof. -intros a b Hb H. symmetry. apply mod_unique with (-(a/b)-1). -- destruct (lt_ge_cases 0 b); [left|right]. - + rewrite le_0_sub. rewrite <- (sub_0_r b) at 5. rewrite <- sub_lt_mono_l. - destruct (mod_pos_bound a b); intuition; order. - + rewrite le_sub_0. rewrite <- (sub_0_r b) at 1. rewrite <- sub_lt_mono_l. - destruct (mod_neg_bound a b); intuition; order. -- rewrite <- (add_opp_r b), mul_sub_distr_l, mul_1_r, sub_add_simpl_r_l. - rewrite mul_opp_r, <-opp_add_distr, <-div_mod; order. -Qed. - -Lemma div_opp_r_z : - forall a b, b~=0 -> a mod b == 0 -> a/(-b) == -(a/b). -Proof. -intros a b **. rewrite <- (opp_involutive a) at 1. -rewrite div_opp_opp; auto using div_opp_l_z. -Qed. - -Lemma div_opp_r_nz : - forall a b, b~=0 -> a mod b ~= 0 -> a/(-b) == -(a/b)-1. -Proof. -intros a b **. rewrite <- (opp_involutive a) at 1. -rewrite div_opp_opp; auto using div_opp_l_nz. -Qed. - -Lemma mod_opp_r_z : - forall a b, b~=0 -> a mod b == 0 -> a mod (-b) == 0. -Proof. -intros a b **. rewrite <- (opp_involutive a) at 1. -now rewrite mod_opp_opp, mod_opp_l_z, opp_0. -Qed. - -Lemma mod_opp_r_nz : - forall a b, b~=0 -> a mod b ~= 0 -> a mod (-b) == (a mod b) - b. -Proof. -intros a b **. rewrite <- (opp_involutive a) at 1. -rewrite mod_opp_opp, mod_opp_l_nz by trivial. -now rewrite opp_sub_distr, add_comm, add_opp_r. -Qed. - -(** The sign of [a mod b] is the one of [b] (when it isn't null) *) - -Lemma mod_sign_nz : forall a b, b~=0 -> a mod b ~= 0 -> - sgn (a mod b) == sgn b. -Proof. -intros a b Hb H. destruct (lt_ge_cases 0 b) as [Hb'|Hb']. -- destruct (mod_pos_bound a b Hb'). rewrite 2 sgn_pos; order. -- destruct (mod_neg_bound a b). + order. + rewrite 2 sgn_neg; order. -Qed. - -Lemma mod_sign : forall a b, b~=0 -> sgn (a mod b) ~= -sgn b. -Proof. -intros a b Hb H. -destruct (eq_decidable (a mod b) 0) as [EQ|NEQ]. -- apply Hb, sgn_null_iff, opp_inj. now rewrite <- H, opp_0, EQ, sgn_0. -- apply Hb, sgn_null_iff. apply eq_mul_0_l with 2; try order'. nzsimpl'. - apply add_move_0_l. rewrite <- H. symmetry. now apply mod_sign_nz. -Qed. - -Lemma mod_sign_mul : forall a b, b~=0 -> 0 <= (a mod b) * b. -Proof. -intros a b **. destruct (lt_ge_cases 0 b). -- apply mul_nonneg_nonneg; destruct (mod_pos_bound a b); order. -- apply mul_nonpos_nonpos; destruct (mod_neg_bound a b); order. -Qed. - -(** A division by itself returns 1 *) - -Lemma div_same : forall a, a~=0 -> a/a == 1. -Proof. - intros a ?. pos_or_neg a. - - apply div_same; order. - - rewrite <- div_opp_opp by trivial. now apply div_same. -Qed. - -Lemma mod_same : forall a, a~=0 -> a mod a == 0. -Proof. -intros. rewrite mod_eq, div_same by trivial. nzsimpl. apply sub_diag. -Qed. - -(** A division of a small number by a bigger one yields zero. *) - -Theorem div_small: forall a b, 0<=a a/b == 0. -Proof. exact div_small. Qed. - -(** Same situation, in term of modulo: *) - -Theorem mod_small: forall a b, 0<=a a mod b == a. -Proof. exact mod_small. Qed. - -(** * Basic values of divisions and modulo. *) - -Lemma div_0_l: forall a, a~=0 -> 0/a == 0. -Proof. - intros a ?. pos_or_neg a. - - apply div_0_l; order. - - rewrite <- div_opp_opp, opp_0 by trivial. now apply div_0_l. -Qed. - -Lemma mod_0_l: forall a, a~=0 -> 0 mod a == 0. -Proof. -intros; rewrite mod_eq, div_0_l; now nzsimpl. -Qed. - -Lemma div_1_r: forall a, a/1 == a. -Proof. - intros. symmetry. apply div_unique with 0. - - left. split; order || apply lt_0_1. - - now nzsimpl. -Qed. - -Lemma mod_1_r: forall a, a mod 1 == 0. -Proof. -intros. rewrite mod_eq, div_1_r; nzsimpl; auto using sub_diag. -intro EQ; symmetry in EQ; revert EQ; apply lt_neq; apply lt_0_1. -Qed. - -Lemma div_1_l: forall a, 1 1/a == 0. -Proof. exact div_1_l. Qed. - -Lemma mod_1_l: forall a, 1 1 mod a == 1. -Proof. exact mod_1_l. Qed. - -Lemma div_mul : forall a b, b~=0 -> (a*b)/b == a. -Proof. -intros a b ?. symmetry. apply div_unique with 0. -- destruct (lt_ge_cases 0 b); [left|right]; split; order. -- nzsimpl; apply mul_comm. -Qed. - -Lemma mod_mul : forall a b, b~=0 -> (a*b) mod b == 0. -Proof. -intros. rewrite mod_eq, div_mul by trivial. rewrite mul_comm; apply sub_diag. -Qed. - -Theorem div_unique_exact a b q: b~=0 -> a == b*q -> q == a/b. -Proof. - intros Hb H. rewrite H, mul_comm. symmetry. now apply div_mul. -Qed. - -(** * Order results about mod and div *) - -(** A modulo cannot grow beyond its starting point. *) - -Theorem mod_le: forall a b, 0<=a -> 0 a mod b <= a. -Proof. exact mod_le. Qed. - -Theorem div_pos : forall a b, 0<=a -> 0 0<= a/b. -Proof. exact div_pos. Qed. - -Lemma div_str_pos : forall a b, 0 0 < a/b. -Proof. exact div_str_pos. Qed. - -Lemma div_small_iff : forall a b, b~=0 -> (a/b==0 <-> 0<=a (a mod b == a <-> 0<=a 1 a/b < a. -Proof. exact div_lt. Qed. - -(** [le] is compatible with a positive division. *) - -Lemma div_le_mono : forall a b c, 0 a<=b -> a/c <= b/c. -Proof. -intros a b c Hc Hab. -rewrite lt_eq_cases in Hab. destruct Hab as [LT|EQ]; - [|rewrite EQ; order]. -rewrite <- lt_succ_r. -rewrite (mul_lt_mono_pos_l c) by order. -nzsimpl. -rewrite (add_lt_mono_r _ _ (a mod c)). -rewrite <- div_mod by order. -apply lt_le_trans with b; trivial. -rewrite (div_mod b c) at 1 by order. -rewrite <- add_assoc, <- add_le_mono_l. -apply le_trans with (c+0). -- nzsimpl; destruct (mod_pos_bound b c); order. -- rewrite <- add_le_mono_l. destruct (mod_pos_bound a c); order. -Qed. - -(** In this convention, [div] performs Rounding-Toward-Bottom. - - Since we cannot speak of rational values here, we express this - fact by multiplying back by [b], and this leads to separates - statements according to the sign of [b]. - - First, [a/b] is below the exact fraction ... -*) - -Lemma mul_div_le : forall a b, 0 b*(a/b) <= a. -Proof. -intros a b **. -rewrite (div_mod a b) at 2; try order. -rewrite <- (add_0_r (b*(a/b))) at 1. -rewrite <- add_le_mono_l. -now destruct (mod_pos_bound a b). -Qed. - -Lemma mul_div_ge : forall a b, b<0 -> a <= b*(a/b). -Proof. -intros. rewrite <- div_opp_opp, opp_le_mono, <-mul_opp_l by order. -apply mul_div_le. now rewrite opp_pos_neg. -Qed. - -(** ... and moreover it is the larger such integer, since [S(a/b)] - is strictly above the exact fraction. -*) - -Lemma mul_succ_div_gt: forall a b, 0 a < b*(S (a/b)). -Proof. -intros a b ?. -nzsimpl. -rewrite (div_mod a b) at 1; try order. -rewrite <- add_lt_mono_l. -destruct (mod_pos_bound a b); order. -Qed. - -Lemma mul_succ_div_lt: forall a b, b<0 -> b*(S (a/b)) < a. -Proof. -intros. rewrite <- div_opp_opp, opp_lt_mono, <-mul_opp_l by order. -apply mul_succ_div_gt. now rewrite opp_pos_neg. -Qed. - -(** NB: The four previous properties could be used as - specifications for [div]. *) - -(** Inequality [mul_div_le] is exact iff the modulo is zero. *) - -Lemma div_exact : forall a b, b~=0 -> (a == b*(a/b) <-> a mod b == 0). -Proof. -intros a b **. -rewrite (div_mod a b) at 1; try order. -rewrite <- (add_0_r (b*(a/b))) at 2. -apply add_cancel_l. -Qed. - -(** Some additional inequalities about div. *) - -Theorem div_lt_upper_bound: - forall a b q, 0 a < b*q -> a/b < q. -Proof. -intros a b q **. -rewrite (mul_lt_mono_pos_l b) by trivial. -apply le_lt_trans with a; trivial. -now apply mul_div_le. -Qed. - -Theorem div_le_upper_bound: - forall a b q, 0 a <= b*q -> a/b <= q. -Proof. -intros a b q **. -rewrite <- (div_mul q b) by order. -apply div_le_mono; trivial. now rewrite mul_comm. -Qed. - -Theorem div_le_lower_bound: - forall a b q, 0 b*q <= a -> q <= a/b. -Proof. -intros a b q **. -rewrite <- (div_mul q b) by order. -apply div_le_mono; trivial. now rewrite mul_comm. -Qed. - -(** A division respects opposite monotonicity for the divisor *) - -Lemma div_le_compat_l: forall p q r, 0<=p -> 0 p/r <= p/q. -Proof. exact div_le_compat_l. Qed. - -(** * Relations between usual operations and mod and div *) - -Lemma mod_add : forall a b c, c~=0 -> - (a + b * c) mod c == a mod c. -Proof. -intros a b c **. -symmetry. -apply mod_unique with (a/c+b); trivial. -- now apply mod_bound_or. -- rewrite mul_add_distr_l, add_shuffle0, <- div_mod by order. - now rewrite mul_comm. -Qed. - -Lemma div_add : forall a b c, c~=0 -> - (a + b * c) / c == a / c + b. -Proof. -intros a b c **. -apply (mul_cancel_l _ _ c); try order. -apply (add_cancel_r _ _ ((a+b*c) mod c)). -rewrite <- div_mod, mod_add by order. -rewrite mul_add_distr_l, add_shuffle0, <- div_mod by order. -now rewrite mul_comm. -Qed. - -Lemma div_add_l: forall a b c, b~=0 -> - (a * b + c) / b == a + c / b. -Proof. - intros a b c. rewrite (add_comm _ c), (add_comm a). - now apply div_add. -Qed. - -(** Cancellations. *) - -Lemma div_mul_cancel_r : forall a b c, b~=0 -> c~=0 -> - (a*c)/(b*c) == a/b. -Proof. -intros a b c **. -symmetry. -apply div_unique with ((a mod b)*c). -- (* ineqs *) - destruct (lt_ge_cases 0 c). - + rewrite <-(mul_0_l c), <-2mul_lt_mono_pos_r, <-2mul_le_mono_pos_r by trivial. - now apply mod_bound_or. - + rewrite <-(mul_0_l c), <-2mul_lt_mono_neg_r, <-2mul_le_mono_neg_r by order. - destruct (mod_bound_or a b); tauto. -- (* equation *) - rewrite (div_mod a b) at 1 by order. - rewrite mul_add_distr_r. - rewrite add_cancel_r. - rewrite <- 2 mul_assoc. now rewrite (mul_comm c). -Qed. - -Lemma div_mul_cancel_l : forall a b c, b~=0 -> c~=0 -> - (c*a)/(c*b) == a/b. -Proof. -intros a b c **. rewrite !(mul_comm c); now apply div_mul_cancel_r. -Qed. - -Lemma mul_mod_distr_l: forall a b c, b~=0 -> c~=0 -> - (c*a) mod (c*b) == c * (a mod b). -Proof. -intros a b c **. -rewrite <- (add_cancel_l _ _ ((c*b)* ((c*a)/(c*b)))). -rewrite <- div_mod. -- rewrite div_mul_cancel_l by trivial. - rewrite <- mul_assoc, <- mul_add_distr_l, mul_cancel_l by order. - apply div_mod; order. -- rewrite <- neq_mul_0; auto. -Qed. - -Lemma mul_mod_distr_r: forall a b c, b~=0 -> c~=0 -> - (a*c) mod (b*c) == (a mod b) * c. -Proof. - intros a b c **. rewrite !(mul_comm _ c); now rewrite mul_mod_distr_l. -Qed. - - -(** Operations modulo. *) - -Theorem mod_mod: forall a n, n~=0 -> - (a mod n) mod n == a mod n. -Proof. -intros. rewrite mod_small_iff by trivial. -now apply mod_bound_or. -Qed. - -Lemma mul_mod_idemp_l : forall a b n, n~=0 -> - ((a mod n)*b) mod n == (a*b) mod n. -Proof. - intros a b n Hn. symmetry. - rewrite (div_mod a n) at 1 by order. - rewrite add_comm, (mul_comm n), (mul_comm _ b). - rewrite mul_add_distr_l, mul_assoc. - intros. rewrite mod_add by trivial. - now rewrite mul_comm. -Qed. - -Lemma mul_mod_idemp_r : forall a b n, n~=0 -> - (a*(b mod n)) mod n == (a*b) mod n. -Proof. - intros a b n **. rewrite !(mul_comm a). now apply mul_mod_idemp_l. -Qed. - -Theorem mul_mod: forall a b n, n~=0 -> - (a * b) mod n == ((a mod n) * (b mod n)) mod n. -Proof. - intros. now rewrite mul_mod_idemp_l, mul_mod_idemp_r. -Qed. - -Lemma add_mod_idemp_l : forall a b n, n~=0 -> - ((a mod n)+b) mod n == (a+b) mod n. -Proof. - intros a b n Hn. symmetry. - rewrite (div_mod a n) at 1 by order. - rewrite <- add_assoc, add_comm, mul_comm. - intros. now rewrite mod_add. -Qed. - -Lemma add_mod_idemp_r : forall a b n, n~=0 -> - (a+(b mod n)) mod n == (a+b) mod n. -Proof. - intros a b n **. rewrite !(add_comm a). now apply add_mod_idemp_l. -Qed. - -Theorem add_mod: forall a b n, n~=0 -> - (a+b) mod n == (a mod n + b mod n) mod n. -Proof. - intros. now rewrite add_mod_idemp_l, add_mod_idemp_r. -Qed. - -(** With the current convention, the following result isn't always - true with a negative last divisor. For instance - [ 3/(-2)/(-2) = 1 <> 0 = 3 / (-2*-2) ], or - [ 5/2/(-2) = -1 <> -2 = 5 / (2*-2) ]. *) - -Lemma div_div : forall a b c, b~=0 -> 0 - (a/b)/c == a/(b*c). -Proof. - intros a b c Hb Hc. - apply div_unique with (b*((a/b) mod c) + a mod b). - - (* begin 0<= ... 0 - a mod (b*c) == a mod b + b*((a/b) mod c). -Proof. - intros a b c Hb Hc. - apply add_cancel_l with (b*c*(a/(b*c))). - rewrite <- div_mod by (apply neq_mul_0; split; order). - rewrite <- div_div by trivial. - rewrite add_assoc, add_shuffle0, <- mul_assoc, <- mul_add_distr_l. - rewrite <- div_mod by order. - apply div_mod; order. -Qed. - -Lemma mod_div: forall a b, b~=0 -> - a mod b / b == 0. -Proof. - intros a b Hb. - rewrite div_small_iff by assumption. - auto using mod_bound_or. -Qed. - -Lemma add_mul_mod_distr_l : forall a b c d, 0<=a -> 0 0<=d - (c*a+d) mod (c*b) == c*(a mod b)+d. -Proof. intros. apply add_mul_mod_distr_l; assumption. Qed. - -Lemma add_mul_mod_distr_r: forall a b c d, 0<=a -> 0 0<=d - (a*c+d) mod (b*c) == (a mod b)*c+d. -Proof. intros. apply add_mul_mod_distr_r; assumption. Qed. - -(** A last inequality: *) - -Theorem div_mul_le: - forall a b c, 0<=a -> 0 0<=c -> c*(a/b) <= (c*a)/b. -Proof. exact div_mul_le. Qed. - -End ZDivProp. diff --git a/stdlib/theories/Numbers/Integer/Abstract/ZDivTrunc.v b/stdlib/theories/Numbers/Integer/Abstract/ZDivTrunc.v deleted file mode 100644 index 07c0998535da..000000000000 --- a/stdlib/theories/Numbers/Integer/Abstract/ZDivTrunc.v +++ /dev/null @@ -1,668 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* a rem b == a - b*(aĆ·b). -Proof. -intros. -rewrite <- add_move_l. -symmetry. now apply quot_rem. -Qed. - -(** A few sign rules (simple ones) *) - -Lemma rem_opp_opp : forall a b, b ~= 0 -> (-a) rem (-b) == - (a rem b). -Proof. intros. now rewrite rem_opp_r, rem_opp_l. Qed. - -Lemma quot_opp_l : forall a b, b ~= 0 -> (-a)Ć·b == -(aĆ·b). -Proof. -intros a b ?. -rewrite <- (mul_cancel_l _ _ b) by trivial. -rewrite <- (add_cancel_r _ _ ((-a) rem b)). -now rewrite <- quot_rem, rem_opp_l, mul_opp_r, <- opp_add_distr, <- quot_rem. -Qed. - -Lemma quot_opp_r : forall a b, b ~= 0 -> aĆ·(-b) == -(aĆ·b). -Proof. -intros a b ?. -assert (-b ~= 0) by (now rewrite eq_opp_l, opp_0). -rewrite <- (mul_cancel_l _ _ (-b)) by trivial. -rewrite <- (add_cancel_r _ _ (a rem (-b))). -now rewrite <- quot_rem, rem_opp_r, mul_opp_opp, <- quot_rem. -Qed. - -Lemma quot_opp_opp : forall a b, b ~= 0 -> (-a)Ć·(-b) == aĆ·b. -Proof. intros. now rewrite quot_opp_r, quot_opp_l, opp_involutive. Qed. - -(** Uniqueness theorems *) - -Theorem quot_rem_unique : forall b q1 q2 r1 r2 : t, - (0<=r1 (0<=r2 - b*q1+r1 == b*q2+r2 -> q1 == q2 /\ r1 == r2. -Proof. -intros b q1 q2 r1 r2 Hr1 Hr2 EQ. -destruct Hr1; destruct Hr2; try (intuition; order). -- apply NZQuot.div_mod_unique with b; trivial. -- rewrite <- (opp_inj_wd r1 r2). - apply NZQuot.div_mod_unique with (-b); trivial. - + rewrite <- opp_lt_mono, opp_nonneg_nonpos; tauto. - + rewrite <- opp_lt_mono, opp_nonneg_nonpos; tauto. - + now rewrite 2 mul_opp_l, <- 2 opp_add_distr, opp_inj_wd. -Qed. - -Theorem quot_unique: - forall a b q r, 0<=a -> 0<=r a == b*q + r -> q == aĆ·b. -Proof. intros a b q r **; now apply NZQuot.div_unique with r. Qed. - -Theorem rem_unique: - forall a b q r, 0<=a -> 0<=r a == b*q + r -> r == a rem b. -Proof. intros a b q r **; now apply NZQuot.mod_unique with q. Qed. - -(** A division by itself returns 1 *) - -Lemma quot_same : forall a, a~=0 -> aĆ·a == 1. -Proof. - intros a ?. pos_or_neg a. - - apply NZQuot.div_same; order. - - rewrite <- quot_opp_opp by trivial. now apply NZQuot.div_same. -Qed. - -Lemma rem_same : forall a, a~=0 -> a rem a == 0. -Proof. -intros. rewrite rem_eq, quot_same by trivial. nzsimpl. apply sub_diag. -Qed. - -(** A division of a small number by a bigger one yields zero. *) - -Theorem quot_small: forall a b, 0<=a aĆ·b == 0. -Proof. exact NZQuot.div_small. Qed. - -(** Same situation, in term of remulo: *) - -Theorem rem_small: forall a b, 0<=a a rem b == a. -Proof. exact NZQuot.mod_small. Qed. - -(** * Basic values of divisions and modulo. *) - -Lemma quot_0_l: forall a, a~=0 -> 0Ć·a == 0. -Proof. - intros a ?. pos_or_neg a. - - apply NZQuot.div_0_l; order. - - rewrite <- quot_opp_opp, opp_0 by trivial. now apply NZQuot.div_0_l. -Qed. - -Lemma rem_0_l: forall a, a~=0 -> 0 rem a == 0. -Proof. -intros; rewrite rem_eq, quot_0_l; now nzsimpl. -Qed. - -Lemma quot_1_r: forall a, aĆ·1 == a. -Proof. - intros a. pos_or_neg a. - - now apply NZQuot.div_1_r. - - apply opp_inj. rewrite <- quot_opp_l. - + apply NZQuot.div_1_r; order. - + intro EQ; symmetry in EQ; revert EQ; apply lt_neq, lt_0_1. -Qed. - -Lemma rem_1_r: forall a, a rem 1 == 0. -Proof. -intros. rewrite rem_eq, quot_1_r; nzsimpl; auto using sub_diag. -intro EQ; symmetry in EQ; revert EQ; apply lt_neq; apply lt_0_1. -Qed. - -Lemma quot_1_l: forall a, 1 1Ć·a == 0. -Proof. exact NZQuot.div_1_l. Qed. - -Lemma rem_1_l: forall a, 1 1 rem a == 1. -Proof. exact NZQuot.mod_1_l. Qed. - -Lemma quot_mul : forall a b, b~=0 -> (a*b)Ć·b == a. -Proof. - intros a b ?. pos_or_neg a; pos_or_neg b. - - apply NZQuot.div_mul; order. - - rewrite <- quot_opp_opp, <- mul_opp_r by order. apply NZQuot.div_mul; order. - - rewrite <- opp_inj_wd, <- quot_opp_l, <- mul_opp_l by order. - apply NZQuot.div_mul; order. - - rewrite <- opp_inj_wd, <- quot_opp_r, <- mul_opp_opp by order. - apply NZQuot.div_mul; order. -Qed. - -Lemma rem_mul : forall a b, b~=0 -> (a*b) rem b == 0. -Proof. -intros. rewrite rem_eq, quot_mul by trivial. rewrite mul_comm; apply sub_diag. -Qed. - -Theorem quot_unique_exact a b q: b~=0 -> a == b*q -> q == aĆ·b. -Proof. - intros Hb H. rewrite H, mul_comm. symmetry. now apply quot_mul. -Qed. - -(** The sign of [a rem b] is the one of [a] (when it's not null) *) - -Lemma rem_nonneg : forall a b, b~=0 -> 0 <= a -> 0 <= a rem b. -Proof. - intros a b **. pos_or_neg b. - - destruct (rem_bound_pos a b); order. - - rewrite <- rem_opp_r; trivial. - destruct (rem_bound_pos a (-b)); trivial. -Qed. - -Lemma rem_nonpos : forall a b, b~=0 -> a <= 0 -> a rem b <= 0. -Proof. - intros a b Hb Ha. - apply opp_nonneg_nonpos. apply opp_nonneg_nonpos in Ha. - rewrite <- rem_opp_l by trivial. now apply rem_nonneg. -Qed. - -Lemma rem_sign_mul : forall a b, b~=0 -> 0 <= (a rem b) * a. -Proof. -intros a b Hb. destruct (le_ge_cases 0 a). - - apply mul_nonneg_nonneg; trivial. now apply rem_nonneg. - - apply mul_nonpos_nonpos; trivial. now apply rem_nonpos. -Qed. - -Lemma rem_sign_nz : forall a b, b~=0 -> a rem b ~= 0 -> - sgn (a rem b) == sgn a. -Proof. -intros a b Hb H. destruct (lt_trichotomy 0 a) as [LT|[EQ|LT]]. -- rewrite 2 sgn_pos; try easy. - generalize (rem_nonneg a b Hb (lt_le_incl _ _ LT)). order. -- now rewrite <- EQ, rem_0_l, sgn_0. -- rewrite 2 sgn_neg; try easy. - generalize (rem_nonpos a b Hb (lt_le_incl _ _ LT)). order. -Qed. - -Lemma rem_sign : forall a b, a~=0 -> b~=0 -> sgn (a rem b) ~= -sgn a. -Proof. -intros a b Ha Hb H. -destruct (eq_decidable (a rem b) 0) as [EQ|NEQ]. -- apply Ha, sgn_null_iff, opp_inj. now rewrite <- H, opp_0, EQ, sgn_0. -- apply Ha, sgn_null_iff. apply eq_mul_0_l with 2; try order'. nzsimpl'. - apply add_move_0_l. rewrite <- H. symmetry. now apply rem_sign_nz. -Qed. - -(** Operations and absolute value *) - -Lemma rem_abs_l : forall a b, b ~= 0 -> (abs a) rem b == abs (a rem b). -Proof. -intros a b Hb. destruct (le_ge_cases 0 a) as [LE|LE]. -- rewrite 2 abs_eq; try easy. now apply rem_nonneg. -- rewrite 2 abs_neq, rem_opp_l; try easy. now apply rem_nonpos. -Qed. - -Lemma rem_abs_r : forall a b, b ~= 0 -> a rem (abs b) == a rem b. -Proof. -intros a b Hb. destruct (le_ge_cases 0 b). -- now rewrite abs_eq. -- now rewrite abs_neq, ?rem_opp_r. -Qed. - -Lemma rem_abs : forall a b, b ~= 0 -> (abs a) rem (abs b) == abs (a rem b). -Proof. -intros. now rewrite rem_abs_r, rem_abs_l. -Qed. - -Lemma quot_abs_l : forall a b, b ~= 0 -> (abs a)Ć·b == (sgn a)*(aĆ·b). -Proof. -intros a b Hb. destruct (lt_trichotomy 0 a) as [LT|[EQ|LT]]. -- rewrite abs_eq, sgn_pos by order. now nzsimpl. -- rewrite <- EQ, abs_0, quot_0_l; trivial. now nzsimpl. -- rewrite abs_neq, quot_opp_l, sgn_neg by order. - rewrite mul_opp_l. now nzsimpl. -Qed. - -Lemma quot_abs_r : forall a b, b ~= 0 -> aĆ·(abs b) == (sgn b)*(aĆ·b). -Proof. -intros a b Hb. destruct (lt_trichotomy 0 b) as [LT|[EQ|LT]]. -- rewrite abs_eq, sgn_pos by order. now nzsimpl. -- order. -- rewrite abs_neq, quot_opp_r, sgn_neg by order. - rewrite mul_opp_l. now nzsimpl. -Qed. - -Lemma quot_abs : forall a b, b ~= 0 -> (abs a)Ć·(abs b) == abs (aĆ·b). -Proof. -intros a b Hb. -pos_or_neg a; [rewrite (abs_eq a)|rewrite (abs_neq a)]; - try apply opp_nonneg_nonpos; try order. -- pos_or_neg b; [rewrite (abs_eq b)|rewrite (abs_neq b)]; - try apply opp_nonneg_nonpos; try order. - + rewrite abs_eq; try easy. apply NZQuot.div_pos; order. - + rewrite <- abs_opp, <- quot_opp_r, abs_eq; try easy. - apply NZQuot.div_pos; order. -- pos_or_neg b; [rewrite (abs_eq b)|rewrite (abs_neq b)]; - try apply opp_nonneg_nonpos; try order. - + rewrite <- (abs_opp (_Ć·_)), <- quot_opp_l, abs_eq; try easy. - apply NZQuot.div_pos; order. - + rewrite <- (quot_opp_opp a b), abs_eq; try easy. - apply NZQuot.div_pos; order. -Qed. - -(** We have a general bound for absolute values *) - -Lemma rem_bound_abs : - forall a b, b~=0 -> abs (a rem b) < abs b. -Proof. -intros. rewrite <- rem_abs; trivial. -apply rem_bound_pos. -- apply abs_nonneg. -- now apply abs_pos. -Qed. - -(** * Order results about rem and quot *) - -(** A modulo cannot grow beyond its starting point. *) - -Theorem rem_le: forall a b, 0<=a -> 0 a rem b <= a. -Proof. exact NZQuot.mod_le. Qed. - -Theorem quot_pos : forall a b, 0<=a -> 0 0<= aĆ·b. -Proof. exact NZQuot.div_pos. Qed. - -Lemma quot_str_pos : forall a b, 0 0 < aĆ·b. -Proof. exact NZQuot.div_str_pos. Qed. - -Lemma quot_small_iff : forall a b, b~=0 -> (aĆ·b==0 <-> abs a < abs b). -Proof. -intros a b ?. pos_or_neg a; pos_or_neg b. -- rewrite NZQuot.div_small_iff; try order. rewrite 2 abs_eq; intuition; order. -- rewrite <- opp_inj_wd, opp_0, <- quot_opp_r, NZQuot.div_small_iff by order. - rewrite (abs_eq a), (abs_neq' b); intuition; order. -- rewrite <- opp_inj_wd, opp_0, <- quot_opp_l, NZQuot.div_small_iff by order. - rewrite (abs_neq' a), (abs_eq b); intuition; order. -- rewrite <- quot_opp_opp, NZQuot.div_small_iff by order. - rewrite (abs_neq' a), (abs_neq' b); intuition; order. -Qed. - -Lemma rem_small_iff : forall a b, b~=0 -> (a rem b == a <-> abs a < abs b). -Proof. -intros a b ?. rewrite rem_eq, <- quot_small_iff by order. -rewrite sub_move_r, <- (add_0_r a) at 1. rewrite add_cancel_l. -rewrite eq_sym_iff, eq_mul_0. tauto. -Qed. - -(** As soon as the divisor is strictly greater than 1, - the division is strictly decreasing. *) - -Lemma quot_lt : forall a b, 0 1 aĆ·b < a. -Proof. exact NZQuot.div_lt. Qed. - -(** [le] is compatible with a positive division. *) - -Lemma quot_le_mono : forall a b c, 0 a<=b -> aĆ·c <= bĆ·c. -Proof. - intros a b c **. pos_or_neg a. - - apply NZQuot.div_le_mono; auto. - - pos_or_neg b. - + apply le_trans with 0. - * rewrite <- opp_nonneg_nonpos, <- quot_opp_l by order. - apply quot_pos; order. - * apply quot_pos; order. - + rewrite opp_le_mono in *. rewrite <- 2 quot_opp_l by order. - apply NZQuot.div_le_mono; intuition; order. -Qed. - -(** With this choice of division, - rounding of quot is always done toward zero: *) - -Lemma mul_quot_le : forall a b, 0<=a -> b~=0 -> 0 <= b*(aĆ·b) <= a. -Proof. -intros a b **. pos_or_neg b. -- split. - + apply mul_nonneg_nonneg; [|apply quot_pos]; order. - + apply NZQuot.mul_div_le; order. -- rewrite <- mul_opp_opp, <- quot_opp_r by order. - split. - + apply mul_nonneg_nonneg; [|apply quot_pos]; order. - + apply NZQuot.mul_div_le; order. -Qed. - -Lemma mul_quot_ge : forall a b, a<=0 -> b~=0 -> a <= b*(aĆ·b) <= 0. -Proof. -intros a b **. -rewrite <- opp_nonneg_nonpos, opp_le_mono, <-mul_opp_r, <-quot_opp_l by order. -rewrite <- opp_nonneg_nonpos in *. -destruct (mul_quot_le (-a) b); tauto. -Qed. - -(** For positive numbers, considering [S (aĆ·b)] leads to an upper bound for [a] *) - -Lemma mul_succ_quot_gt: forall a b, 0<=a -> 0 a < b*(S (aĆ·b)). -Proof. exact NZQuot.mul_succ_div_gt. Qed. - -(** Similar results with negative numbers *) - -Lemma mul_pred_quot_lt: forall a b, a<=0 -> 0 b*(P (aĆ·b)) < a. -Proof. -intros. -rewrite opp_lt_mono, <- mul_opp_r, opp_pred, <- quot_opp_l by order. -rewrite <- opp_nonneg_nonpos in *. -now apply mul_succ_quot_gt. -Qed. - -Lemma mul_pred_quot_gt: forall a b, 0<=a -> b<0 -> a < b*(P (aĆ·b)). -Proof. -intros. -rewrite <- mul_opp_opp, opp_pred, <- quot_opp_r by order. -rewrite <- opp_pos_neg in *. -now apply mul_succ_quot_gt. -Qed. - -Lemma mul_succ_quot_lt: forall a b, a<=0 -> b<0 -> b*(S (aĆ·b)) < a. -Proof. -intros. -rewrite opp_lt_mono, <- mul_opp_l, <- quot_opp_opp by order. -rewrite <- opp_nonneg_nonpos, <- opp_pos_neg in *. -now apply mul_succ_quot_gt. -Qed. - -(** Inequality [mul_quot_le] is exact iff the modulo is zero. *) - -Lemma quot_exact : forall a b, b~=0 -> (a == b*(aĆ·b) <-> a rem b == 0). -Proof. -intros. rewrite rem_eq by order. rewrite sub_move_r; nzsimpl; tauto. -Qed. - -(** Some additional inequalities about quot. *) - -Theorem quot_lt_upper_bound: - forall a b q, 0<=a -> 0 a < b*q -> aĆ·b < q. -Proof. exact NZQuot.div_lt_upper_bound. Qed. - -Theorem quot_le_upper_bound: - forall a b q, 0 a <= b*q -> aĆ·b <= q. -Proof. -intros a b q **. -rewrite <- (quot_mul q b) by order. -apply quot_le_mono; trivial. now rewrite mul_comm. -Qed. - -Theorem quot_le_lower_bound: - forall a b q, 0 b*q <= a -> q <= aĆ·b. -Proof. -intros a b q **. -rewrite <- (quot_mul q b) by order. -apply quot_le_mono; trivial. now rewrite mul_comm. -Qed. - -(** A division respects opposite monotonicity for the divisor *) - -Lemma quot_le_compat_l: forall p q r, 0<=p -> 0 pĆ·r <= pĆ·q. -Proof. exact NZQuot.div_le_compat_l. Qed. - -(** * Relations between usual operations and rem and quot *) - -(** Unlike with other division conventions, some results here aren't - always valid, and need to be restricted. For instance - [(a+b*c) rem c <> a rem c] for [a=9,b=-5,c=2] *) - -Lemma rem_add : forall a b c, c~=0 -> 0 <= (a+b*c)*a -> - (a + b * c) rem c == a rem c. -Proof. -assert (forall a b c, c~=0 -> 0<=a -> 0<=a+b*c -> (a+b*c) rem c == a rem c). { - intros a b c **. pos_or_neg c. - - apply NZQuot.mod_add; order. - - rewrite <- (rem_opp_r a), <- (rem_opp_r (a+b*c)) by order. - rewrite <- mul_opp_opp in *. - apply NZQuot.mod_add; order. -} -intros a b c Hc Habc. -destruct (le_0_mul _ _ Habc) as [(Habc',Ha)|(Habc',Ha)]. { auto. } -apply opp_inj. revert Ha Habc'. -rewrite <- 2 opp_nonneg_nonpos. -rewrite <- 2 rem_opp_l, opp_add_distr, <- mul_opp_l by order. auto. -Qed. - -Lemma quot_add : forall a b c, c~=0 -> 0 <= (a+b*c)*a -> - (a + b * c) Ć· c == a Ć· c + b. -Proof. -intros a b c **. -rewrite <- (mul_cancel_l _ _ c) by trivial. -rewrite <- (add_cancel_r _ _ ((a+b*c) rem c)). -rewrite <- quot_rem, rem_add by trivial. -now rewrite mul_add_distr_l, add_shuffle0, <-quot_rem, mul_comm. -Qed. - -Lemma quot_add_l: forall a b c, b~=0 -> 0 <= (a*b+c)*c -> - (a * b + c) Ć· b == a + c Ć· b. -Proof. - intros a b c. rewrite add_comm, (add_comm a). now apply quot_add. -Qed. - -(** Cancellations. *) - -Lemma quot_mul_cancel_r : forall a b c, b~=0 -> c~=0 -> - (a*c)Ć·(b*c) == aĆ·b. -Proof. -assert (Aux1 : forall a b c, 0<=a -> 0 c~=0 -> (a*c)Ć·(b*c) == aĆ·b). { - intros a b c **. pos_or_neg c. - - apply NZQuot.div_mul_cancel_r; order. - - rewrite <- quot_opp_opp, <- 2 mul_opp_r. - + apply NZQuot.div_mul_cancel_r; order. - + rewrite <- neq_mul_0; intuition order. -} -assert (Aux2 : forall a b c, 0<=a -> b~=0 -> c~=0 -> (a*c)Ć·(b*c) == aĆ·b). { - intros a b c **. pos_or_neg b. - - apply Aux1; order. - - apply opp_inj. rewrite <- 2 quot_opp_r, <- mul_opp_l; try order. - + apply Aux1; order. - + rewrite <- neq_mul_0; intuition order. -} -intros a b c **. pos_or_neg a. { apply Aux2; order. } -apply opp_inj. rewrite <- 2 quot_opp_l, <- mul_opp_l; try order. { apply Aux2; order. } -rewrite <- neq_mul_0; intuition order. -Qed. - -Lemma quot_mul_cancel_l : forall a b c, b~=0 -> c~=0 -> - (c*a)Ć·(c*b) == aĆ·b. -Proof. -intros a b c **. rewrite !(mul_comm c); now apply quot_mul_cancel_r. -Qed. - -Lemma mul_rem_distr_r: forall a b c, b~=0 -> c~=0 -> - (a*c) rem (b*c) == (a rem b) * c. -Proof. -intros a b c **. -assert (b*c ~= 0) by (rewrite <- neq_mul_0; tauto). -rewrite ! rem_eq by trivial. -rewrite quot_mul_cancel_r by order. -now rewrite mul_sub_distr_r, <- !mul_assoc, (mul_comm (aĆ·b) c). -Qed. - -Lemma mul_rem_distr_l: forall a b c, b~=0 -> c~=0 -> - (c*a) rem (c*b) == c * (a rem b). -Proof. -intros a b c **; rewrite !(mul_comm c); now apply mul_rem_distr_r. -Qed. - -(** Operations modulo. *) - -Theorem rem_rem: forall a n, n~=0 -> - (a rem n) rem n == a rem n. -Proof. - intros a n **. pos_or_neg a; pos_or_neg n. - - apply NZQuot.mod_mod; order. - - rewrite <- ! (rem_opp_r _ n) by trivial. apply NZQuot.mod_mod; order. - - apply opp_inj. rewrite <- !rem_opp_l by order. apply NZQuot.mod_mod; order. - - apply opp_inj. rewrite <- !rem_opp_opp by order. apply NZQuot.mod_mod; order. -Qed. - -Lemma mul_rem_idemp_l : forall a b n, n~=0 -> - ((a rem n)*b) rem n == (a*b) rem n. -Proof. -assert (Aux1 : forall a b n, 0<=a -> 0<=b -> n~=0 -> - ((a rem n)*b) rem n == (a*b) rem n). { - intros a b n **. pos_or_neg n. - - apply NZQuot.mul_mod_idemp_l; order. - - rewrite <- ! (rem_opp_r _ n) by order. apply NZQuot.mul_mod_idemp_l; order. -} -assert (Aux2 : forall a b n, 0<=a -> n~=0 -> - ((a rem n)*b) rem n == (a*b) rem n). { - intros a b n **. pos_or_neg b. - - now apply Aux1. - - apply opp_inj. rewrite <-2 rem_opp_l, <-2 mul_opp_r by order. - apply Aux1; order. -} -intros a b n Hn. pos_or_neg a. { now apply Aux2. } -apply opp_inj. rewrite <-2 rem_opp_l, <-2 mul_opp_l, <-rem_opp_l by order. -apply Aux2; order. -Qed. - -Lemma mul_rem_idemp_r : forall a b n, n~=0 -> - (a*(b rem n)) rem n == (a*b) rem n. -Proof. -intros a b n **. rewrite !(mul_comm a). now apply mul_rem_idemp_l. -Qed. - -Theorem mul_rem: forall a b n, n~=0 -> - (a * b) rem n == ((a rem n) * (b rem n)) rem n. -Proof. -intros. now rewrite mul_rem_idemp_l, mul_rem_idemp_r. -Qed. - -(** addition and modulo - - Generally speaking, unlike with other conventions, we don't have - [(a+b) rem n = (a rem n + b rem n) rem n] - for any a and b. - For instance, take (8 + (-10)) rem 3 = -2 whereas - (8 rem 3 + (-10 rem 3)) rem 3 = 1. -*) - -Lemma add_rem_idemp_l : forall a b n, n~=0 -> 0 <= a*b -> - ((a rem n)+b) rem n == (a+b) rem n. -Proof. -assert (Aux : forall a b n, 0<=a -> 0<=b -> n~=0 -> - ((a rem n)+b) rem n == (a+b) rem n). { - intros a b n **. pos_or_neg n. { apply NZQuot.add_mod_idemp_l; order. } - rewrite <- ! (rem_opp_r _ n) by order. apply NZQuot.add_mod_idemp_l; order. -} -intros a b n Hn Hab. destruct (le_0_mul _ _ Hab) as [(Ha,Hb)|(Ha,Hb)]. -{ now apply Aux. } -apply opp_inj. rewrite <-2 rem_opp_l, 2 opp_add_distr, <-rem_opp_l by order. -rewrite <- opp_nonneg_nonpos in *. -now apply Aux. -Qed. - -Lemma add_rem_idemp_r : forall a b n, n~=0 -> 0 <= a*b -> - (a+(b rem n)) rem n == (a+b) rem n. -Proof. -intros a b n **. rewrite !(add_comm a). apply add_rem_idemp_l; trivial. -now rewrite mul_comm. -Qed. - -Theorem add_rem: forall a b n, n~=0 -> 0 <= a*b -> - (a+b) rem n == (a rem n + b rem n) rem n. -Proof. -intros a b n Hn Hab. rewrite add_rem_idemp_l, add_rem_idemp_r; trivial. -- reflexivity. -- destruct (le_0_mul _ _ Hab) as [(Ha,Hb)|(Ha,Hb)]; - destruct (le_0_mul _ _ (rem_sign_mul b n Hn)) as [(Hb',Hm)|(Hb',Hm)]; - auto using mul_nonneg_nonneg, mul_nonpos_nonpos. - + setoid_replace b with 0 by order. rewrite rem_0_l by order. nzsimpl; order. - + setoid_replace b with 0 by order. rewrite rem_0_l by order. nzsimpl; order. -Qed. - -(** Conversely, the following results need less restrictions here. *) - -Lemma quot_quot : forall a b c, b~=0 -> c~=0 -> - (aĆ·b)Ć·c == aĆ·(b*c). -Proof. -assert (Aux1 : forall a b c, 0<=a -> 0 c~=0 -> (aĆ·b)Ć·c == aĆ·(b*c)). { - intros a b c **. pos_or_neg c. { apply NZQuot.div_div; order. } - apply opp_inj. rewrite <- 2 quot_opp_r, <- mul_opp_r; trivial. - { apply NZQuot.div_div; order. } - rewrite <- neq_mul_0; intuition order. -} -assert (Aux2 : forall a b c, 0<=a -> b~=0 -> c~=0 -> (aĆ·b)Ć·c == aĆ·(b*c)). { - intros a b c **. pos_or_neg b. { apply Aux1; order. } - apply opp_inj. rewrite <- quot_opp_l, <- 2 quot_opp_r, <- mul_opp_l; trivial. - { apply Aux1; trivial. } - rewrite <- neq_mul_0; intuition order. -} -intros a b c **. pos_or_neg a. { apply Aux2; order. } -apply opp_inj. rewrite <- 3 quot_opp_l; try order. { apply Aux2; order. } -rewrite <- neq_mul_0. tauto. -Qed. - -Lemma mod_mul_r : forall a b c, b~=0 -> c~=0 -> - a rem (b*c) == a rem b + b*((aĆ·b) rem c). -Proof. - intros a b c Hb Hc. - apply add_cancel_l with (b*c*(aĆ·(b*c))). - rewrite <- quot_rem by (apply neq_mul_0; split; order). - rewrite <- quot_quot by trivial. - rewrite add_assoc, add_shuffle0, <- mul_assoc, <- mul_add_distr_l. - rewrite <- quot_rem by order. - apply quot_rem; order. -Qed. - -Lemma rem_quot: forall a b, b~=0 -> - a rem b Ć· b == 0. -Proof. - intros a b Hb. - rewrite quot_small_iff by assumption. - auto using rem_bound_abs. -Qed. - -(** A last inequality: *) - -Theorem quot_mul_le: - forall a b c, 0<=a -> 0 0<=c -> c*(aĆ·b) <= (c*a)Ć·b. -Proof. exact NZQuot.div_mul_le. Qed. - -End ZQuotProp. diff --git a/stdlib/theories/Numbers/Integer/Abstract/ZGcd.v b/stdlib/theories/Numbers/Integer/Abstract/ZGcd.v deleted file mode 100644 index 8b6b7d81b7bf..000000000000 --- a/stdlib/theories/Numbers/Integer/Abstract/ZGcd.v +++ /dev/null @@ -1,287 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* (n | m). -Proof. - intros n m. split; intros (p,Hp); exists (-p); rewrite Hp. - - now rewrite mul_opp_l, mul_opp_r. - - now rewrite mul_opp_opp. -Qed. - -Lemma divide_opp_r : forall n m, (n | -m) <-> (n | m). -Proof. - intros n m. split; intros (p,Hp); exists (-p). - - now rewrite mul_opp_l, <- Hp, opp_involutive. - - now rewrite Hp, mul_opp_l. -Qed. - -Lemma divide_abs_l : forall n m, (abs n | m) <-> (n | m). -Proof. - intros n m. destruct (abs_eq_or_opp n) as [H|H]; rewrite H. - - easy. - - apply divide_opp_l. -Qed. - -Lemma divide_abs_r : forall n m, (n | abs m) <-> (n | m). -Proof. - intros n m. destruct (abs_eq_or_opp m) as [H|H]; rewrite H. - - easy. - - apply divide_opp_r. -Qed. - -Lemma divide_1_r_abs : forall n, (n | 1) -> abs n == 1. -Proof. - intros n Hn. apply divide_1_r_nonneg. - - apply abs_nonneg. - - now apply divide_abs_l. -Qed. - -Lemma divide_1_r : forall n, (n | 1) -> n==1 \/ n==-1. -Proof. - intros n (m,H). rewrite mul_comm in H. now apply eq_mul_1 with m. -Qed. - -Lemma divide_antisym_abs : forall n m, - (n | m) -> (m | n) -> abs n == abs m. -Proof. - intros. apply divide_antisym_nonneg; try apply abs_nonneg. - - now apply divide_abs_l, divide_abs_r. - - now apply divide_abs_l, divide_abs_r. -Qed. - -Lemma divide_antisym : forall n m, - (n | m) -> (m | n) -> n == m \/ n == -m. -Proof. - intros. now apply abs_eq_cases, divide_antisym_abs. -Qed. - -Lemma divide_sub_r : forall n m p, (n | m) -> (n | p) -> (n | m - p). -Proof. - intros n m p H H'. rewrite <- add_opp_r. - apply divide_add_r; trivial. now apply divide_opp_r. -Qed. - -Lemma divide_add_cancel_r : forall n m p, (n | m) -> (n | m + p) -> (n | p). -Proof. - intros n m p H H'. rewrite <- (add_simpl_l m p). now apply divide_sub_r. -Qed. - -(** Properties of gcd *) - -Lemma gcd_opp_l : forall n m, gcd (-n) m == gcd n m. -Proof. - intros. apply gcd_unique_alt; try apply gcd_nonneg. - intros. rewrite divide_opp_r. apply gcd_divide_iff. -Qed. - -Lemma gcd_opp_r : forall n m, gcd n (-m) == gcd n m. -Proof. - intros. now rewrite gcd_comm, gcd_opp_l, gcd_comm. -Qed. - -Lemma gcd_abs_l : forall n m, gcd (abs n) m == gcd n m. -Proof. - intros n m. destruct (abs_eq_or_opp n) as [H|H]; rewrite H. - - easy. - - apply gcd_opp_l. -Qed. - -Lemma gcd_abs_r : forall n m, gcd n (abs m) == gcd n m. -Proof. - intros. now rewrite gcd_comm, gcd_abs_l, gcd_comm. -Qed. - -Lemma gcd_0_l : forall n, gcd 0 n == abs n. -Proof. - intros. rewrite <- gcd_abs_r. apply gcd_0_l_nonneg, abs_nonneg. -Qed. - -Lemma gcd_0_r : forall n, gcd n 0 == abs n. -Proof. - intros. now rewrite gcd_comm, gcd_0_l. -Qed. - -Lemma gcd_diag : forall n, gcd n n == abs n. -Proof. - intros. rewrite <- gcd_abs_l, <- gcd_abs_r. - apply gcd_diag_nonneg, abs_nonneg. -Qed. - -Lemma gcd_add_mult_diag_r : forall n m p, gcd n (m+p*n) == gcd n m. -Proof. - intros n m p. apply gcd_unique_alt; try apply gcd_nonneg. - intros. rewrite gcd_divide_iff. split; intros (U,V); split; trivial. - - apply divide_add_r; trivial. now apply divide_mul_r. - - apply divide_add_cancel_r with (p*n); trivial. - + now apply divide_mul_r. - + now rewrite add_comm. -Qed. - -Lemma gcd_add_diag_r : forall n m, gcd n (m+n) == gcd n m. -Proof. - intros n m. rewrite <- (mul_1_l n) at 2. apply gcd_add_mult_diag_r. -Qed. - -Lemma gcd_sub_diag_r : forall n m, gcd n (m-n) == gcd n m. -Proof. - intros n m. rewrite <- (mul_1_l n) at 2. - rewrite <- add_opp_r, <- mul_opp_l. apply gcd_add_mult_diag_r. -Qed. - -Definition Bezout n m p := exists a b, a*n + b*m == p. - -#[global] -Instance Bezout_wd : Proper (eq==>eq==>eq==>iff) Bezout. -Proof. - unfold Bezout. intros x x' Hx y y' Hy z z' Hz. - setoid_rewrite Hx. setoid_rewrite Hy. now setoid_rewrite Hz. -Qed. - -Lemma bezout_1_gcd : forall n m, Bezout n m 1 -> gcd n m == 1. -Proof. - intros n m (q & r & H). - apply gcd_unique; trivial using divide_1_l, le_0_1. - intros p Hn Hm. - rewrite <- H. apply divide_add_r; now apply divide_mul_r. -Qed. - -Lemma gcd_bezout : forall n m p, gcd n m == p -> Bezout n m p. -Proof. - (* First, a version restricted to natural numbers *) - assert (aux : forall n, 0<=n -> forall m, 0<=m -> Bezout n m (gcd n m)). { - intros n Hn; pattern n. - apply (fun H => strong_right_induction H 0); trivial. - clear n Hn. intros n Hn IHn. - apply le_lteq in Hn; destruct Hn as [Hn|Hn]. - - intros m Hm; pattern m. - apply (fun H => strong_right_induction H 0); trivial. - clear m Hm. intros m Hm IHm. - destruct (lt_trichotomy n m) as [LT|[EQ|LT]]. - + (* n < m *) - destruct (IHm (m-n)) as (a & b & EQ). - * apply sub_nonneg; order. - * now apply lt_sub_pos. - * exists (a-b). exists b. - rewrite gcd_sub_diag_r in EQ. rewrite <- EQ. - rewrite mul_sub_distr_r, mul_sub_distr_l. - now rewrite add_sub_assoc, add_sub_swap. - + (* n = m *) - rewrite EQ. rewrite gcd_diag_nonneg; trivial. - exists 1. exists 0. now nzsimpl. - + (* m < n *) - destruct (IHn m Hm LT n) as (a & b & EQ). { order. } - exists b. exists a. now rewrite gcd_comm, <- EQ, add_comm. - - (* n = 0 *) - intros m Hm. rewrite <- Hn, gcd_0_l_nonneg; trivial. - exists 0. exists 1. now nzsimpl. - } - (* Then we relax the positivity condition on n *) - assert (aux' : forall n m, 0<=m -> Bezout n m (gcd n m)). { - intros n m Hm. - destruct (le_ge_cases 0 n). - - now apply aux. - - assert (Hn' : 0 <= -n) by now apply opp_nonneg_nonpos. - destruct (aux (-n) Hn' m Hm) as (a & b & EQ). - exists (-a). exists b. now rewrite <- gcd_opp_l, <- EQ, mul_opp_r, mul_opp_l. - } - (* And finally we do the same for m *) - intros n m p Hp. rewrite <- Hp; clear Hp. - destruct (le_ge_cases 0 m). - - now apply aux'. - - assert (Hm' : 0 <= -m) by now apply opp_nonneg_nonpos. - destruct (aux' n (-m) Hm') as (a & b & EQ). - exists a. exists (-b). now rewrite <- gcd_opp_r, <- EQ, mul_opp_r, mul_opp_l. -Qed. - -Lemma gcd_mul_mono_l : - forall n m p, gcd (p * n) (p * m) == abs p * gcd n m. -Proof. - intros n m p. - apply gcd_unique. - - apply mul_nonneg_nonneg; trivial using gcd_nonneg, abs_nonneg. - - destruct (gcd_divide_l n m) as (q,Hq). - rewrite Hq at 2. rewrite mul_assoc. apply mul_divide_mono_r. - rewrite <- (abs_sgn p) at 2. rewrite <- mul_assoc. apply divide_factor_l. - - destruct (gcd_divide_r n m) as (q,Hq). - rewrite Hq at 2. rewrite mul_assoc. apply mul_divide_mono_r. - rewrite <- (abs_sgn p) at 2. rewrite <- mul_assoc. apply divide_factor_l. - - intros q H H'. - destruct (gcd_bezout n m (gcd n m) (eq_refl _)) as (a & b & EQ). - rewrite <- EQ, <- sgn_abs, mul_add_distr_l. apply divide_add_r. - + rewrite mul_shuffle2. now apply divide_mul_l. - + rewrite mul_shuffle2. now apply divide_mul_l. -Qed. - -Lemma gcd_mul_mono_l_nonneg : - forall n m p, 0<=p -> gcd (p*n) (p*m) == p * gcd n m. -Proof. - intros n m p ?. rewrite <- (abs_eq p) at 3; trivial. apply gcd_mul_mono_l. -Qed. - -Lemma gcd_mul_mono_r : - forall n m p, gcd (n * p) (m * p) == gcd n m * abs p. -Proof. - intros n m p. now rewrite !(mul_comm _ p), gcd_mul_mono_l, mul_comm. -Qed. - -Lemma gcd_mul_mono_r_nonneg : - forall n m p, 0<=p -> gcd (n*p) (m*p) == gcd n m * p. -Proof. - intros n m p ?. rewrite <- (abs_eq p) at 3; trivial. apply gcd_mul_mono_r. -Qed. - -Lemma gauss : forall n m p, (n | m * p) -> gcd n m == 1 -> (n | p). -Proof. - intros n m p H G. - destruct (gcd_bezout n m 1 G) as (a & b & EQ). - rewrite <- (mul_1_l p), <- EQ, mul_add_distr_r. - apply divide_add_r. - - rewrite mul_shuffle0. apply divide_factor_r. - - rewrite <- mul_assoc. now apply divide_mul_r. -Qed. - -Lemma divide_mul_split : forall n m p, n ~= 0 -> (n | m * p) -> - exists q r, n == q*r /\ (q | m) /\ (r | p). -Proof. - intros n m p Hn H. - assert (G := gcd_nonneg n m). - apply le_lteq in G; destruct G as [G|G]. - - destruct (gcd_divide_l n m) as (q,Hq). - exists (gcd n m). exists q. - split. - + now rewrite mul_comm. - + split. - * apply gcd_divide_r. - * destruct (gcd_divide_r n m) as (r,Hr). - rewrite Hr in H. rewrite Hq in H at 1. - rewrite mul_shuffle0 in H. apply mul_divide_cancel_r in H; [|order]. - apply gauss with r; trivial. - apply mul_cancel_r with (gcd n m); [order|]. - rewrite mul_1_l. - rewrite <- gcd_mul_mono_r_nonneg, <- Hq, <- Hr; order. - - symmetry in G. apply gcd_eq_0 in G. destruct G as (Hn',_); order. -Qed. - -(** TODO : more about rel_prime (i.e. gcd == 1), about prime ... *) - -End ZGcdProp. diff --git a/stdlib/theories/Numbers/Integer/Abstract/ZLcm.v b/stdlib/theories/Numbers/Integer/Abstract/ZLcm.v deleted file mode 100644 index af2d4deb806d..000000000000 --- a/stdlib/theories/Numbers/Integer/Abstract/ZLcm.v +++ /dev/null @@ -1,488 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* 0 aĆ·b == a/b. -Proof. - intros a b **. apply div_unique_pos with (a rem b). - - now apply rem_bound_pos. - - apply quot_rem. order. -Qed. - -Lemma rem_mod_nonneg : forall a b, 0<=a -> 0 a rem b == a mod b. -Proof. - intros a b **. apply mod_unique_pos with (aĆ·b). - - now apply rem_bound_pos. - - apply quot_rem. order. -Qed. - -(** We can use the sign rule to have an relation between divisions. *) - -Lemma quot_div : forall a b, b~=0 -> - aĆ·b == (sgn a)*(sgn b)*(abs a / abs b). -Proof. - assert (AUX : forall a b, 0 aĆ·b == (sgn a)*(sgn b)*(abs a / abs b)). { - intros a b Hb. rewrite (sgn_pos b), (abs_eq b), mul_1_r by order. - destruct (lt_trichotomy 0 a) as [Ha|[Ha|Ha]]. - - rewrite sgn_pos, abs_eq, mul_1_l, quot_div_nonneg; order. - - rewrite <- Ha, abs_0, sgn_0, quot_0_l, div_0_l, mul_0_l; order. - - rewrite sgn_neg, abs_neq, mul_opp_l, mul_1_l, eq_opp_r, <-quot_opp_l - by order. - apply quot_div_nonneg; trivial. apply opp_nonneg_nonpos; order. - } - (* main *) - intros a b Hb. - apply neg_pos_cases in Hb. destruct Hb as [Hb|Hb]; [|now apply AUX]. - rewrite <- (opp_involutive b) at 1. rewrite quot_opp_r. - - rewrite AUX, abs_opp, sgn_opp, mul_opp_r, mul_opp_l, opp_involutive. - + reflexivity. - + now apply opp_pos_neg. - - rewrite eq_opp_l, opp_0; order. -Qed. - -Lemma rem_mod : forall a b, b~=0 -> - a rem b == (sgn a) * ((abs a) mod (abs b)). -Proof. - intros a b Hb. - rewrite <- rem_abs_r by trivial. - assert (Hb' := proj2 (abs_pos b) Hb). - destruct (lt_trichotomy 0 a) as [Ha|[Ha|Ha]]. - - rewrite (abs_eq a), sgn_pos, mul_1_l, rem_mod_nonneg; order. - - rewrite <- Ha, abs_0, sgn_0, mod_0_l, rem_0_l, mul_0_l; order. - - rewrite sgn_neg, (abs_neq a), mul_opp_l, mul_1_l, eq_opp_r, <-rem_opp_l - by order. - apply rem_mod_nonneg; trivial. apply opp_nonneg_nonpos; order. -Qed. - -(** Modulo and remainder are null at the same place, - and this correspond to the divisibility relation. *) - -Lemma mod_divide : forall a b, b~=0 -> (a mod b == 0 <-> (b|a)). -Proof. - intros a b Hb. split. - - intros Hab. exists (a/b). rewrite mul_comm. - rewrite (div_mod a b Hb) at 1. rewrite Hab; now nzsimpl. - - intros (c,Hc). rewrite Hc. now apply mod_mul. -Qed. - -Lemma rem_divide : forall a b, b~=0 -> (a rem b == 0 <-> (b|a)). -Proof. - intros a b Hb. split. - - intros Hab. exists (aĆ·b). rewrite mul_comm. - rewrite (quot_rem a b Hb) at 1. rewrite Hab; now nzsimpl. - - intros (c,Hc). rewrite Hc. now apply rem_mul. -Qed. - -Lemma rem_mod_eq_0 : forall a b, b~=0 -> (a rem b == 0 <-> a mod b == 0). -Proof. - intros a b Hb. now rewrite mod_divide, rem_divide. -Qed. - -(** When division is exact, div and quot agree *) - -Lemma quot_div_exact : forall a b, b~=0 -> (b|a) -> aĆ·b == a/b. -Proof. - intros a b Hb H. - apply mul_cancel_l with b; trivial. - assert (H':=H). - apply rem_divide, quot_exact in H; trivial. - apply mod_divide, div_exact in H'; trivial. - now rewrite <-H,<-H'. -Qed. - -Lemma divide_div_mul_exact : forall a b c, b~=0 -> (b|a) -> - (c*a)/b == c*(a/b). -Proof. - intros a b c Hb H. - apply mul_cancel_l with b; trivial. - rewrite mul_assoc, mul_shuffle0. - assert (H':=H). apply mod_divide, div_exact in H'; trivial. - rewrite <- H', (mul_comm a c). - symmetry. apply div_exact; trivial. - apply mod_divide; trivial. - now apply divide_mul_r. -Qed. - -Lemma divide_quot_mul_exact : forall a b c, b~=0 -> (b|a) -> - (c*a)Ć·b == c*(aĆ·b). -Proof. - intros a b c Hb H. - rewrite 2 quot_div_exact; trivial. - - apply divide_div_mul_exact; trivial. - - now apply divide_mul_r. -Qed. - -(** Gcd of divided elements, for exact divisions *) - -Lemma gcd_div_factor : forall a b c, 0 (c|a) -> (c|b) -> - gcd (a/c) (b/c) == (gcd a b)/c. -Proof. - intros a b c Hc Ha Hb. - apply mul_cancel_l with c; try order. - assert (H:=gcd_greatest _ _ _ Ha Hb). - apply mod_divide, div_exact in H; try order. - rewrite <- H. - rewrite <- gcd_mul_mono_l_nonneg; try order. - f_equiv; symmetry; apply div_exact; try order; - apply mod_divide; trivial; try order. -Qed. - -Lemma gcd_quot_factor : forall a b c, 0 (c|a) -> (c|b) -> - gcd (aĆ·c) (bĆ·c) == (gcd a b)Ć·c. -Proof. - intros a b c Hc Ha Hb. rewrite !quot_div_exact; trivial; try order. - - now apply gcd_div_factor. - - now apply gcd_greatest. -Qed. - -Lemma gcd_div_gcd : forall a b g, g~=0 -> g == gcd a b -> - gcd (a/g) (b/g) == 1. -Proof. - intros a b g NZ EQ. rewrite gcd_div_factor. - - now rewrite <- EQ, div_same. - - generalize (gcd_nonneg a b); order. - - rewrite EQ; apply gcd_divide_l. - - rewrite EQ; apply gcd_divide_r. -Qed. - -Lemma gcd_quot_gcd : forall a b g, g~=0 -> g == gcd a b -> - gcd (aĆ·g) (bĆ·g) == 1. -Proof. - intros a b g NZ EQ. rewrite !quot_div_exact; trivial. - - now apply gcd_div_gcd. - - rewrite EQ; apply gcd_divide_r. - - rewrite EQ; apply gcd_divide_l. -Qed. - -(** The following equality is crucial for Euclid algorithm *) - -Lemma gcd_mod : forall a b, b~=0 -> gcd (a mod b) b == gcd b a. -Proof. - intros a b Hb. rewrite mod_eq; trivial. - rewrite <- add_opp_r, mul_comm, <- mul_opp_l. - rewrite (gcd_comm _ b). - apply gcd_add_mult_diag_r. -Qed. - -Lemma gcd_rem : forall a b, b~=0 -> gcd (a rem b) b == gcd b a. -Proof. - intros a b Hb. rewrite rem_eq; trivial. - rewrite <- add_opp_r, mul_comm, <- mul_opp_l. - rewrite (gcd_comm _ b). - apply gcd_add_mult_diag_r. -Qed. - -(** We now define lcm thanks to gcd: - - lcm a b = a * (b / gcd a b) - = (a / gcd a b) * b - = (a*b) / gcd a b - - We had an abs in order to have an always-nonnegative lcm, - in the spirit of gcd. Nota: [lcm 0 0] should be 0, which - isn't guarantee with the third equation above. -*) - -Definition lcm a b := abs (a*(b/gcd a b)). - -#[global] -Instance lcm_wd : Proper (eq==>eq==>eq) lcm. -Proof. unfold lcm. solve_proper. Qed. - -Lemma lcm_equiv1 : forall a b, gcd a b ~= 0 -> - a * (b / gcd a b) == (a*b)/gcd a b. -Proof. - intros a b H. rewrite divide_div_mul_exact; try easy. apply gcd_divide_r. -Qed. - -Lemma lcm_equiv2 : forall a b, gcd a b ~= 0 -> - (a / gcd a b) * b == (a*b)/gcd a b. -Proof. - intros a b H. rewrite 2 (mul_comm _ b). - rewrite divide_div_mul_exact; try easy. apply gcd_divide_l. -Qed. - -Lemma gcd_div_swap : forall a b, - (a / gcd a b) * b == a * (b / gcd a b). -Proof. - intros a b. destruct (eq_decidable (gcd a b) 0) as [EQ|NEQ]. - - apply gcd_eq_0 in EQ. destruct EQ as (EQ,EQ'). rewrite EQ, EQ'. now nzsimpl. - - now rewrite lcm_equiv1, <-lcm_equiv2. -Qed. - -Lemma divide_lcm_l : forall a b, (a | lcm a b). -Proof. - unfold lcm. intros a b. apply divide_abs_r, divide_factor_l. -Qed. - -Lemma divide_lcm_r : forall a b, (b | lcm a b). -Proof. - unfold lcm. intros a b. apply divide_abs_r. rewrite <- gcd_div_swap. - apply divide_factor_r. -Qed. - -Lemma divide_div : forall a b c, a~=0 -> (a|b) -> (b|c) -> (b/a|c/a). -Proof. - intros a b c Ha Hb (c',Hc). exists c'. - now rewrite <- divide_div_mul_exact, <- Hc. -Qed. - -Lemma lcm_least : forall a b c, - (a | c) -> (b | c) -> (lcm a b | c). -Proof. - intros a b c Ha Hb. unfold lcm. apply divide_abs_l. - destruct (eq_decidable (gcd a b) 0) as [EQ|NEQ]. - - apply gcd_eq_0 in EQ. destruct EQ as (EQ,EQ'). rewrite EQ in *. now nzsimpl. - - assert (Ga := gcd_divide_l a b). - assert (Gb := gcd_divide_r a b). - set (g:=gcd a b) in *. - assert (Ha' := divide_div g a c NEQ Ga Ha). - assert (Hb' := divide_div g b c NEQ Gb Hb). - destruct Ha' as (a',Ha'). rewrite Ha', mul_comm in Hb'. - apply gauss in Hb'; [|apply gcd_div_gcd; unfold g; trivial using gcd_comm]. - destruct Hb' as (b',Hb'). - exists b'. - rewrite mul_shuffle3, <- Hb'. - rewrite (proj2 (div_exact c g NEQ)). - + rewrite Ha', mul_shuffle3, (mul_comm a a'). f_equiv. - symmetry. apply div_exact; trivial. - apply mod_divide; trivial. - + apply mod_divide; trivial. transitivity a; trivial. -Qed. - -Lemma lcm_nonneg : forall a b, 0 <= lcm a b. -Proof. - intros a b. unfold lcm. apply abs_nonneg. -Qed. - -Lemma lcm_comm : forall a b, lcm a b == lcm b a. -Proof. - intros a b. unfold lcm. rewrite (gcd_comm b), (mul_comm b). - now rewrite <- gcd_div_swap. -Qed. - -Lemma lcm_divide_iff : forall n m p, - (lcm n m | p) <-> (n | p) /\ (m | p). -Proof. - intros n m p. split;[split|]. - - transitivity (lcm n m); trivial using divide_lcm_l. - - transitivity (lcm n m); trivial using divide_lcm_r. - - intros (H,H'). now apply lcm_least. -Qed. - -Lemma lcm_unique : forall n m p, - 0<=p -> (n|p) -> (m|p) -> - (forall q, (n|q) -> (m|q) -> (p|q)) -> - lcm n m == p. -Proof. - intros n m p Hp Hn Hm H. - apply divide_antisym_nonneg; trivial. - - apply lcm_nonneg. - - now apply lcm_least. - - apply H. - + apply divide_lcm_l. - + apply divide_lcm_r. -Qed. - -Lemma lcm_unique_alt : forall n m p, 0<=p -> - (forall q, (p|q) <-> (n|q) /\ (m|q)) -> - lcm n m == p. -Proof. - intros n m p Hp H. - apply lcm_unique; trivial. - - apply H, divide_refl. - - apply H, divide_refl. - - intros. apply H. now split. -Qed. - -Lemma lcm_assoc : forall n m p, lcm n (lcm m p) == lcm (lcm n m) p. -Proof. - intros. apply lcm_unique_alt; try apply lcm_nonneg. - intros. now rewrite !lcm_divide_iff, and_assoc. -Qed. - -Lemma lcm_0_l : forall n, lcm 0 n == 0. -Proof. - intros. apply lcm_unique; trivial. - - order. - - apply divide_refl. - - apply divide_0_r. -Qed. - -Lemma lcm_0_r : forall n, lcm n 0 == 0. -Proof. - intros. now rewrite lcm_comm, lcm_0_l. -Qed. - -Lemma lcm_1_l_nonneg : forall n, 0<=n -> lcm 1 n == n. -Proof. - intros. apply lcm_unique; trivial using divide_1_l, le_0_1, divide_refl. -Qed. - -Lemma lcm_1_r_nonneg : forall n, 0<=n -> lcm n 1 == n. -Proof. - intros. now rewrite lcm_comm, lcm_1_l_nonneg. -Qed. - -Lemma lcm_diag_nonneg : forall n, 0<=n -> lcm n n == n. -Proof. - intros. apply lcm_unique; trivial using divide_refl. -Qed. - -Lemma lcm_eq_0 : forall n m, lcm n m == 0 <-> n == 0 \/ m == 0. -Proof. - intros. split. - - intros EQ. - apply eq_mul_0. - apply divide_0_l. rewrite <- EQ. apply lcm_least. - + apply divide_factor_l. - + apply divide_factor_r. - - destruct 1 as [EQ|EQ]; rewrite EQ. - + apply lcm_0_l. - + apply lcm_0_r. -Qed. - -Lemma divide_lcm_eq_r : forall n m, 0<=m -> (n|m) -> lcm n m == m. -Proof. - intros n m Hm H. apply lcm_unique_alt; trivial. - intros q. split. - - split; trivial. now transitivity m. - - now destruct 1. -Qed. - -Lemma divide_lcm_iff : forall n m, 0<=m -> ((n|m) <-> lcm n m == m). -Proof. - intros n m Hn. split. - - now apply divide_lcm_eq_r. - - intros EQ. rewrite <- EQ. apply divide_lcm_l. -Qed. - -Lemma lcm_opp_l : forall n m, lcm (-n) m == lcm n m. -Proof. - intros. apply lcm_unique_alt; try apply lcm_nonneg. - intros. rewrite divide_opp_l. apply lcm_divide_iff. -Qed. - -Lemma lcm_opp_r : forall n m, lcm n (-m) == lcm n m. -Proof. - intros. now rewrite lcm_comm, lcm_opp_l, lcm_comm. -Qed. - -Lemma lcm_abs_l : forall n m, lcm (abs n) m == lcm n m. -Proof. - intros n m. destruct (abs_eq_or_opp n) as [H|H]; rewrite H. - - easy. - - apply lcm_opp_l. -Qed. - -Lemma lcm_abs_r : forall n m, lcm n (abs m) == lcm n m. -Proof. - intros. now rewrite lcm_comm, lcm_abs_l, lcm_comm. -Qed. - -Lemma lcm_1_l : forall n, lcm 1 n == abs n. -Proof. - intros. rewrite <- lcm_abs_r. apply lcm_1_l_nonneg, abs_nonneg. -Qed. - -Lemma lcm_1_r : forall n, lcm n 1 == abs n. -Proof. - intros. now rewrite lcm_comm, lcm_1_l. -Qed. - -Lemma lcm_diag : forall n, lcm n n == abs n. -Proof. - intros. rewrite <- lcm_abs_l, <- lcm_abs_r. - apply lcm_diag_nonneg, abs_nonneg. -Qed. - -Lemma lcm_mul_mono_l : - forall n m p, lcm (p * n) (p * m) == abs p * lcm n m. -Proof. - intros n m p. - destruct (eq_decidable p 0) as [Hp|Hp];[|destruct (eq_decidable (gcd n m) 0) as [Hg|Hg]]. - - rewrite Hp. nzsimpl. rewrite lcm_0_l, abs_0. now nzsimpl. - - apply gcd_eq_0 in Hg. destruct Hg as (Hn,Hm); rewrite Hn, Hm. - nzsimpl. rewrite lcm_0_l. now nzsimpl. - - unfold lcm. - rewrite gcd_mul_mono_l. - rewrite !abs_mul, mul_assoc. f_equiv. - rewrite <- (abs_sgn p) at 1. rewrite <- mul_assoc. - rewrite div_mul_cancel_l; trivial. - + rewrite divide_div_mul_exact; trivial. - * rewrite abs_mul. - rewrite <- (sgn_abs (sgn p)), sgn_sgn. - { destruct (sgn_spec p) as [(_,EQ)|[(EQ,_)|(_,EQ)]]. - - rewrite EQ. now nzsimpl. - - order. - - rewrite EQ. rewrite mul_opp_l, mul_opp_r, opp_involutive. now nzsimpl. - } - * apply gcd_divide_r. - + contradict Hp. now apply abs_0_iff. -Qed. - -Lemma lcm_mul_mono_l_nonneg : - forall n m p, 0<=p -> lcm (p*n) (p*m) == p * lcm n m. -Proof. - intros n m p ?. rewrite <- (abs_eq p) at 3; trivial. apply lcm_mul_mono_l. -Qed. - -Lemma lcm_mul_mono_r : - forall n m p, lcm (n * p) (m * p) == lcm n m * abs p. -Proof. - intros n m p. now rewrite !(mul_comm _ p), lcm_mul_mono_l, mul_comm. -Qed. - -Lemma lcm_mul_mono_r_nonneg : - forall n m p, 0<=p -> lcm (n*p) (m*p) == lcm n m * p. -Proof. - intros n m p ?. rewrite <- (abs_eq p) at 3; trivial. apply lcm_mul_mono_r. -Qed. - -Lemma gcd_1_lcm_mul : forall n m, n~=0 -> m~=0 -> - (gcd n m == 1 <-> lcm n m == abs (n*m)). -Proof. - intros n m Hn Hm. split; intros H. - - unfold lcm. rewrite H. now rewrite div_1_r. - - unfold lcm in *. - rewrite !abs_mul in H. apply mul_cancel_l in H; [|now rewrite abs_0_iff]. - assert (H' := gcd_divide_r n m). - assert (Hg : gcd n m ~= 0) by (red; rewrite gcd_eq_0; destruct 1; order). - apply mod_divide in H'; trivial. apply div_exact in H'; trivial. - assert (m / gcd n m ~=0) by (contradict Hm; rewrite H', Hm; now nzsimpl). - rewrite <- (mul_1_l (abs (_/_))) in H. - rewrite H' in H at 3. rewrite abs_mul in H. - apply mul_cancel_r in H; [|now rewrite abs_0_iff]. - rewrite abs_eq in H. { order. } apply gcd_nonneg. -Qed. - -End ZLcmProp. diff --git a/stdlib/theories/Numbers/Integer/Abstract/ZLt.v b/stdlib/theories/Numbers/Integer/Abstract/ZLt.v deleted file mode 100644 index 7fbced6bed7e..000000000000 --- a/stdlib/theories/Numbers/Integer/Abstract/ZLt.v +++ /dev/null @@ -1,134 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* n < 0 \/ n > 0. -Proof. -intro; apply lt_gt_cases. -Qed. - -Theorem nonpos_pos_cases : forall n, n <= 0 \/ n > 0. -Proof. -intro; apply le_gt_cases. -Qed. - -Theorem neg_nonneg_cases : forall n, n < 0 \/ n >= 0. -Proof. -intro; apply lt_ge_cases. -Qed. - -Theorem nonpos_nonneg_cases : forall n, n <= 0 \/ n >= 0. -Proof. -intro; apply le_ge_cases. -Qed. - -Ltac zinduct n := induction_maker n ltac:(apply order_induction_0). - -(** Theorems that are either not valid on N or have different proofs - on N and Z *) - -Theorem lt_pred_l : forall n, P n < n. -Proof. -intro n; rewrite <- (succ_pred n) at 2; apply lt_succ_diag_r. -Qed. - -Theorem le_pred_l : forall n, P n <= n. -Proof. -intro; apply lt_le_incl; apply lt_pred_l. -Qed. - -Theorem lt_le_pred : forall n m, n < m <-> n <= P m. -Proof. -intros n m; rewrite <- (succ_pred m); rewrite pred_succ. apply lt_succ_r. -Qed. - -Theorem nle_pred_r : forall n, ~ n <= P n. -Proof. -intro; rewrite <- lt_le_pred; apply lt_irrefl. -Qed. - -Theorem lt_pred_le : forall n m, P n < m <-> n <= m. -Proof. -intros n m; rewrite <- (succ_pred n) at 2. -symmetry; apply le_succ_l. -Qed. - -Theorem lt_lt_pred : forall n m, n < m -> P n < m. -Proof. -intros; apply lt_pred_le; now apply lt_le_incl. -Qed. - -Theorem le_le_pred : forall n m, n <= m -> P n <= m. -Proof. -intros; apply lt_le_incl; now apply lt_pred_le. -Qed. - -Theorem lt_pred_lt : forall n m, n < P m -> n < m. -Proof. -intros n m H; apply lt_trans with (P m); [assumption | apply lt_pred_l]. -Qed. - -Theorem le_pred_lt : forall n m, n <= P m -> n <= m. -Proof. -intros; apply lt_le_incl; now apply lt_le_pred. -Qed. - -Theorem pred_lt_mono : forall n m, n < m <-> P n < P m. -Proof. -intros; rewrite lt_le_pred; symmetry; apply lt_pred_le. -Qed. - -Theorem pred_le_mono : forall n m, n <= m <-> P n <= P m. -Proof. -intros; rewrite <- lt_pred_le; now rewrite lt_le_pred. -Qed. - -Theorem lt_succ_lt_pred : forall n m, S n < m <-> n < P m. -Proof. -intros n m; now rewrite (pred_lt_mono (S n) m), pred_succ. -Qed. - -Theorem le_succ_le_pred : forall n m, S n <= m <-> n <= P m. -Proof. -intros n m; now rewrite (pred_le_mono (S n) m), pred_succ. -Qed. - -Theorem lt_pred_lt_succ : forall n m, P n < m <-> n < S m. -Proof. -intros; rewrite lt_pred_le; symmetry; apply lt_succ_r. -Qed. - -Theorem le_pred_lt_succ : forall n m, P n <= m <-> n <= S m. -Proof. -intros n m; now rewrite (pred_le_mono n (S m)), pred_succ. -Qed. - -Theorem neq_pred_l : forall n, P n ~= n. -Proof. -intro; apply lt_neq; apply lt_pred_l. -Qed. - -Theorem lt_m1_r : forall n m, n < m -> m < 0 -> n < -1. -Proof. -intros n m H1 H2. apply lt_le_pred in H2. -setoid_replace (P 0) with (-1) in H2. -- now apply lt_le_trans with m. -- apply eq_opp_r. now rewrite one_succ, opp_pred, opp_0. -Qed. - -End ZOrderProp. diff --git a/stdlib/theories/Numbers/Integer/Abstract/ZMaxMin.v b/stdlib/theories/Numbers/Integer/Abstract/ZMaxMin.v deleted file mode 100644 index 60c965e01080..000000000000 --- a/stdlib/theories/Numbers/Integer/Abstract/ZMaxMin.v +++ /dev/null @@ -1,181 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* - max (p * n) (p * m) == p * max n m. -Proof. - intros. destruct (le_ge_cases n m); - [rewrite 2 max_r | rewrite 2 max_l]; try order; now apply mul_le_mono_nonneg_l. -Qed. - -Lemma mul_max_distr_nonneg_r n m p : 0 <= p -> - max (n * p) (m * p) == max n m * p. -Proof. - intros. destruct (le_ge_cases n m); - [rewrite 2 max_r | rewrite 2 max_l]; try order; now apply mul_le_mono_nonneg_r. -Qed. - -Lemma mul_min_distr_nonneg_l n m p : 0 <= p -> - min (p * n) (p * m) == p * min n m. -Proof. - intros. destruct (le_ge_cases n m); - [rewrite 2 min_l | rewrite 2 min_r]; try order; now apply mul_le_mono_nonneg_l. -Qed. - -Lemma mul_min_distr_nonneg_r n m p : 0 <= p -> - min (n * p) (m * p) == min n m * p. -Proof. - intros. destruct (le_ge_cases n m); - [rewrite 2 min_l | rewrite 2 min_r]; try order; now apply mul_le_mono_nonneg_r. -Qed. - -Lemma mul_max_distr_nonpos_l n m p : p <= 0 -> - max (p * n) (p * m) == p * min n m. -Proof. - intros. destruct (le_ge_cases n m). - - rewrite min_l by trivial. rewrite max_l by now apply mul_le_mono_nonpos_l. reflexivity. - - rewrite min_r by trivial. rewrite max_r by now apply mul_le_mono_nonpos_l. reflexivity. -Qed. - -Lemma mul_max_distr_nonpos_r n m p : p <= 0 -> - max (n * p) (m * p) == min n m * p. -Proof. - intros. destruct (le_ge_cases n m). - - rewrite min_l by trivial. rewrite max_l by now apply mul_le_mono_nonpos_r. reflexivity. - - rewrite min_r by trivial. rewrite max_r by now apply mul_le_mono_nonpos_r. reflexivity. -Qed. - -Lemma mul_min_distr_nonpos_l n m p : p <= 0 -> - min (p * n) (p * m) == p * max n m. -Proof. - intros. destruct (le_ge_cases n m). - - rewrite max_r by trivial. rewrite min_r by now apply mul_le_mono_nonpos_l. reflexivity. - - rewrite max_l by trivial. rewrite min_l by now apply mul_le_mono_nonpos_l. reflexivity. -Qed. - -Lemma mul_min_distr_nonpos_r n m p : p <= 0 -> - min (n * p) (m * p) == max n m * p. -Proof. - intros. destruct (le_ge_cases n m). - - rewrite max_r by trivial. rewrite min_r by now apply mul_le_mono_nonpos_r. reflexivity. - - rewrite max_l by trivial. rewrite min_l by now apply mul_le_mono_nonpos_r. reflexivity. -Qed. - -End ZMaxMinProp. diff --git a/stdlib/theories/Numbers/Integer/Abstract/ZMul.v b/stdlib/theories/Numbers/Integer/Abstract/ZMul.v deleted file mode 100644 index 3dd8a1ba07fb..000000000000 --- a/stdlib/theories/Numbers/Integer/Abstract/ZMul.v +++ /dev/null @@ -1,75 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* n < m -> q <= 0 -> p < q -> m * q < n * p. -Proof. -intros n m p q H1 H2 H3 H4. -apply le_lt_trans with (m * p). -- apply mul_le_mono_nonpos_l; [assumption | now apply lt_le_incl]. -- apply -> mul_lt_mono_neg_r; [assumption | now apply lt_le_trans with q]. -Qed. - -Theorem mul_le_mono_nonpos : - forall n m p q, m <= 0 -> n <= m -> q <= 0 -> p <= q -> m * q <= n * p. -Proof. -intros n m p q H1 H2 H3 H4. -apply le_trans with (m * p). -- now apply mul_le_mono_nonpos_l. -- apply mul_le_mono_nonpos_r; [now apply le_trans with q | assumption]. -Qed. - -Theorem mul_nonpos_nonpos : forall n m, n <= 0 -> m <= 0 -> 0 <= n * m. -Proof. -intros n m H1 H2. -rewrite <- (mul_0_l m). now apply mul_le_mono_nonpos_r. -Qed. - -Theorem mul_nonneg_nonpos : forall n m, 0 <= n -> m <= 0 -> n * m <= 0. -Proof. -intros n m H1 H2. -rewrite <- (mul_0_l m). now apply mul_le_mono_nonpos_r. -Qed. - -Theorem mul_nonpos_nonneg : forall n m, n <= 0 -> 0 <= m -> n * m <= 0. -Proof. -intros; rewrite mul_comm; now apply mul_nonneg_nonpos. -Qed. - -Notation mul_pos := lt_0_mul (only parsing). - -Theorem lt_mul_0 : - forall n m, n * m < 0 <-> n < 0 /\ m > 0 \/ n > 0 /\ m < 0. -Proof. -intros n m; split; [intro H | intros [[H1 H2] | [H1 H2]]]. -- destruct (lt_trichotomy n 0) as [H1 | [H1 | H1]]; - [| rewrite H1 in H; rewrite mul_0_l in H; false_hyp H lt_irrefl |]; - (destruct (lt_trichotomy m 0) as [H2 | [H2 | H2]]; - [| rewrite H2 in H; rewrite mul_0_r in H; false_hyp H lt_irrefl |]); - try (left; now split); try (right; now split). - + assert (H3 : n * m > 0) by now apply mul_neg_neg. - exfalso; now apply (lt_asymm (n * m) 0). - + assert (H3 : n * m > 0) by now apply mul_pos_pos. - exfalso; now apply (lt_asymm (n * m) 0). -- now apply mul_neg_pos. -- now apply mul_pos_neg. -Qed. - -Notation mul_neg := lt_mul_0 (only parsing). - -Theorem le_0_mul : - forall n m, 0 <= n * m -> 0 <= n /\ 0 <= m \/ n <= 0 /\ m <= 0. -Proof. -assert (R : forall n, 0 == n <-> n == 0) by (intros; split; apply eq_sym). -intros n m. repeat rewrite lt_eq_cases. repeat rewrite R. -rewrite lt_0_mul, eq_mul_0. -pose proof (lt_trichotomy n 0); pose proof (lt_trichotomy m 0). tauto. -Qed. - -Notation mul_nonneg := le_0_mul (only parsing). - -Theorem le_mul_0 : - forall n m, n * m <= 0 -> 0 <= n /\ m <= 0 \/ n <= 0 /\ 0 <= m. -Proof. -assert (R : forall n, 0 == n <-> n == 0) by (intros; split; apply eq_sym). -intros n m. repeat rewrite lt_eq_cases. repeat rewrite R. -rewrite lt_mul_0, eq_mul_0. -pose proof (lt_trichotomy n 0); pose proof (lt_trichotomy m 0). tauto. -Qed. - -Notation mul_nonpos := le_mul_0 (only parsing). - -Notation le_0_square := square_nonneg (only parsing). - -Theorem nlt_square_0 : forall n, ~ n * n < 0. -Proof. -intros n H. apply lt_nge in H. apply H. apply square_nonneg. -Qed. - -Theorem square_lt_mono_nonpos : forall n m, n <= 0 -> m < n -> n * n < m * m. -Proof. -intros n m H1 H2. now apply mul_lt_mono_nonpos. -Qed. - -Theorem square_le_mono_nonpos : forall n m, n <= 0 -> m <= n -> n * n <= m * m. -Proof. -intros n m H1 H2. now apply mul_le_mono_nonpos. -Qed. - -Theorem square_lt_simpl_nonpos : forall n m, m <= 0 -> n * n < m * m -> m < n. -Proof. -intros n m H1 H2. destruct (le_gt_cases n 0); [|order]. -destruct (lt_ge_cases m n) as [LE|GT]; trivial. -apply square_le_mono_nonpos in GT; order. -Qed. - -Theorem square_le_simpl_nonpos : forall n m, m <= 0 -> n * n <= m * m -> m <= n. -Proof. -intros n m H1 H2. destruct (le_gt_cases n 0); [|order]. -destruct (le_gt_cases m n) as [LE|GT]; trivial. -apply square_lt_mono_nonpos in GT; order. -Qed. - -Theorem lt_1_mul_neg : forall n m, n < -1 -> m < 0 -> 1 < n * m. -Proof. -intros n m H1 H2. apply (mul_lt_mono_neg_r m) in H1. -- apply opp_pos_neg in H2. rewrite mul_opp_l, mul_1_l in H1. - now apply lt_1_l with (- m). -- assumption. -Qed. - -Theorem lt_mul_m1_neg : forall n m, 1 < n -> m < 0 -> n * m < -1. -Proof. -intros n m H1 H2. apply (mul_lt_mono_neg_r m) in H1. -- rewrite mul_1_l in H1. now apply lt_m1_r with m. -- assumption. -Qed. - -Theorem lt_mul_m1_pos : forall n m, n < -1 -> 0 < m -> n * m < -1. -Proof. -intros n m H1 H2. apply (mul_lt_mono_pos_r m) in H1. -- rewrite mul_opp_l, mul_1_l in H1. - apply opp_neg_pos in H2. now apply lt_m1_r with (- m). -- assumption. -Qed. - -Theorem lt_1_mul_l : forall n m, 1 < n -> - n * m < -1 \/ n * m == 0 \/ 1 < n * m. -Proof. -intros n m H; destruct (lt_trichotomy m 0) as [H1 | [H1 | H1]]. -- left. now apply lt_mul_m1_neg. -- right; left; now rewrite H1, mul_0_r. -- right; right; now apply lt_1_mul_pos. -Qed. - -Theorem lt_m1_mul_r : forall n m, n < -1 -> - n * m < -1 \/ n * m == 0 \/ 1 < n * m. -Proof. -intros n m H; destruct (lt_trichotomy m 0) as [H1 | [H1 | H1]]. -- right; right. now apply lt_1_mul_neg. -- right; left; now rewrite H1, mul_0_r. -- left. now apply lt_mul_m1_pos. -Qed. - -Theorem eq_mul_1 : forall n m, n * m == 1 -> n == 1 \/ n == -1. -Proof. -assert (F := lt_m1_0). -intro n; zero_pos_neg n. -- (* n = 0 *) - intros m. nzsimpl. now left. -- (* 0 < n, proving P n /\ P (-n) *) - intros n Hn. rewrite <- le_succ_l, <- one_succ in Hn. - le_elim Hn; split; intros m H. - + destruct (lt_1_mul_l n m) as [|[|]]; order'. - + rewrite mul_opp_l, eq_opp_l in H. destruct (lt_1_mul_l n m) as [|[|]]; order'. - + now left. - + intros; right. now f_equiv. -Qed. - -Theorem lt_mul_diag_l : forall n m, n < 0 -> (1 < m <-> n * m < n). -Proof. -intros n m H. stepr (n * m < n * 1) by now rewrite mul_1_r. -now apply mul_lt_mono_neg_l. -Qed. - -Theorem lt_mul_diag_r : forall n m, 0 < n -> (1 < m <-> n < n * m). -Proof. -intros n m H. stepr (n * 1 < n * m) by now rewrite mul_1_r. -now apply mul_lt_mono_pos_l. -Qed. - -Theorem le_mul_diag_l : forall n m, n < 0 -> (1 <= m <-> n * m <= n). -Proof. -intros n m H. stepr (n * m <= n * 1) by now rewrite mul_1_r. -now apply mul_le_mono_neg_l. -Qed. - -Theorem le_mul_diag_r : forall n m, 0 < n -> (1 <= m <-> n <= n * m). -Proof. -intros n m H. stepr (n * 1 <= n * m) by now rewrite mul_1_r. -now apply mul_le_mono_pos_l. -Qed. - -Theorem lt_mul_r : forall n m p, 0 < n -> 1 < p -> n < m -> n < m * p. -Proof. -intros n m p **. stepl (n * 1) by now rewrite mul_1_r. -apply mul_lt_mono_nonneg. -- now apply lt_le_incl. -- assumption. -- apply le_0_1. -- assumption. -Qed. - -(** Alternative name : *) - -Definition mul_eq_1 := eq_mul_1. - -End ZMulOrderProp. diff --git a/stdlib/theories/Numbers/Integer/Abstract/ZParity.v b/stdlib/theories/Numbers/Integer/Abstract/ZParity.v deleted file mode 100644 index 61b8426dedab..000000000000 --- a/stdlib/theories/Numbers/Integer/Abstract/ZParity.v +++ /dev/null @@ -1,55 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* Even (-n)). - { intros n (m,H). exists (-m). rewrite mul_opp_r. now f_equiv. } - intros n. rewrite eq_iff_eq_true, !even_spec. - split. - - rewrite <- (opp_involutive n) at 2. apply H. - - apply H. -Qed. - -Lemma odd_opp : forall n, odd (-n) = odd n. -Proof. - intros. rewrite <- !negb_even. now rewrite even_opp. -Qed. - -Lemma even_sub : forall n m, even (n-m) = Bool.eqb (even n) (even m). -Proof. - intros. now rewrite <- add_opp_r, even_add, even_opp. -Qed. - -Lemma odd_sub : forall n m, odd (n-m) = xorb (odd n) (odd m). -Proof. - intros. now rewrite <- add_opp_r, odd_add, odd_opp. -Qed. - -End ZParityProp. diff --git a/stdlib/theories/Numbers/Integer/Abstract/ZPow.v b/stdlib/theories/Numbers/Integer/Abstract/ZPow.v deleted file mode 100644 index 269ff3e07c75..000000000000 --- a/stdlib/theories/Numbers/Integer/Abstract/ZPow.v +++ /dev/null @@ -1,141 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* even (a^b) = even a. -Proof. - intros a b Hb. apply lt_ind with (4:=Hb). - - solve_proper. - - now nzsimpl. - - clear b Hb. intros b Hb IH. nzsimpl; [|order]. - rewrite even_mul, IH. now destruct (even a). -Qed. - -Lemma odd_pow : forall a b, 0 odd (a^b) = odd a. -Proof. - intros. now rewrite <- !negb_even, even_pow. -Qed. - -(** Properties of power of negative numbers *) - -Lemma pow_opp_even : forall a b, Even b -> (-a)^b == a^b. -Proof. - intros a b (c,H). rewrite H. - destruct (le_gt_cases 0 c). - - rewrite 2 pow_mul_r by order'. - rewrite 2 pow_2_r. - now rewrite mul_opp_opp. - - assert (2*c < 0) by (apply mul_pos_neg; order'). - now rewrite !pow_neg_r. -Qed. - -Lemma pow_opp_odd : forall a b, Odd b -> (-a)^b == -(a^b). -Proof. - intros a b (c,H). rewrite H. - destruct (le_gt_cases 0 c) as [LE|GT]. - - assert (0 <= 2*c) by (apply mul_nonneg_nonneg; order'). - rewrite add_1_r, !pow_succ_r; trivial. - rewrite pow_opp_even by (now exists c). - apply mul_opp_l. - - apply double_above in GT. rewrite mul_0_r in GT. - rewrite !pow_neg_r by trivial. now rewrite opp_0. -Qed. - -Lemma pow_even_abs : forall a b, Even b -> a^b == (abs a)^b. -Proof. - intros a b ?. destruct (abs_eq_or_opp a) as [EQ|EQ]; rewrite EQ. - - reflexivity. - - symmetry. now apply pow_opp_even. -Qed. - -Lemma pow_even_nonneg : forall a b, Even b -> 0 <= a^b. -Proof. - intros. rewrite pow_even_abs by trivial. - apply pow_nonneg, abs_nonneg. -Qed. - -Lemma pow_odd_abs_sgn : forall a b, Odd b -> a^b == sgn a * (abs a)^b. -Proof. - intros a b H. - destruct (sgn_spec a) as [(LT,EQ)|[(EQ',EQ)|(LT,EQ)]]; rewrite EQ. - - nzsimpl. - rewrite abs_eq; order. - - rewrite <- EQ'. nzsimpl. - destruct (le_gt_cases 0 b). - + apply pow_0_l. - assert (b~=0) by (contradict H; now rewrite H, <-odd_spec, odd_0). - order. - + now rewrite pow_neg_r. - - rewrite abs_neq by order. - rewrite pow_opp_odd; trivial. - now rewrite mul_opp_opp, mul_1_l. -Qed. - -Lemma pow_odd_sgn : forall a b, 0<=b -> Odd b -> sgn (a^b) == sgn a. -Proof. - intros a b Hb H. - destruct (sgn_spec a) as [(LT,EQ)|[(EQ',EQ)|(LT,EQ)]]; rewrite EQ. - - apply sgn_pos. apply pow_pos_nonneg; trivial. - - rewrite <- EQ'. rewrite pow_0_l. - + apply sgn_0. - + assert (b~=0) by (contradict H; now rewrite H, <-odd_spec, odd_0). - order. - - apply sgn_neg. - rewrite <- (opp_involutive a). rewrite pow_opp_odd by trivial. - apply opp_neg_pos. - apply pow_pos_nonneg; trivial. - now apply opp_pos_neg. -Qed. - -Lemma abs_pow : forall a b, abs (a^b) == (abs a)^b. -Proof. - intros a b. - destruct (Even_or_Odd b) as [H|H]. - - rewrite pow_even_abs by trivial. - apply abs_eq, pow_nonneg, abs_nonneg. - - rewrite pow_odd_abs_sgn by trivial. - rewrite abs_mul. - destruct (lt_trichotomy 0 a) as [Ha|[Ha|Ha]]. - + rewrite (sgn_pos a), (abs_eq 1), mul_1_l by order'. - apply abs_eq, pow_nonneg, abs_nonneg. - + rewrite <- Ha, sgn_0, abs_0, mul_0_l. - symmetry. apply pow_0_l'. intro Hb. rewrite Hb in H. - apply (Even_Odd_False 0); trivial. exists 0; now nzsimpl. - + rewrite (sgn_neg a), abs_opp, (abs_eq 1), mul_1_l by order'. - apply abs_eq, pow_nonneg, abs_nonneg. -Qed. - -End ZPowProp. diff --git a/stdlib/theories/Numbers/Integer/Abstract/ZProperties.v b/stdlib/theories/Numbers/Integer/Abstract/ZProperties.v deleted file mode 100644 index f09555fbe439..000000000000 --- a/stdlib/theories/Numbers/Integer/Abstract/ZProperties.v +++ /dev/null @@ -1,32 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* abs n == n. - Proof. - intros. unfold abs. apply max_l. - apply le_trans with 0; auto. - rewrite opp_nonpos_nonneg; auto. - Qed. - Lemma abs_neq : forall n, n<=0 -> abs n == -n. - Proof. - intros. unfold abs. apply max_r. - apply le_trans with 0; auto. - rewrite opp_nonneg_nonpos; auto. - Qed. -End GenericAbs. - -(** We can deduce a [sgn] function from a [compare] function *) - -Module Type ZDecAxiomsSig := ZAxiomsMiniSig <+ HasCompare. -Module Type ZDecAxiomsSig' := ZAxiomsMiniSig' <+ HasCompare. - -Module Type GenericSgn (Import Z : ZDecAxiomsSig') - (Import ZP : ZMulOrderProp Z) <: HasSgn Z. - Definition sgn n := - match compare 0 n with Eq => 0 | Lt => 1 | Gt => -1 end. - Lemma sgn_null n : n==0 -> sgn n == 0. - Proof. unfold sgn; intros. destruct (compare_spec 0 n); order. Qed. - Lemma sgn_pos n : 0 sgn n == 1. - Proof. unfold sgn; intros. destruct (compare_spec 0 n); order. Qed. - Lemma sgn_neg n : n<0 -> sgn n == -1. - Proof. unfold sgn; intros. destruct (compare_spec 0 n); order. Qed. -End GenericSgn. - - -(** Derived properties of [abs] and [sgn] *) - -Module Type ZSgnAbsProp (Import Z : ZAxiomsSig') - (Import ZP : ZMulOrderProp Z). - -Ltac destruct_max n := - destruct (le_ge_cases 0 n); - [rewrite (abs_eq n) by auto | rewrite (abs_neq n) by auto]. - -#[global] -Instance abs_wd : Proper (eq==>eq) abs. -Proof. - intros x y EQ. destruct_max x. - - rewrite abs_eq; trivial. now rewrite <- EQ. - - rewrite abs_neq; try order. now rewrite opp_inj_wd. -Qed. - -Lemma abs_max : forall n, abs n == max n (-n). -Proof. - intros n. destruct_max n. - - rewrite max_l; auto with relations. - apply le_trans with 0; auto. - rewrite opp_nonpos_nonneg; auto. - - rewrite max_r; auto with relations. - apply le_trans with 0; auto. - rewrite opp_nonneg_nonpos; auto. -Qed. - -Lemma abs_neq' : forall n, 0<=-n -> abs n == -n. -Proof. - intros. apply abs_neq. now rewrite <- opp_nonneg_nonpos. -Qed. - -Lemma abs_nonneg : forall n, 0 <= abs n. -Proof. - intros n. destruct_max n; auto. - now rewrite opp_nonneg_nonpos. -Qed. - -Lemma abs_eq_iff : forall n, abs n == n <-> 0<=n. -Proof. - split; try apply abs_eq. intros EQ. - rewrite <- EQ. apply abs_nonneg. -Qed. - -Lemma abs_neq_iff : forall n, abs n == -n <-> n<=0. -Proof. - split; try apply abs_neq. intros EQ. - rewrite <- opp_nonneg_nonpos, <- EQ. apply abs_nonneg. -Qed. - -Lemma abs_opp : forall n, abs (-n) == abs n. -Proof. - intros n. destruct_max n. - - rewrite (abs_neq (-n)), opp_involutive. - + reflexivity. - + now rewrite opp_nonpos_nonneg. - - rewrite (abs_eq (-n)). - + reflexivity. - + now rewrite opp_nonneg_nonpos. -Qed. - -Lemma abs_0 : abs 0 == 0. -Proof. - apply abs_eq. apply le_refl. -Qed. - -Lemma abs_0_iff : forall n, abs n == 0 <-> n==0. -Proof. - intros n; split. - - destruct_max n; auto. - now rewrite eq_opp_l, opp_0. - - intros EQ; rewrite EQ. rewrite abs_eq; auto using eq_refl, le_refl. -Qed. - -Lemma abs_pos : forall n, 0 < abs n <-> n~=0. -Proof. - intros n. rewrite <- abs_0_iff. split; [intros LT| intros NEQ]. - - intro EQ. rewrite EQ in LT. now elim (lt_irrefl 0). - - assert (LE : 0 <= abs n) by apply abs_nonneg. - rewrite lt_eq_cases in LE; destruct LE; auto. - elim NEQ; auto with relations. -Qed. - -Lemma abs_eq_or_opp : forall n, abs n == n \/ abs n == -n. -Proof. - intros n. destruct_max n; auto with relations. -Qed. - -Lemma abs_or_opp_abs : forall n, n == abs n \/ n == - abs n. -Proof. - intros n. destruct_max n; rewrite ? opp_involutive; auto with relations. -Qed. - -Lemma abs_idemp : forall n, abs (abs n) == abs n. -Proof. - intros. apply abs_eq. apply abs_nonneg. -Qed. - -#[deprecated(since="8.19", note="Use abs_idemp")] -Notation abs_involutive := abs_idemp. - -Lemma abs_spec : forall n, - (0 <= n /\ abs n == n) \/ (n < 0 /\ abs n == -n). -Proof. - intros n. destruct (le_gt_cases 0 n). - - left; split; auto. now apply abs_eq. - - right; split; auto. apply abs_neq. now apply lt_le_incl. -Qed. - -Lemma abs_case_strong : - forall (P:t->Prop) n, Proper (eq==>iff) P -> - (0<=n -> P n) -> (n<=0 -> P (-n)) -> P (abs n). -Proof. - intros P n **. destruct_max n; auto. -Qed. - -Lemma abs_case : forall (P:t->Prop) n, Proper (eq==>iff) P -> - P n -> P (-n) -> P (abs n). -Proof. intros. now apply abs_case_strong. Qed. - -Lemma abs_eq_cases : forall n m, abs n == abs m -> n == m \/ n == - m. -Proof. - intros n m EQ. destruct (abs_or_opp_abs n) as [EQn|EQn]. - - rewrite EQn, EQ. apply abs_eq_or_opp. - - rewrite EQn, EQ, opp_inj_wd, eq_opp_l, or_comm. apply abs_eq_or_opp. -Qed. - -Lemma abs_lt : forall a b, abs a < b <-> -b < a < b. -Proof. - intros a b. - destruct (abs_spec a) as [[LE EQ]|[LT EQ]]; rewrite EQ; clear EQ. - - split; try split; try destruct 1; try order. - apply lt_le_trans with 0; trivial. apply opp_neg_pos; order. - - rewrite opp_lt_mono, opp_involutive. - split; try split; try destruct 1; try order. - apply lt_le_trans with 0; trivial. apply opp_nonpos_nonneg; order. -Qed. - -Lemma abs_le : forall a b, abs a <= b <-> -b <= a <= b. -Proof. - intros a b. - destruct (abs_spec a) as [[LE EQ]|[LT EQ]]; rewrite EQ; clear EQ. - - split; try split; try destruct 1; try order. - apply le_trans with 0; trivial. apply opp_nonpos_nonneg; order. - - rewrite opp_le_mono, opp_involutive. - split; try split; try destruct 1; try order. - apply le_trans with 0. - + order. - + apply opp_nonpos_nonneg; order. -Qed. - -(** Triangular inequality *) - -Lemma abs_triangle : forall n m, abs (n + m) <= abs n + abs m. -Proof. - intros n m. destruct_max n; destruct_max m. - - rewrite abs_eq. { apply le_refl. } now apply add_nonneg_nonneg. - - destruct_max (n+m); try rewrite opp_add_distr; - apply add_le_mono_l || apply add_le_mono_r. - + apply le_trans with 0; auto. now rewrite opp_nonneg_nonpos. - + apply le_trans with 0; auto. now rewrite opp_nonpos_nonneg. - - destruct_max (n+m); try rewrite opp_add_distr; - apply add_le_mono_l || apply add_le_mono_r. - + apply le_trans with 0; auto. now rewrite opp_nonneg_nonpos. - + apply le_trans with 0; auto. now rewrite opp_nonpos_nonneg. - - rewrite abs_neq, opp_add_distr. { apply le_refl. } - now apply add_nonpos_nonpos. -Qed. - -Lemma abs_sub_triangle : forall n m, abs n - abs m <= abs (n-m). -Proof. - intros n m. - rewrite le_sub_le_add_l, add_comm. - rewrite <- (sub_simpl_r n m) at 1. - apply abs_triangle. -Qed. - -(** Absolute value and multiplication *) - -Lemma abs_mul : forall n m, abs (n * m) == abs n * abs m. -Proof. - assert (H : forall n m, 0<=n -> abs (n*m) == n * abs m). - { intros n m ?. destruct_max m. - - rewrite abs_eq. { apply eq_refl. } now apply mul_nonneg_nonneg. - - rewrite abs_neq, mul_opp_r. { reflexivity. } now apply mul_nonneg_nonpos . - } - intros n m. destruct_max n. - - now apply H. - - rewrite <- mul_opp_opp, H, abs_opp. { reflexivity. } - now apply opp_nonneg_nonpos. -Qed. - -Lemma abs_square : forall n, abs n * abs n == n * n. -Proof. - intros. rewrite <- abs_mul. apply abs_eq. apply le_0_square. -Qed. - -(** Some results about the sign function. *) - -Ltac destruct_sgn n := - let LT := fresh "LT" in - let EQ := fresh "EQ" in - let GT := fresh "GT" in - destruct (lt_trichotomy 0 n) as [LT|[EQ|GT]]; - [rewrite (sgn_pos n) by auto| - rewrite (sgn_null n) by auto with relations| - rewrite (sgn_neg n) by auto]. - -#[global] -Instance sgn_wd : Proper (eq==>eq) sgn. -Proof. - intros x y Hxy. destruct_sgn x. - - rewrite sgn_pos; auto with relations. rewrite <- Hxy; auto. - - rewrite sgn_null; auto with relations. rewrite <- Hxy; auto with relations. - - rewrite sgn_neg; auto with relations. rewrite <- Hxy; auto. -Qed. - -Lemma sgn_spec : forall n, - 0 < n /\ sgn n == 1 \/ - 0 == n /\ sgn n == 0 \/ - 0 > n /\ sgn n == -1. -Proof. - intros n. - destruct_sgn n; [left|right;left|right;right]; auto with relations. -Qed. - -Lemma sgn_0 : sgn 0 == 0. -Proof. - now apply sgn_null. -Qed. - -Lemma sgn_pos_iff : forall n, sgn n == 1 <-> 0 n==0. -Proof. - intros n; split; try apply sgn_null. destruct_sgn n; auto with relations. - - intros. elim (lt_neq 0 1); auto with relations. apply lt_0_1. - - intros. elim (lt_neq (-1) 0); auto. - rewrite opp_neg_pos. apply lt_0_1. -Qed. - -Lemma sgn_neg_iff : forall n, sgn n == -1 <-> n<0. -Proof. - intros n; split; try apply sgn_neg. destruct_sgn n; auto with relations. - - intros. elim (lt_neq (-1) 1); auto with relations. - apply lt_trans with 0. - + rewrite opp_neg_pos. apply lt_0_1. - + apply lt_0_1. - - intros. elim (lt_neq (-1) 0); auto with relations. - rewrite opp_neg_pos. apply lt_0_1. -Qed. - -Lemma sgn_opp : forall n, sgn (-n) == - sgn n. -Proof. - intros n. destruct_sgn n. - - apply sgn_neg. now rewrite opp_neg_pos. - - setoid_replace n with 0 by auto with relations. - rewrite opp_0. apply sgn_0. - - rewrite opp_involutive. apply sgn_pos. now rewrite opp_pos_neg. -Qed. - -Lemma sgn_nonneg : forall n, 0 <= sgn n <-> 0 <= n. -Proof. - intros n; split. - - destruct_sgn n; intros. - + now apply lt_le_incl. - + order. - + elim (lt_irrefl 0). apply lt_le_trans with 1; auto using lt_0_1. - now rewrite <- opp_nonneg_nonpos. - - rewrite lt_eq_cases; destruct 1. - + rewrite sgn_pos by auto. apply lt_le_incl, lt_0_1. - + rewrite sgn_null by auto with relations. apply le_refl. -Qed. - -Lemma sgn_nonpos : forall n, sgn n <= 0 <-> n <= 0. -Proof. - intros. rewrite <- 2 opp_nonneg_nonpos, <- sgn_opp. apply sgn_nonneg. -Qed. - -Lemma sgn_mul : forall n m, sgn (n*m) == sgn n * sgn m. -Proof. - intros n m. destruct_sgn n; nzsimpl. - - destruct_sgn m. - + apply sgn_pos. now apply mul_pos_pos. - + apply sgn_null. rewrite eq_mul_0; auto with relations. - + apply sgn_neg. now apply mul_pos_neg. - - apply sgn_null. rewrite eq_mul_0; auto with relations. - - destruct_sgn m; try rewrite mul_opp_opp; nzsimpl. - + apply sgn_neg. now apply mul_neg_pos. - + apply sgn_null. rewrite eq_mul_0; auto with relations. - + apply sgn_pos. now apply mul_neg_neg. -Qed. - -Lemma sgn_abs : forall n, n * sgn n == abs n. -Proof. - intros n. symmetry. - destruct_sgn n; try rewrite mul_opp_r; nzsimpl. - - apply abs_eq. now apply lt_le_incl. - - rewrite abs_0_iff; auto with relations. - - apply abs_neq. now apply lt_le_incl. -Qed. - -Lemma abs_sgn : forall n, abs n * sgn n == n. -Proof. - intros n. - destruct_sgn n; try rewrite mul_opp_r; nzsimpl; auto. - - apply abs_eq. now apply lt_le_incl. - - rewrite eq_opp_l. apply abs_neq. now apply lt_le_incl. -Qed. - -Lemma sgn_sgn : forall x, sgn (sgn x) == sgn x. -Proof. - intros x. - destruct (sgn_spec x) as [(LT,EQ)|[(EQ',EQ)|(LT,EQ)]]; rewrite EQ. - - apply sgn_pos, lt_0_1. - - now apply sgn_null. - - apply sgn_neg. rewrite opp_neg_pos. apply lt_0_1. -Qed. - -End ZSgnAbsProp. diff --git a/stdlib/theories/Numbers/Integer/Binary/ZBinary.v b/stdlib/theories/Numbers/Integer/Binary/ZBinary.v deleted file mode 100644 index 4703cf48ee06..000000000000 --- a/stdlib/theories/Numbers/Integer/Binary/ZBinary.v +++ /dev/null @@ -1,56 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* y<=x -> x=y]. *) - -Section TestOrder. - Let test : forall x y, x<=y -> y<=x -> x=y. - Proof. - z_order. - Defined. -End TestOrder. - -(** Z forms a ring *) - -(*Lemma Zring : ring_theory 0 1 NZadd NZmul NZsub Z.opp NZeq. -Proof. -constructor. -exact Zadd_0_l. -exact Zadd_comm. -exact Zadd_assoc. -exact Zmul_1_l. -exact Zmul_comm. -exact Zmul_assoc. -exact Zmul_add_distr_r. -intros; now rewrite Zadd_opp_minus. -exact Zadd_opp_r. -Qed. - -Add Ring ZR : Zring.*) diff --git a/stdlib/theories/Numbers/Integer/NatPairs/ZNatPairs.v b/stdlib/theories/Numbers/Integer/NatPairs/ZNatPairs.v deleted file mode 100644 index 176142166031..000000000000 --- a/stdlib/theories/Numbers/Integer/NatPairs/ZNatPairs.v +++ /dev/null @@ -1,361 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* ... -> A -> B] with [n] occurrences of [A] in this type. *) - -#[deprecated(since="8.19", note="Please step up to maintain NaryFunctions.v if you need it.")] -Fixpoint nfun A n B := - match n with - | O => B - | S n => A -> (nfun A n B) - end. - -#[deprecated(since="8.19", note="Please step up to maintain NaryFunctions.v if you need it.")] -Notation " A ^^ n --> B " := (nfun A n B) - (at level 50, n at next level) : type_scope. - -(** [napply_cst _ _ a n f] iterates [n] times the application of a - particular constant [a] to the [n]-ary function [f]. *) - -#[deprecated(since="8.19", note="Please step up to maintain NaryFunctions.v if you need it.")] -Fixpoint napply_cst (A B:Type)(a:A) n : (A^^n-->B) -> B := - match n return (A^^n-->B) -> B with - | O => fun x => x - | S n => fun x => napply_cst _ _ a n (x a) - end. - - -(** A generic transformation from an n-ary function to another one.*) - -#[deprecated(since="8.19", note="Please step up to maintain NaryFunctions.v if you need it.")] -Fixpoint nfun_to_nfun (A B C:Type)(f:B -> C) n : - (A^^n-->B) -> (A^^n-->C) := - match n return (A^^n-->B) -> (A^^n-->C) with - | O => f - | S n => fun g a => nfun_to_nfun _ _ _ f n (g a) - end. - -(** [napply_except_last _ _ n f] expects [S n] arguments of type [A], - applies [n] of them to [f] and discards the last one. *) - -#[deprecated(since="8.19", note="Please step up to maintain NaryFunctions.v if you need it.")] -Fixpoint napply_except_last (A B:Type) (n : nat) (f : A^^n-->B) {struct n} : A^^S n-->B. -Proof. - destruct n. - - exact (fun _ => f). - - exact (fun arg => napply_except_last A B n (f arg)). -Defined. - -(** [napply_then_last _ _ a n f] expects [n] arguments of type [A], - applies them to [f] and then apply [a] to the result. *) - -#[deprecated(since="8.19", note="Please step up to maintain NaryFunctions.v if you need it.")] -Definition napply_then_last (A B:Type)(a:A) := - nfun_to_nfun A (A->B) B (fun fab => fab a). - -(** [napply_discard _ b n] expects [n] arguments, discards then, - and returns [b]. *) - -#[deprecated(since="8.19", note="Please step up to maintain NaryFunctions.v if you need it.")] -Fixpoint napply_discard (A B:Type)(b:B) n : A^^n-->B := - match n return A^^n-->B with - | O => b - | S n => fun _ => napply_discard _ _ b n - end. - -(** A fold function *) - -#[deprecated(since="8.19", note="Please step up to maintain NaryFunctions.v if you need it.")] -Fixpoint nfold A B (f:A->B->B)(b:B) n : (A^^n-->B) := - match n return (A^^n-->B) with - | O => b - | S n => fun a => (nfold _ _ f (f a b) n) - end. - - -(** [n]-ary products : [nprod A n] is [A*...*A*unit], - with [n] occurrences of [A] in this type. *) - -#[deprecated(since="8.19", note="Please step up to maintain NaryFunctions.v if you need it.")] -Fixpoint nprod A n : Type := match n with - | O => unit - | S n => (A * nprod A n)%type - end. - -#[deprecated(since="8.19", note="Please step up to maintain NaryFunctions.v if you need it.")] -Notation "A ^ n" := (nprod A n) : type_scope. - -(** [n]-ary curryfication / uncurryfication *) - -#[deprecated(since="8.19", note="Please step up to maintain NaryFunctions.v if you need it.")] -Fixpoint ncurry (A B:Type) n : (A^n -> B) -> (A^^n-->B) := - match n return (A^n -> B) -> (A^^n-->B) with - | O => fun x => x tt - | S n => fun f a => ncurry _ _ n (fun p => f (a,p)) - end. - -#[deprecated(since="8.19", note="Please step up to maintain NaryFunctions.v if you need it.")] -Fixpoint nuncurry (A B:Type) n : (A^^n-->B) -> (A^n -> B) := - match n return (A^^n-->B) -> (A^n -> B) with - | O => fun x _ => x - | S n => fun f p => let (x,p) := p in nuncurry _ _ n (f x) p - end. - -(** Earlier functions can also be defined via [ncurry/nuncurry]. - For instance : *) - -#[deprecated(since="8.19", note="Please step up to maintain NaryFunctions.v if you need it.")] -Definition nfun_to_nfun_bis A B C (f:B->C) n : - (A^^n-->B) -> (A^^n-->C) := - fun anb => ncurry _ _ n (fun an => f ((nuncurry _ _ n anb) an)). - -(** We can also us it to obtain another [fold] function, - equivalent to the previous one, but with a nicer expansion - (see for instance Int31.iszero). *) - -#[deprecated(since="8.19", note="Please step up to maintain NaryFunctions.v if you need it.")] -Fixpoint nfold_bis A B (f:A->B->B)(b:B) n : (A^^n-->B) := - match n return (A^^n-->B) with - | O => b - | S n => fun a => - nfun_to_nfun_bis _ _ _ (f a) n (nfold_bis _ _ f b n) - end. - -(** From [nprod] to [list] *) - -#[deprecated(since="8.19", note="Please step up to maintain NaryFunctions.v if you need it.")] -Fixpoint nprod_to_list (A:Type) n : A^n -> list A := - match n with - | O => fun _ => nil - | S n => fun p => let (x,p) := p in x::(nprod_to_list _ n p) - end. - -(** From [list] to [nprod] *) - -#[deprecated(since="8.19", note="Please step up to maintain NaryFunctions.v if you need it.")] -Fixpoint nprod_of_list (A:Type)(l:list A) : A^(length l) := - match l return A^(length l) with - | nil => tt - | x::l => (x, nprod_of_list _ l) - end. - -(** This gives an additional way to write the fold *) - -#[deprecated(since="8.19", note="Please step up to maintain NaryFunctions.v if you need it.")] -Definition nfold_list (A B:Type)(f:A->B->B)(b:B) n : (A^^n-->B) := - ncurry _ _ n (fun p => fold_right f b (nprod_to_list _ _ p)). diff --git a/stdlib/theories/Numbers/NatInt/NZAdd.v b/stdlib/theories/Numbers/NatInt/NZAdd.v deleted file mode 100644 index a4229a22eab1..000000000000 --- a/stdlib/theories/Numbers/NatInt/NZAdd.v +++ /dev/null @@ -1,124 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* n == m. -Proof. -intros n m p; nzinduct p. -- now nzsimpl. -- intro p. nzsimpl. now rewrite succ_inj_wd. -Qed. - -Theorem add_cancel_r : forall n m p, n + p == m + p <-> n == m. -Proof. -intros n m p. rewrite (add_comm n p), (add_comm m p). apply add_cancel_l. -Qed. - -Theorem add_shuffle0 : forall n m p, n+m+p == n+p+m. -Proof. -intros n m p. rewrite <- 2 add_assoc, add_cancel_l. apply add_comm. -Qed. - -Theorem add_shuffle1 : forall n m p q, (n + m) + (p + q) == (n + p) + (m + q). -Proof. -intros n m p q. rewrite 2 add_assoc, add_cancel_r. apply add_shuffle0. -Qed. - -Theorem add_shuffle2 : forall n m p q, (n + m) + (p + q) == (n + q) + (m + p). -Proof. -intros n m p q. rewrite (add_comm p). apply add_shuffle1. -Qed. - -Theorem add_shuffle3 : forall n m p, n + (m + p) == m + (n + p). -Proof. -intros n m p. now rewrite add_comm, <- add_assoc, (add_comm p). -Qed. - -Theorem sub_1_r : forall n, n - 1 == P n. -Proof. -intro n; now nzsimpl'. -Qed. - -Global Hint Rewrite sub_1_r : nz. - -End NZAddProp. diff --git a/stdlib/theories/Numbers/NatInt/NZAddOrder.v b/stdlib/theories/Numbers/NatInt/NZAddOrder.v deleted file mode 100644 index 7546755a49ff..000000000000 --- a/stdlib/theories/Numbers/NatInt/NZAddOrder.v +++ /dev/null @@ -1,177 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* p + n < p + m. -Proof. - intros n m p; nzinduct p. - now nzsimpl. - - intro p. nzsimpl. now rewrite <- succ_lt_mono. -Qed. - -Theorem add_lt_mono_r : forall n m p, n < m <-> n + p < m + p. -Proof. -intros n m p. rewrite (add_comm n p), (add_comm m p); apply add_lt_mono_l. -Qed. - -Theorem add_lt_mono : forall n m p q, n < m -> p < q -> n + p < m + q. -Proof. -intros n m p q H1 H2. -apply lt_trans with (m + p); -[now apply add_lt_mono_r | now apply add_lt_mono_l]. -Qed. - -Theorem add_le_mono_l : forall n m p, n <= m <-> p + n <= p + m. -Proof. - intros n m p; nzinduct p. - now nzsimpl. - - intro p. nzsimpl. now rewrite <- succ_le_mono. -Qed. - -Theorem add_le_mono_r : forall n m p, n <= m <-> n + p <= m + p. -Proof. -intros n m p. rewrite (add_comm n p), (add_comm m p); apply add_le_mono_l. -Qed. - -Theorem add_le_mono : forall n m p q, n <= m -> p <= q -> n + p <= m + q. -Proof. -intros n m p q H1 H2. -apply le_trans with (m + p); -[now apply add_le_mono_r | now apply add_le_mono_l]. -Qed. - -Theorem add_lt_le_mono : forall n m p q, n < m -> p <= q -> n + p < m + q. -Proof. -intros n m p q H1 H2. -apply lt_le_trans with (m + p); -[now apply add_lt_mono_r | now apply add_le_mono_l]. -Qed. - -Theorem add_le_lt_mono : forall n m p q, n <= m -> p < q -> n + p < m + q. -Proof. -intros n m p q H1 H2. -apply le_lt_trans with (m + p); -[now apply add_le_mono_r | now apply add_lt_mono_l]. -Qed. - -Theorem add_pos_pos : forall n m, 0 < n -> 0 < m -> 0 < n + m. -Proof. -intros n m H1 H2. rewrite <- (add_0_l 0). now apply add_lt_mono. -Qed. - -Theorem add_pos_nonneg : forall n m, 0 < n -> 0 <= m -> 0 < n + m. -Proof. -intros n m H1 H2. rewrite <- (add_0_l 0). now apply add_lt_le_mono. -Qed. - -Theorem add_nonneg_pos : forall n m, 0 <= n -> 0 < m -> 0 < n + m. -Proof. -intros n m H1 H2. rewrite <- (add_0_l 0). now apply add_le_lt_mono. -Qed. - -Theorem add_nonneg_nonneg : forall n m, 0 <= n -> 0 <= m -> 0 <= n + m. -Proof. -intros n m H1 H2. rewrite <- (add_0_l 0). now apply add_le_mono. -Qed. - -Theorem lt_add_pos_l : forall n m, 0 < n -> m < n + m. -Proof. -intros n m. rewrite (add_lt_mono_r 0 n m). now nzsimpl. -Qed. - -Theorem lt_add_pos_r : forall n m, 0 < n -> m < m + n. -Proof. -intros; rewrite add_comm; now apply lt_add_pos_l. -Qed. - -Theorem le_lt_add_lt : forall n m p q, n <= m -> p + m < q + n -> p < q. -Proof. -intros n m p q H1 H2. destruct (le_gt_cases q p); [| assumption]. -contradict H2. rewrite nlt_ge. now apply add_le_mono. -Qed. - -Theorem lt_le_add_lt : forall n m p q, n < m -> p + m <= q + n -> p < q. -Proof. -intros n m p q H1 H2. destruct (le_gt_cases q p); [| assumption]. -contradict H2. rewrite nle_gt. now apply add_le_lt_mono. -Qed. - -Theorem le_le_add_le : forall n m p q, n <= m -> p + m <= q + n -> p <= q. -Proof. -intros n m p q H1 H2. destruct (le_gt_cases p q); [assumption |]. -contradict H2. rewrite nle_gt. now apply add_lt_le_mono. -Qed. - -Theorem add_lt_cases : forall n m p q, n + m < p + q -> n < p \/ m < q. -Proof. -intros n m p q H; -destruct (le_gt_cases p n) as [H1 | H1]; [| now left]. -destruct (le_gt_cases q m) as [H2 | H2]; [| now right]. -contradict H; rewrite nlt_ge. now apply add_le_mono. -Qed. - -Theorem add_le_cases : forall n m p q, n + m <= p + q -> n <= p \/ m <= q. -Proof. -intros n m p q H. -destruct (le_gt_cases n p) as [H1 | H1]. - now left. -- destruct (le_gt_cases m q) as [H2 | H2]. + now right. - + contradict H; rewrite nle_gt. now apply add_lt_mono. -Qed. - -Theorem add_neg_cases : forall n m, n + m < 0 -> n < 0 \/ m < 0. -Proof. -intros n m H; apply add_lt_cases; now nzsimpl. -Qed. - -Theorem add_pos_cases : forall n m, 0 < n + m -> 0 < n \/ 0 < m. -Proof. -intros n m H; apply add_lt_cases; now nzsimpl. -Qed. - -Theorem add_nonpos_cases : forall n m, n + m <= 0 -> n <= 0 \/ m <= 0. -Proof. -intros n m H; apply add_le_cases; now nzsimpl. -Qed. - -Theorem add_nonneg_cases : forall n m, 0 <= n + m -> 0 <= n \/ 0 <= m. -Proof. -intros n m H; apply add_le_cases; now nzsimpl. -Qed. - -(** Subtraction *) - -(** We can prove the existence of a subtraction of any number by - a smaller one *) - -Lemma le_exists_sub : forall n m, n<=m -> exists p, m == p+n /\ 0<=p. -Proof. - intros n m H. apply le_ind with (4:=H). - solve_proper. - - exists 0; nzsimpl; split; order. - - clear m H. intros m H (p & EQ & LE). exists (S p). - split. + nzsimpl. now f_equiv. + now apply le_le_succ_r. -Qed. - -(** For the moment, it doesn't seem possible to relate - this existing subtraction with [sub]. -*) - -End NZAddOrderProp. diff --git a/stdlib/theories/Numbers/NatInt/NZAxioms.v b/stdlib/theories/Numbers/NatInt/NZAxioms.v deleted file mode 100644 index a024c34009f9..000000000000 --- a/stdlib/theories/Numbers/NatInt/NZAxioms.v +++ /dev/null @@ -1,264 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* t -> Prop. - Parameter eq_equiv : Equivalence eq. - Parameter zero : t. - Parameter succ : t -> t. - Parameter pred : t -> t. - Parameter succ_wd : Proper (eq ==> eq) succ. - Parameter pred_wd : Proper (eq ==> eq) pred. - Parameter pred_succ : forall n : t, eq (pred (succ n)) n. - Parameter bi_induction : - forall A : t -> Prop, - Proper (eq ==> iff) A -> - A zero -> (forall n : t, A n <-> A (succ n)) -> forall n : t, A n. - Parameter one : t. - Parameter two : t. - Parameter one_succ : eq one (succ zero). - Parameter two_succ : eq two (succ one). - Parameter lt : t -> t -> Prop. - Parameter le : t -> t -> Prop. - Parameter lt_wd : Proper (eq ==> eq ==> iff) lt. - Parameter lt_eq_cases : forall n m : t, le n m <-> lt n m \/ eq n m. - Parameter lt_irrefl : forall n : t, ~ lt n n. - Parameter lt_succ_r : forall n m : t, lt n (succ m) <-> le n m. - Parameter add : t -> t -> t. - Parameter sub : t -> t -> t. - Parameter mul : t -> t -> t. - Parameter add_wd : Proper (eq ==> eq ==> eq) add. - Parameter sub_wd : Proper (eq ==> eq ==> eq) sub. - Parameter mul_wd : Proper (eq ==> eq ==> eq) mul. - Parameter add_0_l : forall n : t, eq (add zero n) n. - Parameter add_succ_l : - forall n m : t, eq (add (succ n) m) (succ (add n m)). - Parameter sub_0_r : forall n : t, eq (sub n zero) n. - Parameter sub_succ_r : - forall n m : t, eq (sub n (succ m)) (pred (sub n m)). - Parameter mul_0_l : forall n : t, eq (mul zero n) zero. - Parameter mul_succ_l : - forall n m : t, eq (mul (succ n) m) (add (mul n m) m). - Parameter max : t -> t -> t. - Parameter max_l : forall x y : t, le y x -> eq (max x y) x. - Parameter max_r : forall x y : t, le x y -> eq (max x y) y. - Parameter min : t -> t -> t. - Parameter min_l : forall x y : t, le x y -> eq (min x y) x. - Parameter min_r : forall x y : t, le y x -> eq (min x y) y. - Parameter compare : t -> t -> comparison. - Parameter compare_spec : - forall x y : t, CompareSpec (eq x y) (lt x y) (lt y x) (compare x y). - End -]] - *) - -(** ** Axiomatization of a domain with [zero], [succ], [pred] and a bi-directional induction principle. *) - -(* NB: This was Pierre Letouzey's conclusion in the (now deprecated) NZDomain - file. *) -(** We require [P (S n) = n] but not the other way around, since this domain - is meant to be either N or Z. In fact it can be a few other things, - - S is always injective, P is always surjective (thanks to [pred_succ]). - - I) If S is not surjective, we have an initial point, which is unique. - This bottom is below zero: we have N shifted (or not) to the left. - P cannot be injective: P init = P (S (P init)). - (P init) can be arbitrary. - - II) If S is surjective, we have [forall n, S (P n) = n], S and P are - bijective and reciprocal. - - IIa) if [exists k<>O, 0 == S^k 0], then we have a cyclic structure Z/nZ - IIb) otherwise, we have Z -*) - -(** The [Typ] module type in [Equalities] only has a parameter [t : Type]. *) - -Module Type ZeroSuccPred (Import T:Typ). - Parameter Inline(20) zero : t. - Parameter Inline(50) succ : t -> t. - Parameter Inline pred : t -> t. -End ZeroSuccPred. - -Module Type ZeroSuccPredNotation (T:Typ)(Import NZ:ZeroSuccPred T). - Notation "0" := zero. - Notation S := succ. - Notation P := pred. -End ZeroSuccPredNotation. - -Module Type ZeroSuccPred' (T:Typ) := - ZeroSuccPred T <+ ZeroSuccPredNotation T. - -(** The [Eq'] module type in [Equalities] is a [Type] [t] with a binary predicate - [eq] denoted [==]. The negation of [==] is denoted [~=]. *) - -Module Type IsNZDomain (Import E:Eq')(Import NZ:ZeroSuccPred' E). -#[global] - Declare Instance succ_wd : Proper (eq ==> eq) S. -#[global] - Declare Instance pred_wd : Proper (eq ==> eq) P. - Axiom pred_succ : forall n, P (S n) == n. - Axiom bi_induction : - forall A : t -> Prop, Proper (eq==>iff) A -> - A 0 -> (forall n, A n <-> A (S n)) -> forall n, A n. -End IsNZDomain. - -(** ** Axiomatization of some more constants *) - -(** Simply denoting "1" for (S 0) and so on works ok when implementing - by [nat], but leaves some ([N.succ N0]) when implementing by [N]. -*) - -Module Type OneTwo (Import T:Typ). - Parameter Inline(20) one two : t. -End OneTwo. - -Module Type OneTwoNotation (T:Typ)(Import NZ:OneTwo T). - Notation "1" := one. - Notation "2" := two. -End OneTwoNotation. - -Module Type OneTwo' (T:Typ) := OneTwo T <+ OneTwoNotation T. - -Module Type IsOneTwo (E:Eq')(Z:ZeroSuccPred' E)(O:OneTwo' E). - Import E Z O. - Axiom one_succ : 1 == S 0. - Axiom two_succ : 2 == S 1. -End IsOneTwo. - -Module Type NZDomainSig := - EqualityType <+ ZeroSuccPred <+ IsNZDomain <+ OneTwo <+ IsOneTwo. -Module Type NZDomainSig' := - EqualityType' <+ ZeroSuccPred' <+ IsNZDomain <+ OneTwo' <+ IsOneTwo. - -(** At this point, a module implementing [NZDomainSig] has : -- two unary operators [pred] and [succ] such that - [forall n, pred (succ n) = n]. -- a bidirectional induction principle -- three constants [0], [1 = S 0], [2 = S 1] -*) - -(** ** Axiomatization of basic operations : [+] [-] [*] *) - -Module Type AddSubMul (Import T:Typ). - Parameters Inline add sub mul : t -> t -> t. -End AddSubMul. - -Module Type AddSubMulNotation (T:Typ)(Import NZ:AddSubMul T). - Notation "x + y" := (add x y). - Notation "x - y" := (sub x y). - Notation "x * y" := (mul x y). -End AddSubMulNotation. - -Module Type AddSubMul' (T:Typ) := AddSubMul T <+ AddSubMulNotation T. - -Module Type IsAddSubMul (Import E:NZDomainSig')(Import NZ:AddSubMul' E). -#[global] - Declare Instance add_wd : Proper (eq ==> eq ==> eq) add. -#[global] - Declare Instance sub_wd : Proper (eq ==> eq ==> eq) sub. -#[global] - Declare Instance mul_wd : Proper (eq ==> eq ==> eq) mul. - Axiom add_0_l : forall n, 0 + n == n. - Axiom add_succ_l : forall n m, (S n) + m == S (n + m). - Axiom sub_0_r : forall n, n - 0 == n. - Axiom sub_succ_r : forall n m, n - (S m) == P (n - m). - Axiom mul_0_l : forall n, 0 * n == 0. - Axiom mul_succ_l : forall n m, S n * m == n * m + m. -End IsAddSubMul. - -Module Type NZBasicFunsSig := NZDomainSig <+ AddSubMul <+ IsAddSubMul. -Module Type NZBasicFunsSig' := NZDomainSig' <+ AddSubMul' <+IsAddSubMul. - -(** Old name for the same interface: *) - -Module Type NZAxiomsSig := NZBasicFunsSig. -Module Type NZAxiomsSig' := NZBasicFunsSig'. - -(** ** Axiomatization of order *) - -(** The module type [HasLt] (resp. [HasLe]) is just a type equipped with - a relation [lt] (resp. [le]) in [Prop]. *) -Module Type NZOrd := NZDomainSig <+ HasLt <+ HasLe. -Module Type NZOrd' := NZDomainSig' <+ HasLt <+ HasLe <+ - LtNotation <+ LeNotation <+ LtLeNotation. - -Module Type IsNZOrd (Import NZ : NZOrd'). -#[global] - Declare Instance lt_wd : Proper (eq ==> eq ==> iff) lt. - Axiom lt_eq_cases : forall n m, n <= m <-> n < m \/ n == m. - Axiom lt_irrefl : forall n, ~ (n < n). - Axiom lt_succ_r : forall n m, n < S m <-> n <= m. -End IsNZOrd. - -(** NB: the compatibility of [le] can be proved later from [lt_wd] - and [lt_eq_cases] *) - -Module Type NZOrdSig := NZOrd <+ IsNZOrd. -Module Type NZOrdSig' := NZOrd' <+ IsNZOrd. - -(** Everything together : *) - -(** The [HasMinMax] module type is a type with [min] and [max] operators - consistent with [le]. *) - -Module Type NZOrdAxiomsSig <: NZBasicFunsSig <: NZOrdSig - := NZOrdSig <+ AddSubMul <+ IsAddSubMul <+ HasMinMax. -Module Type NZOrdAxiomsSig' <: NZOrdAxiomsSig - := NZOrdSig' <+ AddSubMul' <+ IsAddSubMul <+ HasMinMax. - - -(** Same, plus a comparison function. *) - -(** The [HasCompare] module type requires a comparison function in type - [comparison] consistent with [eq] and [lt]. In particular, this imposes - that the order is decidable. -*) - -Module Type NZDecOrdSig := NZOrdSig <+ HasCompare. -Module Type NZDecOrdSig' := NZOrdSig' <+ HasCompare. - -Module Type NZDecOrdAxiomsSig := NZOrdAxiomsSig <+ HasCompare. -Module Type NZDecOrdAxiomsSig' := NZOrdAxiomsSig' <+ HasCompare. - -(** A square function *) - -(* TODO: why is this here? *) -Module Type NZSquare (Import NZ : NZBasicFunsSig'). - Parameter Inline square : t -> t. - Axiom square_spec : forall n, square n == n * n. -End NZSquare. diff --git a/stdlib/theories/Numbers/NatInt/NZBase.v b/stdlib/theories/Numbers/NatInt/NZBase.v deleted file mode 100644 index f2737611b0da..000000000000 --- a/stdlib/theories/Numbers/NatInt/NZBase.v +++ /dev/null @@ -1,106 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* y==x. -Proof. -intros; split; symmetry; auto. -Qed. - -(* TODO: how register ~= (which is just a notation) as a Symmetric relation, - hence allowing "symmetry" tac ? *) - -Theorem neq_sym : forall n m, n ~= m -> m ~= n. -Proof. -intros n m H1 H2; symmetry in H2; false_hyp H2 H1. -Qed. - -(** We add entries in the [stepl] and [stepr] databases. *) - -Theorem eq_stepl : forall x y z, x == y -> x == z -> z == y. -Proof. -intros x y z H1 H2; now rewrite <- H1. -Qed. - -Declare Left Step eq_stepl. -(* The right step lemma is just the transitivity of eq *) -Declare Right Step (@Equivalence_Transitive _ _ eq_equiv). - -Theorem succ_inj : forall n1 n2, S n1 == S n2 -> n1 == n2. -Proof. -intros n1 n2 H. -apply pred_wd in H. now do 2 rewrite pred_succ in H. -Qed. - -(* The following theorem is useful as an equivalence for proving -bidirectional induction steps *) -Theorem succ_inj_wd : forall n1 n2, S n1 == S n2 <-> n1 == n2. -Proof. -intros; split. -- apply succ_inj. -- intros. now f_equiv. -Qed. - -Theorem succ_inj_wd_neg : forall n m, S n ~= S m <-> n ~= m. -Proof. -intros; now rewrite succ_inj_wd. -Qed. - -(* We cannot prove that the predecessor is injective, nor that it is -left-inverse to the successor at this point *) - -Section CentralInduction. - -Variable A : t -> Prop. -Hypothesis A_wd : Proper (eq==>iff) A. - -Theorem central_induction : - forall z, A z -> - (forall n, A n <-> A (S n)) -> - forall n, A n. -Proof. -intros z Base Step; revert Base; pattern z; apply bi_induction. -- solve_proper. -- intro; now apply bi_induction. -- intro n; pose proof (Step n); tauto. -Qed. - -End CentralInduction. - -Tactic Notation "nzinduct" ident(n) := - induction_maker n ltac:(apply bi_induction). - -Tactic Notation "nzinduct" ident(n) constr(u) := - induction_maker n ltac:(apply (fun A A_wd => central_induction A A_wd u)). - -End NZBaseProp. diff --git a/stdlib/theories/Numbers/NatInt/NZBits.v b/stdlib/theories/Numbers/NatInt/NZBits.v deleted file mode 100644 index 89d5941f5564..000000000000 --- a/stdlib/theories/Numbers/NatInt/NZBits.v +++ /dev/null @@ -1,67 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* t -> bool. - Parameters Inline shiftl shiftr land lor ldiff lxor : t -> t -> t. - Parameter Inline div2 : t -> t. -End Bits. - -Module Type BitsNotation (Import A : Typ)(Import B : Bits A). - Notation "a .[ n ]" := (testbit a n) (at level 5, format "a .[ n ]"). - Infix ">>" := shiftr (at level 30, no associativity). - Infix "<<" := shiftl (at level 30, no associativity). -End BitsNotation. - -Module Type Bits' (A:Typ) := Bits A <+ BitsNotation A. - -Module Type NZBitsSpec - (Import A : NZOrdAxiomsSig')(Import B : Bits' A). - -#[global] - Declare Instance testbit_wd : Proper (eq==>eq==>Logic.eq) testbit. - Axiom testbit_odd_0 : forall a, (2*a+1).[0] = true. - Axiom testbit_even_0 : forall a, (2*a).[0] = false. - Axiom testbit_odd_succ : forall a n, 0<=n -> (2*a+1).[S n] = a.[n]. - Axiom testbit_even_succ : forall a n, 0<=n -> (2*a).[S n] = a.[n]. - Axiom testbit_neg_r : forall a n, n<0 -> a.[n] = false. - - Axiom shiftr_spec : forall a n m, 0<=m -> (a >> n).[m] = a.[m+n]. - Axiom shiftl_spec_high : forall a n m, 0<=m -> n<=m -> (a << n).[m] = a.[m-n]. - Axiom shiftl_spec_low : forall a n m, m (a << n).[m] = false. - - Axiom land_spec : forall a b n, (land a b).[n] = a.[n] && b.[n]. - Axiom lor_spec : forall a b n, (lor a b).[n] = a.[n] || b.[n]. - Axiom ldiff_spec : forall a b n, (ldiff a b).[n] = a.[n] && negb b.[n]. - Axiom lxor_spec : forall a b n, (lxor a b).[n] = xorb a.[n] b.[n]. - Axiom div2_spec : forall a, div2 a == a >> 1. - -End NZBitsSpec. - -Module Type NZBits (A:NZOrdAxiomsSig) := Bits A <+ NZBitsSpec A. -Module Type NZBits' (A:NZOrdAxiomsSig) := Bits' A <+ NZBitsSpec A. - -(** In the functor of properties will also be defined: - - [setbit : t -> t -> t ] defined as [lor a (1< t -> t ] defined as [ldiff a (1< t], the number with [n] initial true bits, - corresponding to [2^n - 1]. - - a logical complement [lnot]. For integer numbers it will - be a [t->t], doing a swap of all bits, while on natural - numbers, it will be a bounded complement [t->t->t], swapping - only the first [n] bits. -*) - -(** For the moment, no shared properties about NZ here, - since properties and proofs for N and Z are quite different *) diff --git a/stdlib/theories/Numbers/NatInt/NZDiv.v b/stdlib/theories/Numbers/NatInt/NZDiv.v deleted file mode 100644 index e1432ad1a5c6..000000000000 --- a/stdlib/theories/Numbers/NatInt/NZDiv.v +++ /dev/null @@ -1,569 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* t -> t. -End DivMod. - -Module Type DivModNotation (A : Typ)(Import B : DivMod A). - Infix "/" := div. - Infix "mod" := modulo (at level 40, no associativity). -End DivModNotation. - -Module Type DivMod' (A : Typ) := DivMod A <+ DivModNotation A. - -Module Type NZDivSpec (Import A : NZOrdAxiomsSig')(Import B : DivMod' A). -#[global] - Declare Instance div_wd : Proper (eq==>eq==>eq) div. -#[global] - Declare Instance mod_wd : Proper (eq==>eq==>eq) modulo. - Axiom div_mod : forall a b, b ~= 0 -> a == b*(a/b) + (a mod b). - Axiom mod_bound_pos : forall a b, 0<=a -> 0 0 <= a mod b < b. -End NZDivSpec. - -(** Euclidean Division with a / 0 == 0 and a mod 0 == a *) - -Module Type NZDivSpec0 (Import A : Eq')(Import B : ZeroSuccPred' A)(Import C : DivMod' A). - Axiom div_0_r : forall a, a / 0 == 0. - Axiom mod_0_r : forall a, a mod 0 == a. -End NZDivSpec0. - -(** The different divisions will only differ in the conditions - they impose on [modulo]. For NZ, we have only described the - behavior on positive numbers. -*) - -Module Type NZDiv (A : NZOrdAxiomsSig) := DivMod A <+ NZDivSpec A. -Module Type NZDiv' (A : NZOrdAxiomsSig) := NZDiv A <+ DivModNotation A. - -Module Type NZDivProp - (Import A : NZOrdAxiomsSig') - (Import B : NZDiv' A) - (Import C : NZMulOrderProp A). - -(** Uniqueness theorems *) - -Theorem div_mod_unique : - forall b q1 q2 r1 r2, 0<=r1 0<=r2 - b*q1+r1 == b*q2+r2 -> q1 == q2 /\ r1 == r2. -Proof. -intros b. -assert (U : forall q1 q2 r1 r2, - b*q1+r1 == b*q2+r2 -> 0<=r1 0<=r2 -> q1 False). -- intros q1 q2 r1 r2 EQ LT Hr1 Hr2. - contradict EQ. - apply lt_neq. - apply lt_le_trans with (b*q1+b). - + rewrite <- add_lt_mono_l. tauto. - + apply le_trans with (b*q2). - * rewrite mul_comm, <- mul_succ_l, mul_comm. - apply mul_le_mono_nonneg_l; intuition; try order. - rewrite le_succ_l; auto. - * rewrite <- (add_0_r (b*q2)) at 1. - rewrite <- add_le_mono_l. tauto. - -- intros q1 q2 r1 r2 Hr1 Hr2 EQ; destruct (lt_trichotomy q1 q2) as [LT|[EQ'|GT]]. - + elim (U q1 q2 r1 r2); intuition. - + split; auto. rewrite EQ' in EQ. rewrite add_cancel_l in EQ; auto. - + elim (U q2 q1 r2 r1); intuition auto with relations. -Qed. - -Theorem div_unique: - forall a b q r, 0<=a -> 0<=r - a == b*q + r -> q == a/b. -Proof. -intros a b q r Ha (Hb,Hr) EQ. -destruct (div_mod_unique b q (a/b) r (a mod b)); auto. -- apply mod_bound_pos; order. -- rewrite <- div_mod; order. -Qed. - -Theorem mod_unique: - forall a b q r, 0<=a -> 0<=r - a == b*q + r -> r == a mod b. -Proof. -intros a b q r Ha (Hb,Hr) EQ. -destruct (div_mod_unique b q (a/b) r (a mod b)); auto. -- apply mod_bound_pos; order. -- rewrite <- div_mod; order. -Qed. - -Theorem div_unique_exact a b q: - 0<=a -> 0 a == b*q -> q == a/b. -Proof. - intros Ha Hb H. apply div_unique with 0; nzsimpl; now try split. -Qed. - -(** A division by itself returns 1 *) - -Lemma div_same : forall a, 0 a/a == 1. -Proof. -intros. symmetry. apply div_unique_exact; nzsimpl; order. -Qed. - -Lemma mod_same : forall a, 0 a mod a == 0. -Proof. -intros. symmetry. -apply mod_unique with 1; intuition auto; try order. -now nzsimpl. -Qed. - -(** A division of a small number by a bigger one yields zero. *) - -Theorem div_small: forall a b, 0<=a a/b == 0. -Proof. -intros a b ?. symmetry. -apply div_unique with a; intuition; try order. -now nzsimpl. -Qed. - -(** Same situation, in term of modulo: *) - -Theorem mod_small: forall a b, 0<=a a mod b == a. -Proof. -intros. symmetry. -apply mod_unique with 0; intuition; try order. -now nzsimpl. -Qed. - -(** * Basic values of divisions and modulo. *) - -Lemma div_0_l: forall a, 0 0/a == 0. -Proof. -intros; apply div_small; split; order. -Qed. - -Lemma mod_0_l: forall a, 0 0 mod a == 0. -Proof. -intros; apply mod_small; split; order. -Qed. - -Lemma div_1_r: forall a, 0<=a -> a/1 == a. -Proof. -intros. symmetry. apply div_unique_exact; nzsimpl; order'. -Qed. - -Lemma mod_1_r: forall a, 0<=a -> a mod 1 == 0. -Proof. -intros a ?. symmetry. -apply mod_unique with a; try split; try order; try apply lt_0_1. -now nzsimpl. -Qed. - -Lemma div_1_l: forall a, 1 1/a == 0. -Proof. -intros; apply div_small; split; auto. apply le_0_1. -Qed. - -Lemma mod_1_l: forall a, 1 1 mod a == 1. -Proof. -intros; apply mod_small; split; auto. apply le_0_1. -Qed. - -Lemma div_mul : forall a b, 0<=a -> 0 (a*b)/b == a. -Proof. -intros; symmetry. apply div_unique_exact; trivial. -- apply mul_nonneg_nonneg; order. -- apply mul_comm. -Qed. - -Lemma mod_mul : forall a b, 0<=a -> 0 (a*b) mod b == 0. -Proof. -intros a b ? ?; symmetry. -apply mod_unique with a; try split; try order. -- apply mul_nonneg_nonneg; order. -- nzsimpl; apply mul_comm. -Qed. - - -(** * Order results about mod and div *) - -(** A modulo cannot grow beyond its starting point. *) - -Theorem mod_le: forall a b, 0<=a -> 0 a mod b <= a. -Proof. -intros a b ? ?. destruct (le_gt_cases b a). -- apply le_trans with b; auto. - apply lt_le_incl. destruct (mod_bound_pos a b); auto. -- rewrite lt_eq_cases; right. - apply mod_small; auto. -Qed. - - -(* Division of positive numbers is positive. *) - -Lemma div_pos: forall a b, 0<=a -> 0 0 <= a/b. -Proof. -intros a b ? ?. -rewrite (mul_le_mono_pos_l _ _ b); auto; nzsimpl. -rewrite (add_le_mono_r _ _ (a mod b)). -rewrite <- div_mod by order. -nzsimpl. -apply mod_le; auto. -Qed. - -Lemma div_str_pos : forall a b, 0 0 < a/b. -Proof. -intros a b (Hb,Hab). -assert (LE : 0 <= a/b) by (apply div_pos; order). -assert (MOD : a mod b < b) by (destruct (mod_bound_pos a b); order). -rewrite lt_eq_cases in LE; destruct LE as [LT|EQ]; auto. -exfalso; revert Hab. -rewrite (div_mod a b), <-EQ; nzsimpl; order. -Qed. - -Lemma div_small_iff : forall a b, 0<=a -> 0 (a/b==0 <-> a 0 (a mod b == a <-> a 0 (0 b<=a). -Proof. -intros a b Ha Hb; split; intros Hab. -- destruct (lt_ge_cases a b) as [LT|LE]; auto. - rewrite <- div_small_iff in LT; order. -- apply div_str_pos; auto. -Qed. - - -(** As soon as the divisor is strictly greater than 1, - the division is strictly decreasing. *) - -Lemma div_lt : forall a b, 0 1 a/b < a. -Proof. -intros a b ? ?. -assert (0 < b) by (apply lt_trans with 1; auto using lt_0_1). -destruct (lt_ge_cases a b). -- rewrite div_small; try split; order. -- rewrite (div_mod a b) at 2 by order. - apply lt_le_trans with (b*(a/b)). - + rewrite <- (mul_1_l (a/b)) at 1. - rewrite <- mul_lt_mono_pos_r; auto. - apply div_str_pos; auto. - + rewrite <- (add_0_r (b*(a/b))) at 1. - rewrite <- add_le_mono_l. destruct (mod_bound_pos a b); order. -Qed. - -(** [le] is compatible with a positive division. *) - -Lemma div_le_mono : forall a b c, 0 0<=a<=b -> a/c <= b/c. -Proof. -intros a b c Hc (Ha,Hab). -rewrite lt_eq_cases in Hab. destruct Hab as [LT|EQ]; - [|rewrite EQ; order]. -rewrite <- lt_succ_r. -rewrite (mul_lt_mono_pos_l c) by order. -nzsimpl. -rewrite (add_lt_mono_r _ _ (a mod c)). -rewrite <- div_mod by order. -apply lt_le_trans with b; auto. -rewrite (div_mod b c) at 1 by order. -rewrite <- add_assoc, <- add_le_mono_l. -apply le_trans with (c+0). -- nzsimpl; destruct (mod_bound_pos b c); order. -- rewrite <- add_le_mono_l. destruct (mod_bound_pos a c); order. -Qed. - -(** The following two properties could be used as specification of div *) - -Lemma mul_div_le : forall a b, 0<=a -> 0 b*(a/b) <= a. -Proof. -intros a b ? ?. -rewrite (add_le_mono_r _ _ (a mod b)), <- div_mod by order. -rewrite <- (add_0_r a) at 1. -rewrite <- add_le_mono_l. destruct (mod_bound_pos a b); order. -Qed. - -Lemma mul_succ_div_gt : forall a b, 0<=a -> 0 a < b*(S (a/b)). -Proof. -intros a b ? ?. -rewrite (div_mod a b) at 1 by order. -rewrite (mul_succ_r). -rewrite <- add_lt_mono_l. -destruct (mod_bound_pos a b); auto. -Qed. - - -(** The previous inequality is exact iff the modulo is zero. *) - -Lemma div_exact : forall a b, 0<=a -> 0 (a == b*(a/b) <-> a mod b == 0). -Proof. -intros a b ? ?. rewrite (div_mod a b) at 1 by order. -rewrite <- (add_0_r (b*(a/b))) at 2. -apply add_cancel_l. -Qed. - -(** Some additional inequalities about div. *) - -Theorem div_lt_upper_bound: - forall a b q, 0<=a -> 0 a < b*q -> a/b < q. -Proof. -intros a b q ? ? ?. -rewrite (mul_lt_mono_pos_l b) by order. -apply le_lt_trans with a; auto. -apply mul_div_le; auto. -Qed. - -Theorem div_le_upper_bound: - forall a b q, 0<=a -> 0 a <= b*q -> a/b <= q. -Proof. -intros a b q ? ? ?. -rewrite (mul_le_mono_pos_l _ _ b) by order. -apply le_trans with a; auto. -apply mul_div_le; auto. -Qed. - -Theorem div_le_lower_bound: - forall a b q, 0<=a -> 0 b*q <= a -> q <= a/b. -Proof. -intros a b q Ha Hb H. -destruct (lt_ge_cases 0 q). -- rewrite <- (div_mul q b); try order. - apply div_le_mono; auto. - rewrite mul_comm; split; auto. - apply lt_le_incl, mul_pos_pos; auto. -- apply le_trans with 0; auto; apply div_pos; auto. -Qed. - -(** A division respects opposite monotonicity for the divisor *) - -Lemma div_le_compat_l: forall p q r, 0<=p -> 0 - p/r <= p/q. -Proof. - intros p q r Hp (Hq,Hqr). - apply div_le_lower_bound; auto. - rewrite (div_mod p r) at 2 by order. - apply le_trans with (r*(p/r)). - - apply mul_le_mono_nonneg_r; try order. - apply div_pos; order. - - rewrite <- (add_0_r (r*(p/r))) at 1. - rewrite <- add_le_mono_l. destruct (mod_bound_pos p r); order. -Qed. - - -(** * Relations between usual operations and mod and div *) - -Lemma mod_add : forall a b c, 0<=a -> 0<=a+b*c -> 0 - (a + b * c) mod c == a mod c. -Proof. - intros a b c ? ? ?. - symmetry. - apply mod_unique with (a/c+b); auto. - - apply mod_bound_pos; auto. - - rewrite mul_add_distr_l, add_shuffle0, <- div_mod by order. - now rewrite mul_comm. -Qed. - -Lemma div_add : forall a b c, 0<=a -> 0<=a+b*c -> 0 - (a + b * c) / c == a / c + b. -Proof. - intros a b c ? ? ?. - apply (mul_cancel_l _ _ c); try order. - apply (add_cancel_r _ _ ((a+b*c) mod c)). - rewrite <- div_mod, mod_add by order. - rewrite mul_add_distr_l, add_shuffle0, <- div_mod by order. - now rewrite mul_comm. -Qed. - -Lemma div_add_l: forall a b c, 0<=c -> 0<=a*b+c -> 0 - (a * b + c) / b == a + c / b. -Proof. - intros a b c. rewrite (add_comm _ c), (add_comm a). - intros. apply div_add; auto. -Qed. - -(** Cancellations. *) - -Lemma div_mul_cancel_r : forall a b c, 0<=a -> 0 0 - (a*c)/(b*c) == a/b. -Proof. - intros a b c ? ? ?. - symmetry. - apply div_unique with ((a mod b)*c). - - apply mul_nonneg_nonneg; order. - - split. - + apply mul_nonneg_nonneg; destruct (mod_bound_pos a b); order. - + rewrite <- mul_lt_mono_pos_r; auto. destruct (mod_bound_pos a b); auto. - - rewrite (div_mod a b) at 1 by order. - rewrite mul_add_distr_r. - rewrite add_cancel_r. - rewrite <- 2 mul_assoc. now rewrite (mul_comm c). -Qed. - -Lemma div_mul_cancel_l : forall a b c, 0<=a -> 0 0 - (c*a)/(c*b) == a/b. -Proof. - intros a b c ? ? ?. rewrite !(mul_comm c); apply div_mul_cancel_r; auto. -Qed. - -(** Operations modulo. *) - -Theorem mod_mod: forall a n, 0<=a -> 0 - (a mod n) mod n == a mod n. -Proof. - intros a n ? ?. destruct (mod_bound_pos a n); auto. now rewrite mod_small_iff. -Qed. - -Lemma mul_mod_idemp_l : forall a b n, 0<=a -> 0<=b -> 0 - ((a mod n)*b) mod n == (a*b) mod n. -Proof. - intros a b n Ha Hb Hn. symmetry. - generalize (mul_nonneg_nonneg _ _ Ha Hb). - rewrite (div_mod a n) at 1 2 by order. - rewrite add_comm, (mul_comm n), (mul_comm _ b). - rewrite mul_add_distr_l, mul_assoc. - intros. rewrite mod_add; auto. - - now rewrite mul_comm. - - apply mul_nonneg_nonneg; destruct (mod_bound_pos a n); auto. -Qed. - -Lemma mul_mod_idemp_r : forall a b n, 0<=a -> 0<=b -> 0 - (a*(b mod n)) mod n == (a*b) mod n. -Proof. - intros a b n ? ? ?. rewrite !(mul_comm a). apply mul_mod_idemp_l; auto. -Qed. - -Theorem mul_mod: forall a b n, 0<=a -> 0<=b -> 0 - (a * b) mod n == ((a mod n) * (b mod n)) mod n. -Proof. - intros a b n ? ? ?. rewrite mul_mod_idemp_l, mul_mod_idemp_r; trivial. - - reflexivity. - - now destruct (mod_bound_pos b n). -Qed. - -Lemma add_mod_idemp_l : forall a b n, 0<=a -> 0<=b -> 0 - ((a mod n)+b) mod n == (a+b) mod n. -Proof. - intros a b n Ha Hb Hn. symmetry. - generalize (add_nonneg_nonneg _ _ Ha Hb). - rewrite (div_mod a n) at 1 2 by order. - rewrite <- add_assoc, add_comm, mul_comm. - intros. rewrite mod_add; trivial. - reflexivity. - - apply add_nonneg_nonneg; auto. destruct (mod_bound_pos a n); auto. -Qed. - -Lemma add_mod_idemp_r : forall a b n, 0<=a -> 0<=b -> 0 - (a+(b mod n)) mod n == (a+b) mod n. -Proof. - intros a b n ? ? ?. rewrite !(add_comm a). apply add_mod_idemp_l; auto. -Qed. - -Theorem add_mod: forall a b n, 0<=a -> 0<=b -> 0 - (a+b) mod n == (a mod n + b mod n) mod n. -Proof. - intros a b n ? ? ?. rewrite add_mod_idemp_l, add_mod_idemp_r; trivial. - - reflexivity. - - now destruct (mod_bound_pos b n). -Qed. - -Lemma div_div : forall a b c, 0<=a -> 0 0 - (a/b)/c == a/(b*c). -Proof. - intros a b c Ha Hb Hc. - apply div_unique with (b*((a/b) mod c) + a mod b); trivial. - (* begin 0<= ... 0 0 - a mod (b*c) == a mod b + b*((a/b) mod c). -Proof. - intros a b c Ha Hb Hc. - apply add_cancel_l with (b*c*(a/(b*c))). - rewrite <- div_mod by (apply neq_mul_0; split; order). - rewrite <- div_div by trivial. - rewrite add_assoc, add_shuffle0, <- mul_assoc, <- mul_add_distr_l. - rewrite <- div_mod by order. - apply div_mod; order. -Qed. - -Lemma add_mul_mod_distr_l: forall a b c d, 0<=a -> 0 0<=d - (c*a+d) mod (c*b) == c*(a mod b)+d. -Proof. - intros a b c d ? ? [? ?]. - assert (0 <= a*c) by (apply mul_nonneg_nonneg; order). - assert (0 <= a*c+d) by (apply add_nonneg_nonneg; order). - rewrite (mul_comm c a), mod_mul_r, add_mod, mod_mul, div_add_l; [|order ..]. - now rewrite ? add_0_l, div_small, add_0_r, ? (mod_small d c), (add_comm d). -Qed. - -Lemma add_mul_mod_distr_r: forall a b c d, 0<=a -> 0 0<=d - (a*c+d) mod (b*c) == (a mod b)*c+d. -Proof. - intros a b c d ? ? ?. now rewrite !(mul_comm _ c), add_mul_mod_distr_l. -Qed. - -Lemma mul_mod_distr_l: forall a b c, 0<=a -> 0 0 - (c*a) mod (c*b) == c * (a mod b). -Proof. - intros a b c ? ? ?. pose proof (E := add_mul_mod_distr_l a b c 0). - rewrite ? add_0_r in E. now apply E. -Qed. - -Lemma mul_mod_distr_r: forall a b c, 0<=a -> 0 0 - (a*c) mod (b*c) == (a mod b) * c. -Proof. - intros a b c ? ? ?. now rewrite !(mul_comm _ c), mul_mod_distr_l. -Qed. - -(** A last inequality: *) - -Theorem div_mul_le: - forall a b c, 0<=a -> 0 0<=c -> c*(a/b) <= (c*a)/b. -Proof. - intros a b c ? ? ?. - apply div_le_lower_bound; auto. - - apply mul_nonneg_nonneg; auto. - - rewrite mul_assoc, (mul_comm b c), <- mul_assoc. - apply mul_le_mono_nonneg_l; auto. - apply mul_div_le; auto. -Qed. - -(** mod is related to divisibility *) - -Lemma mod_divides : forall a b, 0<=a -> 0 - (a mod b == 0 <-> exists c, a == b*c). -Proof. - intros a b ? ?; split. - - intros. exists (a/b). rewrite div_exact; auto. - - intros (c,Hc). rewrite Hc, mul_comm. apply mod_mul; auto. - rewrite (mul_le_mono_pos_l _ _ b); auto. nzsimpl. order. -Qed. - -End NZDivProp. diff --git a/stdlib/theories/Numbers/NatInt/NZDomain.v b/stdlib/theories/Numbers/NatInt/NZDomain.v deleted file mode 100644 index 50bbcb2f7701..000000000000 --- a/stdlib/theories/Numbers/NatInt/NZDomain.v +++ /dev/null @@ -1,383 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* nat_rect _ x (fun _ => f) n). - -#[global] -Instance nat_rect_wd n {A} (R:relation A) : - Proper (R==>(R==>R)==>R) (fun x f => nat_rect (fun _ => _) x (fun _ => f) n). -Proof. -intros x y eq_xy f g eq_fg; induction n; [assumption | now apply eq_fg]. -Qed. - -Module NZDomainProp (Import NZ:NZDomainSig'). -Include NZBaseProp NZ. - -(** * Relationship between points thanks to [succ] and [pred]. *) - -(** For any two points, one is an iterated successor of the other. *) - -Lemma itersucc_or_itersucc n m : exists k, n == (S^k) m \/ m == (S^k) n. -Proof. -revert n. -apply central_induction with (z:=m). - { intros x y eq_xy; apply ex_iff_morphism. - intros n; apply or_iff_morphism. - + split; intros; etransitivity; try eassumption; now symmetry. - + split; intros; (etransitivity; [eassumption|]); [|symmetry]; - (eapply nat_rect_wd; [eassumption|apply succ_wd]). - } -- exists 0%nat. now left. -- intros n. split; intros [k [L|R]]. - + exists (Datatypes.S k). left. now apply succ_wd. - + destruct k as [|k]. - * simpl in R. exists 1%nat. left. now apply succ_wd. - * rewrite nat_rect_succ_r in R. exists k. now right. - + destruct k as [|k]; simpl in L. - * exists 1%nat. now right. - * apply succ_inj in L. exists k. now left. - + exists (Datatypes.S k). right. now rewrite nat_rect_succ_r. -Qed. - -(** Generalized version of [pred_succ] when iterating *) - -Lemma succ_swap_pred : forall k n m, n == (S^k) m -> m == (P^k) n. -Proof. -induction k. -- simpl; auto with *. -- simpl; intros. apply pred_wd in H. rewrite pred_succ in H. apply IHk in H; auto. - rewrite <- nat_rect_succ_r in H; auto. -Qed. - -(** From a given point, all others are iterated successors - or iterated predecessors. *) - -Lemma itersucc_or_iterpred : forall n m, exists k, n == (S^k) m \/ n == (P^k) m. -Proof. -intros n m. destruct (itersucc_or_itersucc n m) as (k,[H|H]). -- exists k; left; auto. -- exists k; right. apply succ_swap_pred; auto. -Qed. - -(** In particular, all points are either iterated successors of [0] - or iterated predecessors of [0] (or both). *) - -Lemma itersucc0_or_iterpred0 : - forall n, exists p:nat, n == (S^p) 0 \/ n == (P^p) 0. -Proof. - intros n. exact (itersucc_or_iterpred n 0). -Qed. - -(** * Study of initial point w.r.t. [succ] (if any). *) - -Definition initial n := forall m, n ~= S m. - -Lemma initial_alt : forall n, initial n <-> S (P n) ~= n. -Proof. - split. - - intros Bn EQ. symmetry in EQ. destruct (Bn _ EQ). - - intros NEQ m EQ. apply NEQ. rewrite EQ, pred_succ; auto with *. -Qed. - -Lemma initial_alt2 : forall n, initial n <-> ~exists m, n == S m. -Proof. firstorder. Qed. - -(** First case: let's assume such an initial point exists - (i.e. [S] isn't surjective)... *) - -Section InitialExists. -Hypothesis init : t. -Hypothesis Initial : initial init. - -(** ... then we have unicity of this initial point. *) - -Lemma initial_unique : forall m, initial m -> m == init. -Proof. -intros m Im. destruct (itersucc_or_itersucc init m) as (p,[H|H]). -- destruct p. - + now simpl in *. - + destruct (Initial _ H). -- destruct p. - + now simpl in *. - + destruct (Im _ H). -Qed. - -(** ... then all other points are descendant of it. *) - -Lemma initial_ancestor : forall m, exists p, m == (S^p) init. -Proof. -intros m. destruct (itersucc_or_itersucc init m) as (p,[H|H]). -- destruct p; simpl in *; auto. - + exists O; auto with *. - + destruct (Initial _ H). -- exists p; auto. -Qed. - -(** NB : We would like to have [pred n == n] for the initial element, - but nothing forces that. For instance we can have -3 as initial point, - and P(-3) = 2. A bit odd indeed, but legal according to [NZDomainSig]. - We can hence have [n == (P^k) m] without [exists k', m == (S^k') n]. -*) - -(** We need decidability of [eq] (or classical reasoning) for this: *) - -Section SuccPred. -Hypothesis eq_decidable : forall n m, n==m \/ n~=m. -Lemma succ_pred_approx : forall n, ~initial n -> S (P n) == n. -Proof. -intros n NB. rewrite initial_alt in NB. -destruct (eq_decidable (S (P n)) n); auto. -elim NB; auto. -Qed. -End SuccPred. -End InitialExists. - -(** Second case : let's suppose now [S] surjective, i.e. no initial point. *) - -Section InitialDontExists. - -Hypothesis succ_onto : forall n, exists m, n == S m. - -Lemma succ_onto_gives_succ_pred : forall n, S (P n) == n. -Proof. -intros n. destruct (succ_onto n) as (m,H). rewrite H, pred_succ; auto with *. -Qed. - -Lemma succ_onto_pred_injective : forall n m, P n == P m -> n == m. -Proof. -intros n m. intros H; apply succ_wd in H. -rewrite !succ_onto_gives_succ_pred in H; auto. -Qed. - -End InitialDontExists. - - -(** To summarize: - - S is always injective, P is always surjective (thanks to [pred_succ]). - - I) If S is not surjective, we have an initial point, which is unique. - This bottom is below zero: we have N shifted (or not) to the left. - P cannot be injective: P init = P (S (P init)). - (P init) can be arbitrary. - - II) If S is surjective, we have [forall n, S (P n) = n], S and P are - bijective and reciprocal. - - IIa) if [exists k<>O, 0 == S^k 0], then we have a cyclic structure Z/nZ - IIb) otherwise, we have Z -*) - - -(** * An alternative induction principle using [S] and [P]. *) - -(** It is weaker than [bi_induction]. For instance it cannot prove that - we can go from one point by many [S] _or_ many [P], but only by many - [S] mixed with many [P]. Think of a model with two copies of N: - - 0, 1=S 0, 2=S 1, ... - 0', 1'=S 0', 2'=S 1', ... - - and P 0 = 0' and P 0' = 0. -*) - -Lemma bi_induction_pred : - forall A : t -> Prop, Proper (eq==>iff) A -> - A 0 -> (forall n, A n -> A (S n)) -> (forall n, A n -> A (P n)) -> - forall n, A n. -Proof. -intros. apply bi_induction; auto. -clear n. intros n; split; auto. -intros G; apply H2 in G. rewrite pred_succ in G; auto. -Qed. - -Lemma central_induction_pred : - forall A : t -> Prop, Proper (eq==>iff) A -> forall n0, - A n0 -> (forall n, A n -> A (S n)) -> (forall n, A n -> A (P n)) -> - forall n, A n. -Proof. -intros. -assert (A 0). -- destruct (itersucc_or_iterpred 0 n0) as (k,[Hk|Hk]); rewrite Hk; clear Hk. - + clear H2. induction k; simpl in *; auto. - + clear H1. induction k; simpl in *; auto. -- apply bi_induction_pred; auto. -Qed. - -End NZDomainProp. - -(** We now focus on the translation from [nat] into [NZ]. - First, relationship with [0], [succ], [pred]. -*) - -Module NZOfNat (Import NZ:NZDomainSig'). - -Definition ofnat (n : nat) : t := (S^n) 0. - -Declare Scope ofnat. -Local Open Scope ofnat. -Notation "[ n ]" := (ofnat n) (at level 7) : ofnat. - -Lemma ofnat_zero : [O] == 0. -Proof. -reflexivity. -Qed. - -Lemma ofnat_succ : forall n, [Datatypes.S n] == succ [n]. -Proof. - now unfold ofnat. -Qed. - -Lemma ofnat_pred : forall n, n<>O -> [Peano.pred n] == P [n]. -Proof. - unfold ofnat. destruct n. - - destruct 1; auto. - - intros _. simpl. symmetry. apply pred_succ. -Qed. - -(** Since [P 0] can be anything in NZ (either [-1], [0], or even other - numbers, we cannot state previous lemma for [n=O]. *) - -End NZOfNat. - - -(** If we require in addition a strict order on NZ, we can prove that - [ofnat] is injective, and hence that NZ is infinite - (i.e. we ban Z/nZ models) *) - -Module NZOfNatOrd (Import NZ:NZOrdSig'). -Include NZOfNat NZ. -Include NZBaseProp NZ <+ NZOrderProp NZ. -Local Open Scope ofnat. - -Theorem ofnat_S_gt_0 : - forall n : nat, 0 < [Datatypes.S n]. -Proof. -unfold ofnat. -intros n; induction n as [| n IH]; simpl in *. -- apply lt_succ_diag_r. -- apply lt_trans with (S 0). - + apply lt_succ_diag_r. - + now rewrite <- succ_lt_mono. -Qed. - -Theorem ofnat_S_neq_0 : - forall n : nat, 0 ~= [Datatypes.S n]. -Proof. -intros. apply lt_neq, ofnat_S_gt_0. -Qed. - -Lemma ofnat_injective : forall n m, [n]==[m] -> n = m. -Proof. -induction n as [|n IH]; destruct m; auto. -- intros H; elim (ofnat_S_neq_0 _ H). -- intros H; symmetry in H; elim (ofnat_S_neq_0 _ H). -- intros. f_equal. apply IH. now rewrite <- succ_inj_wd. -Qed. - -Lemma ofnat_eq : forall n m, [n]==[m] <-> n = m. -Proof. - split. - - apply ofnat_injective. - - intros; now subst. -Qed. - -(* In addition, we can prove that [ofnat] preserves order. *) - -Lemma ofnat_lt : forall n m : nat, [n]<[m] <-> (n (n<=m)%nat. -Proof. -intros. rewrite lt_eq_cases, ofnat_lt, ofnat_eq. -split. -- destruct 1; subst; auto. - apply Nat.lt_le_incl; assumption. -- apply Nat.lt_eq_cases. -Qed. - -End NZOfNatOrd. - - -(** For basic operations, we can prove correspondence with - their counterpart in [nat]. *) - -Module NZOfNatOps (Import NZ:NZAxiomsSig'). -Include NZOfNat NZ. -Local Open Scope ofnat. - -Lemma ofnat_add_l : forall n m, [n]+m == (S^n) m. -Proof. - induction n; intros. - - apply add_0_l. - - rewrite ofnat_succ, add_succ_l. simpl. now f_equiv. -Qed. - -Lemma ofnat_add : forall n m, [n+m] == [n]+[m]. -Proof. - intros. rewrite ofnat_add_l. - induction n; simpl. - - reflexivity. - - now f_equiv. -Qed. - -Lemma ofnat_mul : forall n m, [n*m] == [n]*[m]. -Proof. - induction n; simpl; intros. - - symmetry. apply mul_0_l. - - rewrite Nat.add_comm. - rewrite ofnat_add, mul_succ_l. - now f_equiv. -Qed. - -Lemma ofnat_sub_r : forall n m, n-[m] == (P^m) n. -Proof. - induction m; simpl; intros. - - apply sub_0_r. - - rewrite sub_succ_r. now f_equiv. -Qed. - -Lemma ofnat_sub : forall n m, m<=n -> [n-m] == [n]-[m]. -Proof. - intros n m H. rewrite ofnat_sub_r. - revert n H. induction m. - - intros. - rewrite Nat.sub_0_r. now simpl. - - intros. - destruct n. - + inversion H. - + rewrite nat_rect_succ_r. - simpl. - etransitivity. - * apply IHm; apply <- Nat.succ_le_mono; assumption. - * eapply nat_rect_wd; [symmetry;apply pred_succ|apply pred_wd]. -Qed. - -End NZOfNatOps. diff --git a/stdlib/theories/Numbers/NatInt/NZGcd.v b/stdlib/theories/Numbers/NatInt/NZGcd.v deleted file mode 100644 index e420ca6e7bca..000000000000 --- a/stdlib/theories/Numbers/NatInt/NZGcd.v +++ /dev/null @@ -1,313 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* t -> t. -End Gcd. - -Module Type NZGcdSpec (A : NZOrdAxiomsSig')(B : Gcd A). - Import A B. - Definition divide n m := exists p, m == p*n. - Local Notation "( n | m )" := (divide n m) (at level 0). - Axiom gcd_divide_l : forall n m, (gcd n m | n). - Axiom gcd_divide_r : forall n m, (gcd n m | m). - Axiom gcd_greatest : forall n m p, (p | n) -> (p | m) -> (p | gcd n m). - Axiom gcd_nonneg : forall n m, 0 <= gcd n m. -End NZGcdSpec. - -Module Type DivideNotation (A:NZOrdAxiomsSig')(B:Gcd A)(C:NZGcdSpec A B). - Import A B C. - Notation "( n | m )" := (divide n m) (at level 0). -End DivideNotation. - -Module Type NZGcd (A : NZOrdAxiomsSig) := Gcd A <+ NZGcdSpec A. -Module Type NZGcd' (A : NZOrdAxiomsSig) := - Gcd A <+ NZGcdSpec A <+ DivideNotation A. - -(** Derived properties of gcd *) - -Module NZGcdProp - (Import A : NZOrdAxiomsSig') - (Import B : NZGcd' A) - (Import C : NZMulOrderProp A). - -(** Results concerning divisibility*) - -#[global] -Instance divide_wd : Proper (eq==>eq==>iff) divide. -Proof. - unfold divide. intros x x' Hx y y' Hy. - setoid_rewrite Hx. setoid_rewrite Hy. easy. -Qed. - -Lemma divide_1_l : forall n, (1 | n). -Proof. - intros n. exists n. now nzsimpl. -Qed. - -Lemma divide_0_r : forall n, (n | 0). -Proof. - intros n. exists 0. now nzsimpl. -Qed. - -Lemma divide_0_l : forall n, (0 | n) -> n==0. -Proof. - intros n (m,Hm). revert Hm. now nzsimpl. -Qed. - -Lemma eq_mul_1_nonneg : forall n m, - 0<=n -> n*m == 1 -> n==1 /\ m==1. -Proof. - intros n m Hn H. - le_elim Hn. - - destruct (lt_ge_cases m 0) as [Hm|Hm]. - + generalize (mul_pos_neg n m Hn Hm). order'. - + le_elim Hm. - * apply le_succ_l in Hn. rewrite <- one_succ in Hn. - le_elim Hn. - -- generalize (lt_1_mul_pos n m Hn Hm). order. - -- rewrite <- Hn, mul_1_l in H. now split. - * rewrite <- Hm, mul_0_r in H. order'. - - rewrite <- Hn, mul_0_l in H. order'. -Qed. - -Lemma eq_mul_1_nonneg' : forall n m, - 0<=m -> n*m == 1 -> n==1 /\ m==1. -Proof. - intros n m Hm H. rewrite mul_comm in H. - now apply and_comm, eq_mul_1_nonneg. -Qed. - -Lemma divide_1_r_nonneg : forall n, 0<=n -> (n | 1) -> n==1. -Proof. - intros n Hn (m,Hm). symmetry in Hm. - now apply (eq_mul_1_nonneg' m n). -Qed. - -Lemma divide_refl : forall n, (n | n). -Proof. - intros n. exists 1. now nzsimpl. -Qed. - -Lemma divide_trans : forall n m p, (n | m) -> (m | p) -> (n | p). -Proof. - intros n m p (q,Hq) (r,Hr). exists (r*q). - now rewrite Hr, Hq, mul_assoc. -Qed. - -#[global] -Instance divide_reflexive : Reflexive divide | 5 := divide_refl. -#[global] -Instance divide_transitive : Transitive divide | 5 := divide_trans. - -(** Due to sign, no general antisymmetry result *) - -Lemma divide_antisym_nonneg : forall n m, - 0<=n -> 0<=m -> (n | m) -> (m | n) -> n == m. -Proof. - intros n m Hn Hm (q,Hq) (r,Hr). - le_elim Hn. - - destruct (lt_ge_cases q 0) as [Hq'|Hq']. - + generalize (mul_neg_pos q n Hq' Hn). order. - + rewrite Hq, mul_assoc in Hr. symmetry in Hr. - apply mul_id_l in Hr; [|order]. - destruct (eq_mul_1_nonneg' r q) as [_ H]; trivial. - now rewrite H, mul_1_l in Hq. - - rewrite <- Hn, mul_0_r in Hq. now rewrite <- Hn. -Qed. - -Lemma mul_divide_mono_l : forall n m p, (n | m) -> (p * n | p * m). -Proof. - intros n m p (q,Hq). exists q. now rewrite mul_shuffle3, Hq. -Qed. - -Lemma mul_divide_mono_r : forall n m p, (n | m) -> (n * p | m * p). -Proof. - intros n m p (q,Hq). exists q. now rewrite mul_assoc, Hq. -Qed. - -Lemma mul_divide_cancel_l : forall n m p, p ~= 0 -> - ((p * n | p * m) <-> (n | m)). -Proof. - intros n m p Hp. split. - - intros (q,Hq). exists q. now rewrite mul_shuffle3, mul_cancel_l in Hq. - - apply mul_divide_mono_l. -Qed. - -Lemma mul_divide_cancel_r : forall n m p, p ~= 0 -> - ((n * p | m * p) <-> (n | m)). -Proof. - intros n m p ?. rewrite 2 (mul_comm _ p). now apply mul_divide_cancel_l. -Qed. - -Lemma divide_add_r : forall n m p, (n | m) -> (n | p) -> (n | m + p). -Proof. - intros n m p (q,Hq) (r,Hr). exists (q+r). - now rewrite mul_add_distr_r, Hq, Hr. -Qed. - -Lemma divide_mul_l : forall n m p, (n | m) -> (n | m * p). -Proof. - intros n m p (q,Hq). exists (q*p). now rewrite mul_shuffle0, Hq. -Qed. - -Lemma divide_mul_r : forall n m p, (n | p) -> (n | m * p). -Proof. - intros n m p. rewrite mul_comm. apply divide_mul_l. -Qed. - -Lemma divide_factor_l : forall n m, (n | n * m). -Proof. - intros. apply divide_mul_l, divide_refl. -Qed. - -Lemma divide_factor_r : forall n m, (n | m * n). -Proof. - intros. apply divide_mul_r, divide_refl. -Qed. - -Lemma divide_pos_le : forall n m, 0 < m -> (n | m) -> n <= m. -Proof. - intros n m Hm (q,Hq). - destruct (le_gt_cases n 0) as [Hn|Hn]. - order. - - rewrite Hq. - destruct (lt_ge_cases q 0) as [Hq'|Hq']. - + generalize (mul_neg_pos q n Hq' Hn). order. - + le_elim Hq'. - * rewrite <- (mul_1_l n) at 1. apply mul_le_mono_pos_r; trivial. - now rewrite one_succ, le_succ_l. - * rewrite <- Hq', mul_0_l in Hq. order. -Qed. - -(** Basic properties of gcd *) - -Lemma gcd_unique : forall n m p, - 0<=p -> (p|n) -> (p|m) -> - (forall q, (q|n) -> (q|m) -> (q|p)) -> - gcd n m == p. -Proof. - intros n m p Hp Hn Hm H. - apply divide_antisym_nonneg; trivial. - apply gcd_nonneg. - - apply H. + apply gcd_divide_l. + apply gcd_divide_r. - - now apply gcd_greatest. -Qed. - -#[global] -Instance gcd_wd : Proper (eq==>eq==>eq) gcd. -Proof. - intros x x' Hx y y' Hy. - apply gcd_unique. - - apply gcd_nonneg. - - rewrite Hx. apply gcd_divide_l. - - rewrite Hy. apply gcd_divide_r. - - intro. rewrite Hx, Hy. apply gcd_greatest. -Qed. - -Lemma gcd_divide_iff : forall n m p, - (p | gcd n m) <-> (p | n) /\ (p | m). -Proof. - intros n m p. split. - split. - + transitivity (gcd n m); trivial using gcd_divide_l. - + transitivity (gcd n m); trivial using gcd_divide_r. - - intros (H,H'). now apply gcd_greatest. -Qed. - -Lemma gcd_unique_alt : forall n m p, 0<=p -> - (forall q, (q|p) <-> (q|n) /\ (q|m)) -> - gcd n m == p. -Proof. - intros n m p Hp H. - apply gcd_unique; trivial. - - apply H. apply divide_refl. - - apply H. apply divide_refl. - - intros. apply H. now split. -Qed. - -Lemma gcd_comm : forall n m, gcd n m == gcd m n. -Proof. - intros. apply gcd_unique_alt; try apply gcd_nonneg. - intros. rewrite and_comm. apply gcd_divide_iff. -Qed. - -Lemma gcd_assoc : forall n m p, gcd n (gcd m p) == gcd (gcd n m) p. -Proof. - intros. apply gcd_unique_alt; try apply gcd_nonneg. - intros. now rewrite !gcd_divide_iff, and_assoc. -Qed. - -Lemma gcd_0_l_nonneg : forall n, 0<=n -> gcd 0 n == n. -Proof. - intros. apply gcd_unique; trivial. - - apply divide_0_r. - - apply divide_refl. -Qed. - -Lemma gcd_0_r_nonneg : forall n, 0<=n -> gcd n 0 == n. -Proof. - intros. now rewrite gcd_comm, gcd_0_l_nonneg. -Qed. - -Lemma gcd_1_l : forall n, gcd 1 n == 1. -Proof. - intros. apply gcd_unique; trivial using divide_1_l, le_0_1. -Qed. - -Lemma gcd_1_r : forall n, gcd n 1 == 1. -Proof. - intros. now rewrite gcd_comm, gcd_1_l. -Qed. - -Lemma gcd_diag_nonneg : forall n, 0<=n -> gcd n n == n. -Proof. - intros. apply gcd_unique; trivial using divide_refl. -Qed. - -Lemma gcd_eq_0_l : forall n m, gcd n m == 0 -> n == 0. -Proof. - intros n m H. - generalize (gcd_divide_l n m). rewrite H. apply divide_0_l. -Qed. - -Lemma gcd_eq_0_r : forall n m, gcd n m == 0 -> m == 0. -Proof. - intros n m ?. apply gcd_eq_0_l with n. now rewrite gcd_comm. -Qed. - -Lemma gcd_eq_0 : forall n m, gcd n m == 0 <-> n == 0 /\ m == 0. -Proof. - intros n m. split. - - split. - + now apply gcd_eq_0_l with m. - + now apply gcd_eq_0_r with n. - - intros (EQ,EQ'). rewrite EQ, EQ'. now apply gcd_0_r_nonneg. -Qed. - -Lemma gcd_mul_diag_l : forall n m, 0<=n -> gcd n (n*m) == n. -Proof. - intros n m Hn. apply gcd_unique_alt; trivial. - intros q. split. - split; trivial. now apply divide_mul_l. - - now destruct 1. -Qed. - -Lemma divide_gcd_iff : forall n m, 0<=n -> ((n|m) <-> gcd n m == n). -Proof. - intros n m Hn. split. - - intros (q,Hq). rewrite Hq. - rewrite mul_comm. now apply gcd_mul_diag_l. - - intros EQ. rewrite <- EQ. apply gcd_divide_r. -Qed. - -End NZGcdProp. diff --git a/stdlib/theories/Numbers/NatInt/NZLog.v b/stdlib/theories/Numbers/NatInt/NZLog.v deleted file mode 100644 index b57fb29f5778..000000000000 --- a/stdlib/theories/Numbers/NatInt/NZLog.v +++ /dev/null @@ -1,897 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* t. -End Log2. - -Module Type NZLog2Spec (A : NZOrdAxiomsSig')(B : Pow' A)(C : Log2 A). - Import A B C. - Axiom log2_spec : forall a, 0 2^(log2 a) <= a < 2^(S (log2 a)). - Axiom log2_nonpos : forall a, a<=0 -> log2 a == 0. -End NZLog2Spec. - -Module Type NZLog2 (A : NZOrdAxiomsSig)(B : Pow A) := Log2 A <+ NZLog2Spec A B. - -(** Derived properties of logarithm *) - -Module Type NZLog2Prop - (Import A : NZOrdAxiomsSig') - (Import B : NZPow' A) - (Import C : NZLog2 A B) - (Import D : NZMulOrderProp A) - (Import E : NZPowProp A B D). - -(** log2 is always non-negative *) - -Lemma log2_nonneg : forall a, 0 <= log2 a. -Proof. - intros a. destruct (le_gt_cases a 0) as [Ha|Ha]. - - now rewrite log2_nonpos. - - destruct (log2_spec a Ha) as (_,LT). - apply lt_succ_r, (pow_gt_1 2). + order'. - + rewrite <- le_succ_l, <- one_succ in Ha. order. -Qed. - -(** A tactic for proving positivity and non-negativity *) - -Ltac order_pos := -((apply add_pos_pos || apply add_nonneg_nonneg || - apply mul_pos_pos || apply mul_nonneg_nonneg || - apply pow_nonneg || apply pow_pos_nonneg || - apply log2_nonneg || apply (le_le_succ_r 0)); - order_pos) (* in case of success of an apply, we recurse *) -|| order'. (* otherwise *) - -(** The spec of log2 indeed determines it *) - -Lemma log2_unique : forall a b, 0<=b -> 2^b<=a<2^(S b) -> log2 a == b. -Proof. - intros a b Hb (LEb,LTb). - assert (Ha : 0 < a). - - apply lt_le_trans with (2^b); trivial. - apply pow_pos_nonneg; order'. - - assert (Hc := log2_nonneg a). - destruct (log2_spec a Ha) as (LEc,LTc). - assert (log2 a <= b). - + apply lt_succ_r, (pow_lt_mono_r_iff 2); try order'. - now apply le_le_succ_r. - + assert (b <= log2 a). - * apply lt_succ_r, (pow_lt_mono_r_iff 2); try order'. - now apply le_le_succ_r. - * order. -Qed. - -(** Hence log2 is a morphism. *) - -#[global] -Instance log2_wd : Proper (eq==>eq) log2. -Proof. - intros x x' Hx. - destruct (le_gt_cases x 0). - - rewrite 2 log2_nonpos; trivial. + reflexivity. + now rewrite <- Hx. - - apply log2_unique. + apply log2_nonneg. - + rewrite Hx in *. now apply log2_spec. -Qed. - -(** An alternate specification *) - -Lemma log2_spec_alt : forall a, 0 exists r, - a == 2^(log2 a) + r /\ 0 <= r < 2^(log2 a). -Proof. - intros a Ha. - destruct (log2_spec _ Ha) as (LE,LT). - destruct (le_exists_sub _ _ LE) as (r & Hr & Hr'). - exists r. - split. - now rewrite add_comm. - - split. + trivial. - + apply (add_lt_mono_r _ _ (2^log2 a)). - rewrite <- Hr. generalize LT. - rewrite pow_succ_r by order_pos. - rewrite two_succ at 1. now nzsimpl. -Qed. - -Lemma log2_unique' : forall a b c, 0<=b -> 0<=c<2^b -> - a == 2^b + c -> log2 a == b. -Proof. - intros a b c Hb (Hc,H) EQ. - apply log2_unique. - trivial. - - rewrite EQ. - split. - + rewrite <- add_0_r at 1. now apply add_le_mono_l. - + rewrite pow_succ_r by order. - rewrite two_succ at 2. nzsimpl. now apply add_lt_mono_l. -Qed. - -(** log2 is exact on powers of 2 *) - -Lemma log2_pow2 : forall a, 0<=a -> log2 (2^a) == a. -Proof. - intros a Ha. - apply log2_unique' with 0; trivial. - - split; order_pos. - now nzsimpl. -Qed. - -(** log2 and predecessors of powers of 2 *) - -Lemma log2_pred_pow2 : forall a, 0 log2 (P (2^a)) == P a. -Proof. - intros a Ha. - assert (Ha' : S (P a) == a) by (now rewrite lt_succ_pred with 0). - apply log2_unique. - - apply lt_succ_r; order. - - rewrite <-le_succ_l, <-lt_succ_r, Ha'. - rewrite lt_succ_pred with 0. - + split; try easy. apply pow_lt_mono_r_iff; try order'. - rewrite succ_lt_mono, Ha'. apply lt_succ_diag_r. - + apply pow_pos_nonneg; order'. -Qed. - -(** log2 and basic constants *) - -Lemma log2_1 : log2 1 == 0. -Proof. - rewrite <- (pow_0_r 2). now apply log2_pow2. -Qed. - -Lemma log2_2 : log2 2 == 1. -Proof. - rewrite <- (pow_1_r 2). apply log2_pow2; order'. -Qed. - -(** log2 n is strictly positive for 1 0 < log2 a. -Proof. - intros a Ha. - assert (Ha' : 0 < a) by order'. - assert (H := log2_nonneg a). le_elim H; trivial. - generalize (log2_spec a Ha'). rewrite <- H in *. nzsimpl; try order. - intros (_,H'). rewrite two_succ in H'. apply lt_succ_r in H'; order. -Qed. - -(** Said otherwise, log2 is null only below 1 *) - -Lemma log2_null : forall a, log2 a == 0 <-> a <= 1. -Proof. - intros a. split; intros H. - - destruct (le_gt_cases a 1) as [Ha|Ha]; trivial. - generalize (log2_pos a Ha); order. - - le_elim H. - + apply log2_nonpos. apply lt_succ_r. now rewrite <- one_succ. - + rewrite H. apply log2_1. -Qed. - -(** log2 is a monotone function (but not a strict one) *) - -Lemma log2_le_mono : forall a b, a<=b -> log2 a <= log2 b. -Proof. - intros a b H. - destruct (le_gt_cases a 0) as [Ha|Ha]. - - rewrite log2_nonpos; order_pos. - - assert (Hb : 0 < b) by order. - destruct (log2_spec a Ha) as (LEa,_). - destruct (log2_spec b Hb) as (_,LTb). - apply lt_succ_r, (pow_lt_mono_r_iff 2); order_pos. -Qed. - -(** No reverse result for <=, consider for instance log2 3 <= log2 2 *) - -Lemma log2_lt_cancel : forall a b, log2 a < log2 b -> a < b. -Proof. - intros a b H. - destruct (le_gt_cases b 0) as [Hb|Hb]. - - rewrite (log2_nonpos b) in H; trivial. - generalize (log2_nonneg a); order. - - destruct (le_gt_cases a 0) as [Ha|Ha]. + order. - + destruct (log2_spec a Ha) as (_,LTa). - destruct (log2_spec b Hb) as (LEb,_). - apply le_succ_l in H. - apply (pow_le_mono_r_iff 2) in H; order_pos. -Qed. - -(** When left side is a power of 2, we have an equivalence for <= *) - -Lemma log2_le_pow2 : forall a b, 0 (2^b<=a <-> b <= log2 a). -Proof. - intros a b Ha. - split; intros H. - - destruct (lt_ge_cases b 0) as [Hb|Hb]. - + generalize (log2_nonneg a); order. - + rewrite <- (log2_pow2 b); trivial. now apply log2_le_mono. - - transitivity (2^(log2 a)). - + apply pow_le_mono_r; order'. - + now destruct (log2_spec a Ha). -Qed. - -(** When right side is a square, we have an equivalence for < *) - -Lemma log2_lt_pow2 : forall a b, 0 (a<2^b <-> log2 a < b). -Proof. - intros a b Ha. - split; intros H. - - destruct (lt_ge_cases b 0) as [Hb|Hb]. - + rewrite pow_neg_r in H; order. - + apply (pow_lt_mono_r_iff 2); try order_pos. - apply le_lt_trans with a; trivial. - now destruct (log2_spec a Ha). - - destruct (lt_ge_cases b 0) as [Hb|Hb]. - + generalize (log2_nonneg a); order. - + apply log2_lt_cancel; try order. - now rewrite log2_pow2. -Qed. - -(** Comparing log2 and identity *) - -Lemma log2_lt_lin : forall a, 0 log2 a < a. -Proof. - intros a Ha. - apply (pow_lt_mono_r_iff 2); try order_pos. - apply le_lt_trans with a. - - now destruct (log2_spec a Ha). - - apply pow_gt_lin_r; order'. -Qed. - -Lemma log2_le_lin : forall a, 0<=a -> log2 a <= a. -Proof. - intros a Ha. - le_elim Ha. - - now apply lt_le_incl, log2_lt_lin. - - rewrite <- Ha, log2_nonpos; order. -Qed. - -(** Log2 and multiplication. *) - -(** Due to rounding error, we don't have the usual - [log2 (a*b) = log2 a + log2 b] but we may be off by 1 at most *) - -Lemma log2_mul_below : forall a b, 0 0 - log2 a + log2 b <= log2 (a*b). -Proof. - intros a b Ha Hb. - apply log2_le_pow2; try order_pos. - rewrite pow_add_r by order_pos. - apply mul_le_mono_nonneg; try apply log2_spec; order_pos. -Qed. - -Lemma log2_mul_above : forall a b, 0<=a -> 0<=b -> - log2 (a*b) <= log2 a + log2 b + 1. -Proof. - intros a b Ha Hb. - le_elim Ha. - - le_elim Hb. - + apply lt_succ_r. - rewrite add_1_r, <- add_succ_r, <- add_succ_l. - apply log2_lt_pow2; try order_pos. - rewrite pow_add_r by order_pos. - apply mul_lt_mono_nonneg; try order; now apply log2_spec. - + rewrite <- Hb. nzsimpl. rewrite log2_nonpos; order_pos. - - rewrite <- Ha. nzsimpl. rewrite log2_nonpos; order_pos. -Qed. - -(** And we can't find better approximations in general. - - The lower bound is exact for powers of 2. - - Concerning the upper bound, for any c>1, take a=b=2^c-1, - then log2 (a*b) = c+c -1 while (log2 a) = (log2 b) = c-1 -*) - -(** At least, we get back the usual equation when we multiply by 2 (or 2^k) *) - -Lemma log2_mul_pow2 : forall a b, 0 0<=b -> log2 (a*2^b) == b + log2 a. -Proof. - intros a b Ha Hb. - apply log2_unique; try order_pos. split. - - rewrite pow_add_r, mul_comm; try order_pos. - apply mul_le_mono_nonneg_r. + order_pos. + now apply log2_spec. - - rewrite <-add_succ_r, pow_add_r, mul_comm; try order_pos. - apply mul_lt_mono_pos_l. + order_pos. + now apply log2_spec. -Qed. - -Lemma log2_double : forall a, 0 log2 (2*a) == S (log2 a). -Proof. - intros a Ha. generalize (log2_mul_pow2 a 1 Ha le_0_1). now nzsimpl'. -Qed. - -(** Two numbers with same log2 cannot be far away. *) - -Lemma log2_same : forall a b, 0 0 log2 a == log2 b -> a < 2*b. -Proof. - intros a b Ha Hb H. - apply log2_lt_cancel. rewrite log2_double, H by trivial. - apply lt_succ_diag_r. -Qed. - -(** Log2 and successor : - - the log2 function climbs by at most 1 at a time - - otherwise it stays at the same value - - the +1 steps occur for powers of two -*) - -Lemma log2_succ_le : forall a, log2 (S a) <= S (log2 a). -Proof. - intros a. - destruct (lt_trichotomy 0 a) as [LT|[EQ|LT]]. - - apply (pow_le_mono_r_iff 2); try order_pos. - transitivity (S a). - + apply log2_spec. - apply lt_succ_r; order. - + now apply le_succ_l, log2_spec. - - rewrite <- EQ, <- one_succ, log2_1; order_pos. - - rewrite 2 log2_nonpos. + order_pos. + order'. + now rewrite le_succ_l. -Qed. - -Lemma log2_succ_or : forall a, - log2 (S a) == S (log2 a) \/ log2 (S a) == log2 a. -Proof. - intros a. - destruct (le_gt_cases (log2 (S a)) (log2 a)) as [H|H]. - - right. generalize (log2_le_mono _ _ (le_succ_diag_r a)); order. - - left. apply le_succ_l in H. generalize (log2_succ_le a); order. -Qed. - -Lemma log2_eq_succ_is_pow2 : forall a, - log2 (S a) == S (log2 a) -> exists b, S a == 2^b. -Proof. - intros a H. - destruct (le_gt_cases a 0) as [Ha|Ha]. - - rewrite 2 (proj2 (log2_null _)) in H. + generalize (lt_succ_diag_r 0); order. - + order'. + apply le_succ_l. order'. - - assert (Ha' : 0 < S a) by (apply lt_succ_r; order). - exists (log2 (S a)). - generalize (proj1 (log2_spec (S a) Ha')) (proj2 (log2_spec a Ha)). - rewrite <- le_succ_l, <- H. order. -Qed. - -Lemma log2_eq_succ_iff_pow2 : forall a, 0 - (log2 (S a) == S (log2 a) <-> exists b, S a == 2^b). -Proof. - intros a Ha. - split. - apply log2_eq_succ_is_pow2. - - intros (b,Hb). - assert (Hb' : 0 < b). - + apply (pow_gt_1 2); try order'; now rewrite <- Hb, one_succ, <- succ_lt_mono. - + rewrite Hb, log2_pow2; try order'. - setoid_replace a with (P (2^b)). * rewrite log2_pred_pow2; trivial. - symmetry; now apply lt_succ_pred with 0. - * apply succ_inj. rewrite Hb. symmetry. apply lt_succ_pred with 0. - rewrite <- Hb, lt_succ_r; order. -Qed. - -Lemma log2_succ_double : forall a, 0 log2 (2*a+1) == S (log2 a). -Proof. - intros a Ha. - rewrite add_1_r. - destruct (log2_succ_or (2*a)) as [H|H]; [exfalso|now rewrite H, log2_double]. - apply log2_eq_succ_is_pow2 in H. destruct H as (b,H). - destruct (lt_trichotomy b 0) as [LT|[EQ|LT]]. - - rewrite pow_neg_r in H; trivial. - apply (mul_pos_pos 2), succ_lt_mono in Ha; try order'. - rewrite <- one_succ in Ha. order'. - - rewrite EQ, pow_0_r in H. - apply (mul_pos_pos 2), succ_lt_mono in Ha; try order'. - rewrite <- one_succ in Ha. order'. - - assert (EQ:=lt_succ_pred 0 b LT). - rewrite <- EQ, pow_succ_r in H; [|now rewrite <- lt_succ_r, EQ]. - destruct (lt_ge_cases a (2^(P b))) as [LT'|LE']. - + generalize (mul_2_mono_l _ _ LT'). rewrite add_1_l. order. - + rewrite (mul_le_mono_pos_l _ _ 2) in LE'; try order'. - rewrite <- H in LE'. apply le_succ_l in LE'. order. -Qed. - -(** Log2 and addition *) - -Lemma log2_add_le : forall a b, a~=1 -> b~=1 -> log2 (a+b) <= log2 a + log2 b. -Proof. - intros a b Ha Hb. - destruct (lt_trichotomy a 1) as [Ha'|[Ha'|Ha']]; [|order|]. - - rewrite one_succ, lt_succ_r in Ha'. - rewrite (log2_nonpos a); trivial. nzsimpl. apply log2_le_mono. - rewrite <- (add_0_l b) at 2. now apply add_le_mono. - - destruct (lt_trichotomy b 1) as [Hb'|[Hb'|Hb']]; [|order|]. - + rewrite one_succ, lt_succ_r in Hb'. - rewrite (log2_nonpos b); trivial. nzsimpl. apply log2_le_mono. - rewrite <- (add_0_r a) at 2. now apply add_le_mono. - + clear Ha Hb. - apply lt_succ_r. - apply log2_lt_pow2; try order_pos. - rewrite pow_succ_r by order_pos. - rewrite two_succ, one_succ at 1. nzsimpl. - apply add_lt_mono. - * apply lt_le_trans with (2^(S (log2 a))). -- apply log2_spec; order'. - -- apply pow_le_mono_r. ++ order'. - ++ rewrite <- add_1_r. apply add_le_mono_l. - rewrite one_succ; now apply le_succ_l, log2_pos. - * apply lt_le_trans with (2^(S (log2 b))). - -- apply log2_spec; order'. - -- apply pow_le_mono_r. ++ order'. - ++ rewrite <- add_1_l. apply add_le_mono_r. - rewrite one_succ; now apply le_succ_l, log2_pos. -Qed. - -(** The sum of two log2 is less than twice the log2 of the sum. - The large inequality is obvious thanks to monotonicity. - The strict one requires some more work. This is almost - a convexity inequality for points [2a], [2b] and their middle [a+b] : - ideally, we would have [2*log(a+b) >= log(2a)+log(2b) = 2+log a+log b]. - Here, we cannot do better: consider for instance a=2 b=4, then 1+2<2*2 -*) - -Lemma add_log2_lt : forall a b, 0 0 - log2 a + log2 b < 2 * log2 (a+b). -Proof. - intros a b Ha Hb. nzsimpl'. - assert (H : log2 a <= log2 (a+b)). - - apply log2_le_mono. rewrite <- (add_0_r a) at 1. apply add_le_mono; order. - - assert (H' : log2 b <= log2 (a+b)). - + apply log2_le_mono. rewrite <- (add_0_l b) at 1. apply add_le_mono; order. - + le_elim H. - * apply lt_le_trans with (log2 (a+b) + log2 b). - -- now apply add_lt_mono_r. -- now apply add_le_mono_l. - * rewrite <- H at 1. apply add_lt_mono_l. - le_elim H'; trivial. - symmetry in H. apply log2_same in H; try order_pos. - symmetry in H'. apply log2_same in H'; try order_pos. - revert H H'. nzsimpl'. rewrite <- add_lt_mono_l, <- add_lt_mono_r; order. -Qed. - -End NZLog2Prop. - -Module NZLog2UpProp - (Import A : NZDecOrdAxiomsSig') - (Import B : NZPow' A) - (Import C : NZLog2 A B) - (Import D : NZMulOrderProp A) - (Import E : NZPowProp A B D) - (Import F : NZLog2Prop A B C D E). - -(** * [log2_up] : a binary logarithm that rounds up instead of down *) - -(** For once, we define instead of axiomatizing, thanks to log2 *) - -Definition log2_up a := - match compare 1 a with - | Lt => S (log2 (P a)) - | _ => 0 - end. - -Lemma log2_up_eqn0 : forall a, a<=1 -> log2_up a == 0. -Proof. - intros a Ha. unfold log2_up. case compare_spec; try order. -Qed. - -Lemma log2_up_eqn : forall a, 1 log2_up a == S (log2 (P a)). -Proof. - intros a Ha. unfold log2_up. case compare_spec; try order. -Qed. - -Lemma log2_up_spec : forall a, 1 - 2^(P (log2_up a)) < a <= 2^(log2_up a). -Proof. - intros a Ha. - rewrite log2_up_eqn; trivial. - rewrite pred_succ. - rewrite <- (lt_succ_pred 1 a Ha) at 2 3. - rewrite lt_succ_r, le_succ_l. - apply log2_spec. - apply succ_lt_mono. now rewrite (lt_succ_pred 1 a Ha), <- one_succ. -Qed. - -Lemma log2_up_nonpos : forall a, a<=0 -> log2_up a == 0. -Proof. - intros. apply log2_up_eqn0. order'. -Qed. - -#[global] -Instance log2_up_wd : Proper (eq==>eq) log2_up. -Proof. - assert (Proper (eq==>eq==>Logic.eq) compare). - - repeat red; intros; do 2 case compare_spec; trivial; order. - - intros a a' Ha. unfold log2_up. rewrite Ha at 1. - case compare; now rewrite ?Ha. -Qed. - -(** [log2_up] is always non-negative *) - -Lemma log2_up_nonneg : forall a, 0 <= log2_up a. -Proof. - intros a. unfold log2_up. case compare_spec; try order. - intros. apply le_le_succ_r, log2_nonneg. -Qed. - -(** The spec of [log2_up] indeed determines it *) - -Lemma log2_up_unique : forall a b, 0 2^(P b) log2_up a == b. -Proof. - intros a b Hb (LEb,LTb). - assert (Ha : 1 < a). - - apply le_lt_trans with (2^(P b)); trivial. - rewrite one_succ. apply le_succ_l. - apply pow_pos_nonneg. + order'. - + apply lt_succ_r. - now rewrite (lt_succ_pred 0 b Hb). - - assert (Hc := log2_up_nonneg a). - destruct (log2_up_spec a Ha) as (LTc,LEc). - assert (b <= log2_up a). - + apply lt_succ_r. rewrite <- (lt_succ_pred 0 b Hb). - rewrite <- succ_lt_mono. - apply (pow_lt_mono_r_iff 2); try order'. - + assert (Hc' : 0 < log2_up a) by order. - assert (log2_up a <= b). - * apply lt_succ_r. rewrite <- (lt_succ_pred 0 _ Hc'). - rewrite <- succ_lt_mono. - apply (pow_lt_mono_r_iff 2); try order'. - * order. -Qed. - -(** [log2_up] is exact on powers of 2 *) - -Lemma log2_up_pow2 : forall a, 0<=a -> log2_up (2^a) == a. -Proof. - intros a Ha. - le_elim Ha. - - apply log2_up_unique; trivial. - split; try order. - apply pow_lt_mono_r; try order'. - rewrite <- (lt_succ_pred 0 a Ha) at 2. - now apply lt_succ_r. - - now rewrite <- Ha, pow_0_r, log2_up_eqn0. -Qed. - -(** [log2_up] and successors of powers of 2 *) - -Lemma log2_up_succ_pow2 : forall a, 0<=a -> log2_up (S (2^a)) == S a. -Proof. - intros a Ha. - rewrite log2_up_eqn, pred_succ, log2_pow2; try easy. - rewrite one_succ, <- succ_lt_mono. apply pow_pos_nonneg; order'. -Qed. - -(** Basic constants *) - -Lemma log2_up_1 : log2_up 1 == 0. -Proof. - now apply log2_up_eqn0. -Qed. - -Lemma log2_up_2 : log2_up 2 == 1. -Proof. - rewrite <- (pow_1_r 2). apply log2_up_pow2; order'. -Qed. - -(** Links between log2 and [log2_up] *) - -Lemma le_log2_log2_up : forall a, log2 a <= log2_up a. -Proof. - intros a. unfold log2_up. case compare_spec; intros H. - - rewrite <- H, log2_1. order. - - rewrite <- (lt_succ_pred 1 a H) at 1. apply log2_succ_le. - - rewrite log2_nonpos. + order. + now rewrite <-lt_succ_r, <-one_succ. -Qed. - -Lemma le_log2_up_succ_log2 : forall a, log2_up a <= S (log2 a). -Proof. - intros a. unfold log2_up. case compare_spec; intros H; try order_pos. - rewrite <- succ_le_mono. apply log2_le_mono. - rewrite <- (lt_succ_pred 1 a H) at 2. apply le_succ_diag_r. -Qed. - -Lemma log2_log2_up_spec : forall a, 0 - 2^log2 a <= a <= 2^log2_up a. -Proof. - intros a H. split. - - now apply log2_spec. - - rewrite <-le_succ_l, <-one_succ in H. le_elim H. - + now apply log2_up_spec. - + now rewrite <-H, log2_up_1, pow_0_r. -Qed. - -Lemma log2_log2_up_exact : - forall a, 0 (log2 a == log2_up a <-> exists b, a == 2^b). -Proof. - intros a Ha. - split. - - intros H. exists (log2 a). - generalize (log2_log2_up_spec a Ha). rewrite <-H. - destruct 1; order. - - intros (b,Hb). rewrite Hb. - destruct (le_gt_cases 0 b). - + now rewrite log2_pow2, log2_up_pow2. - + rewrite pow_neg_r; trivial. now rewrite log2_nonpos, log2_up_nonpos. -Qed. - -(** [log2_up] n is strictly positive for 1 0 < log2_up a. -Proof. - intros. rewrite log2_up_eqn; trivial. apply lt_succ_r; order_pos. -Qed. - -(** Said otherwise, [log2_up] is null only below 1 *) - -Lemma log2_up_null : forall a, log2_up a == 0 <-> a <= 1. -Proof. - intros a. split; intros H. - - destruct (le_gt_cases a 1) as [Ha|Ha]; trivial. - generalize (log2_up_pos a Ha); order. - - now apply log2_up_eqn0. -Qed. - -(** [log2_up] is a monotone function (but not a strict one) *) - -Lemma log2_up_le_mono : forall a b, a<=b -> log2_up a <= log2_up b. -Proof. - intros a b H. - destruct (le_gt_cases a 1) as [Ha|Ha]. - - rewrite log2_up_eqn0; trivial. apply log2_up_nonneg. - - rewrite 2 log2_up_eqn; try order. - rewrite <- succ_le_mono. apply log2_le_mono, succ_le_mono. - rewrite 2 lt_succ_pred with 1; order. -Qed. - -(** No reverse result for <=, consider for instance log2_up 4 <= log2_up 3 *) - -Lemma log2_up_lt_cancel : forall a b, log2_up a < log2_up b -> a < b. -Proof. - intros a b H. - destruct (le_gt_cases b 1) as [Hb|Hb]. - - rewrite (log2_up_eqn0 b) in H; trivial. - generalize (log2_up_nonneg a); order. - - destruct (le_gt_cases a 1) as [Ha|Ha]. + order. - + rewrite 2 log2_up_eqn in H; try order. - rewrite <- succ_lt_mono in H. apply log2_lt_cancel, succ_lt_mono in H. - rewrite 2 lt_succ_pred with 1 in H; order. -Qed. - -(** When left side is a power of 2, we have an equivalence for < *) - -Lemma log2_up_lt_pow2 : forall a b, 0 (2^b b < log2_up a). -Proof. - intros a b Ha. - split; intros H. - - destruct (lt_ge_cases b 0) as [Hb|Hb]. - + generalize (log2_up_nonneg a); order. - + apply (pow_lt_mono_r_iff 2). * order'. * apply log2_up_nonneg. - * apply lt_le_trans with a; trivial. - apply (log2_up_spec a). - apply le_lt_trans with (2^b); trivial. - rewrite one_succ, le_succ_l. apply pow_pos_nonneg; order'. - - destruct (lt_ge_cases b 0) as [Hb|Hb]. - + now rewrite pow_neg_r. - + rewrite <- (log2_up_pow2 b) in H; trivial. now apply log2_up_lt_cancel. -Qed. - -(** When right side is a square, we have an equivalence for <= *) - -Lemma log2_up_le_pow2 : forall a b, 0 (a<=2^b <-> log2_up a <= b). -Proof. - intros a b Ha. - split; intros H. - - destruct (lt_ge_cases b 0) as [Hb|Hb]. - + rewrite pow_neg_r in H; order. - + rewrite <- (log2_up_pow2 b); trivial. now apply log2_up_le_mono. - - transitivity (2^(log2_up a)). - + now apply log2_log2_up_spec. - + apply pow_le_mono_r; order'. -Qed. - -(** Comparing [log2_up] and identity *) - -Lemma log2_up_lt_lin : forall a, 0 log2_up a < a. -Proof. - intros a Ha. - assert (H : S (P a) == a) by (now apply lt_succ_pred with 0). - rewrite <- H at 2. apply lt_succ_r. apply log2_up_le_pow2; trivial. - rewrite <- H at 1. apply le_succ_l. - apply pow_gt_lin_r. - order'. - apply lt_succ_r; order. -Qed. - -Lemma log2_up_le_lin : forall a, 0<=a -> log2_up a <= a. -Proof. - intros a Ha. - le_elim Ha. - - now apply lt_le_incl, log2_up_lt_lin. - - rewrite <- Ha, log2_up_nonpos; order. -Qed. - -(** [log2_up] and multiplication. *) - -(** Due to rounding error, we don't have the usual - [log2_up (a*b) = log2_up a + log2_up b] but we may be off by 1 at most *) - -Lemma log2_up_mul_above : forall a b, 0<=a -> 0<=b -> - log2_up (a*b) <= log2_up a + log2_up b. -Proof. - intros a b Ha Hb. - assert (Ha':=log2_up_nonneg a). - assert (Hb':=log2_up_nonneg b). - le_elim Ha. - - le_elim Hb. - + apply log2_up_le_pow2; try order_pos. - rewrite pow_add_r; trivial. - apply mul_le_mono_nonneg; try apply log2_log2_up_spec; order'. - + rewrite <- Hb. nzsimpl. rewrite log2_up_nonpos; order_pos. - - rewrite <- Ha. nzsimpl. rewrite log2_up_nonpos; order_pos. -Qed. - -Lemma log2_up_mul_below : forall a b, 0 0 - log2_up a + log2_up b <= S (log2_up (a*b)). -Proof. - intros a b Ha Hb. - rewrite <-le_succ_l, <-one_succ in Ha. le_elim Ha. - - rewrite <-le_succ_l, <-one_succ in Hb. le_elim Hb. - + assert (Ha' : 0 < log2_up a) by (apply log2_up_pos; trivial). - assert (Hb' : 0 < log2_up b) by (apply log2_up_pos; trivial). - rewrite <- (lt_succ_pred 0 (log2_up a)); trivial. - rewrite <- (lt_succ_pred 0 (log2_up b)); trivial. - nzsimpl. rewrite <- succ_le_mono, le_succ_l. - apply (pow_lt_mono_r_iff 2). * order'. * apply log2_up_nonneg. - * rewrite pow_add_r; try (apply lt_succ_r; rewrite (lt_succ_pred 0); trivial). - apply lt_le_trans with (a*b). - -- apply mul_lt_mono_nonneg; try order_pos; try now apply log2_up_spec. - -- apply log2_up_spec. - setoid_replace 1 with (1*1) by now nzsimpl. - apply mul_lt_mono_nonneg; order'. - + rewrite <- Hb, log2_up_1; nzsimpl. apply le_succ_diag_r. - - rewrite <- Ha, log2_up_1; nzsimpl. apply le_succ_diag_r. -Qed. - -(** And we can't find better approximations in general. - - The upper bound is exact for powers of 2. - - Concerning the lower bound, for any c>1, take a=b=2^c+1, - then [log2_up (a*b) = c+c +1] while [(log2_up a) = (log2_up b) = c+1] -*) - -(** At least, we get back the usual equation when we multiply by 2 (or 2^k) *) - -Lemma log2_up_mul_pow2 : forall a b, 0 0<=b -> - log2_up (a*2^b) == b + log2_up a. -Proof. - intros a b Ha Hb. - rewrite <- le_succ_l, <- one_succ in Ha; le_elim Ha. - - apply log2_up_unique. + apply add_nonneg_pos; trivial. now apply log2_up_pos. - + split. - * assert (EQ := lt_succ_pred 0 _ (log2_up_pos _ Ha)). - rewrite <- EQ. nzsimpl. rewrite pow_add_r, mul_comm; trivial. - -- apply mul_lt_mono_pos_r. ++ order_pos. ++ now apply log2_up_spec. - -- rewrite <- lt_succ_r, EQ. now apply log2_up_pos. - * rewrite pow_add_r, mul_comm; trivial. - -- apply mul_le_mono_nonneg_l. ++ order_pos. ++ now apply log2_up_spec. - -- apply log2_up_nonneg. - - now rewrite <- Ha, mul_1_l, log2_up_1, add_0_r, log2_up_pow2. -Qed. - -Lemma log2_up_double : forall a, 0 log2_up (2*a) == S (log2_up a). -Proof. - intros a Ha. generalize (log2_up_mul_pow2 a 1 Ha le_0_1). now nzsimpl'. -Qed. - -(** Two numbers with same [log2_up] cannot be far away. *) - -Lemma log2_up_same : forall a b, 0 0 log2_up a == log2_up b -> a < 2*b. -Proof. - intros a b Ha Hb H. - apply log2_up_lt_cancel. rewrite log2_up_double, H by trivial. - apply lt_succ_diag_r. -Qed. - -(** [log2_up] and successor : - - the [log2_up] function climbs by at most 1 at a time - - otherwise it stays at the same value - - the +1 steps occur after powers of two -*) - -Lemma log2_up_succ_le : forall a, log2_up (S a) <= S (log2_up a). -Proof. - intros a. - destruct (lt_trichotomy 1 a) as [LT|[EQ|LT]]. - - rewrite 2 log2_up_eqn; trivial. - + rewrite pred_succ, <- succ_le_mono. rewrite <-(lt_succ_pred 1 a LT) at 1. - apply log2_succ_le. - + apply lt_succ_r; order. - - rewrite <- EQ, <- two_succ, log2_up_1, log2_up_2. now nzsimpl'. - - rewrite 2 log2_up_eqn0. + order_pos. + order'. + now rewrite le_succ_l. -Qed. - -Lemma log2_up_succ_or : forall a, - log2_up (S a) == S (log2_up a) \/ log2_up (S a) == log2_up a. -Proof. - intros a. - destruct (le_gt_cases (log2_up (S a)) (log2_up a)) as [H|H]. - - right. generalize (log2_up_le_mono _ _ (le_succ_diag_r a)); order. - - left. apply le_succ_l in H. generalize (log2_up_succ_le a); order. -Qed. - -Lemma log2_up_eq_succ_is_pow2 : forall a, - log2_up (S a) == S (log2_up a) -> exists b, a == 2^b. -Proof. - intros a H. - destruct (le_gt_cases a 0) as [Ha|Ha]. - - rewrite 2 (proj2 (log2_up_null _)) in H. + generalize (lt_succ_diag_r 0); order. - + order'. + apply le_succ_l. order'. - - assert (Ha' : 1 < S a) by (now rewrite one_succ, <- succ_lt_mono). - exists (log2_up a). - generalize (proj1 (log2_up_spec (S a) Ha')) (proj2 (log2_log2_up_spec a Ha)). - rewrite H, pred_succ, lt_succ_r. order. -Qed. - -Lemma log2_up_eq_succ_iff_pow2 : forall a, 0 - (log2_up (S a) == S (log2_up a) <-> exists b, a == 2^b). -Proof. - intros a Ha. - split. - apply log2_up_eq_succ_is_pow2. - - intros (b,Hb). - destruct (lt_ge_cases b 0) as [Hb'|Hb']. - + rewrite pow_neg_r in Hb; order. - + rewrite Hb, log2_up_pow2; try order'. - now rewrite log2_up_succ_pow2. -Qed. - -Lemma log2_up_succ_double : forall a, 0 - log2_up (2*a+1) == 2 + log2 a. -Proof. - intros a Ha. - rewrite log2_up_eqn. - rewrite add_1_r, pred_succ, log2_double; now nzsimpl'. - - apply le_lt_trans with (0+1). + now nzsimpl'. - + apply add_lt_mono_r. order_pos. -Qed. - -(** [log2_up] and addition *) - -Lemma log2_up_add_le : forall a b, a~=1 -> b~=1 -> - log2_up (a+b) <= log2_up a + log2_up b. -Proof. - intros a b Ha Hb. - destruct (lt_trichotomy a 1) as [Ha'|[Ha'|Ha']]; [|order|]. - - rewrite (log2_up_eqn0 a) by order. nzsimpl. apply log2_up_le_mono. - rewrite one_succ, lt_succ_r in Ha'. - rewrite <- (add_0_l b) at 2. now apply add_le_mono. - - destruct (lt_trichotomy b 1) as [Hb'|[Hb'|Hb']]; [|order|]. - + rewrite (log2_up_eqn0 b) by order. nzsimpl. apply log2_up_le_mono. - rewrite one_succ, lt_succ_r in Hb'. - rewrite <- (add_0_r a) at 2. now apply add_le_mono. - + clear Ha Hb. - transitivity (log2_up (a*b)). - * now apply log2_up_le_mono, add_le_mul. - * apply log2_up_mul_above; order'. -Qed. - -(** The sum of two [log2_up] is less than twice the [log2_up] of the sum. - The large inequality is obvious thanks to monotonicity. - The strict one requires some more work. This is almost - a convexity inequality for points [2a], [2b] and their middle [a+b] : - ideally, we would have [2*log(a+b) >= log(2a)+log(2b) = 2+log a+log b]. - Here, we cannot do better: consider for instance a=3 b=5, then 2+3<2*3 -*) - -Lemma add_log2_up_lt : forall a b, 0 0 - log2_up a + log2_up b < 2 * log2_up (a+b). -Proof. - intros a b Ha Hb. nzsimpl'. - assert (H : log2_up a <= log2_up (a+b)). - - apply log2_up_le_mono. rewrite <- (add_0_r a) at 1. apply add_le_mono; order. - - assert (H' : log2_up b <= log2_up (a+b)). - + apply log2_up_le_mono. rewrite <- (add_0_l b) at 1. apply add_le_mono; order. - + le_elim H. - * apply lt_le_trans with (log2_up (a+b) + log2_up b). - -- now apply add_lt_mono_r. -- now apply add_le_mono_l. - * rewrite <- H at 1. apply add_lt_mono_l. - le_elim H'. -- trivial. - -- symmetry in H. apply log2_up_same in H; try order_pos. - symmetry in H'. apply log2_up_same in H'; try order_pos. - revert H H'. nzsimpl'. rewrite <- add_lt_mono_l, <- add_lt_mono_r; order. -Qed. - -End NZLog2UpProp. diff --git a/stdlib/theories/Numbers/NatInt/NZMul.v b/stdlib/theories/Numbers/NatInt/NZMul.v deleted file mode 100644 index 4dc242592ee8..000000000000 --- a/stdlib/theories/Numbers/NatInt/NZMul.v +++ /dev/null @@ -1,111 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* (p * n < p * m <-> q * n + m < q * m + n). -Proof. -intros p q n m H. rewrite <- H. nzsimpl. -rewrite <- ! add_assoc, (add_comm n m). -now rewrite <- add_lt_mono_r. -Qed. - -Theorem mul_lt_mono_pos_l : forall p n m, 0 < p -> (n < m <-> p * n < p * m). -Proof. - intros p n m Hp. revert n m. apply lt_ind with (4:=Hp). - solve_proper. - - intros. now nzsimpl. - - clear p Hp. intros p Hp IH n m. nzsimpl. - assert (LR : forall n m, n < m -> p * n + n < p * m + m) - by (intros n1 m1 H; apply add_lt_mono; trivial; now rewrite <- IH). - split; intros H. - + now apply LR. - + destruct (lt_trichotomy n m) as [LT|[EQ|GT]]; trivial. - * rewrite EQ in H. order. - * apply LR in GT. order. -Qed. - -Theorem mul_lt_mono_pos_r : forall p n m, 0 < p -> (n < m <-> n * p < m * p). -Proof. -intros p n m. -rewrite (mul_comm n p), (mul_comm m p). now apply mul_lt_mono_pos_l. -Qed. - -Theorem mul_lt_mono_neg_l : forall p n m, p < 0 -> (n < m <-> p * m < p * n). -Proof. -intro p; nzord_induct p. -- order. -- intros p Hp _ n m Hp'. apply lt_succ_l in Hp'. order. -- intros p Hp IH n m _. apply le_succ_l in Hp. - le_elim Hp. - + assert (LR : forall n m, n < m -> p * m < p * n). - * intros n1 m1 H. apply (le_lt_add_lt n1 m1). - -- now apply lt_le_incl. - -- rewrite <- 2 mul_succ_l. now rewrite <- IH. - * split; intros H. - -- now apply LR. - -- destruct (lt_trichotomy n m) as [LT|[EQ|GT]]; trivial. - ++ rewrite EQ in H. order. - ++ apply LR in GT. order. - + rewrite (mul_lt_pred p (S p)), Hp; now nzsimpl. -Qed. - -Theorem mul_lt_mono_neg_r : forall p n m, p < 0 -> (n < m <-> m * p < n * p). -Proof. -intros p n m. -rewrite (mul_comm n p), (mul_comm m p). now apply mul_lt_mono_neg_l. -Qed. - -Theorem mul_le_mono_nonneg_l : forall n m p, 0 <= p -> n <= m -> p * n <= p * m. -Proof. -intros n m p H1 H2. le_elim H1. -- le_elim H2. + apply lt_le_incl. now apply mul_lt_mono_pos_l. - + apply eq_le_incl; now rewrite H2. -- apply eq_le_incl; rewrite <- H1; now do 2 rewrite mul_0_l. -Qed. - -Theorem mul_le_mono_nonpos_l : forall n m p, p <= 0 -> n <= m -> p * m <= p * n. -Proof. -intros n m p H1 H2. le_elim H1. -- le_elim H2. + apply lt_le_incl. now apply mul_lt_mono_neg_l. - + apply eq_le_incl; now rewrite H2. -- apply eq_le_incl; rewrite H1; now do 2 rewrite mul_0_l. -Qed. - -Theorem mul_le_mono_nonneg_r : forall n m p, 0 <= p -> n <= m -> n * p <= m * p. -Proof. -intros n m p H1 H2; -rewrite (mul_comm n p), (mul_comm m p); now apply mul_le_mono_nonneg_l. -Qed. - -Theorem mul_le_mono_nonpos_r : forall n m p, p <= 0 -> n <= m -> m * p <= n * p. -Proof. -intros n m p H1 H2; -rewrite (mul_comm n p), (mul_comm m p); now apply mul_le_mono_nonpos_l. -Qed. - -Theorem mul_cancel_l : forall n m p, p ~= 0 -> (p * n == p * m <-> n == m). -Proof. -intros n m p Hp; split; intro H; [|now f_equiv]. -apply lt_gt_cases in Hp; destruct Hp as [Hp|Hp]; - destruct (lt_trichotomy n m) as [LT|[EQ|GT]]; trivial. -- apply (mul_lt_mono_neg_l p) in LT; order. -- apply (mul_lt_mono_neg_l p) in GT; order. -- apply (mul_lt_mono_pos_l p) in LT; order. -- apply (mul_lt_mono_pos_l p) in GT; order. -Qed. - -Theorem mul_cancel_r : forall n m p, p ~= 0 -> (n * p == m * p <-> n == m). -Proof. -intros n m p. rewrite (mul_comm n p), (mul_comm m p); apply mul_cancel_l. -Qed. - -Lemma mul_reg_l n m p : p ~= 0 -> p * n == p * m -> n == m. -Proof. - exact (fun Hp => proj1 (mul_cancel_l n m p Hp)). -Qed. - -Lemma mul_reg_r n m p : p ~= 0 -> n * p == m * p -> n == m. -Proof. - exact (fun Hp => proj1 (mul_cancel_r n m p Hp)). -Qed. - -Theorem mul_id_l : forall n m, m ~= 0 -> (n * m == m <-> n == 1). -Proof. -intros n m H. -stepl (n * m == 1 * m) by now rewrite mul_1_l. now apply mul_cancel_r. -Qed. - -Theorem mul_id_r : forall n m, n ~= 0 -> (n * m == n <-> m == 1). -Proof. -intros n m; rewrite mul_comm; apply mul_id_l. -Qed. - -Theorem mul_le_mono_pos_l : forall n m p, 0 < p -> (n <= m <-> p * n <= p * m). -Proof. -intros n m p H; do 2 rewrite lt_eq_cases. -rewrite (mul_lt_mono_pos_l p n m) by assumption. -now rewrite -> (mul_cancel_l n m p) by -(intro H1; rewrite H1 in H; false_hyp H lt_irrefl). -Qed. - -Theorem mul_le_mono_pos_r : forall n m p, 0 < p -> (n <= m <-> n * p <= m * p). -Proof. -intros n m p. rewrite (mul_comm n p), (mul_comm m p); apply mul_le_mono_pos_l. -Qed. - -Theorem mul_le_mono_neg_l : forall n m p, p < 0 -> (n <= m <-> p * m <= p * n). -Proof. -intros n m p H; do 2 rewrite lt_eq_cases. -rewrite (mul_lt_mono_neg_l p n m); [| assumption]. -rewrite -> (mul_cancel_l m n p) - by (intro H1; rewrite H1 in H; false_hyp H lt_irrefl). -now setoid_replace (n == m) with (m == n) by (split; now intro). -Qed. - -Theorem mul_le_mono_neg_r : forall n m p, p < 0 -> (n <= m <-> m * p <= n * p). -Proof. -intros n m p. rewrite (mul_comm n p), (mul_comm m p); apply mul_le_mono_neg_l. -Qed. - -Theorem mul_lt_mono_nonneg : - forall n m p q, 0 <= n -> n < m -> 0 <= p -> p < q -> n * p < m * q. -Proof. -intros n m p q H1 H2 H3 H4. -apply le_lt_trans with (m * p). -- apply mul_le_mono_nonneg_r; [assumption | now apply lt_le_incl]. -- apply -> mul_lt_mono_pos_l; [assumption | now apply le_lt_trans with n]. -Qed. - -(* There are still many variants of the theorem above. One can assume 0 < n -or 0 < p or n <= m or p <= q. *) - -Theorem mul_le_mono_nonneg : - forall n m p q, 0 <= n -> n <= m -> 0 <= p -> p <= q -> n * p <= m * q. -Proof. -intros n m p q H1 H2 H3 H4. -le_elim H2; le_elim H4. -- apply lt_le_incl; now apply mul_lt_mono_nonneg. -- rewrite <- H4; apply mul_le_mono_nonneg_r; [assumption | now apply lt_le_incl]. -- rewrite <- H2; apply mul_le_mono_nonneg_l; [assumption | now apply lt_le_incl]. -- rewrite H2; rewrite H4; now apply eq_le_incl. -Qed. - -Theorem mul_pos_pos : forall n m, 0 < n -> 0 < m -> 0 < n * m. -Proof. -intros n m H1 H2. rewrite <- (mul_0_l m). now apply mul_lt_mono_pos_r. -Qed. - -Theorem mul_neg_neg : forall n m, n < 0 -> m < 0 -> 0 < n * m. -Proof. -intros n m H1 H2. rewrite <- (mul_0_l m). now apply mul_lt_mono_neg_r. -Qed. - -Theorem mul_pos_neg : forall n m, 0 < n -> m < 0 -> n * m < 0. -Proof. -intros n m H1 H2. rewrite <- (mul_0_l m). now apply mul_lt_mono_neg_r. -Qed. - -Theorem mul_neg_pos : forall n m, n < 0 -> 0 < m -> n * m < 0. -Proof. -intros; rewrite mul_comm; now apply mul_pos_neg. -Qed. - -Theorem mul_nonneg_nonneg : forall n m, 0 <= n -> 0 <= m -> 0 <= n*m. -Proof. -intros n m Hn Hm. rewrite <- (mul_0_l m). apply mul_le_mono_nonneg; order. -Qed. - -Theorem mul_pos_cancel_l : forall n m, 0 < n -> (0 < n*m <-> 0 < m). -Proof. -intros n m Hn. rewrite <- (mul_0_r n) at 1. - symmetry. now apply mul_lt_mono_pos_l. -Qed. - -Theorem mul_pos_cancel_r : forall n m, 0 < m -> (0 < n*m <-> 0 < n). -Proof. -intros n m Hn. rewrite <- (mul_0_l m) at 1. - symmetry. now apply mul_lt_mono_pos_r. -Qed. - -Theorem mul_nonneg_cancel_l : forall n m, 0 < n -> (0 <= n*m <-> 0 <= m). -Proof. -intros n m Hn. rewrite <- (mul_0_r n) at 1. - symmetry. now apply mul_le_mono_pos_l. -Qed. - -Theorem mul_nonneg_cancel_r : forall n m, 0 < m -> (0 <= n*m <-> 0 <= n). -Proof. -intros n m Hn. rewrite <- (mul_0_l m) at 1. - symmetry. now apply mul_le_mono_pos_r. -Qed. - -Theorem lt_1_mul_pos : forall n m, 1 < n -> 0 < m -> 1 < n * m. -Proof. -intros n m H1 H2. apply (mul_lt_mono_pos_r m) in H1. -- rewrite mul_1_l in H1. now apply lt_1_l with m. -- assumption. -Qed. - -Theorem eq_mul_0 : forall n m, n * m == 0 <-> n == 0 \/ m == 0. -Proof. -intros n m; split. -- intro H; destruct (lt_trichotomy n 0) as [H1 | [H1 | H1]]; - destruct (lt_trichotomy m 0) as [H2 | [H2 | H2]]; - try (now right); try (now left). - + exfalso; now apply (lt_neq 0 (n * m)); [apply mul_neg_neg |]. - + exfalso; now apply (lt_neq (n * m) 0); [apply mul_neg_pos |]. - + exfalso; now apply (lt_neq (n * m) 0); [apply mul_pos_neg |]. - + exfalso; now apply (lt_neq 0 (n * m)); [apply mul_pos_pos |]. -- intros [H | H]. + now rewrite H, mul_0_l. + now rewrite H, mul_0_r. -Qed. - -Theorem neq_mul_0 : forall n m, n ~= 0 /\ m ~= 0 <-> n * m ~= 0. -Proof. -intros n m; split; intro H. -- intro H1; apply eq_mul_0 in H1. tauto. -- split; intro H1; rewrite H1 in H; - (rewrite mul_0_l in H || rewrite mul_0_r in H); now apply H. -Qed. - -Theorem eq_square_0 : forall n, n * n == 0 <-> n == 0. -Proof. -intro n; rewrite eq_mul_0; tauto. -Qed. - -Theorem eq_mul_0_l : forall n m, n * m == 0 -> m ~= 0 -> n == 0. -Proof. -intros n m H1 H2. apply eq_mul_0 in H1. destruct H1 as [H1 | H1]. -- assumption. - false_hyp H1 H2. -Qed. - -Theorem eq_mul_0_r : forall n m, n * m == 0 -> n ~= 0 -> m == 0. -Proof. -intros n m H1 H2; apply eq_mul_0 in H1. destruct H1 as [H1 | H1]. -- false_hyp H1 H2. - assumption. -Qed. - -(* Some alternative names: *) - -Notation mul_eq_0 := eq_mul_0. -Notation mul_eq_0_l := eq_mul_0_l. -Notation mul_eq_0_r := eq_mul_0_r. - -Theorem lt_0_mul n m : 0 < n * m <-> (0 < n /\ 0 < m) \/ (m < 0 /\ n < 0). -Proof. -split; [intro H | intros [[H1 H2] | [H1 H2]]]. -- destruct (lt_trichotomy n 0) as [H1 | [H1 | H1]]; - [| rewrite H1 in H; rewrite mul_0_l in H; false_hyp H lt_irrefl |]; - (destruct (lt_trichotomy m 0) as [H2 | [H2 | H2]]; - [| rewrite H2 in H; rewrite mul_0_r in H; false_hyp H lt_irrefl |]); - try (left; now split); try (right; now split). - + assert (H3 : n * m < 0) by now apply mul_neg_pos. - exfalso; now apply (lt_asymm (n * m) 0). - + assert (H3 : n * m < 0) by now apply mul_pos_neg. - exfalso; now apply (lt_asymm (n * m) 0). -- now apply mul_pos_pos. - now apply mul_neg_neg. -Qed. - -Theorem square_lt_mono_nonneg : forall n m, 0 <= n -> n < m -> n * n < m * m. -Proof. -intros n m H1 H2. now apply mul_lt_mono_nonneg. -Qed. - -Theorem square_le_mono_nonneg : forall n m, 0 <= n -> n <= m -> n * n <= m * m. -Proof. -intros n m H1 H2. now apply mul_le_mono_nonneg. -Qed. - -(* The converse theorems require nonnegativity (or nonpositivity) of the -other variable *) - -Theorem square_lt_simpl_nonneg : forall n m, 0 <= m -> n * n < m * m -> n < m. -Proof. -intros n m H1 H2. destruct (lt_ge_cases n 0). -- now apply lt_le_trans with 0. -- destruct (lt_ge_cases n m) as [LT|LE]; trivial. - apply square_le_mono_nonneg in LE; order. -Qed. - -Theorem square_le_simpl_nonneg : forall n m, 0 <= m -> n * n <= m * m -> n <= m. -Proof. -intros n m H1 H2. destruct (lt_ge_cases n 0). -- apply lt_le_incl; now apply lt_le_trans with 0. -- destruct (le_gt_cases n m) as [LE|LT]; trivial. - apply square_lt_mono_nonneg in LT; order. -Qed. - -Theorem mul_2_mono_l : forall n m, n < m -> 1 + 2 * n < 2 * m. -Proof. -intros n m. rewrite <- le_succ_l, (mul_le_mono_pos_l (S n) m two). -- rewrite two_succ. nzsimpl. now rewrite le_succ_l. -- order'. -Qed. - -Lemma add_le_mul : forall a b, 1 1 a+b <= a*b. -Proof. - assert (AUX : forall a b, 0 0 (S a)+(S b) <= (S a)*(S b)). - - intros a b Ha Hb. - nzsimpl. rewrite <- succ_le_mono. apply le_succ_l. - rewrite <- add_assoc, <- (add_0_l (a+b)), (add_comm b). - apply add_lt_mono_r. - now apply mul_pos_pos. - - intros a b Ha Hb. - assert (Ha' := lt_succ_pred 1 a Ha). - assert (Hb' := lt_succ_pred 1 b Hb). - rewrite <- Ha', <- Hb'. apply AUX; rewrite succ_lt_mono, <- one_succ; order. -Qed. - -(** A few results about squares *) - -Lemma square_nonneg : forall a, 0 <= a * a. -Proof. - intro a. rewrite <- (mul_0_r a). destruct (le_gt_cases a 0). - - now apply mul_le_mono_nonpos_l. - - apply mul_le_mono_nonneg_l; order. -Qed. - -Lemma crossmul_le_addsquare : forall a b, 0<=a -> 0<=b -> b*a+a*b <= a*a+b*b. -Proof. - assert (AUX : forall a b, 0<=a<=b -> b*a+a*b <= a*a+b*b). - - intros a b (Ha,H). - destruct (le_exists_sub _ _ H) as (d & EQ & Hd). - rewrite EQ. - rewrite 2 mul_add_distr_r. - rewrite !add_assoc. apply add_le_mono_r. - rewrite add_comm. apply add_le_mono_l. - apply mul_le_mono_nonneg_l; trivial. order. - - intros a b Ha Hb. - destruct (le_gt_cases a b). - + apply AUX; split; order. - + rewrite (add_comm (b*a)), (add_comm (a*a)). - apply AUX; split; order. -Qed. - -Lemma add_square_le : forall a b, 0<=a -> 0<=b -> - a*a + b*b <= (a+b)*(a+b). -Proof. - intros a b Ha Hb. - rewrite mul_add_distr_r, !mul_add_distr_l. - rewrite add_assoc. - apply add_le_mono_r. - rewrite <- add_assoc. - rewrite <- (add_0_r (a*a)) at 1. - apply add_le_mono_l. - apply add_nonneg_nonneg; now apply mul_nonneg_nonneg. -Qed. - -Lemma square_add_le : forall a b, 0<=a -> 0<=b -> - (a+b)*(a+b) <= 2*(a*a + b*b). -Proof. - intros a b Ha Hb. - rewrite !mul_add_distr_l, !mul_add_distr_r. nzsimpl'. - rewrite <- !add_assoc. apply add_le_mono_l. - rewrite !add_assoc. apply add_le_mono_r. - apply crossmul_le_addsquare; order. -Qed. - -Lemma quadmul_le_squareadd : forall a b, 0<=a -> 0<=b -> - 2*2*a*b <= (a+b)*(a+b). -Proof. - intros a b Ha Hb. - nzsimpl'. - rewrite !mul_add_distr_l, !mul_add_distr_r. - rewrite (add_comm _ (b*b)), add_assoc. - apply add_le_mono_r. - rewrite (add_shuffle0 (a*a)), (mul_comm b a). - apply add_le_mono_r. - rewrite (mul_comm a b) at 1. - now apply crossmul_le_addsquare. -Qed. - -End NZMulOrderProp. diff --git a/stdlib/theories/Numbers/NatInt/NZOrder.v b/stdlib/theories/Numbers/NatInt/NZOrder.v deleted file mode 100644 index 722e607a01f6..000000000000 --- a/stdlib/theories/Numbers/NatInt/NZOrder.v +++ /dev/null @@ -1,679 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* eq==>iff) le. -Proof. -intros n n' Hn m m' Hm. now rewrite <- !lt_succ_r, Hn, Hm. -Qed. - -Ltac le_elim H := rewrite lt_eq_cases in H; destruct H as [H | H]. - -Theorem lt_le_incl : forall n m, n < m -> n <= m. -Proof. -intros. apply lt_eq_cases. now left. -Qed. - -Theorem le_refl : forall n, n <= n. -Proof. -intro. apply lt_eq_cases. now right. -Qed. - -Theorem lt_succ_diag_r : forall n, n < S n. -Proof. -intro n. rewrite lt_succ_r. apply le_refl. -Qed. - -Theorem le_succ_diag_r : forall n, n <= S n. -Proof. -intro; apply lt_le_incl; apply lt_succ_diag_r. -Qed. - -Theorem neq_succ_diag_l : forall n, S n ~= n. -Proof. -intros n H. apply (lt_irrefl n). rewrite <- H at 2. apply lt_succ_diag_r. -Qed. - -Theorem neq_succ_diag_r : forall n, n ~= S n. -Proof. -intro n; apply neq_sym, neq_succ_diag_l. -Qed. - -Theorem nlt_succ_diag_l : forall n, ~ S n < n. -Proof. -intros n H. apply (lt_irrefl (S n)). rewrite lt_succ_r. now apply lt_le_incl. -Qed. - -Theorem nle_succ_diag_l : forall n, ~ S n <= n. -Proof. -intros n H; le_elim H. -+ false_hyp H nlt_succ_diag_l. + false_hyp H neq_succ_diag_l. -Qed. - -Theorem le_succ_l : forall n m, S n <= m <-> n < m. -Proof. -intros n m; nzinduct m n. -- split; intro H. + false_hyp H nle_succ_diag_l. + false_hyp H lt_irrefl. -- intro m. - rewrite (lt_eq_cases (S n) (S m)), !lt_succ_r, (lt_eq_cases n m), succ_inj_wd. - rewrite or_cancel_r. - + reflexivity. - + intros LE EQ; rewrite EQ in LE; false_hyp LE nle_succ_diag_l. - + intros LT EQ; rewrite EQ in LT; false_hyp LT lt_irrefl. -Qed. - -(** Trichotomy *) - -Theorem le_gt_cases : forall n m, n <= m \/ n > m. -Proof. -intros n m; nzinduct n m. -- left; apply le_refl. -- intro n. rewrite lt_succ_r, le_succ_l, !lt_eq_cases. intuition auto with relations. -Qed. - -Theorem lt_trichotomy : forall n m, n < m \/ n == m \/ m < n. -Proof. -intros n m. generalize (le_gt_cases n m); rewrite lt_eq_cases; tauto. -Qed. - -Notation lt_eq_gt_cases := lt_trichotomy (only parsing). - -(** *** Asymmetry and transitivity. *) - -Theorem lt_asymm : forall n m, n < m -> ~ m < n. -Proof. -intros n m; nzinduct n m. -- intros H; false_hyp H lt_irrefl. -- intro n; split; intros H H1 H2. - + apply lt_succ_r in H2. le_elim H2. - * apply H; auto. apply le_succ_l. now apply lt_le_incl. - * rewrite H2 in H1. false_hyp H1 nlt_succ_diag_l. - + apply le_succ_l in H1. le_elim H1. - * apply H; auto. rewrite lt_succ_r. now apply lt_le_incl. - * rewrite <- H1 in H2. false_hyp H2 nlt_succ_diag_l. -Qed. - -Notation lt_ngt := lt_asymm (only parsing). - -Theorem lt_trans : forall n m p, n < m -> m < p -> n < p. -Proof. -intros n m p; nzinduct p m. -- intros _ H; false_hyp H lt_irrefl. -- intro p. rewrite 2 lt_succ_r. - split; intros H H1 H2. - + apply lt_le_incl; le_elim H2; [now apply H | now rewrite H2 in H1]. - + assert (n <= p) as H3 by (auto using lt_le_incl). - le_elim H3. - * assumption. - * rewrite <- H3 in H2. - elim (lt_asymm n m); auto. -Qed. - -Theorem le_trans : forall n m p, n <= m -> m <= p -> n <= p. -Proof. -intros n m p. rewrite 3 lt_eq_cases. -intros [LT|EQ] [LT'|EQ']; try rewrite EQ; try rewrite <- EQ'; - generalize (lt_trans n m p); auto with relations. -Qed. - -(** *** Some type classes about order *) - -#[global] -Instance lt_strorder : StrictOrder lt. -Proof. split. - exact lt_irrefl. - exact lt_trans. Qed. - -#[global] -Instance le_preorder : PreOrder le. -Proof. split. - exact le_refl. - exact le_trans. Qed. - -#[global] -Instance le_partialorder : PartialOrder _ le. -Proof. -intros x y. compute. split. -- intro EQ; now rewrite EQ. -- rewrite 2 lt_eq_cases. intuition auto with relations. elim (lt_irrefl x). now transitivity y. -Qed. - -(** *** Making the generic [order] tactic *) - -Definition lt_compat := lt_wd. -Definition lt_total := lt_trichotomy. -Definition le_lteq := lt_eq_cases. - -Module Private_OrderTac. -Module IsTotal. - Definition eq_equiv := eq_equiv. - Definition lt_strorder := lt_strorder. - Definition lt_compat := lt_compat. - Definition lt_total := lt_total. - Definition le_lteq := le_lteq. -End IsTotal. -Module Tac := !MakeOrderTac NZ IsTotal. -End Private_OrderTac. -Ltac order := Private_OrderTac.Tac.order. - -(** *** Some direct consequences of [order] *) - -Theorem lt_neq : forall n m, n < m -> n ~= m. -Proof. order. Qed. - -Theorem le_neq : forall n m, n < m <-> n <= m /\ n ~= m. -Proof. intuition order. Qed. - -Theorem eq_le_incl : forall n m, n == m -> n <= m. -Proof. order. Qed. - -Lemma lt_stepl : forall x y z, x < y -> x == z -> z < y. -Proof. order. Qed. - -Lemma lt_stepr : forall x y z, x < y -> y == z -> x < z. -Proof. order. Qed. - -Lemma le_stepl : forall x y z, x <= y -> x == z -> z <= y. -Proof. order. Qed. - -Lemma le_stepr : forall x y z, x <= y -> y == z -> x <= z. -Proof. order. Qed. - -Declare Left Step lt_stepl. -Declare Right Step lt_stepr. -Declare Left Step le_stepl. -Declare Right Step le_stepr. - -Theorem le_lt_trans : forall n m p, n <= m -> m < p -> n < p. -Proof. order. Qed. - -Theorem lt_le_trans : forall n m p, n < m -> m <= p -> n < p. -Proof. order. Qed. - -Theorem le_antisymm : forall n m, n <= m -> m <= n -> n == m. -Proof. order. Qed. - -(** *** More properties of [<] and [<=] with respect to [S] and [0] *) - -Theorem le_succ_r : forall n m, n <= S m <-> n <= m \/ n == S m. -Proof. -intros n m; rewrite lt_eq_cases. now rewrite lt_succ_r. -Qed. - -Theorem lt_succ_l : forall n m, S n < m -> n < m. -Proof. -intros n m H; apply le_succ_l; order. -Qed. - -Theorem le_le_succ_r : forall n m, n <= m -> n <= S m. -Proof. -intros n m LE. apply lt_succ_r in LE. order. -Qed. - -Theorem lt_lt_succ_r : forall n m, n < m -> n < S m. -Proof. -intros. rewrite lt_succ_r. order. -Qed. - -Theorem succ_lt_mono : forall n m, n < m <-> S n < S m. -Proof. -intros n m. rewrite <- le_succ_l. symmetry. apply lt_succ_r. -Qed. - -Theorem succ_le_mono : forall n m, n <= m <-> S n <= S m. -Proof. -intros n m. now rewrite 2 lt_eq_cases, <- succ_lt_mono, succ_inj_wd. -Qed. - -Theorem lt_0_1 : 0 < 1. -Proof. -rewrite one_succ. apply lt_succ_diag_r. -Qed. - -Theorem le_0_1 : 0 <= 1. -Proof. -apply lt_le_incl, lt_0_1. -Qed. - -Theorem lt_1_2 : 1 < 2. -Proof. -rewrite two_succ. apply lt_succ_diag_r. -Qed. - -Theorem lt_0_2 : 0 < 2. -Proof. - transitivity 1. - apply lt_0_1. - apply lt_1_2. -Qed. - -Theorem le_0_2 : 0 <= 2. -Proof. -apply lt_le_incl, lt_0_2. -Qed. - -(** The order tactic enriched with some knowledge of 0,1,2 *) - -Ltac order' := generalize lt_0_1 lt_1_2; order. - -Theorem lt_1_l : forall n m, 0 < n -> n < m -> 1 < m. -Proof. -intros n m H1 H2. rewrite <- le_succ_l, <- one_succ in H1. order. -Qed. - -(** *** More Trichotomy, decidability and double negation elimination *) - -(** The following theorem is cleary redundant, but helps not to -remember whether one has to say [le_gt_cases] or [lt_ge_cases]. *) - -Theorem lt_ge_cases : forall n m, n < m \/ n >= m. -Proof. -intros n m; destruct (le_gt_cases m n); intuition order. -Qed. - -Theorem le_ge_cases : forall n m, n <= m \/ n >= m. -Proof. -intros n m; destruct (le_gt_cases n m); intuition order. -Qed. - -Theorem lt_gt_cases : forall n m, n ~= m <-> n < m \/ n > m. -Proof. -intros n m; destruct (lt_trichotomy n m); intuition order. -Qed. - -(** Decidability of equality, even though true in each finite ring, does not -have a uniform proof. Otherwise, the proof for two fixed numbers would -reduce to a normal form that will say if the numbers are equal or not, -which cannot be true in all finite rings. Therefore, we prove decidability -in the presence of order. *) - -Theorem eq_decidable : forall n m, decidable (n == m). -Proof. -intros n m; destruct (lt_trichotomy n m) as [ | [ | ]]; - (right; order) || (left; order). -Qed. - -(** DNE stands for double-negation elimination. *) - -Theorem eq_dne : forall n m, ~ ~ n == m <-> n == m. -Proof. -intros n m; split; intro H. -- destruct (eq_decidable n m) as [H1 | H1]. - + assumption. + false_hyp H1 H. -- intro H1; now apply H1. -Qed. - -Theorem le_ngt : forall n m, n <= m <-> ~ n > m. -Proof. intuition order. Qed. - -(** Redundant but useful *) - -Theorem nlt_ge : forall n m, ~ n < m <-> n >= m. -Proof. intuition order. Qed. - -Theorem lt_decidable : forall n m, decidable (n < m). -Proof. -intros n m; destruct (le_gt_cases m n); [right|left]; order. -Qed. - -Theorem lt_dne : forall n m, ~ ~ n < m <-> n < m. -Proof. -intros n m; split; intro H. -- destruct (lt_decidable n m) as [H1 | H1]; [assumption | false_hyp H1 H]. -- intro H1; false_hyp H H1. -Qed. - -Theorem nle_gt : forall n m, ~ n <= m <-> n > m. -Proof. intuition order. Qed. - -(** Redundant but useful *) - -Theorem lt_nge : forall n m, n < m <-> ~ n >= m. -Proof. intuition order. Qed. - -Theorem le_decidable : forall n m, decidable (n <= m). -Proof. -intros n m; destruct (le_gt_cases n m); [left|right]; order. -Qed. - -Theorem le_dne : forall n m, ~ ~ n <= m <-> n <= m. -Proof. -intros n m; split; intro H. -- destruct (le_decidable n m) as [H1 | H1]; [assumption | false_hyp H1 H]. -- intro H1; false_hyp H H1. -Qed. - -Theorem nlt_succ_r : forall n m, ~ m < S n <-> n < m. -Proof. -intros n m; rewrite lt_succ_r. intuition order. -Qed. - -(** The difference between integers and natural numbers is that for -every integer there is a predecessor, which is not true for natural -numbers. However, for both classes, every number that is bigger than -some other number has a predecessor. The proof of this fact by regular -induction does not go through, so we need to use strong -(course-of-value) induction. *) - -Theorem lt_exists_pred : - forall z n, z < n -> exists k, n == S k /\ z <= k. -Proof. -intros z n Hzn. assert (exists m, n <= m) as [m Hnm] by now exists n. -revert n Hzn Hnm. nzinduct m z. -- order. -- intro m; split; intros IH n H1 H2. - + apply le_succ_r in H2. destruct H2 as [H2 | H2]. - * now apply IH. * exists m. now split; [| rewrite <- lt_succ_r; rewrite <- H2]. - + apply IH. * assumption. * now apply le_le_succ_r. -Qed. - -Lemma lt_succ_pred : forall z n, z < n -> S (P n) == n. -Proof. - intros z n H. - destruct (lt_exists_pred _ _ H) as (n' & EQ & LE). - rewrite EQ. now rewrite pred_succ. -Qed. - -(** ** Order-based induction principles *) - -Section WF. - -Variable z : t. - -Let Rlt (n m : t) := z <= n < m. -Let Rgt (n m : t) := m < n <= z. - -Instance Rlt_wd : Proper (eq ==> eq ==> iff) Rlt. -Proof. -intros x1 x2 H1 x3 x4 H2; unfold Rlt. now rewrite H1, H2. -Qed. - -Instance Rgt_wd : Proper (eq ==> eq ==> iff) Rgt. -Proof. -intros x1 x2 H1 x3 x4 H2; unfold Rgt; now rewrite H1, H2. -Qed. - -Theorem lt_wf : well_founded Rlt. -Proof. -intros a. constructor. revert a. -refine (central_induction _ _ z _ _). -- solve_proper. -- intros y [??]. order. -- intros x. split. - + intros IH y [? [? | ->]%lt_succ_r%lt_eq_cases]. - * now apply IH. - * now constructor. - + intros IH y [? ?%lt_lt_succ_r]. now apply IH. -Qed. - -Theorem gt_wf : well_founded Rgt. -Proof. -intros a. constructor. revert a. -refine (central_induction _ _ z _ _). -- solve_proper. -- intros y [??]. order. -- intros x. split. - + intros IH y [?%lt_succ_l ?]. now apply IH. - + intros IH y [[? | <-]%le_succ_l%lt_eq_cases ?]. - * now apply IH. - * now constructor. -Qed. - -End WF. - -(** Stronger variant of induction with assumptions [n >= 0] ([n < 0]) -in the induction step *) - -Section Induction. - -Variable A : t -> Prop. -Hypothesis A_wd : Proper (eq==>iff) A. - -Section Center. - -Variable z : t. (* A z is the basis of induction *) - -Section RightInduction. - -Let A' (n : t) := forall m, z <= m -> m < n -> A m. -Let right_step := forall n, z <= n -> A n -> A (S n). -Let right_step' := forall n, z <= n -> A' n -> A n. -Let right_step'' := forall n, A' n <-> A' (S n). - -Theorem strong_right_induction: right_step' -> forall n, z <= n -> A n. -Proof. -intros Hstep. refine (well_founded_induction (lt_wf z) _ _). -intros x IH Hzx. apply Hstep; [trivial|]. -intros y ??. apply IH; [split|]; order. -Qed. - -Theorem right_induction : A z -> right_step -> forall n, z <= n -> A n. -Proof. -intros Az RS; apply strong_right_induction. -intros n H1 H2. -le_elim H1. -- apply lt_exists_pred in H1. destruct H1 as [k [H3 H4]]. - rewrite H3. apply RS; trivial. apply H2; trivial. - rewrite H3; apply lt_succ_diag_r. -- rewrite <- H1; apply Az. -Qed. - -Theorem right_induction' : - (forall n, n <= z -> A n) -> right_step -> forall n, A n. -Proof. -intros L R n. -destruct (lt_trichotomy n z) as [H | [H | H]]. -- apply L; now apply lt_le_incl. -- apply L; now apply eq_le_incl. -- apply right_induction. - + apply L; now apply eq_le_incl. - + assumption. - + now apply lt_le_incl. -Qed. - -Theorem strong_right_induction' : - (forall n, n <= z -> A n) -> right_step' -> forall n, A n. -Proof. -intros L R n. -destruct (lt_trichotomy n z) as [H | [H | H]]. -- apply L; now apply lt_le_incl. -- apply L; now apply eq_le_incl. -- apply strong_right_induction. - + assumption. + now apply lt_le_incl. -Qed. - -End RightInduction. - -Section LeftInduction. - -Let A' (n : t) := forall m, m <= z -> n <= m -> A m. -Let left_step := forall n, n < z -> A (S n) -> A n. -Let left_step' := forall n, n <= z -> A' (S n) -> A n. -Let left_step'' := forall n, A' n <-> A' (S n). - -Theorem strong_left_induction: left_step' -> forall n, n <= z -> A n. -Proof. -intros Hstep. refine (well_founded_induction (gt_wf z) _ _). -intros x IH Hzx. apply Hstep; [trivial|]. -intros y ? ?%le_succ_l. apply IH; [split|]; order. -Qed. - -Theorem left_induction : A z -> left_step -> forall n, n <= z -> A n. -Proof. -intros Az LS; apply strong_left_induction. -intros n H1 H2. le_elim H1. -- apply LS; trivial. apply H2; [now apply le_succ_l | now apply eq_le_incl]. -- rewrite H1; apply Az. -Qed. - -Theorem left_induction' : - (forall n, z <= n -> A n) -> left_step -> forall n, A n. -Proof. -intros R L n. -destruct (lt_trichotomy n z) as [H | [H | H]]. -- apply left_induction. - + apply R. now apply eq_le_incl. - + assumption. - + now apply lt_le_incl. -- rewrite H; apply R; now apply eq_le_incl. -- apply R; now apply lt_le_incl. -Qed. - -Theorem strong_left_induction' : - (forall n, z <= n -> A n) -> left_step' -> forall n, A n. -Proof. -intros R L n. -destruct (lt_trichotomy n z) as [H | [H | H]]. -- apply strong_left_induction. - + trivial. + now apply lt_le_incl. -- rewrite H; apply R; now apply eq_le_incl. -- apply R; now apply lt_le_incl. -Qed. - -End LeftInduction. - -Theorem order_induction : - A z -> - (forall n, z <= n -> A n -> A (S n)) -> - (forall n, n < z -> A (S n) -> A n) -> - forall n, A n. -Proof. -intros Az RS LS n. -destruct (lt_trichotomy n z) as [H | [H | H]]. -- now apply left_induction; [| | apply lt_le_incl]. -- now rewrite H. -- now apply right_induction; [| | apply lt_le_incl]. -Qed. - -Theorem order_induction' : - A z -> - (forall n, z <= n -> A n -> A (S n)) -> - (forall n, n <= z -> A n -> A (P n)) -> - forall n, A n. -Proof. -intros Az AS AP n; apply order_induction; try assumption. -intros m H1 H2. apply AP in H2; [|now apply le_succ_l]. -now rewrite pred_succ in H2. -Qed. - -End Center. - -Theorem order_induction_0 : - A 0 -> - (forall n, 0 <= n -> A n -> A (S n)) -> - (forall n, n < 0 -> A (S n) -> A n) -> - forall n, A n. -Proof. exact (order_induction 0). Qed. - -Theorem order_induction'_0 : - A 0 -> - (forall n, 0 <= n -> A n -> A (S n)) -> - (forall n, n <= 0 -> A n -> A (P n)) -> - forall n, A n. -Proof. exact (order_induction' 0). Qed. - -(** Elimination principle for [<] *) - -Theorem lt_ind : forall (n : t), - A (S n) -> - (forall m, n < m -> A m -> A (S m)) -> - forall m, n < m -> A m. -Proof. -intros n H1 H2 m H3. -apply right_induction with (S n); [assumption | | now apply le_succ_l]. -intros; apply H2; try assumption. now apply le_succ_l. -Qed. - -(** Elimination principle for [<=] *) - -Theorem le_ind : forall (n : t), - A n -> - (forall m, n <= m -> A m -> A (S m)) -> - forall m, n <= m -> A m. -Proof. -intros n H1 H2 m H3. -now apply right_induction with n. -Qed. - -End Induction. - -Tactic Notation "nzord_induct" ident(n) := - induction_maker n ltac:(apply order_induction_0). - -Tactic Notation "nzord_induct" ident(n) constr(z) := - induction_maker n ltac:(apply order_induction with z). - -(** Induction principles with respect to a measure *) - -Section MeasureInduction. - -Variable X : Type. -Variable f : X -> t. - -Theorem measure_right_induction : forall (A : X -> Type) (z : t), - (forall x, z <= f x -> (forall y, z <= f y < f x -> A y) -> A x) -> - forall x, z <= f x -> A x. -Proof. - intros A z IH x Hx. - enough (H : forall y, f y = f x -> A y) by now apply H. - induction (lt_wf z (f x)) as [n _ IH']. - intros y Hy. subst n. apply (IH y Hx). - intros y' Hy'. now apply (IH' _ Hy'). -Defined. - -Lemma measure_left_induction : forall (A : X -> Type) (z : t), - (forall x, f x <= z -> (forall y, f x < f y <= z -> A y) -> A x) -> - forall x, f x <= z -> A x. -Proof. - intros A z IH x Hx. - enough (H : forall y, f y = f x -> A y) by now apply H. - induction (gt_wf z (f x)) as [n _ IH']. - intros y Hy. subst n. apply (IH y Hx). - intros y' Hy'. now apply (IH' _ Hy'). -Defined. - -End MeasureInduction. - -End NZOrderProp. - -(* If we have moreover a [compare] function, we can build - an [OrderedType] structure. *) - -(* Temporary workaround for bug #2949: remove this problematic + unused functor -Module NZOrderedType (NZ : NZDecOrdSig') - <: DecidableTypeFull <: OrderedTypeFull - := NZ <+ NZBaseProp <+ NZOrderProp <+ Compare2EqBool <+ HasEqBool2Dec. -*) diff --git a/stdlib/theories/Numbers/NatInt/NZParity.v b/stdlib/theories/Numbers/NatInt/NZParity.v deleted file mode 100644 index a2aa5b73bf37..000000000000 --- a/stdlib/theories/Numbers/NatInt/NZParity.v +++ /dev/null @@ -1,283 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* bool. - Definition Even n := exists m, n == 2*m. - Definition Odd n := exists m, n == 2*m+1. - Axiom even_spec : forall n, even n = true <-> Even n. - Axiom odd_spec : forall n, odd n = true <-> Odd n. -End NZParity. - -Module Type NZParityProp - (Import A : NZOrdAxiomsSig') - (Import B : NZParity A) - (Import C : NZMulOrderProp A). - -(** Morphisms *) - -#[global] -Instance Even_wd : Proper (eq==>iff) Even. -Proof. unfold Even. solve_proper. Qed. - -#[global] -Instance Odd_wd : Proper (eq==>iff) Odd. -Proof. unfold Odd. solve_proper. Qed. - -#[global] -Instance even_wd : Proper (eq==>Logic.eq) even. -Proof. - intros x x' EQ. rewrite eq_iff_eq_true, 2 even_spec. now f_equiv. -Qed. - -#[global] -Instance odd_wd : Proper (eq==>Logic.eq) odd. -Proof. - intros x x' EQ. rewrite eq_iff_eq_true, 2 odd_spec. now f_equiv. -Qed. - -(** Evenness and oddity are dual notions *) - -Lemma Even_or_Odd : forall x, Even x \/ Odd x. -Proof. - intro x; nzinduct x. - - left. exists 0. now nzsimpl. - - intros x. - split; intros [(y,H)|(y,H)]. - + right. exists y. rewrite H. now nzsimpl. - + left. exists (S y). rewrite H. now nzsimpl'. - + right. - assert (LT : exists z, z 2*n < 2*m+1. -Proof. - intros. nzsimpl'. apply lt_succ_r. now apply add_le_mono. -Qed. - -Lemma double_above : forall n m, n 2*n+1 < 2*m. -Proof. - intros. nzsimpl'. - rewrite <- le_succ_l, <- add_succ_l, <- add_succ_r. - apply add_le_mono; now apply le_succ_l. -Qed. - -Lemma Even_Odd_False : forall x, Even x -> Odd x -> False. -Proof. -intros x (y,E) (z,O). rewrite O in E; clear O. -destruct (le_gt_cases y z) as [LE|GT]. -- generalize (double_below _ _ LE); order. -- generalize (double_above _ _ GT); order. -Qed. - -Lemma orb_even_odd : forall n, orb (even n) (odd n) = true. -Proof. - intros n. - destruct (Even_or_Odd n) as [H|H]. - - rewrite <- even_spec in H. now rewrite H. - - rewrite <- odd_spec in H. now rewrite H, orb_true_r. -Qed. - -Lemma negb_odd : forall n, negb (odd n) = even n. -Proof. - intros n. - generalize (Even_or_Odd n) (Even_Odd_False n). - rewrite <- even_spec, <- odd_spec. - destruct (odd n), (even n) ; simpl; intuition. -Qed. - -Lemma negb_even : forall n, negb (even n) = odd n. -Proof. - intros. rewrite <- negb_odd. apply negb_involutive. -Qed. - -(** Constants *) - -Lemma even_0 : even 0 = true. -Proof. - rewrite even_spec. exists 0. now nzsimpl. -Qed. - -Lemma odd_0 : odd 0 = false. -Proof. - now rewrite <- negb_even, even_0. -Qed. - -Lemma odd_1 : odd 1 = true. -Proof. - rewrite odd_spec. exists 0. now nzsimpl'. -Qed. - -Lemma even_1 : even 1 = false. -Proof. - now rewrite <- negb_odd, odd_1. -Qed. - -Lemma even_2 : even 2 = true. -Proof. - rewrite even_spec. exists 1. now nzsimpl'. -Qed. - -Lemma odd_2 : odd 2 = false. -Proof. - now rewrite <- negb_even, even_2. -Qed. - -(** Parity and successor *) - -Lemma Odd_succ : forall n, Odd (S n) <-> Even n. -Proof. - split; intros (m,H). - - exists m. apply succ_inj. now rewrite add_1_r in H. - - exists m. rewrite add_1_r. now f_equiv. -Qed. - -Lemma odd_succ : forall n, odd (S n) = even n. -Proof. - intros. apply eq_iff_eq_true. rewrite even_spec, odd_spec. - apply Odd_succ. -Qed. - -Lemma even_succ : forall n, even (S n) = odd n. -Proof. - intros. now rewrite <- negb_odd, odd_succ, negb_even. -Qed. - -Lemma Even_succ : forall n, Even (S n) <-> Odd n. -Proof. - intros. now rewrite <- even_spec, even_succ, odd_spec. -Qed. - -(** Parity and successor of successor *) - -Lemma Even_succ_succ : forall n, Even (S (S n)) <-> Even n. -Proof. - intros. now rewrite Even_succ, Odd_succ. -Qed. - -Lemma Odd_succ_succ : forall n, Odd (S (S n)) <-> Odd n. -Proof. - intros. now rewrite Odd_succ, Even_succ. -Qed. - -Lemma even_succ_succ : forall n, even (S (S n)) = even n. -Proof. - intros. now rewrite even_succ, odd_succ. -Qed. - -Lemma odd_succ_succ : forall n, odd (S (S n)) = odd n. -Proof. - intros. now rewrite odd_succ, even_succ. -Qed. - -(** Parity and addition *) - -Lemma even_add : forall n m, even (n+m) = Bool.eqb (even n) (even m). -Proof. - intros n m. - case_eq (even n); case_eq (even m); - rewrite <- ?negb_true_iff, ?negb_even, ?odd_spec, ?even_spec; - intros (m',Hm) (n',Hn). - - exists (n'+m'). now rewrite mul_add_distr_l, Hn, Hm. - - exists (n'+m'). now rewrite mul_add_distr_l, Hn, Hm, add_assoc. - - exists (n'+m'). now rewrite mul_add_distr_l, Hn, Hm, add_shuffle0. - - exists (n'+m'+1). rewrite Hm,Hn. nzsimpl'. now rewrite add_shuffle1. -Qed. - -Lemma odd_add : forall n m, odd (n+m) = xorb (odd n) (odd m). -Proof. - intros n m. rewrite <- !negb_even. rewrite even_add. - now destruct (even n), (even m). -Qed. - -(** Parity and multiplication *) - -Lemma even_mul : forall n m, even (mul n m) = even n || even m. -Proof. - intros n m. - case_eq (even n); simpl; rewrite ?even_spec. - - intros (n',Hn). exists (n'*m). now rewrite Hn, mul_assoc. - - case_eq (even m); simpl; rewrite ?even_spec. - + intros (m',Hm). exists (n*m'). now rewrite Hm, !mul_assoc, (mul_comm 2). - (* odd / odd *) - + rewrite <- !negb_true_iff, !negb_even, !odd_spec. - intros (m',Hm) (n',Hn). exists (n'*2*m' +n'+m'). - rewrite Hn,Hm, !mul_add_distr_l, !mul_add_distr_r, !mul_1_l, !mul_1_r. - now rewrite add_shuffle1, add_assoc, !mul_assoc. -Qed. - -Lemma odd_mul : forall n m, odd (mul n m) = odd n && odd m. -Proof. - intros n m. rewrite <- !negb_even. rewrite even_mul. - now destruct (even n), (even m). -Qed. - -(** A particular case : adding by an even number *) - -Lemma even_add_even : forall n m, Even m -> even (n+m) = even n. -Proof. - intros n m Hm. apply even_spec in Hm. - rewrite even_add, Hm. now destruct (even n). -Qed. - -Lemma odd_add_even : forall n m, Even m -> odd (n+m) = odd n. -Proof. - intros n m Hm. apply even_spec in Hm. - rewrite odd_add, <- (negb_even m), Hm. now destruct (odd n). -Qed. - -Lemma even_add_mul_even : forall n m p, Even m -> even (n+m*p) = even n. -Proof. - intros n m p Hm. apply even_spec in Hm. - apply even_add_even. apply even_spec. now rewrite even_mul, Hm. -Qed. - -Lemma odd_add_mul_even : forall n m p, Even m -> odd (n+m*p) = odd n. -Proof. - intros n m p Hm. apply even_spec in Hm. - apply odd_add_even. apply even_spec. now rewrite even_mul, Hm. -Qed. - -Lemma even_add_mul_2 : forall n m, even (n+2*m) = even n. -Proof. - intros. apply even_add_mul_even. apply even_spec, even_2. -Qed. - -Lemma odd_add_mul_2 : forall n m, odd (n+2*m) = odd n. -Proof. - intros. apply odd_add_mul_even. apply even_spec, even_2. -Qed. - -(** Parity of [2 * n] and [2 * n + 1] *) - -Lemma even_even : forall n, even (2 * n) = true. -Proof. intros n; apply even_spec; exists n; reflexivity. Qed. - -Lemma odd_even : forall n, odd (2 * n) = false. -Proof. intros n; rewrite <-(negb_even), even_even; reflexivity. Qed. - -Lemma odd_odd : forall n, odd (2 * n + 1) = true. -Proof. intros n; rewrite odd_spec; exists n; reflexivity. Qed. - -Lemma even_odd : forall n, even (2 * n + 1) = false. -Proof. intros n; rewrite <-(negb_odd), odd_odd; reflexivity. Qed. - -End NZParityProp. diff --git a/stdlib/theories/Numbers/NatInt/NZPow.v b/stdlib/theories/Numbers/NatInt/NZPow.v deleted file mode 100644 index 97f3f28dec74..000000000000 --- a/stdlib/theories/Numbers/NatInt/NZPow.v +++ /dev/null @@ -1,414 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* t -> t. -End Pow. - -Module Type PowNotation (A : Typ)(Import B : Pow A). - Infix "^" := pow. -End PowNotation. - -Module Type Pow' (A : Typ) := Pow A <+ PowNotation A. - -Module Type NZPowSpec (Import A : NZOrdAxiomsSig')(Import B : Pow' A). -#[global] - Declare Instance pow_wd : Proper (eq==>eq==>eq) pow. - Axiom pow_0_r : forall a, a^0 == 1. - Axiom pow_succ_r : forall a b, 0<=b -> a^(succ b) == a * a^b. - Axiom pow_neg_r : forall a b, b<0 -> a^b == 0. -End NZPowSpec. - -(** The above [pow_neg_r] specification is useless (and trivially - provable) for N. Having it here already allows deriving - some slightly more general statements. *) - -Module Type NZPow (A : NZOrdAxiomsSig) := Pow A <+ NZPowSpec A. -Module Type NZPow' (A : NZOrdAxiomsSig) := Pow' A <+ NZPowSpec A. - -(** Derived properties of power *) - -Module Type NZPowProp - (Import A : NZOrdAxiomsSig') - (Import B : NZPow' A) - (Import C : NZMulOrderProp A). - -Global Hint Rewrite pow_0_r pow_succ_r : nz. - -(** Power and basic constants *) - -Lemma pow_0_l : forall a, 0 0^a == 0. -Proof. - intros a Ha. - destruct (lt_exists_pred _ _ Ha) as (a' & EQ & Ha'). - rewrite EQ. now nzsimpl. -Qed. - -Lemma pow_0_l' : forall a, a~=0 -> 0^a == 0. -Proof. - intros a Ha. - destruct (lt_trichotomy a 0) as [LT|[EQ|GT]]; try order. - - now rewrite pow_neg_r. - - now apply pow_0_l. -Qed. - -Lemma pow_1_r : forall a, a^1 == a. -Proof. - intros. now nzsimpl'. -Qed. - -Lemma pow_1_l : forall a, 0<=a -> 1^a == 1. -Proof. - apply le_ind; intros. - solve_proper. - - now nzsimpl. - - now nzsimpl. -Qed. - -Global Hint Rewrite pow_1_r pow_1_l : nz. - -Lemma pow_2_r : forall a, a^2 == a*a. -Proof. - intros. rewrite two_succ. nzsimpl; order'. -Qed. - -Global Hint Rewrite pow_2_r : nz. - -(** Power and nullity *) - -Lemma pow_eq_0 : forall a b, 0<=b -> a^b == 0 -> a == 0. -Proof. - intros a b Hb. apply le_ind with (4:=Hb). - - solve_proper. - - rewrite pow_0_r. order'. - - clear b Hb. intros b Hb IH. - rewrite pow_succ_r by trivial. - intros H. apply eq_mul_0 in H. destruct H; trivial. - now apply IH. -Qed. - -Lemma pow_nonzero : forall a b, a~=0 -> 0<=b -> a^b ~= 0. -Proof. - intros a b Ha Hb. contradict Ha. now apply pow_eq_0 with b. -Qed. - -Lemma pow_eq_0_iff : forall a b, a^b == 0 <-> b<0 \/ (0 0<=c -> - a^(b+c) == a^b * a^c. -Proof. - intros a b c Hb. apply le_ind with (4:=Hb). - solve_proper. - - now nzsimpl. - - clear b Hb. intros b Hb IH Hc. - nzsimpl; trivial. - + rewrite IH; trivial. apply mul_assoc. - + now apply add_nonneg_nonneg. -Qed. - -Lemma pow_mul_l : forall a b c, - (a*b)^c == a^c * b^c. -Proof. - intros a b c. - destruct (lt_ge_cases c 0) as [Hc|Hc]. - - rewrite !(pow_neg_r _ _ Hc). now nzsimpl. - - apply le_ind with (4:=Hc). + solve_proper. - + now nzsimpl. - + clear c Hc. intros c Hc IH. - nzsimpl; trivial. - rewrite IH; trivial. apply mul_shuffle1. -Qed. - -Lemma pow_mul_r : forall a b c, 0<=b -> 0<=c -> - a^(b*c) == (a^b)^c. -Proof. - intros a b c Hb. apply le_ind with (4:=Hb). - solve_proper. - - intros. now nzsimpl. - - clear b Hb. intros b Hb IH Hc. - nzsimpl; trivial. - rewrite pow_add_r, IH, pow_mul_l; trivial. + apply mul_comm. - + now apply mul_nonneg_nonneg. -Qed. - -(** Positivity *) - -Lemma pow_nonneg : forall a b, 0<=a -> 0<=a^b. -Proof. - intros a b Ha. - destruct (lt_ge_cases b 0) as [Hb|Hb]. - - now rewrite !(pow_neg_r _ _ Hb). - - apply le_ind with (4:=Hb). + solve_proper. - + nzsimpl; order'. - + clear b Hb. intros b Hb IH. - nzsimpl; trivial. now apply mul_nonneg_nonneg. -Qed. - -Lemma pow_pos_nonneg : forall a b, 0 0<=b -> 0 0<=a a^c < b^c. -Proof. - intros a b c Hc. apply lt_ind with (4:=Hc). - solve_proper. - - intros (Ha,H). nzsimpl; trivial; order. - - clear c Hc. intros c Hc IH (Ha,H). - nzsimpl; try order. - apply mul_lt_mono_nonneg; trivial. - + apply pow_nonneg; try order. - + apply IH. now split. -Qed. - -Lemma pow_le_mono_l : forall a b c, 0<=a<=b -> a^c <= b^c. -Proof. - intros a b c (Ha,H). - destruct (lt_trichotomy c 0) as [Hc|[Hc|Hc]]. - - rewrite !(pow_neg_r _ _ Hc); now nzsimpl. - - rewrite Hc; now nzsimpl. - - apply lt_eq_cases in H. destruct H as [H|H]; [|now rewrite <- H]. - apply lt_le_incl, pow_lt_mono_l; now try split. -Qed. - -Lemma pow_gt_1 : forall a b, 1 (0 1 0<=c -> b a^b < a^c. -Proof. - intros a b c Ha Hc H. - destruct (lt_ge_cases b 0) as [Hb|Hb]. - - rewrite pow_neg_r by trivial. apply pow_pos_nonneg; order'. - - assert (H' : b<=c) by order. - destruct (le_exists_sub _ _ H') as (d & EQ & Hd). - rewrite EQ, pow_add_r; trivial. rewrite <- (mul_1_l (a^b)) at 1. - apply mul_lt_mono_pos_r. - + apply pow_pos_nonneg; order'. - + apply pow_gt_1; trivial. - apply lt_eq_cases in Hd; destruct Hd as [LT|EQ']; trivial. - rewrite <- EQ' in *. rewrite add_0_l in EQ. order. -Qed. - -(** NB: since 0^0 > 0^1, the following result isn't valid with a=0 *) - -Lemma pow_le_mono_r : forall a b c, 0 b<=c -> a^b <= a^c. -Proof. - intros a b c Ha H. - destruct (lt_ge_cases b 0) as [Hb|Hb]. - - rewrite (pow_neg_r _ _ Hb). apply pow_nonneg; order. - - apply le_succ_l in Ha; rewrite <- one_succ in Ha. - apply lt_eq_cases in Ha; destruct Ha as [Ha|Ha]; [|rewrite <- Ha]. - + apply lt_eq_cases in H; destruct H as [H|H]; [|now rewrite <- H]. - apply lt_le_incl, pow_lt_mono_r; order. - + nzsimpl; order. -Qed. - -Lemma pow_le_mono : forall a b c d, 0 b<=d -> - a^b <= c^d. -Proof. - intros a b c d ? ?. transitivity (a^d). - - apply pow_le_mono_r; intuition order. - - apply pow_le_mono_l; intuition order. -Qed. - -Lemma pow_lt_mono : forall a b c d, 0 0 - a^b < c^d. -Proof. - intros a b c d (Ha,Hac) (Hb,Hbd). - apply le_succ_l in Ha; rewrite <- one_succ in Ha. - apply lt_eq_cases in Ha; destruct Ha as [Ha|Ha]; [|rewrite <- Ha]. - - transitivity (a^d). - + apply pow_lt_mono_r; intuition order. - + apply pow_lt_mono_l; try split; order'. - - nzsimpl; try order. apply pow_gt_1; order. -Qed. - -(** Injectivity *) - -Lemma pow_inj_l : forall a b c, 0<=a -> 0<=b -> 0 - a^c == b^c -> a == b. -Proof. - intros a b c Ha Hb Hc EQ. - destruct (lt_trichotomy a b) as [LT|[EQ'|GT]]; trivial. - - assert (a^c < b^c) by (apply pow_lt_mono_l; try split; trivial). - order. - - assert (b^c < a^c) by (apply pow_lt_mono_l; try split; trivial). - order. -Qed. - -Lemma pow_inj_r : forall a b c, 1 0<=b -> 0<=c -> - a^b == a^c -> b == c. -Proof. - intros a b c Ha Hb Hc EQ. - destruct (lt_trichotomy b c) as [LT|[EQ'|GT]]; trivial. - - assert (a^b < a^c) by (apply pow_lt_mono_r; try split; trivial). - order. - - assert (a^c < a^b) by (apply pow_lt_mono_r; try split; trivial). - order. -Qed. - -(** Monotonicity results, both ways *) - -Lemma pow_lt_mono_l_iff : forall a b c, 0<=a -> 0<=b -> 0 - (a a^c < b^c). -Proof. - intros a b c Ha Hb Hc. - split; intro LT. - - apply pow_lt_mono_l; try split; trivial. - - destruct (le_gt_cases b a) as [LE|GT]; trivial. - assert (b^c <= a^c) by (apply pow_le_mono_l; try split; order). - order. -Qed. - -Lemma pow_le_mono_l_iff : forall a b c, 0<=a -> 0<=b -> 0 - (a<=b <-> a^c <= b^c). -Proof. - intros a b c Ha Hb Hc. - split; intro LE. - - apply pow_le_mono_l; try split; trivial. - - destruct (le_gt_cases a b) as [LE'|GT]; trivial. - assert (b^c < a^c) by (apply pow_lt_mono_l; try split; trivial). - order. -Qed. - -Lemma pow_lt_mono_r_iff : forall a b c, 1 0<=c -> - (b a^b < a^c). -Proof. - intros a b c Ha Hc. - split; intro LT. - - now apply pow_lt_mono_r. - - destruct (le_gt_cases c b) as [LE|GT]; trivial. - assert (a^c <= a^b) by (apply pow_le_mono_r; order'). - order. -Qed. - -Lemma pow_le_mono_r_iff : forall a b c, 1 0<=c -> - (b<=c <-> a^b <= a^c). -Proof. - intros a b c Ha Hc. - split; intro LE. - - apply pow_le_mono_r; order'. - - destruct (le_gt_cases b c) as [LE'|GT]; trivial. - assert (a^c < a^b) by (apply pow_lt_mono_r; order'). - order. -Qed. - -(** For any a>1, the a^x function is above the identity function *) - -Lemma pow_gt_lin_r : forall a b, 1 0<=b -> b < a^b. -Proof. - intros a b Ha Hb. apply le_ind with (4:=Hb). - solve_proper. - - nzsimpl. order'. - - clear b Hb. intros b Hb IH. nzsimpl; trivial. - rewrite <- !le_succ_l in *. rewrite <- two_succ in Ha. - transitivity (2*(S b)). - + nzsimpl'. rewrite <- 2 succ_le_mono. - rewrite <- (add_0_l b) at 1. apply add_le_mono; order. - + apply mul_le_mono_nonneg; trivial. - * order'. - * now apply lt_le_incl, lt_succ_r. -Qed. - -(** Someday, we should say something about the full Newton formula. - In the meantime, we can at least provide some inequalities about - (a+b)^c. -*) - -Lemma pow_add_lower : forall a b c, 0<=a -> 0<=b -> 0 - a^c + b^c <= (a+b)^c. -Proof. - intros a b c Ha Hb Hc. apply lt_ind with (4:=Hc). - solve_proper. - - nzsimpl; order. - - clear c Hc. intros c Hc IH. - assert (0<=c) by order'. - nzsimpl; trivial. - transitivity ((a+b)*(a^c + b^c)). - + rewrite mul_add_distr_r, !mul_add_distr_l. - apply add_le_mono. - * rewrite <- add_0_r at 1. apply add_le_mono_l. - apply mul_nonneg_nonneg; trivial. - apply pow_nonneg; trivial. - * rewrite <- add_0_l at 1. apply add_le_mono_r. - apply mul_nonneg_nonneg; trivial. - apply pow_nonneg; trivial. - + apply mul_le_mono_nonneg_l; trivial. - now apply add_nonneg_nonneg. -Qed. - -(** This upper bound can also be seen as a convexity proof for x^c : - image of (a+b)/2 is below the middle of the images of a and b -*) - -Lemma pow_add_upper : forall a b c, 0<=a -> 0<=b -> 0 - (a+b)^c <= 2^(pred c) * (a^c + b^c). -Proof. - assert (aux : forall a b c, 0<=a<=b -> 0 - (a + b) * (a ^ c + b ^ c) <= 2 * (a * a ^ c + b * b ^ c)). - (* begin *) - - intros a b c (Ha,H) Hc. - rewrite !mul_add_distr_l, !mul_add_distr_r. nzsimpl'. - rewrite <- !add_assoc. apply add_le_mono_l. - rewrite !add_assoc. apply add_le_mono_r. - destruct (le_exists_sub _ _ H) as (d & EQ & Hd). - rewrite EQ. - rewrite 2 mul_add_distr_r. - rewrite !add_assoc. apply add_le_mono_r. - rewrite add_comm. apply add_le_mono_l. - apply mul_le_mono_nonneg_l; trivial. - apply pow_le_mono_l; try split; order. - (* end *) - - intros a b c Ha Hb Hc. apply lt_ind with (4:=Hc). + solve_proper. - + nzsimpl; order. - + clear c Hc. intros c Hc IH. - assert (0<=c) by order. - nzsimpl; trivial. - transitivity ((a+b)*(2^(pred c) * (a^c + b^c))). - * apply mul_le_mono_nonneg_l; trivial. - now apply add_nonneg_nonneg. - * rewrite mul_assoc. rewrite (mul_comm (a+b)). - assert (EQ : S (P c) == c) by (apply lt_succ_pred with 0; order'). - assert (LE : 0 <= P c) by (now rewrite succ_le_mono, EQ, le_succ_l). - assert (EQ' : 2^c == 2^(P c) * 2) by (rewrite <- EQ at 1; nzsimpl'; order). - rewrite EQ', <- !mul_assoc. - apply mul_le_mono_nonneg_l. - -- apply pow_nonneg; order'. - -- destruct (le_gt_cases a b). - ++ apply aux; try split; order'. - ++ rewrite (add_comm a), (add_comm (a^c)), (add_comm (a*a^c)). - apply aux; try split; order'. -Qed. - -End NZPowProp. diff --git a/stdlib/theories/Numbers/NatInt/NZProperties.v b/stdlib/theories/Numbers/NatInt/NZProperties.v deleted file mode 100644 index 3d57ce29cd32..000000000000 --- a/stdlib/theories/Numbers/NatInt/NZProperties.v +++ /dev/null @@ -1,21 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* t. -End Sqrt. - -Module Type SqrtNotation (A : Typ)(Import B : Sqrt A). - Notation "āˆš x" := (sqrt x) (at level 6). -End SqrtNotation. - -Module Type Sqrt' (A : Typ) := Sqrt A <+ SqrtNotation A. - -Module Type NZSqrtSpec (Import A : NZOrdAxiomsSig')(Import B : Sqrt' A). - Axiom sqrt_spec : forall a, 0<=a -> āˆša * āˆša <= a < S (āˆša) * S (āˆša). - Axiom sqrt_neg : forall a, a<0 -> āˆša == 0. -End NZSqrtSpec. - -Module Type NZSqrt (A : NZOrdAxiomsSig) := Sqrt A <+ NZSqrtSpec A. -Module Type NZSqrt' (A : NZOrdAxiomsSig) := Sqrt' A <+ NZSqrtSpec A. - -(** Derived properties of power *) - -Module Type NZSqrtProp - (Import A : NZOrdAxiomsSig') - (Import B : NZSqrt' A) - (Import C : NZMulOrderProp A). - -Local Notation "a Ā²" := (a*a) (at level 5, no associativity, format "a Ā²"). - -(** First, sqrt is non-negative *) - -Lemma sqrt_spec_nonneg : forall b, - bĀ² < (S b)Ā² -> 0 <= b. -Proof. - intros b LT. - destruct (le_gt_cases 0 b) as [Hb|Hb]; trivial. exfalso. - assert ((S b)Ā² < bĀ²). - - rewrite mul_succ_l, <- (add_0_r bĀ²). - apply add_lt_le_mono. - + apply mul_lt_mono_neg_l; trivial. apply lt_succ_diag_r. - + now apply le_succ_l. - - order. -Qed. - -Lemma sqrt_nonneg : forall a, 0<=āˆša. -Proof. - intros a. destruct (lt_ge_cases a 0) as [Ha|Ha]. - - now rewrite (sqrt_neg _ Ha). - - apply sqrt_spec_nonneg. destruct (sqrt_spec a Ha). order. -Qed. - -(** The spec of sqrt indeed determines it *) - -Lemma sqrt_unique : forall a b, bĀ² <= a < (S b)Ā² -> āˆša == b. -Proof. - intros a b (LEb,LTb). - assert (Ha : 0<=a) by (transitivity (bĀ²); trivial using square_nonneg). - assert (Hb : 0<=b) by (apply sqrt_spec_nonneg; order). - assert (Ha': 0<=āˆša) by now apply sqrt_nonneg. - destruct (sqrt_spec a Ha) as (LEa,LTa). - assert (b <= āˆša). - - apply lt_succ_r, square_lt_simpl_nonneg; [|order]. - now apply lt_le_incl, lt_succ_r. - - assert (āˆša <= b). - + apply lt_succ_r, square_lt_simpl_nonneg; [|order]. - now apply lt_le_incl, lt_succ_r. - + order. -Qed. - -(** Hence sqrt is a morphism *) - -#[global] -Instance sqrt_wd : Proper (eq==>eq) sqrt. -Proof. - intros x x' Hx. - destruct (lt_ge_cases x 0) as [H|H]. - - rewrite 2 sqrt_neg; trivial. + reflexivity. - + now rewrite <- Hx. - - apply sqrt_unique. rewrite Hx in *. now apply sqrt_spec. -Qed. - -(** An alternate specification *) - -Lemma sqrt_spec_alt : forall a, 0<=a -> exists r, - a == (āˆša)Ā² + r /\ 0 <= r <= 2*āˆša. -Proof. - intros a Ha. - destruct (sqrt_spec _ Ha) as (LE,LT). - destruct (le_exists_sub _ _ LE) as (r & Hr & Hr'). - exists r. - split. - now rewrite add_comm. - - split. + trivial. - + apply (add_le_mono_r _ _ (āˆša)Ā²). - rewrite <- Hr, add_comm. - generalize LT. nzsimpl'. now rewrite lt_succ_r, add_assoc. -Qed. - -Lemma sqrt_unique' : forall a b c, 0<=c<=2*b -> - a == bĀ² + c -> āˆša == b. -Proof. - intros a b c (Hc,H) EQ. - apply sqrt_unique. - rewrite EQ. - split. - - rewrite <- add_0_r at 1. now apply add_le_mono_l. - - nzsimpl. apply lt_succ_r. - rewrite <- add_assoc. apply add_le_mono_l. - generalize H; now nzsimpl'. -Qed. - -(** Sqrt is exact on squares *) - -Lemma sqrt_square : forall a, 0<=a -> āˆš(aĀ²) == a. -Proof. - intros a Ha. - apply sqrt_unique' with 0. - - split. + order. + apply mul_nonneg_nonneg; order'. - now nzsimpl. -Qed. - -(** Sqrt and predecessors of squares *) - -Lemma sqrt_pred_square : forall a, 0 āˆš(P aĀ²) == P a. -Proof. - intros a Ha. - apply sqrt_unique. - assert (EQ := lt_succ_pred 0 a Ha). - rewrite EQ. split. - - apply lt_succ_r. - rewrite (lt_succ_pred 0). - + assert (0 <= P a) by (now rewrite <- lt_succ_r, EQ). - assert (P a < a) by (now rewrite <- le_succ_l, EQ). - apply mul_lt_mono_nonneg; trivial. - + now apply mul_pos_pos. - - apply le_succ_l. - rewrite (lt_succ_pred 0). + reflexivity. + now apply mul_pos_pos. -Qed. - -(** Sqrt is a monotone function (but not a strict one) *) - -Lemma sqrt_le_mono : forall a b, a <= b -> āˆša <= āˆšb. -Proof. - intros a b Hab. - destruct (lt_ge_cases a 0) as [Ha|Ha]. - - rewrite (sqrt_neg _ Ha). apply sqrt_nonneg. - - assert (Hb : 0 <= b) by order. - destruct (sqrt_spec a Ha) as (LE,_). - destruct (sqrt_spec b Hb) as (_,LT). - apply lt_succ_r. - apply square_lt_simpl_nonneg; try order. - now apply lt_le_incl, lt_succ_r, sqrt_nonneg. -Qed. - -(** No reverse result for <=, consider for instance āˆš2 <= āˆš1 *) - -Lemma sqrt_lt_cancel : forall a b, āˆša < āˆšb -> a < b. -Proof. - intros a b H. - destruct (lt_ge_cases b 0) as [Hb|Hb]. - - rewrite (sqrt_neg b Hb) in H; generalize (sqrt_nonneg a); order. - - destruct (lt_ge_cases a 0) as [Ha|Ha]; [order|]. - destruct (sqrt_spec a Ha) as (_,LT). - destruct (sqrt_spec b Hb) as (LE,_). - apply le_succ_l in H. - assert ((S (āˆša))Ā² <= (āˆšb)Ā²). - + apply mul_le_mono_nonneg; trivial. - * now apply lt_le_incl, lt_succ_r, sqrt_nonneg. - * now apply lt_le_incl, lt_succ_r, sqrt_nonneg. - + order. -Qed. - -(** When left side is a square, we have an equivalence for <= *) - -Lemma sqrt_le_square : forall a b, 0<=a -> 0<=b -> (bĀ²<=a <-> b <= āˆša). -Proof. - intros a b Ha Hb. split; intros H. - - rewrite <- (sqrt_square b); trivial. - now apply sqrt_le_mono. - - destruct (sqrt_spec a Ha) as (LE,LT). - transitivity (āˆša)Ā²; trivial. - now apply mul_le_mono_nonneg. -Qed. - -(** When right side is a square, we have an equivalence for < *) - -Lemma sqrt_lt_square : forall a b, 0<=a -> 0<=b -> (a āˆša < b). -Proof. - intros a b Ha Hb. split; intros H. - - destruct (sqrt_spec a Ha) as (LE,_). - apply square_lt_simpl_nonneg; try order. - - rewrite <- (sqrt_square b Hb) in H. - now apply sqrt_lt_cancel. -Qed. - -(** Sqrt and basic constants *) - -Lemma sqrt_0 : āˆš0 == 0. -Proof. - rewrite <- (mul_0_l 0) at 1. now apply sqrt_square. -Qed. - -Lemma sqrt_1 : āˆš1 == 1. -Proof. - rewrite <- (mul_1_l 1) at 1. apply sqrt_square. order'. -Qed. - -Lemma sqrt_2 : āˆš2 == 1. -Proof. - apply sqrt_unique' with 1. - nzsimpl; split; order'. - now nzsimpl'. -Qed. - -Lemma sqrt_pos : forall a, 0 < āˆša <-> 0 < a. -Proof. - intros a. split; intros Ha. - apply sqrt_lt_cancel. now rewrite sqrt_0. - - rewrite <- le_succ_l, <- one_succ, <- sqrt_1. apply sqrt_le_mono. - now rewrite one_succ, le_succ_l. -Qed. - -Lemma sqrt_lt_lin : forall a, 1 āˆša āˆša<=a. -Proof. - intros a Ha. - destruct (le_gt_cases a 0) as [H|H]. - - setoid_replace a with 0 by order. now rewrite sqrt_0. - - destruct (le_gt_cases a 1) as [H'|H']. - + rewrite <- le_succ_l, <- one_succ in H. - setoid_replace a with 1 by order. now rewrite sqrt_1. - + now apply lt_le_incl, sqrt_lt_lin. -Qed. - -(** Sqrt and multiplication. *) - -(** Due to rounding error, we don't have the usual āˆš(a*b) = āˆša*āˆšb - but only lower and upper bounds. *) - -Lemma sqrt_mul_below : forall a b, āˆša * āˆšb <= āˆš(a*b). -Proof. - intros a b. - destruct (lt_ge_cases a 0) as [Ha|Ha]. - - rewrite (sqrt_neg a Ha). nzsimpl. apply sqrt_nonneg. - - destruct (lt_ge_cases b 0) as [Hb|Hb]. - + rewrite (sqrt_neg b Hb). nzsimpl. apply sqrt_nonneg. - + assert (Ha':=sqrt_nonneg a). - assert (Hb':=sqrt_nonneg b). - apply sqrt_le_square; try now apply mul_nonneg_nonneg. - rewrite mul_shuffle1. - apply mul_le_mono_nonneg; try now apply mul_nonneg_nonneg. - * now apply sqrt_spec. - * now apply sqrt_spec. -Qed. - -Lemma sqrt_mul_above : forall a b, 0<=a -> 0<=b -> āˆš(a*b) < S (āˆša) * S (āˆšb). -Proof. - intros a b Ha Hb. - apply sqrt_lt_square. - - now apply mul_nonneg_nonneg. - - apply mul_nonneg_nonneg. - + now apply lt_le_incl, lt_succ_r, sqrt_nonneg. - + now apply lt_le_incl, lt_succ_r, sqrt_nonneg. - - rewrite mul_shuffle1. - apply mul_lt_mono_nonneg; trivial; now apply sqrt_spec. -Qed. - -(** And we can't find better approximations in general. - - The lower bound is exact for squares - - Concerning the upper bound, for any c>0, take a=b=cĀ²-1, - then āˆš(a*b) = cĀ² -1 while S āˆša = S āˆšb = c -*) - -(** Sqrt and successor : - - the sqrt function climbs by at most 1 at a time - - otherwise it stays at the same value - - the +1 steps occur for squares -*) - -Lemma sqrt_succ_le : forall a, 0<=a -> āˆš(S a) <= S (āˆša). -Proof. - intros a Ha. - apply lt_succ_r. - apply sqrt_lt_square. - - now apply le_le_succ_r. - - apply le_le_succ_r, le_le_succ_r, sqrt_nonneg. - - rewrite <- (add_1_l (S (āˆša))). - apply lt_le_trans with (1Ā²+(S (āˆša))Ā²). - + rewrite mul_1_l, add_1_l, <- succ_lt_mono. - now apply sqrt_spec. - + apply add_square_le. * order'. * apply le_le_succ_r, sqrt_nonneg. -Qed. - -Lemma sqrt_succ_or : forall a, 0<=a -> āˆš(S a) == S (āˆša) \/ āˆš(S a) == āˆša. -Proof. - intros a Ha. - destruct (le_gt_cases (āˆš(S a)) (āˆša)) as [H|H]. - - right. generalize (sqrt_le_mono _ _ (le_succ_diag_r a)); order. - - left. apply le_succ_l in H. generalize (sqrt_succ_le a Ha); order. -Qed. - -Lemma sqrt_eq_succ_iff_square : forall a, 0<=a -> - (āˆš(S a) == S (āˆša) <-> exists b, 0 āˆš(a+b) <= āˆša + āˆšb). - - intros a b Ha. rewrite (sqrt_neg a Ha). nzsimpl. - apply sqrt_le_mono. - rewrite <- (add_0_l b) at 2. - apply add_le_mono_r; order. - - intros a b. - destruct (lt_ge_cases a 0) as [Ha|Ha]. + now apply AUX. - + destruct (lt_ge_cases b 0) as [Hb|Hb]. - * rewrite (add_comm a), (add_comm (āˆša)); now apply AUX. - * assert (Ha':=sqrt_nonneg a). - assert (Hb':=sqrt_nonneg b). - rewrite <- lt_succ_r. - apply sqrt_lt_square. - -- now apply add_nonneg_nonneg. - -- now apply lt_le_incl, lt_succ_r, add_nonneg_nonneg. - -- destruct (sqrt_spec a Ha) as (_,LTa). - destruct (sqrt_spec b Hb) as (_,LTb). - revert LTa LTb. nzsimpl. rewrite 3 lt_succ_r. - intros LTa LTb. - assert (H:=add_le_mono _ _ _ _ LTa LTb). - etransitivity; [eexact H|]. clear LTa LTb H. - rewrite <- (add_assoc _ (āˆša) (āˆša)). - rewrite <- (add_assoc _ (āˆšb) (āˆšb)). - rewrite add_shuffle1. - rewrite <- (add_assoc _ (āˆša + āˆšb)). - rewrite (add_shuffle1 (āˆša) (āˆšb)). - apply add_le_mono_r. - now apply add_square_le. -Qed. - -(** convexity inequality for sqrt: sqrt of middle is above middle - of square roots. *) - -Lemma add_sqrt_le : forall a b, 0<=a -> 0<=b -> āˆša + āˆšb <= āˆš(2*(a+b)). -Proof. - intros a b Ha Hb. - assert (Ha':=sqrt_nonneg a). - assert (Hb':=sqrt_nonneg b). - apply sqrt_le_square. - - apply mul_nonneg_nonneg. + order'. + now apply add_nonneg_nonneg. - - now apply add_nonneg_nonneg. - - transitivity (2*((āˆša)Ā² + (āˆšb)Ā²)). - + now apply square_add_le. - + apply mul_le_mono_nonneg_l. * order'. - * apply add_le_mono; now apply sqrt_spec. -Qed. - -End NZSqrtProp. - -Module Type NZSqrtUpProp - (Import A : NZDecOrdAxiomsSig') - (Import B : NZSqrt' A) - (Import C : NZMulOrderProp A) - (Import D : NZSqrtProp A B C). - -(** * [sqrt_up] : a square root that rounds up instead of down *) - -Local Notation "a Ā²" := (a*a) (at level 5, no associativity, format "a Ā²"). - -(** For once, we define instead of axiomatizing, thanks to sqrt *) - -Definition sqrt_up a := - match compare 0 a with - | Lt => S āˆš(P a) - | _ => 0 - end. - -Local Notation "āˆšĀ° a" := (sqrt_up a) (at level 6, no associativity). - -Lemma sqrt_up_eqn0 : forall a, a<=0 -> āˆšĀ°a == 0. -Proof. - intros a Ha. unfold sqrt_up. case compare_spec; try order. -Qed. - -Lemma sqrt_up_eqn : forall a, 0 āˆšĀ°a == S āˆš(P a). -Proof. - intros a Ha. unfold sqrt_up. case compare_spec; try order. -Qed. - -Lemma sqrt_up_spec : forall a, 0 (P āˆšĀ°a)Ā² < a <= (āˆšĀ°a)Ā². -Proof. - intros a Ha. - rewrite sqrt_up_eqn, pred_succ; trivial. - assert (Ha' := lt_succ_pred 0 a Ha). - rewrite <- Ha' at 3 4. - rewrite le_succ_l, lt_succ_r. - apply sqrt_spec. - now rewrite <- lt_succ_r, Ha'. -Qed. - -(** First, [sqrt_up] is non-negative *) - -Lemma sqrt_up_nonneg : forall a, 0<=āˆšĀ°a. -Proof. - intros a. destruct (le_gt_cases a 0) as [Ha|Ha]. - - now rewrite sqrt_up_eqn0. - - rewrite sqrt_up_eqn; trivial. apply le_le_succ_r, sqrt_nonneg. -Qed. - -(** [sqrt_up] is a morphism *) - -#[global] -Instance sqrt_up_wd : Proper (eq==>eq) sqrt_up. -Proof. - assert (Proper (eq==>eq==>Logic.eq) compare). - - intros x x' Hx y y' Hy. do 2 case compare_spec; trivial; order. - - intros x x' Hx; unfold sqrt_up; rewrite Hx; case compare; now rewrite ?Hx. -Qed. - -(** The spec of [sqrt_up] indeed determines it *) - -Lemma sqrt_up_unique : forall a b, 0 (P b)Ā² < a <= bĀ² -> āˆšĀ°a == b. -Proof. - intros a b Hb (LEb,LTb). - assert (Ha : 0 āˆšĀ°(aĀ²) == a. -Proof. - intros a Ha. - le_elim Ha. - - rewrite sqrt_up_eqn by (now apply mul_pos_pos). - rewrite sqrt_pred_square; trivial. apply (lt_succ_pred 0); trivial. - - rewrite sqrt_up_eqn0; trivial. rewrite <- Ha. now nzsimpl. -Qed. - -(** [sqrt_up] and successors of squares *) - -Lemma sqrt_up_succ_square : forall a, 0<=a -> āˆšĀ°(S aĀ²) == S a. -Proof. - intros a Ha. - rewrite sqrt_up_eqn by (now apply lt_succ_r, mul_nonneg_nonneg). - now rewrite pred_succ, sqrt_square. -Qed. - -(** Basic constants *) - -Lemma sqrt_up_0 : āˆšĀ°0 == 0. -Proof. - rewrite <- (mul_0_l 0) at 1. now apply sqrt_up_square. -Qed. - -Lemma sqrt_up_1 : āˆšĀ°1 == 1. -Proof. - rewrite <- (mul_1_l 1) at 1. apply sqrt_up_square. order'. -Qed. - -Lemma sqrt_up_2 : āˆšĀ°2 == 2. -Proof. - rewrite sqrt_up_eqn by order'. - now rewrite two_succ, pred_succ, sqrt_1. -Qed. - -(** Links between sqrt and [sqrt_up] *) - -Lemma le_sqrt_sqrt_up : forall a, āˆša <= āˆšĀ°a. -Proof. - intros a. unfold sqrt_up. case compare_spec; intros H. - - rewrite <- H, sqrt_0. order. - - rewrite <- (lt_succ_pred 0 a H) at 1. apply sqrt_succ_le. - apply lt_succ_r. now rewrite (lt_succ_pred 0 a H). - - now rewrite sqrt_neg. -Qed. - -Lemma le_sqrt_up_succ_sqrt : forall a, āˆšĀ°a <= S (āˆša). -Proof. - intros a. unfold sqrt_up. - case compare_spec; intros H; try apply le_le_succ_r, sqrt_nonneg. - rewrite <- succ_le_mono. apply sqrt_le_mono. - rewrite <- (lt_succ_pred 0 a H) at 2. apply le_succ_diag_r. -Qed. - -Lemma sqrt_sqrt_up_spec : forall a, 0<=a -> (āˆša)Ā² <= a <= (āˆšĀ°a)Ā². -Proof. - intros a H. split. - - now apply sqrt_spec. - - le_elim H. - + now apply sqrt_up_spec. - + now rewrite <-H, sqrt_up_0, mul_0_l. -Qed. - -Lemma sqrt_sqrt_up_exact : - forall a, 0<=a -> (āˆša == āˆšĀ°a <-> exists b, 0<=b /\ a == bĀ²). -Proof. - intros a Ha. - split. - intros H. exists āˆša. - split. + apply sqrt_nonneg. - + generalize (sqrt_sqrt_up_spec a Ha). rewrite <-H. destruct 1; order. - - intros (b & Hb & Hb'). rewrite Hb'. - now rewrite sqrt_square, sqrt_up_square. -Qed. - -(** [sqrt_up] is a monotone function (but not a strict one) *) - -Lemma sqrt_up_le_mono : forall a b, a <= b -> āˆšĀ°a <= āˆšĀ°b. -Proof. - intros a b H. - destruct (le_gt_cases a 0) as [Ha|Ha]. - - rewrite (sqrt_up_eqn0 _ Ha). apply sqrt_up_nonneg. - - rewrite 2 sqrt_up_eqn by order. rewrite <- succ_le_mono. - apply sqrt_le_mono, succ_le_mono. rewrite 2 (lt_succ_pred 0); order. -Qed. - -(** No reverse result for <=, consider for instance āˆšĀ°3 <= āˆšĀ°2 *) - -Lemma sqrt_up_lt_cancel : forall a b, āˆšĀ°a < āˆšĀ°b -> a < b. -Proof. - intros a b H. - destruct (le_gt_cases b 0) as [Hb|Hb]. - - rewrite (sqrt_up_eqn0 _ Hb) in H; generalize (sqrt_up_nonneg a); order. - - destruct (le_gt_cases a 0) as [Ha|Ha]; [order|]. - rewrite <- (lt_succ_pred 0 a Ha), <- (lt_succ_pred 0 b Hb), <- succ_lt_mono. - apply sqrt_lt_cancel, succ_lt_mono. now rewrite <- 2 sqrt_up_eqn. -Qed. - -(** When left side is a square, we have an equivalence for < *) - -Lemma sqrt_up_lt_square : forall a b, 0<=a -> 0<=b -> (bĀ² < a <-> b < āˆšĀ°a). -Proof. - intros a b Ha Hb. split; intros H. - - destruct (sqrt_up_spec a) as (LE,LT). - + apply le_lt_trans with bĀ²; trivial using square_nonneg. - + apply square_lt_simpl_nonneg; try order. apply sqrt_up_nonneg. - - apply sqrt_up_lt_cancel. now rewrite sqrt_up_square. -Qed. - -(** When right side is a square, we have an equivalence for <= *) - -Lemma sqrt_up_le_square : forall a b, 0<=a -> 0<=b -> (a <= bĀ² <-> āˆšĀ°a <= b). -Proof. - intros a b Ha Hb. split; intros H. - - rewrite <- (sqrt_up_square b Hb). - now apply sqrt_up_le_mono. - - apply square_le_mono_nonneg in H; [|now apply sqrt_up_nonneg]. - transitivity (āˆšĀ°a)Ā²; trivial. now apply sqrt_sqrt_up_spec. -Qed. - -Lemma sqrt_up_pos : forall a, 0 < āˆšĀ°a <-> 0 < a. -Proof. - intros a. split; intros Ha. - apply sqrt_up_lt_cancel. now rewrite sqrt_up_0. - - rewrite <- le_succ_l, <- one_succ, <- sqrt_up_1. apply sqrt_up_le_mono. - now rewrite one_succ, le_succ_l. -Qed. - -Lemma sqrt_up_lt_lin : forall a, 2 āˆšĀ°a < a. -Proof. - intros a Ha. - rewrite sqrt_up_eqn by order'. - assert (Ha' := lt_succ_pred 2 a Ha). - rewrite <- Ha' at 2. rewrite <- succ_lt_mono. - apply sqrt_lt_lin. rewrite succ_lt_mono. now rewrite Ha', <- two_succ. -Qed. - -Lemma sqrt_up_le_lin : forall a, 0<=a -> āˆšĀ°a<=a. -Proof. - intros a Ha. - le_elim Ha. - - rewrite sqrt_up_eqn; trivial. apply le_succ_l. - apply le_lt_trans with (P a). + apply sqrt_le_lin. - now rewrite <- lt_succ_r, (lt_succ_pred 0). - + rewrite <- (lt_succ_pred 0 a) at 2; trivial. apply lt_succ_diag_r. - - now rewrite <- Ha, sqrt_up_0. -Qed. - -(** [sqrt_up] and multiplication. *) - -(** Due to rounding error, we don't have the usual [āˆš(a*b) = āˆša*āˆšb] - but only lower and upper bounds. *) - -Lemma sqrt_up_mul_above : forall a b, 0<=a -> 0<=b -> āˆšĀ°(a*b) <= āˆšĀ°a * āˆšĀ°b. -Proof. - intros a b Ha Hb. - apply sqrt_up_le_square. - - now apply mul_nonneg_nonneg. - - apply mul_nonneg_nonneg; apply sqrt_up_nonneg. - - rewrite mul_shuffle1. - apply mul_le_mono_nonneg; trivial; now apply sqrt_sqrt_up_spec. -Qed. - -Lemma sqrt_up_mul_below : forall a b, 0 0 (P āˆšĀ°a)*(P āˆšĀ°b) < āˆšĀ°(a*b). -Proof. - intros a b Ha Hb. - apply sqrt_up_lt_square. - - apply mul_nonneg_nonneg; order. - - apply mul_nonneg_nonneg; apply lt_succ_r. - + rewrite (lt_succ_pred 0); now rewrite sqrt_up_pos. - + rewrite (lt_succ_pred 0); now rewrite sqrt_up_pos. - - rewrite mul_shuffle1. - apply mul_lt_mono_nonneg; trivial using square_nonneg; - now apply sqrt_up_spec. -Qed. - -(** And we can't find better approximations in general. - - The upper bound is exact for squares - - Concerning the lower bound, for any c>0, take [a=b=cĀ²+1], - then [āˆšĀ°(a*b) = cĀ²+1] while [P āˆšĀ°a = P āˆšĀ°b = c] -*) - -(** [sqrt_up] and successor : - - the [sqrt_up] function climbs by at most 1 at a time - - otherwise it stays at the same value - - the +1 steps occur after squares -*) - -Lemma sqrt_up_succ_le : forall a, 0<=a -> āˆšĀ°(S a) <= S (āˆšĀ°a). -Proof. - intros a Ha. - apply sqrt_up_le_square. - - now apply le_le_succ_r. - - apply le_le_succ_r, sqrt_up_nonneg. - - rewrite <- (add_1_l (āˆšĀ°a)). - apply le_trans with (1Ā²+(āˆšĀ°a)Ā²). - + rewrite mul_1_l, add_1_l, <- succ_le_mono. - now apply sqrt_sqrt_up_spec. - + apply add_square_le. * order'. * apply sqrt_up_nonneg. -Qed. - -Lemma sqrt_up_succ_or : forall a, 0<=a -> āˆšĀ°(S a) == S (āˆšĀ°a) \/ āˆšĀ°(S a) == āˆšĀ°a. -Proof. - intros a Ha. - destruct (le_gt_cases (āˆšĀ°(S a)) (āˆšĀ°a)) as [H|H]. - - right. generalize (sqrt_up_le_mono _ _ (le_succ_diag_r a)); order. - - left. apply le_succ_l in H. generalize (sqrt_up_succ_le a Ha); order. -Qed. - -Lemma sqrt_up_eq_succ_iff_square : forall a, 0<=a -> - (āˆšĀ°(S a) == S (āˆšĀ°a) <-> exists b, 0<=b /\ a == bĀ²). -Proof. - intros a Ha. split. - - intros EQ. - le_elim Ha. - + exists (āˆšĀ°a). split. * apply sqrt_up_nonneg. - * generalize (proj2 (sqrt_up_spec a Ha)). - assert (Ha' : 0 < S a) by (apply lt_succ_r; order'). - generalize (proj1 (sqrt_up_spec (S a) Ha')). - rewrite EQ, pred_succ, lt_succ_r. order. - + exists 0. nzsimpl. now split. - - intros (b & Hb & H). - now rewrite H, sqrt_up_succ_square, sqrt_up_square. -Qed. - -(** [sqrt_up] and addition *) - -Lemma sqrt_up_add_le : forall a b, āˆšĀ°(a+b) <= āˆšĀ°a + āˆšĀ°b. -Proof. - assert (AUX : forall a b, a<=0 -> āˆšĀ°(a+b) <= āˆšĀ°a + āˆšĀ°b). - - intros a b Ha. rewrite (sqrt_up_eqn0 a Ha). nzsimpl. - apply sqrt_up_le_mono. - rewrite <- (add_0_l b) at 2. - apply add_le_mono_r; order. - - intros a b. - destruct (le_gt_cases a 0) as [Ha|Ha]. + now apply AUX. - + destruct (le_gt_cases b 0) as [Hb|Hb]. - * rewrite (add_comm a), (add_comm (āˆšĀ°a)); now apply AUX. - * rewrite 2 sqrt_up_eqn; trivial. - -- nzsimpl. rewrite <- succ_le_mono. - transitivity (āˆš(P a) + āˆšb). - ++ rewrite <- (lt_succ_pred 0 a Ha) at 1. nzsimpl. apply sqrt_add_le. - ++ apply add_le_mono_l. - apply le_sqrt_sqrt_up. - -- now apply add_pos_pos. -Qed. - -(** Convexity-like inequality for [sqrt_up]: [sqrt_up] of middle is above middle - of square roots. We cannot say more, for instance take a=b=2, then - 2+2 <= S 3 *) - -Lemma add_sqrt_up_le : forall a b, 0<=a -> 0<=b -> āˆšĀ°a + āˆšĀ°b <= S āˆšĀ°(2*(a+b)). -Proof. - intros a b Ha Hb. - le_elim Ha;[le_elim Hb|]. - - rewrite 3 sqrt_up_eqn; trivial. - + nzsimpl. rewrite <- 2 succ_le_mono. - etransitivity; [eapply add_sqrt_le|]. - * apply lt_succ_r. now rewrite (lt_succ_pred 0 a Ha). - * apply lt_succ_r. now rewrite (lt_succ_pred 0 b Hb). - * apply sqrt_le_mono. - apply lt_succ_r. rewrite (lt_succ_pred 0). - -- apply mul_lt_mono_pos_l. ++ order'. - ++ apply add_lt_mono. - ** apply le_succ_l. now rewrite (lt_succ_pred 0). - ** apply le_succ_l. now rewrite (lt_succ_pred 0). - -- apply mul_pos_pos. ++ order'. ++ now apply add_pos_pos. - + apply mul_pos_pos. * order'. * now apply add_pos_pos. - - rewrite <- Hb, sqrt_up_0. nzsimpl. apply le_le_succ_r, sqrt_up_le_mono. - rewrite <- (mul_1_l a) at 1. apply mul_le_mono_nonneg_r; order'. - - rewrite <- Ha, sqrt_up_0. nzsimpl. apply le_le_succ_r, sqrt_up_le_mono. - rewrite <- (mul_1_l b) at 1. apply mul_le_mono_nonneg_r; order'. -Qed. - -End NZSqrtUpProp. diff --git a/stdlib/theories/Numbers/Natural/Abstract/NAdd.v b/stdlib/theories/Numbers/Natural/Abstract/NAdd.v deleted file mode 100644 index 2d638b5909ca..000000000000 --- a/stdlib/theories/Numbers/Natural/Abstract/NAdd.v +++ /dev/null @@ -1,80 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* n == 0 /\ m == 0. -Proof. -intros n m; induct n. -- nzsimpl; intuition auto with relations. -- intros n IH. nzsimpl. -setoid_replace (S (n + m) == 0) with False by - (apply neg_false; apply neq_succ_0). -setoid_replace (S n == 0) with False by - (apply neg_false; apply neq_succ_0). tauto. -Qed. - -Theorem eq_add_succ : - forall n m, (exists p, n + m == S p) <-> - (exists n', n == S n') \/ (exists m', m == S m'). -Proof. -intros n m; cases n. -- split; intro H. - + destruct H as [p H]. rewrite add_0_l in H; right; now exists p. - + destruct H as [[n' H] | [m' H]]. - * symmetry in H; false_hyp H neq_succ_0. - * exists m'; now rewrite add_0_l. -- intro n; split; intro H. - + left; now exists n. - + exists (n + m); now rewrite add_succ_l. -Qed. - -Theorem eq_add_1 : forall n m, - n + m == 1 -> n == 1 /\ m == 0 \/ n == 0 /\ m == 1. -Proof. -intros n m. rewrite one_succ. intro H. -assert (H1 : exists p, n + m == S p) by now exists 0. -apply eq_add_succ in H1. destruct H1 as [[n' H1] | [m' H1]]. -- left. rewrite H1 in H; rewrite add_succ_l in H; apply succ_inj in H. - apply eq_add_0 in H. destruct H as [H2 H3]; rewrite H2 in H1; now split. -- right. rewrite H1 in H; rewrite add_succ_r in H; apply succ_inj in H. - apply eq_add_0 in H. destruct H as [H2 H3]; rewrite H3 in H1; now split. -Qed. - -Theorem succ_add_discr : forall n m, m ~= S (n + m). -Proof. -intros n m; induct m. -- apply neq_sym. apply neq_succ_0. -- intros m IH H. apply succ_inj in H. rewrite add_succ_r in H. - unfold not in IH; now apply IH. -Qed. - -Theorem add_pred_l : forall n m, n ~= 0 -> P n + m == P (n + m). -Proof. -intros n m; cases n. -- intro H; now elim H. -- intros n IH; rewrite add_succ_l; now do 2 rewrite pred_succ. -Qed. - -Theorem add_pred_r : forall n m, m ~= 0 -> n + P m == P (n + m). -Proof. -intros n m H; rewrite (add_comm n (P m)); -rewrite (add_comm n m); now apply add_pred_l. -Qed. - -End NAddProp. diff --git a/stdlib/theories/Numbers/Natural/Abstract/NAddOrder.v b/stdlib/theories/Numbers/Natural/Abstract/NAddOrder.v deleted file mode 100644 index bf0c54bce989..000000000000 --- a/stdlib/theories/Numbers/Natural/Abstract/NAddOrder.v +++ /dev/null @@ -1,57 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* n < m + p. -Proof. -intros n m p H; rewrite <- (add_0_r n). -apply add_lt_le_mono; [assumption | apply le_0_l]. -Qed. - -Theorem lt_lt_add_l : forall n m p, n < m -> n < p + m. -Proof. -intros n m p; rewrite add_comm; apply lt_lt_add_r. -Qed. - -Theorem add_pos_l : forall n m, 0 < n -> 0 < n + m. -Proof. - intros; apply add_pos_nonneg. - - assumption. - - apply le_0_l. -Qed. - -Theorem add_pos_r : forall n m, 0 < m -> 0 < n + m. -Proof. - intros; apply add_nonneg_pos. - - apply le_0_l. - - assumption. -Qed. - -End NAddOrderProp. diff --git a/stdlib/theories/Numbers/Natural/Abstract/NAxioms.v b/stdlib/theories/Numbers/Natural/Abstract/NAxioms.v deleted file mode 100644 index 95d086db9f10..000000000000 --- a/stdlib/theories/Numbers/Natural/Abstract/NAxioms.v +++ /dev/null @@ -1,70 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* a mod b < b. -End NDivSpecific. - -(** For all other functions, the NZ axiomatizations are enough. *) - -(** We now group everything together. *) - -Module Type NAxiomsSig := NAxiomsMiniSig <+ OrderFunctions - <+ NZParity.NZParity <+ NZPow.NZPow <+ NZSqrt.NZSqrt <+ NZLog.NZLog2 - <+ NZGcd.NZGcd <+ NZDiv.NZDiv <+ NZBits.NZBits <+ NZSquare. - -Module Type NAxiomsSig' := NAxiomsMiniSig' <+ OrderFunctions' - <+ NZParity.NZParity <+ NZPow.NZPow' <+ NZSqrt.NZSqrt' <+ NZLog.NZLog2 - <+ NZGcd.NZGcd' <+ NZDiv.NZDiv' <+ NZBits.NZBits' <+ NZSquare. - - -(** It could also be interesting to have a constructive recursor function. *) - -Module Type NAxiomsRec (Import NZ : NZDomainSig'). - -Parameter Inline recursion : forall {A : Type}, A -> (t -> A -> A) -> t -> A. - -#[global] -Declare Instance recursion_wd {A : Type} (Aeq : relation A) : - Proper (Aeq ==> (eq==>Aeq==>Aeq) ==> eq ==> Aeq) recursion. - -Axiom recursion_0 : - forall {A} (a : A) (f : t -> A -> A), recursion a f 0 = a. - -Axiom recursion_succ : - forall {A} (Aeq : relation A) (a : A) (f : t -> A -> A), - Aeq a a -> Proper (eq==>Aeq==>Aeq) f -> - forall n, Aeq (recursion a f (S n)) (f n (recursion a f n)). - -End NAxiomsRec. - -Module Type NAxiomsRecSig := NAxiomsMiniSig <+ NAxiomsRec. -Module Type NAxiomsRecSig' := NAxiomsMiniSig' <+ NAxiomsRec. - -Module Type NAxiomsFullSig := NAxiomsSig <+ NAxiomsRec. -Module Type NAxiomsFullSig' := NAxiomsSig' <+ NAxiomsRec. diff --git a/stdlib/theories/Numbers/Natural/Abstract/NBase.v b/stdlib/theories/Numbers/Natural/Abstract/NBase.v deleted file mode 100644 index cd48e3fbc399..000000000000 --- a/stdlib/theories/Numbers/Natural/Abstract/NBase.v +++ /dev/null @@ -1,192 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* Prop, Proper (N.eq==>iff) A -> - A 0 -> (forall n, A n -> A (S n)) -> forall n, A n. -Proof. -intros A A_wd A0 AS n; apply right_induction with 0; try assumption. -- intros; auto; apply le_0_l. -- apply le_0_l. -Qed. - -(** The theorems [bi_induction], [central_induction] and the tactic [nzinduct] -refer to bidirectional induction, which is not useful on natural -numbers. Therefore, we define a new induction tactic for natural numbers. -We do not have to call "Declare Left Step" and "Declare Right Step" -commands again, since the data for stepl and stepr tactics is inherited -from NZ. *) - -Ltac induct n := induction_maker n ltac:(apply induction). - -Theorem case_analysis : - forall A : N.t -> Prop, Proper (N.eq==>iff) A -> - A 0 -> (forall n, A (S n)) -> forall n, A n. -Proof. -intros; apply induction; auto. -Qed. - -Ltac cases n := induction_maker n ltac:(apply case_analysis). - -Theorem neq_0 : ~ forall n, n == 0. -Proof. -intro H; apply (neq_succ_0 0). apply H. -Qed. - -Theorem neq_0_r n : n ~= 0 <-> exists m, n == S m. -Proof. - cases n. - - split; intro H;[now elim H | destruct H as [m H]; - symmetry in H; false_hyp H neq_succ_0]. - - intro n; split; intro H; [now exists n | apply neq_succ_0]. -Qed. - -Theorem zero_or_succ n : n == 0 \/ exists m, n == S m. -Proof. -cases n. -- now left. -- intro n; right; now exists n. -Qed. - -Theorem eq_pred_0 n : P n == 0 <-> n == 0 \/ n == 1. -Proof. -cases n. -- rewrite pred_0. now split; [left|]. -- intro n. rewrite pred_succ. - split. - + intros H; right. now rewrite H, one_succ. - + intros [H|H]. - * elim (neq_succ_0 _ H). - * apply succ_inj_wd. now rewrite <- one_succ. -Qed. - -Theorem succ_pred n : n ~= 0 -> S (P n) == n. -Proof. -cases n. -- intro H; exfalso; now apply H. -- intros; now rewrite pred_succ. -Qed. - -Theorem pred_inj n m : n ~= 0 -> m ~= 0 -> P n == P m -> n == m. -Proof. -cases n. -- intros H; exfalso; now apply H. -- intros n _; cases m. - + intros H; exfalso; now apply H. - + intros m H2 H3. do 2 rewrite pred_succ in H3. now rewrite H3. -Qed. - -(** The following induction principle is useful for reasoning about, e.g., -Fibonacci numbers *) - -Section PairInduction. - -Variable A : N.t -> Prop. -Hypothesis A_wd : Proper (N.eq==>iff) A. - -Theorem pair_induction : - A 0 -> A 1 -> - (forall n, A n -> A (S n) -> A (S (S n))) -> forall n, A n. -Proof. -rewrite one_succ. -intros until 3. -assert (D : forall n, A n /\ A (S n)); [ |intro n; exact (proj1 (D n))]. -intro n; induct n; [ | intros n [IH1 IH2]]; auto. -Qed. - -End PairInduction. - -(** The following is useful for reasoning about, e.g., Ackermann function *) - -Section TwoDimensionalInduction. - -Variable R : N.t -> N.t -> Prop. -Hypothesis R_wd : Proper (N.eq==>N.eq==>iff) R. - -Theorem two_dim_induction : - R 0 0 -> - (forall n m, R n m -> R n (S m)) -> - (forall n, (forall m, R n m) -> R (S n) 0) -> forall n m, R n m. -Proof. -intros H1 H2 H3. intro n; induct n. -- intro m; induct m. - + exact H1. - + exact (H2 0). -- intros n IH. intro m; induct m. - + now apply H3. - + exact (H2 (S n)). -Qed. - -End TwoDimensionalInduction. - - -Section DoubleInduction. - -Variable R : N.t -> N.t -> Prop. -Hypothesis R_wd : Proper (N.eq==>N.eq==>iff) R. - -Theorem double_induction : - (forall m, R 0 m) -> - (forall n, R (S n) 0) -> - (forall n m, R n m -> R (S n) (S m)) -> forall n m, R n m. -Proof. -intros H1 H2 H3 n; induct n; auto. -intros n H m; cases m; auto. -Qed. - -End DoubleInduction. - -Ltac double_induct n m := - try intros until n; - try intros until m; - pattern n, m; apply double_induction; clear n m; - [solve_proper | | | ]. - -End NBaseProp. diff --git a/stdlib/theories/Numbers/Natural/Abstract/NBits.v b/stdlib/theories/Numbers/Natural/Abstract/NBits.v deleted file mode 100644 index 18f9ef8030f4..000000000000 --- a/stdlib/theories/Numbers/Natural/Abstract/NBits.v +++ /dev/null @@ -1,1787 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* c<=b -> a^(b-c) == a^b / a^c. -Proof. - intros a b c Ha H. - apply div_unique with 0. - - generalize (pow_nonzero a c Ha) (le_0_l (a^c)); order'. - - nzsimpl. now rewrite <- pow_add_r, add_comm, sub_add. -Qed. - -Lemma pow_div_l : forall a b c, b~=0 -> a mod b == 0 -> - (a/b)^c == a^c / b^c. -Proof. - intros a b c Hb H. - apply div_unique with 0. - - generalize (pow_nonzero b c Hb) (le_0_l (b^c)); order'. - - nzsimpl. rewrite <- pow_mul_l. f_equiv. now apply div_exact. -Qed. - -(** An injection from bits [true] and [false] to numbers 1 and 0. - We declare it as a (local) coercion for shorter statements. *) - -Definition b2n (b:bool) := if b then 1 else 0. -Local Coercion b2n : bool >-> t. - -#[global] -Instance b2n_proper : Proper (Logic.eq ==> eq) b2n. -Proof. solve_proper. Qed. - -Lemma b2n_le_1 (b : bool) : b <= 1. -Proof. destruct b as [|]; [exact (le_refl _) | exact le_0_1]. Qed. - -Lemma exists_div2 a : exists a' (b:bool), a == 2*a' + b. -Proof. - elim (Even_or_Odd a); [intros (a',H)| intros (a',H)]. - - exists a'. exists false. now nzsimpl. - - exists a'. exists true. now simpl. -Qed. - -(* This is kept private in order to drop the `Proper` condition in - implementations. *) -(* begin hide *) -Lemma Private_binary_induction (A : t -> Prop) : - (Proper (eq ==> iff) A) -> A 0 -> (forall n, A n -> A (2 * n)) -> - (forall n, A n -> A (2 * n + 1)) -> (forall n, A n). -Proof. - intros H H0 I J. - apply Private_strong_induction_le; [exact H | exact H0 |]; intros n Hm. - pose proof (exists_div2 (S n)) as [m [[|] Hmb]]; simpl in Hmb; rewrite Hmb. - - apply J, Hm. - rewrite add_1_r in Hmb; apply succ_inj in Hmb; rewrite Hmb, two_succ. - apply le_mul_l; exact (neq_succ_0 1). - - rewrite add_0_r in *; apply I, Hm; apply <-succ_le_mono; rewrite Hmb. - rewrite <-(add_1_r), two_succ, mul_succ_l, mul_1_l. - apply add_le_mono_l, neq_0_le_1; intros C; rewrite C, mul_0_r in Hmb. - exact (neq_succ_0 _ Hmb). -Qed. -(* end hide *) - -(** We can compact [testbit_odd_0] [testbit_even_0] - [testbit_even_succ] [testbit_odd_succ] in only two lemmas. *) - -Lemma testbit_0_r a (b:bool) : testbit (2*a+b) 0 = b. -Proof. - destruct b; simpl; rewrite ?add_0_r. - - apply testbit_odd_0. - - apply testbit_even_0. -Qed. - -Lemma testbit_succ_r a (b:bool) n : - testbit (2*a+b) (succ n) = testbit a n. -Proof. - destruct b; simpl; rewrite ?add_0_r. - - apply testbit_odd_succ, le_0_l. - - apply testbit_even_succ, le_0_l. -Qed. - -(** Specification without useless condition on the bit number *) -Lemma testbit_odd_succ' a n : testbit (2*a+1) (S n) = testbit a n. -Proof. apply testbit_odd_succ; exact (le_0_l n). Qed. - -Lemma testbit_even_succ' a n : testbit (2*a) (S n) = testbit a n. -Proof. apply testbit_even_succ; exact (le_0_l n). Qed. - -(** Alternative characterisations of [testbit] *) - -(** This concise equation could have been taken as specification - for testbit in the interface, but it would have been hard to - implement with little initial knowledge about div and mod *) - -Lemma testbit_spec' a n : a.[n] == (a / 2^n) mod 2. -Proof. - revert a. induct n. - - intros a. nzsimpl. - destruct (exists_div2 a) as (a' & b & H). rewrite H at 1. - rewrite testbit_0_r. apply mod_unique with a'; trivial. - destruct b; order'. - - intros n IH a. - destruct (exists_div2 a) as (a' & b & H). rewrite H at 1. - rewrite testbit_succ_r, IH. f_equiv. - rewrite pow_succ_r', <- div_div by order_nz. f_equiv. - apply div_unique with b; trivial. - destruct b; order'. -Qed. - -(** This characterisation that uses only basic operations and - power was initially taken as specification for testbit. - We describe [a] as having a low part and a high part, with - the corresponding bit in the middle. This characterisation - is moderatly complex to implement, but also moderately - usable... *) - -Lemma testbit_spec a n : - exists l h, 0<=l<2^n /\ a == l + (a.[n] + 2*h)*2^n. -Proof. - exists (a mod 2^n). exists (a / 2^n / 2). split. - - split; [apply le_0_l | apply mod_upper_bound; order_nz]. - - rewrite add_comm, mul_comm, (add_comm a.[n]). - rewrite (div_mod a (2^n)) at 1 by order_nz. do 2 f_equiv. - rewrite testbit_spec'. apply div_mod. order'. -Qed. - -Lemma testbit_true : forall a n, - a.[n] = true <-> (a / 2^n) mod 2 == 1. -Proof. - intros a n. - rewrite <- testbit_spec'; destruct a.[n]; split; simpl; now try order'. -Qed. - -Lemma testbit_false : forall a n, - a.[n] = false <-> (a / 2^n) mod 2 == 0. -Proof. - intros a n. - rewrite <- testbit_spec'; destruct a.[n]; split; simpl; now try order'. -Qed. - -Lemma testbit_eqb : forall a n, - a.[n] = eqb ((a / 2^n) mod 2) 1. -Proof. - intros a n. - apply eq_true_iff_eq. now rewrite testbit_true, eqb_eq. -Qed. - -(** Results about the injection [b2n] *) - -Lemma b2n_inj : forall (a0 b0:bool), a0 == b0 -> a0 = b0. -Proof. - intros [|] [|]; simpl; trivial; order'. -Qed. - -Lemma add_b2n_double_div2 : forall (a0:bool) a, (a0+2*a)/2 == a. -Proof. - intros a0 a. rewrite mul_comm, div_add by order'. - now rewrite div_small, add_0_l by (destruct a0; order'). -Qed. - -Lemma add_b2n_double_bit0 : forall (a0:bool) a, (a0+2*a).[0] = a0. -Proof. - intros a0 a. apply b2n_inj. - rewrite testbit_spec'. nzsimpl. rewrite mul_comm, mod_add by order'. - now rewrite mod_small by (destruct a0; order'). -Qed. - -Lemma b2n_div2 : forall (a0:bool), a0/2 == 0. -Proof. - intros a0. rewrite <- (add_b2n_double_div2 a0 0). now nzsimpl. -Qed. - -Lemma b2n_bit0 : forall (a0:bool), a0.[0] = a0. -Proof. - intros a0. rewrite <- (add_b2n_double_bit0 a0 0) at 2. now nzsimpl. -Qed. - -(** The specification of testbit by low and high parts is complete *) - -Lemma testbit_unique : forall a n (a0:bool) l h, - l<2^n -> a == l + (a0 + 2*h)*2^n -> a.[n] = a0. -Proof. - intros a n a0 l h Hl EQ. - apply b2n_inj. rewrite testbit_spec' by trivial. - symmetry. apply mod_unique with h. - - destruct a0; simpl; order'. - - symmetry. apply div_unique with l; trivial. - now rewrite add_comm, (add_comm _ a0), mul_comm. -Qed. - -(** All bits of number 0 are 0 *) - -Lemma bits_0 : forall n, 0.[n] = false. -Proof. - intros n. apply testbit_false. nzsimpl; order_nz. -Qed. - -(** Various ways to refer to the lowest bit of a number *) - -Lemma bit0_odd : forall a, a.[0] = odd a. -Proof. - intros a. symmetry. - destruct (exists_div2 a) as (a' & b & EQ). - rewrite EQ, testbit_0_r, add_comm, odd_add_mul_2. - destruct b; simpl; apply odd_1 || apply odd_0. -Qed. - -Lemma bit0_eqb : forall a, a.[0] = eqb (a mod 2) 1. -Proof. - intros a. rewrite testbit_eqb. now nzsimpl. -Qed. - -Lemma bit0_mod : forall a, a.[0] == a mod 2. -Proof. - intros a. rewrite testbit_spec'. now nzsimpl. -Qed. - -(** Hence testing a bit is equivalent to shifting and testing parity *) - -Lemma testbit_odd : forall a n, a.[n] = odd (a>>n). -Proof. - intros. now rewrite <- bit0_odd, shiftr_spec, add_0_l. -Qed. - -(** [log2] gives the highest nonzero bit *) - -Lemma bit_log2 : forall a, a~=0 -> a.[log2 a] = true. -Proof. - intros a Ha. - assert (Ha' : 0 < a) by (generalize (le_0_l a); order). - destruct (log2_spec_alt a Ha') as (r & EQ & (_,Hr)). - rewrite EQ at 1. - rewrite testbit_true, add_comm. - rewrite <- (mul_1_l (2^log2 a)) at 1. - rewrite div_add by order_nz. - rewrite div_small by trivial. - rewrite add_0_l. apply mod_small. order'. -Qed. - -Lemma bits_above_log2 : forall a n, log2 a < n -> - a.[n] = false. -Proof. - intros a n H. - rewrite testbit_false. - rewrite div_small. - - nzsimpl; order'. - - apply log2_lt_cancel. rewrite log2_pow2; trivial using le_0_l. -Qed. - -(** Hence the number of bits of [a] is [1+log2 a] - (see [Pos.size_nat] and [Pos.size]). -*) - -(** Testing bits after division or multiplication by a power of two *) - -Lemma testbit_div2 : forall a n, (div2 a).[n] = a.[S n]. -Proof. - intros a n; rewrite div2_spec, shiftr_spec, add_1_r by (exact (le_0_l _)); - reflexivity. -Qed. - -Lemma div2_bits : forall a n, (a/2).[n] = a.[S n]. -Proof. - intros. apply eq_true_iff_eq. - rewrite 2 testbit_true. - rewrite pow_succ_r by apply le_0_l. - now rewrite div_div by order_nz. -Qed. - -Lemma div_pow2_bits : forall a n m, (a/2^n).[m] = a.[m+n]. -Proof. - intros a n. revert a. induct n. - - intros a m. now nzsimpl. - - intros n IH a m. nzsimpl; try apply le_0_l. - rewrite <- div_div by order_nz. - now rewrite IH, div2_bits. -Qed. - -Lemma double_bits_succ : forall a n, (2*a).[S n] = a.[n]. -Proof. - intros. rewrite <- div2_bits. now rewrite mul_comm, div_mul by order'. -Qed. - -Lemma mul_pow2_bits_add : forall a n m, (a*2^n).[m+n] = a.[m]. -Proof. - intros. rewrite <- div_pow2_bits. now rewrite div_mul by order_nz. -Qed. - -Lemma mul_pow2_bits_high : forall a n m, n<=m -> (a*2^n).[m] = a.[m-n]. -Proof. - intros a n m ?. - rewrite <- (sub_add n m) at 1 by order'. - now rewrite mul_pow2_bits_add. -Qed. - -Lemma mul_pow2_bits_low : forall a n m, m (a*2^n).[m] = false. -Proof. - intros a n m H. apply testbit_false. - rewrite <- (sub_add m n) by order'. rewrite pow_add_r, mul_assoc. - rewrite div_mul by order_nz. - rewrite <- (succ_pred (n-m)). - - rewrite pow_succ_r. - + now rewrite (mul_comm 2), mul_assoc, mod_mul by order'. - + apply lt_le_pred. - apply sub_gt in H. generalize (le_0_l (n-m)); order. - - now apply sub_gt. -Qed. - -(** Selecting the low part of a number can be done by a modulo *) - -Lemma mod_pow2_bits_high : forall a n m, n<=m -> - (a mod 2^n).[m] = false. -Proof. - intros a n m H. - destruct (eq_0_gt_0_cases (a mod 2^n)) as [EQ|LT]. - - now rewrite EQ, bits_0. - - apply bits_above_log2. - apply lt_le_trans with n; trivial. - apply log2_lt_pow2; trivial. - apply mod_upper_bound; order_nz. -Qed. - -Lemma mod_pow2_bits_low : forall a n m, m - (a mod 2^n).[m] = a.[m]. -Proof. - intros a n m H. - rewrite testbit_eqb. - rewrite <- (mod_add _ (2^(P (n-m))*(a/2^n))) by order'. - rewrite <- div_add by order_nz. - rewrite (mul_comm _ 2), mul_assoc, <- pow_succ_r', succ_pred - by now apply sub_gt. - rewrite mul_comm, mul_assoc, <- pow_add_r, (add_comm m), sub_add - by order. - rewrite add_comm, <- div_mod by order_nz. - symmetry. apply testbit_eqb. -Qed. - -(** We now prove that having the same bits implies equality. - For that we use a notion of equality over functional - streams of bits. *) - -Definition eqf (f g:t -> bool) := forall n:t, f n = g n. - -#[global] -Instance eqf_equiv : Equivalence eqf. -Proof. - split; congruence. -Qed. - -Local Infix "===" := eqf (at level 70, no associativity). - -#[global] -Instance testbit_eqf : Proper (eq==>eqf) testbit. -Proof. - intros a a' Ha n. now rewrite Ha. -Qed. - -(** Only zero corresponds to the always-false stream. *) - -Lemma bits_inj_0 : - forall a, (forall n, a.[n] = false) -> a == 0. -Proof. - intros a H. destruct (eq_decidable a 0) as [EQ|NEQ]; trivial. - apply bit_log2 in NEQ. now rewrite H in NEQ. -Qed. - -(** If two numbers produce the same stream of bits, they are equal. *) - -Lemma bits_inj : forall a b, testbit a === testbit b -> a == b. -Proof. - intros a. pattern a. - apply strong_right_induction with 0;[clear a|apply le_0_l]. - intros a _ IH b H. - destruct (eq_0_gt_0_cases a) as [EQ|LT]. - - rewrite EQ in H |- *. symmetry. apply bits_inj_0. - intros n. now rewrite <- H, bits_0. - - rewrite (div_mod a 2), (div_mod b 2) by order'. - f_equiv; [ | now rewrite <- 2 bit0_mod, H]. - f_equiv. - apply IH; trivial using le_0_l. - + apply div_lt; order'. - + intro n. rewrite 2 div2_bits. apply H. -Qed. - -Lemma bits_inj_iff : forall a b, testbit a === testbit b <-> a == b. -Proof. - split. - - apply bits_inj. - - intros EQ; now rewrite EQ. -Qed. - -Global Hint Rewrite lxor_spec lor_spec land_spec ldiff_spec bits_0 : bitwise. - -Tactic Notation "bitwise" "as" simple_intropattern(m) - := apply bits_inj; intros m; autorewrite with bitwise. - -Ltac bitwise := bitwise as ?m. - -(** The streams of bits that correspond to a natural numbers are - exactly the ones that are always 0 after some point *) - -Lemma are_bits : forall (f:t->bool), Proper (eq==>Logic.eq) f -> - ((exists n, f === testbit n) <-> - (exists k, forall m, k<=m -> f m = false)). -Proof. - intros f Hf. split. - - intros (a,H). - exists (S (log2 a)). intros m Hm. apply le_succ_l in Hm. - rewrite H, bits_above_log2; trivial using lt_succ_diag_r. - - intros (k,Hk). - revert f Hf Hk. induct k. - + intros f Hf H0. - exists 0. intros m. rewrite bits_0, H0; trivial. apply le_0_l. - + intros k IH f Hf Hk. - destruct (IH (fun m => f (S m))) as (n, Hn). - * solve_proper. - * intros m Hm. apply Hk. now rewrite <- succ_le_mono. - * { exists (f 0 + 2*n). intros m. - destruct (zero_or_succ m) as [Hm|(m', Hm)]; rewrite Hm. - - symmetry. apply add_b2n_double_bit0. - - rewrite Hn, <- div2_bits. - rewrite mul_comm, div_add, b2n_div2, add_0_l; trivial. order'. - } -Qed. - -(** Properties of shifts *) - -Lemma shiftr_spec' : forall a n m, (a >> n).[m] = a.[m+n]. -Proof. - intros. apply shiftr_spec. apply le_0_l. -Qed. - -Lemma shiftl_spec_high' : forall a n m, n<=m -> (a << n).[m] = a.[m-n]. -Proof. - intros. apply shiftl_spec_high; trivial. apply le_0_l. -Qed. - -Lemma shiftr_div_pow2 : forall a n, a >> n == a / 2^n. -Proof. - intros. bitwise. rewrite shiftr_spec'. - symmetry. apply div_pow2_bits. -Qed. - -Lemma shiftl_mul_pow2 : forall a n, a << n == a * 2^n. -Proof. - intros a n. bitwise as m. - destruct (le_gt_cases n m) as [H|H]. - - now rewrite shiftl_spec_high', mul_pow2_bits_high. - - now rewrite shiftl_spec_low, mul_pow2_bits_low. -Qed. - -Lemma shiftl_spec_alt : forall a n m, (a << n).[m+n] = a.[m]. -Proof. - intros. now rewrite shiftl_mul_pow2, mul_pow2_bits_add. -Qed. - -#[global] -Instance shiftr_wd : Proper (eq==>eq==>eq) shiftr. -Proof. - intros a a' Ha b b' Hb. now rewrite 2 shiftr_div_pow2, Ha, Hb. -Qed. - -#[global] -Instance shiftl_wd : Proper (eq==>eq==>eq) shiftl. -Proof. - intros a a' Ha b b' Hb. now rewrite 2 shiftl_mul_pow2, Ha, Hb. -Qed. - -Lemma shiftl_shiftl : forall a n m, - (a << n) << m == a << (n+m). -Proof. - intros. now rewrite !shiftl_mul_pow2, pow_add_r, mul_assoc. -Qed. - -Lemma shiftr_shiftr : forall a n m, - (a >> n) >> m == a >> (n+m). -Proof. - intros. - now rewrite !shiftr_div_pow2, pow_add_r, div_div by order_nz. -Qed. - -Lemma shiftr_shiftl_l : forall a n m, m<=n -> - (a << n) >> m == a << (n-m). -Proof. - intros a n m ?. - rewrite shiftr_div_pow2, !shiftl_mul_pow2. - rewrite <- (sub_add m n) at 1 by trivial. - now rewrite pow_add_r, mul_assoc, div_mul by order_nz. -Qed. - -Lemma shiftr_shiftl_r : forall a n m, n<=m -> - (a << n) >> m == a >> (m-n). -Proof. - intros a n m ?. - rewrite !shiftr_div_pow2, shiftl_mul_pow2. - rewrite <- (sub_add n m) at 1 by trivial. - rewrite pow_add_r, (mul_comm (2^(m-n))). - now rewrite <- div_div, div_mul by order_nz. -Qed. - -(** shifts and constants *) - -Lemma shiftl_1_l : forall n, 1 << n == 2^n. -Proof. - intros. now rewrite shiftl_mul_pow2, mul_1_l. -Qed. - -Lemma shiftl_0_r : forall a, a << 0 == a. -Proof. - intros. rewrite shiftl_mul_pow2. now nzsimpl. -Qed. - -Lemma shiftr_0_r : forall a, a >> 0 == a. -Proof. - intros. rewrite shiftr_div_pow2. now nzsimpl. -Qed. - -Lemma shiftl_0_l : forall n, 0 << n == 0. -Proof. - intros. rewrite shiftl_mul_pow2. now nzsimpl. -Qed. - -Lemma shiftr_0_l : forall n, 0 >> n == 0. -Proof. - intros. rewrite shiftr_div_pow2. nzsimpl; order_nz. -Qed. - -Lemma shiftl_eq_0_iff : forall a n, a << n == 0 <-> a == 0. -Proof. - intros a n. rewrite shiftl_mul_pow2. rewrite eq_mul_0. split. - - intros [H | H]; trivial. contradict H; order_nz. - - intros H. now left. -Qed. - -Lemma shiftr_eq_0_iff : forall a n, - a >> n == 0 <-> a==0 \/ (0 a >> n == 0. -Proof. - intros a n H. rewrite shiftr_eq_0_iff. - destruct (eq_0_gt_0_cases a) as [EQ|LT]. - - now left. - - right; now split. -Qed. - -(** Properties of [div2]. *) - -Lemma div2_div : forall a, div2 a == a/2. -Proof. - intros. rewrite div2_spec, shiftr_div_pow2. now nzsimpl. -Qed. - -Lemma div2_0 : div2 0 == 0. -Proof. - rewrite div2_div, div_0_l by (rewrite two_succ; exact (neq_succ_0 _)). - reflexivity. -Qed. - -Lemma div2_1 : div2 1 == 0. -Proof. rewrite div2_div, div_small by (exact lt_1_2); reflexivity. Qed. - -Lemma div2_le_mono : forall a b, a <= b -> div2 a <= div2 b. -Proof. - intros a b H; rewrite 2!div2_div; apply div_le_mono; [| exact H]. - rewrite two_succ; exact (neq_succ_0 1). -Qed. - -#[global] -Instance div2_wd : Proper (eq==>eq) div2. -Proof. - intros a a' Ha. now rewrite 2 div2_div, Ha. -Qed. - -Lemma div2_odd : forall a, a == 2*(div2 a) + odd a. -Proof. - intros a. rewrite div2_div, <- bit0_odd, bit0_mod. - apply div_mod. order'. -Qed. - -Lemma div2_even : forall a, div2 (2 * a) == a. -Proof. - intros a; rewrite div2_div, mul_comm, div_mul - by (rewrite two_succ; exact (neq_succ_0 _)); reflexivity. -Qed. - -Lemma div2_odd' : forall a, div2 (2 * a + 1) == a. -Proof. - intros a; rewrite div2_div; symmetry; apply (div_unique _ _ _ 1); - [exact lt_1_2 | reflexivity]. -Qed. - -Lemma le_div2_diag_l a : div2 a <= a. -Proof. - rewrite (div2_odd a) at 2; rewrite <-(mul_1_l (div2 a)) at 1. - apply (le_trans _ (2 * (div2 a))). - - apply mul_le_mono_r, lt_le_incl; exact lt_1_2. - - exact (le_add_r _ _). -Qed. - -Lemma div2_le_upper_bound a q : a <= 2 * q -> div2 a <= q. -Proof. - rewrite div2_div, two_succ; apply div_le_upper_bound; exact (neq_succ_0 _). -Qed. - -Lemma div2_le_lower_bound a q : 2 * q <= a -> q <= div2 a. -Proof. - rewrite div2_div, two_succ; apply div_le_lower_bound; exact (neq_succ_0 _). -Qed. - -Lemma lt_div2_diag_l a : a ~= 0 -> div2 a < a. -Proof. - destruct (zero_or_succ a) as [| [b ->]]; [| clear a]. { - intros H'; contradict H'; rewrite H; reflexivity. - } - destruct (zero_or_succ b) as [| [c ->]]; [| clear b]. { - intros _; rewrite H, <-one_succ, div2_1; exact lt_0_1. - } - intros _; rewrite (div2_odd (S (S c))) at 2. - rewrite <-(mul_1_l (div2 _)) at 1; apply lt_lt_add_r, mul_lt_mono_pos_r; - [| exact lt_1_2]. - apply lt_le_trans with (1 := lt_0_1). - apply div2_le_lower_bound; rewrite mul_1_r, two_succ, one_succ. - apply ->succ_le_mono; apply ->succ_le_mono; exact (le_0_l _). -Qed. - -Lemma le_div2 n : div2 (S n) <= n. -Proof. - destruct (zero_or_succ n) as [-> | [k ->]]; [| clear n]. { - rewrite <-one_succ, div2_1; exact (le_0_l 0). - } - apply div2_le_upper_bound. - setoid_replace (2 * (S k)) with (S k + S k); cycle 1. { - rewrite two_succ, <-(add_1_r 1), mul_add_distr_r, mul_1_l; reflexivity. - } - rewrite add_succ_r; apply ->succ_le_mono; exact (le_add_r _ _). -Qed. - -Lemma lt_div2 n : 0 < n -> div2 n < n. -Proof. intros H%lt_neq%neq_sym; exact (lt_div2_diag_l _ H). Qed. - -Lemma div2_decr a n : a <= S n -> div2 a <= n. -Proof. - destruct (zero_or_succ a) as [-> | [b ->]]; [intros _ | clear a]. { - rewrite div2_0; exact (le_0_l _). - } - intros H%div2_le_mono; apply le_trans with (1 := H); exact (le_div2 n). -Qed. - -(** Properties of [lxor] and others, directly deduced - from properties of [xorb] and others. *) - -#[global] -Instance lxor_wd : Proper (eq ==> eq ==> eq) lxor. -Proof. - intros a a' Ha b b' Hb. bitwise. now rewrite Ha, Hb. -Qed. - -#[global] -Instance land_wd : Proper (eq ==> eq ==> eq) land. -Proof. - intros a a' Ha b b' Hb. bitwise. now rewrite Ha, Hb. -Qed. - -#[global] -Instance lor_wd : Proper (eq ==> eq ==> eq) lor. -Proof. - intros a a' Ha b b' Hb. bitwise. now rewrite Ha, Hb. -Qed. - -#[global] -Instance ldiff_wd : Proper (eq ==> eq ==> eq) ldiff. -Proof. - intros a a' Ha b b' Hb. bitwise. now rewrite Ha, Hb. -Qed. - -Lemma lxor_eq : forall a a', lxor a a' == 0 -> a == a'. -Proof. - intros a a' H. bitwise. apply xorb_eq. - now rewrite <- lxor_spec, H, bits_0. -Qed. - -Lemma lxor_nilpotent : forall a, lxor a a == 0. -Proof. - intros. bitwise. apply xorb_nilpotent. -Qed. - -Lemma lxor_eq_0_iff : forall a a', lxor a a' == 0 <-> a == a'. -Proof. - split. - - apply lxor_eq. - - intros EQ; rewrite EQ; apply lxor_nilpotent. -Qed. - -Lemma lxor_0_l : forall a, lxor 0 a == a. -Proof. - intros. bitwise. apply xorb_false_l. -Qed. - -Lemma lxor_0_r : forall a, lxor a 0 == a. -Proof. - intros. bitwise. apply xorb_false_r. -Qed. - -Lemma lxor_comm : forall a b, lxor a b == lxor b a. -Proof. - intros. bitwise. apply xorb_comm. -Qed. - -Lemma lxor_assoc : - forall a b c, lxor (lxor a b) c == lxor a (lxor b c). -Proof. - intros. bitwise. apply xorb_assoc. -Qed. - -Lemma lor_0_l : forall a, lor 0 a == a. -Proof. - intros. bitwise. trivial. -Qed. - -Lemma lor_0_r : forall a, lor a 0 == a. -Proof. - intros. bitwise. apply orb_false_r. -Qed. - -Lemma lor_comm : forall a b, lor a b == lor b a. -Proof. - intros. bitwise. apply orb_comm. -Qed. - -Lemma lor_assoc : - forall a b c, lor a (lor b c) == lor (lor a b) c. -Proof. - intros. bitwise. apply orb_assoc. -Qed. - -Lemma lor_diag : forall a, lor a a == a. -Proof. - intros. bitwise. apply orb_diag. -Qed. - -Lemma lor_eq_0_l : forall a b, lor a b == 0 -> a == 0. -Proof. - intros a b H. bitwise as m. - apply (orb_false_iff a.[m] b.[m]). - now rewrite <- lor_spec, H, bits_0. -Qed. - -Lemma lor_eq_0_iff : forall a b, lor a b == 0 <-> a == 0 /\ b == 0. -Proof. - intros a b. split. - - intro H; split. - + now apply lor_eq_0_l in H. - + rewrite lor_comm in H. now apply lor_eq_0_l in H. - - intros (EQ,EQ'). now rewrite EQ, lor_0_l. -Qed. - -Lemma land_0_l : forall a, land 0 a == 0. -Proof. - intros. bitwise. trivial. -Qed. - -Lemma land_0_r : forall a, land a 0 == 0. -Proof. - intros. bitwise. apply andb_false_r. -Qed. - -Lemma land_comm : forall a b, land a b == land b a. -Proof. - intros. bitwise. apply andb_comm. -Qed. - -Lemma land_assoc : - forall a b c, land a (land b c) == land (land a b) c. -Proof. - intros. bitwise. apply andb_assoc. -Qed. - -Lemma land_diag : forall a, land a a == a. -Proof. - intros. bitwise. apply andb_diag. -Qed. - -Lemma land_even_l : - forall a b, land (2 * a) b == 2 * (land a (div2 b)). -Proof. - intros a b; rewrite (div2_odd b) at 1; apply bits_inj; intros m. - destruct (zero_or_succ m) as [-> | [m' ->]]; rewrite !land_spec. - - rewrite 2!testbit_even_0; reflexivity. - - rewrite 2!testbit_even_succ, testbit_succ_r, land_spec by exact (le_0_l _). - reflexivity. -Qed. - -Lemma land_even_r : - forall a b, land a (2 * b) == 2 * (land (div2 a) b). -Proof. - intros a b; rewrite (land_comm a _), (land_comm _ b); exact (land_even_l _ _). -Qed. - -Lemma land_odd_l : - forall a b, land (2 * a + 1) b == 2 * (land a (div2 b)) + odd b. -Proof. - intros a b; rewrite (div2_odd b) at 1; apply bits_inj; intros m. - destruct (zero_or_succ m) as [-> | [m' ->]]; rewrite !land_spec. - - rewrite 2!testbit_0_r, testbit_odd_0; reflexivity. - - rewrite 2!testbit_succ_r, land_spec, testbit_odd_succ by (exact (le_0_l _)). - reflexivity. -Qed. - -Lemma land_odd_r : - forall a b, land a (2 * b + 1) == 2 * (land (div2 a) b) + odd a. -Proof. - intros a b; rewrite (land_comm a _), (land_comm _ b); exact (land_odd_l _ _). -Qed. - -Lemma land_even_even : forall a b, land (2 * a) (2 * b) == 2 * land a b. -Proof. intros a b; rewrite land_even_l, div2_even; reflexivity. Qed. - -Lemma land_odd_even : forall a b, land (2 * a + 1) (2 * b) == 2 * land a b. -Proof. intros a b; rewrite land_even_r, div2_odd'; reflexivity. Qed. - -Lemma land_even_odd : forall a b, land (2 * a) (2 * b + 1) == 2 * land a b. -Proof. intros a b; rewrite land_even_l, div2_odd'; reflexivity. Qed. - -Lemma land_odd_odd : - forall a b, land (2 * a + 1) (2 * b + 1) == 2 * (land a b) + 1. -Proof. intros a b; rewrite land_odd_l, div2_odd', odd_odd; reflexivity. Qed. - -Lemma land_le_l : - forall a b, land a b <= a. -Proof. - apply (Private_binary_induction (fun a => forall b, _)); [| | intros a H b..]. - - intros x y eq; split; intros H b; [rewrite <-eq | rewrite eq]; now apply H. - - intros b; rewrite land_0_l; exact (le_refl _). - - rewrite land_even_l; apply mul_le_mono_l; exact (H _). - - rewrite land_odd_l; apply add_le_mono; - [apply mul_le_mono_l; exact (H _) | exact (b2n_le_1 _)]. -Qed. - -Lemma land_le_r : - forall a b, land a b <= b. -Proof. intros a b; rewrite land_comm; exact (land_le_l _ _). Qed. - -Lemma ldiff_0_l : forall a, ldiff 0 a == 0. -Proof. - intros. bitwise. trivial. -Qed. - -Lemma ldiff_0_r : forall a, ldiff a 0 == a. -Proof. - intros. bitwise. now rewrite andb_true_r. -Qed. - -Lemma ldiff_diag : forall a, ldiff a a == 0. -Proof. - intros. bitwise. apply andb_negb_r. -Qed. - -Lemma ldiff_even_l : forall a b, ldiff (2 * a) b == 2 * ldiff a (div2 b). -Proof. - intros a b; apply bits_inj; intros m. - destruct (zero_or_succ m) as [-> | [m' ->]]; rewrite ldiff_spec. - - rewrite 2!testbit_even_0; reflexivity. - - rewrite 2!testbit_even_succ, ldiff_spec, testbit_div2 - by (exact (le_0_l _)); reflexivity. -Qed. - -Lemma ldiff_odd_l : - forall a b, ldiff (2 * a + 1) b == 2 * ldiff a (div2 b) + even b. -Proof. - intros a b; apply bits_inj; intros m. - destruct (zero_or_succ m) as [-> | [m' ->]]; rewrite ldiff_spec. - - rewrite testbit_odd_0, testbit_0_r, bit0_odd, negb_odd; reflexivity. - - rewrite testbit_odd_succ, testbit_succ_r, ldiff_spec, testbit_div2 - by (exact (le_0_l _)); reflexivity. -Qed. - -Lemma ldiff_even_r : - forall a b, ldiff a (2 * b) == 2 * ldiff (div2 a) b + odd a. -Proof. - intros a b; apply bits_inj; intros m. - destruct (zero_or_succ m) as [-> | [m' ->]]; rewrite ldiff_spec. - - rewrite testbit_0_r, testbit_even_0, bit0_odd; simpl; rewrite andb_true_r; - reflexivity. - - rewrite testbit_succ_r, testbit_even_succ, ldiff_spec, testbit_div2 - by (exact (le_0_l _)); reflexivity. -Qed. - -Lemma ldiff_odd_r : - forall a b, ldiff a (2 * b + 1) == 2 * ldiff (div2 a) b. -Proof. - intros a b; apply bits_inj; intros m. - destruct (zero_or_succ m) as [-> | [m' ->]]; rewrite ldiff_spec. - - rewrite testbit_odd_0, testbit_even_0; simpl; rewrite andb_false_r; - reflexivity. - - rewrite testbit_odd_succ, testbit_even_succ, ldiff_spec, testbit_div2 - by (exact (le_0_l _)); reflexivity. -Qed. - -Lemma ldiff_even_even : forall a b, ldiff (2 * a) (2 * b) == 2 * ldiff a b. -Proof. intros a b; rewrite ldiff_even_l, div2_even; reflexivity. Qed. - -Lemma ldiff_odd_even : - forall a b, ldiff (2 * a + 1) (2 * b) == 2 * (ldiff a b) + 1. -Proof. intros a b; rewrite ldiff_even_r, div2_odd', odd_odd; reflexivity. Qed. - -Lemma ldiff_even_odd : forall a b, ldiff (2 * a) (2 * b + 1) == 2 * ldiff a b. -Proof. intros a b; rewrite ldiff_even_l, div2_odd'; reflexivity. Qed. - -Lemma ldiff_odd_odd : - forall a b, ldiff (2 * a + 1) (2 * b + 1) == 2 * ldiff a b. -Proof. intros a b; rewrite ldiff_odd_r, div2_odd'; reflexivity. Qed. - -Lemma ldiff_le_l : - forall a b, ldiff a b <= a. -Proof. - apply (Private_binary_induction (fun a => forall b, _)); [| | intros a H b..]. - - intros x y eq; split; intros H b; [rewrite <-eq | rewrite eq]; now apply H. - - intros b; rewrite ldiff_0_l; exact (le_0_l _). - - rewrite ldiff_even_l; apply mul_le_mono_l; exact (H _). - - rewrite ldiff_odd_l; apply add_le_mono; - [ apply mul_le_mono_l; exact (H _) | exact (b2n_le_1 _)]. -Qed. - -Lemma lor_land_distr_l : forall a b c, - lor (land a b) c == land (lor a c) (lor b c). -Proof. - intros. bitwise. apply orb_andb_distrib_l. -Qed. - -Lemma lor_land_distr_r : forall a b c, - lor a (land b c) == land (lor a b) (lor a c). -Proof. - intros. bitwise. apply orb_andb_distrib_r. -Qed. - -Lemma land_lor_distr_l : forall a b c, - land (lor a b) c == lor (land a c) (land b c). -Proof. - intros. bitwise. apply andb_orb_distrib_l. -Qed. - -Lemma land_lor_distr_r : forall a b c, - land a (lor b c) == lor (land a b) (land a c). -Proof. - intros. bitwise. apply andb_orb_distrib_r. -Qed. - -Lemma ldiff_ldiff_l : forall a b c, - ldiff (ldiff a b) c == ldiff a (lor b c). -Proof. - intros. bitwise. now rewrite negb_orb, andb_assoc. -Qed. - -Lemma lor_ldiff_and : forall a b, - lor (ldiff a b) (land a b) == a. -Proof. - intros. bitwise. - now rewrite <- andb_orb_distrib_r, orb_comm, orb_negb_r, andb_true_r. -Qed. - -Lemma land_ldiff : forall a b, - land (ldiff a b) b == 0. -Proof. - intros. bitwise. - now rewrite <-andb_assoc, (andb_comm (negb _)), andb_negb_r, andb_false_r. -Qed. - -(** Properties of [setbit] and [clearbit] *) - -Definition setbit a n := lor a (1<eq==>eq) setbit. -Proof. unfold setbit. solve_proper. Qed. - -#[global] -Instance clearbit_wd : Proper (eq==>eq==>eq) clearbit. -Proof. unfold clearbit. solve_proper. Qed. - -Lemma pow2_bits_true : forall n, (2^n).[n] = true. -Proof. - intros n. rewrite <- (mul_1_l (2^n)). rewrite <- (add_0_l n) at 2. - now rewrite mul_pow2_bits_add, bit0_odd, odd_1. -Qed. - -Lemma pow2_bits_false : forall n m, n~=m -> (2^n).[m] = false. -Proof. - intros n m ?. - rewrite <- (mul_1_l (2^n)). - destruct (le_gt_cases n m). - - rewrite mul_pow2_bits_high; trivial. - rewrite <- (succ_pred (m-n)) by (apply sub_gt; order). - now rewrite <- div2_bits, div_small, bits_0 by order'. - - rewrite mul_pow2_bits_low; trivial. -Qed. - -Lemma pow2_bits_eqb : forall n m, (2^n).[m] = eqb n m. -Proof. - intros n m. apply eq_true_iff_eq. rewrite eqb_eq. split. - - destruct (eq_decidable n m) as [H|H]. { trivial. } - now rewrite (pow2_bits_false _ _ H). - - intros EQ. rewrite EQ. apply pow2_bits_true. -Qed. - -Lemma setbit_eqb : forall a n m, - (setbit a n).[m] = eqb n m || a.[m]. -Proof. - intros. now rewrite setbit_spec', lor_spec, pow2_bits_eqb, orb_comm. -Qed. - -Lemma setbit_iff : forall a n m, - (setbit a n).[m] = true <-> n==m \/ a.[m] = true. -Proof. - intros. now rewrite setbit_eqb, orb_true_iff, eqb_eq. -Qed. - -Lemma setbit_eq : forall a n, (setbit a n).[n] = true. -Proof. - intros. apply setbit_iff. now left. -Qed. - -Lemma setbit_neq : forall a n m, n~=m -> - (setbit a n).[m] = a.[m]. -Proof. - intros a n m H. rewrite setbit_eqb. - rewrite <- eqb_eq in H. apply not_true_is_false in H. now rewrite H. -Qed. - -Lemma clearbit_eqb : forall a n m, - (clearbit a n).[m] = a.[m] && negb (eqb n m). -Proof. - intros. now rewrite clearbit_spec', ldiff_spec, pow2_bits_eqb. -Qed. - -Lemma clearbit_iff : forall a n m, - (clearbit a n).[m] = true <-> a.[m] = true /\ n~=m. -Proof. - intros. rewrite clearbit_eqb, andb_true_iff, <- eqb_eq. - now rewrite negb_true_iff, not_true_iff_false. -Qed. - -Lemma clearbit_eq : forall a n, (clearbit a n).[n] = false. -Proof. - intros a n. rewrite clearbit_eqb, (proj2 (eqb_eq _ _) (eq_refl n)). - apply andb_false_r. -Qed. - -Lemma clearbit_neq : forall a n m, n~=m -> - (clearbit a n).[m] = a.[m]. -Proof. - intros a n m H. rewrite clearbit_eqb. - rewrite <- eqb_eq in H. apply not_true_is_false in H. rewrite H. - apply andb_true_r. -Qed. - -(** Shifts of bitwise operations *) - -Lemma shiftl_lxor : forall a b n, - (lxor a b) << n == lxor (a << n) (b << n). -Proof. - intros a b n. bitwise as m. - destruct (le_gt_cases n m). - - now rewrite !shiftl_spec_high', lxor_spec. - - now rewrite !shiftl_spec_low. -Qed. - -Lemma shiftr_lxor : forall a b n, - (lxor a b) >> n == lxor (a >> n) (b >> n). -Proof. - intros. bitwise. now rewrite !shiftr_spec', lxor_spec. -Qed. - -Lemma shiftl_land : forall a b n, - (land a b) << n == land (a << n) (b << n). -Proof. - intros a b n. bitwise as m. - destruct (le_gt_cases n m). - - now rewrite !shiftl_spec_high', land_spec. - - now rewrite !shiftl_spec_low. -Qed. - -Lemma shiftr_land : forall a b n, - (land a b) >> n == land (a >> n) (b >> n). -Proof. - intros. bitwise. now rewrite !shiftr_spec', land_spec. -Qed. - -Lemma shiftl_lor : forall a b n, - (lor a b) << n == lor (a << n) (b << n). -Proof. - intros a b n. bitwise as m. - destruct (le_gt_cases n m). - - now rewrite !shiftl_spec_high', lor_spec. - - now rewrite !shiftl_spec_low. -Qed. - -Lemma shiftr_lor : forall a b n, - (lor a b) >> n == lor (a >> n) (b >> n). -Proof. - intros. bitwise. now rewrite !shiftr_spec', lor_spec. -Qed. - -Lemma shiftl_ldiff : forall a b n, - (ldiff a b) << n == ldiff (a << n) (b << n). -Proof. - intros a b n. bitwise as m. - destruct (le_gt_cases n m). - - now rewrite !shiftl_spec_high', ldiff_spec. - - now rewrite !shiftl_spec_low. -Qed. - -Lemma shiftr_ldiff : forall a b n, - (ldiff a b) >> n == ldiff (a >> n) (b >> n). -Proof. - intros. bitwise. now rewrite !shiftr_spec', ldiff_spec. -Qed. - -(** Shifts and order *) - -Lemma shiftl_lower_bound : forall a n, a <= a << n. -Proof. - intros a n; rewrite shiftl_mul_pow2, two_succ; rewrite <-(mul_1_r a) at 1. - apply mul_le_mono_l, pow_lower_bound; exact (neq_succ_0 _). -Qed. - -Lemma shiftr_upper_bound : forall a n, a >> n <= a. -Proof. - intros a n; rewrite shiftr_div_pow2, two_succ; apply div_le_upper_bound; - [| apply le_mul_l]; apply pow_nonzero; exact (neq_succ_0 _). -Qed. - -(** We cannot have a function complementing all bits of a number, - otherwise it would have an infinity of bit 1. Nonetheless, - we can design a bounded complement *) - -Definition ones n := P (1 << n). - -Definition lnot a n := lxor a (ones n). - -#[global] -Instance ones_wd : Proper (eq==>eq) ones. -Proof. unfold ones. solve_proper. Qed. - -#[global] -Instance lnot_wd : Proper (eq==>eq==>eq) lnot. -Proof. unfold lnot. solve_proper. Qed. - -Lemma ones_equiv : forall n, ones n == P (2^n). -Proof. - intros; unfold ones; now rewrite shiftl_1_l. -Qed. - -Lemma ones_0 : ones 0 == 0. -Proof. - rewrite ones_equiv, pow_0_r, one_succ, pred_succ; reflexivity. -Qed. - -Lemma ones_add : forall n m, ones (m+n) == 2^m * ones n + ones m. -Proof. - intros n m. rewrite !ones_equiv. - rewrite <- !sub_1_r, mul_sub_distr_l, mul_1_r, <- pow_add_r. - rewrite add_sub_assoc, sub_add. - - reflexivity. - - apply pow_le_mono_r. { order'. } - rewrite <- (add_0_r m) at 1. apply add_le_mono_l, le_0_l. - - rewrite <- (pow_0_r 2). apply pow_le_mono_r. { order'. } apply le_0_l. -Qed. - -Lemma ones_div_pow2 : forall n m, m<=n -> ones n / 2^m == ones (n-m). -Proof. - intros n m H. symmetry. apply div_unique with (ones m). - - rewrite ones_equiv. - apply le_succ_l. rewrite succ_pred; order_nz. - - rewrite <- (sub_add m n H) at 1. rewrite (add_comm _ m). - apply ones_add. -Qed. - -Lemma ones_mod_pow2 : forall n m, m<=n -> (ones n) mod (2^m) == ones m. -Proof. - intros n m H. symmetry. apply mod_unique with (ones (n-m)). - - rewrite ones_equiv. - apply le_succ_l. rewrite succ_pred; order_nz. - - rewrite <- (sub_add m n H) at 1. rewrite (add_comm _ m). - apply ones_add. -Qed. - -Lemma ones_spec_low : forall n m, m (ones n).[m] = true. -Proof. - intros. apply testbit_true. rewrite ones_div_pow2 by order. - rewrite <- (pow_1_r 2). rewrite ones_mod_pow2. - - rewrite ones_equiv. now nzsimpl'. - - apply le_add_le_sub_r. nzsimpl. now apply le_succ_l. -Qed. - -Lemma ones_spec_high : forall n m, n<=m -> (ones n).[m] = false. -Proof. - intros n m ?. - destruct (eq_0_gt_0_cases n) as [EQ|LT]; rewrite ones_equiv. - - now rewrite EQ, pow_0_r, one_succ, pred_succ, bits_0. - - apply bits_above_log2. - rewrite log2_pred_pow2; trivial. rewrite <-le_succ_l, succ_pred; order. -Qed. - -Lemma ones_spec_iff : forall n m, (ones n).[m] = true <-> m - (lnot a n).[m] = negb a.[m]. -Proof. - intros. unfold lnot. now rewrite lxor_spec, ones_spec_low. -Qed. - -Lemma lnot_spec_high : forall a n m, n<=m -> - (lnot a n).[m] = a.[m]. -Proof. - intros. unfold lnot. now rewrite lxor_spec, ones_spec_high, xorb_false_r. -Qed. - -Lemma lnot_involutive : forall a n, lnot (lnot a n) n == a. -Proof. - intros a n. bitwise as m. - destruct (le_gt_cases n m). - - now rewrite 2 lnot_spec_high. - - now rewrite 2 lnot_spec_low, negb_involutive. -Qed. - -Lemma lnot_0_l : forall n, lnot 0 n == ones n. -Proof. - intros. unfold lnot. apply lxor_0_l. -Qed. - -Lemma lnot_ones : forall n, lnot (ones n) n == 0. -Proof. - intros. unfold lnot. apply lxor_nilpotent. -Qed. - -Lemma ones_succ : forall n, ones (S n) == 2 * (ones n) + 1. -Proof. - intros n; rewrite 2!ones_equiv, <-2!sub_1_r, mul_sub_distr_l. - rewrite mul_1_r, <-pow_succ_r, two_succ, one_succ by (exact (le_0_l _)). - rewrite <-sub_sub_distr, sub_succ, sub_0_r; [reflexivity | |]. - - apply ->succ_le_mono; exact (le_0_l _). - - rewrite <-(pow_1_r (S (S 0))) at 1; apply pow_le_mono_r; - [exact (neq_succ_0 _) | exact (le_1_succ _)]. -Qed. - -(** Bounded complement and other operations *) - -Lemma lor_ones_low : forall a n, log2 a < n -> - lor a (ones n) == ones n. -Proof. - intros a n H. bitwise as m. destruct (le_gt_cases n m). - - rewrite ones_spec_high, bits_above_log2; trivial. - now apply lt_le_trans with n. - - now rewrite ones_spec_low, orb_true_r. -Qed. - -Lemma land_ones : forall a n, land a (ones n) == a mod 2^n. -Proof. - intros a n. bitwise as m. destruct (le_gt_cases n m). - - now rewrite ones_spec_high, mod_pow2_bits_high, andb_false_r. - - now rewrite ones_spec_low, mod_pow2_bits_low, andb_true_r. -Qed. - -Lemma land_ones_low : forall a n, log2 a < n -> - land a (ones n) == a. -Proof. - intros; rewrite land_ones. apply mod_small. - apply log2_lt_cancel. rewrite log2_pow2; trivial using le_0_l. -Qed. - -Lemma ldiff_ones_r : forall a n, - ldiff a (ones n) == (a >> n) << n. -Proof. - intros a n. bitwise as m. destruct (le_gt_cases n m). - - rewrite ones_spec_high, shiftl_spec_high', shiftr_spec'; trivial. - rewrite sub_add; trivial. apply andb_true_r. - - now rewrite ones_spec_low, shiftl_spec_low, andb_false_r. -Qed. - -Lemma ldiff_ones_r_low : forall a n, log2 a < n -> - ldiff a (ones n) == 0. -Proof. - intros a n H. bitwise as m. destruct (le_gt_cases n m). - - rewrite ones_spec_high, bits_above_log2; trivial. - now apply lt_le_trans with n. - - now rewrite ones_spec_low, andb_false_r. -Qed. - -Lemma ldiff_ones_l_low : forall a n, log2 a < n -> - ldiff (ones n) a == lnot a n. -Proof. - intros a n H. bitwise as m. destruct (le_gt_cases n m). - - rewrite ones_spec_high, lnot_spec_high, bits_above_log2; trivial. - now apply lt_le_trans with n. - - now rewrite ones_spec_low, lnot_spec_low. -Qed. - -Lemma lor_lnot_diag : forall a n, - lor a (lnot a n) == lor a (ones n). -Proof. - intros a n. bitwise as m. - destruct (le_gt_cases n m). - - rewrite lnot_spec_high, ones_spec_high; trivial. now destruct a.[m]. - - rewrite lnot_spec_low, ones_spec_low; trivial. now destruct a.[m]. -Qed. - -Lemma lor_lnot_diag_low : forall a n, log2 a < n -> - lor a (lnot a n) == ones n. -Proof. - intros a n H. now rewrite lor_lnot_diag, lor_ones_low. -Qed. - -Lemma land_lnot_diag : forall a n, - land a (lnot a n) == ldiff a (ones n). -Proof. - intros a n. bitwise as m. - destruct (le_gt_cases n m). - - rewrite lnot_spec_high, ones_spec_high; trivial. now destruct a.[m]. - - rewrite lnot_spec_low, ones_spec_low; trivial. now destruct a.[m]. -Qed. - -Lemma land_lnot_diag_low : forall a n, log2 a < n -> - land a (lnot a n) == 0. -Proof. - intros. now rewrite land_lnot_diag, ldiff_ones_r_low. -Qed. - -Lemma lnot_lor_low : forall a b n, log2 a < n -> log2 b < n -> - lnot (lor a b) n == land (lnot a n) (lnot b n). -Proof. - intros a b n Ha Hb. bitwise as m. destruct (le_gt_cases n m). - - rewrite !lnot_spec_high, lor_spec, !bits_above_log2; trivial. - + now apply lt_le_trans with n. - + now apply lt_le_trans with n. - - now rewrite !lnot_spec_low, lor_spec, negb_orb. -Qed. - -Lemma lnot_land_low : forall a b n, log2 a < n -> log2 b < n -> - lnot (land a b) n == lor (lnot a n) (lnot b n). -Proof. - intros a b n Ha Hb. bitwise as m. destruct (le_gt_cases n m). - - rewrite !lnot_spec_high, land_spec, !bits_above_log2; trivial. - + now apply lt_le_trans with n. - + now apply lt_le_trans with n. - - now rewrite !lnot_spec_low, land_spec, negb_andb. -Qed. - -Lemma ldiff_land_low : forall a b n, log2 a < n -> - ldiff a b == land a (lnot b n). -Proof. - intros a b n Ha. bitwise as m. destruct (le_gt_cases n m). - - rewrite (bits_above_log2 a m). - + trivial. - + now apply lt_le_trans with n. - - rewrite !lnot_spec_low; trivial. -Qed. - -Lemma lnot_ldiff_low : forall a b n, log2 a < n -> log2 b < n -> - lnot (ldiff a b) n == lor (lnot a n) b. -Proof. - intros a b n Ha Hb. bitwise as m. destruct (le_gt_cases n m). - - rewrite !lnot_spec_high, ldiff_spec, !bits_above_log2; trivial. - + now apply lt_le_trans with n. - + now apply lt_le_trans with n. - - now rewrite !lnot_spec_low, ldiff_spec, negb_andb, negb_involutive. -Qed. - -Lemma lxor_lnot_lnot : forall a b n, - lxor (lnot a n) (lnot b n) == lxor a b. -Proof. - intros a b n. bitwise as m. destruct (le_gt_cases n m). - - rewrite !lnot_spec_high; trivial. - - rewrite !lnot_spec_low, xorb_negb_negb; trivial. -Qed. - -Lemma lnot_lxor_l : forall a b n, - lnot (lxor a b) n == lxor (lnot a n) b. -Proof. - intros a b n. bitwise as m. destruct (le_gt_cases n m). - - rewrite !lnot_spec_high, lxor_spec; trivial. - - rewrite !lnot_spec_low, lxor_spec, negb_xorb_l; trivial. -Qed. - -Lemma lnot_lxor_r : forall a b n, - lnot (lxor a b) n == lxor a (lnot b n). -Proof. - intros a b n. bitwise as m. destruct (le_gt_cases n m). - - rewrite !lnot_spec_high, lxor_spec; trivial. - - rewrite !lnot_spec_low, lxor_spec, negb_xorb_r; trivial. -Qed. - -Lemma lxor_lor : forall a b, land a b == 0 -> - lxor a b == lor a b. -Proof. - intros a b H. bitwise as m. - assert (a.[m] && b.[m] = false) - by now rewrite <- land_spec, H, bits_0. - now destruct a.[m], b.[m]. -Qed. - -(** Bitwise operations and log2 *) - -Lemma log2_bits_unique : forall a n, - a.[n] = true -> - (forall m, n a.[m] = false) -> - log2 a == n. -Proof. - intros a n H H'. - destruct (eq_0_gt_0_cases a) as [Ha|Ha]. - - now rewrite Ha, bits_0 in H. - - apply le_antisymm; apply le_ngt; intros LT. - + specialize (H' _ LT). now rewrite bit_log2 in H' by order. - + now rewrite bits_above_log2 in H by order. -Qed. - -Lemma log2_shiftr : forall a n, log2 (a >> n) == log2 a - n. -Proof. - intros a n. - destruct (eq_0_gt_0_cases a) as [Ha|Ha]. - - now rewrite Ha, shiftr_0_l, log2_nonpos, sub_0_l by order. - - destruct (lt_ge_cases (log2 a) n). - + rewrite shiftr_eq_0, log2_nonpos by order. - symmetry. rewrite sub_0_le; order. - + apply log2_bits_unique. - * now rewrite shiftr_spec', sub_add, bit_log2 by order. - * intros m Hm. - rewrite shiftr_spec'; trivial. apply bits_above_log2; try order. - now apply lt_sub_lt_add_r. -Qed. - -Lemma log2_shiftl : forall a n, a~=0 -> log2 (a << n) == log2 a + n. -Proof. - intros a n Ha. - rewrite shiftl_mul_pow2, add_comm by trivial. - apply log2_mul_pow2. - - generalize (le_0_l a); order. - - apply le_0_l. -Qed. - -Lemma log2_lor : forall a b, - log2 (lor a b) == max (log2 a) (log2 b). -Proof. - assert (AUX : forall a b, a<=b -> log2 (lor a b) == log2 b). { - intros a b H. - destruct (eq_0_gt_0_cases a) as [Ha|Ha]. - - now rewrite Ha, lor_0_l. - - apply log2_bits_unique. - + now rewrite lor_spec, bit_log2, orb_true_r by order. - + intros m Hm. assert (H' := log2_le_mono _ _ H). - now rewrite lor_spec, 2 bits_above_log2 by order. - } - (* main *) - intros a b. destruct (le_ge_cases a b) as [H|H]. - - rewrite max_r by now apply log2_le_mono. - now apply AUX. - - rewrite max_l by now apply log2_le_mono. - rewrite lor_comm. now apply AUX. -Qed. - -Lemma log2_land : forall a b, - log2 (land a b) <= min (log2 a) (log2 b). -Proof. - assert (AUX : forall a b, a<=b -> log2 (land a b) <= log2 a). { - intros a b H. - apply le_ngt. intros H'. - destruct (eq_decidable (land a b) 0) as [EQ|NEQ]. - - rewrite EQ in H'. apply log2_lt_cancel in H'. generalize (le_0_l a); order. - - generalize (bit_log2 (land a b) NEQ). - now rewrite land_spec, bits_above_log2. - } - (* main *) - intros a b. - destruct (le_ge_cases a b) as [H|H]. - - rewrite min_l by now apply log2_le_mono. now apply AUX. - - rewrite min_r by now apply log2_le_mono. rewrite land_comm. now apply AUX. -Qed. - -Lemma log2_lxor : forall a b, - log2 (lxor a b) <= max (log2 a) (log2 b). -Proof. - assert (AUX : forall a b, a<=b -> log2 (lxor a b) <= log2 b). { - intros a b H. - apply le_ngt. intros H'. - destruct (eq_decidable (lxor a b) 0) as [EQ|NEQ]. - - rewrite EQ in H'. apply log2_lt_cancel in H'. generalize (le_0_l a); order. - - generalize (bit_log2 (lxor a b) NEQ). - rewrite lxor_spec, 2 bits_above_log2; try order. - + discriminate. - + apply le_lt_trans with (log2 b); trivial. now apply log2_le_mono. - } - (* main *) - intros a b. - destruct (le_ge_cases a b) as [H|H]. - - rewrite max_r by now apply log2_le_mono. now apply AUX. - - rewrite max_l by now apply log2_le_mono. rewrite lxor_comm. now apply AUX. -Qed. - -(** Bitwise operations and arithmetical operations *) - -Local Notation xor3 a b c := (xorb (xorb a b) c). -Local Notation lxor3 a b c := (lxor (lxor a b) c). - -Local Notation nextcarry a b c := ((a&&b) || (c && (a||b))). -Local Notation lnextcarry a b c := (lor (land a b) (land c (lor a b))). - -Lemma add_bit0 : forall a b, (a+b).[0] = xorb a.[0] b.[0]. -Proof. - intros. now rewrite !bit0_odd, odd_add. -Qed. - -Lemma add3_bit0 : forall a b c, - (a+b+c).[0] = xor3 a.[0] b.[0] c.[0]. -Proof. - intros. now rewrite !add_bit0. -Qed. - -Lemma add3_bits_div2 : forall (a0 b0 c0 : bool), - (a0 + b0 + c0)/2 == nextcarry a0 b0 c0. -Proof. - assert (H : 1+1 == 2) by now nzsimpl'. - intros [|] [|] [|]; simpl; rewrite ?add_0_l, ?add_0_r, ?H; - (apply div_same; order') || (apply div_small; order') || idtac. - symmetry. apply div_unique with 1. { order'. } now nzsimpl'. -Qed. - -Lemma add_carry_div2 : forall a b (c0:bool), - (a + b + c0)/2 == a/2 + b/2 + nextcarry a.[0] b.[0] c0. -Proof. - intros a b c0. - rewrite <- add3_bits_div2. - rewrite (add_comm ((a/2)+_)). - rewrite <- div_add by order'. - f_equiv. - rewrite <- !div2_div, mul_comm, mul_add_distr_l. - rewrite (div2_odd a), <- bit0_odd at 1. fold (b2n a.[0]). - rewrite (div2_odd b), <- bit0_odd at 1. fold (b2n b.[0]). - rewrite add_shuffle1. - rewrite <-(add_assoc _ _ c0). apply add_comm. -Qed. - -(** The main result concerning addition: we express the bits of the sum - in term of bits of [a] and [b] and of some carry stream which is also - recursively determined by another equation. -*) - -Lemma add_carry_bits : forall a b (c0:bool), exists c, - a+b+c0 == lxor3 a b c /\ c/2 == lnextcarry a b c /\ c.[0] = c0. -Proof. - intros a b c0. - (* induction over some n such that [a<2^n] and [b<2^n] *) - set (n:=max a b). - assert (Ha : a<2^n). { - apply lt_le_trans with (2^a). - - apply pow_gt_lin_r, lt_1_2. - - apply pow_le_mono_r. { order'. } unfold n. - destruct (le_ge_cases a b); [rewrite max_r|rewrite max_l]; order'. - } - assert (Hb : b<2^n). { - apply lt_le_trans with (2^b). - - apply pow_gt_lin_r, lt_1_2. - - apply pow_le_mono_r. { order'. } unfold n. - destruct (le_ge_cases a b); [rewrite max_r|rewrite max_l]; order'. - } - clearbody n. - revert a b c0 Ha Hb. induct n. - - (*base*) - intros a b c0. rewrite !pow_0_r, !one_succ, !lt_succ_r. intros Ha Hb. - exists c0. - setoid_replace a with 0 by (generalize (le_0_l a); order'). - setoid_replace b with 0 by (generalize (le_0_l b); order'). - rewrite !add_0_l, !lxor_0_l, !lor_0_r, !land_0_r, !lor_0_r. - rewrite b2n_div2, b2n_bit0; now repeat split. - - (*step*) - intros n IH a b c0 Ha Hb. - set (c1:=nextcarry a.[0] b.[0] c0). - destruct (IH (a/2) (b/2) c1) as (c & IH1 & IH2 & Hc); clear IH. - + apply div_lt_upper_bound; trivial. { order'. } now rewrite <- pow_succ_r'. - + apply div_lt_upper_bound; trivial. { order'. } now rewrite <- pow_succ_r'. - + exists (c0 + 2*c). repeat split. - * { (* - add *) - bitwise as m. - destruct (zero_or_succ m) as [EQ|[m' EQ]]; rewrite EQ; clear EQ. - - now rewrite add_b2n_double_bit0, add3_bit0, b2n_bit0. - - rewrite <- !div2_bits, <- 2 lxor_spec. - f_equiv. - rewrite add_b2n_double_div2, <- IH1. apply add_carry_div2. - } - * { (* - carry *) - rewrite add_b2n_double_div2. - bitwise as m. - destruct (zero_or_succ m) as [EQ|[m' EQ]]; rewrite EQ; clear EQ. - - now rewrite add_b2n_double_bit0. - - rewrite <- !div2_bits, IH2. autorewrite with bitwise. - now rewrite add_b2n_double_div2. - } - * (* - carry0 *) - apply add_b2n_double_bit0. -Qed. - -(** Particular case : the second bit of an addition *) - -Lemma add_bit1 : forall a b, - (a+b).[1] = xor3 a.[1] b.[1] (a.[0] && b.[0]). -Proof. - intros a b. - destruct (add_carry_bits a b false) as (c & EQ1 & EQ2 & Hc). - simpl in EQ1; rewrite add_0_r in EQ1. rewrite EQ1. - autorewrite with bitwise. f_equal. - rewrite one_succ, <- div2_bits, EQ2. - autorewrite with bitwise. - rewrite Hc. simpl. apply orb_false_r. -Qed. - -(** In an addition, there will be no carries iff there is - no common bits in the numbers to add *) - -Lemma nocarry_equiv : forall a b c, - c/2 == lnextcarry a b c -> c.[0] = false -> - (c == 0 <-> land a b == 0). -Proof. - intros a b c H H'. - split. - - intros EQ; rewrite EQ in *. - rewrite div_0_l in H by order'. - symmetry in H. now apply lor_eq_0_l in H. - - intros EQ. rewrite EQ, lor_0_l in H. - apply bits_inj_0. - intro n; induct n. - + trivial. - + intros n IH. - rewrite <- div2_bits, H. - autorewrite with bitwise. - now rewrite IH. -Qed. - -(** When there is no common bits, the addition is just a xor *) - -Lemma add_nocarry_lxor : forall a b, land a b == 0 -> - a+b == lxor a b. -Proof. - intros a b H. - destruct (add_carry_bits a b false) as (c & EQ1 & EQ2 & Hc). - simpl in EQ1; rewrite add_0_r in EQ1. rewrite EQ1. - apply (nocarry_equiv a b c) in H; trivial. - rewrite H. now rewrite lxor_0_r. -Qed. - -(** A null [ldiff] implies being smaller *) - -Lemma ldiff_le : forall a b, ldiff a b == 0 -> a <= b. -Proof. - cut (forall n a b, a < 2^n -> ldiff a b == 0 -> a <= b). { - intros H a b. apply (H a), pow_gt_lin_r; order'. - } - intro n; induct n. - - intros a b Ha _. rewrite pow_0_r, one_succ, lt_succ_r in Ha. - assert (Ha' : a == 0) by (generalize (le_0_l a); order'). - rewrite Ha'. apply le_0_l. - - intros n IH a b Ha H. - assert (NEQ : 2 ~= 0) by order'. - rewrite (div_mod a 2 NEQ), (div_mod b 2 NEQ). - apply add_le_mono. - + apply mul_le_mono_l. - apply IH. - * apply div_lt_upper_bound; trivial. now rewrite <- pow_succ_r'. - * rewrite <- (pow_1_r 2), <- 2 shiftr_div_pow2. - now rewrite <- shiftr_ldiff, H, shiftr_div_pow2, pow_1_r, div_0_l. - + rewrite <- 2 bit0_mod. - apply bits_inj_iff in H. specialize (H 0). - rewrite ldiff_spec, bits_0 in H. - destruct a.[0], b.[0]; try discriminate; simpl; order'. -Qed. - -(** Subtraction can be a ldiff when the opposite ldiff is null. *) - -Lemma sub_nocarry_ldiff : forall a b, ldiff b a == 0 -> - a-b == ldiff a b. -Proof. - intros a b H. - apply add_cancel_r with b. - rewrite sub_add. - - symmetry. - rewrite add_nocarry_lxor. - + bitwise as m. - apply bits_inj_iff in H. specialize (H m). - rewrite ldiff_spec, bits_0 in H. - now destruct a.[m], b.[m]. - + apply land_ldiff. - - now apply ldiff_le. -Qed. - -(** We can express lnot in term of subtraction *) - -Lemma add_lnot_diag_low : forall a n, log2 a < n -> - a + lnot a n == ones n. -Proof. - intros a n H. - assert (H' := land_lnot_diag_low a n H). - rewrite add_nocarry_lxor, lxor_lor by trivial. - now apply lor_lnot_diag_low. -Qed. - -Lemma lnot_sub_low : forall a n, log2 a < n -> - lnot a n == ones n - a. -Proof. - intros a n H. - now rewrite <- (add_lnot_diag_low a n H), add_comm, add_sub. -Qed. - -(** Adding numbers with no common bits cannot lead to a much bigger number *) - -Lemma add_nocarry_lt_pow2 : forall a b n, land a b == 0 -> - a < 2^n -> b < 2^n -> a+b < 2^n. -Proof. - intros a b n H Ha Hb. - rewrite add_nocarry_lxor by trivial. - apply div_small_iff. { order_nz. } - rewrite <- shiftr_div_pow2, shiftr_lxor, !shiftr_div_pow2. - rewrite 2 div_small by trivial. - apply lxor_0_l. -Qed. - -Lemma add_nocarry_mod_lt_pow2 : forall a b n, land a b == 0 -> - a mod 2^n + b mod 2^n < 2^n. -Proof. - intros a b n H. - apply add_nocarry_lt_pow2. - - bitwise as m. - destruct (le_gt_cases n m). - + now rewrite mod_pow2_bits_high. - + now rewrite !mod_pow2_bits_low, <- land_spec, H, bits_0. - - apply mod_upper_bound; order_nz. - - apply mod_upper_bound; order_nz. -Qed. - -End NBitsProp. diff --git a/stdlib/theories/Numbers/Natural/Abstract/NDefOps.v b/stdlib/theories/Numbers/Natural/Abstract/NDefOps.v deleted file mode 100644 index 33eda5c914eb..000000000000 --- a/stdlib/theories/Numbers/Natural/Abstract/NDefOps.v +++ /dev/null @@ -1,454 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* b) n. - -Arguments if_zero [A] a b n. - -#[global] -Instance if_zero_wd (A : Type) : - Proper (Logic.eq ==> Logic.eq ==> N.eq ==> Logic.eq) (@if_zero A). -Proof. -unfold if_zero. (* TODO : solve_proper : SLOW + BUG *) -f_equiv'. -Qed. - -Theorem if_zero_0 : forall (A : Type) (a b : A), if_zero a b 0 = a. -Proof. -unfold if_zero; intros; now rewrite recursion_0. -Qed. - -Theorem if_zero_succ : - forall (A : Type) (a b : A) (n : N.t), if_zero a b (S n) = b. -Proof. -intros; unfold if_zero. -now rewrite recursion_succ. -Qed. - -(*****************************************************) -(** Addition *) - -Definition def_add (x y : N.t) := recursion y (fun _ => S) x. - -Local Infix "+++" := def_add (at level 50, left associativity). - -#[global] -Instance def_add_wd : Proper (N.eq ==> N.eq ==> N.eq) def_add. -Proof. -unfold def_add. f_equiv'. -Qed. - -Theorem def_add_0_l : forall y, 0 +++ y == y. -Proof. -intro y. unfold def_add. now rewrite recursion_0. -Qed. - -Theorem def_add_succ_l : forall x y, S x +++ y == S (x +++ y). -Proof. -intros x y; unfold def_add. -rewrite recursion_succ; f_equiv'. -Qed. - -Theorem def_add_add : forall n m, n +++ m == n + m. -Proof. -intros n m; induct n. -- now rewrite def_add_0_l, add_0_l. -- intros n H. now rewrite def_add_succ_l, add_succ_l, H. -Qed. - -(*****************************************************) -(** Multiplication *) - -Definition def_mul (x y : N.t) := recursion 0 (fun _ p => p +++ x) y. - -Local Infix "**" := def_mul (at level 40, left associativity). - -#[global] -Instance def_mul_wd : Proper (N.eq ==> N.eq ==> N.eq) def_mul. -Proof. -unfold def_mul. (* TODO : solve_proper SLOW + BUG *) -f_equiv'. -Qed. - -Theorem def_mul_0_r : forall x, x ** 0 == 0. -Proof. -intro. unfold def_mul. now rewrite recursion_0. -Qed. - -Theorem def_mul_succ_r : forall x y, x ** S y == x ** y +++ x. -Proof. -intros x y; unfold def_mul. -rewrite recursion_succ; auto with *. -f_equiv'. -Qed. - -Theorem def_mul_mul : forall n m, n ** m == n * m. -Proof. -intros n m; induct m. -- now rewrite def_mul_0_r, mul_0_r. -- intros m IH; now rewrite def_mul_succ_r, mul_succ_r, def_add_add, IH. -Qed. - -(*****************************************************) -(** Order *) - -Definition ltb (m : N.t) : N.t -> bool := -recursion - (if_zero false true) - (fun _ f n => recursion false (fun n' _ => f n') n) - m. - -Local Infix "<<" := ltb (at level 70, no associativity). - -#[global] -Instance ltb_wd : Proper (N.eq ==> N.eq ==> Logic.eq) ltb. -Proof. -unfold ltb. f_equiv'. -Qed. - -Theorem ltb_base : forall n, 0 << n = if_zero false true n. -Proof. -intro n; unfold ltb; now rewrite recursion_0. -Qed. - -Theorem ltb_step : - forall m n, S m << n = recursion false (fun n' _ => m << n') n. -Proof. -intros m n; unfold ltb at 1. -f_equiv. -rewrite recursion_succ; f_equiv'. -Qed. - -(* Above, we rewrite applications of function. Is it possible to rewrite -functions themselves, i.e., rewrite (recursion lt_base lt_step (S n)) to -lt_step n (recursion lt_base lt_step n)? *) - -Theorem ltb_0 : forall n, n << 0 = false. -Proof. -cases n. -- rewrite ltb_base; now rewrite if_zero_0. -- intro n; rewrite ltb_step. now rewrite recursion_0. -Qed. - -Theorem ltb_0_succ : forall n, 0 << S n = true. -Proof. -intro n; rewrite ltb_base; now rewrite if_zero_succ. -Qed. - -Theorem succ_ltb_mono : forall n m, (S n << S m) = (n << m). -Proof. -intros n m. -rewrite ltb_step. rewrite recursion_succ; f_equiv'. -Qed. - -Theorem ltb_lt : forall n m, n << m = true <-> n < m. -Proof. -double_induct n m. -- cases m. - + rewrite ltb_0. split; intro H; [discriminate H | false_hyp H nlt_0_r]. - + intro n. rewrite ltb_0_succ. split; intro; [apply lt_0_succ | reflexivity]. -- intro n. rewrite ltb_0. split; intro H; [discriminate | false_hyp H nlt_0_r]. -- intros n m. rewrite succ_ltb_mono. now rewrite <- succ_lt_mono. -Qed. - -Theorem ltb_ge : forall n m, n << m = false <-> n >= m. -Proof. -intros. rewrite <- not_true_iff_false, ltb_lt. apply nlt_ge. -Qed. - -(*****************************************************) -(** Even *) - -Definition even (x : N.t) := recursion true (fun _ p => negb p) x. - -#[global] -Instance even_wd : Proper (N.eq==>Logic.eq) even. -Proof. -unfold even. f_equiv'. -Qed. - -Theorem even_0 : even 0 = true. -Proof. -unfold even. -now rewrite recursion_0. -Qed. - -Theorem even_succ : forall x, even (S x) = negb (even x). -Proof. -unfold even. -intro x; rewrite recursion_succ; f_equiv'. -Qed. - -(*****************************************************) -(** Division by 2 *) - -Definition half_aux (x : N.t) : N.t * N.t := - recursion (0, 0) (fun _ p => let (x1, x2) := p in (S x2, x1)) x. - -Definition half (x : N.t) := snd (half_aux x). - -#[global] -Instance half_aux_wd : Proper (N.eq ==> N.eq*N.eq) half_aux. -Proof. -intros x x' Hx. unfold half_aux. -f_equiv; trivial. -intros y y' Hy (u,v) (u',v') (Hu,Hv). compute in *. -rewrite Hu, Hv; auto with *. -Qed. - -#[global] -Instance half_wd : Proper (N.eq==>N.eq) half. -Proof. -unfold half. f_equiv'. -Qed. - -Lemma half_aux_0 : half_aux 0 = (0,0). -Proof. -unfold half_aux. rewrite recursion_0; auto. -Qed. - -Lemma half_aux_succ : forall x, - half_aux (S x) = (S (snd (half_aux x)), fst (half_aux x)). -Proof. -intros. -remember (half_aux x) as h. -destruct h as (f,s); simpl in *. -unfold half_aux in *. -rewrite recursion_succ, <- Heqh; simpl; f_equiv'. -Qed. - -Theorem half_aux_spec : forall n, - n == fst (half_aux n) + snd (half_aux n). -Proof. -apply induction. -- intros x x' Hx. setoid_rewrite Hx; auto with *. -- rewrite half_aux_0; simpl; rewrite add_0_l; auto with *. -- intros. - rewrite half_aux_succ. simpl. - rewrite add_succ_l, add_comm; auto. - now f_equiv. -Qed. - -Theorem half_aux_spec2 : forall n, - fst (half_aux n) == snd (half_aux n) \/ - fst (half_aux n) == S (snd (half_aux n)). -Proof. -apply induction. -- intros x x' Hx. setoid_rewrite Hx; auto with *. -- rewrite half_aux_0; simpl. auto with *. -- intros. - rewrite half_aux_succ; simpl. - destruct H; auto with *. - right; now f_equiv. -Qed. - -Theorem half_0 : half 0 == 0. -Proof. -unfold half. rewrite half_aux_0; simpl; auto with *. -Qed. - -Theorem half_1 : half 1 == 0. -Proof. -unfold half. rewrite one_succ, half_aux_succ, half_aux_0; simpl; auto with *. -Qed. - -Theorem half_double : forall n, - n == 2 * half n \/ n == 1 + 2 * half n. -Proof. -intros. unfold half. -nzsimpl'. -destruct (half_aux_spec2 n) as [H|H]; [left|right]. -- rewrite <- H at 1. apply half_aux_spec. -- rewrite <- add_succ_l. rewrite <- H at 1. apply half_aux_spec. -Qed. - -Theorem half_upper_bound : forall n, 2 * half n <= n. -Proof. -intros. -destruct (half_double n) as [E|E]; rewrite E at 2. -- apply le_refl. -- nzsimpl. - apply le_le_succ_r, le_refl. -Qed. - -Theorem half_lower_bound : forall n, n <= 1 + 2 * half n. -Proof. -intros. -destruct (half_double n) as [E|E]; rewrite E at 1. -- nzsimpl. - apply le_le_succ_r, le_refl. -- apply le_refl. -Qed. - -Theorem half_nz : forall n, 1 < n -> 0 < half n. -Proof. -intros n LT. -assert (LE : 0 <= half n) by apply le_0_l. -le_elim LE; auto. -destruct (half_double n) as [E|E]; - rewrite <- LE, mul_0_r, ?add_0_r in E; rewrite E in LT. -- order'. -- order. -Qed. - -Theorem half_decrease : forall n, 0 < n -> half n < n. -Proof. -intros n LT. -destruct (half_double n) as [E|E]; rewrite E at 2; nzsimpl'. -- rewrite <- add_0_l at 1. - rewrite <- add_lt_mono_r. - assert (LE : 0 <= half n) by apply le_0_l. - le_elim LE; auto. - rewrite <- LE, mul_0_r in E. rewrite E in LT. destruct (nlt_0_r _ LT). -- rewrite <- add_succ_l. - rewrite <- add_0_l at 1. - rewrite <- add_lt_mono_r. - apply lt_0_succ. -Qed. - - -(*****************************************************) -(** Power *) - -Definition pow (n m : N.t) := recursion 1 (fun _ r => n*r) m. - -Local Infix "^^" := pow (at level 30, right associativity). - -#[global] -Instance pow_wd : Proper (N.eq==>N.eq==>N.eq) pow. -Proof. -unfold pow. f_equiv'. -Qed. - -Lemma pow_0 : forall n, n^^0 == 1. -Proof. -intros. unfold pow. rewrite recursion_0. auto with *. -Qed. - -Lemma pow_succ : forall n m, n^^(S m) == n*(n^^m). -Proof. -intros. unfold pow. rewrite recursion_succ; f_equiv'. -Qed. - - -(*****************************************************) -(** Logarithm for the base 2 *) - -Definition log (x : N.t) : N.t := -strong_rec 0 - (fun g x => - if x << 2 then 0 - else S (g (half x))) - x. - -#[global] -Instance log_prewd : - Proper ((N.eq==>N.eq)==>N.eq==>N.eq) - (fun g x => if x<<2 then 0 else S (g (half x))). -Proof. -intros g g' Hg n n' Hn. -rewrite Hn. -destruct (n' << 2); auto with *. -f_equiv. apply Hg. now f_equiv. -Qed. - -#[global] -Instance log_wd : Proper (N.eq==>N.eq) log. -Proof. -intros x x' Exx'. unfold log. -apply strong_rec_wd; f_equiv'. -Qed. - -Lemma log_good_step : forall n h1 h2, - (forall m, m < n -> h1 m == h2 m) -> - (if n << 2 then 0 else S (h1 (half n))) == - (if n << 2 then 0 else S (h2 (half n))). -Proof. -intros n h1 h2 E. -destruct (n<<2) eqn:H. -- auto with *. -- f_equiv. apply E, half_decrease. - rewrite two_succ, <- not_true_iff_false, ltb_lt, nlt_ge, le_succ_l in H. - order'. -Qed. -#[global] -Hint Resolve log_good_step : core. - -Theorem log_init : forall n, n < 2 -> log n == 0. -Proof. -intros n Hn. unfold log. rewrite strong_rec_fixpoint; auto with *. -replace (n << 2) with true; auto with *. -symmetry. now rewrite ltb_lt. -Qed. - -Theorem log_step : forall n, 2 <= n -> log n == S (log (half n)). -Proof. -intros n Hn. unfold log. rewrite strong_rec_fixpoint; auto with *. -replace (n << 2) with false; auto with *. -symmetry. rewrite <- not_true_iff_false, ltb_lt, nlt_ge; auto. -Qed. - -Theorem pow2_log : forall n, 0 < n -> half n < 2^^(log n) <= n. -Proof. -intro n; generalize (le_refl n). set (k:=n) at -2. clearbody k. -revert k. pattern n. apply induction; clear n. -- intros n n' Hn; setoid_rewrite Hn; auto with *. -- intros k Hk1 Hk2. - le_elim Hk1. - + destruct (nlt_0_r _ Hk1). - + rewrite Hk1 in Hk2. destruct (nlt_0_r _ Hk2). - -- intros n IH k Hk1 Hk2. - destruct (lt_ge_cases k 2) as [LT|LE]. - + (* base *) - rewrite log_init, pow_0 by auto. - rewrite <- le_succ_l, <- one_succ in Hk2. - le_elim Hk2. - * rewrite two_succ, <- nle_gt, le_succ_l in LT. destruct LT; auto. - * rewrite <- Hk2. - rewrite half_1; auto using lt_0_1, le_refl. - + (* step *) - rewrite log_step, pow_succ by auto. - rewrite two_succ, le_succ_l in LE. - destruct (IH (half k)) as (IH1,IH2). - * rewrite <- lt_succ_r. apply lt_le_trans with k; auto. - now apply half_decrease. - * apply half_nz; auto. - * set (K:=2^^log (half k)) in *; clearbody K. - split. - -- rewrite <- le_succ_l in IH1. - apply mul_le_mono_l with (p:=2) in IH1. - eapply lt_le_trans; eauto. - nzsimpl'. - rewrite lt_succ_r. - eapply le_trans; [ eapply half_lower_bound | ]. - nzsimpl'; apply le_refl. - -- eapply le_trans; [ | eapply half_upper_bound ]. - apply mul_le_mono_l; auto. -Qed. - -End NdefOpsProp. diff --git a/stdlib/theories/Numbers/Natural/Abstract/NDiv.v b/stdlib/theories/Numbers/Natural/Abstract/NDiv.v deleted file mode 100644 index df4f9a57444b..000000000000 --- a/stdlib/theories/Numbers/Natural/Abstract/NDiv.v +++ /dev/null @@ -1,258 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* a mod b < b. -Proof. intros. apply mod_bound_pos; auto'. Qed. - -(** Another formulation of the main equation *) - -Lemma mod_eq : - forall a b, b~=0 -> a mod b == a - b*(a/b). -Proof. -intros. -symmetry. apply add_sub_eq_l. symmetry. -now apply div_mod. -Qed. - -(** Uniqueness theorems *) - -Theorem div_mod_unique : - forall b q1 q2 r1 r2, r1 r2 - b*q1+r1 == b*q2+r2 -> q1 == q2 /\ r1 == r2. -Proof. intros b q1 q2 r1 r2 ? ? ?. apply div_mod_unique with b; auto'. Qed. - -Theorem div_unique: - forall a b q r, r a == b*q + r -> q == a/b. -Proof. intros a b q r ? ?; apply div_unique with r; auto'. Qed. - -Theorem mod_unique: - forall a b q r, r a == b*q + r -> r == a mod b. -Proof. intros a b q r ? ?. apply mod_unique with q; auto'. Qed. - -Theorem div_unique_exact: forall a b q, b~=0 -> a == b*q -> q == a/b. -Proof. intros. apply div_unique_exact; auto'. Qed. - -(** A division by itself returns 1 *) - -Lemma div_same : forall a, a~=0 -> a/a == 1. -Proof. intros. apply div_same; auto'. Qed. - -Lemma mod_same : forall a, a~=0 -> a mod a == 0. -Proof. intros. apply mod_same; auto'. Qed. - -(** A division of a small number by a bigger one yields zero. *) - -Theorem div_small: forall a b, a a/b == 0. -Proof. intros. apply div_small; auto'. Qed. - -(** Same situation, in term of modulo: *) - -Theorem mod_small: forall a b, a a mod b == a. -Proof. intros. apply mod_small; auto'. Qed. - -(** * Basic values of divisions and modulo. *) - -Lemma div_0_l: forall a, a~=0 -> 0/a == 0. -Proof. intros. apply div_0_l; auto'. Qed. - -Lemma mod_0_l: forall a, a~=0 -> 0 mod a == 0. -Proof. intros. apply mod_0_l; auto'. Qed. - -Lemma div_1_r: forall a, a/1 == a. -Proof. intros. apply div_1_r; auto'. Qed. - -Lemma mod_1_r: forall a, a mod 1 == 0. -Proof. intros. apply mod_1_r; auto'. Qed. - -Lemma div_1_l: forall a, 1 1/a == 0. -Proof. exact div_1_l. Qed. - -Lemma mod_1_l: forall a, 1 1 mod a == 1. -Proof. exact mod_1_l. Qed. - -Lemma div_mul : forall a b, b~=0 -> (a*b)/b == a. -Proof. intros. apply div_mul; auto'. Qed. - -Lemma mod_mul : forall a b, b~=0 -> (a*b) mod b == 0. -Proof. intros. apply mod_mul; auto'. Qed. - - -(** * Order results about mod and div *) - -(** A modulo cannot grow beyond its starting point. *) - -Theorem mod_le: forall a b, b~=0 -> a mod b <= a. -Proof. intros. apply mod_le; auto'. Qed. - -Lemma div_str_pos : forall a b, 0 0 < a/b. -Proof. exact div_str_pos. Qed. - -Lemma div_small_iff : forall a b, b~=0 -> (a/b==0 <-> a (a mod b == a <-> a (0 b<=a). -Proof. intros. apply div_str_pos_iff; auto'. Qed. - - -(** As soon as the divisor is strictly greater than 1, - the division is strictly decreasing. *) - -Lemma div_lt : forall a b, 0 1 a/b < a. -Proof. exact div_lt. Qed. - -(** [le] is compatible with a positive division. *) - -Lemma div_le_mono : forall a b c, c~=0 -> a<=b -> a/c <= b/c. -Proof. intros. apply div_le_mono; auto'. Qed. - -Lemma mul_div_le : forall a b, b~=0 -> b*(a/b) <= a. -Proof. intros. apply mul_div_le; auto'. Qed. - -Lemma mul_succ_div_gt: forall a b, b~=0 -> a < b*(S (a/b)). -Proof. intros; apply mul_succ_div_gt; auto'. Qed. - -(** The previous inequality is exact iff the modulo is zero. *) - -Lemma div_exact : forall a b, b~=0 -> (a == b*(a/b) <-> a mod b == 0). -Proof. intros. apply div_exact; auto'. Qed. - -(** Some additional inequalities about div. *) - -Theorem div_lt_upper_bound: - forall a b q, b~=0 -> a < b*q -> a/b < q. -Proof. intros. apply div_lt_upper_bound; auto'. Qed. - -Theorem div_le_upper_bound: - forall a b q, b~=0 -> a <= b*q -> a/b <= q. -Proof. intros; apply div_le_upper_bound; auto'. Qed. - -Theorem div_le_lower_bound: - forall a b q, b~=0 -> b*q <= a -> q <= a/b. -Proof. intros; apply div_le_lower_bound; auto'. Qed. - -(** A division respects opposite monotonicity for the divisor *) - -Lemma div_le_compat_l: forall p q r, 0 p/r <= p/q. -Proof. intros. apply div_le_compat_l;[auto' | auto]. Qed. - -(** * Relations between usual operations and mod and div *) - -Lemma mod_add : forall a b c, c~=0 -> - (a + b * c) mod c == a mod c. -Proof. intros. apply mod_add; auto'. Qed. - -Lemma div_add : forall a b c, c~=0 -> - (a + b * c) / c == a / c + b. -Proof. intros. apply div_add; auto'. Qed. - -Lemma div_add_l: forall a b c, b~=0 -> - (a * b + c) / b == a + c / b. -Proof. intros. apply div_add_l; auto'. Qed. - -(** Cancellations. *) - -Lemma div_mul_cancel_r : forall a b c, b~=0 -> c~=0 -> - (a*c)/(b*c) == a/b. -Proof. intros. apply div_mul_cancel_r; auto'. Qed. - -Lemma div_mul_cancel_l : forall a b c, b~=0 -> c~=0 -> - (c*a)/(c*b) == a/b. -Proof. intros. apply div_mul_cancel_l; auto'. Qed. - -Lemma mul_mod_distr_r: forall a b c, b~=0 -> c~=0 -> - (a*c) mod (b*c) == (a mod b) * c. -Proof. intros. apply mul_mod_distr_r; auto'. Qed. - -Lemma mul_mod_distr_l: forall a b c, b~=0 -> c~=0 -> - (c*a) mod (c*b) == c * (a mod b). -Proof. intros. apply mul_mod_distr_l; auto'. Qed. - -(** Operations modulo. *) - -Theorem mod_mod: forall a n, n~=0 -> - (a mod n) mod n == a mod n. -Proof. intros. apply mod_mod; auto'. Qed. - -Lemma mul_mod_idemp_l : forall a b n, n~=0 -> - ((a mod n)*b) mod n == (a*b) mod n. -Proof. intros. apply mul_mod_idemp_l; auto'. Qed. - -Lemma mul_mod_idemp_r : forall a b n, n~=0 -> - (a*(b mod n)) mod n == (a*b) mod n. -Proof. intros. apply mul_mod_idemp_r; auto'. Qed. - -Theorem mul_mod: forall a b n, n~=0 -> - (a * b) mod n == ((a mod n) * (b mod n)) mod n. -Proof. intros. apply mul_mod; auto'. Qed. - -Lemma add_mod_idemp_l : forall a b n, n~=0 -> - ((a mod n)+b) mod n == (a+b) mod n. -Proof. intros. apply add_mod_idemp_l; auto'. Qed. - -Lemma add_mod_idemp_r : forall a b n, n~=0 -> - (a+(b mod n)) mod n == (a+b) mod n. -Proof. intros. apply add_mod_idemp_r; auto'. Qed. - -Theorem add_mod: forall a b n, n~=0 -> - (a+b) mod n == (a mod n + b mod n) mod n. -Proof. intros. apply add_mod; auto'. Qed. - -Lemma div_div : forall a b c, b~=0 -> c~=0 -> - (a/b)/c == a/(b*c). -Proof. intros. apply div_div; auto'. Qed. - -Lemma mod_mul_r : forall a b c, b~=0 -> c~=0 -> - a mod (b*c) == a mod b + b*((a/b) mod c). -Proof. intros. apply mod_mul_r; auto'. Qed. - -Lemma add_mul_mod_distr_l : forall a b c d, b~=0 -> 0<=d - (c*a+d) mod (c*b) == c*(a mod b)+d. -Proof. - intros a b c d Hb ?. apply add_mul_mod_distr_l. - - apply le_0_l. - - assert (H'b := le_0_l b). order. - - assumption. -Qed. - -Lemma add_mul_mod_distr_r : forall a b c d, b~=0 -> 0<=d - (a*c+d) mod (b*c) == (a mod b)*c+d. -Proof. - intros a b c d ? ?. now rewrite !(mul_comm _ c), add_mul_mod_distr_l. -Qed. - -(** A last inequality: *) - -Theorem div_mul_le: - forall a b c, b~=0 -> c*(a/b) <= (c*a)/b. -Proof. intros. apply div_mul_le; auto'. Qed. - -(** mod is related to divisibility *) - -Lemma mod_divides : forall a b, b~=0 -> - (a mod b == 0 <-> exists c, a == b*c). -Proof. intros. apply mod_divides; auto'. Qed. - -End NDivProp. diff --git a/stdlib/theories/Numbers/Natural/Abstract/NDiv0.v b/stdlib/theories/Numbers/Natural/Abstract/NDiv0.v deleted file mode 100644 index edf304fc2f2b..000000000000 --- a/stdlib/theories/Numbers/Natural/Abstract/NDiv0.v +++ /dev/null @@ -1,340 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* |Ha]. - - apply div_0_r. - - now apply div_0_l. -Qed. - -Lemma mod_0_l : forall a, 0 mod a == 0. -Proof. - intros a. destruct (eq_decidable a 0) as [->|Hb]. - - apply mod_0_r. - - now apply mod_0_l. -Qed. - -#[local] Hint Rewrite div_0_l mod_0_l div_0_r mod_0_r : nz. - -Lemma div_mod : forall a b, a == b*(a/b) + (a mod b). -Proof. - intros a b. destruct (eq_decidable b 0) as [->|Hb]. - - now nzsimpl. - - now apply div_mod. -Qed. - -Lemma mod_eq : forall a b, a mod b == a - b*(a/b). -Proof. - intros a b. destruct (eq_decidable b 0) as [->|Hb]. - - now nzsimpl. - - now apply mod_eq. -Qed. - -Lemma mod_same : forall a, a mod a == 0. -Proof. - intros a. destruct (eq_decidable a 0) as [->|Ha]. - - now nzsimpl. - - now apply mod_same. -Qed. - -Lemma mod_mul : forall a b, (a*b) mod b == 0. -Proof. - intros a b. destruct (eq_decidable b 0) as [->|Hb]. - - now nzsimpl. - - now apply mod_mul. -Qed. - -Lemma mod_le : forall a b, a mod b <= a. -Proof. - intros a b. destruct (eq_decidable b 0) as [->|Hb]. - - now nzsimpl. - - now apply mod_le. -Qed. - -Lemma div_le_mono : forall a b c, a<=b -> a/c <= b/c. -Proof. - intros a b c. destruct (eq_decidable c 0) as [->|Hc]. - - now nzsimpl. - - now apply div_le_mono. -Qed. - -Lemma mul_div_le : forall a b, b*(a/b) <= a. -Proof. - intros a b. destruct (eq_decidable b 0) as [->|Hb]. - - nzsimpl. apply le_0_l. - - now apply mul_div_le. -Qed. - -Lemma div_exact : forall a b, (a == b*(a/b) <-> a mod b == 0). -Proof. - intros a b. destruct (eq_decidable b 0) as [->|Hb]. - - now nzsimpl. - - now apply div_exact. -Qed. - -Lemma div_lt_upper_bound : forall a b q, a < b*q -> a/b < q. -Proof. - intros a b q. destruct (eq_decidable b 0) as [->|Hb]. - - nzsimpl. now intros ?%nlt_0_r. - - now apply div_lt_upper_bound. -Qed. - -Lemma div_le_upper_bound : forall a b q, a <= b*q -> a/b <= q. -Proof. - intros a b c. destruct (eq_decidable b 0) as [->|Hb]. - - nzsimpl. intros. apply le_0_l. - - now apply div_le_upper_bound. -Qed. - -Lemma mod_add : forall a b c, (a + b * c) mod c == a mod c. -Proof. - intros a b c. destruct (eq_decidable c 0) as [->|Hc]. - - now nzsimpl. - - now apply mod_add. -Qed. - -Lemma div_mul_cancel_r : forall a b c, c~=0 -> (a*c)/(b*c) == a/b. -Proof. - intros a b c. destruct (eq_decidable b 0) as [->|Hb]. - - now nzsimpl. - - now apply div_mul_cancel_r. -Qed. - -Lemma div_mul_cancel_l : forall a b c, c~=0 -> (c*a)/(c*b) == a/b. -Proof. - intros a b c. destruct (eq_decidable b 0) as [->|Hb]. - - now nzsimpl. - - now apply div_mul_cancel_l. -Qed. - -Lemma mul_mod_distr_r : forall a b c, (a*c) mod (b*c) == (a mod b) * c. -Proof. - intros a b c. destruct (eq_decidable b 0) as [->|Hb]. - - now nzsimpl. - - destruct (eq_decidable c 0) as [->|Hc]. - + now nzsimpl. - + now apply mul_mod_distr_r. -Qed. - -Lemma mul_mod_distr_l : forall a b c, (c*a) mod (c*b) == c * (a mod b). -Proof. - intros a b c. destruct (eq_decidable b 0) as [->|Hb]. - - now nzsimpl. - - destruct (eq_decidable c 0) as [->|Hc]. - + now nzsimpl. - + now apply mul_mod_distr_l. -Qed. - -Lemma mod_mod : forall a n, (a mod n) mod n == a mod n. -Proof. - intros a n. destruct (eq_decidable n 0) as [->|Hn]. - - now nzsimpl. - - now apply mod_mod. -Qed. - -Lemma mul_mod_idemp_l : forall a b n, ((a mod n)*b) mod n == (a*b) mod n. -Proof. - intros a b n. destruct (eq_decidable n 0) as [->|Hn]. - - now nzsimpl. - - now apply mul_mod_idemp_l. -Qed. - -Lemma mul_mod_idemp_r : forall a b n, (a*(b mod n)) mod n == (a*b) mod n. -Proof. - intros a b n. destruct (eq_decidable n 0) as [->|Hn]. - - now nzsimpl. - - now apply mul_mod_idemp_r. -Qed. - -Lemma mul_mod : forall a b n, (a * b) mod n == ((a mod n) * (b mod n)) mod n. -Proof. - intros a b n. destruct (eq_decidable n 0) as [->|Hn]. - - now nzsimpl. - - now apply mul_mod. -Qed. - -Lemma add_mod_idemp_l : forall a b n, ((a mod n)+b) mod n == (a+b) mod n. -Proof. - intros a b n. destruct (eq_decidable n 0) as [->|Hn]. - - now nzsimpl. - - now apply add_mod_idemp_l. -Qed. - -Lemma add_mod_idemp_r : forall a b n, (a+(b mod n)) mod n == (a+b) mod n. -Proof. - intros a b n. destruct (eq_decidable n 0) as [->|Hn]. - - now nzsimpl. - - now apply add_mod_idemp_r. -Qed. - -Lemma add_mod : forall a b n, (a+b) mod n == (a mod n + b mod n) mod n. -Proof. - intros a b n. destruct (eq_decidable n 0) as [->|Hn]. - - now nzsimpl. - - now apply add_mod. -Qed. - -Lemma div_div : forall a b c, (a/b)/c == a/(b*c). -Proof. - intros a b c. destruct (eq_decidable b 0) as [->|Hb]. - - now nzsimpl. - - destruct (eq_decidable c 0) as [->|Hc]. - + now nzsimpl. - + now apply div_div. -Qed. - -Lemma mod_mul_r : forall a b c, a mod (b*c) == a mod b + b*((a/b) mod c). -Proof. - intros a b c. destruct (eq_decidable b 0) as [->|Hb]. - - now nzsimpl. - - destruct (eq_decidable c 0) as [->|Hc]. - + nzsimpl. rewrite add_comm. apply div_mod. - + now apply mod_mul_r. -Qed. - -Lemma add_mul_mod_distr_l : forall a b c d, d (c*a+d) mod (c*b) == c*(a mod b)+d. -Proof. - intros a b c d ?. destruct (eq_decidable b 0) as [->|Hb]. - - now nzsimpl. - - apply add_mul_mod_distr_l; intuition auto using le_0_l. -Qed. - -Lemma add_mul_mod_distr_r : forall a b c d, d (a*c+d) mod (b*c) == (a mod b)*c+d. -Proof. - intros a b c d ?. destruct (eq_decidable b 0) as [->|Hb]. - - now nzsimpl. - - apply add_mul_mod_distr_r; intuition auto using le_0_l. -Qed. - -Lemma div_mul_le : forall a b c, c*(a/b) <= (c*a)/b. -Proof. - intros a b c. destruct (eq_decidable b 0) as [->|Hb]. - - now nzsimpl. - - now apply div_mul_le. -Qed. - -Lemma mod_divides : forall a b, (a mod b == 0 <-> exists c, a == b*c). -Proof. - intros a b. destruct (eq_decidable b 0) as [Hb|Hb]. - - split. - + intros Hab. exists 0. revert Hab. rewrite Hb. now nzsimpl. - + intros [c Hc]. revert Hc. rewrite Hb. now nzsimpl. - - now apply mod_divides. -Qed. - -End Div0. - -(** Unchanged theorems. *) - -Definition mod_upper_bound := mod_upper_bound. -Definition div_mod_unique := div_mod_unique. -Definition div_unique := div_unique. -Definition mod_unique := mod_unique. -Definition div_unique_exact := div_unique_exact. -Definition div_same := div_same. -Definition div_small := div_small. -Definition mod_small := mod_small. -Definition div_1_r := div_1_r. -Definition mod_1_r := mod_1_r. -Definition div_1_l := div_1_l. -Definition mod_1_l := mod_1_l. -Definition div_mul := div_mul. -Definition div_str_pos := div_str_pos. -Definition div_small_iff := div_small_iff. -Definition mod_small_iff := mod_small_iff. -Definition div_str_pos_iff := div_str_pos_iff. -Definition div_lt := div_lt. -Definition mul_succ_div_gt := mul_succ_div_gt. -Definition div_le_lower_bound := div_le_lower_bound. -Definition div_le_compat_l := div_le_compat_l. -Definition div_add := div_add. -Definition div_add_l := div_add_l. - -(** Deprecation statements. - After deprecation phase, remove statements below - in favor of Div0 statements. *) - -#[deprecated(since="8.17",note="Use Div0.mod_eq instead.")] -Notation mod_eq := mod_eq (only parsing). -#[deprecated(since="8.17",note="Use Div0.mod_same instead.")] -Notation mod_same := mod_same (only parsing). -#[deprecated(since="8.17",note="Use Div0.div_0_l instead.")] -Notation div_0_l := div_0_l (only parsing). -#[deprecated(since="8.17",note="Use Div0.mod_0_l instead.")] -Notation mod_0_l := mod_0_l (only parsing). -#[deprecated(since="8.17",note="Use Div0.mod_mul instead.")] -Notation mod_mul := mod_mul (only parsing). -#[deprecated(since="8.17",note="Use Div0.mod_le instead.")] -Notation mod_le := mod_le (only parsing). -#[deprecated(since="8.17",note="Use Div0.div_le_mono instead.")] -Notation div_le_mono := div_le_mono (only parsing). -#[deprecated(since="8.17",note="Use Div0.mul_div_le instead.")] -Notation mul_div_le := mul_div_le (only parsing). -#[deprecated(since="8.17",note="Use Div0.div_exact instead.")] -Notation div_exact := div_exact (only parsing). -#[deprecated(since="8.17",note="Use Div0.div_lt_upper_bound instead.")] -Notation div_lt_upper_bound := div_lt_upper_bound (only parsing). -#[deprecated(since="8.17",note="Use Div0.div_le_upper_bound instead.")] -Notation div_le_upper_bound := div_le_upper_bound (only parsing). -#[deprecated(since="8.17",note="Use Div0.mod_add instead.")] -Notation mod_add := mod_add (only parsing). -#[deprecated(since="8.17",note="Use Div0.div_mul_cancel_r instead.")] -Notation div_mul_cancel_r := div_mul_cancel_r (only parsing). -#[deprecated(since="8.17",note="Use Div0.div_mul_cancel_l instead.")] -Notation div_mul_cancel_l := div_mul_cancel_l (only parsing). -#[deprecated(since="8.17",note="Use Div0.mul_mod_distr_r instead.")] -Notation mul_mod_distr_r := mul_mod_distr_r (only parsing). -#[deprecated(since="8.17",note="Use Div0.mul_mod_distr_l instead.")] -Notation mul_mod_distr_l := mul_mod_distr_l (only parsing). -#[deprecated(since="8.17",note="Use Div0.mod_mod instead.")] -Notation mod_mod := mod_mod (only parsing). -#[deprecated(since="8.17",note="Use Div0.mul_mod_idemp_l instead.")] -Notation mul_mod_idemp_l := mul_mod_idemp_l (only parsing). -#[deprecated(since="8.17",note="Use Div0.mul_mod_idemp_r instead.")] -Notation mul_mod_idemp_r := mul_mod_idemp_r (only parsing). -#[deprecated(since="8.17",note="Use Div0.mul_mod instead.")] -Notation mul_mod := mul_mod (only parsing). -#[deprecated(since="8.17",note="Use Div0.add_mod_idemp_l instead.")] -Notation add_mod_idemp_l := add_mod_idemp_l (only parsing). -#[deprecated(since="8.17",note="Use Div0.add_mod_idemp_r instead.")] -Notation add_mod_idemp_r := add_mod_idemp_r (only parsing). -#[deprecated(since="8.17",note="Use Div0.add_mod instead.")] -Notation add_mod := add_mod (only parsing). -#[deprecated(since="8.17",note="Use Div0.div_div instead.")] -Notation div_div := div_div (only parsing). -#[deprecated(since="8.17",note="Use Div0.mod_mul_r instead.")] -Notation mod_mul_r := mod_mul_r (only parsing). -#[deprecated(since="8.17",note="Use Div0.div_mul_le instead.")] -Notation div_mul_le := div_mul_le (only parsing). -#[deprecated(since="8.17",note="Use Div0.mod_divides instead.")] -Notation mod_divides := mod_divides (only parsing). - -End NDivProp0. diff --git a/stdlib/theories/Numbers/Natural/Abstract/NGcd.v b/stdlib/theories/Numbers/Natural/Abstract/NGcd.v deleted file mode 100644 index e0bad3e32cd2..000000000000 --- a/stdlib/theories/Numbers/Natural/Abstract/NGcd.v +++ /dev/null @@ -1,260 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* eq==>iff) divide := divide_wd. -Definition divide_1_r n := divide_1_r_nonneg n (le_0_l n). -Definition divide_1_l := divide_1_l. -Definition divide_0_r := divide_0_r. -Definition divide_0_l := divide_0_l. -Definition divide_refl := divide_refl. -Definition divide_trans := divide_trans. -#[global] Instance divide_reflexive : Reflexive divide | 5 := divide_refl. -#[global] Instance divide_transitive : Transitive divide | 5 := divide_trans. -Definition divide_antisym n m := divide_antisym_nonneg n m (le_0_l n) (le_0_l m). -Definition mul_divide_mono_l := mul_divide_mono_l. -Definition mul_divide_mono_r := mul_divide_mono_r. -Definition mul_divide_cancel_l := mul_divide_cancel_l. -Definition mul_divide_cancel_r := mul_divide_cancel_r. -Definition divide_add_r := divide_add_r. -Definition divide_mul_l := divide_mul_l. -Definition divide_mul_r := divide_mul_r. -Definition divide_factor_l := divide_factor_l. -Definition divide_factor_r := divide_factor_r. -Definition divide_pos_le := divide_pos_le. - -(** Properties of gcd *) - -Definition gcd_0_l n : gcd 0 n == n := gcd_0_l_nonneg n (le_0_l n). -Definition gcd_0_r n : gcd n 0 == n := gcd_0_r_nonneg n (le_0_l n). -Definition gcd_diag n : gcd n n == n := gcd_diag_nonneg n (le_0_l n). -Definition gcd_unique n m p := gcd_unique n m p (le_0_l p). -Definition gcd_unique_alt n m p := gcd_unique_alt n m p (le_0_l p). -Definition divide_gcd_iff n m := divide_gcd_iff n m (le_0_l n). -#[global] Instance gcd_wd : Proper (eq==>eq==>eq) gcd := gcd_wd. -Definition gcd_comm := gcd_comm. -Definition gcd_assoc := gcd_assoc. -Definition gcd_eq_0_l := gcd_eq_0_l. -Definition gcd_eq_0_r := gcd_eq_0_r. -Definition gcd_eq_0 := gcd_eq_0. -Definition gcd_mul_diag_l n m := gcd_mul_diag_l n m (le_0_l n). - -#[deprecated(since="8.17",note="Use divide_antisym instead.")] -Notation divide_antisym_nonneg := divide_antisym_nonneg (only parsing). -#[deprecated(since="8.17",note="Use gcd_unique instead.")] -Notation gcd_unique' n m p := gcd_unique (only parsing). -#[deprecated(since="8.17",note="Use gcd_unique_alt instead.")] -Notation gcd_unique_alt' := gcd_unique_alt. -#[deprecated(since="8.17",note="Use divide_gcd_iff instead.")] -Notation divide_gcd_iff' := divide_gcd_iff. - -Lemma divide_add_cancel_r : forall n m p, (n | m) -> (n | m + p) -> (n | p). -Proof. - intros n m p (q,Hq) (r,Hr). - exists (r-q). rewrite mul_sub_distr_r, <- Hq, <- Hr. - now rewrite add_comm, add_sub. -Qed. - -Lemma divide_sub_r : forall n m p, (n | m) -> (n | p) -> (n | m - p). -Proof. - intros n m p H H'. - destruct (le_ge_cases m p) as [LE|LE]. - - apply sub_0_le in LE. rewrite LE. apply divide_0_r. - - apply divide_add_cancel_r with p; trivial. - now rewrite add_comm, sub_add. -Qed. - -Lemma gcd_add_mult_diag_r : forall n m p, gcd n (m+p*n) == gcd n m. -Proof. - intros n m p. apply gcd_unique_alt. - intros. rewrite gcd_divide_iff. split; intros (U,V); split; trivial. - - apply divide_add_r; trivial. now apply divide_mul_r. - - apply divide_add_cancel_r with (p*n); trivial. - + now apply divide_mul_r. - + now rewrite add_comm. -Qed. - -Lemma gcd_add_diag_r : forall n m, gcd n (m+n) == gcd n m. -Proof. - intros n m. rewrite <- (mul_1_l n) at 2. apply gcd_add_mult_diag_r. -Qed. - -Lemma gcd_sub_diag_r : forall n m, n<=m -> gcd n (m-n) == gcd n m. -Proof. - intros n m H. symmetry. - rewrite <- (sub_add n m H) at 1. apply gcd_add_diag_r. -Qed. - -(** On natural numbers, we should use a particular form - for the Bezout identity, since we don't have full subtraction. *) - -Definition Bezout n m p := exists a b, a*n == p + b*m. - -#[global] -Instance Bezout_wd : Proper (eq==>eq==>eq==>iff) Bezout. -Proof. - unfold Bezout. intros x x' Hx y y' Hy z z' Hz. - setoid_rewrite Hx. setoid_rewrite Hy. now setoid_rewrite Hz. -Qed. - -Lemma bezout_1_gcd : forall n m, Bezout n m 1 -> gcd n m == 1. -Proof. - intros n m (q & r & H). - apply gcd_unique; trivial using divide_1_l, le_0_1. - intros p Hn Hm. - apply divide_add_cancel_r with (r*m). - - now apply divide_mul_r. - - rewrite add_comm, <- H. now apply divide_mul_r. -Qed. - -(** Bezout on natural numbers commutes *) - -Theorem bezout_comm : forall a b g, - b ~= 0 -> Bezout a b g -> Bezout b a g. -Proof. - intros a b g Hb [p [q Hpq]]. - destruct (eq_decidable a 0) as [Ha|Ha]. - { exists 0, 0. symmetry in Hpq. - rewrite Ha, mul_0_r in Hpq. - apply eq_add_0 in Hpq as [-> _]. - now nzsimpl. } - exists (a*(p+1)*(q+1)-q), (b*(p+1)*(q+1)-p). - enough (E' : (a*(p+1)*(q+1)-q+q)*b == (b*(p+1)*(q+1)-p+p)*a). - { rewrite (mul_add_distr_r _ _ a), (mul_add_distr_r _ _ b), Hpq in E'. - rewrite add_assoc, (add_comm _ g) in E'. - now apply add_cancel_r in E'. } - rewrite !sub_add. - - now rewrite !(mul_comm _ b), !mul_assoc, !(mul_comm _ a), !mul_assoc. - - rewrite <- mul_1_r at 1. apply mul_le_mono; [|apply le_add_l]. - rewrite <- mul_1_l at 1. apply mul_le_mono; [|apply le_add_r]. - rewrite one_succ. apply le_succ_l. assert (H := le_0_l b). order. - - rewrite <- mul_1_l at 1. apply mul_le_mono; [|apply le_add_r]. - rewrite <- mul_1_l at 1. apply mul_le_mono; [|apply le_add_l]. - rewrite one_succ. apply le_succ_l. assert (H := le_0_l a). order. -Qed. - -Lemma gcd_bezout_pos : forall n m, 0 < n -> Bezout n m (gcd n m). -Proof. - enough (H : forall nm, 0 < fst nm -> Bezout (fst nm) (snd nm) (gcd (fst nm) (snd nm))). - { intros n m. apply (H (n, m)). } - intros nm. - induction nm as [[n m] IH] using (measure_induction _ (fun '(n, m) => n + m)). - enough (H : forall n' m', n+m == n'+m' -> 0 Bezout n' m' (gcd n' m')). - { cbn. intros ?. destruct (lt_trichotomy n m) as [Hnm|[Hnm|Hnm]]. - - now apply H. - - exists 1, 0. now rewrite Hnm, mul_1_l, mul_0_l, add_0_r, gcd_diag. - - destruct (eq_0_gt_0_cases m) as [->|?]. - + exists 1, 0. now rewrite gcd_0_r, mul_1_l, mul_0_l, add_0_r. - + apply bezout_comm; [order|]. - rewrite gcd_comm. now apply H; [apply add_comm|]. } - intros n' m' E' [Hn' Hn'm']. - assert (Hlt : n' + (m' - n') < n + m). - { rewrite (add_comm n'), E', sub_add by order. - now apply lt_add_pos_l. } - destruct (IH (n', m'-n') Hlt Hn') as [a [b Hab]]. - cbn in Hab. exists (a+b), b. - rewrite mul_add_distr_r, Hab, mul_sub_distr_l, gcd_sub_diag_r by order. - now rewrite <- add_assoc, sub_add by (apply mul_le_mono_l; order). -Qed. - -(** For strictly positive numbers, we have Bezout in the two directions. *) - -Lemma gcd_bezout_pos_pos : forall n, 0 forall m, 0 - Bezout n m (gcd n m) /\ Bezout m n (gcd n m). -Proof. - intros ????. split; [|rewrite gcd_comm]; now apply gcd_bezout_pos. -Qed. - -(** For arbitrary natural numbers, we could only say that at least - one of the Bezout identities holds. *) - -Lemma gcd_bezout : forall n m, - Bezout n m (gcd n m) \/ Bezout m n (gcd n m). -Proof. - intros n m. - destruct (eq_0_gt_0_cases n) as [EQ|LT]. - - right. rewrite EQ, gcd_0_l. exists 1. exists 0. now nzsimpl. - - left. now apply gcd_bezout_pos. -Qed. - -Lemma gcd_mul_mono_l : - forall n m p, gcd (p * n) (p * m) == p * gcd n m. -Proof. - intros n m p. apply gcd_unique. - - apply mul_divide_mono_l, gcd_divide_l. - - apply mul_divide_mono_l, gcd_divide_r. - - intros q H H'. - destruct (eq_0_gt_0_cases n) as [EQ|LT]. - + rewrite EQ in *. now rewrite gcd_0_l. - + destruct (gcd_bezout_pos n m) as (a & b & EQ); trivial. - apply divide_add_cancel_r with (p*m*b). - * now apply divide_mul_l. - * rewrite <- mul_assoc, <- mul_add_distr_l, add_comm, (mul_comm m), <- EQ. - rewrite (mul_comm a), mul_assoc. - now apply divide_mul_l. -Qed. - -Lemma gcd_mul_mono_r : - forall n m p, gcd (n*p) (m*p) == gcd n m * p. -Proof. - intros n m p. rewrite !(mul_comm _ p). apply gcd_mul_mono_l. -Qed. - -Lemma gauss : forall n m p, (n | m * p) -> gcd n m == 1 -> (n | p). -Proof. - intros n m p H G. - destruct (eq_0_gt_0_cases n) as [EQ|LT]. - - rewrite EQ in *. rewrite gcd_0_l in G. now rewrite <- (mul_1_l p), <- G. - - destruct (gcd_bezout_pos n m) as (a & b & EQ); trivial. - rewrite G in EQ. - apply divide_add_cancel_r with (m*p*b). - + now apply divide_mul_l. - + rewrite (mul_comm _ b), mul_assoc. rewrite <- (mul_1_l p) at 2. - rewrite <- mul_add_distr_r, add_comm, <- EQ. - now apply divide_mul_l, divide_factor_r. -Qed. - -Lemma divide_mul_split : forall n m p, n ~= 0 -> (n | m * p) -> - exists q r, n == q*r /\ (q | m) /\ (r | p). -Proof. - intros n m p Hn H. - assert (G := gcd_nonneg n m). le_elim G. - - destruct (gcd_divide_l n m) as (q,Hq). - exists (gcd n m). exists q. - split. - + now rewrite mul_comm. - + split. - * apply gcd_divide_r. - * destruct (gcd_divide_r n m) as (r,Hr). - rewrite Hr in H. rewrite Hq in H at 1. - rewrite mul_shuffle0 in H. apply mul_divide_cancel_r in H; [|order]. - apply gauss with r; trivial. - apply mul_cancel_r with (gcd n m); [order|]. - rewrite mul_1_l. - rewrite <- gcd_mul_mono_r, <- Hq, <- Hr; order. - - symmetry in G. apply gcd_eq_0 in G. destruct G as (Hn',_); order. -Qed. - -(** TODO : relation between gcd and division and modulo *) - -(** TODO : more about rel_prime (i.e. gcd == 1), about prime ... *) - -End NGcdProp. diff --git a/stdlib/theories/Numbers/Natural/Abstract/NIso.v b/stdlib/theories/Numbers/Natural/Abstract/NIso.v deleted file mode 100644 index aca615679477..000000000000 --- a/stdlib/theories/Numbers/Natural/Abstract/NIso.v +++ /dev/null @@ -1,103 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* N2.t) : Prop := - f N1.zero == N2.zero /\ forall n, f (N1.succ n) == N2.succ (f n). - -Definition natural_isomorphism : N1.t -> N2.t := - N1.recursion N2.zero (fun (n : N1.t) (p : N2.t) => N2.succ p). - -#[global] -Instance natural_isomorphism_wd : Proper (N1.eq ==> N2.eq) natural_isomorphism. -Proof. -unfold natural_isomorphism. -repeat red; intros. f_equiv; trivial. -repeat red; intros. now f_equiv. -Qed. - -Theorem natural_isomorphism_0 : natural_isomorphism N1.zero == N2.zero. -Proof. -unfold natural_isomorphism; now rewrite N1.recursion_0. -Qed. - -Theorem natural_isomorphism_succ : - forall n : N1.t, natural_isomorphism (N1.succ n) == N2.succ (natural_isomorphism n). -Proof. -unfold natural_isomorphism. -intro n. rewrite N1.recursion_succ; auto with *. -repeat red; intros. now f_equiv. -Qed. - -Theorem hom_nat_iso : homomorphism natural_isomorphism. -Proof. -unfold homomorphism, natural_isomorphism; split; -[exact natural_isomorphism_0 | exact natural_isomorphism_succ]. -Qed. - -End Homomorphism. - -Module Inverse (N1 N2 : NAxiomsRecSig). - -Module Import NBasePropMod1 := NBaseProp N1. -(* This makes the tactic induct available. Since it is taken from -(NBasePropFunct NAxiomsMod1), it refers to induction on N1. *) - -Module Hom12 := Homomorphism N1 N2. -Module Hom21 := Homomorphism N2 N1. - -Local Notation h12 := Hom12.natural_isomorphism. -Local Notation h21 := Hom21.natural_isomorphism. -Local Notation "n == m" := (N1.eq n m) (at level 70, no associativity). - -Lemma inverse_nat_iso : forall n : N1.t, h21 (h12 n) == n. -Proof. -induct n. -- now rewrite Hom12.natural_isomorphism_0, Hom21.natural_isomorphism_0. -- intros n IH. - now rewrite Hom12.natural_isomorphism_succ, Hom21.natural_isomorphism_succ, IH. -Qed. - -End Inverse. - -Module Isomorphism (N1 N2 : NAxiomsRecSig). - -Module Hom12 := Homomorphism N1 N2. -Module Hom21 := Homomorphism N2 N1. -Module Inverse12 := Inverse N1 N2. -Module Inverse21 := Inverse N2 N1. - -Local Notation h12 := Hom12.natural_isomorphism. -Local Notation h21 := Hom21.natural_isomorphism. - -Definition isomorphism (f1 : N1.t -> N2.t) (f2 : N2.t -> N1.t) : Prop := - Hom12.homomorphism f1 /\ Hom21.homomorphism f2 /\ - forall n, N1.eq (f2 (f1 n)) n /\ - forall n, N2.eq (f1 (f2 n)) n. - -Theorem iso_nat_iso : isomorphism h12 h21. -Proof. -unfold isomorphism. -split. { apply Hom12.hom_nat_iso. } -split. { apply Hom21.hom_nat_iso. } -split. { apply Inverse12.inverse_nat_iso. } -apply Inverse21.inverse_nat_iso. -Qed. - -End Isomorphism. diff --git a/stdlib/theories/Numbers/Natural/Abstract/NLcm.v b/stdlib/theories/Numbers/Natural/Abstract/NLcm.v deleted file mode 100644 index ce9b4a592696..000000000000 --- a/stdlib/theories/Numbers/Natural/Abstract/NLcm.v +++ /dev/null @@ -1,302 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* (a mod b == 0 <-> (b|a)). -Proof. - intros a b Hb. split. - - intros Hab. exists (a/b). rewrite mul_comm. - rewrite (div_mod a b Hb) at 1. rewrite Hab; now nzsimpl. - - intros (c,Hc). rewrite Hc. now apply mod_mul. -Qed. - -Lemma divide_div_mul_exact : forall a b c, b~=0 -> (b|a) -> - (c*a)/b == c*(a/b). -Proof. - intros a b c Hb H. - apply mul_cancel_l with b; trivial. - rewrite mul_assoc, mul_shuffle0. - assert (H':=H). apply mod_divide, div_exact in H'; trivial. - rewrite <- H', (mul_comm a c). - symmetry. apply div_exact; trivial. - apply mod_divide; trivial. - now apply divide_mul_r. -Qed. - -(** Gcd of divided elements, for exact divisions *) - -Lemma gcd_div_factor : forall a b c, c~=0 -> (c|a) -> (c|b) -> - gcd (a/c) (b/c) == (gcd a b)/c. -Proof. - intros a b c Hc Ha Hb. - apply mul_cancel_l with c; try order. - assert (H:=gcd_greatest _ _ _ Ha Hb). - apply mod_divide, div_exact in H; try order. - rewrite <- H. - rewrite <- gcd_mul_mono_l; try order. - f_equiv; symmetry; apply div_exact; try order; - apply mod_divide; trivial; try order. -Qed. - -Lemma gcd_div_gcd : forall a b g, g~=0 -> g == gcd a b -> - gcd (a/g) (b/g) == 1. -Proof. - intros a b g NZ EQ. rewrite gcd_div_factor. - - now rewrite <- EQ, div_same. - - generalize (gcd_nonneg a b); order. - - rewrite EQ; apply gcd_divide_l. - - rewrite EQ; apply gcd_divide_r. -Qed. - -(** The following equality is crucial for Euclid algorithm *) - -Lemma gcd_mod : forall a b, b~=0 -> gcd (a mod b) b == gcd b a. -Proof. - intros a b Hb. rewrite (gcd_comm _ b). - rewrite <- (gcd_add_mult_diag_r b (a mod b) (a/b)). - now rewrite add_comm, mul_comm, <- div_mod. -Qed. - -(** We now define lcm thanks to gcd: - - lcm a b = a * (b / gcd a b) - = (a / gcd a b) * b - = (a*b) / gcd a b - - Nota: [lcm 0 0] should be 0, which isn't guarantee with the third - equation above. -*) - -Definition lcm a b := a*(b/gcd a b). - -#[global] -Instance lcm_wd : Proper (eq==>eq==>eq) lcm. -Proof. unfold lcm. solve_proper. Qed. - -Lemma lcm_equiv1 : forall a b, gcd a b ~= 0 -> - a * (b / gcd a b) == (a*b)/gcd a b. -Proof. - intros a b H. rewrite divide_div_mul_exact; try easy. apply gcd_divide_r. -Qed. - -Lemma lcm_equiv2 : forall a b, gcd a b ~= 0 -> - (a / gcd a b) * b == (a*b)/gcd a b. -Proof. - intros a b H. rewrite 2 (mul_comm _ b). - rewrite divide_div_mul_exact; try easy. apply gcd_divide_l. -Qed. - -Lemma gcd_div_swap : forall a b, - (a / gcd a b) * b == a * (b / gcd a b). -Proof. - intros a b. destruct (eq_decidable (gcd a b) 0) as [EQ|NEQ]. - - apply gcd_eq_0 in EQ. destruct EQ as (EQ,EQ'). rewrite EQ, EQ'. now nzsimpl. - - now rewrite lcm_equiv1, <-lcm_equiv2. -Qed. - -Lemma divide_lcm_l : forall a b, (a | lcm a b). -Proof. - unfold lcm. intros a b. apply divide_factor_l. -Qed. - -Lemma divide_lcm_r : forall a b, (b | lcm a b). -Proof. - unfold lcm. intros a b. rewrite <- gcd_div_swap. - apply divide_factor_r. -Qed. - -Lemma divide_div : forall a b c, a~=0 -> (a|b) -> (b|c) -> (b/a|c/a). -Proof. - intros a b c Ha Hb (c',Hc). exists c'. - now rewrite <- divide_div_mul_exact, Hc. -Qed. - -Lemma lcm_least : forall a b c, - (a | c) -> (b | c) -> (lcm a b | c). -Proof. - intros a b c Ha Hb. unfold lcm. - destruct (eq_decidable (gcd a b) 0) as [EQ|NEQ]. - - apply gcd_eq_0 in EQ. destruct EQ as (EQ,EQ'). rewrite EQ in *. now nzsimpl. - - assert (Ga := gcd_divide_l a b). - assert (Gb := gcd_divide_r a b). - set (g:=gcd a b) in *. - assert (Ha' := divide_div g a c NEQ Ga Ha). - assert (Hb' := divide_div g b c NEQ Gb Hb). - destruct Ha' as (a',Ha'). rewrite Ha', mul_comm in Hb'. - apply gauss in Hb'; [|apply gcd_div_gcd; unfold g; trivial using gcd_comm]. - destruct Hb' as (b',Hb'). - exists b'. - rewrite mul_shuffle3, <- Hb'. - rewrite (proj2 (div_exact c g NEQ)). - + rewrite Ha', mul_shuffle3, (mul_comm a a'). f_equiv. - symmetry. apply div_exact; trivial. - apply mod_divide; trivial. - + apply mod_divide; trivial. transitivity a; trivial. -Qed. - -Lemma lcm_comm : forall a b, lcm a b == lcm b a. -Proof. - intros a b. unfold lcm. rewrite (gcd_comm b), (mul_comm b). - now rewrite <- gcd_div_swap. -Qed. - -Lemma lcm_divide_iff : forall n m p, - (lcm n m | p) <-> (n | p) /\ (m | p). -Proof. - intros n m p. split;[split|]. - - transitivity (lcm n m); trivial using divide_lcm_l. - - transitivity (lcm n m); trivial using divide_lcm_r. - - intros (H,H'). now apply lcm_least. -Qed. - -Lemma lcm_unique : forall n m p, - 0<=p -> (n|p) -> (m|p) -> - (forall q, (n|q) -> (m|q) -> (p|q)) -> - lcm n m == p. -Proof. - intros n m p Hp Hn Hm H. - apply divide_antisym; trivial. - - now apply lcm_least. - - apply H. - + apply divide_lcm_l. - + apply divide_lcm_r. -Qed. - -Lemma lcm_unique_alt : forall n m p, 0<=p -> - (forall q, (p|q) <-> (n|q) /\ (m|q)) -> - lcm n m == p. -Proof. - intros n m p Hp H. - apply lcm_unique; trivial. - - apply H, divide_refl. - - apply H, divide_refl. - - intros. apply H. now split. -Qed. - -Lemma lcm_assoc : forall n m p, lcm n (lcm m p) == lcm (lcm n m) p. -Proof. - intros. apply lcm_unique_alt. - - apply le_0_l. - - intros. now rewrite !lcm_divide_iff, and_assoc. -Qed. - -Lemma lcm_0_l : forall n, lcm 0 n == 0. -Proof. - intros. apply lcm_unique; trivial. - - order. - - apply divide_refl. - - apply divide_0_r. -Qed. - -Lemma lcm_0_r : forall n, lcm n 0 == 0. -Proof. - intros. now rewrite lcm_comm, lcm_0_l. -Qed. - -Lemma lcm_1_l : forall n, lcm 1 n == n. -Proof. - intros. apply lcm_unique; trivial using divide_1_l, le_0_l, divide_refl. -Qed. - -Lemma lcm_1_r : forall n, lcm n 1 == n. -Proof. - intros. now rewrite lcm_comm, lcm_1_l. -Qed. - -Lemma lcm_diag : forall n, lcm n n == n. -Proof. - intros. apply lcm_unique; trivial using divide_refl, le_0_l. -Qed. - -Lemma lcm_eq_0 : forall n m, lcm n m == 0 <-> n == 0 \/ m == 0. -Proof. - intros. split. - - intros EQ. - apply eq_mul_0. - apply divide_0_l. rewrite <- EQ. apply lcm_least. - + apply divide_factor_l. - + apply divide_factor_r. - - destruct 1 as [EQ|EQ]; rewrite EQ. - + apply lcm_0_l. - + apply lcm_0_r. -Qed. - -Lemma divide_lcm_eq_r : forall n m, (n|m) -> lcm n m == m. -Proof. - intros n m H. apply lcm_unique_alt; trivial using le_0_l. - intros q. split. - - split; trivial. now transitivity m. - - now destruct 1. -Qed. - -Lemma divide_lcm_iff : forall n m, (n|m) <-> lcm n m == m. -Proof. - intros n m. split. - - now apply divide_lcm_eq_r. - - intros EQ. rewrite <- EQ. apply divide_lcm_l. -Qed. - -Lemma lcm_mul_mono_l : - forall n m p, lcm (p * n) (p * m) == p * lcm n m. -Proof. - intros n m p. - destruct (eq_decidable p 0) as [Hp|Hp]. - - rewrite Hp. nzsimpl. rewrite lcm_0_l. now nzsimpl. - - destruct (eq_decidable (gcd n m) 0) as [Hg|Hg]. - + apply gcd_eq_0 in Hg. destruct Hg as (Hn,Hm); rewrite Hn, Hm. - nzsimpl. rewrite lcm_0_l. now nzsimpl. - + unfold lcm. - rewrite gcd_mul_mono_l. - rewrite mul_assoc. f_equiv. - now rewrite div_mul_cancel_l. -Qed. - -Lemma lcm_mul_mono_r : - forall n m p, lcm (n * p) (m * p) == lcm n m * p. -Proof. - intros n m p. now rewrite !(mul_comm _ p), lcm_mul_mono_l, mul_comm. -Qed. - -Lemma gcd_1_lcm_mul : forall n m, n~=0 -> m~=0 -> - (gcd n m == 1 <-> lcm n m == n*m). -Proof. - intros n m Hn Hm. split; intros H. - - unfold lcm. rewrite H. now rewrite div_1_r. - - unfold lcm in *. - apply mul_cancel_l in H; trivial. - assert (Hg : gcd n m ~= 0) by (red; rewrite gcd_eq_0; destruct 1; order). - assert (H' := gcd_divide_r n m). - apply mod_divide in H'; trivial. apply div_exact in H'; trivial. - rewrite H in H'. - rewrite <- (mul_1_l m) in H' at 1. - now apply mul_cancel_r in H'. -Qed. - -End NLcmProp. diff --git a/stdlib/theories/Numbers/Natural/Abstract/NLcm0.v b/stdlib/theories/Numbers/Natural/Abstract/NLcm0.v deleted file mode 100644 index 850e861602f7..000000000000 --- a/stdlib/theories/Numbers/Natural/Abstract/NLcm0.v +++ /dev/null @@ -1,144 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* eq==>eq) lcm := lcm_wd. - -(* The types are restated to avoid [Private_NLcmProp.lcm] indirection. *) -Definition gcd_div_gcd : forall a b g, g ~= 0 -> g == gcd a b -> - gcd (a / g) (b / g) == 1 := gcd_div_gcd. -Definition divide_lcm_l : forall a b, (a | lcm a b) := divide_lcm_l. -Definition gcd_div_swap : forall a b, a / gcd a b * b == a * (b / gcd a b) := gcd_div_swap. -Definition divide_lcm_r : forall a b, (b | lcm a b) := divide_lcm_r. -Definition lcm_least : forall a b c, (a | c) -> (b | c) -> (lcm a b | c) := lcm_least. -Definition lcm_comm : forall a b, lcm a b == lcm b a := lcm_comm. -Definition lcm_divide_iff : forall n m p, (lcm n m | p) <-> (n | p) /\ (m | p) := lcm_divide_iff. -Definition lcm_assoc : forall n m p, lcm n (lcm m p) == lcm (lcm n m) p := lcm_assoc. -Definition lcm_0_l : forall n, lcm 0 n == 0 := lcm_0_l. -Definition lcm_0_r : forall n, lcm n 0 == 0 := lcm_0_r. -Definition lcm_1_l : forall n, lcm 1 n == n := lcm_1_l. -Definition lcm_1_r : forall n, lcm n 1 == n := lcm_1_r. -Definition lcm_diag : forall n : t, lcm n n == n := lcm_diag. -Definition lcm_eq_0 : forall n m, lcm n m == 0 <-> n == 0 \/ m == 0 := lcm_eq_0. -Definition divide_lcm_eq_r : forall n m, (n | m) -> lcm n m == m := divide_lcm_eq_r. -Definition divide_lcm_iff : forall n m, (n | m) <-> lcm n m == m := divide_lcm_iff. -Definition lcm_mul_mono_l : forall n m p, lcm (p * n) (p * m) == p * lcm n m := lcm_mul_mono_l. -Definition lcm_mul_mono_r : forall n m p, lcm (n * p) (m * p) == lcm n m * p := lcm_mul_mono_r. -Definition gcd_1_lcm_mul : forall n m, n ~= 0 -> m ~= 0 -> - gcd n m == 1 <-> lcm n m == n * m := gcd_1_lcm_mul. -Module Lcm0. - -#[local] Hint Rewrite div_0_l mod_0_l div_0_r mod_0_r gcd_0_l gcd_0_r : nz. - -Lemma mod_divide : forall a b, (a mod b == 0 <-> (b|a)). -Proof. - intros a b. destruct (eq_decidable b 0) as [Hb|Hb]. - - split. - + intros Hab. exists 0. revert Hab. rewrite Hb. now nzsimpl. - + intros [c Hc]. revert Hc. rewrite Hb. now nzsimpl. - - now apply mod_divide. -Qed. - -Lemma divide_div_mul_exact : forall a b c, (b|a) -> (c*a)/b == c*(a/b). -Proof. - intros a b c. destruct (eq_decidable b 0) as [->|Hb]. - - now nzsimpl. - - now apply divide_div_mul_exact. -Qed. - -Lemma gcd_div_factor : forall a b c, (c|a) -> (c|b) -> - gcd (a/c) (b/c) == (gcd a b)/c. -Proof. - intros a b c. destruct (eq_decidable c 0) as [->|Hc]. - - now nzsimpl. - - now apply gcd_div_factor. -Qed. - -Lemma gcd_mod : forall a b, gcd (a mod b) b == gcd b a. -Proof. - intros a b. destruct (eq_decidable b 0) as [->|Hb]. - - now nzsimpl. - - now apply gcd_mod. -Qed. - -Lemma lcm_equiv1 : forall a b, a * (b / gcd a b) == (a*b)/gcd a b. -Proof. - intros a b. destruct (eq_decidable (gcd a b) 0) as [->|?]. - - now nzsimpl. - - now apply lcm_equiv1. -Qed. - -Lemma lcm_equiv2 : forall a b, (a / gcd a b) * b == (a*b)/gcd a b. -Proof. - intros a b. destruct (eq_decidable (gcd a b) 0) as [->|?]. - - now nzsimpl. - - now apply lcm_equiv2. -Qed. - -Lemma divide_div : forall a b c, (a|b) -> (b|c) -> (b/a|c/a). -Proof. - intros a b c. destruct (eq_decidable a 0) as [->|Ha]. - - now nzsimpl. - - now apply divide_div. -Qed. - -Lemma lcm_unique : forall n m p, - (n|p) -> (m|p) -> (forall q, (n|q) -> (m|q) -> (p|q)) -> lcm n m == p. -Proof. intros n m p. apply lcm_unique, le_0_l. Qed. - -Lemma lcm_unique_alt : forall n m p, - (forall q, (p|q) <-> (n|q) /\ (m|q)) -> lcm n m == p. -Proof. intros n m p. apply lcm_unique_alt, le_0_l. Qed. - -End Lcm0. - -(** Deprecation statements. - After deprecation phase, remove statements below - in favor of Lcm0 statements. *) - -#[deprecated(since="8.17",note="Use Lcm0.mod_divide instead.")] -Notation mod_divide := mod_divide (only parsing). -#[deprecated(since="8.17",note="Use Lcm0.divide_div_mul_exact instead.")] -Notation divide_div_mul_exact := divide_div_mul_exact (only parsing). -#[deprecated(since="8.17",note="Use Lcm0.gcd_div_factor instead.")] -Notation gcd_div_factor := gcd_div_factor (only parsing). -#[deprecated(since="8.17",note="Use Lcm0.gcd_mod instead.")] -Notation gcd_mod := gcd_mod (only parsing). -#[deprecated(since="8.17",note="Use Lcm0.gcd_mod instead.")] -Notation lcm_equiv1 := lcm_equiv1 (only parsing). -#[deprecated(since="8.17",note="Use Lcm0.lcm_equiv2 instead.")] -Notation lcm_equiv2 := lcm_equiv2 (only parsing). -#[deprecated(since="8.17",note="Use Lcm0.divide_div instead.")] -Notation divide_div := divide_div (only parsing). -#[deprecated(since="8.17",note="Use Lcm0.lcm_unique instead.")] -Notation lcm_unique := lcm_unique (only parsing). -#[deprecated(since="8.17",note="Use Lcm0.lcm_unique_alt instead.")] -Notation lcm_unique_alt := lcm_unique_alt (only parsing). - -End NLcmProp0. diff --git a/stdlib/theories/Numbers/Natural/Abstract/NLog.v b/stdlib/theories/Numbers/Natural/Abstract/NLog.v deleted file mode 100644 index b7ba894a972a..000000000000 --- a/stdlib/theories/Numbers/Natural/Abstract/NLog.v +++ /dev/null @@ -1,25 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* n * n < m * m. -Proof. -intros n m; split; intro; -[apply square_lt_mono_nonneg | apply square_lt_simpl_nonneg]; -try assumption; apply le_0_l. -Qed. - -Theorem square_le_mono : forall n m, n <= m <-> n * n <= m * m. -Proof. -intros n m; split; intro; -[apply square_le_mono_nonneg | apply square_le_simpl_nonneg]; -try assumption; apply le_0_l. -Qed. - -Theorem mul_le_mono_l : forall n m p, n <= m -> p * n <= p * m. -Proof. - intros; apply mul_le_mono_nonneg_l. - - apply le_0_l. - - assumption. -Qed. - -Theorem mul_le_mono_r : forall n m p, n <= m -> n * p <= m * p. -Proof. - intros; apply mul_le_mono_nonneg_r. - - apply le_0_l. - - assumption. -Qed. - -Theorem le_mul_l : forall n m, m ~= 0 -> n <= m * n. -Proof. - intros n m D%neq_0_le_1; rewrite <-(mul_1_l n) at 1. - apply mul_le_mono_r; exact D. -Qed. - -Theorem le_mul_r : forall n m, m ~= 0 -> n <= n * m. -Proof. - intros n m; rewrite mul_comm; exact (le_mul_l _ _). -Qed. - -Theorem mul_lt_mono : forall n m p q, n < m -> p < q -> n * p < m * q. -Proof. -intros; apply mul_lt_mono_nonneg; try assumption; apply le_0_l. -Qed. - -Theorem mul_le_mono : forall n m p q, n <= m -> p <= q -> n * p <= m * q. -Proof. -intros; apply mul_le_mono_nonneg; try assumption; apply le_0_l. -Qed. - -Theorem lt_0_mul' : forall n m, n * m > 0 <-> n > 0 /\ m > 0. -Proof. -intros n m; split; [intro H | intros [H1 H2]]. -- apply lt_0_mul in H. destruct H as [[H1 H2] | [H1 H2]]. - + now split. - + false_hyp H1 nlt_0_r. -- now apply mul_pos_pos. -Qed. - -Notation mul_pos := lt_0_mul' (only parsing). - -Theorem eq_mul_1 : forall n m, n * m == 1 <-> n == 1 /\ m == 1. -Proof. -intros n m. -split; [| intros [H1 H2]; now rewrite H1, H2, mul_1_l]. -intro H; destruct (lt_trichotomy n 1) as [H1 | [H1 | H1]]. -- apply lt_1_r in H1. rewrite H1, mul_0_l in H. order'. -- rewrite H1, mul_1_l in H; now split. -- destruct (eq_0_gt_0_cases m) as [H2 | H2]. - + rewrite H2, mul_0_r in H. order'. - + apply (mul_lt_mono_pos_r m) in H1; [| assumption]. rewrite mul_1_l in H1. - assert (H3 : 1 < n * m) by now apply (lt_1_l m). - rewrite H in H3; false_hyp H3 lt_irrefl. -Qed. - -(** Alternative name : *) - -Definition mul_eq_1 := eq_mul_1. - -End NMulOrderProp. diff --git a/stdlib/theories/Numbers/Natural/Abstract/NOrder.v b/stdlib/theories/Numbers/Natural/Abstract/NOrder.v deleted file mode 100644 index 9e4551918d3b..000000000000 --- a/stdlib/theories/Numbers/Natural/Abstract/NOrder.v +++ /dev/null @@ -1,294 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* 0 <= n < m). -- apply lt_wf. -- intros x y; split. - + intro H; split; [apply le_0_l | assumption]. - + now intros [_ H]. -Defined. - -(* "le_0_l : forall n : N, 0 <= n" was proved in NBase.v *) - -Theorem nlt_0_r : forall n, ~ n < 0. -Proof. -intro n; apply le_ngt. apply le_0_l. -Qed. - -Theorem nle_succ_0 : forall n, ~ (S n <= 0). -Proof. -intros n H; apply le_succ_l in H; false_hyp H nlt_0_r. -Qed. - -Theorem le_0_r : forall n, n <= 0 <-> n == 0. -Proof. -intros n; split; intro H. -- le_elim H; [false_hyp H nlt_0_r | assumption]. -- now apply eq_le_incl. -Qed. - -Theorem lt_0_succ : forall n, 0 < S n. -Proof. -intro n; induct n; [apply lt_succ_diag_r | intros n H; now apply lt_lt_succ_r]. -Qed. - -Theorem le_1_succ : forall n, 1 <= S n. -Proof. -intros n; rewrite one_succ; apply ->succ_le_mono; exact (le_0_l _). -Qed. - -Theorem neq_0_lt_0 : forall n, n ~= 0 <-> 0 < n. -Proof. -intro n; cases n. -- split; intro H; [now elim H | intro; now apply lt_irrefl with 0]. -- intro n; split; intro H; [apply lt_0_succ | apply neq_succ_0]. -Qed. - -Theorem neq_0_le_1 : forall n, n ~= 0 <-> 1 <= n. -Proof. -intros n; split. -- intros <-%succ_pred; exact (le_1_succ _). -- intros H E; rewrite E, one_succ in H; apply (nle_succ_0 0); exact H. -Qed. - -Theorem eq_0_gt_0_cases : forall n, n == 0 \/ 0 < n. -Proof. -intro n; cases n. -- now left. -- intro; right; apply lt_0_succ. -Qed. - -Theorem zero_one : forall n, n == 0 \/ n == 1 \/ 1 < n. -Proof. -setoid_rewrite one_succ. -intro n; induct n. { now left. } -intro n; cases n. { intros; right; now left. } -intros n IH. destruct IH as [H | [H | H]]. -- false_hyp H neq_succ_0. -- right; right. rewrite H. apply lt_succ_diag_r. -- right; right. now apply lt_lt_succ_r. -Qed. - -Theorem lt_1_r : forall n, n < 1 <-> n == 0. -Proof. -setoid_rewrite one_succ. -intro n; cases n. -- split; intro; [reflexivity | apply lt_succ_diag_r]. -- intros n. rewrite <- succ_lt_mono. - split; intro H; [false_hyp H nlt_0_r | false_hyp H neq_succ_0]. -Qed. - -Theorem le_1_r : forall n, n <= 1 <-> n == 0 \/ n == 1. -Proof. -setoid_rewrite one_succ. -intro n; cases n. -- split; intro; [now left | apply le_succ_diag_r]. -- intro n. rewrite <- succ_le_mono, le_0_r, succ_inj_wd. - split; [intro; now right | intros [H | H]; [false_hyp H neq_succ_0 | assumption]]. -Qed. - -Theorem lt_lt_0 : forall n m, n < m -> 0 < m. -Proof. -intros n m; induct n. -- trivial. -- intros n IH H. apply IH; now apply lt_succ_l. -Qed. - -Theorem lt_1_l' : forall n m p, n < m -> m < p -> 1 < p. -Proof. -intros n m p H H0. apply lt_1_l with m; auto. -apply le_lt_trans with n; auto. now apply le_0_l. -Qed. - -(** Elimination principlies for < and <= for relations *) - -Section RelElim. - -Variable R : relation N.t. -Hypothesis R_wd : Proper (N.eq==>N.eq==>iff) R. - -Theorem le_ind_rel : - (forall m, R 0 m) -> - (forall n m, n <= m -> R n m -> R (S n) (S m)) -> - forall n m, n <= m -> R n m. -Proof. -intros Base Step n; induct n. -{ intros; apply Base. } -intros n IH m H. elim H using le_ind. -- solve_proper. -- apply Step; [| apply IH]; now apply eq_le_incl. -- intros k H1 H2. apply le_succ_l in H1. apply lt_le_incl in H1. auto. -Qed. - -Theorem lt_ind_rel : - (forall m, R 0 (S m)) -> - (forall n m, n < m -> R n m -> R (S n) (S m)) -> - forall n m, n < m -> R n m. -Proof. -intros Base Step n; induct n. -- intros m H. apply lt_exists_pred in H; destruct H as [m' [H _]]. - rewrite H; apply Base. -- intros n IH m H. elim H using lt_ind. - + solve_proper. - + apply Step; [| apply IH]; now apply lt_succ_diag_r. - + intros k H1 H2. apply lt_succ_l in H1. auto. -Qed. - -End RelElim. - -(** Predecessor and order *) - -Theorem succ_pred_pos : forall n, 0 < n -> S (P n) == n. -Proof. -intros n H; apply succ_pred; intro H1; rewrite H1 in H. -false_hyp H lt_irrefl. -Qed. - -Theorem le_pred_l : forall n, P n <= n. -Proof. -intro n; cases n. -- rewrite pred_0; now apply eq_le_incl. -- intros; rewrite pred_succ; apply le_succ_diag_r. -Qed. - -Theorem lt_pred_l : forall n, n ~= 0 -> P n < n. -Proof. -intro n; cases n. -- intro H; exfalso; now apply H. -- intros; rewrite pred_succ; apply lt_succ_diag_r. -Qed. - -Theorem le_le_pred : forall n m, n <= m -> P n <= m. -Proof. - intros n m H; apply le_trans with n. - - apply le_pred_l. - - assumption. -Qed. - -Theorem lt_lt_pred : forall n m, n < m -> P n < m. -Proof. - intros n m H; apply le_lt_trans with n. - - apply le_pred_l. - - assumption. -Qed. - -Theorem lt_le_pred : forall n m, n < m -> n <= P m. - (* Converse is false for n == m == 0 *) -Proof. -intros n m; cases m. -- intro H; false_hyp H nlt_0_r. -- intros m IH. rewrite pred_succ; now apply lt_succ_r. -Qed. - -Theorem lt_pred_le : forall n m, P n < m -> n <= m. - (* Converse is false for n == m == 0 *) -Proof. -intros n m; cases n. -- rewrite pred_0; intro H; now apply lt_le_incl. -- intros n IH. rewrite pred_succ in IH. now apply le_succ_l. -Qed. - -Theorem lt_pred_lt : forall n m, n < P m -> n < m. -Proof. -intros n m H; apply lt_le_trans with (P m); [assumption | apply le_pred_l]. -Qed. - -Theorem le_pred_le : forall n m, n <= P m -> n <= m. -Proof. -intros n m H; apply le_trans with (P m); [assumption | apply le_pred_l]. -Qed. - -Theorem pred_le_mono : forall n m, n <= m -> P n <= P m. - (* Converse is false for n == 1, m == 0 *) -Proof. -intros n m H; elim H using le_ind_rel. -- solve_proper. -- intro; rewrite pred_0; apply le_0_l. -- intros p q H1 _; now do 2 rewrite pred_succ. -Qed. - -Theorem pred_lt_mono : forall n m, n ~= 0 -> (n < m <-> P n < P m). -Proof. -intros n m H1; split; intro H2. -- assert (m ~= 0). { apply neq_0_lt_0. now apply lt_lt_0 with n. } - now rewrite <- (succ_pred n) in H2; rewrite <- (succ_pred m) in H2 ; - [apply succ_lt_mono | | |]. -- assert (m ~= 0). - { apply neq_0_lt_0. apply lt_lt_0 with (P n). - apply lt_le_trans with (P m). - - assumption. - - apply le_pred_l. - } - apply succ_lt_mono in H2. now do 2 rewrite succ_pred in H2. -Qed. - -Theorem lt_succ_lt_pred : forall n m, S n < m <-> n < P m. -Proof. -intros n m. rewrite pred_lt_mono by apply neq_succ_0. now rewrite pred_succ. -Qed. - -Theorem le_succ_le_pred : forall n m, S n <= m -> n <= P m. - (* Converse is false for n == m == 0 *) -Proof. -intros n m H. apply lt_le_pred. now apply le_succ_l. -Qed. - -Theorem lt_pred_lt_succ : forall n m, P n < m -> n < S m. - (* Converse is false for n == m == 0 *) -Proof. -intros n m H. apply lt_succ_r. now apply lt_pred_le. -Qed. - -Theorem le_pred_le_succ : forall n m, P n <= m <-> n <= S m. -Proof. -intros n m; cases n. -- rewrite pred_0. split; intro H; apply le_0_l. -- intro n. rewrite pred_succ. apply succ_le_mono. -Qed. - -Lemma measure_induction : forall (X : Type) (f : X -> t) (A : X -> Type), - (forall x, (forall y, f y < f x -> A y) -> A x) -> - forall x, A x. -Proof. - intros X f A IH x. apply (measure_right_induction X f A 0); [|apply le_0_l]. - intros y _ IH'. apply IH. intros. apply IH'. now split; [apply le_0_l|]. -Defined. - -(* This is kept private in order to drop the [Proper] condition in - implementations. *) -(* begin hide *) -Theorem Private_strong_induction_le {A : t -> Prop} : - Proper (eq ==> iff) A -> - A 0 -> (forall n, ((forall m, m <= n -> A m) -> A (S n))) -> (forall n, A n). -Proof. - intros H H0 sIH n. - enough (forall k, k <= n -> A k) as key. { - apply key; exact (le_refl _). - } - induct n. - - intros k ->%le_0_r; exact H0. - - intros n I k [Hk%lt_succ_r%I | ->]%lt_eq_cases. - + exact Hk. - + apply sIH; exact I. -Qed. -(* end hide *) - -End NOrderProp. diff --git a/stdlib/theories/Numbers/Natural/Abstract/NParity.v b/stdlib/theories/Numbers/Natural/Abstract/NParity.v deleted file mode 100644 index 5489663f27fd..000000000000 --- a/stdlib/theories/Numbers/Natural/Abstract/NParity.v +++ /dev/null @@ -1,66 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* odd (P n) = even n. -Proof. - intros. rewrite <- (succ_pred n) at 2 by trivial. - symmetry. apply even_succ. -Qed. - -Lemma even_pred n : n~=0 -> even (P n) = odd n. -Proof. - intros. rewrite <- (succ_pred n) at 2 by trivial. - symmetry. apply odd_succ. -Qed. - -Lemma even_sub n m : m<=n -> even (n-m) = Bool.eqb (even n) (even m). -Proof. - intros. - case_eq (even n); case_eq (even m); - rewrite <- ?negb_true_iff, ?negb_even, ?odd_spec, ?even_spec; - intros (m',Hm) (n',Hn). - - exists (n'-m'). now rewrite mul_sub_distr_l, Hn, Hm. - - exists (n'-m'-1). - rewrite !mul_sub_distr_l, Hn, Hm, sub_add_distr, mul_1_r. - rewrite two_succ at 5. rewrite <- (add_1_l 1). rewrite sub_add_distr. - symmetry. apply sub_add. - apply le_add_le_sub_l. - rewrite add_1_l, <- two_succ, <- (mul_1_r 2) at 1. - rewrite <- mul_sub_distr_l. rewrite <- mul_le_mono_pos_l by order'. - rewrite one_succ, le_succ_l. rewrite <- lt_add_lt_sub_l, add_0_r. - destruct (le_gt_cases n' m') as [LE|GT]; trivial. - generalize (double_below _ _ LE). order. - - exists (n'-m'). rewrite mul_sub_distr_l, Hn, Hm. - apply add_sub_swap. - apply mul_le_mono_pos_l; try order'. - destruct (le_gt_cases m' n') as [LE|GT]; trivial. - generalize (double_above _ _ GT). order. - - exists (n'-m'). rewrite Hm,Hn, mul_sub_distr_l. - rewrite sub_add_distr. rewrite add_sub_swap. - + apply add_sub. - + apply succ_le_mono. - rewrite add_1_r in Hm,Hn. order. -Qed. - -Lemma odd_sub n m : m<=n -> odd (n-m) = xorb (odd n) (odd m). -Proof. - intros. rewrite <- !negb_even. rewrite even_sub by trivial. - now destruct (even n), (even m). -Qed. - -End NParityProp. diff --git a/stdlib/theories/Numbers/Natural/Abstract/NPow.v b/stdlib/theories/Numbers/Natural/Abstract/NPow.v deleted file mode 100644 index 47ce59e7a79b..000000000000 --- a/stdlib/theories/Numbers/Natural/Abstract/NPow.v +++ /dev/null @@ -1,170 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* 0^a == 0. -Proof. wrap pow_0_l. Qed. - -Definition pow_1_r : forall a, a^1 == a - := pow_1_r. - -Lemma pow_1_l : forall a, 1^a == 1. -Proof. wrap pow_1_l. Qed. - -Definition pow_2_r : forall a, a^2 == a*a - := pow_2_r. - -(** Power and addition, multiplication *) - -Lemma pow_add_r : forall a b c, a^(b+c) == a^b * a^c. -Proof. wrap pow_add_r. Qed. - -Lemma pow_mul_l : forall a b c, (a*b)^c == a^c * b^c. -Proof. wrap pow_mul_l. Qed. - -Lemma pow_mul_r : forall a b c, a^(b*c) == (a^b)^c. -Proof. wrap pow_mul_r. Qed. - -(** Power and nullity *) - -Lemma pow_eq_0 : forall a b, b~=0 -> a^b == 0 -> a == 0. -Proof. intros a b ? ?. apply (pow_eq_0 a b); trivial. auto'. Qed. - -Lemma pow_nonzero : forall a b, a~=0 -> a^b ~= 0. -Proof. wrap pow_nonzero. Qed. - -Lemma pow_eq_0_iff : forall a b, a^b == 0 <-> b~=0 /\ a==0. -Proof. - intros a b. split. - - rewrite pow_eq_0_iff. intros [H |[H H']]. - + generalize (le_0_l b); order. - + split; order. - - intros (Hb,Ha). rewrite Ha. now apply pow_0_l'. -Qed. - -(** Monotonicity *) - -Lemma pow_lt_mono_l : forall a b c, c~=0 -> a a^c < b^c. -Proof. wrap pow_lt_mono_l. Qed. - -Lemma pow_le_mono_l : forall a b c, a<=b -> a^c <= b^c. -Proof. wrap pow_le_mono_l. Qed. - -Lemma pow_gt_1 : forall a b, 1 b~=0 -> 1 b a^b < a^c. -Proof. wrap pow_lt_mono_r. Qed. - -(** NB: since 0^0 > 0^1, the following result isn't valid with a=0 *) - -Lemma pow_le_mono_r : forall a b c, a~=0 -> b<=c -> a^b <= a^c. -Proof. wrap pow_le_mono_r. Qed. - -Lemma pow_le_mono : forall a b c d, a~=0 -> a<=c -> b<=d -> - a^b <= c^d. -Proof. wrap pow_le_mono. Qed. - -Definition pow_lt_mono : forall a b c d, 0 0 - a^b < c^d - := pow_lt_mono. - -(** Injectivity *) - -Lemma pow_inj_l : forall a b c, c~=0 -> a^c == b^c -> a == b. -Proof. intros; eapply pow_inj_l; eauto; auto'. Qed. - -Lemma pow_inj_r : forall a b c, 1 a^b == a^c -> b == c. -Proof. intros; eapply pow_inj_r; eauto; auto'. Qed. - -(** Monotonicity results, both ways *) - -Lemma pow_lt_mono_l_iff : forall a b c, c~=0 -> - (a a^c < b^c). -Proof. wrap pow_lt_mono_l_iff. Qed. - -Lemma pow_le_mono_l_iff : forall a b c, c~=0 -> - (a<=b <-> a^c <= b^c). -Proof. wrap pow_le_mono_l_iff. Qed. - -Lemma pow_lt_mono_r_iff : forall a b c, 1 - (b a^b < a^c). -Proof. wrap pow_lt_mono_r_iff. Qed. - -Lemma pow_le_mono_r_iff : forall a b c, 1 - (b<=c <-> a^b <= a^c). -Proof. wrap pow_le_mono_r_iff. Qed. - -Lemma pow_lower_bound : forall a b, a~= 0 -> 1 <= a ^ b. -Proof. - intros a b; rewrite <-(pow_0_r a); intros H. - exact (pow_le_mono_r _ _ _ H (le_0_l _)). -Qed. - -(** For any a>1, the a^x function is above the identity function *) - -Lemma pow_gt_lin_r : forall a b, 1 b < a^b. -Proof. wrap pow_gt_lin_r. Qed. - -(** Someday, we should say something about the full Newton formula. - In the meantime, we can at least provide some inequalities about - (a+b)^c. -*) - -Lemma pow_add_lower : forall a b c, c~=0 -> - a^c + b^c <= (a+b)^c. -Proof. wrap pow_add_lower. Qed. - -(** This upper bound can also be seen as a convexity proof for x^c : - image of (a+b)/2 is below the middle of the images of a and b -*) - -Lemma pow_add_upper : forall a b c, c~=0 -> - (a+b)^c <= 2^(pred c) * (a^c + b^c). -Proof. wrap pow_add_upper. Qed. - -(** Power and parity *) - -Lemma even_pow : forall a b, b~=0 -> even (a^b) = even a. -Proof. - intros a b Hb. rewrite neq_0_lt_0 in Hb. - apply lt_ind with (4:=Hb). - - solve_proper. - - now nzsimpl. - - clear b Hb. intros b Hb IH. - rewrite pow_succ_r', even_mul, IH. now destruct (even a). -Qed. - -Lemma odd_pow : forall a b, b~=0 -> odd (a^b) = odd a. -Proof. - intros. now rewrite <- !negb_even, even_pow. -Qed. - -End NPowProp. diff --git a/stdlib/theories/Numbers/Natural/Abstract/NProperties.v b/stdlib/theories/Numbers/Natural/Abstract/NProperties.v deleted file mode 100644 index af359444740c..000000000000 --- a/stdlib/theories/Numbers/Natural/Abstract/NProperties.v +++ /dev/null @@ -1,40 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* āˆša == b - := sqrt_unique. - -Lemma sqrt_square : forall a, āˆš(a*a) == a. -Proof. wrap sqrt_square. Qed. - -Definition sqrt_le_mono : forall a b, a<=b -> āˆša <= āˆšb - := sqrt_le_mono. - -Definition sqrt_lt_cancel : forall a b, āˆša < āˆšb -> a < b - := sqrt_lt_cancel. - -Lemma sqrt_le_square : forall a b, b*b<=a <-> b <= āˆša. -Proof. wrap sqrt_le_square. Qed. - -Lemma sqrt_lt_square : forall a b, a āˆša < b. -Proof. wrap sqrt_lt_square. Qed. - -Definition sqrt_0 := sqrt_0. -Definition sqrt_1 := sqrt_1. -Definition sqrt_2 := sqrt_2. - -Definition sqrt_lt_lin : forall a, 1 āˆšaA)->N->A] is the step function: - [F f n] should return [phi(n)] when [f] is a function - that coincide with [phi] for numbers strictly less than [n]. -*) - -Definition strong_rec (a : A) (f : (N.t -> A) -> N.t -> A) (n : N.t) : A := - recursion (fun _ => a) (fun _ => f) (S n) n. - -(** For convenience, we use in proofs an intermediate definition - between [recursion] and [strong_rec]. *) - -Definition strong_rec0 (a : A) (f : (N.t -> A) -> N.t -> A) : N.t -> N.t -> A := - recursion (fun _ => a) (fun _ => f). - -Lemma strong_rec_alt : forall a f n, - strong_rec a f n = strong_rec0 a f (S n) n. -Proof. -reflexivity. -Qed. - -Instance strong_rec0_wd : - Proper (Aeq ==> ((N.eq ==> Aeq) ==> N.eq ==> Aeq) ==> N.eq ==> N.eq ==> Aeq) - strong_rec0. -Proof. -unfold strong_rec0; f_equiv'. -Qed. - -Instance strong_rec_wd : - Proper (Aeq ==> ((N.eq ==> Aeq) ==> N.eq ==> Aeq) ==> N.eq ==> Aeq) strong_rec. -Proof. -intros a a' Eaa' f f' Eff' n n' Enn'. -rewrite !strong_rec_alt; f_equiv'. -Qed. - -Section FixPoint. - -Variable f : (N.t -> A) -> N.t -> A. -Variable f_wd : Proper ((N.eq==>Aeq)==>N.eq==>Aeq) f. - -Lemma strong_rec0_0 : forall a m, - (strong_rec0 a f 0 m) = a. -Proof. -intros. unfold strong_rec0. rewrite recursion_0; auto. -Qed. - -Lemma strong_rec0_succ : forall a n m, - Aeq (strong_rec0 a f (S n) m) (f (strong_rec0 a f n) m). -Proof. -intros. unfold strong_rec0. -f_equiv. -rewrite recursion_succ; f_equiv'. -Qed. - -Lemma strong_rec_0 : forall a, - Aeq (strong_rec a f 0) (f (fun _ => a) 0). -Proof. -intros. rewrite strong_rec_alt, strong_rec0_succ; f_equiv'. -rewrite strong_rec0_0. reflexivity. -Qed. - -(* We need an assumption saying that for every n, the step function (f h n) -calls h only on the segment [0 ... n - 1]. This means that if h1 and h2 -coincide on values < n, then (f h1 n) coincides with (f h2 n) *) - -Hypothesis step_good : - forall (n : N.t) (h1 h2 : N.t -> A), - (forall m : N.t, m < n -> Aeq (h1 m) (h2 m)) -> Aeq (f h1 n) (f h2 n). - -Lemma strong_rec0_more_steps : forall a k n m, m < n -> - Aeq (strong_rec0 a f n m) (strong_rec0 a f (n+k) m). -Proof. - intros a k n. pattern n. - apply induction; clear n. - - - intros n n' Hn; setoid_rewrite Hn; auto with *. - - - intros m Hm. destruct (nlt_0_r _ Hm). - - - intros n IH m Hm. - rewrite lt_succ_r in Hm. - rewrite add_succ_l. - rewrite 2 strong_rec0_succ. - apply step_good. - intros m' Hm'. - apply IH. - apply lt_le_trans with m; auto. -Qed. - -Lemma strong_rec0_fixpoint : forall (a : A) (n : N.t), - Aeq (strong_rec0 a f (S n) n) (f (fun n => strong_rec0 a f (S n) n) n). -Proof. -intros. -rewrite strong_rec0_succ. -apply step_good. -intros m Hm. -symmetry. -setoid_replace n with (S m + (n - S m)). -- apply strong_rec0_more_steps. - apply lt_succ_diag_r. -- rewrite add_comm. - symmetry. - apply sub_add. - rewrite le_succ_l; auto. -Qed. - -Theorem strong_rec_fixpoint : forall (a : A) (n : N.t), - Aeq (strong_rec a f n) (f (strong_rec a f) n). -Proof. -intros. -transitivity (f (fun n => strong_rec0 a f (S n) n) n). -- rewrite strong_rec_alt. - apply strong_rec0_fixpoint. -- f_equiv. - intros x x' Hx; rewrite strong_rec_alt, Hx; auto with *. -Qed. - -(** NB: without the [step_good] hypothesis, we have proved that - [strong_rec a f 0] is [f (fun _ => a) 0]. Now we can prove - that the first argument of [f] is arbitrary in this case... -*) - -Theorem strong_rec_0_any : forall (a : A)(any : N.t->A), - Aeq (strong_rec a f 0) (f any 0). -Proof. -intros. -rewrite strong_rec_fixpoint. -apply step_good. -intros m Hm. destruct (nlt_0_r _ Hm). -Qed. - -(** ... and that first argument of [strong_rec] is always arbitrary. *) - -Lemma strong_rec_any_fst_arg : forall a a' n, - Aeq (strong_rec a f n) (strong_rec a' f n). -Proof. -intros a a' n. -generalize (le_refl n). -set (k:=n) at -2. clearbody k. revert k. pattern n. -apply induction; clear n. -- (* compat *) - intros n n' Hn. setoid_rewrite Hn; auto with *. -- (* 0 *) - intros k Hk. rewrite le_0_r in Hk. - rewrite Hk, strong_rec_0. symmetry. apply strong_rec_0_any. -- (* S *) - intros n IH k Hk. - rewrite 2 strong_rec_fixpoint. - apply step_good. - intros m Hm. - apply IH. - rewrite succ_le_mono. - apply le_trans with k; auto. - rewrite le_succ_l; auto. -Qed. - -End FixPoint. -End StrongRecursion. - -Arguments strong_rec [A] a f n. - -End NStrongRecProp. diff --git a/stdlib/theories/Numbers/Natural/Abstract/NSub.v b/stdlib/theories/Numbers/Natural/Abstract/NSub.v deleted file mode 100644 index cfc39d0dba41..000000000000 --- a/stdlib/theories/Numbers/Natural/Abstract/NSub.v +++ /dev/null @@ -1,365 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* m -> n - m ~= 0. -Proof. -intros n m H; elim H using lt_ind_rel; clear n m H. -- solve_proper. -- intro; rewrite sub_0_r; apply neq_succ_0. -- intros; now rewrite sub_succ. -Qed. - -Theorem add_sub_assoc : forall n m p, p <= m -> n + (m - p) == (n + m) - p. -Proof. -intros n m p; induct p. -- intro; now do 2 rewrite sub_0_r. -- intros p IH H. do 2 rewrite sub_succ_r. - rewrite <- IH by (apply lt_le_incl; now apply le_succ_l). - rewrite add_pred_r by (apply sub_gt; now apply le_succ_l). - reflexivity. -Qed. - -Theorem sub_succ_l : forall n m, n <= m -> S m - n == S (m - n). -Proof. -intros n m H. rewrite <- (add_1_l m). rewrite <- (add_1_l (m - n)). -symmetry; now apply add_sub_assoc. -Qed. - -Theorem add_sub : forall n m, (n + m) - m == n. -Proof. -intros n m. rewrite <- add_sub_assoc by (apply le_refl). -rewrite sub_diag; now rewrite add_0_r. -Qed. - -Theorem sub_add : forall n m, n <= m -> (m - n) + n == m. -Proof. -intros n m H. rewrite add_comm. rewrite add_sub_assoc by assumption. -rewrite add_comm. apply add_sub. -Qed. - -Theorem add_sub_eq_l : forall n m p, m + p == n -> n - m == p. -Proof. -intros n m p H. symmetry. -assert (H1 : m + p - m == n - m) by now rewrite H. -rewrite add_comm in H1. now rewrite add_sub in H1. -Qed. - -Theorem add_sub_eq_r : forall n m p, m + p == n -> n - p == m. -Proof. -intros n m p H; rewrite add_comm in H; now apply add_sub_eq_l. -Qed. - -(* This could be proved by adding m to both sides. Then the proof would -use add_sub_assoc and sub_0_le, which is proven below. *) - -Theorem add_sub_eq_nz : forall n m p, p ~= 0 -> n - m == p -> m + p == n. -Proof. -intros n m p H; double_induct n m. -- intros m H1; rewrite sub_0_l in H1. symmetry in H1; false_hyp H1 H. -- intro n; rewrite sub_0_r; now rewrite add_0_l. -- intros n m IH H1. rewrite sub_succ in H1. apply IH in H1. - rewrite add_succ_l; now rewrite H1. -Qed. - -Theorem sub_add_distr : forall n m p, n - (m + p) == (n - m) - p. -Proof. -intros n m p; induct p. -- rewrite add_0_r; now rewrite sub_0_r. -- intros p IH. rewrite add_succ_r; do 2 rewrite sub_succ_r. now rewrite IH. -Qed. - -Theorem add_sub_swap : forall n m p, p <= n -> n + m - p == n - p + m. -Proof. -intros n m p H. -rewrite (add_comm n m). -rewrite <- add_sub_assoc by assumption. -now rewrite (add_comm m (n - p)). -Qed. - -(** Sub and order *) - -Theorem le_sub_l : forall n m, n - m <= n. -Proof. -intros n m; induct m. -- rewrite sub_0_r; now apply eq_le_incl. -- intros m IH. rewrite sub_succ_r. - apply le_trans with (n - m); [apply le_pred_l | assumption]. -Qed. - -Theorem sub_0_le : forall n m, n - m == 0 <-> n <= m. -Proof. -intros n m; double_induct n m. -- intro m; split; intro; [apply le_0_l | apply sub_0_l]. -- intro m; rewrite sub_0_r; split; intro H; - [false_hyp H neq_succ_0 | false_hyp H nle_succ_0]. -- intros n m H. rewrite <- succ_le_mono. now rewrite sub_succ. -Qed. - -Theorem sub_pred_l : forall n m, P n - m == P (n - m). -Proof. -intros n m; destruct (zero_or_succ n) as [-> | [k ->]]. -- rewrite pred_0, sub_0_l, pred_0; reflexivity. -- rewrite pred_succ; destruct (lt_ge_cases k m) as [H | H]. - + pose proof H as H'. apply lt_le_incl in H' as ->%sub_0_le. - apply le_succ_l, sub_0_le in H as ->; rewrite pred_0; reflexivity. - + rewrite sub_succ_l, pred_succ by (exact H); reflexivity. -Qed. - -Theorem sub_pred_r : forall n m, m ~= 0 -> m <= n -> n - P m == S (n - m). -Proof. -intros n m H H'; destruct (zero_or_succ m) as [[]%H | [k Hk]]; rewrite Hk in *. -rewrite pred_succ, sub_succ_r, succ_pred; [reflexivity |]. -apply sub_gt, le_succ_l; exact H'. -Qed. - -Theorem sub_add_le : forall n m, n <= n - m + m. -Proof. -intros n m. -destruct (le_ge_cases n m) as [LE|GE]. -- rewrite <- sub_0_le in LE. rewrite LE; nzsimpl. - now rewrite <- sub_0_le. -- rewrite sub_add by assumption. apply le_refl. -Qed. - -Theorem le_sub_le_add_r : forall n m p, - n - p <= m <-> n <= m + p. -Proof. -intros n m p. -split; intros LE. -- rewrite (add_le_mono_r _ _ p) in LE. - apply le_trans with (n-p+p); auto using sub_add_le. -- destruct (le_ge_cases n p) as [LE'|GE]. - + rewrite <- sub_0_le in LE'. rewrite LE'. apply le_0_l. - + rewrite (add_le_mono_r _ _ p). now rewrite sub_add. -Qed. - -Theorem le_sub_le_add_l : forall n m p, n - m <= p <-> n <= m + p. -Proof. -intros n m p. rewrite add_comm; apply le_sub_le_add_r. -Qed. - -Theorem lt_sub_lt_add_r : forall n m p, - n - p < m -> n < m + p. -Proof. -intros n m p LT. -rewrite (add_lt_mono_r _ _ p) in LT. -apply le_lt_trans with (n-p+p); auto using sub_add_le. -Qed. - -(** Unfortunately, we do not have [n < m + p -> n - p < m]. - For instance [1<0+2] but not [1-2<0]. *) - -Theorem lt_sub_lt_add_l : forall n m p, n - m < p -> n < m + p. -Proof. -intros n m p. rewrite add_comm; apply lt_sub_lt_add_r. -Qed. - -Theorem le_add_le_sub_r : forall n m p, n + p <= m -> n <= m - p. -Proof. -intros n m p LE. -apply (add_le_mono_r _ _ p). -rewrite sub_add. -- assumption. -- apply le_trans with (n+p); trivial. - rewrite <- (add_0_l p) at 1. rewrite <- add_le_mono_r. apply le_0_l. -Qed. - -(** Unfortunately, we do not have [n <= m - p -> n + p <= m]. - For instance [0<=1-2] but not [2+0<=1]. *) - -Theorem le_add_le_sub_l : forall n m p, n + p <= m -> p <= m - n. -Proof. -intros n m p. rewrite add_comm; apply le_add_le_sub_r. -Qed. - -Theorem lt_add_lt_sub_r : forall n m p, n + p < m <-> n < m - p. -Proof. -intros n m p. -destruct (le_ge_cases p m) as [LE|GE]. -- rewrite <- (sub_add p m) at 1 by assumption. - now rewrite <- add_lt_mono_r. -- assert (GE' := GE). rewrite <- sub_0_le in GE'; rewrite GE'. - split; intros LT. - + elim (lt_irrefl m). apply le_lt_trans with (n+p); trivial. - rewrite <- (add_0_l m). apply add_le_mono. - * apply le_0_l. - * assumption. - + now elim (nlt_0_r n). -Qed. - -Theorem lt_add_lt_sub_l : forall n m p, n + p < m <-> p < m - n. -Proof. -intros n m p. rewrite add_comm; apply lt_add_lt_sub_r. -Qed. - -Theorem sub_lt : forall n m, m <= n -> 0 < m -> n - m < n. -Proof. -intros n m LE LT. -assert (LE' := le_sub_l n m). rewrite lt_eq_cases in LE'. -destruct LE' as [LT'|EQ]. -- assumption. -- apply add_sub_eq_nz in EQ; [|order]. - rewrite (add_lt_mono_r _ _ n), add_0_l in LT. order. -Qed. - -Lemma sub_le_mono_r : forall n m p, n <= m -> n-p <= m-p. -Proof. - intros n m p. rewrite le_sub_le_add_r. - transitivity m. - - assumption. - - apply sub_add_le. -Qed. - -Lemma sub_le_mono_l : forall n m p, n <= m -> p-m <= p-n. -Proof. - intros n m p. rewrite le_sub_le_add_r. - transitivity (p-n+n); [ apply sub_add_le | now apply add_le_mono_l]. -Qed. - -Theorem sub_sub_distr : - forall n m p, p <= m -> m <= n -> n - (m - p) == (n - m) + p. -Proof. - intros n m p; revert n m; induct p. - - intros n m _ _; rewrite add_0_r, sub_0_r; reflexivity. - - intros p IH n m H1 H2; rewrite add_succ_r. - destruct (zero_or_succ m) as [Hm | [k Hk]]. - + contradict H1; rewrite Hm; exact (nle_succ_0 _). - + rewrite Hk in *; clear m Hk; rewrite sub_succ; apply <-succ_le_mono in H1. - assert (n - k ~= 0) as ne by (apply sub_gt, le_succ_l; exact H2). - rewrite sub_succ_r, add_pred_l by (exact ne). - rewrite succ_pred by (intros [[]%ne _]%eq_add_0). - apply IH with (1 := H1), le_trans with (2 := H2). - exact (le_succ_diag_r _). -Qed. - -(** Sub and mul *) - -Theorem mul_pred_r : forall n m, n * (P m) == n * m - n. -Proof. -intros n m; cases m. -- now rewrite pred_0, mul_0_r, sub_0_l. -- intro m; rewrite pred_succ, mul_succ_r, <- add_sub_assoc. - + now rewrite sub_diag, add_0_r. - + now apply eq_le_incl. -Qed. - -Theorem mul_sub_distr_r : forall n m p, (n - m) * p == n * p - m * p. -Proof. -intros n m p; induct n. -- now rewrite sub_0_l, mul_0_l, sub_0_l. -- intros n IH. destruct (le_gt_cases m n) as [H | H]. - + rewrite sub_succ_l by assumption. do 2 rewrite mul_succ_l. - rewrite (add_comm ((n - m) * p) p), (add_comm (n * p) p). - rewrite <- (add_sub_assoc p (n * p) (m * p)) by now apply mul_le_mono_r. - now apply add_cancel_l. - + assert (H1 : S n <= m) by now apply le_succ_l. - setoid_replace (S n - m) with 0 by now apply sub_0_le. - setoid_replace ((S n * p) - m * p) with 0 by (apply sub_0_le; now apply mul_le_mono_r). - apply mul_0_l. -Qed. - -Theorem mul_sub_distr_l : forall n m p, p * (n - m) == p * n - p * m. -Proof. -intros n m p; rewrite (mul_comm p (n - m)), (mul_comm p n), (mul_comm p m). -apply mul_sub_distr_r. -Qed. - -(** Alternative definitions of [<=] and [<] based on [+] *) - -Definition le_alt n m := exists p, p + n == m. -Definition lt_alt n m := exists p, S p + n == m. - -Lemma le_equiv : forall n m, le_alt n m <-> n <= m. -Proof. -intros n m; split. -- intros (p,H). rewrite <- H, add_comm. apply le_add_r. -- intro H. exists (m-n). now apply sub_add. -Qed. - -Lemma lt_equiv : forall n m, lt_alt n m <-> n < m. -Proof. -intros n m; split. -- intros (p,H). rewrite <- H, add_succ_l, lt_succ_r, add_comm. apply le_add_r. -- intro H. exists (m-S n). rewrite add_succ_l, <- add_succ_r. - apply sub_add. now rewrite le_succ_l. -Qed. - -#[global] -Instance le_alt_wd : Proper (eq==>eq==>iff) le_alt. -Proof. - intros x x' Hx y y' Hy; unfold le_alt. - setoid_rewrite Hx. setoid_rewrite Hy. auto with *. -Qed. - -#[global] -Instance lt_alt_wd : Proper (eq==>eq==>iff) lt_alt. -Proof. - intros x x' Hx y y' Hy; unfold lt_alt. - setoid_rewrite Hx. setoid_rewrite Hy. auto with *. -Qed. - -(** With these alternative definition, the dichotomy: - -[forall n m, n <= m \/ m <= n] - -becomes: - -[forall n m, (exists p, p + n == m) \/ (exists p, p + m == n)] - -We will need this in the proof of induction principle for integers -constructed as pairs of natural numbers. This formula can be proved -from know properties of [<=]. However, it can also be done directly. *) - -Theorem le_alt_dichotomy : forall n m, le_alt n m \/ le_alt m n. -Proof. -intros n m; induct n. -- left; exists m; apply add_0_r. -- intros n IH. - destruct IH as [[p H] | [p H]]. - + destruct (zero_or_succ p) as [H1 | [p' H1]]; rewrite H1 in H. - * rewrite add_0_l in H. right; exists (S 0); rewrite H, add_succ_l; - now rewrite add_0_l. - * left; exists p'; rewrite add_succ_r; now rewrite add_succ_l in H. - + right; exists (S p). rewrite add_succ_l; now rewrite H. -Qed. - -Theorem add_dichotomy : - forall n m, (exists p, p + n == m) \/ (exists p, p + m == n). -Proof. exact le_alt_dichotomy. Qed. - -End NSubProp. diff --git a/stdlib/theories/Numbers/Natural/Binary/NBinary.v b/stdlib/theories/Numbers/Natural/Binary/NBinary.v deleted file mode 100644 index 279a637c5241..000000000000 --- a/stdlib/theories/Numbers/Natural/Binary/NBinary.v +++ /dev/null @@ -1,51 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* 0 -| xO p' => N.succ (binposlog p') -| xI p' => N.succ (binposlog p') -end. - -Definition binlog (n : N) : N := -match n with -| 0 => 0 -| Npos p => binposlog p -end. - -Time Eval vm_compute in (binlog 500000). (* 0 sec *) -Time Eval vm_compute in (binlog 1000000000000000000000000000000). (* 0 sec *) - -*) diff --git a/stdlib/theories/Numbers/NumPrelude.v b/stdlib/theories/Numbers/NumPrelude.v deleted file mode 100644 index 82b4d0d77aa3..000000000000 --- a/stdlib/theories/Numbers/NumPrelude.v +++ /dev/null @@ -1,25 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* Gt. -Definition ge x y := (x ?= y) <> Lt. - -Infix "<=" := le : positive_scope. -Infix "<" := lt : positive_scope. -Infix ">=" := ge : positive_scope. -Infix ">" := gt : positive_scope. - -Notation "x <= y <= z" := (x <= y /\ y <= z) : positive_scope. -Notation "x <= y < z" := (x <= y /\ y < z) : positive_scope. -Notation "x < y < z" := (x < y /\ y < z) : positive_scope. -Notation "x < y <= z" := (x < y /\ y <= z) : positive_scope. - -(**********************************************************************) -(** * Properties of operations over positive numbers *) - -(** ** Decidability of equality on binary positive numbers *) - -Lemma eq_dec : forall x y:positive, {x = y} + {x <> y}. -Proof. - decide equality. -Defined. - -(**********************************************************************) -(** * Properties of successor on binary positive numbers *) - -(** ** Specification of [xI] in term of [succ] and [xO] *) - -Lemma xI_succ_xO p : p~1 = succ p~0. -Proof. - reflexivity. -Qed. - -Lemma succ_discr p : p <> succ p. -Proof. - now destruct p. -Qed. - -(** ** Successor and double *) - -Lemma pred_double_spec p : pred_double p = pred (p~0). -Proof. - reflexivity. -Qed. - -Lemma succ_pred_double p : succ (pred_double p) = p~0. -Proof. - induction p; simpl; now f_equal. -Qed. - -Lemma pred_double_succ p : pred_double (succ p) = p~1. -Proof. - induction p; simpl; now f_equal. -Qed. - -Lemma double_succ p : (succ p)~0 = succ (succ p~0). -Proof. - now destruct p. -Qed. - -Lemma pred_double_xO_discr p : pred_double p <> p~0. -Proof. - now destruct p. -Qed. - -(** ** Successor and predecessor *) - -Lemma succ_not_1 p : succ p <> 1. -Proof. - now destruct p. -Qed. - -Lemma pred_succ p : pred (succ p) = p. -Proof. - destruct p; simpl; trivial. apply pred_double_succ. -Qed. - -Lemma succ_pred_or p : p = 1 \/ succ (pred p) = p. -Proof. - destruct p; simpl; auto. - right; apply succ_pred_double. -Qed. - -Lemma succ_pred p : p <> 1 -> succ (pred p) = p. -Proof. - destruct p; intros H; simpl; trivial. - - apply succ_pred_double. - - now destruct H. -Qed. - -(** ** Injectivity of successor *) - -Lemma succ_inj p q : succ p = succ q -> p = q. -Proof. - revert q. - induction p as [p|p|]; intros [q|q| ] H; simpl in H; destr_eq H; f_equal; auto. - - elim (succ_not_1 p); auto. - - elim (succ_not_1 q); auto. -Qed. - -(** ** Predecessor to [N] *) - -Lemma pred_N_succ p : pred_N (succ p) = Npos p. -Proof. - destruct p; simpl; trivial. f_equal. apply pred_double_succ. -Qed. - - -(**********************************************************************) -(** * Properties of addition on binary positive numbers *) - -(** ** Specification of [succ] in term of [add] *) - -Lemma add_1_r p : p + 1 = succ p. -Proof. - now destruct p. -Qed. - -Lemma add_1_l p : 1 + p = succ p. -Proof. - now destruct p. -Qed. - -(** ** Specification of [add_carry] *) - -Theorem add_carry_spec p q : add_carry p q = succ (p + q). -Proof. - revert q. induction p; intro q; destruct q; simpl; now f_equal. -Qed. - -(** ** Commutativity *) - -Theorem add_comm p q : p + q = q + p. -Proof. - revert q. induction p; intro q; destruct q; simpl; f_equal; trivial. - rewrite 2 add_carry_spec; now f_equal. -Qed. - -(** ** Permutation of [add] and [succ] *) - -Theorem add_succ_r p q : p + succ q = succ (p + q). -Proof. - revert q. - induction p; intro q; destruct q; simpl; f_equal; - auto using add_1_r; rewrite add_carry_spec; auto. -Qed. - -Theorem add_succ_l p q : succ p + q = succ (p + q). -Proof. - rewrite add_comm, (add_comm p). apply add_succ_r. -Qed. - -(** ** No neutral elements for addition *) -Lemma add_no_neutral p q : q + p <> p. -Proof. - revert q. - induction p as [p IHp|p IHp| ]; intros [q|q| ] H; - destr_eq H; apply (IHp q H). -Qed. - -(** ** Simplification *) - -Lemma add_carry_add p q r s : - add_carry p r = add_carry q s -> p + r = q + s. -Proof. - intros H; apply succ_inj; now rewrite <- 2 add_carry_spec. -Qed. - -Lemma add_reg_r p q r : p + r = q + r -> p = q. -Proof. - revert p q. induction r. - - intros [p|p| ] [q|q| ] H; simpl; destr_eq H; f_equal; - auto using add_carry_add; contradict H; - rewrite add_carry_spec, <- add_succ_r; auto using add_no_neutral. - - intros [p|p| ] [q|q| ] H; simpl; destr_eq H; f_equal; auto; - contradict H; auto using add_no_neutral. - - intros p q H. apply succ_inj. now rewrite <- 2 add_1_r. -Qed. - -Lemma add_reg_l p q r : p + q = p + r -> q = r. -Proof. - rewrite 2 (add_comm p). now apply add_reg_r. -Qed. - -Lemma add_cancel_r p q r : p + r = q + r <-> p = q. -Proof. - split. - - apply add_reg_r. - - congruence. -Qed. - -Lemma add_cancel_l p q r : r + p = r + q <-> p = q. -Proof. - split. - - apply add_reg_l. - - congruence. -Qed. - -Lemma add_carry_reg_r p q r : - add_carry p r = add_carry q r -> p = q. -Proof. - intros H. apply (add_reg_r _ _ r); now apply add_carry_add. -Qed. - -Lemma add_carry_reg_l p q r : - add_carry p q = add_carry p r -> q = r. -Proof. - intros H; apply (add_reg_r _ _ p); - rewrite (add_comm r), (add_comm q); now apply add_carry_add. -Qed. - -(** ** Addition is associative *) - -Theorem add_assoc p q r : p + (q + r) = p + q + r. -Proof. - revert q r. induction p. - - intros [q|q| ] [r|r| ]; simpl; f_equal; trivial; - rewrite ?add_carry_spec, ?add_succ_r, ?add_succ_l, ?add_1_r; - f_equal; trivial. - - intros [q|q| ] [r|r| ]; simpl; f_equal; trivial; - rewrite ?add_carry_spec, ?add_succ_r, ?add_succ_l, ?add_1_r; - f_equal; trivial. - - intros q r; rewrite 2 add_1_l, add_succ_l; auto. -Qed. - -(** ** Commutation of addition and double *) - -Lemma add_xO p q : (p + q)~0 = p~0 + q~0. -Proof. - now destruct p, q. -Qed. - -Lemma add_xI_pred_double p q : - (p + q)~0 = p~1 + pred_double q. -Proof. - change (p~1) with (p~0 + 1). - now rewrite <- add_assoc, add_1_l, succ_pred_double. -Qed. - -Lemma add_xO_pred_double p q : - pred_double (p + q) = p~0 + pred_double q. -Proof. - revert q. induction p as [p IHp| p IHp| ]; intro q; destruct q; simpl; - rewrite ?add_carry_spec, ?pred_double_succ, ?add_xI_pred_double; - try reflexivity. - - rewrite IHp; auto. - - rewrite <- succ_pred_double, <- add_1_l. reflexivity. -Qed. - -(** ** Miscellaneous *) - -Lemma add_diag p : p + p = p~0. -Proof. - induction p as [p IHp| p IHp| ]; simpl; - now rewrite ?add_carry_spec, ?IHp. -Qed. - -(**********************************************************************) -(** * Peano induction and recursion on binary positive positive numbers *) - -(** The Peano-like recursor function for [positive] (due to Daniel Schepler) *) - -Fixpoint peano_rect (P:positive->Type) (a:P 1) - (f: forall p:positive, P p -> P (succ p)) (p:positive) : P p := -let f2 := peano_rect (fun p:positive => P (p~0)) (f _ a) - (fun (p:positive) (x:P (p~0)) => f _ (f _ x)) -in -match p with - | q~1 => f _ (f2 q) - | q~0 => f2 q - | 1 => a -end. - -Theorem peano_rect_succ (P:positive->Type) (a:P 1) - (f:forall p, P p -> P (succ p)) (p:positive) : - peano_rect P a f (succ p) = f _ (peano_rect P a f p). -Proof. - revert P a f. induction p as [p IHp|p IHp|]; trivial. - intros. simpl. now rewrite IHp. -Qed. - -Theorem peano_rect_base (P:positive->Type) (a:P 1) - (f:forall p, P p -> P (succ p)) : - peano_rect P a f 1 = a. -Proof. - trivial. -Qed. - -Definition peano_rec (P:positive->Set) := peano_rect P. - -(** Peano induction *) - -Definition peano_ind (P:positive->Prop) := peano_rect P. - -(** Peano case analysis *) - -Theorem peano_case : - forall P:positive -> Prop, - P 1 -> (forall n:positive, P (succ n)) -> forall p:positive, P p. -Proof. - intros; apply peano_ind; auto. -Qed. - -(** Earlier, the Peano-like recursor was built and proved in a way due to - Conor McBride, see "The view from the left" *) - -Inductive PeanoView : positive -> Type := -| PeanoOne : PeanoView 1 -| PeanoSucc : forall p, PeanoView p -> PeanoView (succ p). - -Fixpoint peanoView_xO p (q:PeanoView p) : PeanoView (p~0) := - match q in PeanoView x return PeanoView (x~0) with - | PeanoOne => PeanoSucc _ PeanoOne - | PeanoSucc _ q => PeanoSucc _ (PeanoSucc _ (peanoView_xO _ q)) - end. - -Fixpoint peanoView_xI p (q:PeanoView p) : PeanoView (p~1) := - match q in PeanoView x return PeanoView (x~1) with - | PeanoOne => PeanoSucc _ (PeanoSucc _ PeanoOne) - | PeanoSucc _ q => PeanoSucc _ (PeanoSucc _ (peanoView_xI _ q)) - end. - -Fixpoint peanoView p : PeanoView p := - match p return PeanoView p with - | 1 => PeanoOne - | p~0 => peanoView_xO p (peanoView p) - | p~1 => peanoView_xI p (peanoView p) - end. - -Definition PeanoView_iter (P:positive->Type) - (a:P 1) (f:forall p, P p -> P (succ p)) := - (fix iter p (q:PeanoView p) : P p := - match q in PeanoView p return P p with - | PeanoOne => a - | PeanoSucc _ q => f _ (iter _ q) - end). - -Theorem eq_dep_eq_positive : - forall (P:positive->Type) (p:positive) (x y:P p), - eq_dep positive P p x p y -> x = y. -Proof. - apply eq_dep_eq_dec. - decide equality. -Qed. - -Theorem PeanoViewUnique : forall p (q q':PeanoView p), q = q'. -Proof. - intros p q q'. - induction q as [ | p q IHq ]. - - apply eq_dep_eq_positive. - cut (1=1). - + pattern 1 at 1 2 5, q'. destruct q' as [|p ?]. - * trivial. - * destruct p; intros; discriminate. - + trivial. - - apply eq_dep_eq_positive. - cut (succ p=succ p). - + pattern (succ p) at 1 2 5, q'. destruct q' as [|? q']. - * intro. destruct p; discriminate. - * intro H. apply succ_inj in H. - generalize q'. rewrite H. intro q'0. - rewrite (IHq q'0). - trivial. - + trivial. -Qed. - -Lemma peano_equiv (P:positive->Type) (a:P 1) (f:forall p, P p -> P (succ p)) p : - PeanoView_iter P a f p (peanoView p) = peano_rect P a f p. -Proof. - revert P a f. induction p as [|p IHp] using peano_rect. - - trivial. - - intros; simpl. rewrite peano_rect_succ. - rewrite (PeanoViewUnique _ (peanoView (succ p)) (PeanoSucc _ (peanoView p))). - simpl; now f_equal. -Qed. - -(**********************************************************************) -(** * Properties of multiplication on binary positive numbers *) - -(** ** One is neutral for multiplication *) - -Lemma mul_1_l p : 1 * p = p. -Proof. - reflexivity. -Qed. - -Lemma mul_1_r p : p * 1 = p. -Proof. - induction p; simpl; now f_equal. -Qed. - -(** ** Right reduction properties for multiplication *) - -Lemma mul_xO_r p q : p * q~0 = (p * q)~0. -Proof. - induction p; simpl; f_equal; f_equal; trivial. -Qed. - -Lemma mul_xI_r p q : p * q~1 = p + (p * q)~0. -Proof. - induction p as [p IHp|p IHp| ]; simpl; f_equal; trivial. - now rewrite IHp, 2 add_assoc, (add_comm p). -Qed. - -(** ** Commutativity of multiplication *) - -Theorem mul_comm p q : p * q = q * p. -Proof. - induction q as [q IHq|q IHq| ]; simpl; rewrite <- ? IHq; - auto using mul_xI_r, mul_xO_r, mul_1_r. -Qed. - -(** ** Distributivity of multiplication over addition *) - -Theorem mul_add_distr_l p q r : - p * (q + r) = p * q + p * r. -Proof. - induction p as [p IHp|p IHp| ]; simpl. - - rewrite IHp. set (m:=(p*q)~0). set (n:=(p*r)~0). - change ((p*q+p*r)~0) with (m+n). - rewrite 2 add_assoc; f_equal. - rewrite <- 2 add_assoc; f_equal. - apply add_comm. - - f_equal; auto. - - reflexivity. -Qed. - -Theorem mul_add_distr_r p q r : - (p + q) * r = p * r + q * r. -Proof. - rewrite 3 (mul_comm _ r); apply mul_add_distr_l. -Qed. - -(** ** Associativity of multiplication *) - -Theorem mul_assoc p q r : p * (q * r) = p * q * r. -Proof. - induction p as [p IHp| p IHp | ]; simpl; rewrite ?IHp; trivial. - now rewrite mul_add_distr_r. -Qed. - -(** ** Successor and multiplication *) - -Lemma mul_succ_l p q : (succ p) * q = q + p * q. -Proof. - induction p as [p IHp | p IHp | ]; simpl; trivial. - - now rewrite IHp, add_assoc, add_diag, <-add_xO. - - symmetry; apply add_diag. -Qed. - -Lemma mul_succ_r p q : p * (succ q) = p + p * q. -Proof. - rewrite mul_comm, mul_succ_l. f_equal. apply mul_comm. -Qed. - -(** ** Parity properties of multiplication *) - -Lemma mul_xI_mul_xO_discr p q r : p~1 * r <> q~0 * r. -Proof. - induction r; try discriminate. - rewrite 2 mul_xO_r; intro H; destr_eq H; auto. -Qed. - -Lemma mul_xO_discr p q : p~0 * q <> q. -Proof. - induction q; try discriminate. - rewrite mul_xO_r; injection; auto. -Qed. - -(** ** Simplification properties of multiplication *) - -Theorem mul_reg_r p q r : p * r = q * r -> p = q. -Proof. - revert q r. - induction p as [p IHp| p IHp| ]; intros [q|q| ] r H; - reflexivity || apply f_equal || exfalso. - - apply IHp with (r~0). simpl in *. - rewrite 2 mul_xO_r. apply add_reg_l with (1:=H). - - contradict H. apply mul_xI_mul_xO_discr. - - contradict H. simpl. rewrite add_comm. apply add_no_neutral. - - symmetry in H. contradict H. apply mul_xI_mul_xO_discr. - - apply IHp with (r~0). simpl. now rewrite 2 mul_xO_r. - - contradict H. apply mul_xO_discr. - - symmetry in H. contradict H. simpl. rewrite add_comm. - apply add_no_neutral. - - symmetry in H. contradict H. apply mul_xO_discr. -Qed. - -Theorem mul_reg_l p q r : r * p = r * q -> p = q. -Proof. - rewrite 2 (mul_comm r). apply mul_reg_r. -Qed. - -Lemma mul_cancel_r p q r : p * r = q * r <-> p = q. -Proof. - split. - - apply mul_reg_r. - - congruence. -Qed. - -Lemma mul_cancel_l p q r : r * p = r * q <-> p = q. -Proof. - split. - - apply mul_reg_l. - - congruence. -Qed. - -(** ** Inversion of multiplication *) - -Lemma mul_eq_1_l p q : p * q = 1 -> p = 1. -Proof. - now destruct p, q. -Qed. - -Lemma mul_eq_1_r p q : p * q = 1 -> q = 1. -Proof. - now destruct p, q. -Qed. - -Notation mul_eq_1 := mul_eq_1_l. - -(** ** Square *) - -Lemma square_xO p : p~0 * p~0 = (p*p)~0~0. -Proof. - simpl. now rewrite mul_comm. -Qed. - -Lemma square_xI p : p~1 * p~1 = (p*p+p)~0~1. -Proof. - simpl. rewrite mul_comm. simpl. f_equal. - rewrite add_assoc, add_diag. simpl. now rewrite add_comm. -Qed. - -(** ** Properties of [iter] *) - -Lemma iter_swap_gen A B (f:A->B)(g:A->A)(h:B->B) : - (forall a, f (g a) = h (f a)) -> forall p a, - f (iter g a p) = iter h (f a) p. -Proof. - intros H p; induction p as [p IHp|p IHp|]; simpl; intros; now rewrite ?H, ?IHp. -Qed. - -Theorem iter_swap : - forall p (A:Type) (f:A -> A) (x:A), - iter f (f x) p = f (iter f x p). -Proof. - intros. symmetry. now apply iter_swap_gen. -Qed. - -Theorem iter_succ : - forall p (A:Type) (f:A -> A) (x:A), - iter f x (succ p) = f (iter f x p). -Proof. - intro p; induction p as [p IHp|p IHp|]; intros; simpl; trivial. - now rewrite !IHp, iter_swap. -Qed. - -Theorem iter_succ_r : - forall p (A:Type) (f:A -> A) (x:A), - iter f x (succ p) = iter f (f x) p. -Proof. - intros; now rewrite iter_succ, iter_swap. -Qed. - -Theorem iter_add : - forall p q (A:Type) (f:A -> A) (x:A), - iter f x (p+q) = iter f (iter f x q) p. -Proof. - intro p; induction p as [|p IHp] using peano_ind; intros. - - now rewrite add_1_l, iter_succ. - - now rewrite add_succ_l, !iter_succ, IHp. -Qed. - -Theorem iter_ind (A:Type) (f:A -> A) (a:A) (P:positive -> A -> Prop) : - P 1 (f a) -> - (forall p a', P p a' -> P (succ p) (f a')) -> - forall p, P p (iter f a p). -Proof. - intros ? ? p; induction p as [|p IHp] using peano_ind; trivial. - rewrite iter_succ; auto. -Qed. - -Theorem iter_invariant : - forall (p:positive) (A:Type) (f:A -> A) (Inv:A -> Prop), - (forall x:A, Inv x -> Inv (f x)) -> - forall x:A, Inv x -> Inv (iter f x p). -Proof. - intros; apply iter_ind; auto. -Qed. - -(** ** Properties of power *) - -Lemma pow_1_r p : p^1 = p. -Proof. - unfold pow. simpl. now rewrite mul_comm. -Qed. - -Lemma pow_succ_r p q : p^(succ q) = p * p^q. -Proof. - unfold pow. now rewrite iter_succ. -Qed. - -(** ** Properties of square *) - -Lemma square_spec p : square p = p * p. -Proof. - induction p as [p IHp|p IHp|]. - - rewrite square_xI. simpl. now rewrite IHp. - - rewrite square_xO. simpl. now rewrite IHp. - - trivial. -Qed. - -(** ** Properties of [sub_mask] *) - -Lemma sub_mask_succ_r p q : - sub_mask p (succ q) = sub_mask_carry p q. -Proof. - revert q. induction p as [p ?|p ?|]; intro q; destruct q; - simpl; f_equal; trivial; now destruct p. -Qed. - -Theorem sub_mask_carry_spec p q : - sub_mask_carry p q = pred_mask (sub_mask p q). -Proof. - revert q. induction p as [p IHp|p IHp|]; intro q; destruct q as [q|q|]; simpl; - try reflexivity; rewrite ?IHp; - destruct (sub_mask p q) as [|[r|r| ]|] || destruct p; auto. -Qed. - -Inductive SubMaskSpec (p q : positive) : mask -> Prop := - | SubIsNul : p = q -> SubMaskSpec p q IsNul - | SubIsPos : forall r, q + r = p -> SubMaskSpec p q (IsPos r) - | SubIsNeg : forall r, p + r = q -> SubMaskSpec p q IsNeg. - -Theorem sub_mask_spec p q : SubMaskSpec p q (sub_mask p q). -Proof. - revert q. induction p as [p IHp|p IHp|]; intro q; destruct q as [q|q|]; - simpl; try constructor; trivial. - - (* p~1 q~1 *) - destruct (IHp q) as [|r|r]; subst; try now constructor. - now apply SubIsNeg with r~0. - - (* p~1 q~0 *) - destruct (IHp q) as [|r|r]; subst; try now constructor. - apply SubIsNeg with (pred_double r). symmetry. apply add_xI_pred_double. - - (* p~0 q~1 *) - rewrite sub_mask_carry_spec. - destruct (IHp q) as [|r|r]; subst; try constructor. - + now apply SubIsNeg with 1. - + destruct r; simpl; try constructor; simpl. - * now rewrite add_carry_spec, <- add_succ_r. - * now rewrite add_carry_spec, <- add_succ_r, succ_pred_double. - * now rewrite add_1_r. - + now apply SubIsNeg with r~1. - - (* p~0 q~0 *) - destruct (IHp q) as [|r|r]; subst; try now constructor. - now apply SubIsNeg with r~0. - - (* p~0 1 *) - now rewrite add_1_l, succ_pred_double. - - (* 1 q~1 *) - now apply SubIsNeg with q~0. - - (* 1 q~0 *) - apply SubIsNeg with (pred_double q). now rewrite add_1_l, succ_pred_double. -Qed. - -Theorem sub_mask_nul_iff p q : sub_mask p q = IsNul <-> p = q. -Proof. - split. - - now case sub_mask_spec. - - intros <-. induction p as [p IHp|p IHp|]; simpl; now rewrite ?IHp. -Qed. - -Theorem sub_mask_diag p : sub_mask p p = IsNul. -Proof. - now apply sub_mask_nul_iff. -Qed. - -Lemma sub_mask_add p q r : sub_mask p q = IsPos r -> q + r = p. -Proof. - case sub_mask_spec; congruence. -Qed. - -Lemma sub_mask_add_diag_l p q : sub_mask (p+q) p = IsPos q. -Proof. - case sub_mask_spec. - - intros H. rewrite add_comm in H. elim (add_no_neutral _ _ H). - - intros r H. apply add_cancel_l in H. now f_equal. - - intros r H. rewrite <- add_assoc, add_comm in H. elim (add_no_neutral _ _ H). -Qed. - -Lemma sub_mask_pos_iff p q r : sub_mask p q = IsPos r <-> q + r = p. -Proof. - split. - - apply sub_mask_add. - - intros <-; apply sub_mask_add_diag_l. -Qed. - -Lemma sub_mask_add_diag_r p q : sub_mask p (p+q) = IsNeg. -Proof. - case sub_mask_spec; trivial. - - intros H. symmetry in H; rewrite add_comm in H. elim (add_no_neutral _ _ H). - - intros r H. rewrite <- add_assoc, add_comm in H. elim (add_no_neutral _ _ H). -Qed. - -Lemma sub_mask_neg_iff p q : sub_mask p q = IsNeg <-> exists r, p + r = q. -Proof. - split. - - case sub_mask_spec; try discriminate. intros r Hr _; now exists r. - - intros (r,<-). apply sub_mask_add_diag_r. -Qed. - -(*********************************************************************) -(** * Properties of boolean comparisons *) - -Theorem eqb_eq p q : (p =? q) = true <-> p=q. -Proof. - revert q. induction p as [p IHp|p IHp|]; intro q; destruct q; - simpl; rewrite ?IHp; split; congruence. -Qed. - -Theorem ltb_lt p q : (p p < q. -Proof. - unfold ltb, lt. destruct compare; easy'. -Qed. - -Theorem leb_le p q : (p <=? q) = true <-> p <= q. -Proof. - unfold leb, le. destruct compare; easy'. -Qed. - -(** More about [eqb] *) - -Include BoolEqualityFacts. - -(**********************************************************************) -(** * Properties of comparison on binary positive numbers *) - -(** First, we express [compare_cont] in term of [compare] *) - -Definition switch_Eq c c' := - match c' with - | Eq => c - | Lt => Lt - | Gt => Gt - end. - -Lemma compare_cont_spec p q c : - compare_cont c p q = switch_Eq c (p ?= q). -Proof. - unfold compare. - revert q c. - induction p as [p IHp|p IHp|]; intro q; destruct q as [q|q|]; simpl; trivial. - - intros c. - rewrite 2 IHp. now destruct (compare_cont Eq p q). - - intros c. - rewrite 2 IHp. now destruct (compare_cont Eq p q). -Qed. - -(** From this general result, we now describe particular cases - of [compare_cont p q c = c'] : - - When [c=Eq], this is directly [compare] - - When [c<>Eq], we'll show first that [c'<>Eq] - - That leaves only 4 lemmas for [c] and [c'] being [Lt] or [Gt] -*) - -Theorem compare_cont_Eq p q c : - compare_cont c p q = Eq -> c = Eq. -Proof. - rewrite compare_cont_spec. now destruct (p ?= q). -Qed. - -Lemma compare_cont_Lt_Gt p q : - compare_cont Lt p q = Gt <-> p > q. -Proof. - rewrite compare_cont_spec. unfold gt. destruct (p ?= q); now split. -Qed. - -Lemma compare_cont_Lt_Lt p q : - compare_cont Lt p q = Lt <-> p <= q. -Proof. - rewrite compare_cont_spec. unfold le. destruct (p ?= q); easy'. -Qed. - -Lemma compare_cont_Gt_Lt p q : - compare_cont Gt p q = Lt <-> p < q. -Proof. - rewrite compare_cont_spec. unfold lt. destruct (p ?= q); now split. -Qed. - -Lemma compare_cont_Gt_Gt p q : - compare_cont Gt p q = Gt <-> p >= q. -Proof. - rewrite compare_cont_spec. unfold ge. destruct (p ?= q); easy'. -Qed. - -Lemma compare_cont_Lt_not_Lt p q : - compare_cont Lt p q <> Lt <-> p > q. -Proof. - rewrite compare_cont_Lt_Lt. - unfold gt, le, compare. - now destruct compare_cont; split; try apply comparison_eq_stable. -Qed. - -Lemma compare_cont_Lt_not_Gt p q : - compare_cont Lt p q <> Gt <-> p <= q. -Proof. - apply not_iff_compat, compare_cont_Lt_Gt. -Qed. - -Lemma compare_cont_Gt_not_Lt p q : - compare_cont Gt p q <> Lt <-> p >= q. -Proof. - apply not_iff_compat, compare_cont_Gt_Lt. -Qed. - -Lemma compare_cont_Gt_not_Gt p q : - compare_cont Gt p q <> Gt <-> p < q. -Proof. - rewrite compare_cont_Gt_Gt. - unfold ge, lt, compare. - now destruct compare_cont; split; try apply comparison_eq_stable. -Qed. - -(** We can express recursive equations for [compare] *) - -Lemma compare_xO_xO p q : (p~0 ?= q~0) = (p ?= q). -Proof. reflexivity. Qed. - -Lemma compare_xI_xI p q : (p~1 ?= q~1) = (p ?= q). -Proof. reflexivity. Qed. - -Lemma compare_xI_xO p q : - (p~1 ?= q~0) = switch_Eq Gt (p ?= q). -Proof. exact (compare_cont_spec p q Gt). Qed. - -Lemma compare_xO_xI p q : - (p~0 ?= q~1) = switch_Eq Lt (p ?= q). -Proof. exact (compare_cont_spec p q Lt). Qed. - -Global Hint Rewrite compare_xO_xO compare_xI_xI compare_xI_xO compare_xO_xI : compare. - -Ltac simpl_compare := autorewrite with compare. -Ltac simpl_compare_in H := autorewrite with compare in H. - -(** Relation between [compare] and [sub_mask] *) - -Definition mask2cmp (p:mask) : comparison := - match p with - | IsNul => Eq - | IsPos _ => Gt - | IsNeg => Lt - end. - -Lemma compare_sub_mask p q : (p ?= q) = mask2cmp (sub_mask p q). -Proof. - revert q. - induction p as [p IHp| p IHp| ]; intros [q|q| ]; simpl; trivial; - specialize (IHp q); rewrite ?sub_mask_carry_spec; - destruct (sub_mask p q) as [|r|]; simpl in *; - try clear r; try destruct r; simpl; trivial; - simpl_compare; now rewrite IHp. -Qed. - -(** Alternative characterisation of strict order in term of addition *) - -Lemma lt_iff_add p q : p < q <-> exists r, p + r = q. -Proof. - unfold "<". rewrite <- sub_mask_neg_iff, compare_sub_mask. - destruct sub_mask; now split. -Qed. - -Lemma gt_iff_add p q : p > q <-> exists r, q + r = p. -Proof. - unfold ">". rewrite compare_sub_mask. - split. - - case_eq (sub_mask p q); try discriminate; intros r Hr _. - exists r. now apply sub_mask_pos_iff. - - intros (r,Hr). apply sub_mask_pos_iff in Hr. now rewrite Hr. -Qed. - -(** Basic facts about [compare_cont] *) - -Theorem compare_cont_refl p c : - compare_cont c p p = c. -Proof. - now induction p. -Qed. - -Lemma compare_cont_antisym p q c : - CompOpp (compare_cont c p q) = compare_cont (CompOpp c) q p. -Proof. - revert q c. - induction p as [p IHp|p IHp| ]; intros [q|q| ] c; simpl; - trivial; apply IHp. -Qed. - -(** Basic facts about [compare] *) - -Lemma compare_eq_iff p q : (p ?= q) = Eq <-> p = q. -Proof. - rewrite compare_sub_mask, <- sub_mask_nul_iff. - destruct sub_mask; now split. -Qed. - -Lemma compare_antisym p q : (q ?= p) = CompOpp (p ?= q). -Proof. - unfold compare. now rewrite compare_cont_antisym. -Qed. - -Lemma compare_lt_iff p q : (p ?= q) = Lt <-> p < q. -Proof. reflexivity. Qed. - -Lemma compare_le_iff p q : (p ?= q) <> Gt <-> p <= q. -Proof. reflexivity. Qed. - -(** More properties about [compare] and boolean comparisons, - including [compare_spec] and [lt_irrefl] and [lt_eq_cases]. *) - -Include BoolOrderFacts. - -Definition le_lteq := lt_eq_cases. - -(** ** Facts about [gt] and [ge] *) - -(** The predicates [lt] and [le] are now favored in the statements - of theorems, the use of [gt] and [ge] is hence not recommended. - We provide here the bare minimal results to related them with - [lt] and [le]. *) - -Lemma gt_lt_iff p q : p > q <-> q < p. -Proof. - unfold lt, gt. now rewrite compare_antisym, CompOpp_iff. -Qed. - -Lemma gt_lt p q : p > q -> q < p. -Proof. - apply gt_lt_iff. -Qed. - -Lemma lt_gt p q : p < q -> q > p. -Proof. - apply gt_lt_iff. -Qed. - -Lemma ge_le_iff p q : p >= q <-> q <= p. -Proof. - unfold le, ge. now rewrite compare_antisym, CompOpp_iff. -Qed. - -Lemma ge_le p q : p >= q -> q <= p. -Proof. - apply ge_le_iff. -Qed. - -Lemma le_ge p q : p <= q -> q >= p. -Proof. - apply ge_le_iff. -Qed. - -(** ** Comparison and the successor *) - -Lemma compare_succ_r p q : - switch_Eq Gt (p ?= succ q) = switch_Eq Lt (p ?= q). -Proof. - revert q. - induction p as [p IH|p IH| ]; intros [q|q| ]; simpl; - simpl_compare; rewrite ?IH; trivial; - (now destruct compare) || (now destruct p). -Qed. - -Lemma compare_succ_l p q : - switch_Eq Lt (succ p ?= q) = switch_Eq Gt (p ?= q). -Proof. - rewrite 2 (compare_antisym q). generalize (compare_succ_r q p). - now do 2 destruct compare. -Qed. - -Theorem lt_succ_r p q : p < succ q <-> p <= q. -Proof. - unfold lt, le. generalize (compare_succ_r p q). - do 2 destruct compare; try discriminate; now split. -Qed. - -Lemma lt_succ_diag_r p : p < succ p. -Proof. - rewrite lt_iff_add. exists 1. apply add_1_r. -Qed. - -Lemma compare_succ_succ p q : (succ p ?= succ q) = (p ?= q). -Proof. - revert q. - induction p as [p|p|]; intro q; destruct q as [q|q|]; - simpl; simpl_compare; trivial; - apply compare_succ_l || apply compare_succ_r || - (now destruct p) || (now destruct q). -Qed. - -(** ** 1 is the least positive number *) - -Lemma le_1_l p : 1 <= p. -Proof. - now destruct p. -Qed. - -Lemma nlt_1_r p : ~ p < 1. -Proof. - now destruct p. -Qed. - -Lemma lt_1_succ p : 1 < succ p. -Proof. - apply lt_succ_r, le_1_l. -Qed. - -(** ** Properties of the order *) - -Lemma le_nlt p q : p <= q <-> ~ q < p. -Proof. - now rewrite <- ge_le_iff. -Qed. - -Lemma lt_nle p q : p < q <-> ~ q <= p. -Proof. - intros. unfold lt, le. rewrite compare_antisym. - destruct compare; split; auto; easy'. -Qed. - -Lemma lt_le_incl p q : p p<=q. -Proof. - intros. apply le_lteq. now left. -Qed. - -Lemma lt_lt_succ n m : n < m -> n < succ m. -Proof. - intros. now apply lt_succ_r, lt_le_incl. -Qed. - -Lemma succ_lt_mono n m : n < m <-> succ n < succ m. -Proof. - unfold lt. now rewrite compare_succ_succ. -Qed. - -Lemma succ_le_mono n m : n <= m <-> succ n <= succ m. -Proof. - unfold le. now rewrite compare_succ_succ. -Qed. - -Lemma lt_trans n m p : n < m -> m < p -> n < p. -Proof. - rewrite 3 lt_iff_add. intros (r,Hr) (s,Hs). - exists (r+s). now rewrite add_assoc, Hr, Hs. -Qed. - -Theorem lt_ind : forall (A : positive -> Prop) (n : positive), - A (succ n) -> - (forall m : positive, n < m -> A m -> A (succ m)) -> - forall m : positive, n < m -> A m. -Proof. - intros A n AB AS m. induction m using peano_ind; intros H. - - elim (nlt_1_r _ H). - - apply lt_succ_r, le_lteq in H. destruct H as [H|H]; subst; auto. -Qed. - -#[global] -Instance lt_strorder : StrictOrder lt. -Proof. - split. - - exact lt_irrefl. - - exact lt_trans. -Qed. - -#[global] -Instance lt_compat : Proper (Logic.eq==>Logic.eq==>iff) lt. -Proof. repeat red. intros. subst; auto. Qed. - -Lemma lt_total p q : p < q \/ p = q \/ q < p. -Proof. - case (compare_spec p q); intuition. -Qed. - -Lemma le_refl p : p <= p. -Proof. - intros. unfold le. now rewrite compare_refl. -Qed. - -Lemma le_lt_trans n m p : n <= m -> m < p -> n < p. -Proof. - intros H H'. apply le_lteq in H. destruct H. - - now apply lt_trans with m. - - now subst. -Qed. - -Lemma lt_le_trans n m p : n < m -> m <= p -> n < p. -Proof. - intros H H'. apply le_lteq in H'. destruct H'. - - now apply lt_trans with m. - - now subst. -Qed. - -Lemma le_trans n m p : n <= m -> m <= p -> n <= p. -Proof. - intros H H'. - apply le_lteq in H. destruct H. - - apply le_lteq; left. now apply lt_le_trans with m. - - now subst. -Qed. - -Lemma le_succ_l n m : succ n <= m <-> n < m. -Proof. - rewrite <- lt_succ_r. symmetry. apply succ_lt_mono. -Qed. - -Lemma le_antisym p q : p <= q -> q <= p -> p = q. -Proof. - rewrite le_lteq; destruct 1; auto. - rewrite le_lteq; destruct 1; auto. - elim (lt_irrefl p). now transitivity q. -Qed. - -#[global] -Instance le_preorder : PreOrder le. -Proof. - split. - - exact le_refl. - - exact le_trans. -Qed. - -#[global] -Instance le_partorder : PartialOrder Logic.eq le. -Proof. - intros x y. change (x=y <-> x <= y <= x). - split. - - intros; now subst. - - destruct 1; now apply le_antisym. -Qed. - -(** ** Comparison and addition *) - -Lemma add_compare_mono_l p q r : (p+q ?= p+r) = (q ?= r). -Proof. - revert q r. induction p using peano_ind; intros q r. - - rewrite 2 add_1_l. apply compare_succ_succ. - - now rewrite 2 add_succ_l, compare_succ_succ. -Qed. - -Lemma add_compare_mono_r p q r : (q+p ?= r+p) = (q ?= r). -Proof. - rewrite 2 (add_comm _ p). apply add_compare_mono_l. -Qed. - -(** ** Order and addition *) - -Lemma lt_add_diag_r p q : p < p + q. -Proof. - rewrite lt_iff_add. now exists q. -Qed. - -Lemma add_lt_mono_l p q r : q p+q < p+r. -Proof. - unfold lt. rewrite add_compare_mono_l. apply iff_refl. -Qed. - -Lemma add_lt_mono_r p q r : q q+p < r+p. -Proof. - unfold lt. rewrite add_compare_mono_r. apply iff_refl. -Qed. - -Lemma add_lt_mono p q r s : p r p+r p+q<=p+r. -Proof. - unfold le. rewrite add_compare_mono_l. apply iff_refl. -Qed. - -Lemma add_le_mono_r p q r : q<=r <-> q+p<=r+p. -Proof. - unfold le. rewrite add_compare_mono_r. apply iff_refl. -Qed. - -Lemma add_le_mono p q r s : p<=q -> r<=s -> p+r <= q+s. -Proof. - intros. apply le_trans with (p+s). - - now apply add_le_mono_l. - - now apply add_le_mono_r. -Qed. - -(** ** Comparison and multiplication *) - -Lemma mul_compare_mono_l p q r : (p*q ?= p*r) = (q ?= r). -Proof. - revert q r. induction p as [p IHp|p IHp|]; simpl; trivial. - intros q r. specialize (IHp q r). - destruct (compare_spec q r). - - subst. apply compare_refl. - - now apply add_lt_mono. - - now apply lt_gt, add_lt_mono, gt_lt. -Qed. - -Lemma mul_compare_mono_r p q r : (q*p ?= r*p) = (q ?= r). -Proof. - rewrite 2 (mul_comm _ p). apply mul_compare_mono_l. -Qed. - -(** ** Order and multiplication *) - -Lemma mul_lt_mono_l p q r : q p*q < p*r. -Proof. - unfold lt. rewrite mul_compare_mono_l. apply iff_refl. -Qed. - -Lemma mul_lt_mono_r p q r : q q*p < r*p. -Proof. - unfold lt. rewrite mul_compare_mono_r. apply iff_refl. -Qed. - -Lemma mul_lt_mono p q r s : p r p*r < q*s. -Proof. - intros. apply lt_trans with (p*s). - - now apply mul_lt_mono_l. - - now apply mul_lt_mono_r. -Qed. - -Lemma mul_le_mono_l p q r : q<=r <-> p*q<=p*r. -Proof. - unfold le. rewrite mul_compare_mono_l. apply iff_refl. -Qed. - -Lemma mul_le_mono_r p q r : q<=r <-> q*p<=r*p. -Proof. - unfold le. rewrite mul_compare_mono_r. apply iff_refl. -Qed. - -Lemma mul_le_mono p q r s : p<=q -> r<=s -> p*r <= q*s. -Proof. - intros. apply le_trans with (p*s). - - now apply mul_le_mono_l. - - now apply mul_le_mono_r. -Qed. - -Lemma lt_add_r p q : p < p+q. -Proof. - induction q as [|q] using peano_ind. - - rewrite add_1_r. apply lt_succ_diag_r. - - apply lt_trans with (p+q); auto. - apply add_lt_mono_l, lt_succ_diag_r. -Qed. - -Lemma lt_not_add_l p q : ~ p+q < p. -Proof. - intro H. elim (lt_irrefl p). - apply lt_trans with (p+q); auto using lt_add_r. -Qed. - -Lemma pow_gt_1 n p : 1 1 exists r, sub_mask p q = IsPos r /\ q + r = p. -Proof. - rewrite lt_iff_add. intros (r,Hr). exists r. split; trivial. - now apply sub_mask_pos_iff. -Qed. - -Lemma sub_mask_pos p q : - q < p -> exists r, sub_mask p q = IsPos r. -Proof. - intros H. destruct (sub_mask_pos' p q H) as (r & Hr & _). now exists r. -Qed. - -Theorem sub_add p q : q < p -> (p-q)+q = p. -Proof. - intros H. destruct (sub_mask_pos p q H) as (r,U). - unfold sub. rewrite U. rewrite add_comm. now apply sub_mask_add. -Qed. - -Lemma add_sub p q : (p+q)-q = p. -Proof. - intros. apply add_reg_r with q. - rewrite sub_add; trivial. - rewrite add_comm. apply lt_add_r. -Qed. - -Lemma mul_sub_distr_l p q r : r p*(q-r) = p*q-p*r. -Proof. - intros H. - apply add_reg_r with (p*r). - rewrite <- mul_add_distr_l. - rewrite sub_add; trivial. - symmetry. apply sub_add; trivial. - now apply mul_lt_mono_l. -Qed. - -Lemma mul_sub_distr_r p q r : q

(p-q)*r = p*r-q*r. -Proof. - intros H. rewrite 3 (mul_comm _ r). now apply mul_sub_distr_l. -Qed. - -Lemma sub_lt_mono_l p q r: q

p r-p < r-q. -Proof. - intros Hqp Hpr. - apply (add_lt_mono_r p). - rewrite sub_add by trivial. - apply le_lt_trans with ((r-q)+q). - - rewrite sub_add by (now apply lt_trans with p). - apply le_refl. - - now apply add_lt_mono_l. -Qed. - -Lemma sub_compare_mono_l p q r : - q

r

(p-q ?= p-r) = (r ?= q). -Proof. - intros Hqp Hrp. - case (compare_spec r q); intros H. - - subst. apply compare_refl. - - apply sub_lt_mono_l; trivial. - - apply lt_gt, sub_lt_mono_l; trivial. -Qed. - -Lemma sub_compare_mono_r p q r : - p p (q-p ?= r-p) = (q ?= r). -Proof. - intros. rewrite <- (add_compare_mono_r p), 2 sub_add; trivial. -Qed. - -Lemma sub_lt_mono_r p q r : q

r q-r < p-r. -Proof. - intros. unfold lt. rewrite sub_compare_mono_r; trivial. - now apply lt_trans with q. -Qed. - -Lemma sub_decr n m : m n-m < n. -Proof. - intros. - apply add_lt_mono_r with m. - rewrite sub_add; trivial. - apply lt_add_r. -Qed. - -Lemma add_sub_assoc p q r : r p+(q-r) = p+q-r. -Proof. - intros. - apply add_reg_r with r. - rewrite <- add_assoc, !sub_add; trivial. - rewrite add_comm. apply lt_trans with q; trivial using lt_add_r. -Qed. - -Lemma sub_add_distr p q r : q+r < p -> p-(q+r) = p-q-r. -Proof. - intros. - assert (q < p) - by (apply lt_trans with (q+r); trivial using lt_add_r). - rewrite (add_comm q r) in *. - apply add_reg_r with (r+q). - rewrite sub_add by trivial. - rewrite add_assoc, !sub_add; trivial. - apply (add_lt_mono_r q). rewrite sub_add; trivial. -Qed. - -Lemma sub_sub_distr p q r : r q-r < p -> p-(q-r) = p+r-q. -Proof. - intros. - apply add_reg_r with ((q-r)+r). - rewrite add_assoc, !sub_add; trivial. - rewrite <- (sub_add q r); trivial. - now apply add_lt_mono_r. -Qed. - -(** Recursive equations for [sub] *) - -Lemma sub_xO_xO n m : m n~0 - m~0 = (n-m)~0. -Proof. - intros H. unfold sub. simpl. - now destruct (sub_mask_pos n m H) as (p, ->). -Qed. - -Lemma sub_xI_xI n m : m n~1 - m~1 = (n-m)~0. -Proof. - intros H. unfold sub. simpl. - now destruct (sub_mask_pos n m H) as (p, ->). -Qed. - -Lemma sub_xI_xO n m : m n~1 - m~0 = (n-m)~1. -Proof. - intros H. unfold sub. simpl. - now destruct (sub_mask_pos n m) as (p, ->). -Qed. - -Lemma sub_xO_xI n m : n~0 - m~1 = pred_double (n-m). -Proof. - unfold sub. simpl. rewrite sub_mask_carry_spec. - now destruct (sub_mask n m) as [|[r|r|]|]. -Qed. - -(** Properties of subtraction with underflow *) - -Lemma sub_mask_neg_iff' p q : sub_mask p q = IsNeg <-> p < q. -Proof. - rewrite lt_iff_add. apply sub_mask_neg_iff. -Qed. - -Lemma sub_mask_neg p q : p sub_mask p q = IsNeg. -Proof. - apply sub_mask_neg_iff'. -Qed. - -Lemma sub_le p q : p<=q -> p-q = 1. -Proof. - unfold le, sub. rewrite compare_sub_mask. - destruct sub_mask; easy'. -Qed. - -Lemma sub_lt p q : p p-q = 1. -Proof. - intros. now apply sub_le, lt_le_incl. -Qed. - -Lemma sub_diag p : p-p = 1. -Proof. - unfold sub. now rewrite sub_mask_diag. -Qed. - -(** ** Results concerning [size] and [size_nat] *) - -Lemma size_nat_monotone p q : p (size_nat p <= size_nat q)%nat. -Proof. - assert (le0 : forall n, (0<=n)%nat) by (intro n; induction n; auto). - assert (leS : forall n m, (n<=m -> S n <= S m)%nat) by (induction 1; auto). - revert q. - induction p as [p IHp|p IHp|]; intro q; destruct q as [q|q|]; - simpl; intros H; auto; easy || apply leS; - red in H; simpl_compare_in H. - - apply IHp. red. now destruct (p?=q). - - destruct (compare_spec p q); subst; now auto. -Qed. - -Lemma size_gt p : p < 2^(size p). -Proof. - induction p as [p IHp|p IHp|]; simpl; try rewrite pow_succ_r; try easy. - apply le_succ_l in IHp. now apply le_succ_l. -Qed. - -Lemma size_le p : 2^(size p) <= p~0. -Proof. - induction p as [p IHp|p IHp|]; simpl; try rewrite pow_succ_r; try easy. - apply mul_le_mono_l. - apply le_lteq; left. rewrite xI_succ_xO. apply lt_succ_r, IHp. -Qed. - -(** ** Properties of [min] and [max] *) - -(** First, the specification *) - -Lemma max_l : forall x y, y<=x -> max x y = x. -Proof. - intros x y H. unfold max. case compare_spec; auto. - intros H'. apply le_nlt in H. now elim H. -Qed. - -Lemma max_r : forall x y, x<=y -> max x y = y. -Proof. - unfold le, max. intros x y. destruct compare; easy'. -Qed. - -Lemma min_l : forall x y, x<=y -> min x y = x. -Proof. - unfold le, min. intros x y. destruct compare; easy'. -Qed. - -Lemma min_r : forall x y, y<=x -> min x y = y. -Proof. - intros x y H. unfold min. case compare_spec; auto. - intros H'. apply le_nlt in H. now elim H'. -Qed. - -(** We hence obtain all the generic properties of [min] and [max]. *) - -Include UsualMinMaxLogicalProperties <+ UsualMinMaxDecProperties. - -Ltac order := Private_Tac.order. - -(** Minimum, maximum and constant one *) - -Lemma max_1_l n : max 1 n = n. -Proof. - unfold max. case compare_spec; auto. - intros H. apply lt_nle in H. elim H. apply le_1_l. -Qed. - -Lemma max_1_r n : max n 1 = n. -Proof. rewrite max_comm. apply max_1_l. Qed. - -Lemma min_1_l n : min 1 n = 1. -Proof. - unfold min. case compare_spec; auto. - intros H. apply lt_nle in H. elim H. apply le_1_l. -Qed. - -Lemma min_1_r n : min n 1 = 1. -Proof. rewrite min_comm. apply min_1_l. Qed. - -(** Minimum, maximum and operations (consequences of monotonicity) *) - -Lemma succ_max_distr n m : succ (max n m) = max (succ n) (succ m). -Proof. - symmetry. apply max_monotone. - intros x x'. apply succ_le_mono. -Qed. - -Lemma succ_min_distr n m : succ (min n m) = min (succ n) (succ m). -Proof. - symmetry. apply min_monotone. - intros x x'. apply succ_le_mono. -Qed. - -Lemma add_max_distr_l n m p : max (p + n) (p + m) = p + max n m. -Proof. - apply max_monotone. intros x x'. apply add_le_mono_l. -Qed. - -Lemma add_max_distr_r n m p : max (n + p) (m + p) = max n m + p. -Proof. - rewrite 3 (add_comm _ p). apply add_max_distr_l. -Qed. - -Lemma add_min_distr_l n m p : min (p + n) (p + m) = p + min n m. -Proof. - apply min_monotone. intros x x'. apply add_le_mono_l. -Qed. - -Lemma add_min_distr_r n m p : min (n + p) (m + p) = min n m + p. -Proof. - rewrite 3 (add_comm _ p). apply add_min_distr_l. -Qed. - -Lemma mul_max_distr_l n m p : max (p * n) (p * m) = p * max n m. -Proof. - apply max_monotone. intros x x'. apply mul_le_mono_l. -Qed. - -Lemma mul_max_distr_r n m p : max (n * p) (m * p) = max n m * p. -Proof. - rewrite 3 (mul_comm _ p). apply mul_max_distr_l. -Qed. - -Lemma mul_min_distr_l n m p : min (p * n) (p * m) = p * min n m. -Proof. - apply min_monotone. intros x x'. apply mul_le_mono_l. -Qed. - -Lemma mul_min_distr_r n m p : min (n * p) (m * p) = min n m * p. -Proof. - rewrite 3 (mul_comm _ p). apply mul_min_distr_l. -Qed. - - -(** ** Results concerning [iter_op] *) - -Lemma iter_op_succ : forall A (op:A->A->A), - (forall x y z, op x (op y z) = op (op x y) z) -> - forall p a, - iter_op op (succ p) a = op a (iter_op op p a). -Proof. - intros A op H p; induction p as [p IHp|p IHp|]; simpl; intros; trivial. - rewrite H. apply IHp. -Qed. - -Lemma iter_op_correct {A} op x p z - (op_zero_r : op x z = x) - (op_assoc : forall x y z : A, op x (op y z) = op (op x y) z) - : @Pos.iter_op A op p x = Pos.iter (op x) z p. -Proof. - induction p using peano_ind; cbn; - rewrite ?iter_op_succ, ?iter_succ, ?IHp; auto. -Qed. - -(** ** Results about [of_nat] and [of_succ_nat] *) - -Lemma of_nat_succ (n:nat) : of_succ_nat n = of_nat (S n). -Proof. - induction n as [|n IHn]. - - trivial. - - simpl. f_equal. now rewrite IHn. -Qed. - -Lemma pred_of_succ_nat (n:nat) : pred (of_succ_nat n) = of_nat n. -Proof. - destruct n. - - trivial. - - simpl pred. rewrite pred_succ. apply of_nat_succ. -Qed. - -Lemma succ_of_nat (n:nat) : n<>O -> succ (of_nat n) = of_succ_nat n. -Proof. - rewrite of_nat_succ. destruct n; trivial. now destruct 1. -Qed. - -(** ** Correctness proofs for the square root function *) - -Inductive SqrtSpec : positive*mask -> positive -> Prop := - | SqrtExact s x : x=s*s -> SqrtSpec (s,IsNul) x - | SqrtApprox s r x : x=s*s+r -> r <= s~0 -> SqrtSpec (s,IsPos r) x. - -Lemma sqrtrem_step_spec f g p x : - (f=xO \/ f=xI) -> (g=xO \/ g=xI) -> - SqrtSpec p x -> SqrtSpec (sqrtrem_step f g p) (g (f x)). -Proof. - intros Hf Hg [ s _ -> | s r _ -> Hr ]. - - (* exact *) - unfold sqrtrem_step. - destruct Hf,Hg; subst; simpl; constructor; now rewrite ?square_xO. - - (* approx *) - assert (Hfg : forall p q, g (f (p+q)) = p~0~0 + g (f q)) - by (intros; destruct Hf, Hg; now subst). - unfold sqrtrem_step, leb. - case compare_spec; [intros EQ | intros LT | intros GT]. - + (* - EQ *) - rewrite <- EQ, sub_mask_diag. constructor. - destruct Hg; subst g; destr_eq EQ. - destruct Hf; subst f; destr_eq EQ. - subst. now rewrite square_xI. - + (* - LT *) - destruct (sub_mask_pos' _ _ LT) as (y & -> & H). constructor. - * rewrite Hfg, <- H. now rewrite square_xI, add_assoc. - * clear Hfg. - rewrite <- lt_succ_r in Hr. change (r < s~1) in Hr. - rewrite <- lt_succ_r, (add_lt_mono_l (s~0~1)), H. simpl. - rewrite add_carry_spec, add_diag. simpl. - destruct Hf,Hg; subst; red; simpl_compare; now rewrite Hr. - + (* - GT *) - constructor. - * now rewrite Hfg, square_xO. - * apply lt_succ_r, GT. -Qed. - -Lemma sqrtrem_spec p : SqrtSpec (sqrtrem p) p. -Proof. -revert p. fix sqrtrem_spec 1. - intro p; destruct p as [p|p|]; try destruct p; try (constructor; easy); - apply sqrtrem_step_spec; auto. -Qed. - -Lemma sqrt_spec p : - let s := sqrt p in s*s <= p < (succ s)*(succ s). -Proof. - simpl. - assert (H:=sqrtrem_spec p). - unfold sqrt in *. destruct sqrtrem as (s,rm); simpl. - inversion_clear H; subst. - - (* exact *) - split. - + reflexivity. - + apply mul_lt_mono; apply lt_succ_diag_r. - - (* approx *) - split. - + apply lt_le_incl, lt_add_r. - + rewrite <- add_1_l, mul_add_distr_r, !mul_add_distr_l, !mul_1_r, !mul_1_l. - rewrite add_assoc, (add_comm _ _). apply add_lt_mono_r. - now rewrite <- add_assoc, add_diag, add_1_l, lt_succ_r. -Qed. - -(** ** Correctness proofs for the gcd function *) - -Lemma divide_add_cancel_l p q r : (p | r) -> (p | q + r) -> (p | q). -Proof. - intros (s,Hs) (t,Ht). - exists (t-s). - rewrite mul_sub_distr_r. - - rewrite <- Hs, <- Ht. - symmetry. apply add_sub. - - apply mul_lt_mono_r with p. - rewrite <- Hs, <- Ht, add_comm. - apply lt_add_r. -Qed. - -Lemma divide_xO_xI p q r : (p | q~0) -> (p | r~1) -> (p | q). -Proof. - intros (s,Hs) (t,Ht). - destruct p. - - destruct s as [s|s|]; try easy. simpl in Hs. destr_eq Hs. now exists s. - - rewrite mul_xO_r in Ht; discriminate. - - exists q; now rewrite mul_1_r. -Qed. - -Lemma divide_xO_xO p q : (p~0|q~0) <-> (p|q). -Proof. - split; intros (r,H); simpl in *. - - rewrite mul_xO_r in H. destr_eq H. now exists r. - - exists r; simpl. rewrite mul_xO_r. f_equal; auto. -Qed. - -Lemma divide_mul_l p q r : (p|q) -> (p|q*r). -Proof. - intros (s,H). exists (s*r). - rewrite <- mul_assoc, (mul_comm r p), mul_assoc. now f_equal. -Qed. - -Lemma divide_mul_r p q r : (p|r) -> (p|q*r). -Proof. - rewrite mul_comm. apply divide_mul_l. -Qed. - -(** The first component of ggcd is gcd *) - -Lemma ggcdn_gcdn : forall n a b, - fst (ggcdn n a b) = gcdn n a b. -Proof. - intro n; induction n as [|n IHn]. - - simpl; auto. - - intros a b; destruct a, b; simpl; auto; try case compare_spec; simpl; trivial; - rewrite <- IHn; destruct ggcdn as (g,(u,v)); simpl; auto. -Qed. - -Lemma ggcd_gcd : forall a b, fst (ggcd a b) = gcd a b. -Proof. - unfold ggcd, gcd. intros. apply ggcdn_gcdn. -Qed. - -(** The other components of ggcd are indeed the correct factors. *) - -Ltac destr_pggcdn IHn := - match goal with |- context [ ggcdn _ ?x ?y ] => - generalize (IHn x y); destruct ggcdn as (?g,(?u,?v)); simpl - end. - -Lemma ggcdn_correct_divisors : forall n a b, - let '(g,(aa,bb)) := ggcdn n a b in - a = g*aa /\ b = g*bb. -Proof. - intro n; induction n as [|n IHn]. - - simpl; auto. - - intros a b; destruct a, b; - simpl; auto; try case compare_spec; try destr_pggcdn IHn. - + (* Eq *) - intros ->. now rewrite mul_comm. - + (* Lt *) - intros (H',H) LT; split; auto. - rewrite mul_add_distr_l, mul_xO_r, <- H, <- H'. - simpl. f_equal. symmetry. - rewrite add_comm. now apply sub_add. - + (* Gt *) - intros (H',H) LT; split; auto. - rewrite mul_add_distr_l, mul_xO_r, <- H, <- H'. - simpl. f_equal. symmetry. - rewrite add_comm. now apply sub_add. - + (* Then... *) - intros (H,H'); split; auto. rewrite mul_xO_r, H'; auto. - + intros (H,H'); split; auto. rewrite mul_xO_r, H; auto. - + intros (H,H'); split; subst; auto. -Qed. - -Lemma ggcd_correct_divisors : forall a b, - let '(g,(aa,bb)) := ggcd a b in - a=g*aa /\ b=g*bb. -Proof. - unfold ggcd. intros. apply ggcdn_correct_divisors. -Qed. - -(** We can use this fact to prove a part of the gcd correctness *) - -Lemma gcd_divide_l : forall a b, (gcd a b | a). -Proof. - intros a b. rewrite <- ggcd_gcd. generalize (ggcd_correct_divisors a b). - destruct ggcd as (g,(aa,bb)); simpl. intros (H,_). exists aa. - now rewrite mul_comm. -Qed. - -Lemma gcd_divide_r : forall a b, (gcd a b | b). -Proof. - intros a b. rewrite <- ggcd_gcd. generalize (ggcd_correct_divisors a b). - destruct ggcd as (g,(aa,bb)); simpl. intros (_,H). exists bb. - now rewrite mul_comm. -Qed. - -(** We now prove directly that gcd is the greatest amongst common divisors *) - -Lemma gcdn_greatest : forall n a b, (size_nat a + size_nat b <= n)%nat -> - forall p, (p|a) -> (p|b) -> (p|gcdn n a b). -Proof. - intro n; induction n as [|n IHn]; intros a b. - - destruct a, b; simpl; inversion 1. - - destruct a as [a|a|], b as [b|b|]; simpl; try case compare_spec; simpl; auto. - + (* Lt *) - intros LT LE p Hp1 Hp2. apply IHn; clear IHn; trivial. - * apply le_S_n in LE. eapply Nat.le_trans; [|eapply LE]. - rewrite Nat.add_comm, <- plus_n_Sm, <- plus_Sn_m. - apply Nat.add_le_mono; trivial. - apply size_nat_monotone, sub_decr, LT. - * apply divide_xO_xI with a; trivial. - apply (divide_add_cancel_l p _ a~1); trivial. - now rewrite <- sub_xI_xI, sub_add. - + (* Gt *) - intros LT LE p Hp1 Hp2. apply IHn; clear IHn; trivial. - * apply le_S_n in LE. eapply Nat.le_trans; [|eapply LE]. - apply Nat.add_le_mono; trivial. - apply size_nat_monotone, sub_decr, LT. - * apply divide_xO_xI with b; trivial. - apply (divide_add_cancel_l p _ b~1); trivial. - now rewrite <- sub_xI_xI, sub_add. - + (* a~1 b~0 *) - intros LE p Hp1 Hp2. apply IHn; clear IHn; trivial. - * apply le_S_n in LE. simpl. now rewrite plus_n_Sm. - * apply divide_xO_xI with a; trivial. - + (* a~0 b~1 *) - intros LE p Hp1 Hp2. apply IHn; clear IHn; trivial. - * simpl. now apply le_S_n. - * apply divide_xO_xI with b; trivial. - + (* a~0 b~0 *) - intros LE p Hp1 Hp2. - destruct p as [p|p|]. - * { change (gcdn n a b)~0 with (2*(gcdn n a b)). - apply divide_mul_r. - apply IHn; clear IHn. - - apply le_S_n in LE. rewrite <- plus_n_Sm in LE. now apply Nat.lt_le_incl. - - apply divide_xO_xI with p; trivial. now exists 1. - - apply divide_xO_xI with p; trivial. now exists 1. - } - * { apply divide_xO_xO. - apply IHn; clear IHn. - - apply le_S_n in LE. rewrite <- plus_n_Sm in LE. now apply Nat.lt_le_incl. - - now apply divide_xO_xO. - - now apply divide_xO_xO. - } - * exists (gcdn n a b)~0. now rewrite mul_1_r. -Qed. - -Lemma gcd_greatest : forall a b p, (p|a) -> (p|b) -> (p|gcd a b). -Proof. - intros. apply gcdn_greatest; auto. -Qed. - -(** As a consequence, the rests after division by gcd are relatively prime *) - -Lemma ggcd_greatest : forall a b, - let (aa,bb) := snd (ggcd a b) in - forall p, (p|aa) -> (p|bb) -> p=1. -Proof. - intros a b **. generalize (gcd_greatest a b) (ggcd_correct_divisors a b). - rewrite <- ggcd_gcd. destruct ggcd as (g,(aa,bb)); simpl. - intros H (EQa,EQb) p Hp1 Hp2; subst. - assert (H' : (g*p | g)). { - apply H. - - destruct Hp1 as (r,Hr). exists r. - now rewrite mul_assoc, (mul_comm r g), <- mul_assoc, <- Hr. - - destruct Hp2 as (r,Hr). exists r. - now rewrite mul_assoc, (mul_comm r g), <- mul_assoc, <- Hr. - } - destruct H' as (q,H'). - rewrite (mul_comm g p), mul_assoc in H'. - apply mul_eq_1 with q; rewrite mul_comm. - now apply mul_reg_r with g. -Qed. - -End Pos. - -Bind Scope positive_scope with Pos.t positive. - -(** Exportation of notations *) - -Number Notation positive Pos.of_num_int Pos.to_num_uint : positive_scope. - -Infix "+" := Pos.add : positive_scope. -Infix "-" := Pos.sub : positive_scope. -Infix "*" := Pos.mul : positive_scope. -Infix "^" := Pos.pow : positive_scope. -Infix "?=" := Pos.compare (at level 70, no associativity) : positive_scope. -Infix "=?" := Pos.eqb (at level 70, no associativity) : positive_scope. -Infix "<=?" := Pos.leb (at level 70, no associativity) : positive_scope. -Infix "=" := Pos.ge : positive_scope. -Infix ">" := Pos.gt : positive_scope. - -Notation "x <= y <= z" := (x <= y /\ y <= z) : positive_scope. -Notation "x <= y < z" := (x <= y /\ y < z) : positive_scope. -Notation "x < y < z" := (x < y /\ y < z) : positive_scope. -Notation "x < y <= z" := (x < y /\ y <= z) : positive_scope. - -Notation "( p | q )" := (Pos.divide p q) (at level 0) : positive_scope. - -(** Compatibility notations *) - -Notation positive := positive (only parsing). -Notation positive_rect := positive_rect (only parsing). -Notation positive_rec := positive_rec (only parsing). -Notation positive_ind := positive_ind (only parsing). -Notation xI := xI (only parsing). -Notation xO := xO (only parsing). -Notation xH := xH (only parsing). - -Notation IsNul := Pos.IsNul (only parsing). -Notation IsPos := Pos.IsPos (only parsing). -Notation IsNeg := Pos.IsNeg (only parsing). - -Notation Pplus := Pos.add (only parsing). -Notation Pplus_carry := Pos.add_carry (only parsing). -Notation Pmult_nat := (Pos.iter_op plus) (only parsing). -Notation nat_of_P := Pos.to_nat (only parsing). -Notation P_of_succ_nat := Pos.of_succ_nat (only parsing). -Notation Pdouble_minus_one := Pos.pred_double (only parsing). -Notation positive_mask := Pos.mask (only parsing). -Notation positive_mask_rect := Pos.mask_rect (only parsing). -Notation positive_mask_ind := Pos.mask_ind (only parsing). -Notation positive_mask_rec := Pos.mask_rec (only parsing). -Notation Pdouble_plus_one_mask := Pos.succ_double_mask (only parsing). -Notation Pdouble_minus_two := Pos.double_pred_mask (only parsing). -Notation Pminus_mask := Pos.sub_mask (only parsing). -Notation Pminus_mask_carry := Pos.sub_mask_carry (only parsing). -Notation Pminus := Pos.sub (only parsing). -Notation Pmult := Pos.mul (only parsing). -Notation iter_pos := @Pos.iter (only parsing). -Notation Psize := Pos.size_nat (only parsing). -Notation Psize_pos := Pos.size (only parsing). -Notation Pcompare x y m := (Pos.compare_cont m x y) (only parsing). -Notation positive_eq_dec := Pos.eq_dec (only parsing). -Notation xI_succ_xO := Pos.xI_succ_xO (only parsing). -Notation Psucc_o_double_minus_one_eq_xO := - Pos.succ_pred_double (only parsing). -Notation Pdouble_minus_one_o_succ_eq_xI := - Pos.pred_double_succ (only parsing). -Notation xO_succ_permute := Pos.double_succ (only parsing). -Notation double_moins_un_xO_discr := - Pos.pred_double_xO_discr (only parsing). -Notation Psucc_not_one := Pos.succ_not_1 (only parsing). -Notation Psucc_pred := Pos.succ_pred_or (only parsing). -Notation Pplus_carry_spec := Pos.add_carry_spec (only parsing). -Notation Pplus_comm := Pos.add_comm (only parsing). -Notation Pplus_succ_permute_r := Pos.add_succ_r (only parsing). -Notation Pplus_succ_permute_l := Pos.add_succ_l (only parsing). -Notation Pplus_no_neutral := Pos.add_no_neutral (only parsing). -Notation Pplus_carry_plus := Pos.add_carry_add (only parsing). -Notation Pplus_reg_r := Pos.add_reg_r (only parsing). -Notation Pplus_reg_l := Pos.add_reg_l (only parsing). -Notation Pplus_carry_reg_r := Pos.add_carry_reg_r (only parsing). -Notation Pplus_carry_reg_l := Pos.add_carry_reg_l (only parsing). -Notation Pplus_assoc := Pos.add_assoc (only parsing). -Notation Pplus_xO := Pos.add_xO (only parsing). -Notation Pplus_xI_double_minus_one := Pos.add_xI_pred_double (only parsing). -Notation Pplus_xO_double_minus_one := Pos.add_xO_pred_double (only parsing). -Notation Pplus_diag := Pos.add_diag (only parsing). -Notation PeanoView := Pos.PeanoView (only parsing). -Notation PeanoOne := Pos.PeanoOne (only parsing). -Notation PeanoSucc := Pos.PeanoSucc (only parsing). -Notation PeanoView_rect := Pos.PeanoView_rect (only parsing). -Notation PeanoView_ind := Pos.PeanoView_ind (only parsing). -Notation PeanoView_rec := Pos.PeanoView_rec (only parsing). -Notation peanoView_xO := Pos.peanoView_xO (only parsing). -Notation peanoView_xI := Pos.peanoView_xI (only parsing). -Notation peanoView := Pos.peanoView (only parsing). -Notation PeanoView_iter := Pos.PeanoView_iter (only parsing). -Notation eq_dep_eq_positive := Pos.eq_dep_eq_positive (only parsing). -Notation PeanoViewUnique := Pos.PeanoViewUnique (only parsing). -Notation Prect := Pos.peano_rect (only parsing). -Notation Prect_succ := Pos.peano_rect_succ (only parsing). -Notation Prect_base := Pos.peano_rect_base (only parsing). -Notation Prec := Pos.peano_rec (only parsing). -Notation Pind := Pos.peano_ind (only parsing). -Notation Pcase := Pos.peano_case (only parsing). -Notation Pmult_1_r := Pos.mul_1_r (only parsing). -Notation Pmult_Sn_m := Pos.mul_succ_l (only parsing). -Notation Pmult_xO_permute_r := Pos.mul_xO_r (only parsing). -Notation Pmult_xI_permute_r := Pos.mul_xI_r (only parsing). -Notation Pmult_comm := Pos.mul_comm (only parsing). -Notation Pmult_plus_distr_l := Pos.mul_add_distr_l (only parsing). -Notation Pmult_plus_distr_r := Pos.mul_add_distr_r (only parsing). -Notation Pmult_assoc := Pos.mul_assoc (only parsing). -Notation Pmult_xI_mult_xO_discr := Pos.mul_xI_mul_xO_discr (only parsing). -Notation Pmult_xO_discr := Pos.mul_xO_discr (only parsing). -Notation Pmult_reg_r := Pos.mul_reg_r (only parsing). -Notation Pmult_reg_l := Pos.mul_reg_l (only parsing). -Notation Pmult_1_inversion_l := Pos.mul_eq_1_l (only parsing). -Notation iter_pos_swap_gen := Pos.iter_swap_gen (only parsing). -Notation iter_pos_swap := Pos.iter_swap (only parsing). -Notation iter_pos_succ := Pos.iter_succ (only parsing). -Notation iter_pos_plus := Pos.iter_add (only parsing). -Notation iter_pos_invariant := Pos.iter_invariant (only parsing). -Notation Pcompare_refl_id := Pos.compare_cont_refl (only parsing). -Notation Pcompare_eq_iff := Pos.compare_eq_iff (only parsing). -Notation Pcompare_Gt_Lt := Pos.compare_cont_Gt_Lt (only parsing). -Notation Pcompare_eq_Lt := Pos.compare_lt_iff (only parsing). -Notation Pcompare_Lt_Gt := Pos.compare_cont_Lt_Gt (only parsing). - -Notation Pcompare_antisym := Pos.compare_cont_antisym (only parsing). -Notation ZC1 := Pos.gt_lt (only parsing). -Notation ZC2 := Pos.lt_gt (only parsing). -Notation Pcompare_p_Sp := Pos.lt_succ_diag_r (only parsing). -Notation Pcompare_1 := Pos.nlt_1_r (only parsing). -Notation Plt_1 := Pos.nlt_1_r (only parsing). -Notation Pplus_compare_mono_l := Pos.add_compare_mono_l (only parsing). -Notation Pplus_compare_mono_r := Pos.add_compare_mono_r (only parsing). -Notation Pplus_lt_mono_l := Pos.add_lt_mono_l (only parsing). -Notation Pplus_lt_mono_r := Pos.add_lt_mono_r (only parsing). -Notation Pplus_lt_mono := Pos.add_lt_mono (only parsing). -Notation Pplus_le_mono_l := Pos.add_le_mono_l (only parsing). -Notation Pplus_le_mono_r := Pos.add_le_mono_r (only parsing). -Notation Pplus_le_mono := Pos.add_le_mono (only parsing). -Notation Pmult_compare_mono_l := Pos.mul_compare_mono_l (only parsing). -Notation Pmult_compare_mono_r := Pos.mul_compare_mono_r (only parsing). -Notation Pmult_lt_mono_l := Pos.mul_lt_mono_l (only parsing). -Notation Pmult_lt_mono_r := Pos.mul_lt_mono_r (only parsing). -Notation Pmult_lt_mono := Pos.mul_lt_mono (only parsing). -Notation Pmult_le_mono_l := Pos.mul_le_mono_l (only parsing). -Notation Pmult_le_mono_r := Pos.mul_le_mono_r (only parsing). -Notation Pmult_le_mono := Pos.mul_le_mono (only parsing). -Notation Plt_plus_r := Pos.lt_add_r (only parsing). -Notation Plt_not_plus_l := Pos.lt_not_add_l (only parsing). -Notation Pminus_mask_succ_r := Pos.sub_mask_succ_r (only parsing). -Notation Pminus_mask_carry_spec := Pos.sub_mask_carry_spec (only parsing). -Notation Pminus_succ_r := Pos.sub_succ_r (only parsing). -Notation Pminus_mask_diag := Pos.sub_mask_diag (only parsing). - -Notation Pplus_minus_eq := Pos.add_sub (only parsing). -Notation Pmult_minus_distr_l := Pos.mul_sub_distr_l (only parsing). -Notation Pminus_lt_mono_l := Pos.sub_lt_mono_l (only parsing). -Notation Pminus_compare_mono_l := Pos.sub_compare_mono_l (only parsing). -Notation Pminus_compare_mono_r := Pos.sub_compare_mono_r (only parsing). -Notation Pminus_lt_mono_r := Pos.sub_lt_mono_r (only parsing). -Notation Pminus_decr := Pos.sub_decr (only parsing). -Notation Pminus_xI_xI := Pos.sub_xI_xI (only parsing). -Notation Pplus_minus_assoc := Pos.add_sub_assoc (only parsing). -Notation Pminus_plus_distr := Pos.sub_add_distr (only parsing). -Notation Pminus_minus_distr := Pos.sub_sub_distr (only parsing). -Notation Pminus_mask_Lt := Pos.sub_mask_neg (only parsing). -Notation Pminus_Lt := Pos.sub_lt (only parsing). -Notation Pminus_Eq := Pos.sub_diag (only parsing). -Notation Psize_monotone := Pos.size_nat_monotone (only parsing). -Notation Psize_pos_gt := Pos.size_gt (only parsing). -Notation Psize_pos_le := Pos.size_le (only parsing). - -(** More complex compatibility facts, expressed as lemmas - (to preserve scopes for instance) *) - -Lemma Peqb_true_eq x y : Pos.eqb x y = true -> x=y. -Proof. apply Pos.eqb_eq. Qed. -Lemma Pcompare_eq_Gt p q : (p ?= q) = Gt <-> p > q. -Proof. reflexivity. Qed. -Lemma Pplus_one_succ_r p : Pos.succ p = p + 1. -Proof (eq_sym (Pos.add_1_r p)). -Lemma Pplus_one_succ_l p : Pos.succ p = 1 + p. -Proof (eq_sym (Pos.add_1_l p)). -Lemma Pcompare_refl p : Pos.compare_cont Eq p p = Eq. -Proof (Pos.compare_cont_refl p Eq). -Lemma Pcompare_Eq_eq : forall p q, Pos.compare_cont Eq p q = Eq -> p = q. -Proof Pos.compare_eq. -Lemma ZC4 p q : Pos.compare_cont Eq p q = CompOpp (Pos.compare_cont Eq q p). -Proof (Pos.compare_antisym q p). -Lemma Ppred_minus p : Pos.pred p = p - 1. -Proof (eq_sym (Pos.sub_1_r p)). - -Lemma Pminus_mask_Gt p q : - p > q -> - exists h : positive, - Pos.sub_mask p q = IsPos h /\ - q + h = p /\ (h = 1 \/ Pos.sub_mask_carry p q = IsPos (Pos.pred h)). -Proof. - intros H. apply Pos.gt_lt in H. - destruct (Pos.sub_mask_pos p q H) as (r & U). - exists r. repeat split; trivial. - - now apply Pos.sub_mask_pos_iff. - - destruct (Pos.eq_dec r 1) as [EQ|NE]; [now left|right]. - rewrite Pos.sub_mask_carry_spec, U. destruct r; trivial. now elim NE. -Qed. - -Lemma Pplus_minus : forall p q, p > q -> q+(p-q) = p. -Proof. - intros. rewrite Pos.add_comm. now apply Pos.sub_add, Pos.gt_lt. -Qed. - -(** Discontinued results of little interest and little/zero use - in user contributions: - - Pplus_carry_no_neutral - Pplus_carry_pred_eq_plus - Pcompare_not_Eq - Pcompare_Lt_Lt - Pcompare_Lt_eq_Lt - Pcompare_Gt_Gt - Pcompare_Gt_eq_Gt - Psucc_lt_compat - Psucc_le_compat - ZC3 - Pcompare_p_Sq - Pminus_mask_carry_diag - Pminus_mask_IsNeg - ZL10 - ZL11 - double_eq_zero_inversion - double_plus_one_zero_discr - double_plus_one_eq_one_inversion - double_eq_one_discr - - Infix "/" := Pdiv2 : positive_scope. -*) - -(** Old stuff, to remove someday *) - -Lemma Dcompare : forall r:comparison, r = Eq \/ r = Lt \/ r = Gt. -Proof. - intro r; destruct r; auto. -Qed. - -(** Incompatibilities : - - - [(_ ?= _)%positive] expects no arg now, and designates [Pos.compare] - which is convertible but syntactically distinct to - [Pos.compare_cont .. .. Eq]. - - - [Pmult_nat] cannot be unfolded (unfold [Pos.iter_op] instead). - -*) - -(** Re-export the notation for those who just [Import BinPos] *) -Number Notation positive Pos.of_num_int Pos.to_num_hex_uint : hex_positive_scope. -Number Notation positive Pos.of_num_int Pos.to_num_uint : positive_scope. diff --git a/stdlib/theories/PArith/BinPosDef.v b/stdlib/theories/PArith/BinPosDef.v deleted file mode 100644 index 1c9871bfe690..000000000000 --- a/stdlib/theories/PArith/BinPosDef.v +++ /dev/null @@ -1,385 +0,0 @@ -(* -*- coding: utf-8 -*- *) -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* p~0 - | p~0 => pred_double p - | 1 => 1 - end. - -(** ** Predecessor with mask *) - -Definition pred_mask (p : mask) : mask := - match p with - | IsPos 1 => IsNul - | IsPos q => IsPos (pred q) - | IsNul => IsNeg - | IsNeg => IsNeg - end. - -Infix "-" := sub : positive_scope. - -Infix "*" := mul : positive_scope. - -(** ** Power *) - -Definition pow (x:positive) := iter (mul x) 1. - -Infix "^" := pow : positive_scope. - -(** ** Square *) - -Fixpoint square p := - match p with - | p~1 => (square p + p)~0~1 - | p~0 => (square p)~0~0 - | 1 => 1 - end. - -(** ** Number of digits in a positive number *) - -Fixpoint size_nat p : nat := - match p with - | 1 => S O - | p~1 => S (size_nat p) - | p~0 => S (size_nat p) - end. - -(** Same, with positive output *) - -Fixpoint size p := - match p with - | 1 => 1 - | p~1 => succ (size p) - | p~0 => succ (size p) - end. - -Infix "?=" := compare (at level 70, no associativity) : positive_scope. - -Definition min p p' := - match p ?= p' with - | Lt | Eq => p - | Gt => p' - end. - -Definition max p p' := - match p ?= p' with - | Lt | Eq => p' - | Gt => p - end. - -(** ** Boolean equality and comparisons *) - -Definition ltb x y := - match x ?= y with Lt => true | _ => false end. - -Infix "=?" := eqb (at level 70, no associativity) : positive_scope. -Infix "<=?" := leb (at level 70, no associativity) : positive_scope. -Infix " 1 - | S n => - match a,b with - | 1, _ => 1 - | _, 1 => 1 - | a~0, b~0 => (gcdn n a b)~0 - | _ , b~0 => gcdn n a b - | a~0, _ => gcdn n a b - | a'~1, b'~1 => - match a' ?= b' with - | Eq => a - | Lt => gcdn n (b'-a') a - | Gt => gcdn n (a'-b') b - end - end - end. - -(** We'll show later that we need at most (log2(a.b)) loops *) - -Definition gcd (a b : positive) := gcdn (size_nat a + size_nat b)%nat a b. - -(** Generalized Gcd, also computing the division of a and b by the gcd *) -Set Printing Universes. -Fixpoint ggcdn (n : nat) (a b : positive) : (positive*(positive*positive)) := - match n with - | O => (1,(a,b)) - | S n => - match a,b with - | 1, _ => (1,(1,b)) - | _, 1 => (1,(a,1)) - | a~0, b~0 => - let (g,p) := ggcdn n a b in - (g~0,p) - | _, b~0 => - let '(g,(aa,bb)) := ggcdn n a b in - (g,(aa, bb~0)) - | a~0, _ => - let '(g,(aa,bb)) := ggcdn n a b in - (g,(aa~0, bb)) - | a'~1, b'~1 => - match a' ?= b' with - | Eq => (a,(1,1)) - | Lt => - let '(g,(ba,aa)) := ggcdn n (b'-a') a in - (g,(aa, aa + ba~0)) - | Gt => - let '(g,(ab,bb)) := ggcdn n (a'-b') b in - (g,(bb + ab~0, bb)) - end - end - end. - -Definition ggcd (a b: positive) := ggcdn (size_nat a + size_nat b)%nat a b. - -(** Shifts. NB: right shift of 1 stays at 1. *) - -Definition shiftl_nat (p:positive) := nat_rect _ p (fun _ => xO). -Definition shiftr_nat (p:positive) := nat_rect _ p (fun _ => div2). - -Definition shiftl (p:positive)(n:N) := - match n with - | N0 => p - | Npos n => iter xO p n - end. - -Definition shiftr (p:positive)(n:N) := - match n with - | N0 => p - | Npos n => iter div2 p n - end. - -(** Checking whether a particular bit is set or not *) - -Fixpoint testbit_nat (p:positive) : nat -> bool := - match p with - | 1 => fun n => match n with - | O => true - | S _ => false - end - | p~0 => fun n => match n with - | O => false - | S n' => testbit_nat p n' - end - | p~1 => fun n => match n with - | O => true - | S n' => testbit_nat p n' - end - end. - -(** Same, but with index in N *) - -Fixpoint testbit (p:positive)(n:N) := - match p, n with - | p~0, N0 => false - | _, N0 => true - | 1, _ => false - | p~0, Npos n => testbit p (pred_N n) - | p~1, Npos n => testbit p (pred_N n) - end. - -(** ** From Peano natural numbers to binary positive numbers *) - -(** A version preserving positive numbers, and sending 0 to 1. *) - -Fixpoint of_nat (n:nat) : positive := - match n with - | O => 1 - | S O => 1 - | S x => succ (of_nat x) - end. - -(** ** Conversion with a decimal representation for printing/parsing *) - -Local Notation ten := 1~0~1~0. - -Fixpoint of_uint_acc (d:Decimal.uint)(acc:positive) := - match d with - | Decimal.Nil => acc - | Decimal.D0 l => of_uint_acc l (mul ten acc) - | Decimal.D1 l => of_uint_acc l (add 1 (mul ten acc)) - | Decimal.D2 l => of_uint_acc l (add 1~0 (mul ten acc)) - | Decimal.D3 l => of_uint_acc l (add 1~1 (mul ten acc)) - | Decimal.D4 l => of_uint_acc l (add 1~0~0 (mul ten acc)) - | Decimal.D5 l => of_uint_acc l (add 1~0~1 (mul ten acc)) - | Decimal.D6 l => of_uint_acc l (add 1~1~0 (mul ten acc)) - | Decimal.D7 l => of_uint_acc l (add 1~1~1 (mul ten acc)) - | Decimal.D8 l => of_uint_acc l (add 1~0~0~0 (mul ten acc)) - | Decimal.D9 l => of_uint_acc l (add 1~0~0~1 (mul ten acc)) - end. - -Fixpoint of_uint (d:Decimal.uint) : N := - match d with - | Decimal.Nil => N0 - | Decimal.D0 l => of_uint l - | Decimal.D1 l => Npos (of_uint_acc l 1) - | Decimal.D2 l => Npos (of_uint_acc l 1~0) - | Decimal.D3 l => Npos (of_uint_acc l 1~1) - | Decimal.D4 l => Npos (of_uint_acc l 1~0~0) - | Decimal.D5 l => Npos (of_uint_acc l 1~0~1) - | Decimal.D6 l => Npos (of_uint_acc l 1~1~0) - | Decimal.D7 l => Npos (of_uint_acc l 1~1~1) - | Decimal.D8 l => Npos (of_uint_acc l 1~0~0~0) - | Decimal.D9 l => Npos (of_uint_acc l 1~0~0~1) - end. - -Local Notation sixteen := 1~0~0~0~0. - -Fixpoint of_hex_uint_acc (d:Hexadecimal.uint)(acc:positive) := - match d with - | Hexadecimal.Nil => acc - | Hexadecimal.D0 l => of_hex_uint_acc l (mul sixteen acc) - | Hexadecimal.D1 l => of_hex_uint_acc l (add 1 (mul sixteen acc)) - | Hexadecimal.D2 l => of_hex_uint_acc l (add 1~0 (mul sixteen acc)) - | Hexadecimal.D3 l => of_hex_uint_acc l (add 1~1 (mul sixteen acc)) - | Hexadecimal.D4 l => of_hex_uint_acc l (add 1~0~0 (mul sixteen acc)) - | Hexadecimal.D5 l => of_hex_uint_acc l (add 1~0~1 (mul sixteen acc)) - | Hexadecimal.D6 l => of_hex_uint_acc l (add 1~1~0 (mul sixteen acc)) - | Hexadecimal.D7 l => of_hex_uint_acc l (add 1~1~1 (mul sixteen acc)) - | Hexadecimal.D8 l => of_hex_uint_acc l (add 1~0~0~0 (mul sixteen acc)) - | Hexadecimal.D9 l => of_hex_uint_acc l (add 1~0~0~1 (mul sixteen acc)) - | Hexadecimal.Da l => of_hex_uint_acc l (add 1~0~1~0 (mul sixteen acc)) - | Hexadecimal.Db l => of_hex_uint_acc l (add 1~0~1~1 (mul sixteen acc)) - | Hexadecimal.Dc l => of_hex_uint_acc l (add 1~1~0~0 (mul sixteen acc)) - | Hexadecimal.Dd l => of_hex_uint_acc l (add 1~1~0~1 (mul sixteen acc)) - | Hexadecimal.De l => of_hex_uint_acc l (add 1~1~1~0 (mul sixteen acc)) - | Hexadecimal.Df l => of_hex_uint_acc l (add 1~1~1~1 (mul sixteen acc)) - end. - -Fixpoint of_hex_uint (d:Hexadecimal.uint) : N := - match d with - | Hexadecimal.Nil => N0 - | Hexadecimal.D0 l => of_hex_uint l - | Hexadecimal.D1 l => Npos (of_hex_uint_acc l 1) - | Hexadecimal.D2 l => Npos (of_hex_uint_acc l 1~0) - | Hexadecimal.D3 l => Npos (of_hex_uint_acc l 1~1) - | Hexadecimal.D4 l => Npos (of_hex_uint_acc l 1~0~0) - | Hexadecimal.D5 l => Npos (of_hex_uint_acc l 1~0~1) - | Hexadecimal.D6 l => Npos (of_hex_uint_acc l 1~1~0) - | Hexadecimal.D7 l => Npos (of_hex_uint_acc l 1~1~1) - | Hexadecimal.D8 l => Npos (of_hex_uint_acc l 1~0~0~0) - | Hexadecimal.D9 l => Npos (of_hex_uint_acc l 1~0~0~1) - | Hexadecimal.Da l => Npos (of_hex_uint_acc l 1~0~1~0) - | Hexadecimal.Db l => Npos (of_hex_uint_acc l 1~0~1~1) - | Hexadecimal.Dc l => Npos (of_hex_uint_acc l 1~1~0~0) - | Hexadecimal.Dd l => Npos (of_hex_uint_acc l 1~1~0~1) - | Hexadecimal.De l => Npos (of_hex_uint_acc l 1~1~1~0) - | Hexadecimal.Df l => Npos (of_hex_uint_acc l 1~1~1~1) - end. - -Definition of_num_uint (d:Number.uint) : N := - match d with - | Number.UIntDecimal d => of_uint d - | Number.UIntHexadecimal d => of_hex_uint d - end. - -Definition of_int (d:Decimal.int) : option positive := - match d with - | Decimal.Pos d => - match of_uint d with - | N0 => None - | Npos p => Some p - end - | Decimal.Neg _ => None - end. - -Definition of_hex_int (d:Hexadecimal.int) : option positive := - match d with - | Hexadecimal.Pos d => - match of_hex_uint d with - | N0 => None - | Npos p => Some p - end - | Hexadecimal.Neg _ => None - end. - -Definition of_num_int (d:Number.int) : option positive := - match d with - | Number.IntDecimal d => of_int d - | Number.IntHexadecimal d => of_hex_int d - end. - -Fixpoint to_little_uint p := - match p with - | 1 => Decimal.D1 Decimal.Nil - | p~1 => Decimal.Little.succ_double (to_little_uint p) - | p~0 => Decimal.Little.double (to_little_uint p) - end. - -Definition to_uint p := Decimal.rev (to_little_uint p). - -Fixpoint to_little_hex_uint p := - match p with - | 1 => Hexadecimal.D1 Hexadecimal.Nil - | p~1 => Hexadecimal.Little.succ_double (to_little_hex_uint p) - | p~0 => Hexadecimal.Little.double (to_little_hex_uint p) - end. - -Definition to_hex_uint p := Hexadecimal.rev (to_little_hex_uint p). - -Definition to_num_uint p := Number.UIntDecimal (to_uint p). - -Definition to_num_hex_uint n := Number.UIntHexadecimal (to_hex_uint n). - -Definition to_int n := Decimal.Pos (to_uint n). - -Definition to_hex_int p := Hexadecimal.Pos (to_hex_uint p). - -Definition to_num_int n := Number.IntDecimal (to_int n). - -Definition to_num_hex_int n := Number.IntHexadecimal (to_hex_int n). - -Number Notation positive of_num_int to_num_hex_uint : hex_positive_scope. -Number Notation positive of_num_int to_num_uint : positive_scope. - -End Pos. - -(** Re-export the notation for those who just [Import BinPosDef] *) -Number Notation positive Pos.of_num_int Pos.to_num_hex_uint : hex_positive_scope. -Number Notation positive Pos.of_num_int Pos.to_num_uint : positive_scope. diff --git a/stdlib/theories/PArith/PArith.v b/stdlib/theories/PArith/PArith.v deleted file mode 100644 index 9b247cf6093d..000000000000 --- a/stdlib/theories/PArith/PArith.v +++ /dev/null @@ -1,13 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* y<=x -> x=y]. *) diff --git a/stdlib/theories/PArith/Pnat.v b/stdlib/theories/PArith/Pnat.v deleted file mode 100644 index e80966961fd2..000000000000 --- a/stdlib/theories/PArith/Pnat.v +++ /dev/null @@ -1,530 +0,0 @@ -(* -*- coding: utf-8 -*- *) -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* ). apply Nat.lt_0_succ. -Qed. - -(** [Pos.to_nat] is a bijection between [positive] and - non-zero [nat], with [Pos.of_nat] as reciprocal. - See [Nat2Pos.id] below for the dual equation. *) - -Theorem id p : of_nat (to_nat p) = p. -Proof. - induction p as [|p IHp] using peano_ind. - - trivial. - - rewrite inj_succ. rewrite <- IHp at 2. - now destruct (is_succ p) as (n,->). -Qed. - -(** [Pos.to_nat] is hence injective *) - -Lemma inj p q : to_nat p = to_nat q -> p = q. -Proof. - intros H. now rewrite <- (id p), <- (id q), H. -Qed. - -Lemma inj_iff p q : to_nat p = to_nat q <-> p = q. -Proof. - split. - - apply inj. - - intros; now subst. -Qed. - -(** [Pos.to_nat] is a morphism for comparison *) - -Lemma inj_compare p q : (p ?= q)%positive = (to_nat p ?= to_nat q). -Proof. - revert q. induction p as [ |p IH] using peano_ind; intros q. - - destruct (succ_pred_or q) as [Hq|Hq]; [now subst|]. - rewrite <- Hq, lt_1_succ, inj_succ, inj_1, Nat.compare_succ. - symmetry. apply Nat.compare_lt_iff, is_pos. - - destruct (succ_pred_or q) as [Hq|Hq]; [subst|]. - + rewrite compare_antisym, lt_1_succ, inj_succ. simpl. - symmetry. apply Nat.compare_gt_iff, is_pos. - + now rewrite <- Hq, 2 inj_succ, compare_succ_succ, IH. -Qed. - -(** [Pos.to_nat] is a morphism for [lt], [le], etc *) - -Lemma inj_lt p q : (p < q)%positive <-> to_nat p < to_nat q. -Proof. - unfold lt. now rewrite inj_compare, Nat.compare_lt_iff. -Qed. - -Lemma inj_le p q : (p <= q)%positive <-> to_nat p <= to_nat q. -Proof. - unfold le. now rewrite inj_compare, Nat.compare_le_iff. -Qed. - -Lemma inj_gt p q : (p > q)%positive <-> to_nat p > to_nat q. -Proof. - unfold gt. now rewrite inj_compare, Nat.compare_gt_iff. -Qed. - -Lemma inj_ge p q : (p >= q)%positive <-> to_nat p >= to_nat q. -Proof. - unfold ge. now rewrite inj_compare, Nat.compare_ge_iff. -Qed. - -(** [Pos.to_nat] is a morphism for subtraction *) - -Theorem inj_sub p q : (q < p)%positive -> - to_nat (p - q) = to_nat p - to_nat q. -Proof. - intro H. apply Nat.add_cancel_r with (to_nat q). - rewrite Nat.sub_add. - - now rewrite <- inj_add, sub_add. - - now apply Nat.lt_le_incl, inj_lt. -Qed. - -Theorem inj_sub_max p q : - to_nat (p - q) = Nat.max 1 (to_nat p - to_nat q). -Proof. - destruct (ltb_spec q p) as [H|H]. - - (* q < p *) - rewrite <- inj_sub by trivial. - now destruct (is_succ (p - q)) as (m,->). - - (* p <= q *) - rewrite sub_le by trivial. - apply inj_le, Nat.sub_0_le in H. now rewrite H. -Qed. - -Theorem inj_pred p : (1 < p)%positive -> - to_nat (pred p) = Nat.pred (to_nat p). -Proof. - intros. now rewrite <- Pos.sub_1_r, inj_sub, Nat.sub_1_r. -Qed. - -Theorem inj_pred_max p : - to_nat (pred p) = Nat.max 1 (Peano.pred (to_nat p)). -Proof. - rewrite <- Pos.sub_1_r, <- Nat.sub_1_r. apply inj_sub_max. -Qed. - -(** [Pos.to_nat] and other operations *) - -Lemma inj_min p q : - to_nat (min p q) = Nat.min (to_nat p) (to_nat q). -Proof. - unfold min. rewrite inj_compare. - case Nat.compare_spec; intros H; symmetry. - - apply Nat.min_l. now rewrite H. - - now apply Nat.min_l, Nat.lt_le_incl. - - now apply Nat.min_r, Nat.lt_le_incl. -Qed. - -Lemma inj_max p q : - to_nat (max p q) = Nat.max (to_nat p) (to_nat q). -Proof. - unfold max. rewrite inj_compare. - case Nat.compare_spec; intros H; symmetry. - - apply Nat.max_r. now rewrite H. - - now apply Nat.max_r, Nat.lt_le_incl. - - now apply Nat.max_l, Nat.lt_le_incl. -Qed. - -Theorem inj_iter p {A} (f:A->A) (x:A) : - Pos.iter f x p = nat_rect _ x (fun _ => f) (to_nat p). -Proof. - induction p as [|p IHp] using peano_ind. - - trivial. - - intros. rewrite inj_succ, iter_succ. - simpl. f_equal. apply IHp. -Qed. - -Theorem inj_pow p q : to_nat (p ^ q) = to_nat p ^ to_nat q. -Proof. - induction q as [|q IHq] using peano_ind. - - now rewrite Pos.pow_1_r, inj_1, Nat.pow_1_r. - - unfold Pos.pow. rewrite inj_succ, iter_succ, inj_mul. fold (Pos.pow p q). - now rewrite IHq. -Qed. - -End Pos2Nat. - -Module Nat2Pos. - -(** [Pos.of_nat] is a bijection between non-zero [nat] and - [positive], with [Pos.to_nat] as reciprocal. - See [Pos2Nat.id] above for the dual equation. *) - -Theorem id (n:nat) : n<>0 -> Pos.to_nat (Pos.of_nat n) = n. -Proof. - induction n as [|n H]; trivial. - - now destruct 1. - - intros _. simpl Pos.of_nat. destruct n. - + trivial. - + rewrite Pos2Nat.inj_succ. f_equal. now apply H. -Qed. - -Theorem id_max (n:nat) : Pos.to_nat (Pos.of_nat n) = max 1 n. -Proof. - destruct n. - - trivial. - - now rewrite id. -Qed. - -(** [Pos.of_nat] is hence injective for non-zero numbers *) - -Lemma inj (n m : nat) : n<>0 -> m<>0 -> Pos.of_nat n = Pos.of_nat m -> n = m. -Proof. - intros Hn Hm H. now rewrite <- (id n), <- (id m), H. -Qed. - -Lemma inj_iff (n m : nat) : n<>0 -> m<>0 -> - (Pos.of_nat n = Pos.of_nat m <-> n = m). -Proof. - split. - - now apply inj. - - intros; now subst. -Qed. - -(** Usual operations are morphisms with respect to [Pos.of_nat] - for non-zero numbers. *) - -Lemma inj_0 : Pos.of_nat 0 = 1%positive. -Proof. reflexivity. Qed. - -Lemma inj_succ (n:nat) : n<>0 -> Pos.of_nat (S n) = Pos.succ (Pos.of_nat n). -Proof. -intro H. apply Pos2Nat.inj. now rewrite Pos2Nat.inj_succ, !id. -Qed. - -Lemma inj_pred (n:nat) : Pos.of_nat (pred n) = Pos.pred (Pos.of_nat n). -Proof. - destruct n as [|[|n]]; trivial. simpl. now rewrite Pos.pred_succ. -Qed. - -Lemma inj_add (n m : nat) : n<>0 -> m<>0 -> - Pos.of_nat (n+m) = (Pos.of_nat n + Pos.of_nat m)%positive. -Proof. -intros Hn Hm. apply Pos2Nat.inj. -rewrite Pos2Nat.inj_add, !id; trivial. -intros H. destruct n. -- now destruct Hn. -- now simpl in H. -Qed. - -Lemma inj_mul (n m : nat) : n<>0 -> m<>0 -> - Pos.of_nat (n*m) = (Pos.of_nat n * Pos.of_nat m)%positive. -Proof. -intros Hn Hm. apply Pos2Nat.inj. -rewrite Pos2Nat.inj_mul, !id; trivial. -intros H. apply Nat.mul_eq_0 in H. destruct H. -- now elim Hn. -- now elim Hm. -Qed. - -Lemma inj_compare (n m : nat) : n<>0 -> m<>0 -> - (n ?= m) = (Pos.of_nat n ?= Pos.of_nat m)%positive. -Proof. -intros Hn Hm. rewrite Pos2Nat.inj_compare, !id; trivial. -Qed. - -Lemma inj_sub (n m : nat) : m<>0 -> - Pos.of_nat (n-m) = (Pos.of_nat n - Pos.of_nat m)%positive. -Proof. - intros Hm. - apply Pos2Nat.inj. - rewrite Pos2Nat.inj_sub_max. - rewrite (id m) by trivial. rewrite !id_max. - destruct n, m; trivial. -Qed. - -Lemma inj_min (n m : nat) : - Pos.of_nat (min n m) = Pos.min (Pos.of_nat n) (Pos.of_nat m). -Proof. - destruct n as [|n]. { simpl. symmetry. apply Pos.min_l, Pos.le_1_l. } - destruct m as [|m]. { simpl. symmetry. apply Pos.min_r, Pos.le_1_l. } - unfold Pos.min. rewrite <- inj_compare by easy. - case Nat.compare_spec; intros H; f_equal; - apply Nat.min_l || apply Nat.min_r. - - rewrite H; auto. - - now apply Nat.lt_le_incl. - - now apply Nat.lt_le_incl. -Qed. - -Lemma inj_max (n m : nat) : - Pos.of_nat (max n m) = Pos.max (Pos.of_nat n) (Pos.of_nat m). -Proof. - destruct n as [|n]. { simpl. symmetry. apply Pos.max_r, Pos.le_1_l. } - destruct m as [|m]. { simpl. symmetry. apply Pos.max_l, Pos.le_1_l. } - unfold Pos.max. rewrite <- inj_compare by easy. - case Nat.compare_spec; intros H; f_equal; - apply Nat.max_l || apply Nat.max_r. - - rewrite H; auto. - - now apply Nat.lt_le_incl. - - now apply Nat.lt_le_incl. -Qed. - -Theorem inj_pow (n m : nat) : m <> 0 -> - Pos.of_nat (n^m) = (Pos.of_nat n ^ Pos.of_nat m)%positive. -Proof. - intros Hm. apply Pos2Nat.inj. rewrite Pos2Nat.inj_pow. - destruct n. - - now rewrite Nat.pow_0_l, inj_0, Pos2Nat.inj_1, Nat.pow_1_l. - - now rewrite !id; [..|apply Nat.pow_nonzero]. -Qed. - -End Nat2Pos. - -(**********************************************************************) -(** Properties of the shifted injection from Peano natural numbers - to binary positive numbers *) - -Module Pos2SuccNat. - -(** Composition of [Pos.to_nat] and [Pos.of_succ_nat] is successor - on [positive] *) - -Theorem id_succ p : Pos.of_succ_nat (Pos.to_nat p) = Pos.succ p. -Proof. -rewrite Pos.of_nat_succ, <- Pos2Nat.inj_succ. apply Pos2Nat.id. -Qed. - -(** Composition of [Pos.to_nat], [Pos.of_succ_nat] and [Pos.pred] - is identity on [positive] *) - -Theorem pred_id p : Pos.pred (Pos.of_succ_nat (Pos.to_nat p)) = p. -Proof. -now rewrite id_succ, Pos.pred_succ. -Qed. - -End Pos2SuccNat. - -Module SuccNat2Pos. - -(** Composition of [Pos.of_succ_nat] and [Pos.to_nat] is successor on [nat] *) - -Theorem id_succ (n:nat) : Pos.to_nat (Pos.of_succ_nat n) = S n. -Proof. -rewrite Pos.of_nat_succ. now apply Nat2Pos.id. -Qed. - -Theorem pred_id (n:nat) : pred (Pos.to_nat (Pos.of_succ_nat n)) = n. -Proof. -now rewrite id_succ. -Qed. - -(** [Pos.of_succ_nat] is hence injective *) - -Lemma inj (n m : nat) : Pos.of_succ_nat n = Pos.of_succ_nat m -> n = m. -Proof. - intro H. apply (f_equal Pos.to_nat) in H. rewrite !id_succ in H. - now injection H. -Qed. - -Lemma inj_iff (n m : nat) : Pos.of_succ_nat n = Pos.of_succ_nat m <-> n = m. -Proof. - split. - - apply inj. - - intros; now subst. -Qed. - -(** Another formulation *) - -Theorem inv n p : Pos.to_nat p = S n -> Pos.of_succ_nat n = p. -Proof. - intros H. apply Pos2Nat.inj. now rewrite id_succ. -Qed. - -(** Successor and comparison are morphisms with respect to - [Pos.of_succ_nat] *) - -Lemma inj_succ n : Pos.of_succ_nat (S n) = Pos.succ (Pos.of_succ_nat n). -Proof. -apply Pos2Nat.inj. now rewrite Pos2Nat.inj_succ, !id_succ. -Qed. - -Lemma inj_compare n m : - (n ?= m) = (Pos.of_succ_nat n ?= Pos.of_succ_nat m)%positive. -Proof. -rewrite Pos2Nat.inj_compare, !id_succ; trivial. -Qed. - -(** Other operations, for instance [Pos.add] and [plus] aren't - directly related this way (we would need to compensate for - the successor hidden in [Pos.of_succ_nat] *) - -End SuccNat2Pos. - -(** For compatibility, old names and old-style lemmas *) - -Notation Psucc_S := Pos2Nat.inj_succ (only parsing). -Notation Pplus_plus := Pos2Nat.inj_add (only parsing). -Notation Pmult_mult := Pos2Nat.inj_mul (only parsing). -Notation Pcompare_nat_compare := Pos2Nat.inj_compare (only parsing). -Notation nat_of_P_xH := Pos2Nat.inj_1 (only parsing). -Notation nat_of_P_xO := Pos2Nat.inj_xO (only parsing). -Notation nat_of_P_xI := Pos2Nat.inj_xI (only parsing). -Notation nat_of_P_is_S := Pos2Nat.is_succ (only parsing). -Notation nat_of_P_pos := Pos2Nat.is_pos (only parsing). -Notation nat_of_P_inj_iff := Pos2Nat.inj_iff (only parsing). -Notation nat_of_P_inj := Pos2Nat.inj (only parsing). -Notation Plt_lt := Pos2Nat.inj_lt (only parsing). -Notation Pgt_gt := Pos2Nat.inj_gt (only parsing). -Notation Ple_le := Pos2Nat.inj_le (only parsing). -Notation Pge_ge := Pos2Nat.inj_ge (only parsing). -Notation Pminus_minus := Pos2Nat.inj_sub (only parsing). -Notation iter_nat_of_P := @Pos2Nat.inj_iter (only parsing). - -Notation nat_of_P_of_succ_nat := SuccNat2Pos.id_succ (only parsing). -Notation P_of_succ_nat_of_P := Pos2SuccNat.id_succ (only parsing). - -Notation nat_of_P_succ_morphism := Pos2Nat.inj_succ (only parsing). -Notation nat_of_P_plus_morphism := Pos2Nat.inj_add (only parsing). -Notation nat_of_P_mult_morphism := Pos2Nat.inj_mul (only parsing). -Notation nat_of_P_compare_morphism := Pos2Nat.inj_compare (only parsing). -Notation lt_O_nat_of_P := Pos2Nat.is_pos (only parsing). -Notation ZL4 := Pos2Nat.is_succ (only parsing). -Notation nat_of_P_o_P_of_succ_nat_eq_succ := SuccNat2Pos.id_succ (only parsing). -Notation P_of_succ_nat_o_nat_of_P_eq_succ := Pos2SuccNat.id_succ (only parsing). -Notation pred_o_P_of_succ_nat_o_nat_of_P_eq_id := Pos2SuccNat.pred_id (only parsing). - -Lemma nat_of_P_minus_morphism p q : - Pos.compare_cont Eq p q = Gt -> - Pos.to_nat (p - q) = Pos.to_nat p - Pos.to_nat q. -Proof (fun H => Pos2Nat.inj_sub p q (Pos.gt_lt _ _ H)). - -Lemma nat_of_P_lt_Lt_compare_morphism p q : - Pos.compare_cont Eq p q = Lt -> Pos.to_nat p < Pos.to_nat q. -Proof (proj1 (Pos2Nat.inj_lt p q)). - -Lemma nat_of_P_gt_Gt_compare_morphism p q : - Pos.compare_cont Eq p q = Gt -> Pos.to_nat p > Pos.to_nat q. -Proof (proj1 (Pos2Nat.inj_gt p q)). - -Lemma nat_of_P_lt_Lt_compare_complement_morphism p q : - Pos.to_nat p < Pos.to_nat q -> Pos.compare_cont Eq p q = Lt. -Proof (proj2 (Pos2Nat.inj_lt p q)). - -Lemma nat_of_P_gt_Gt_compare_complement_morphism p q : - Pos.to_nat p > Pos.to_nat q -> Pos.compare_cont Eq p q = Gt. -Proof (proj2 (Pos2Nat.inj_gt p q)). - -(** Old intermediate results about [Pmult_nat] *) - -Section ObsoletePmultNat. - -Lemma Pmult_nat_mult : forall p n, - Pmult_nat p n = Pos.to_nat p * n. -Proof. - intro p; induction p as [p IHp|p IHp|]; intros n; unfold Pos.to_nat; simpl. - - f_equal. rewrite 2 IHp. rewrite <- Nat.mul_assoc. - f_equal. simpl. now rewrite Nat.add_0_r. - - rewrite 2 IHp. rewrite <- Nat.mul_assoc. - f_equal. simpl. now rewrite Nat.add_0_r. - - simpl. now rewrite Nat.add_0_r. -Qed. - -Lemma Pmult_nat_succ_morphism : - forall p n, Pmult_nat (Pos.succ p) n = n + Pmult_nat p n. -Proof. - intros. now rewrite !Pmult_nat_mult, Pos2Nat.inj_succ. -Qed. - -Theorem Pmult_nat_l_plus_morphism : - forall p q n, Pmult_nat (p + q) n = Pmult_nat p n + Pmult_nat q n. -Proof. - intros. rewrite !Pmult_nat_mult, Pos2Nat.inj_add. apply Nat.mul_add_distr_r. -Qed. - -Theorem Pmult_nat_plus_carry_morphism : - forall p q n, Pmult_nat (Pos.add_carry p q) n = n + Pmult_nat (p + q) n. -Proof. - intros. now rewrite Pos.add_carry_spec, Pmult_nat_succ_morphism. -Qed. - -Lemma Pmult_nat_r_plus_morphism : - forall p n, Pmult_nat p (n + n) = Pmult_nat p n + Pmult_nat p n. -Proof. - intros. rewrite !Pmult_nat_mult. apply Nat.mul_add_distr_l. -Qed. - -Lemma ZL6 : forall p, Pmult_nat p 2 = Pos.to_nat p + Pos.to_nat p. -Proof. - intros. rewrite Pmult_nat_mult, Nat.mul_comm. simpl. now rewrite Nat.add_0_r. -Qed. - -Lemma le_Pmult_nat : forall p n, n <= Pmult_nat p n. -Proof. - intros p n. rewrite Pmult_nat_mult. - apply Nat.le_trans with (1*n). - - now rewrite Nat.mul_1_l. - - apply Nat.mul_le_mono_r. apply Pos2Nat.is_pos. -Qed. - -End ObsoletePmultNat. diff --git a/stdlib/theories/Program/Basics.v b/stdlib/theories/Program/Basics.v deleted file mode 100644 index 95ea1db5a9dd..000000000000 --- a/stdlib/theories/Program/Basics.v +++ /dev/null @@ -1 +0,0 @@ -From Corelib Require Export Basics. diff --git a/stdlib/theories/Program/Combinators.v b/stdlib/theories/Program/Combinators.v deleted file mode 100644 index 8bf1e16f3ed7..000000000000 --- a/stdlib/theories/Program/Combinators.v +++ /dev/null @@ -1,68 +0,0 @@ -(* -*- coding: utf-8 -*- *) -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* B), id āˆ˜ f = f. -Proof. - intros. - reflexivity. -Qed. - -Lemma compose_id_right : forall A B (f : A -> B), f āˆ˜ id = f. -Proof. - intros. - reflexivity. -Qed. - -Lemma compose_assoc : forall A B C D (f : A -> B) (g : B -> C) (h : C -> D), - h āˆ˜ g āˆ˜ f = h āˆ˜ (g āˆ˜ f). -Proof. - intros. - reflexivity. -Qed. - -Global Hint Rewrite @compose_id_left @compose_id_right : core. -Global Hint Rewrite <- @compose_assoc : core. - -(** [flip] is involutive. *) - -Lemma flip_flip : forall A B C, @flip A B C āˆ˜ flip = id. -Proof. - intros. - reflexivity. -Qed. - -(** [uncurry] and [curry] are each others inverses. *) - -Lemma curry_uncurry : forall A B C, @curry A B C āˆ˜ uncurry = id. -Proof. - intros. - reflexivity. -Qed. - -Lemma uncurry_curry : forall A B C, @uncurry A B C āˆ˜ curry = id. -Proof. - simpl ; intros. - unfold curry, uncurry, compose. - extensionality x ; extensionality p. - destruct p ; simpl ; reflexivity. -Qed. diff --git a/stdlib/theories/Program/Equality.v b/stdlib/theories/Program/Equality.v deleted file mode 100644 index fe27b20f4546..000000000000 --- a/stdlib/theories/Program/Equality.v +++ /dev/null @@ -1,475 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* is_ground T - end. - -(** Try to find a contradiction. *) - -#[global] -Hint Extern 10 => is_ground_goal ; progress exfalso : exfalso. - -(** We will use the [block] definition to separate the goal from the - equalities generated by the tactic. *) - -Definition block {A : Type} (a : A) := a. - -Ltac block_goal := match goal with [ |- ?T ] => change (block T) end. -Ltac unblock_goal := unfold block in *. - -(** Notation for heterogeneous equality. *) -#[deprecated(since="8.17")] -Notation " x ~= y " := (@JMeq _ x _ y) (at level 70, no associativity). - -(** Do something on an heterogeneous equality appearing in the context. *) - -Ltac on_JMeq tac := - match goal with - | [ H : @JMeq ?x ?X ?y ?Y |- _ ] => tac H - end. - -(** Try to apply [JMeq_eq] to get back a regular equality when the two types are equal. *) - -Ltac simpl_one_JMeq := - on_JMeq ltac:(fun H => apply JMeq_eq in H). - -(** Repeat it for every possible hypothesis. *) - -Ltac simpl_JMeq := repeat simpl_one_JMeq. - -(** Just simplify an h.eq. without clearing it. *) - -Ltac simpl_one_dep_JMeq := - on_JMeq - ltac:(fun H => let H' := fresh "H" in - assert (H' := JMeq_eq H)). - -Require Import Eqdep. - -(** Simplify dependent equality using sigmas to equality of the second projections if possible. - Uses UIP. *) - -Ltac simpl_existT := - match goal with - [ H : existT _ ?x _ = existT _ ?x _ |- _ ] => - let Hi := fresh H in assert(Hi:=inj_pairT2 _ _ _ _ _ H) ; clear H - end. - -Ltac simpl_existTs := repeat simpl_existT. - -(** Tries to eliminate a call to [eq_rect] (the substitution principle) by any means available. *) - -Ltac elim_eq_rect := - match goal with - | [ |- ?t ] => - match t with - | context [ @eq_rect _ _ _ _ _ ?p ] => - let P := fresh "P" in - set (P := p); simpl in P ; - ((case P ; clear P) || (clearbody P; rewrite (UIP_refl _ _ P); clear P)) - | context [ @eq_rect _ _ _ _ _ ?p _ ] => - let P := fresh "P" in - set (P := p); simpl in P ; - ((case P ; clear P) || (clearbody P; rewrite (UIP_refl _ _ P); clear P)) - end - end. - -(** Rewrite using uniqueness of identity proofs [H = eq_refl]. *) - -Ltac simpl_uip := - match goal with - [ H : ?X = ?X |- _ ] => rewrite (UIP_refl _ _ H) in *; clear H - end. - -(** Simplify equalities appearing in the context and goal. *) - -Ltac simpl_eq := simpl ; unfold eq_rec_r, eq_rec ; repeat (elim_eq_rect ; simpl) ; repeat (simpl_uip ; simpl). - -(** Try to abstract a proof of equality, if no proof of the same equality is present in the context. *) - -Ltac abstract_eq_hyp H' p := - let ty := type of p in - let tyred := eval simpl in ty in - match tyred with - ?X = ?Y => - match goal with - | [ H : X = Y |- _ ] => fail 1 - | _ => set (H':=p) ; try (change p with H') ; clearbody H' ; simpl in H' - end - end. - -(** Apply the tactic tac to proofs of equality appearing as coercion arguments. - Just redefine this tactic (using [Ltac on_coerce_proof tac ::=]) to handle custom coercion operators. - *) - -Ltac on_coerce_proof tac T := - match T with - | context [ eq_rect _ _ _ _ ?p ] => tac p - end. - -Ltac on_coerce_proof_gl tac := - match goal with - [ |- ?T ] => on_coerce_proof tac T - end. - -(** Abstract proofs of equalities of coercions. *) - -Ltac abstract_eq_proof := on_coerce_proof_gl ltac:(fun p => let H := fresh "eqH" in abstract_eq_hyp H p). - -Ltac abstract_eq_proofs := repeat abstract_eq_proof. - -(** Factorize proofs, by using proof irrelevance so that two proofs of the same equality - in the goal become convertible. *) - -Ltac pi_eq_proof_hyp p := - let ty := type of p in - let tyred := eval simpl in ty in - match tyred with - ?X = ?Y => - match goal with - | [ H : X = Y |- _ ] => - match p with - | H => fail 2 - | _ => rewrite (UIP _ X Y p H) - end - | _ => fail " No hypothesis with same type " - end - end. - -(** Factorize proofs of equality appearing as coercion arguments. *) - -Ltac pi_eq_proof := on_coerce_proof_gl pi_eq_proof_hyp. - -Ltac pi_eq_proofs := repeat pi_eq_proof. - -(** The two preceding tactics in sequence. *) - -Ltac clear_eq_proofs := - abstract_eq_proofs ; pi_eq_proofs. - -Global Hint Rewrite <- eq_rect_eq : refl_id. - -(** The [refl_id] database should be populated with lemmas of the form - [coerce_* t eq_refl = t]. *) - -Lemma JMeq_eq_refl {A} (x : A) : JMeq_eq (@JMeq_refl _ x) = eq_refl. -Proof. apply UIP. Qed. - -Lemma UIP_refl_refl A (x : A) : - Eqdep.EqdepTheory.UIP_refl A x eq_refl = eq_refl. -Proof. apply UIP_refl. Qed. - -Lemma inj_pairT2_refl A (x : A) (P : A -> Type) (p : P x) : - Eqdep.EqdepTheory.inj_pairT2 A P x p p eq_refl = eq_refl. -Proof. apply UIP_refl. Qed. - -Global Hint Rewrite @JMeq_eq_refl @UIP_refl_refl @inj_pairT2_refl : refl_id. - -Ltac rewrite_refl_id := autorewrite with refl_id. - -(** Clear the context and goal of equality proofs. *) - -Ltac clear_eq_ctx := - rewrite_refl_id ; clear_eq_proofs. - -(** Reapeated elimination of [eq_rect] applications. - Abstracting equalities makes it run much faster than an naive implementation. *) - -Ltac simpl_eqs := - repeat (elim_eq_rect ; simpl ; clear_eq_ctx). - -(** Clear unused reflexivity proofs. *) - -Ltac clear_refl_eq := - match goal with [ H : ?X = ?X |- _ ] => clear H end. -Ltac clear_refl_eqs := repeat clear_refl_eq. - -(** Clear unused equality proofs. *) - -Ltac clear_eq := - match goal with [ H : _ = _ |- _ ] => clear H end. -Ltac clear_eqs := repeat clear_eq. - -(** Combine all the tactics to simplify goals containing coercions. *) - -Ltac simplify_eqs := - simpl ; simpl_eqs ; clear_eq_ctx ; clear_refl_eqs ; - try subst ; simpl ; repeat simpl_uip ; rewrite_refl_id. - -(** A tactic that tries to remove trivial equality guards in induction hypotheses coming - from [dependent induction]/[generalize_eqs] invocations. *) - -Ltac simplify_IH_hyps := repeat - match goal with - | [ hyp : context [ block _ ] |- _ ] => - specialize_eqs hyp - end. - -(** We split substitution tactics in the two directions depending on which - names we want to keep corresponding to the generalization performed by the - [generalize_eqs] tactic. *) - -Ltac subst_left_no_fail := - repeat (match goal with - [ H : ?X = ?Y |- _ ] => subst X - end). - -Ltac subst_right_no_fail := - repeat (match goal with - [ H : ?X = ?Y |- _ ] => subst Y - end). - -Ltac inject_left H := - progress (inversion H ; subst_left_no_fail ; clear_dups) ; clear H. - -Ltac inject_right H := - progress (inversion H ; subst_right_no_fail ; clear_dups) ; clear H. - -Ltac autoinjections_left := repeat autoinjection ltac:(inject_left). -Ltac autoinjections_right := repeat autoinjection ltac:(inject_right). - -Ltac simpl_depind := subst_no_fail ; autoinjections ; try discriminates ; - simpl_JMeq ; simpl_existTs ; simplify_IH_hyps. - -Ltac simpl_depind_l := subst_left_no_fail ; autoinjections_left ; try discriminates ; - simpl_JMeq ; simpl_existTs ; simplify_IH_hyps. - -Ltac simpl_depind_r := subst_right_no_fail ; autoinjections_right ; try discriminates ; - simpl_JMeq ; simpl_existTs ; simplify_IH_hyps. - -Ltac blocked t := block_goal ; t ; unblock_goal. - -(** The [DependentEliminationPackage] provides the default dependent elimination principle to - be used by the [equations] resolver. It is especially useful to register the dependent elimination - principles for things in [Prop] which are not automatically generated. *) - -Class DependentEliminationPackage (A : Type) := - { elim_type : Type ; elim : elim_type }. - -(** A higher-order tactic to apply a registered eliminator. *) - -Ltac elim_tac tac p := - let ty := type of p in - let eliminator := eval simpl in (@elim _ (_ : DependentEliminationPackage ty)) in - tac p eliminator. - -(** Specialization to do case analysis or induction. - Note: the [equations] tactic tries [case] before [elim_case]: there is no need to register - generated induction principles. *) - -Ltac elim_case p := elim_tac ltac:(fun p el => destruct p using el) p. -Ltac elim_ind p := elim_tac ltac:(fun p el => induction p using el) p. - -(** Lemmas used by the simplifier, mainly rephrasings of [eq_rect], [eq_ind]. *) - -Lemma solution_left A (B : A -> Type) (t : A) : - B t -> (forall x, x = t -> B x). -Proof. intros; subst; assumption. Defined. - -Lemma solution_right A (B : A -> Type) (t : A) : - B t -> (forall x, t = x -> B x). -Proof. intros; subst; assumption. Defined. - -Lemma deletion A B (t : A) : B -> (t = t -> B). -Proof. intros; assumption. Defined. - -Lemma simplification_heq A B (x y : A) : - (x = y -> B) -> (JMeq x y -> B). -Proof. intros H J; apply H; apply (JMeq_eq J). Defined. - -Definition conditional_eq {A} (x y : A) := eq x y. - -Lemma simplification_existT2 A (P : A -> Type) B (p : A) (x y : P p) : - (x = y -> B) -> (conditional_eq (existT P p x) (existT P p y) -> B). -Proof. intros H E. apply H. apply inj_pair2. assumption. Defined. - -Lemma simplification_existT1 A (P : A -> Type) B (p q : A) (x : P p) (y : P q) : - (p = q -> conditional_eq (existT P p x) (existT P q y) -> B) -> (existT P p x = existT P q y -> B). -Proof. injection 2. auto. Defined. - -Lemma simplification_K A (x : A) (B : x = x -> Type) : - B eq_refl -> (forall p : x = x, B p). -Proof. intros. rewrite (UIP_refl A). assumption. Defined. - -(** This hint database and the following tactic can be used with [autounfold] to - unfold everything to [eq_rect]s. *) - -#[global] -Hint Unfold solution_left solution_right deletion simplification_heq - simplification_existT1 simplification_existT2 simplification_K - eq_rect_r eq_rec eq_ind : dep_elim. - -(** Using these we can make a simplifier that will perform the unification - steps needed to put the goal in normalised form (provided there are only - constructor forms). Compare with the lemma 16 of the paper. - We don't have a [noCycle] procedure yet. *) - -Ltac simplify_one_dep_elim_term c := - match c with - | @JMeq _ _ _ _ -> _ => refine (simplification_heq _ _ _ _ _) - | ?t = ?t -> _ => intros _ || refine (simplification_K _ t _ _) - | eq (existT _ _ _) (existT _ _ _) -> _ => - refine (simplification_existT1 _ _ _ _ _ _ _ _) - | conditional_eq (existT _ _ _) (existT _ _ _) -> _ => - refine (simplification_existT2 _ _ _ _ _ _ _) || - (unfold conditional_eq; intro) - | ?x = ?y -> _ => (* variables case *) - (unfold x) || (unfold y) || - (let hyp := fresh in intros hyp ; - move hyp before x ; revert_until hyp ; generalize dependent x ; - refine (solution_left _ _ _ _)(* ; intros until 0 *)) || - (let hyp := fresh in intros hyp ; - move hyp before y ; revert_until hyp ; generalize dependent y ; - refine (solution_right _ _ _ _)(* ; intros until 0 *)) - | ?f ?x = ?g ?y -> _ => let H := fresh in progress (intros H ; simple injection H; clear H) - | ?t = ?u -> _ => let hyp := fresh in - intros hyp ; exfalso ; discriminate - | ?x = ?y -> _ => let hyp := fresh in - intros hyp ; (try (clear hyp ; (* If non dependent, don't clear it! *) fail 1)) ; - case hyp ; clear hyp - | block ?T => fail 1 (* Do not put any part of the rhs in the hyps *) - | forall x, _ => intro x || (let H := fresh x in rename x into H ; intro x) (* Try to keep original names *) - | _ => intro - end. - -Ltac simplify_one_dep_elim := - match goal with - | [ |- ?gl ] => simplify_one_dep_elim_term gl - end. - -(** Repeat until no progress is possible. By construction, it should leave the goal with - no remaining equalities generated by the [generalize_eqs] tactic. *) - -Ltac simplify_dep_elim := repeat simplify_one_dep_elim. - -(** Do dependent elimination of the last hypothesis, but not simplifying yet - (used internally). *) - -Ltac destruct_last := - on_last_hyp ltac:(fun id => simpl in id ; generalize_eqs id ; destruct id). - -Ltac introduce p := first [ - match p with _ => (* Already there, generalize dependent hyps *) - generalize dependent p ; intros p - end - | intros until p | intros until 1 | intros ]. - -Ltac do_case p := introduce p ; (destruct p || elim_case p || (case p ; clear p)). -Ltac do_ind p := introduce p ; (induction p || elim_ind p). - -(** The following tactics allow to do induction on an already instantiated inductive predicate - by first generalizing it and adding the proper equalities to the context, in a maner similar to - the BasicElim tactic of "Elimination with a motive" by Conor McBride. *) - -(** The [do_depelim] higher-order tactic takes an elimination tactic as argument and an hypothesis - and starts a dependent elimination using this tactic. *) - -Ltac is_introduced H := - match goal with - | [ H' : _ |- _ ] => match H' with H => idtac end - end. - -Tactic Notation "intro_block" hyp(H) := - (is_introduced H ; block_goal ; revert_until H ; block_goal) || - (let H' := fresh H in intros until H' ; block_goal) || (intros ; block_goal). - -Tactic Notation "intro_block_id" ident(H) := - (is_introduced H ; block_goal ; revert_until H; block_goal) || - (let H' := fresh H in intros until H' ; block_goal) || (intros ; block_goal). - -Ltac unblock_dep_elim := - match goal with - | |- block ?T => - match T with context [ block _ ] => - change T ; intros ; unblock_goal - end - | _ => unblock_goal - end. - -Ltac simpl_dep_elim := simplify_dep_elim ; simplify_IH_hyps ; unblock_dep_elim. - -Ltac do_intros H := - (try intros until H) ; (intro_block_id H || intro_block H). - -Ltac do_depelim_nosimpl tac H := do_intros H ; generalize_eqs H ; tac H. - -Ltac do_depelim tac H := do_depelim_nosimpl tac H ; simpl_dep_elim. - -Ltac do_depind tac H := - (try intros until H) ; intro_block H ; - generalize_eqs_vars H ; tac H ; simpl_dep_elim. - -(** To dependent elimination on some hyp. *) - -Ltac depelim id := do_depelim ltac:(fun hyp => do_case hyp) id. - -(** Used internally. *) - -Ltac depelim_nosimpl id := do_depelim_nosimpl ltac:(fun hyp => do_case hyp) id. - -(** To dependent induction on some hyp. *) - -Ltac depind id := do_depind ltac:(fun hyp => do_ind hyp) id. - -(** A variant where generalized variables should be given by the user. *) - -Ltac do_depelim' rev tac H := - (try intros until H) ; block_goal ; - (try revert_until H ; block_goal) ; - generalize_eqs H ; rev H ; tac H ; simpl_dep_elim. - -(** Calls [destruct] on the generalized hypothesis, results should be similar to inversion. - By default, we don't try to generalize the hyp by its variable indices. *) - -Tactic Notation "dependent" "destruction" ident(H) := - do_depelim' ltac:(fun hyp => idtac) ltac:(fun hyp => do_case hyp) H. - -Tactic Notation "dependent" "destruction" ident(H) "using" constr(c) := - do_depelim' ltac:(fun hyp => idtac) ltac:(fun hyp => destruct hyp using c) H. - -(** This tactic also generalizes the goal by the given variables before the elimination. *) - -Tactic Notation "dependent" "destruction" ident(H) "generalizing" ne_hyp_list(l) := - do_depelim' ltac:(fun hyp => revert l) ltac:(fun hyp => do_case hyp) H. - -Tactic Notation "dependent" "destruction" ident(H) "generalizing" ne_hyp_list(l) "using" constr(c) := - do_depelim' ltac:(fun hyp => revert l) ltac:(fun hyp => destruct hyp using c) H. - -(** Then we have wrappers for usual calls to induction. One can customize the induction tactic by - writing another wrapper calling do_depelim. We suppose the hyp has to be generalized before - calling [induction]. *) - -Tactic Notation "dependent" "induction" ident(H) := - do_depind ltac:(fun hyp => do_ind hyp) H. - -Tactic Notation "dependent" "induction" ident(H) "using" constr(c) := - do_depind ltac:(fun hyp => induction hyp using c) H. - -(** This tactic also generalizes the goal by the given variables before the induction. *) - -Tactic Notation "dependent" "induction" ident(H) "generalizing" ne_hyp_list(l) := - do_depelim' ltac:(fun hyp => revert l) ltac:(fun hyp => do_ind hyp) H. - -Tactic Notation "dependent" "induction" ident(H) "generalizing" ne_hyp_list(l) "using" constr(c) := - do_depelim' ltac:(fun hyp => revert l) ltac:(fun hyp => induction hyp using c) H. - -Tactic Notation "dependent" "induction" ident(H) "in" ne_hyp_list(l) := - do_depelim' ltac:(fun hyp => idtac) ltac:(fun hyp => induction hyp in l) H. - -Tactic Notation "dependent" "induction" ident(H) "in" ne_hyp_list(l) "using" constr(c) := - do_depelim' ltac:(fun hyp => idtac) ltac:(fun hyp => induction hyp in l using c) H. diff --git a/stdlib/theories/Program/Program.v b/stdlib/theories/Program/Program.v deleted file mode 100644 index 456ae760d44e..000000000000 --- a/stdlib/theories/Program/Program.v +++ /dev/null @@ -1,17 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* try on_subset_proof_aux tac P ; tac p - end. - -Ltac on_subset_proof tac := - match goal with - [ |- ?T ] => on_subset_proof_aux tac T - end. - -Ltac abstract_any_hyp H' p := - match type of p with - ?X => - match goal with - | [ H : X |- _ ] => fail 1 - | _ => set (H':=p) ; try (change p with H') ; clearbody H' - end - end. - -Ltac abstract_subset_proof := - on_subset_proof ltac:(fun p => let H := fresh "eqH" in abstract_any_hyp H p ; simpl in H). - -Ltac abstract_subset_proofs := repeat abstract_subset_proof. - -Ltac pi_subset_proof_hyp p := - match type of p with - ?X => - match goal with - | [ H : X |- _ ] => - match p with - | H => fail 2 - | _ => rewrite (proof_irrelevance X p H) - end - | _ => fail " No hypothesis with same type " - end - end. - -Ltac pi_subset_proof := on_subset_proof pi_subset_proof_hyp. - -Ltac pi_subset_proofs := repeat pi_subset_proof. - -(** The two preceding tactics in sequence. *) - -Ltac clear_subset_proofs := - abstract_subset_proofs ; simpl in * |- ; pi_subset_proofs ; clear_dups. - -Ltac pi := repeat f_equal ; apply proof_irrelevance. - -Lemma subset_eq : forall A (P : A -> Prop) (n m : sig P), n = m <-> `n = `m. -Proof. - intros A P n m. - destruct n as (x,p). - destruct m as (x',p'). - simpl. - split ; intros H ; subst. - - - inversion H. - reflexivity. - - - pi. -Qed. - -(* Somewhat trivial definition, but not unfolded automatically hence we can match on [match_eq ?A ?B ?x ?f] - in tactics. *) - -Definition match_eq (A B : Type) (x : A) (fn : {y : A | y = x} -> B) : B := - fn (exist _ x eq_refl). - -(* This is what we want to be able to do: replace the originally matched object by a new, - propositionally equal one. If [fn] works on [x] it should work on any [y | y = x]. *) - -Lemma match_eq_rewrite : forall (A B : Type) (x : A) (fn : {y : A | y = x} -> B) - (y : {y:A | y = x}), - match_eq A B x fn = fn y. -Proof. - intros A B x fn y. - unfold match_eq. - f_equal. - destruct y. - (* uses proof-irrelevance *) - apply <- subset_eq. - symmetry. assumption. -Qed. - -(** Now we make a tactic to be able to rewrite a term [t] which is applied to a [match_eq] using an arbitrary - equality [t = u], and [u] is now the subject of the [match]. *) - -Ltac rewrite_match_eq H := - match goal with - [ |- ?T ] => - match T with - context [ match_eq ?A ?B ?t ?f ] => - rewrite (match_eq_rewrite A B t f (exist _ _ (eq_sym H))) - end - end. - -(** Otherwise we can simply unfold [match_eq] and the term trivially reduces to the original definition. *) - -Ltac simpl_match_eq := unfold match_eq ; simpl. diff --git a/stdlib/theories/Program/Syntax.v b/stdlib/theories/Program/Syntax.v deleted file mode 100644 index 46875c6d05d6..000000000000 --- a/stdlib/theories/Program/Syntax.v +++ /dev/null @@ -1,31 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* A -> Prop) (Rwf : well_founded R) - (P : A -> Type) - (F_sub : forall x : A, (forall y:{y : A | R y x}, P (` y)) -> P x), - forall x : A, - Fix_sub A R Rwf P F_sub x = - F_sub x (fun y:{y : A | R y x} => Fix_sub A R Rwf P F_sub (` y)). - Proof. - intros A R Rwf P F_sub x; apply Fix_eq ; auto. - intros ? f g H. - assert(f = g) as H0. - - extensionality y ; apply H. - - rewrite H0 ; auto. - Qed. - - (** Tactic to unfold once a definition based on [Fix_sub]. *) - - Ltac unfold_sub f fargs := - set (call:=fargs) ; unfold f in call ; unfold call ; clear call ; - rewrite fix_sub_eq_ext ; repeat fold_sub f ; simpl proj1_sig. - -End WfExtensionality. diff --git a/stdlib/theories/QArith/QArith.v b/stdlib/theories/QArith/QArith.v deleted file mode 100644 index 328f0e8f3b3f..000000000000 --- a/stdlib/theories/QArith/QArith.v +++ /dev/null @@ -1,13 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* y" := (Qlt y x)(only parsing) : Q_scope. -Notation "x >= y" := (Qle y x)(only parsing) : Q_scope. -Notation "x <= y <= z" := (x<=y/\y<=z) : Q_scope. -Notation "x <= y < z" := (x<=y/\y a=b. -Proof. - intros a b p. - unfold Qeq. - apply Z.mul_cancel_r, not_eq_sym, Z.lt_neq, Pos2Z.is_pos. -Qed. - -Lemma Qnum_cancel : forall (a b : positive) (z : Z), - z<>0%Z -> (z#a)==(z#b) -> a=b. -Proof. - intros a b z Hz_ne_0. - unfold Qeq. - rewrite Z.eq_sym_iff, <- Pos2Z.inj_iff. - apply (Z.mul_reg_l _ _ _ Hz_ne_0). -Qed. - -(** injection from Z is injective. *) - -Lemma inject_Z_injective (a b: Z): inject_Z a == inject_Z b <-> a = b. -Proof. - unfold Qeq; simpl; rewrite !Z.mul_1_r; reflexivity. -Qed. - -(** Another approach : using Qcompare for defining order relations. *) - -Definition Qcompare (p q : Q) := (Qnum p * QDen q ?= Qnum q * QDen p)%Z. -Notation "p ?= q" := (Qcompare p q) : Q_scope. - -Lemma Qeq_alt p q : (p == q) <-> (p ?= q) = Eq. -Proof. -symmetry. apply Z.compare_eq_iff. -Qed. - -Lemma Qlt_alt p q : (p (p?=q = Lt). -Proof. -reflexivity. -Qed. - -Lemma Qgt_alt p q : (p>q) <-> (p?=q = Gt). -Proof. -symmetry. apply Z.gt_lt_iff. -Qed. - -Lemma Qle_alt p q : (p<=q) <-> (p?=q <> Gt). -Proof. -reflexivity. -Qed. - -Lemma Qge_alt p q : (p>=q) <-> (p?=q <> Lt). -Proof. -symmetry. apply Z.ge_le_iff. -Qed. - -#[global] -Hint Unfold Qeq Qlt Qle : qarith. -#[global] -Hint Extern 5 (?X1 <> ?X2) => intro; discriminate: qarith. - -Lemma Qcompare_antisym x y : CompOpp (x ?= y) = (y ?= x). -Proof. - symmetry. apply Z.compare_antisym. -Qed. - -Lemma Qcompare_spec x y : CompareSpec (x==y) (x y == x. -Proof. - auto with qarith. -Qed. - -Theorem Qeq_trans x y z : x == y -> y == z -> x == z. -Proof. -unfold Qeq; intros XY YZ. -apply Z.mul_reg_r with (QDen y); [auto with qarith|]. -now rewrite Z.mul_shuffle0, XY, Z.mul_shuffle0, YZ, Z.mul_shuffle0. -Qed. - -#[global] -Hint Immediate Qeq_sym : qarith. -#[global] -Hint Resolve Qeq_refl Qeq_trans : qarith. - -(** In a word, [Qeq] is a setoid equality. *) - -#[global] -Instance Q_Setoid : Equivalence Qeq. -Proof. split; red; eauto with qarith. Qed. - -(** Furthermore, this equality is decidable: *) - -Theorem Qeq_dec x y : {x==y} + {~ x==y}. -Proof. - apply Z.eq_dec. -Defined. - -Definition Qeq_bool x y := - (Z.eqb (Qnum x * QDen y) (Qnum y * QDen x))%Z. - -Definition Qle_bool x y := - (Z.leb (Qnum x * QDen y) (Qnum y * QDen x))%Z. - -Lemma Qeq_bool_iff x y : Qeq_bool x y = true <-> x == y. -Proof. apply Z.eqb_eq. Qed. - -Lemma Qeq_bool_eq x y : Qeq_bool x y = true -> x == y. -Proof. - apply Qeq_bool_iff. -Qed. - -Lemma Qeq_eq_bool x y : x == y -> Qeq_bool x y = true. -Proof. - apply Qeq_bool_iff. -Qed. - -Lemma Qeq_bool_neq x y : Qeq_bool x y = false -> ~ x == y. -Proof. - rewrite <- Qeq_bool_iff. now intros ->. -Qed. - -Lemma Qle_bool_iff x y : Qle_bool x y = true <-> x <= y. -Proof. apply Z.leb_le. Qed. - -Lemma Qle_bool_imp_le x y : Qle_bool x y = true -> x <= y. -Proof. - apply Qle_bool_iff. -Qed. - -Theorem Qnot_eq_sym x y : ~x == y -> ~y == x. -Proof. - auto with qarith. -Qed. - -Lemma Qeq_bool_comm x y: Qeq_bool x y = Qeq_bool y x. -Proof. - apply eq_true_iff_eq. rewrite !Qeq_bool_iff. now symmetry. -Qed. - -Lemma Qeq_bool_refl x: Qeq_bool x x = true. -Proof. - rewrite Qeq_bool_iff. now reflexivity. -Qed. - -Lemma Qeq_bool_sym x y: Qeq_bool x y = true -> Qeq_bool y x = true. -Proof. - rewrite !Qeq_bool_iff. now symmetry. -Qed. - -Lemma Qeq_bool_trans x y z: Qeq_bool x y = true -> Qeq_bool y z = true -> Qeq_bool x z = true. -Proof. - rewrite !Qeq_bool_iff; apply Qeq_trans. -Qed. - -#[global] -Hint Resolve Qnot_eq_sym : qarith. - -(** * Addition, multiplication and opposite *) - -(** The addition, multiplication and opposite are defined - in the straightforward way: *) - -Definition Qplus (x y : Q) := - (Qnum x * QDen y + Qnum y * QDen x) # (Qden x * Qden y). - -Definition Qmult (x y : Q) := (Qnum x * Qnum y) # (Qden x * Qden y). - -Definition Qopp (x : Q) := (- Qnum x) # (Qden x). - -Definition Qminus (x y : Q) := Qplus x (Qopp y). - -Definition Qinv (x : Q) := - match Qnum x with - | Z0 => 0#1 - | Zpos p => (QDen x)#p - | Zneg p => (Zneg (Qden x))#p - end. - -Definition Qdiv (x y : Q) := Qmult x (Qinv y). - -Infix "+" := Qplus : Q_scope. -Notation "- x" := (Qopp x) : Q_scope. -Infix "-" := Qminus : Q_scope. -Infix "*" := Qmult : Q_scope. -Notation "/ x" := (Qinv x) : Q_scope. -Infix "/" := Qdiv : Q_scope. - -Register Qplus as rat.Q.Qplus. -Register Qminus as rat.Q.Qminus. -Register Qopp as rat.Q.Qopp. -Register Qmult as rat.Q.Qmult. - -(** Number notation for constants *) - -Inductive IZ := - | IZpow_pos : Z -> positive -> IZ - | IZ0 : IZ - | IZpos : positive -> IZ - | IZneg : positive -> IZ. - -Inductive IQ := - | IQmake : IZ -> positive -> IQ - | IQmult : IQ -> IQ -> IQ - | IQdiv : IQ -> IQ -> IQ. - -Definition IZ_of_Z z := - match z with - | Z0 => IZ0 - | Zpos e => IZpos e - | Zneg e => IZneg e - end. - -Definition IZ_to_Z z := - match z with - | IZ0 => Some Z0 - | IZpos e => Some (Zpos e) - | IZneg e => Some (Zneg e) - | IZpow_pos _ _ => None - end. - -Definition of_decimal (d:Decimal.decimal) : IQ := - let '(i, f, e) := - match d with - | Decimal.Decimal i f => (i, f, Decimal.Pos Decimal.Nil) - | Decimal.DecimalExp i f e => (i, f, e) - end in - let num := Z.of_int (Decimal.app_int i f) in - let den := Nat.iter (Decimal.nb_digits f) (Pos.mul 10) 1%positive in - let q := IQmake (IZ_of_Z num) den in - let e := Z.of_int e in - match e with - | Z0 => q - | Zpos e => IQmult q (IQmake (IZpow_pos 10 e) 1) - | Zneg e => IQdiv q (IQmake (IZpow_pos 10 e) 1) - end. - -Definition IQmake_to_decimal num den := - let num := Z.to_int num in - let (den, e_den) := Decimal.nztail (Pos.to_uint den) in - match den with - | Decimal.D1 Decimal.Nil => - match e_den with - | O => Some (Decimal.Decimal num Decimal.Nil) - | ne => - let ai := Decimal.abs num in - let ni := Decimal.nb_digits ai in - if Nat.ltb ne ni then - let i := Decimal.del_tail_int ne num in - let f := Decimal.del_head (Nat.sub ni ne) ai in - Some (Decimal.Decimal i f) - else - let z := match num with - | Decimal.Pos _ => Decimal.Pos (Decimal.zero) - | Decimal.Neg _ => Decimal.Neg (Decimal.zero) end in - Some (Decimal.Decimal z (Nat.iter (Nat.sub ne ni) Decimal.D0 ai)) - end - | _ => None - end. - -Definition IQmake_to_decimal' num den := - match IZ_to_Z num with - | None => None - | Some num => IQmake_to_decimal num den - end. - -Definition to_decimal (n : IQ) : option Decimal.decimal := - match n with - | IQmake num den => IQmake_to_decimal' num den - | IQmult (IQmake num den) (IQmake (IZpow_pos 10 e) 1) => - match IQmake_to_decimal' num den with - | Some (Decimal.Decimal i f) => - Some (Decimal.DecimalExp i f (Pos.to_int e)) - | _ => None - end - | IQdiv (IQmake num den) (IQmake (IZpow_pos 10 e) 1) => - match IQmake_to_decimal' num den with - | Some (Decimal.Decimal i f) => - Some (Decimal.DecimalExp i f (Decimal.Neg (Pos.to_uint e))) - | _ => None - end - | _ => None - end. - -Definition of_hexadecimal (d:Hexadecimal.hexadecimal) : IQ := - let '(i, f, e) := - match d with - | Hexadecimal.Hexadecimal i f => (i, f, Decimal.Pos Decimal.Nil) - | Hexadecimal.HexadecimalExp i f e => (i, f, e) - end in - let num := Z.of_hex_int (Hexadecimal.app_int i f) in - let den := Nat.iter (Hexadecimal.nb_digits f) (Pos.mul 16) 1%positive in - let q := IQmake (IZ_of_Z num) den in - let e := Z.of_int e in - match e with - | Z0 => q - | Zpos e => IQmult q (IQmake (IZpow_pos 2 e) 1) - | Zneg e => IQdiv q (IQmake (IZpow_pos 2 e) 1) - end. - -Definition IQmake_to_hexadecimal num den := - let num := Z.to_hex_int num in - let (den, e_den) := Hexadecimal.nztail (Pos.to_hex_uint den) in - match den with - | Hexadecimal.D1 Hexadecimal.Nil => - match e_den with - | O => Some (Hexadecimal.Hexadecimal num Hexadecimal.Nil) - | ne => - let ai := Hexadecimal.abs num in - let ni := Hexadecimal.nb_digits ai in - if Nat.ltb ne ni then - let i := Hexadecimal.del_tail_int ne num in - let f := Hexadecimal.del_head (Nat.sub ni ne) ai in - Some (Hexadecimal.Hexadecimal i f) - else - let z := match num with - | Hexadecimal.Pos _ => Hexadecimal.Pos (Hexadecimal.zero) - | Hexadecimal.Neg _ => Hexadecimal.Neg (Hexadecimal.zero) end in - Some (Hexadecimal.Hexadecimal z (Nat.iter (Nat.sub ne ni) Hexadecimal.D0 ai)) - end - | _ => None - end. - -Definition IQmake_to_hexadecimal' num den := - match IZ_to_Z num with - | None => None - | Some num => IQmake_to_hexadecimal num den - end. - -Definition to_hexadecimal (n : IQ) : option Hexadecimal.hexadecimal := - match n with - | IQmake num den => IQmake_to_hexadecimal' num den - | IQmult (IQmake num den) (IQmake (IZpow_pos 2 e) 1) => - match IQmake_to_hexadecimal' num den with - | Some (Hexadecimal.Hexadecimal i f) => - Some (Hexadecimal.HexadecimalExp i f (Pos.to_int e)) - | _ => None - end - | IQdiv (IQmake num den) (IQmake (IZpow_pos 2 e) 1) => - match IQmake_to_hexadecimal' num den with - | Some (Hexadecimal.Hexadecimal i f) => - Some (Hexadecimal.HexadecimalExp i f (Decimal.Neg (Pos.to_uint e))) - | _ => None - end - | _ => None - end. - -Definition of_number (n : Number.number) : IQ := - match n with - | Number.Decimal d => of_decimal d - | Number.Hexadecimal h => of_hexadecimal h - end. - -Definition to_number (q:IQ) : option Number.number := - match to_decimal q with - | None => None - | Some q => Some (Number.Decimal q) - end. - -Definition to_hex_number q := - match to_hexadecimal q with - | None => None - | Some q => Some (Number.Hexadecimal q) - end. - -Number Notation Q of_number to_hex_number (via IQ - mapping [Qmake => IQmake, Qmult => IQmult, Qdiv => IQdiv, - Z.pow_pos => IZpow_pos, Z0 => IZ0, Zpos => IZpos, Zneg => IZneg]) - : hex_Q_scope. - -Number Notation Q of_number to_number (via IQ - mapping [Qmake => IQmake, Qmult => IQmult, Qdiv => IQdiv, - Z.pow_pos => IZpow_pos, Z0 => IZ0, Zpos => IZpos, Zneg => IZneg]) - : Q_scope. - -(** A light notation for [Zpos] *) - -Lemma Qmake_Qdiv a b : a#b==inject_Z a/inject_Z (Zpos b). -Proof. -unfold Qeq. simpl. ring. -Qed. - -(** * Setoid compatibility results *) - -#[global] -Instance Qplus_comp : Proper (Qeq==>Qeq==>Qeq) Qplus. -Proof. - unfold Qeq, Qplus; simpl. - Open Scope Z_scope. - intros (p1, p2) (q1, q2) H (r1, r2) (s1, s2) H0; simpl in *. - simpl_mult; ring_simplify. - replace (p1 * Zpos r2 * Zpos q2) with (p1 * Zpos q2 * Zpos r2) by ring. - rewrite H. - replace (r1 * Zpos p2 * Zpos q2 * Zpos s2) with (r1 * Zpos s2 * Zpos p2 * Zpos q2) by ring. - rewrite H0. - ring. - Close Scope Z_scope. -Qed. - -#[global] -Instance Qopp_comp : Proper (Qeq==>Qeq) Qopp. -Proof. - unfold Qeq, Qopp; simpl. - Open Scope Z_scope. - intros x y H; simpl. - replace (- Qnum x * Zpos (Qden y)) with (- (Qnum x * Zpos (Qden y))) by ring. - rewrite H; ring. - Close Scope Z_scope. -Qed. - -#[global] -Instance Qminus_comp : Proper (Qeq==>Qeq==>Qeq) Qminus. -Proof. - intros x x' Hx y y' Hy. - unfold Qminus. rewrite Hx, Hy; auto with qarith. -Qed. - -#[global] -Instance Qmult_comp : Proper (Qeq==>Qeq==>Qeq) Qmult. -Proof. - unfold Qeq; simpl. - Open Scope Z_scope. - intros (p1, p2) (q1, q2) H (r1, r2) (s1, s2) H0; simpl in *. - intros; simpl_mult; ring_simplify. - replace (q1 * s1 * Zpos p2) with (q1 * Zpos p2 * s1) by ring. - rewrite <- H. - replace (p1 * r1 * Zpos q2 * Zpos s2) with (r1 * Zpos s2 * p1 * Zpos q2) by ring. - rewrite H0. - ring. - Close Scope Z_scope. -Qed. - -#[global] -Instance Qinv_comp : Proper (Qeq==>Qeq) Qinv. -Proof. - unfold Qeq, Qinv; simpl. - Open Scope Z_scope. - intros (p1, p2) (q1, q2) EQ; simpl in *. - destruct q1; simpl in *. - - apply Z.mul_eq_0 in EQ. destruct EQ; now subst. - - destruct p1; simpl in *; try discriminate. - now rewrite Pos.mul_comm, <- EQ, Pos.mul_comm. - - destruct p1; simpl in *; try discriminate. - now rewrite Pos.mul_comm, <- EQ, Pos.mul_comm. - Close Scope Z_scope. -Qed. - -#[global] -Instance Qdiv_comp : Proper (Qeq==>Qeq==>Qeq) Qdiv. -Proof. - intros x x' Hx y y' Hy; unfold Qdiv. - rewrite Hx, Hy; auto with qarith. -Qed. - -#[global] -Instance Qcompare_comp : Proper (Qeq==>Qeq==>eq) Qcompare. -Proof. - unfold Qeq, Qcompare. - Open Scope Z_scope. - intros (p1,p2) (q1,q2) H (r1,r2) (s1,s2) H'; simpl in *. - rewrite <- (Zcompare.Zcompare_mult_compat (q2*s2) (p1*Zpos r2)). - rewrite <- (Zcompare.Zcompare_mult_compat (p2*r2) (q1*Zpos s2)). - change (Zpos (q2*s2)) with (Zpos q2 * Zpos s2). - change (Zpos (p2*r2)) with (Zpos p2 * Zpos r2). - replace (Zpos q2 * Zpos s2 * (p1*Zpos r2)) with ((p1*Zpos q2)*Zpos r2*Zpos s2) by ring. - rewrite H. - replace (Zpos q2 * Zpos s2 * (r1*Zpos p2)) with ((r1*Zpos s2)*Zpos q2*Zpos p2) by ring. - rewrite H'. - f_equal; ring. - Close Scope Z_scope. -Qed. - -#[global] -Instance Qle_comp : Proper (Qeq==>Qeq==>iff) Qle. -Proof. - intros p q H r s H'. rewrite 2 Qle_alt, H, H'; auto with *. -Qed. - -#[global] -Instance Qlt_compat : Proper (Qeq==>Qeq==>iff) Qlt. -Proof. - intros p q H r s H'. rewrite 2 Qlt_alt, H, H'; auto with *. -Qed. - -#[global] -Instance Qeqb_comp : Proper (Qeq==>Qeq==>eq) Qeq_bool. -Proof. - intros p q H r s H'; apply eq_true_iff_eq. - rewrite 2 Qeq_bool_iff, H, H'; split; auto with qarith. -Qed. - -#[global] -Instance Qleb_comp : Proper (Qeq==>Qeq==>eq) Qle_bool. -Proof. - intros p q H r s H'; apply eq_true_iff_eq. - rewrite 2 Qle_bool_iff, H, H'; split; auto with qarith. -Qed. - - -(** [0] and [1] are apart *) - -Lemma Q_apart_0_1 : ~ 1 == 0. -Proof. - unfold Qeq; auto with qarith. -Qed. - -(** * Properties of [Qadd] *) - -(** Addition is associative: *) - -Theorem Qplus_assoc : forall x y z, x+(y+z)==(x+y)+z. -Proof. - intros (x1, x2) (y1, y2) (z1, z2). - unfold Qeq, Qplus; simpl; simpl_mult; ring. -Qed. - -(** [0] is a neutral element for addition: *) - -Lemma Qplus_0_l : forall x, 0+x == x. -Proof. - intros (x1, x2); unfold Qeq, Qplus; simpl; ring. -Qed. - -Lemma Qplus_0_r : forall x, x+0 == x. -Proof. - intros (x1, x2); unfold Qeq, Qplus; simpl. - rewrite Pos.mul_comm; simpl; ring. -Qed. - -(** Commutativity of addition: *) - -Theorem Qplus_comm : forall x y, x+y == y+x. -Proof. - intros (x1, x2); unfold Qeq, Qplus; simpl. - intros; rewrite Pos.mul_comm; ring. -Qed. - - -(** * Properties of [Qopp] *) - -Lemma Qopp_involutive : forall q, - -q == q. -Proof. - red; simpl; intros; ring. -Qed. - -Theorem Qplus_opp_r : forall q, q+(-q) == 0. -Proof. - red; simpl; intro; ring. -Qed. - -(** Injectivity of addition (uses theory about Qopp above): *) - -Lemma Qplus_inj_r (x y z: Q): - x + z == y + z <-> x == y. -Proof. - split; intro E. - - rewrite <- (Qplus_0_r x), <- (Qplus_0_r y). - rewrite <- (Qplus_opp_r z); auto. - do 2 rewrite Qplus_assoc. - rewrite E. reflexivity. - - rewrite E. reflexivity. -Qed. - -Lemma Qplus_inj_l (x y z: Q): - z + x == z + y <-> x == y. -Proof. - rewrite (Qplus_comm z x), (Qplus_comm z y). - apply Qplus_inj_r. -Qed. - - -(** * Properties of [Qmult] *) - -(** Multiplication is associative: *) - -Theorem Qmult_assoc : forall n m p, n*(m*p)==(n*m)*p. -Proof. - intros; red; simpl; rewrite Pos.mul_assoc; ring. -Qed. - -(** multiplication and zero *) - -Lemma Qmult_0_l : forall x , 0*x == 0. -Proof. - intros; compute; reflexivity. -Qed. - -Lemma Qmult_0_r : forall x , x*0 == 0. -Proof. - intros; red; simpl; ring. -Qed. - -(** [1] is a neutral element for multiplication: *) - -Lemma Qmult_1_l : forall n, 1*n == n. -Proof. - intro n; red; simpl; destruct (Qnum n); auto. -Qed. - -Theorem Qmult_1_r : forall n, n*1==n. -Proof. - intro n; red; simpl. - rewrite (Z.mul_1_r (Qnum n)). - rewrite Pos.mul_comm; simpl; trivial. -Qed. - -(** Commutativity of multiplication *) - -Theorem Qmult_comm : forall x y, x*y==y*x. -Proof. - intros; red; simpl; rewrite Pos.mul_comm; ring. -Qed. - -(** Distributivity over [Qadd] *) - -Theorem Qmult_plus_distr_r : forall x y z, x*(y+z)==(x*y)+(x*z). -Proof. - intros (x1, x2) (y1, y2) (z1, z2). - unfold Qeq, Qmult, Qplus; simpl; simpl_mult; ring. -Qed. - -Theorem Qmult_plus_distr_l : forall x y z, (x+y)*z==(x*z)+(y*z). -Proof. - intros (x1, x2) (y1, y2) (z1, z2). - unfold Qeq, Qmult, Qplus; simpl; simpl_mult; ring. -Qed. - -(** Integrality *) - -Theorem Qmult_integral : forall x y, x*y==0 -> x==0 \/ y==0. -Proof. - intros (x1,x2) (y1,y2). - unfold Qeq, Qmult; simpl. - now rewrite <- Z.mul_eq_0, !Z.mul_1_r. -Qed. - -Theorem Qmult_integral_l : forall x y, ~ x == 0 -> x*y == 0 -> y == 0. -Proof. - intros (x1, x2) (y1, y2). - unfold Qeq, Qmult; simpl. - rewrite !Z.mul_1_r, Z.mul_eq_0. intuition. -Qed. - - -(** * inject_Z is a ring homomorphism: *) - -Lemma inject_Z_plus (x y: Z): inject_Z (x + y) = inject_Z x + inject_Z y. -Proof. - unfold Qplus, inject_Z. simpl. f_equal. ring. -Qed. - -Lemma inject_Z_mult (x y: Z): inject_Z (x * y) = inject_Z x * inject_Z y. -Proof. reflexivity. Qed. - -Lemma inject_Z_opp (x: Z): inject_Z (- x) = - inject_Z x. -Proof. reflexivity. Qed. - - -(** * Inverse and division. *) - -Lemma Qinv_involutive : forall q, (/ / q) == q. -Proof. -intros [[|n|n] d]; red; simpl; reflexivity. -Qed. - -Theorem Qmult_inv_r : forall x, ~ x == 0 -> x*(/x) == 1. -Proof. - intros (x1, x2); unfold Qeq, Qdiv, Qmult; case x1; simpl; - intros H **; simpl_mult; try ring. - elim H; auto. -Qed. - -Lemma Qinv_mult_distr : forall p q, / (p * q) == /p * /q. -Proof. - intros (x1,x2) (y1,y2); unfold Qeq, Qinv, Qmult; simpl. - destruct x1; simpl; auto; - destruct y1; simpl; auto. -Qed. - -Lemma Qinv_pos: forall (a b : positive), - / (Z.pos b # a) == Z.pos a # b. -Proof. - intros a b. - reflexivity. -Qed. - -Lemma Qinv_neg: forall (a b : positive), - / (Z.neg b # a) == Z.neg a # b. -Proof. - intros a b. - reflexivity. -Qed. - -Theorem Qdiv_mult_l : forall x y, ~ y == 0 -> (x*y)/y == x. -Proof. - intros x y H; unfold Qdiv. - rewrite <- (Qmult_assoc x y (Qinv y)). - rewrite (Qmult_inv_r y H). - apply Qmult_1_r. -Qed. - -Theorem Qmult_div_r : forall x y, ~ y == 0 -> y*(x/y) == x. -Proof. - intros x y ?; unfold Qdiv. - rewrite (Qmult_assoc y x (Qinv y)). - rewrite (Qmult_comm y x). - fold (Qdiv (Qmult x y) y). - apply Qdiv_mult_l; auto. -Qed. - -Lemma Qinv_plus_distr : forall a b c, ((a # c) + (b # c) == (a+b) # c)%Q. -Proof. - intros. unfold Qeq. simpl. rewrite Pos2Z.inj_mul. ring. -Qed. - -Lemma Qinv_minus_distr : forall a b c, (a # c) + - (b # c) == (a-b) # c. -Proof. - intros. unfold Qeq. simpl. rewrite Pos2Z.inj_mul. ring. -Qed. - -(** Injectivity of Qmult (requires theory about Qinv above): *) - -Lemma Qmult_inj_r (x y z: Q): ~ z == 0 -> (x * z == y * z <-> x == y). -Proof. - intro z_ne_0. - split; intro E. - - rewrite <- (Qmult_1_r x), <- (Qmult_1_r y). - rewrite <- (Qmult_inv_r z); auto. - do 2 rewrite Qmult_assoc. - rewrite E. reflexivity. - - rewrite E. reflexivity. -Qed. - -Lemma Qmult_inj_l (x y z: Q): ~ z == 0 -> (z * x == z * y <-> x == y). -Proof. - rewrite (Qmult_comm z x), (Qmult_comm z y). - apply Qmult_inj_r. -Qed. - -(** * Reduction and construction of Q *) - -(** ** Removal/introduction of common factor in both numerator and denominator. *) - -Lemma Qreduce_l : forall (a : Z) (b z : positive), - (Zpos z)*a # z*b == a#b. -Proof. - intros a b z. - unfold Qeq, Qnum, Qden. - rewrite Pos2Z.inj_mul. - ring. -Qed. - -Lemma Qreduce_r : forall (a : Z) (b z : positive), - a*(Zpos z) # b*z == a#b. -Proof. - intros a b z. - unfold Qeq, Qnum, Qden. - rewrite Pos2Z.inj_mul. - ring. -Qed. - -Lemma Qreduce_num_l : forall (a b : positive), - Z.pos a # a * b == (1 # b). -Proof. - intros a b. - unfold Qeq, Qnum, Qden. - rewrite Pos2Z.inj_mul. - ring. -Qed. - -Lemma Qreduce_num_r : forall (a b : positive), - Z.pos b # a * b == (1 # a). -Proof. - intros a b. - unfold Qeq, Qnum, Qden. - rewrite Pos2Z.inj_mul. - ring. -Qed. - -Lemma Qreduce_den_l : forall (a : positive) (b : Z), - Z.pos a * b # a == (b # 1). -Proof. - intros a b. - unfold Qeq, Qnum, Qden. - ring. -Qed. - -Lemma Qreduce_den_r : forall (a : Z) (b : positive), - a * Z.pos b # b == (a # 1). -Proof. - intros a b. - unfold Qeq, Qnum, Qden. - ring. -Qed. - -Lemma Qreduce_den_inject_Z_l : forall (a : positive) (b : Z), - (Z.pos a * b # a == inject_Z b)%Q. -Proof. - intros a b. - unfold Qeq, Qnum, Qden, inject_Z. - ring. -Qed. - -Lemma Qreduce_den_inject_Z_r : forall (a : Z) (b : positive), - a * Z.pos b # b == inject_Z a. -Proof. - intros a b. - unfold Qeq, Qnum, Qden, inject_Z. - ring. -Qed. - -Lemma Qreduce_zero: forall (d : positive), - (0#d == 0)%Q. -Proof. - intros d. - unfold Qeq, Qnum, Qden; reflexivity. -Qed. - -(** ** Construction of a new rational by multiplication with an integer or pure fraction *) - -(** (or to be more precise multiplication with a rational of the form z/1 or 1/p) *) - -Lemma Qmult_inject_Z_l : forall (a : Z) (b : positive) (z : Z), - (inject_Z z) * (a#b) == z*a#b. -Proof. - intros a b z. - unfold Qeq. cbn. ring. -Qed. - -Lemma Qmult_inject_Z_r : forall (a : Z) (b : positive) (z : Z), - (a#b) * inject_Z z == a*z#b. -Proof. - intros a b z. - unfold Qeq. cbn. - rewrite Pos2Z.inj_mul. - ring. -Qed. - -Lemma Qmult_frac_l : forall (a:Z) (b c:positive), (a # (b * c)) == (1#b) * (a#c). -Proof. - intros a b c. - unfold Qeq, Qnum, Qden; cbn. - destruct a; reflexivity. -Qed. - -Lemma Qmult_frac_r : forall (a:Z) (b c:positive), (a # (b * c)) == (a#b) * (1#c). -Proof. - intros a b c. - unfold Qeq, Qnum, Qden; cbn. - rewrite Pos2Z.inj_mul. - ring. -Qed. - -(** * Properties of order upon Q. *) - -Lemma Qle_refl x : x<=x. -Proof. - unfold Qle; reflexivity. -Qed. - -Lemma Qle_antisym x y : x<=y -> y<=x -> x==y. -Proof. apply Z.le_antisymm. Qed. - -Lemma Qle_trans : forall x y z, x<=y -> y<=z -> x<=z. -Proof. - unfold Qle; intros (x1, x2) (y1, y2) (z1, z2); simpl; intros. - Open Scope Z_scope. - apply Z.mul_le_mono_pos_r with (Zpos y2); [easy|]. - apply Z.le_trans with (y1 * Zpos x2 * Zpos z2). - - rewrite Z.mul_shuffle0. now apply Z.mul_le_mono_pos_r. - - rewrite Z.mul_shuffle0, (Z.mul_shuffle0 z1). - now apply Z.mul_le_mono_pos_r. - Close Scope Z_scope. -Qed. - -#[global] -Hint Resolve Qle_trans : qarith. - -Lemma Qlt_irrefl x : ~x ~ x==y. -Proof. apply Z.lt_neq. Qed. - -Lemma Zle_Qle (x y: Z): (x <= y)%Z = (inject_Z x <= inject_Z y). -Proof. - unfold Qle. simpl. now rewrite !Z.mul_1_r. -Qed. - -Lemma Zlt_Qlt (x y: Z): (x < y)%Z = (inject_Z x < inject_Z y). -Proof. - unfold Qlt. simpl. now rewrite !Z.mul_1_r. -Qed. - - -(** Large = strict or equal *) - -Lemma Qle_lteq x y : x<=y <-> x p <= q /\ ~ (p == q). -Proof. - intros p q; split; intros H. - - rewrite Qlt_alt in H; rewrite Qle_alt, Qeq_alt. - rewrite H; split; intros H1; inversion H1. - - rewrite Qlt_alt; rewrite Qle_alt, Qeq_alt in H. - destruct (p ?= q); tauto. -Qed. - -Lemma Qlt_le_weak x y : x x<=y. -Proof. apply Z.lt_le_incl. Qed. - -(** Qgt and Qge are just a notations, but one might not know this and search for these lemmas *) - -Lemma Qgt_lt: forall p q : Q, p > q -> q < p. -Proof. - intros p q H; assumption. -Qed. - -Lemma Qlt_gt: forall p q : Q, p < q -> q > p. -Proof. - intros p q H; assumption. -Qed. - -Lemma Qge_le: forall p q : Q, p >= q -> q <= p. -Proof. - intros p q H; assumption. -Qed. - -Lemma Qle_ge: forall p q : Q, p <= q -> q >= p. -Proof. - intros p q H; assumption. -Qed. - -Lemma Qle_lt_trans : forall x y z, x<=y -> y x y<=z -> x y x y <= x. -Proof. apply Z.nlt_ge. Qed. - -Lemma Qnot_le_lt x y : ~ x <= y -> y < x. -Proof. apply Z.nle_gt. Qed. - -Lemma Qlt_not_le x y : x < y -> ~ y <= x. -Proof. apply Z.lt_nge. Qed. - -Lemma Qle_not_lt x y : x <= y -> ~ y < x. -Proof. apply Z.le_ngt. Qed. - -Lemma Qle_lt_or_eq : forall x y, x<=y -> x -q <= -p. -Proof. - intros (a1,a2) (b1,b2); unfold Qle, Qlt; simpl. - now rewrite !Z.mul_opp_l, <- Z.opp_le_mono. -Qed. - -Lemma Qopp_lt_compat: forall p q : Q, p < q -> - q < - p. -Proof. - intros (a1,a2) (b1,b2); unfold Qle, Qlt; simpl. - now rewrite !Z.mul_opp_l, <- Z.opp_lt_mono. -Qed. - -#[global] -Hint Resolve Qopp_le_compat Qopp_lt_compat : qarith. - -Lemma Qle_minus_iff : forall p q, p <= q <-> 0 <= q+-p. -Proof. - intros (x1,x2) (y1,y2); unfold Qle; simpl. - rewrite Z.mul_1_r, Z.mul_opp_l, <- Z.le_sub_le_add_r, Z.opp_involutive. - reflexivity. -Qed. - -Lemma Qlt_minus_iff : forall p q, p < q <-> 0 < q+-p. -Proof. - intros (x1,x2) (y1,y2); unfold Qlt; simpl. - rewrite Z.mul_1_r, Z.mul_opp_l, <- Z.lt_sub_lt_add_r, Z.opp_involutive. - reflexivity. -Qed. - -Lemma Qplus_le_compat : - forall x y z t, x<=y -> z<=t -> x+z <= y+t. -Proof. - unfold Qplus, Qle; intros (x1, x2) (y1, y2) (z1, z2) (t1, t2); - simpl; simpl_mult. - Open Scope Z_scope. - intros. - match goal with |- ?a <= ?b => ring_simplify a b end. - rewrite Z.add_comm. - apply Z.add_le_mono. - - match goal with |- ?a <= ?b => ring_simplify z1 t1 (Zpos z2) (Zpos t2) a b end. - auto using Z.mul_le_mono_nonneg_r, Pos2Z.is_nonneg. - - match goal with |- ?a <= ?b => ring_simplify x1 y1 (Zpos x2) (Zpos y2) a b end. - auto using Z.mul_le_mono_nonneg_r, Pos2Z.is_nonneg. - Close Scope Z_scope. -Qed. - -Lemma Qplus_lt_le_compat : - forall x y z t, x z<=t -> x+z < y+t. -Proof. - unfold Qplus, Qle, Qlt; intros (x1, x2) (y1, y2) (z1, z2) (t1, t2); - simpl; simpl_mult. - Open Scope Z_scope. - intros. - match goal with |- ?a < ?b => ring_simplify a b end. - rewrite Z.add_comm. - apply Z.add_le_lt_mono. - - match goal with |- ?a <= ?b => ring_simplify z1 t1 (Zpos z2) (Zpos t2) a b end. - auto using Z.mul_le_mono_nonneg_r, Pos2Z.is_nonneg. - - match goal with |- ?a < ?b => ring_simplify x1 y1 (Zpos x2) (Zpos y2) a b end. - do 2 (apply Z.mul_lt_mono_pos_r;try easy). - Close Scope Z_scope. -Qed. - -Lemma Qplus_le_l (x y z: Q): x + z <= y + z <-> x <= y. -Proof. - split; intros. - - rewrite <- (Qplus_0_r x), <- (Qplus_0_r y), <- (Qplus_opp_r z). - do 2 rewrite Qplus_assoc. - apply Qplus_le_compat; auto with *. - - apply Qplus_le_compat; auto with *. -Qed. - -Lemma Qplus_le_r (x y z: Q): z + x <= z + y <-> x <= y. -Proof. - rewrite (Qplus_comm z x), (Qplus_comm z y). - apply Qplus_le_l. -Qed. - -Lemma Qplus_lt_l (x y z: Q): x + z < y + z <-> x < y. -Proof. - split; intros. - - rewrite <- (Qplus_0_r x), <- (Qplus_0_r y), <- (Qplus_opp_r z). - do 2 rewrite Qplus_assoc. - apply Qplus_lt_le_compat; auto with *. - - apply Qplus_lt_le_compat; auto with *. -Qed. - -Lemma Qplus_lt_r (x y z: Q): z + x < z + y <-> x < y. -Proof. - rewrite (Qplus_comm z x), (Qplus_comm z y). - apply Qplus_lt_l. -Qed. - -Lemma Qplus_lt_compat : forall x y z t : Q, - x < y -> z < t -> x + z < y + t. -Proof. - intros x y z t H1 H2. - apply Qplus_lt_le_compat. - - assumption. - - apply Qle_lteq; left; assumption. -Qed. - -(** ** Compatibility of multiplication with order. *) - -Lemma Qmult_le_compat_r : forall x y z, x <= y -> 0 <= z -> x*z <= y*z. -Proof. - intros (a1,a2) (b1,b2) (c1,c2); unfold Qle, Qlt; simpl. - Open Scope Z_scope. - rewrite Z.mul_1_r. - intros; simpl_mult. - rewrite Z.mul_shuffle1, (Z.mul_shuffle1 b1). - apply Z.mul_le_mono_nonneg_r; auto. - now apply Z.mul_nonneg_nonneg. - Close Scope Z_scope. -Qed. - -Lemma Qmult_lt_0_le_reg_r : forall x y z, 0 < z -> x*z <= y*z -> x <= y. -Proof. - intros (a1,a2) (b1,b2) (c1,c2); unfold Qle, Qlt; simpl. - Open Scope Z_scope. - simpl_mult. - rewrite Z.mul_shuffle1, (Z.mul_shuffle1 b1). - rewrite Z.mul_1_r. - intros LT LE. - apply Z.mul_le_mono_pos_r in LE; trivial. - apply Z.mul_pos_pos; easy. - Close Scope Z_scope. -Qed. - -Lemma Qmult_le_r (x y z: Q): 0 < z -> (x*z <= y*z <-> x <= y). -Proof. - split; intro. - - now apply Qmult_lt_0_le_reg_r with z. - - apply Qmult_le_compat_r; auto with qarith. -Qed. - -Lemma Qmult_le_l (x y z: Q): 0 < z -> (z*x <= z*y <-> x <= y). -Proof. - rewrite (Qmult_comm z x), (Qmult_comm z y). - apply Qmult_le_r. -Qed. - -Lemma Qmult_lt_compat_r : forall x y z, 0 < z -> x < y -> x*z < y*z. -Proof. - intros (a1,a2) (b1,b2) (c1,c2); unfold Qle, Qlt; simpl. - Open Scope Z_scope. - rewrite Z.mul_1_r. - intros; simpl_mult. - rewrite Z.mul_shuffle1, (Z.mul_shuffle1 b1). - apply Z.mul_lt_mono_pos_r; auto with zarith. - apply Z.mul_pos_pos; easy. - Close Scope Z_scope. -Qed. - -Lemma Qmult_lt_r: forall x y z, 0 < z -> (x*z < y*z <-> x < y). -Proof. - Open Scope Z_scope. - intros (a1,a2) (b1,b2) (c1,c2). - unfold Qle, Qlt; simpl. - simpl_mult. - rewrite Z.mul_shuffle1, (Z.mul_shuffle1 b1). - rewrite Z.mul_1_r. - intro LT. rewrite <- Z.mul_lt_mono_pos_r. - - reflexivity. - - now apply Z.mul_pos_pos. - Close Scope Z_scope. -Qed. - -Lemma Qmult_lt_l (x y z: Q): 0 < z -> (z*x < z*y <-> x < y). -Proof. - rewrite (Qmult_comm z x), (Qmult_comm z y). - apply Qmult_lt_r. -Qed. - -Lemma Qmult_le_0_compat : forall a b, 0 <= a -> 0 <= b -> 0 <= a*b. -Proof. -intros a b Ha Hb. -unfold Qle in *. -simpl in *. -rewrite Z.mul_1_r in *. -auto using Z.mul_nonneg_nonneg. -Qed. - -Lemma Qmult_lt_0_compat : forall a b : Q, 0 < a -> 0 < b -> 0 < a * b. -Proof. - intros a b Ha Hb. - destruct a,b. unfold Qlt, Qmult, QArith_base.Qnum, QArith_base.Qden in *. - rewrite Pos2Z.inj_mul. - rewrite Z.mul_0_l, Z.mul_1_r in *. - apply Z.mul_pos_pos; assumption. -Qed. - -Lemma Qmult_le_1_compat: forall a b : Q, 1 <= a -> 1 <= b -> 1 <= a * b. -Proof. - intros a b Ha Hb. - destruct a,b. unfold Qle, Qmult, QArith_base.Qnum, QArith_base.Qden in *. - rewrite Pos2Z.inj_mul. - rewrite Z.mul_1_l, Z.mul_1_r in *. - apply Z.mul_le_mono_nonneg. - 2,4: assumption. - 1,2: apply Pos2Z.is_nonneg. -Qed. - -Lemma Qmult_lt_1_compat: forall a b : Q, 1 < a -> 1 < b -> 1 < a * b. -Proof. - intros a b Ha Hb. - destruct a,b. unfold Qlt, Qmult, QArith_base.Qnum, QArith_base.Qden in *. - rewrite Pos2Z.inj_mul. - rewrite Z.mul_1_l, Z.mul_1_r in *. - apply Z.mul_lt_mono_nonneg. - 2,4: assumption. - 1,2: apply Pos2Z.is_nonneg. -Qed. - -Lemma Qmult_lt_compat_nonneg: forall x y z t : Q, 0 <= x < y -> 0 <= z < t -> x * z < y * t. -Proof. - intros [xn xd] [yn yd] [zn zd] [tn td] [H0lex Hxlty] [H0lez Hzltt]. - unfold Qmult, Qlt, Qle, Qnum, Qden in *. - rewrite Z.mul_0_l,Z.mul_1_r in H0lex, H0lez. - do 2 rewrite Pos2Z.inj_mul. - setoid_replace (xn * zn * (Z.pos yd * Z.pos td))%Z with ((xn * Z.pos yd) * (zn * Z.pos td))%Z by ring. - setoid_replace (yn * tn * (Z.pos xd * Z.pos zd))%Z with ((yn * Z.pos xd) * (tn * Z.pos zd))%Z by ring. - apply Z.mul_lt_mono_nonneg. - 2,4 : assumption. - 1,2 : rewrite <- (Z.mul_0_l 0); apply Z.mul_le_mono_nonneg; - [reflexivity|assumption|reflexivity|apply Pos2Z.is_nonneg]. -Qed. - -Lemma Qmult_le_lt_compat_pos: forall x y z t : Q, 0 < x <= y -> 0 < z < t -> x * z < y * t. -Proof. - intros [xn xd] [yn yd] [zn zd] [tn td] [H0ltx Hxlty] [H0ltz Hzltt]. - unfold Qmult, Qlt, Qle, Qnum, Qden in *. - rewrite Z.mul_0_l,Z.mul_1_r in H0ltx, H0ltz. - do 2 rewrite Pos2Z.inj_mul. - setoid_replace (xn * zn * (Z.pos yd * Z.pos td))%Z with ((xn * Z.pos yd) * (zn * Z.pos td))%Z by ring. - setoid_replace (yn * tn * (Z.pos xd * Z.pos zd))%Z with ((yn * Z.pos xd) * (tn * Z.pos zd))%Z by ring. - apply Zorder.Zmult_lt_compat2; split. - 2,4 : assumption. - 1,2 : rewrite <- (Z.mul_0_l 0); apply Z.mul_lt_mono_nonneg; - [reflexivity|assumption|reflexivity|apply Pos2Z.is_pos]. -Qed. - -Lemma Qmult_le_compat_nonneg: forall x y z t : Q, 0 <= x <= y -> 0 <= z <= t -> x * z <= y * t. -Proof. - intros [xn xd] [yn yd] [zn zd] [tn td] [H0lex Hxlty] [H0lez Hzltt]. - unfold Qmult, Qlt, Qle, Qnum, Qden in *. - rewrite Z.mul_0_l,Z.mul_1_r in H0lex, H0lez. - do 2 rewrite Pos2Z.inj_mul. - setoid_replace (xn * zn * (Z.pos yd * Z.pos td))%Z with ((xn * Z.pos yd) * (zn * Z.pos td))%Z by ring. - setoid_replace (yn * tn * (Z.pos xd * Z.pos zd))%Z with ((yn * Z.pos xd) * (tn * Z.pos zd))%Z by ring. - apply Z.mul_le_mono_nonneg. - 2,4 : assumption. - 1,2 : rewrite <- (Z.mul_0_l 0); apply Z.mul_le_mono_nonneg; - [reflexivity|assumption|reflexivity|apply Pos2Z.is_nonneg]. -Qed. - -(** ** Compatibility of inversion and division with order *) - -Lemma Qinv_le_0_compat : forall a, 0 <= a -> 0 <= /a. -Proof. -intros [[|n|n] d] Ha; assumption. -Qed. - -Lemma Qle_shift_div_l : forall a b c, - 0 < c -> a*c <= b -> a <= b/c. -Proof. -intros a b c Hc H. -apply Qmult_lt_0_le_reg_r with (c). -- assumption. -- setoid_replace (b/c*c) with (c*(b/c)) by apply Qmult_comm. - rewrite Qmult_div_r; try assumption. - auto with *. -Qed. - -Lemma Qle_shift_inv_l : forall a c, - 0 < c -> a*c <= 1 -> a <= /c. -Proof. -intros a c Hc H. -setoid_replace (/c) with (1*/c) by (symmetry; apply Qmult_1_l). -change (a <= 1/c). -apply Qle_shift_div_l; assumption. -Qed. - -Lemma Qle_shift_div_r : forall a b c, - 0 < b -> a <= c*b -> a/b <= c. -Proof. -intros a b c Hc H. -apply Qmult_lt_0_le_reg_r with b. -- assumption. -- setoid_replace (a/b*b) with (b*(a/b)) by apply Qmult_comm. - rewrite Qmult_div_r; try assumption. - auto with *. -Qed. - -Lemma Qle_shift_inv_r : forall b c, - 0 < b -> 1 <= c*b -> /b <= c. -Proof. -intros b c Hc H. -setoid_replace (/b) with (1*/b) by (symmetry; apply Qmult_1_l). -change (1/b <= c). -apply Qle_shift_div_r; assumption. -Qed. - -Lemma Qinv_lt_0_compat : forall a, 0 < a -> 0 < /a. -Proof. -intros [[|n|n] d] Ha; assumption. -Qed. - -Lemma Qlt_shift_div_l : forall a b c, - 0 < c -> a*c < b -> a < b/c. -Proof. -intros a b c Hc H. -apply Qnot_le_lt. -intros H0. -apply (Qlt_not_le _ _ H). -apply Qmult_lt_0_le_reg_r with (/c). -- apply Qinv_lt_0_compat. - assumption. -- setoid_replace (a*c/c) with (a) by (apply Qdiv_mult_l; auto with *). - assumption. -Qed. - -Lemma Qlt_shift_inv_l : forall a c, - 0 < c -> a*c < 1 -> a < /c. -Proof. -intros a c Hc H. -setoid_replace (/c) with (1*/c) by (symmetry; apply Qmult_1_l). -change (a < 1/c). -apply Qlt_shift_div_l; assumption. -Qed. - -Lemma Qlt_shift_div_r : forall a b c, - 0 < b -> a < c*b -> a/b < c. -Proof. -intros a b c Hc H. -apply Qnot_le_lt. -intros H0. -apply (Qlt_not_le _ _ H). -apply Qmult_lt_0_le_reg_r with (/b). -- apply Qinv_lt_0_compat. - assumption. -- setoid_replace (c*b/b) with (c) by (apply Qdiv_mult_l; auto with *). - assumption. -Qed. - -Lemma Qlt_shift_inv_r : forall b c, - 0 < b -> 1 < c*b -> /b < c. -Proof. -intros b c Hc H. -setoid_replace (/b) with (1*/b) by (symmetry; apply Qmult_1_l). -change (1/b < c). -apply Qlt_shift_div_r; assumption. -Qed. - -Lemma Qinv_lt_contravar : forall a b : Q, - 0 < a -> 0 < b -> (a < b <-> /b < /a). -Proof. - intros a b H H0. split. - - intro H1. rewrite <- Qmult_1_l. apply Qlt_shift_div_r. - + apply H0. - + rewrite <- (Qmult_inv_r a). - * rewrite Qmult_comm. - apply Qmult_lt_l. - -- apply Qinv_lt_0_compat. apply H. - -- apply H1. - * intro abs. rewrite abs in H. apply (Qlt_irrefl 0 H). - - intro H1. rewrite <- (Qinv_involutive b). rewrite <- (Qmult_1_l (// b)). - apply Qlt_shift_div_l. - + apply Qinv_lt_0_compat. apply H0. - + rewrite <- (Qmult_inv_r a). - * apply Qmult_lt_l. - -- apply H. - -- apply H1. - * intro abs. rewrite abs in H. apply (Qlt_irrefl 0 H). -Qed. - - -(** * Rational to the n-th power *) - -Definition Qpower_positive : Q -> positive -> Q := - pow_pos Qmult. - -#[global] -Instance Qpower_positive_comp : Proper (Qeq==>eq==>Qeq) Qpower_positive. -Proof. -intros x x' Hx y y' Hy. rewrite <-Hy; clear y' Hy. -unfold Qpower_positive. -induction y as [y IHy|y IHy|]; simpl; -try rewrite IHy; -try rewrite Hx; -reflexivity. -Qed. - -Definition Qpower (q:Q) (z:Z) := - match z with - | Zpos p => Qpower_positive q p - | Z0 => 1 - | Zneg p => /Qpower_positive q p - end. - -Notation " q ^ z " := (Qpower q z) : Q_scope. - -Register Qpower as rat.Q.Qpower. - -#[global] -Instance Qpower_comp : Proper (Qeq==>eq==>Qeq) Qpower. -Proof. -intros x x' Hx y y' Hy. rewrite <- Hy; clear y' Hy. -destruct y; simpl; rewrite ?Hx; auto with *. -Qed. diff --git a/stdlib/theories/QArith/QOrderedType.v b/stdlib/theories/QArith/QOrderedType.v deleted file mode 100644 index 552447134169..000000000000 --- a/stdlib/theories/QArith/QOrderedType.v +++ /dev/null @@ -1,62 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* Qeq==>iff) Qlt. - Proof. auto with *. Qed. - - Definition le_lteq := Qle_lteq. - Definition compare_spec := Qcompare_spec. - -End Q_as_OT. - - -(** * An [order] tactic for [Q] numbers *) - -Module QOrder := OTF_to_OrderTac Q_as_OT. -Ltac q_order := QOrder.order. - -(** Note that [q_order] is domain-agnostic: it will not prove - [1<=2] or [x<=x+x], but rather things like [x<=y -> y<=x -> x==y]. *) diff --git a/stdlib/theories/QArith/Qabs.v b/stdlib/theories/QArith/Qabs.v deleted file mode 100644 index 60c1c88d1d29..000000000000 --- a/stdlib/theories/QArith/Qabs.v +++ /dev/null @@ -1,218 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* Type), (0 <= x -> P x) -> (x <= 0 -> P (- x)) -> P (Qabs x). -Proof. -intros x P H1 H2. -destruct x as [[|xn|xn] xd]; -[apply H1|apply H1|apply H2]; -abstract (compute; discriminate). -Defined. - -Add Morphism Qabs with signature Qeq ==> Qeq as Qabs_wd. -intros [xn xd] [yn yd] H. -simpl. -unfold Qeq in *. -simpl in *. -change (Zpos yd)%Z with (Z.abs (Zpos yd)). -change (Zpos xd)%Z with (Z.abs (Zpos xd)). -repeat rewrite <- Z.abs_mul. -congruence. -Qed. - -Lemma Qabs_pos : forall x, 0 <= x -> Qabs x == x. -Proof. -intros x H. -apply Qabs_case. -- reflexivity. -- intros H0. - setoid_replace x with 0. - + reflexivity. - + apply Qle_antisym; assumption. -Qed. - -Lemma Qabs_neg : forall x, x <= 0 -> Qabs x == - x. -Proof. -intros x H. -apply Qabs_case. -- intros H0. - setoid_replace x with 0. - + reflexivity. - + apply Qle_antisym; assumption. -- reflexivity. -Qed. - -Lemma Qabs_nonneg : forall x, 0 <= (Qabs x). -intros x. -apply Qabs_case. -- auto. -- apply (Qopp_le_compat x 0). -Qed. - -Lemma Zabs_Qabs : forall n d, (Z.abs n#d)==Qabs (n#d). -Proof. -intros [|n|n]; reflexivity. -Qed. - -Lemma Qabs_opp : forall x, Qabs (-x) == Qabs x. -Proof. -intros x. -do 2 apply Qabs_case; try (intros; ring); -(intros H0 H1; -setoid_replace x with 0;[reflexivity|]; -apply Qle_antisym);try assumption; -rewrite Qle_minus_iff in *; -ring_simplify; -ring_simplify in H1; -assumption. -Qed. - -Lemma Qabs_triangle : forall x y, Qabs (x+y) <= Qabs x + Qabs y. -Proof. -intros [xn xd] [yn yd]. -unfold Qplus. -unfold Qle. -simpl. -apply Z.mul_le_mono_nonneg_r;auto with *. -change (Zpos yd)%Z with (Z.abs (Zpos yd)). -change (Zpos xd)%Z with (Z.abs (Zpos xd)). -repeat rewrite <- Z.abs_mul. -apply Z.abs_triangle. -Qed. - -Lemma Qabs_Qmult : forall a b, Qabs (a*b) == (Qabs a)*(Qabs b). -Proof. -intros [an ad] [bn bd]. -simpl. -rewrite Z.abs_mul. -reflexivity. -Qed. - -Lemma Qabs_Qinv : forall q, Qabs (/ q) == / (Qabs q). -Proof. - intros [n d]; simpl. - unfold Qinv. - case_eq n; intros; simpl in *; apply Qeq_refl. -Qed. - -Lemma Qabs_Qminus x y: Qabs (x - y) = Qabs (y - x). -Proof. - unfold Qminus, Qopp. simpl. - rewrite Pos.mul_comm, <- Z.abs_opp. - do 2 f_equal. ring. -Qed. - -Lemma Qle_Qabs : forall a, a <= Qabs a. -Proof. -intros a. -apply Qabs_case; auto with *. -intros H. -apply Qle_trans with 0; try assumption. -change 0 with (-0). -apply Qopp_le_compat. -assumption. -Qed. - -Lemma Qabs_triangle_reverse : forall x y, Qabs x - Qabs y <= Qabs (x - y). -Proof. -intros x y. -rewrite Qle_minus_iff. -setoid_replace (Qabs (x - y) + - (Qabs x - Qabs y)) with ((Qabs (x - y) + Qabs y) + - Qabs x) by ring. -rewrite <- Qle_minus_iff. -setoid_replace (Qabs x) with (Qabs (x-y+y)). -- apply Qabs_triangle. -- apply Qabs_wd. - ring. -Qed. - -Lemma Qabs_Qle_condition x y: Qabs x <= y <-> -y <= x <= y. -Proof. - split. - - split. - + rewrite <- (Qopp_opp x). - apply Qopp_le_compat. - apply Qle_trans with (Qabs (-x)). - * apply Qle_Qabs. - * now rewrite Qabs_opp. - + apply Qle_trans with (Qabs x); auto using Qle_Qabs. - - intros (H,H'). - apply Qabs_case; trivial. - intros. rewrite <- (Qopp_opp y). now apply Qopp_le_compat. -Qed. - -Lemma Qabs_Qlt_condition: forall x y : Q, - Qabs x < y <-> -y < x < y. -Proof. - split. - - split. - + rewrite <- (Qopp_opp x). - apply Qopp_lt_compat. - apply Qle_lt_trans with (Qabs (-x)). - * apply Qle_Qabs. - * now rewrite Qabs_opp. - + apply Qle_lt_trans with (Qabs x); auto using Qle_Qabs. - - intros (H,H'). - apply Qabs_case; trivial. - intros. rewrite <- (Qopp_opp y). now apply Qopp_lt_compat. -Qed. - -Lemma Qabs_diff_Qle_condition x y r: Qabs (x - y) <= r <-> x - r <= y <= x + r. -Proof. - intros. unfold Qminus. - rewrite Qabs_Qle_condition. - rewrite <- (Qplus_le_l (-r) (x+-y) (y+r)). - rewrite <- (Qplus_le_l (x+-y) r (y-r)). - setoid_replace (-r + (y + r)) with y by ring. - setoid_replace (r + (y - r)) with y by ring. - setoid_replace (x + - y + (y + r)) with (x + r) by ring. - setoid_replace (x + - y + (y - r)) with (x - r) by ring. - intuition. -Qed. - -Lemma Qabs_diff_Qlt_condition x y r: Qabs (x - y) < r <-> x - r < y < x + r. -Proof. - intros. unfold Qminus. - rewrite Qabs_Qlt_condition. - rewrite <- (Qplus_lt_l (-r) (x+-y) (y+r)). - rewrite <- (Qplus_lt_l (x+-y) r (y-r)). - setoid_replace (-r + (y + r)) with y by ring. - setoid_replace (r + (y - r)) with y by ring. - setoid_replace (x + - y + (y + r)) with (x + r) by ring. - setoid_replace (x + - y + (y - r)) with (x - r) by ring. - intuition. -Qed. - -Lemma Qabs_ge: forall r s : Q, r <= s -> r <= Qabs s. -Proof. - intros r s Hrles. - apply Qabs_case; intros Hs. - - exact Hrles. - - pose proof Qle_trans _ _ _ Hrles Hs as Hr. - apply Qopp_le_compat in Hs. - exact (Qle_trans _ _ _ Hr Hs). -Qed. - -Lemma Qabs_gt: forall r s : Q, r < s -> r < Qabs s. -Proof. - intros r s Hrlts. - apply Qabs_case; intros Hs. - - exact Hrlts. - - pose proof Qlt_le_trans _ _ _ Hrlts Hs as Hr. - apply Qopp_le_compat in Hs. - exact (Qlt_le_trans _ _ _ Hr Hs). -Qed. diff --git a/stdlib/theories/QArith/Qcabs.v b/stdlib/theories/QArith/Qcabs.v deleted file mode 100644 index f3381bb0648d..000000000000 --- a/stdlib/theories/QArith/Qcabs.v +++ /dev/null @@ -1,131 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* Qred (Qabs x) = Qabs x. -Proof. intros H; now rewrite (Qred_abs x), H. Qed. - -Definition Qcabs (x:Qc) : Qc := {| canon := Qcabs_canon x (canon x) |}. -Notation "[ q ]" := (Qcabs q) : Qc_scope. - -Ltac Qc_unfolds := - unfold Qcabs, Qcminus, Qcopp, Qcplus, Qcmult, Qcle, Q2Qc, this. - -Lemma Qcabs_case (x:Qc) (P : Qc -> Type) : - (0 <= x -> P x) -> (x <= 0 -> P (- x)) -> P [x]. -Proof. - intros A B. - apply (Qabs_case x (fun x => forall Hx, P {|this:=x;canon:=Hx|})). - - intros; case (Qc_decomp x {|canon:=Hx|}); auto. - - intros; case (Qc_decomp (-x) {|canon:=Hx|}); auto. -Qed. - -Lemma Qcabs_pos x : 0 <= x -> [x] = x. -Proof. - intro Hx; apply Qc_decomp; Qc_unfolds; fold (this x). - set (K := canon [x]); simpl in K; case K; clear K. - set (a := x) at 1; case (canon x); subst a; apply Qred_complete. - now apply Qabs_pos. -Qed. - -Lemma Qcabs_neg x : x <= 0 -> [x] = - x. -Proof. - intro Hx; apply Qc_decomp; Qc_unfolds; fold (this x). - set (K := canon [x]); simpl in K; case K; clear K. - now apply Qred_complete; apply Qabs_neg. -Qed. - -Lemma Qcabs_nonneg x : 0 <= [x]. -Proof. intros; apply Qabs_nonneg. Qed. - -Lemma Qcabs_opp x : [(-x)] = [x]. -Proof. - apply Qc_decomp; Qc_unfolds; fold (this x). - set (K := canon [x]); simpl in K; case K; clear K. - case Qred_abs; apply Qred_complete; apply Qabs_opp. -Qed. - -Lemma Qcabs_triangle x y : [x+y] <= [x] + [y]. -Proof. - Qc_unfolds; case Qred_abs; rewrite !Qred_le; apply Qabs_triangle. -Qed. - -Lemma Qcabs_Qcmult x y : [x*y] = [x]*[y]. -Proof. - apply Qc_decomp; Qc_unfolds; fold (this x) (this y); case Qred_abs. - apply Qred_complete; apply Qabs_Qmult. -Qed. - -Lemma Qcabs_Qcminus x y: [x-y] = [y-x]. -Proof. - apply Qc_decomp; Qc_unfolds; fold (this x) (this y) (this (-x)) (this (-y)). - set (a := x) at 2; case (canon x); subst a. - set (a := y) at 1; case (canon y); subst a. - rewrite !Qred_opp; fold (Qred x - Qred y)%Q (Qred y - Qred x)%Q. - repeat case Qred_abs; f_equal; apply Qabs_Qminus. -Qed. - -Lemma Qcle_Qcabs x : x <= [x]. -Proof. apply Qle_Qabs. Qed. - -Lemma Qcabs_triangle_reverse x y : [x] - [y] <= [x - y]. -Proof. - unfold Qcle, Qcabs, Qcminus, Qcplus, Qcopp, Q2Qc, this; - fold (this x) (this y) (this (-x)) (this (-y)). - case Qred_abs; rewrite !Qred_le, !Qred_opp, Qred_abs. - apply Qabs_triangle_reverse. -Qed. - -Lemma Qcabs_Qcle_condition x y : [x] <= y <-> -y <= x <= y. -Proof. - Qc_unfolds; fold (this x) (this y). - destruct (Qabs_Qle_condition x y) as [A B]. - split; intros H. - + destruct (A H) as [X Y]; split; auto. - now case (canon x); apply Qred_le. - + destruct H as [X Y]; apply B; split; auto. - now case (canon y); case Qred_opp. -Qed. - -Lemma Qcabs_diff_Qcle_condition x y r : [x-y] <= r <-> x - r <= y <= x + r. -Proof. - Qc_unfolds; fold (this x) (this y) (this r). - case Qred_abs; repeat rewrite Qred_opp. - set (a := y) at 1; case (canon y); subst a. - set (a := r) at 2; case (canon r); subst a. - set (a := Qred r) at 2 3; - assert (K := canon (Q2Qc r)); simpl in K; case K; clear K; subst a. - set (a := Qred y) at 1; - assert (K := canon (Q2Qc y)); simpl in K; case K; clear K; subst a. - fold (x - Qred y)%Q (x - Qred r)%Q. - destruct (Qabs_diff_Qle_condition x (Qred y) (Qred r)) as [A B]. - split. - + clear B; rewrite !Qred_le. auto. - + clear A; rewrite !Qred_le. auto. -Qed. - -Lemma Qcabs_null x : [x] = 0 -> x = 0. -Proof. - intros H. - destruct (proj1 (Qcabs_Qcle_condition x 0)) as [A B]. - + rewrite H; apply Qcle_refl. - + apply Qcle_antisym; auto. -Qed. diff --git a/stdlib/theories/QArith/Qcanon.v b/stdlib/theories/QArith/Qcanon.v deleted file mode 100644 index 78712a7845b5..000000000000 --- a/stdlib/theories/QArith/Qcanon.v +++ /dev/null @@ -1,546 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* Q ; canon : Qred this = this }. - -Declare Scope Qc_scope. -Delimit Scope Qc_scope with Qc. -Bind Scope Qc_scope with Qc. -Arguments Qcmake this%_Q _. -Open Scope Qc_scope. - -(** An alternative statement of [Qred q = q] via [Z.gcd] *) - -Lemma Qred_identity : - forall q:Q, Z.gcd (Qnum q) (QDen q) = 1%Z -> Qred q = q. -Proof. - intros (a,b) H; simpl in *. - rewrite <- Z.ggcd_gcd in H. - generalize (Z.ggcd_correct_divisors a (Zpos b)). - destruct Z.ggcd as (g,(aa,bb)); simpl in *; subst. - rewrite !Z.mul_1_l. now intros (<-,<-). -Qed. - -Lemma Qred_identity2 : - forall q:Q, Qred q = q -> Z.gcd (Qnum q) (QDen q) = 1%Z. -Proof. - intros (a,b) H; simpl in *. - generalize (Z.gcd_nonneg a (Zpos b)) (Z.ggcd_correct_divisors a (Zpos b)). - rewrite <- Z.ggcd_gcd. - destruct Z.ggcd as (g,(aa,bb)); simpl in *. - injection H as [= <- <-]. intros H (_,H'). - destruct g as [|g|g]; [ discriminate | | now elim H ]. - destruct bb as [|b|b]; simpl in *; try discriminate. - injection H' as [= H']. f_equal. - apply Pos.mul_reg_r with b. now rewrite Pos.mul_1_l. -Qed. - -Lemma Qred_iff : forall q:Q, Qred q = q <-> Z.gcd (Qnum q) (QDen q) = 1%Z. -Proof. - split; intros. - - apply Qred_identity2; auto. - - apply Qred_identity; auto. -Qed. - -(** Coercion from [Qc] to [Q] and equality *) - -Lemma Qc_is_canon : forall q q' : Qc, q == q' -> q = q'. -Proof. - intros (q,hq) (q',hq') H. simpl in *. - assert (H' := Qred_complete _ _ H). - rewrite hq, hq' in H'. subst q'. f_equal. - apply eq_proofs_unicity. intros. repeat decide equality. -Qed. -#[global] -Hint Resolve Qc_is_canon : core. - -Theorem Qc_decomp: forall q q': Qc, (q:Q) = q' -> q = q'. -Proof. - intros. apply Qc_is_canon. now rewrite H. -Qed. - -(** [Q2Qc] : a conversion from [Q] to [Qc]. *) - -Lemma Qred_involutive : forall q:Q, Qred (Qred q) = Qred q. -Proof. - intros; apply Qred_complete. - apply Qred_correct. -Qed. - -Definition Q2Qc (q:Q) : Qc := Qcmake (Qred q) (Qred_involutive q). -Arguments Q2Qc q%_Q. - -Lemma Q2Qc_eq_iff (q q' : Q) : Q2Qc q = Q2Qc q' <-> q == q'. -Proof. - split; intro H. - - now injection H as [= H%Qred_eq_iff]. - - apply Qc_is_canon. simpl. now rewrite H. -Qed. - -Notation " 0 " := (Q2Qc 0) : Qc_scope. -Notation " 1 " := (Q2Qc 1) : Qc_scope. - -Definition Qcle (x y : Qc) := (x <= y)%Q. -Definition Qclt (x y : Qc) := (x < y)%Q. -Notation Qcgt := (fun x y : Qc => Qlt y x). -Notation Qcge := (fun x y : Qc => Qle y x). -Infix "<" := Qclt : Qc_scope. -Infix "<=" := Qcle : Qc_scope. -Infix ">" := Qcgt : Qc_scope. -Infix ">=" := Qcge : Qc_scope. -Notation "x <= y <= z" := (x<=y/\y<=z) : Qc_scope. -Notation "x < y < z" := (x (p ?= q) = Eq. -Proof. - unfold Qccompare. - intros; rewrite <- Qeq_alt. - split; auto. now intros <-. -Qed. - -Lemma Qclt_alt : forall p q, (p (p?=q = Lt). -Proof. - intros; exact (Qlt_alt p q). -Qed. - -Lemma Qcgt_alt : forall p q, (p>q) <-> (p?=q = Gt). -Proof. - intros; exact (Qgt_alt p q). -Qed. - -Lemma Qcle_alt : forall p q, (p<=q) <-> (p?=q <> Gt). -Proof. - intros; exact (Qle_alt p q). -Qed. - -Lemma Qcge_alt : forall p q, (p>=q) <-> (p?=q <> Lt). -Proof. - intros; exact (Qge_alt p q). -Qed. - -(** equality on [Qc] is decidable: *) - -Theorem Qc_eq_dec : forall x y:Qc, {x=y} + {x<>y}. -Proof. - intros. - destruct (Qeq_dec x y) as [H|H]; auto. - right; contradict H; subst; auto with qarith. -Defined. - -(** The addition, multiplication and opposite are defined - in the straightforward way: *) - -Definition Qcplus (x y : Qc) := Q2Qc (x+y). -Infix "+" := Qcplus : Qc_scope. -Definition Qcmult (x y : Qc) := Q2Qc (x*y). -Infix "*" := Qcmult : Qc_scope. -Definition Qcopp (x : Qc) := Q2Qc (-x). -Notation "- x" := (Qcopp x) : Qc_scope. -Definition Qcminus (x y : Qc) := x+-y. -Infix "-" := Qcminus : Qc_scope. -Definition Qcinv (x : Qc) := Q2Qc (/x). -Notation "/ x" := (Qcinv x) : Qc_scope. -Definition Qcdiv (x y : Qc) := x*/y. -Infix "/" := Qcdiv : Qc_scope. - -(** [0] and [1] are apart *) - -Lemma Q_apart_0_1 : 1 <> 0. -Proof. - unfold Q2Qc. - intros H; discriminate H. -Qed. - -Ltac qc := match goal with - | q:Qc |- _ => destruct q; qc - | _ => apply Qc_is_canon; simpl; rewrite !Qred_correct -end. - -Opaque Qred. - -(** Addition is associative: *) - -Theorem Qcplus_assoc : forall x y z, x+(y+z)=(x+y)+z. -Proof. - intros; qc; apply Qplus_assoc. -Qed. - -(** [0] is a neutral element for addition: *) - -Lemma Qcplus_0_l : forall x, 0+x = x. -Proof. - intros; qc; apply Qplus_0_l. -Qed. - -Lemma Qcplus_0_r : forall x, x+0 = x. -Proof. - intros; qc; apply Qplus_0_r. -Qed. - -(** Commutativity of addition: *) - -Theorem Qcplus_comm : forall x y, x+y = y+x. -Proof. - intros; qc; apply Qplus_comm. -Qed. - -(** Properties of [Qopp] *) - -Lemma Qcopp_involutive : forall q, - -q = q. -Proof. - intros; qc; apply Qopp_involutive. -Qed. - -Theorem Qcplus_opp_r : forall q, q+(-q) = 0. -Proof. - intros; qc; apply Qplus_opp_r. -Qed. - -(** Multiplication is associative: *) - -Theorem Qcmult_assoc : forall n m p, n*(m*p)=(n*m)*p. -Proof. - intros; qc; apply Qmult_assoc. -Qed. - -(** [0] is absorbing for multiplication: *) - -Lemma Qcmult_0_l : forall n, 0*n = 0. -Proof. - intros; qc; split. -Qed. - -Theorem Qcmult_0_r : forall n, n*0=0. -Proof. - intros; qc; rewrite Qmult_comm; split. -Qed. - -(** [1] is a neutral element for multiplication: *) - -Lemma Qcmult_1_l : forall n, 1*n = n. -Proof. - intros; qc; apply Qmult_1_l. -Qed. - -Theorem Qcmult_1_r : forall n, n*1=n. -Proof. - intros; qc; apply Qmult_1_r. -Qed. - -(** Commutativity of multiplication *) - -Theorem Qcmult_comm : forall x y, x*y=y*x. -Proof. - intros; qc; apply Qmult_comm. -Qed. - -(** Distributivity *) - -Theorem Qcmult_plus_distr_r : forall x y z, x*(y+z)=(x*y)+(x*z). -Proof. - intros; qc; apply Qmult_plus_distr_r. -Qed. - -Theorem Qcmult_plus_distr_l : forall x y z, (x+y)*z=(x*z)+(y*z). -Proof. - intros; qc; apply Qmult_plus_distr_l. -Qed. - -(** Integrality *) - -Theorem Qcmult_integral : forall x y, x*y=0 -> x=0 \/ y=0. -Proof. - intros. - destruct (Qmult_integral x y); try qc; auto. - injection H as [= H]. - rewrite <- (Qred_correct (x*y)). - rewrite <- (Qred_correct 0). - rewrite H; auto with qarith. -Qed. - -Theorem Qcmult_integral_l : forall x y, ~ x = 0 -> x*y = 0 -> y = 0. -Proof. - intros; destruct (Qcmult_integral _ _ H0); tauto. -Qed. - -(** Inverse and division. *) - -Theorem Qcmult_inv_r : forall x, x<>0 -> x*(/x) = 1. -Proof. - intros; qc; apply Qmult_inv_r; auto. -Qed. - -Theorem Qcmult_inv_l : forall x, x<>0 -> (/x)*x = 1. -Proof. - intros. - rewrite Qcmult_comm. - apply Qcmult_inv_r; auto. -Qed. - -Lemma Qcinv_mult_distr : forall p q, / (p * q) = /p * /q. -Proof. - intros; qc; apply Qinv_mult_distr. -Qed. - -Theorem Qcdiv_mult_l : forall x y, y<>0 -> (x*y)/y = x. -Proof. - unfold Qcdiv. - intros. - rewrite <- Qcmult_assoc. - rewrite Qcmult_inv_r; auto. - apply Qcmult_1_r. -Qed. - -Theorem Qcmult_div_r : forall x y, ~ y = 0 -> y*(x/y) = x. -Proof. - unfold Qcdiv. - intros. - rewrite Qcmult_assoc. - rewrite Qcmult_comm. - rewrite Qcmult_assoc. - rewrite Qcmult_inv_l; auto. - apply Qcmult_1_l. -Qed. - -(** Properties of order upon Qc. *) - -Lemma Qcle_refl : forall x, x<=x. -Proof. - unfold Qcle; intros; simpl; apply Qle_refl. -Qed. - -Lemma Qcle_antisym : forall x y, x<=y -> y<=x -> x=y. -Proof. - unfold Qcle; intros; simpl in *. - apply Qc_is_canon; apply Qle_antisym; auto. -Qed. - -Lemma Qcle_trans : forall x y z, x<=y -> y<=z -> x<=z. -Proof. - unfold Qcle; intros; eapply Qle_trans; eauto. -Qed. - -Lemma Qclt_not_eq : forall x y, x x<>y. -Proof. - unfold Qclt; intros; simpl in *. - intro; destruct (Qlt_not_eq _ _ H). - subst; auto with qarith. -Qed. - -(** Large = strict or equal *) - -Lemma Qclt_le_weak : forall x y, x x<=y. -Proof. - unfold Qcle, Qclt; intros; apply Qlt_le_weak; auto. -Qed. - -Lemma Qcle_lt_trans : forall x y z, x<=y -> y x y<=z -> x y x y<=x. -Proof. - unfold Qcle, Qclt; intros; apply Qnot_lt_le; auto. -Qed. - -Lemma Qcnot_le_lt : forall x y, ~ x<=y -> y ~ y<=x. -Proof. - unfold Qcle, Qclt; intros; apply Qlt_not_le; auto. -Qed. - -Lemma Qcle_not_lt : forall x y, x<=y -> ~ y x -q <= -p. -Proof. - unfold Qcle, Qcopp; intros; simpl in *. - repeat rewrite Qred_correct. - apply Qopp_le_compat; auto. -Qed. - -Lemma Qcle_minus_iff : forall p q, p <= q <-> 0 <= q+-p. -Proof. - unfold Qcle, Qcminus; intros; simpl in *. - repeat rewrite Qred_correct. - apply Qle_minus_iff; auto. -Qed. - -Lemma Qclt_minus_iff : forall p q, p < q <-> 0 < q+-p. -Proof. - unfold Qclt, Qcplus, Qcopp; intros; simpl in *. - repeat rewrite Qred_correct. - apply Qlt_minus_iff; auto. -Qed. - -Lemma Qcplus_le_compat : - forall x y z t, x<=y -> z<=t -> x+z <= y+t. -Proof. - unfold Qcplus, Qcle; intros; simpl in *. - repeat rewrite Qred_correct. - apply Qplus_le_compat; auto. -Qed. - -Lemma Qcmult_le_compat_r : forall x y z, x <= y -> 0 <= z -> x*z <= y*z. -Proof. - unfold Qcmult, Qcle; intros; simpl in *. - repeat rewrite Qred_correct. - apply Qmult_le_compat_r; auto. -Qed. - -Lemma Qcmult_lt_0_le_reg_r : forall x y z, 0 < z -> x*z <= y*z -> x <= y. -Proof. - unfold Qcmult, Qcle, Qclt; intros; simpl in *. - rewrite !Qred_correct in * |-. - eapply Qmult_lt_0_le_reg_r; eauto. -Qed. - -Lemma Qcmult_lt_compat_r : forall x y z, 0 < z -> x < y -> x*z < y*z. -Proof. - unfold Qcmult, Qclt; intros; simpl in *. - rewrite !Qred_correct in *. - eapply Qmult_lt_compat_r; eauto. -Qed. - -(** Rational to the n-th power *) - -Fixpoint Qcpower (q:Qc)(n:nat) : Qc := - match n with - | O => 1 - | S n => q * (Qcpower q n) - end. - -Notation " q ^ n " := (Qcpower q n) : Qc_scope. - -Lemma Qcpower_1 : forall n, 1^n = 1. -Proof. - induction n; simpl; auto with qarith. - rewrite IHn; auto with qarith. -Qed. - -Lemma Qcpower_0 : forall n, n<>O -> 0^n = 0. -Proof. - destruct n; simpl. - - destruct 1; auto. - - intros. - now apply Qc_is_canon. -Qed. - -Lemma Qcpower_pos : forall p n, 0 <= p -> 0 <= p^n. -Proof. - induction n; simpl; auto with qarith. - - easy. - - intros. - apply Qcle_trans with (0*(p^n)). - + easy. - + apply Qcmult_le_compat_r; auto. -Qed. - -(** And now everything is easier concerning tactics: *) - -(** A ring tactic for rational numbers *) - -Definition Qc_eq_bool (x y : Qc) := - if Qc_eq_dec x y then true else false. - -Lemma Qc_eq_bool_correct : forall x y : Qc, Qc_eq_bool x y = true -> x=y. -Proof. - intros x y; unfold Qc_eq_bool; case (Qc_eq_dec x y); simpl; auto. - intros _ H; inversion H. -Qed. - -Definition Qcrt : ring_theory 0 1 Qcplus Qcmult Qcminus Qcopp (eq(A:=Qc)). -Proof. - constructor. - - exact Qcplus_0_l. - - exact Qcplus_comm. - - exact Qcplus_assoc. - - exact Qcmult_1_l. - - exact Qcmult_comm. - - exact Qcmult_assoc. - - exact Qcmult_plus_distr_l. - - reflexivity. - - exact Qcplus_opp_r. -Qed. - -Definition Qcft : - field_theory 0%Qc 1%Qc Qcplus Qcmult Qcminus Qcopp Qcdiv Qcinv (eq(A:=Qc)). -Proof. - constructor. - - exact Qcrt. - - exact Q_apart_0_1. - - reflexivity. - - exact Qcmult_inv_l. -Qed. - -Add Field Qcfield : Qcft. - -(** A field tactic for rational numbers *) - -Example test_field : (forall x y : Qc, y<>0 -> (x/y)*y = x)%Qc. -Proof. -intros. -field. -auto. -Qed. diff --git a/stdlib/theories/QArith/Qfield.v b/stdlib/theories/QArith/Qfield.v deleted file mode 100644 index f438d3ae3f7a..000000000000 --- a/stdlib/theories/QArith/Qfield.v +++ /dev/null @@ -1,164 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* isZcst z - | Qmake ?n ?d => - match isZcst n with - true => isPcst d - | _ => false - end - | _ => false - end. - -Ltac Qcst t := - match isQcst t with - true => t - | _ => NotConstant - end. - -Ltac Qpow_tac t := - match t with - | Z0 => N0 - | Zpos ?n => Ncst (Npos n) - | Z.of_N ?n => Ncst n - | NtoZ ?n => Ncst n - | _ => NotConstant - end. - -Add Field Qfield : Qsft - (decidable Qeq_bool_eq, - completeness Qeq_eq_bool, - constants [Qcst], - power_tac Qpower_theory [Qpow_tac]). - -(** Exemple of use: *) - -Section Examples. - -Section Ex1. -Let ex1 : forall x y z : Q, (x+y)*z == (x*z)+(y*z). - intros. - ring. -Defined. -End Ex1. - -Section Ex2. -Let ex2 : forall x y : Q, x+y == y+x. - intros. - ring. -Defined. -End Ex2. - -Section Ex3. -Let ex3 : forall x y z : Q, (x+y)+z == x+(y+z). - intros. - ring. -Defined. -End Ex3. - -Section Ex4. -Let ex4 : (inject_Z 1)+(inject_Z 1)==(inject_Z 2). - ring. -Defined. -End Ex4. - -Section Ex5. -Let ex5 : 1+1 == 2#1. - ring. -Defined. -End Ex5. - -Section Ex6. -Let ex6 : (1#1)+(1#1) == 2#1. - ring. -Defined. -End Ex6. - -Section Ex7. -Let ex7 : forall x : Q, x-x== 0. - intro. - ring. -Defined. -End Ex7. - -Section Ex8. -Let ex8 : forall x : Q, x^1 == x. - intro. - ring. -Defined. -End Ex8. - -Section Ex9. -Let ex9 : forall x : Q, x^0 == 1. - intro. - ring. -Defined. -End Ex9. - -Section Ex10. -Let ex10 : forall x y : Q, ~(y==0) -> (x/y)*y == x. - intros. - field. - auto. -Defined. -End Ex10. - -End Examples. - -Lemma Qopp_plus : forall a b, -(a+b) == -a + -b. -Proof. - intros; ring. -Qed. - -Lemma Qopp_opp : forall q, - -q==q. -Proof. - intros; ring. -Qed. diff --git a/stdlib/theories/QArith/Qminmax.v b/stdlib/theories/QArith/Qminmax.v deleted file mode 100644 index 2eafbd38ecf5..000000000000 --- a/stdlib/theories/QArith/Qminmax.v +++ /dev/null @@ -1,69 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* ~Qpower_positive a n == 0. -Proof. -intros a n X H. -apply X; clear X. -induction n; simpl in *; try assumption; -destruct (Qmult_integral _ _ H); -try destruct (Qmult_integral _ _ H0); auto. -Qed. - -Lemma Qpower_pos_positive : forall p n, 0 <= p -> 0 <= Qpower_positive p n. -Proof. -intros p n Hp. -induction n; simpl; repeat apply Qmult_le_0_compat;assumption. -Qed. - -(** ** Qpower_positive and multiplication, exponent subtraction *) - -Lemma Qmult_power_positive : forall a b n, Qpower_positive (a*b) n == (Qpower_positive a n)*(Qpower_positive b n). -Proof. -induction n; -simpl; repeat rewrite IHn; ring. -Qed. - -Lemma Qpower_plus_positive : forall a n m, Qpower_positive a (n+m) == (Qpower_positive a n)*(Qpower_positive a m). -Proof. -intros a n m. -unfold Qpower_positive. -apply pow_pos_add. -- apply Q_Setoid. -- apply Qmult_comp. -- apply Qmult_assoc. -Qed. - -(** ** Qpower_positive and inversion, division, exponent subtraction *) - -Lemma Qinv_power_positive : forall a n, Qpower_positive (/a) n == /(Qpower_positive a n). -Proof. -induction n; -simpl; repeat (rewrite IHn || rewrite Qinv_mult_distr); reflexivity. -Qed. - -Lemma Qpower_minus_positive : forall a (n m:positive), - (m < n)%positive -> - Qpower_positive a (n-m)%positive == (Qpower_positive a n)/(Qpower_positive a m). -Proof. -intros a n m H. -destruct (Qeq_dec a 0) as [EQ|NEQ]. -- now rewrite EQ, !Qpower_positive_0. -- rewrite <- (Qdiv_mult_l (Qpower_positive a (n - m)) (Qpower_positive a m)) by - (now apply Qpower_not_0_positive). - f_equiv. - rewrite <- Qpower_plus_positive. - now rewrite Pos.sub_add. -Qed. - -(** ** Qpower and exponent multiplication *) - -Lemma Qpower_mult_positive : forall a n m, - Qpower_positive a (n*m) == Qpower_positive (Qpower_positive a n) m. -Proof. -intros a n m. -induction n using Pos.peano_ind. -- reflexivity. -- rewrite Pos.mul_succ_l. - rewrite <- Pos.add_1_l. - do 2 rewrite Qpower_plus_positive. - rewrite IHn. - rewrite Qmult_power_positive. - reflexivity. -Qed. - -(** ** Qpower_positive decomposition *) - -Lemma Qpower_decomp_positive p x y : - Qpower_positive (x#y) p = x ^ Zpos p # (y ^ p). -Proof. -induction p; intros; simpl Qpower_positive; rewrite ?IHp. -- (* xI *) - unfold Qmult, Qnum, Qden. f_equal. - + now rewrite <- Z.pow_twice_r, <- Z.pow_succ_r. - + apply Pos2Z.inj; rewrite !Pos2Z.inj_mul, !Pos2Z.inj_pow. - now rewrite <- Z.pow_twice_r, <- Z.pow_succ_r. -- (* xO *) - unfold Qmult, Qnum, Qden. f_equal. - + now rewrite <- Z.pow_twice_r. - + apply Pos2Z.inj; rewrite !Pos2Z.inj_mul, !Pos2Z.inj_pow. - now rewrite <- Z.pow_twice_r. -- (* xO *) - now rewrite Z.pow_1_r, Pos.pow_1_r. -Qed. - -(* This notation will be deprecated with a planned larger rework of Q lemma naming *) -Notation Qpower_decomp := Qpower_decomp_positive (only parsing). - -(** * Properties of Qpower *) - -(** ** Values of Qpower for specific arguments *) - -Lemma Qpower_0 : forall n, (n<>0)%Z -> 0^n == 0. -Proof. - intros [|n|n] Hn; try (elim Hn; reflexivity); simpl; - rewrite Qpower_positive_0; reflexivity. -Qed. - -Lemma Qpower_1 : forall n, 1^n == 1. -Proof. - intros [|n|n]; simpl; try rewrite Qpower_positive_1; reflexivity. -Qed. - -Lemma Qpower_0_r: forall q:Q, - q^0 == 1. -Proof. - intros q. - reflexivity. -Qed. - -Lemma Qpower_1_r: forall q:Q, - q^1 == q. -Proof. - intros q. - reflexivity. -Qed. - -(** ** Relation of Qpower to zero *) - -Lemma Qpower_not_0: forall (a : Q) (z : Z), - ~ a == 0 -> ~ Qpower a z == 0. -Proof. - intros a z H; destruct z. - - discriminate. - - apply Qpower_not_0_positive; assumption. - - cbn. intros H1. - pose proof Qmult_inv_r (Qpower_positive a p) as H2. - specialize (H2 (Qpower_not_0_positive _ _ H)). - rewrite H1, Qmult_0_r in H2. - discriminate H2. -Qed. - -Lemma Qpower_0_le : forall (p : Q) (n : Z), 0 <= p -> 0 <= p^n. -Proof. - intros p [|n|n] Hp; simpl; try discriminate; - try apply Qinv_le_0_compat; apply Qpower_pos_positive; assumption. -Qed. - -(* This notation will be deprecated with a planned larger rework of Q lemma naming *) -Notation Qpower_pos := Qpower_0_le (only parsing). - -Lemma Qpower_0_lt: forall (a : Q) (z : Z), 0 < a -> 0 < Qpower a z. -Proof. - intros q z Hpos. - pose proof Qpower_pos q z (Qlt_le_weak 0 q Hpos) as H1. - pose proof Qpower_not_0 q z as H2. - pose proof Qlt_not_eq 0 q Hpos as H3. - specialize (H2 (Qnot_eq_sym _ _ H3)); clear H3. - apply Qnot_eq_sym in H2. - apply Qlt_leneq; split; assumption. -Qed. - -(** ** Relation of Qpower to 1 *) - -Lemma Qpower_1_lt_pos: - forall (q : Q) (n : positive), (1 (1 < q ^ (Z.pos n))%Q. -Proof. - intros q n Hq. - induction n. - - cbn in *. - apply Qmult_lt_1_compat. 1:assumption. - apply Qmult_lt_1_compat; assumption. - - cbn in *. - apply Qmult_lt_1_compat; assumption. - - cbn; assumption. -Qed. - -Lemma Qpower_1_lt: - forall (q : Q) (n : Z), (1 (0 (1 < q ^ n)%Q. -Proof. - intros q n Hq Hn. - destruct n. - - inversion Hn. - - apply Qpower_1_lt_pos; assumption. - - discriminate (Z.lt_trans _ _ _ Hn (Pos2Z.neg_is_neg p)). -Qed. - -Lemma Qpower_1_le_pos: - forall (q : Q) (n : positive), (1<=q)%Q -> (1 <= q ^ (Z.pos n))%Q. -Proof. - intros q n Hq. - induction n. - - cbn in *. - apply Qmult_le_1_compat. 1:assumption. - apply Qmult_le_1_compat; assumption. - - cbn in *. - apply Qmult_le_1_compat; assumption. - - cbn; assumption. -Qed. - -Lemma Qpower_1_le: - forall (q : Q) (n : Z), (1<=q)%Q -> (0<=n)%Z -> (1 <= q ^ n)%Q. -Proof. - intros q n Hq Hn. - destruct n. - - apply Qle_refl. - - apply Qpower_1_le_pos; assumption. - - discriminate (Z.le_lt_trans _ _ _ Hn (Pos2Z.neg_is_neg p)). -Qed. - -(** ** Qpower and multiplication, exponent addition *) - -Lemma Qmult_power : forall a b n, (a*b)^n == a^n*b^n. -Proof. - intros a b [|n|n]; simpl; - try rewrite Qmult_power_positive; - try rewrite Qinv_mult_distr; - reflexivity. -Qed. - -Lemma Qpower_plus : forall a n m, ~a==0 -> a^(n+m) == a^n*a^m. -Proof. -intros a [|n|n] [|m|m] H; simpl; try ring; -try rewrite Qpower_plus_positive; -try apply Qinv_mult_distr; try reflexivity; -rewrite ?Z.pos_sub_spec; -case Pos.compare_spec; intros H0; simpl; subst; - try rewrite Qpower_minus_positive; - try (field; try split; apply Qpower_not_0_positive); - assumption. -Qed. - -Lemma Qpower_plus' : forall a n m, (n+m <> 0)%Z -> a^(n+m) == a^n*a^m. -Proof. -intros a n m H. -destruct (Qeq_dec a 0)as [X|X]. -- rewrite X. - rewrite Qpower_0 by assumption. - destruct n; destruct m; try (elim H; reflexivity); - simpl; repeat rewrite Qpower_positive_0; ring_simplify; - reflexivity. -- apply Qpower_plus. - assumption. -Qed. - -(** ** Qpower and inversion, division, exponent subtraction *) - -Lemma Qinv_power : forall a n, (/a)^n == /a^n. -Proof. - intros a [|n|n]; simpl; - try rewrite Qinv_power_positive; - reflexivity. -Qed. - -Lemma Qdiv_power : forall a b n, (a/b)^n == (a^n/b^n). -Proof. -unfold Qdiv. -intros a b n. -rewrite Qmult_power. -rewrite Qinv_power. -reflexivity. -Qed. - -Lemma Qinv_power_n : forall n p, (1#p)^n == /(inject_Z (Zpos p))^n. -Proof. -intros n p. -rewrite Qmake_Qdiv. -rewrite Qdiv_power. -rewrite Qpower_1. -unfold Qdiv. -ring. -Qed. - -Lemma Qpower_opp : forall a n, a^(-n) == /a^n. -Proof. -intros a [|n|n]; simpl; try reflexivity. -symmetry; apply Qinv_involutive. -Qed. - -Lemma Qpower_minus: forall (a : Q) (n m : Z), - ~ a == 0 -> a ^ (n - m) == a ^ n / a ^ m. -Proof. - intros a n m Hnz. - rewrite <- Z.add_opp_r. - rewrite Qpower_plus by assumption. - rewrite Qpower_opp. - field. - apply Qpower_not_0; assumption. -Qed. - -Lemma Qpower_minus_pos: forall (a b : positive) (n m : Z), - (Z.pos a#b) ^ (n - m) == (Z.pos a#b) ^ n * (Z.pos b#a) ^ m. -Proof. - intros a b n m. - rewrite Qpower_minus by discriminate. - rewrite <- (Qinv_pos b a), Qinv_power. - reflexivity. -Qed. - -Lemma Qpower_minus_neg: forall (a b : positive) (n m : Z), - (Z.neg a#b) ^ (n - m) == (Z.neg a#b) ^ n * (Z.neg b#a) ^ m. -Proof. - intros a b n m. - rewrite Qpower_minus by discriminate. - rewrite <- (Qinv_neg b a), Qinv_power. - reflexivity. -Qed. - -(** ** Qpower and exponent multiplication *) - -Lemma Qpower_mult : forall a n m, a^(n*m) == (a^n)^m. -Proof. -intros a [|n|n] [|m|m]; simpl; - try rewrite Qpower_positive_1; - try rewrite Qpower_mult_positive; - try rewrite Qinv_power_positive; - try rewrite Qinv_involutive; - try reflexivity. -Qed. - -(** ** Qpower decomposition *) - -Lemma Qpower_decomp_pos: forall (p : positive) (a : Z) (b : positive), - (a # b) ^ (Z.pos p) == a ^ (Z.pos p) # (b ^ p)%positive. -Proof. - intros p a b. - pose proof Qpower_decomp_positive p a b. - cbn; rewrite H; reflexivity. -Qed. - -Lemma Qpower_decomp_neg_pos: forall (p a b: positive), - (Z.pos a # b) ^ (Z.neg p) == (Z.pos b) ^ (Z.pos p) # (a ^ p)%positive. -Proof. - intros p a b. - cbn. - rewrite <- Qinv_power_positive, Qinv_pos. - rewrite Qpower_decomp_positive. - reflexivity. -Qed. - -Lemma Qpower_decomp_neg_neg: forall (p a b: positive), - (Z.neg a # b) ^ (Z.neg p) == (Z.neg b) ^ (Z.pos p) # (a ^ p)%positive. -Proof. - intros p a b. - cbn. - rewrite <- Qinv_power_positive, Qinv_neg. - rewrite Qpower_decomp_positive. - reflexivity. -Qed. - -(** ** Compatibility of Qpower with relational operators *) - -Lemma Qpower_lt_compat_l: - forall (q : Q) (n m : Z), (n < m)%Z -> (1 (q ^ n < q ^ m)%Q. -Proof. - intros q n m Hnm Hq. - replace m with (n+(m-n))%Z by ring. - rewrite Qpower_plus, <- Qmult_1_r, <- Qmult_assoc. - 2: { intros Habsurd. rewrite Habsurd in Hq. discriminate Hq. } - rewrite Qmult_lt_l, Qmult_1_l. - 2: { apply Qpower_0_lt. exact (Qlt_trans 0 1 q ltac:(reflexivity) Hq). } - remember (m-n)%Z as k. - apply Qpower_1_lt. - - exact Hq. - - rewrite Heqk; apply Z.lt_0_sub, Hnm. -Qed. - -Lemma Qpower_le_compat_l: - forall (q : Q) (n m : Z), (n <= m)%Z -> (1<=q)%Q -> (q ^ n <= q ^ m)%Q. -Proof. - intros q n m Hnm Hq. - replace m with (n+(m-n))%Z by ring. - rewrite Qpower_plus, <- Qmult_1_r, <- Qmult_assoc. - 2: { intros Habsurd. rewrite Habsurd in Hq. apply Hq. reflexivity. } - rewrite Qmult_le_l, Qmult_1_l. - 2: { apply Qpower_0_lt. exact (Qlt_le_trans 0 1 q ltac:(reflexivity) Hq). } - remember (m-n)%Z as k. - apply Qpower_1_le. - - exact Hq. - - rewrite Heqk; apply Z.le_0_sub, Hnm. -Qed. - -Lemma Qpower_lt_compat_l_inv: - forall (q : Q) (n m : Z), (q ^ n < q ^ m)%Q -> (1 (n < m)%Z. -Proof. - intros q n m Hnm Hq. - destruct (Z.ltb_spec n m) as [Hd|Hd]. - - assumption. - - pose proof Qpower_le_compat_l q m n Hd (Qlt_le_weak _ _ Hq) as Hnm'. - pose proof Qlt_le_trans _ _ _ Hnm Hnm' as Habsurd. - destruct (Qlt_irrefl _ Habsurd). -Qed. - -Lemma Qpower_le_compat_l_inv: - forall (q : Q) (n m : Z), (q ^ n <= q ^ m)%Q -> (1 (n <= m)%Z. -Proof. - intros q n m Hnm Hq. - destruct (Z.ltb_spec m n) as [Hd|Hd]. - - pose proof Qpower_lt_compat_l q m n Hd Hq as Hnm'. - pose proof Qle_lt_trans _ _ _ Hnm Hnm' as Habsurd. - destruct (Qlt_irrefl _ Habsurd). - - assumption. -Qed. - -(** ** Qpower and inject_Z *) - -Lemma Zpower_Qpower : forall (a n:Z), (0<=n)%Z -> inject_Z (a^n) == (inject_Z a)^n. -Proof. -intros a [|n|n] H;[reflexivity| |elim H; reflexivity]. -induction n using Pos.peano_ind. -- replace (a^1)%Z with a by ring. - ring. -- rewrite Pos2Z.inj_succ. - unfold Z.succ. - rewrite Zpower_exp; auto with *; try discriminate. - rewrite Qpower_plus' by discriminate. - rewrite <- IHn by discriminate. - replace (a^Zpos n*a^1)%Z with (a^Zpos n*a)%Z by ring. - ring_simplify. - reflexivity. -Qed. - -(** ** Square *) - -Lemma Qsqr_nonneg : forall a, 0 <= a^2. -Proof. -intros a. -destruct (Qlt_le_dec 0 a) as [A|A]. -- apply (Qmult_le_0_compat a a); - (apply Qlt_le_weak; assumption). -- setoid_replace (a^2) with ((-a)*(-a)) by ring. - rewrite Qle_minus_iff in A. - setoid_replace (0+ - a) with (-a) in A by ring. - apply Qmult_le_0_compat; assumption. -Qed. - -(** ** Power of 2 positive upper bound *) - -Lemma Qarchimedean_power2_pos : forall q : Q, - {p : positive | (q < Z.pos (2^p) # 1)%Q}. -Proof. - intros q. - destruct (Qarchimedean q) as [pexp Hpexp]. - exists (Pos.size pexp). - pose proof Pos.size_gt pexp as H1. - unfold Qlt in *. cbn in *; Zify.zify. - apply (Z.mul_lt_mono_pos_r (QDen q)) in H1; [|assumption]. - apply (Z.lt_trans _ _ _ Hpexp H1). -Qed. diff --git a/stdlib/theories/QArith/Qreals.v b/stdlib/theories/QArith/Qreals.v deleted file mode 100644 index 5a840101fdf9..000000000000 --- a/stdlib/theories/QArith/Qreals.v +++ /dev/null @@ -1,183 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* 0%R. -Proof. -intros. -now apply not_O_IZR. -Qed. - -#[global] -Hint Resolve IZR_nz Rmult_integral_contrapositive : core. - -Lemma eqR_Qeq : forall x y : Q, Q2R x = Q2R y -> x==y. -Proof. -unfold Qeq, Q2R; intros (x1, x2) (y1, y2); unfold Qnum, Qden; - intros. -apply eq_IZR. -do 2 rewrite mult_IZR. -set (X1 := IZR x1) in *; assert (X2nz := IZR_nz x2); - set (X2 := IZR (Zpos x2)) in *. -set (Y1 := IZR y1) in *; assert (Y2nz := IZR_nz y2); - set (Y2 := IZR (Zpos y2)) in *. -assert ((X2 * X1 * / X2)%R = (X2 * (Y1 * / Y2))%R). -- rewrite <- H; field; auto. -- rewrite Rinv_r_simpl_m in H0; auto; rewrite H0; field; auto. -Qed. - -Lemma Qeq_eqR : forall x y : Q, x==y -> Q2R x = Q2R y. -Proof. -unfold Qeq, Q2R; intros (x1, x2) (y1, y2); unfold Qnum, Qden; - intros. -set (X1 := IZR x1) in *; assert (X2nz := IZR_nz x2); - set (X2 := IZR (Zpos x2)) in *. -set (Y1 := IZR y1) in *; assert (Y2nz := IZR_nz y2); - set (Y2 := IZR (Zpos y2)) in *. -assert ((X1 * Y2)%R = (Y1 * X2)%R). -- unfold X1, X2, Y1, Y2; do 2 rewrite <- mult_IZR. - f_equal; auto. -- clear H. - field_simplify_eq; auto. - rewrite H0; ring. -Qed. - -Lemma Rle_Qle : forall x y : Q, (Q2R x <= Q2R y)%R -> x<=y. -Proof. -unfold Qle, Q2R; intros (x1, x2) (y1, y2); unfold Qnum, Qden; - intros. -apply le_IZR. -do 2 rewrite mult_IZR. -set (X1 := IZR x1) in *; assert (X2nz := IZR_nz x2); - set (X2 := IZR (Zpos x2)) in *. -set (Y1 := IZR y1) in *; assert (Y2nz := IZR_nz y2); - set (Y2 := IZR (Zpos y2)) in *. -replace (X1 * Y2)%R with (X1 * / X2 * (X2 * Y2))%R; try (field; auto). -replace (Y1 * X2)%R with (Y1 * / Y2 * (X2 * Y2))%R; try (field; auto). -apply Rmult_le_compat_r; auto. -apply Rmult_le_pos. -- now apply IZR_le. -- now apply IZR_le. -Qed. - -Lemma Qle_Rle : forall x y : Q, x<=y -> (Q2R x <= Q2R y)%R. -Proof. -unfold Qle, Q2R; intros (x1, x2) (y1, y2); unfold Qnum, Qden; - intros. -set (X1 := IZR x1) in *; assert (X2nz := IZR_nz x2); - set (X2 := IZR (Zpos x2)) in *. -set (Y1 := IZR y1) in *; assert (Y2nz := IZR_nz y2); - set (Y2 := IZR (Zpos y2)) in *. -assert (X1 * Y2 <= Y1 * X2)%R. -- unfold X1, X2, Y1, Y2; do 2 rewrite <- mult_IZR. - apply IZR_le; auto. -- clear H. - replace (X1 * / X2)%R with (X1 * Y2 * (/ X2 * / Y2))%R; try (field; auto). - replace (Y1 * / Y2)%R with (Y1 * X2 * (/ X2 * / Y2))%R; try (field; auto). - apply Rmult_le_compat_r; auto. - apply Rmult_le_pos; apply Rlt_le; apply Rinv_0_lt_compat. - + now apply IZR_lt. - + now apply IZR_lt. -Qed. - -Lemma Rlt_Qlt : forall x y : Q, (Q2R x < Q2R y)%R -> x (Q2R x < Q2R y)%R. -Proof. -unfold Qlt, Q2R; intros (x1, x2) (y1, y2); unfold Qnum, Qden; - intros. -set (X1 := IZR x1) in *; assert (X2nz := IZR_nz x2); - set (X2 := IZR (Zpos x2)) in *. -set (Y1 := IZR y1) in *; assert (Y2nz := IZR_nz y2); - set (Y2 := IZR (Zpos y2)) in *. -assert (X1 * Y2 < Y1 * X2)%R. -- unfold X1, X2, Y1, Y2; do 2 rewrite <- mult_IZR. - apply IZR_lt; auto. -- clear H. - replace (X1 * / X2)%R with (X1 * Y2 * (/ X2 * / Y2))%R; try (field; auto). - replace (Y1 * / Y2)%R with (Y1 * X2 * (/ X2 * / Y2))%R; try (field; auto). - apply Rmult_lt_compat_r; auto. - apply Rmult_lt_0_compat; apply Rinv_0_lt_compat. - + now apply IZR_lt. - + now apply IZR_lt. -Qed. - -Lemma Q2R_plus : forall x y : Q, Q2R (x+y) = (Q2R x + Q2R y)%R. -Proof. -unfold Qplus, Qeq, Q2R; intros (x1, x2) (y1, y2); - unfold Qden, Qnum. -simpl_mult. -rewrite plus_IZR. -do 3 rewrite mult_IZR. -field; auto. -Qed. - -Lemma Q2R_mult : forall x y : Q, Q2R (x*y) = (Q2R x * Q2R y)%R. -Proof. -unfold Qmult, Qeq, Q2R; intros (x1, x2) (y1, y2); - unfold Qden, Qnum. -simpl_mult. -do 2 rewrite mult_IZR. -field; auto. -Qed. - -Lemma Q2R_opp : forall x : Q, Q2R (- x) = (- Q2R x)%R. -Proof. -unfold Qopp, Qeq, Q2R; intros (x1, x2); unfold Qden, Qnum. -rewrite Ropp_Ropp_IZR. -field; auto. -Qed. - -Lemma Q2R_minus : forall x y : Q, Q2R (x-y) = (Q2R x - Q2R y)%R. -Proof. -unfold Qminus; intros; rewrite Q2R_plus; rewrite Q2R_opp; auto. -Qed. - -Lemma Q2R_inv : forall x : Q, ~ x==0 -> Q2R (/x) = (/ Q2R x)%R. -Proof. -unfold Qinv, Q2R, Qeq; intros (x1, x2). case x1; unfold Qnum, Qden. -- simpl; intros; elim H; trivial. -- intros; field; auto. -- intros; - change (IZR (Zneg x2)) with (- IZR (Zpos x2))%R; - change (IZR (Zneg p)) with (- IZR (Zpos p))%R; - simpl; field; (*auto 8 with real.*) - repeat split; auto; auto with real. -Qed. - -Lemma Q2R_div : - forall x y : Q, ~ y==0 -> Q2R (x/y) = (Q2R x / Q2R y)%R. -Proof. -unfold Qdiv, Rdiv. -intros; rewrite Q2R_mult. -rewrite Q2R_inv; auto. -Qed. - -Global Hint Rewrite Q2R_plus Q2R_mult Q2R_opp Q2R_minus Q2R_inv Q2R_div : q2r_simpl. diff --git a/stdlib/theories/QArith/Qreduction.v b/stdlib/theories/QArith/Qreduction.v deleted file mode 100644 index c9ce035967ce..000000000000 --- a/stdlib/theories/QArith/Qreduction.v +++ /dev/null @@ -1,170 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* g) by (intro; subst; discriminate). - rewrite Z2Pos.id. - - ring. - - now rewrite <- (Z.mul_pos_cancel_l g); [ rewrite <- Hd | apply Z.le_neq ]. - Close Scope Z_scope. -Qed. - -Lemma Qred_complete : forall p q, p==q -> Qred p = Qred q. -Proof. - intros (a,b) (c,d). - unfold Qred, Qeq in *; simpl in *. - Open Scope Z_scope. - intros H. - generalize (Z.ggcd_gcd a (Zpos b)) (Zgcd_is_gcd a (Zpos b)) - (Z.gcd_nonneg a (Zpos b)) (Z.ggcd_correct_divisors a (Zpos b)). - destruct (Z.ggcd a (Zpos b)) as (g,(aa,bb)). - simpl. intros <- Hg1 Hg2 (Hg3,Hg4). - assert (Hg0 : g <> 0) by (intro; now subst g). - generalize (Z.ggcd_gcd c (Zpos d)) (Zgcd_is_gcd c (Zpos d)) - (Z.gcd_nonneg c (Zpos d)) (Z.ggcd_correct_divisors c (Zpos d)). - destruct (Z.ggcd c (Zpos d)) as (g',(cc,dd)). - simpl. intros <- Hg'1 Hg'2 (Hg'3,Hg'4). - assert (Hg'0 : g' <> 0) by (intro; now subst g'). - - elim (rel_prime_cross_prod aa bb cc dd). - - congruence. - - (*rel_prime*) - constructor. - * exists aa; auto using Z.mul_1_r. - * exists bb; auto using Z.mul_1_r. - * intros x Ha Hb. - destruct Hg1 as (Hg11,Hg12,Hg13). - destruct (Hg13 (g*x)) as (x',Hx). - { rewrite Hg3. - destruct Ha as (xa,Hxa); exists xa; rewrite Hxa; ring. } - { rewrite Hg4. - destruct Hb as (xb,Hxb); exists xb; rewrite Hxb; ring. } - exists x'. - apply Z.mul_reg_l with g; auto. rewrite Hx at 1; ring. - - (* rel_prime *) - constructor. - * exists cc; auto using Z.mul_1_r. - * exists dd; auto using Z.mul_1_r. - * intros x Hc Hd. - inversion Hg'1 as (Hg'11,Hg'12,Hg'13). - destruct (Hg'13 (g'*x)) as (x',Hx). - { rewrite Hg'3. - destruct Hc as (xc,Hxc); exists xc; rewrite Hxc; ring. } - { rewrite Hg'4. - destruct Hd as (xd,Hxd); exists xd; rewrite Hxd; ring. } - exists x'. - apply Z.mul_reg_l with g'; auto. rewrite Hx at 1; ring. - - apply Z.lt_gt. - rewrite <- (Z.mul_pos_cancel_l g); [ now rewrite <- Hg4 | apply Z.le_neq; intuition ]. - - apply Z.lt_gt. - rewrite <- (Z.mul_pos_cancel_l g'); [now rewrite <- Hg'4 | apply Z.le_neq; intuition ]. - - apply Z.mul_reg_l with (g*g'). - * rewrite Z.mul_eq_0. now destruct 1. - * rewrite Z.mul_shuffle1, <- Hg3, <- Hg'4. - now rewrite Z.mul_shuffle1, <- Hg'3, <- Hg4, H, Z.mul_comm. - Close Scope Z_scope. -Qed. - -Lemma Qred_eq_iff q q' : Qred q = Qred q' <-> q == q'. -Proof. - split. - - intros E. rewrite <- (Qred_correct q), <- (Qred_correct q'). - now rewrite E. - - apply Qred_complete. -Qed. - -Add Morphism Qred with signature (Qeq ==> Qeq) as Qred_comp. -Proof. - intros. now rewrite !Qred_correct. -Qed. - -Definition Qplus' (p q : Q) := Qred (Qplus p q). -Definition Qmult' (p q : Q) := Qred (Qmult p q). -Definition Qminus' x y := Qred (Qminus x y). - -Lemma Qplus'_correct : forall p q : Q, (Qplus' p q)==(Qplus p q). -Proof. - intros; unfold Qplus'; apply Qred_correct; auto. -Qed. - -Lemma Qmult'_correct : forall p q : Q, (Qmult' p q)==(Qmult p q). -Proof. - intros; unfold Qmult'; apply Qred_correct; auto. -Qed. - -Lemma Qminus'_correct : forall p q : Q, (Qminus' p q)==(Qminus p q). -Proof. - intros; unfold Qminus'; apply Qred_correct; auto. -Qed. - -Add Morphism Qplus' with signature (Qeq ==> Qeq ==> Qeq) as Qplus'_comp. -Proof. - intros ? ? H ? ? H0; unfold Qplus'. - rewrite H, H0; auto with qarith. -Qed. - -Add Morphism Qmult' with signature (Qeq ==> Qeq ==> Qeq) as Qmult'_comp. -Proof. - intros ? ? H ? ? H0; unfold Qmult'. - rewrite H, H0; auto with qarith. -Qed. - -Add Morphism Qminus' with signature (Qeq ==> Qeq ==> Qeq) as Qminus'_comp. -Proof. - intros ? ? H ? ? H0; unfold Qminus'. - rewrite H, H0; auto with qarith. -Qed. - -Lemma Qred_opp: forall q, Qred (-q) = - (Qred q). -Proof. - intros (x, y); unfold Qred; simpl. - rewrite Z.ggcd_opp; case Z.ggcd; intros p1 (p2, p3); simpl. - unfold Qopp; auto. -Qed. - -Theorem Qred_compare: forall x y, - Qcompare x y = Qcompare (Qred x) (Qred y). -Proof. - intros x y; apply Qcompare_comp; apply Qeq_sym; apply Qred_correct. -Qed. - -Lemma Qred_le q q' : Qred q <= Qred q' <-> q <= q'. -Proof. - now rewrite !Qle_alt, <- Qred_compare. -Qed. - -Lemma Qred_lt q q' : Qred q < Qred q' <-> q < q'. -Proof. - now rewrite !Qlt_alt, <- Qred_compare. -Qed. diff --git a/stdlib/theories/QArith/Qring.v b/stdlib/theories/QArith/Qring.v deleted file mode 100644 index 8b996074ec23..000000000000 --- a/stdlib/theories/QArith/Qring.v +++ /dev/null @@ -1,11 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* -> Q. - -Definition Qfloor (x:Q) := let (n,d) := x in Z.div n (Zpos d). -Definition Qceiling (x:Q) := (-(Qfloor (-x)))%Z. - -Lemma Qfloor_Z : forall z:Z, Qfloor z = z. -Proof. -intros z. -simpl. -auto with *. -Qed. - -Lemma Qceiling_Z : forall z:Z, Qceiling z = z. -Proof. -intros z. -unfold Qceiling. -simpl. -rewrite Z.div_1_r. -apply Z.opp_involutive. -Qed. - -Lemma Qfloor_le : forall x, Qfloor x <= x. -Proof. -intros [n d]. -simpl. -unfold Qle. -simpl. -replace (n*1)%Z with n by ring. -rewrite Z.mul_comm. -now apply Z.mul_div_le. -Qed. - -#[global] -Hint Resolve Qfloor_le : qarith. - -Lemma Qle_ceiling : forall x, x <= Qceiling x. -Proof. -intros x. -apply Qle_trans with (- - x). -- rewrite Qopp_involutive. - auto with *. -- change (Qceiling x:Q) with (-(Qfloor(-x))). - auto with *. -Qed. - -#[global] -Hint Resolve Qle_ceiling : qarith. - -Lemma Qle_floor_ceiling : forall x, Qfloor x <= Qceiling x. -Proof. -eauto with qarith. -Qed. - -Lemma Qlt_floor : forall x, x < (Qfloor x+1)%Z. -Proof. -intros [n d]. -simpl. -unfold Qlt. -simpl. -replace (n*1)%Z with n by ring. -ring_simplify. -replace (n / Zpos d * Zpos d + Zpos d)%Z with - ((Zpos d * (n / Zpos d) + n mod Zpos d) + Zpos d - n mod Zpos d)%Z by ring. -rewrite <- Z_div_mod_eq_full. -rewrite <- Z.lt_add_lt_sub_r. -destruct (Z_mod_lt n (Zpos d)); auto with *. -Qed. - -#[global] -Hint Resolve Qlt_floor : qarith. - -Lemma Qceiling_lt : forall x, (Qceiling x-1)%Z < x. -Proof. -intros x. -unfold Qceiling. -replace (- Qfloor (- x) - 1)%Z with (-(Qfloor (-x) + 1))%Z by ring. -change ((- (Qfloor (- x) + 1))%Z:Q) with (-(Qfloor (- x) + 1)%Z). -apply Qlt_le_trans with (- - x); auto with *. -rewrite Qopp_involutive. -auto with *. -Qed. - -#[global] -Hint Resolve Qceiling_lt : qarith. - -Lemma Qfloor_resp_le : forall x y, x <= y -> (Qfloor x <= Qfloor y)%Z. -Proof. -intros [xn xd] [yn yd] Hxy. -unfold Qle in *. -simpl in *. -rewrite <- (Zdiv_mult_cancel_r xn (Zpos xd) (Zpos yd)); auto with *. -rewrite <- (Zdiv_mult_cancel_r yn (Zpos yd) (Zpos xd)); auto with *. -rewrite (Z.mul_comm (Zpos yd) (Zpos xd)). -apply Z_div_le; auto with *. -Qed. - -#[global] -Hint Resolve Qfloor_resp_le : qarith. - -Lemma Qceiling_resp_le : forall x y, x <= y -> (Qceiling x <= Qceiling y)%Z. -Proof. -intros x y Hxy. -unfold Qceiling. -rewrite <- Z.opp_le_mono; auto with qarith. -Qed. - -#[global] -Hint Resolve Qceiling_resp_le : qarith. - -Add Morphism Qfloor with signature Qeq ==> eq as Qfloor_comp. -Proof. -intros x y H. -apply Z.le_antisymm. -- auto with *. -- symmetry in H; auto with *. -Qed. - -Add Morphism Qceiling with signature Qeq ==> eq as Qceiling_comp. -Proof. -intros x y H. -apply Z.le_antisymm. -- auto with *. -- symmetry in H; auto with *. -Qed. - -Lemma Zdiv_Qdiv (n m: Z): (n / m)%Z = Qfloor (n / m). -Proof. - unfold Qfloor. intros. simpl. - destruct m as [ | | p]; simpl. - - now rewrite Zdiv_0_r, Z.mul_0_r. - - now rewrite Z.mul_1_r. - - rewrite <- Z.opp_eq_mul_m1. - rewrite <- (Z.opp_involutive (Zpos p)). - now rewrite Zdiv_opp_opp. -Qed. diff --git a/stdlib/theories/Reals/Abstract/ConstructiveAbs.v b/stdlib/theories/Reals/Abstract/ConstructiveAbs.v deleted file mode 100644 index bd97ce63d004..000000000000 --- a/stdlib/theories/Reals/Abstract/ConstructiveAbs.v +++ /dev/null @@ -1,370 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* 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 _ 0). 2: exact H. - apply (CRle_trans _ (CRopp R 0)). - * intro abs. apply CRopp_lt_cancel in abs. contradiction. - * apply (CRplus_le_reg_l 0). - apply (CRle_trans _ 0). - -- 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 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. - * apply (CReq_trans _ (CRopp R (CR_of_Q R q))). - -- apply CRabs_right. - 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. - -- apply CReq_sym, CR_of_Q_opp. - + apply CR_of_Q_morph; symmetry; apply Qabs_neg, q0. -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). - * 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. - ++ rewrite <- Qopp_involutive, CR_of_Q_opp. - apply CRopp_ge_le_contravar, CRlt_asym, c. - -- exact H1. - * exact c. - + apply (CRlt_le_trans _ _ _ H0). - 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. diff --git a/stdlib/theories/Reals/Abstract/ConstructiveLUB.v b/stdlib/theories/Reals/Abstract/ConstructiveLUB.v deleted file mode 100644 index c3126b4fdb44..000000000000 --- a/stdlib/theories/Reals/Abstract/ConstructiveLUB.v +++ /dev/null @@ -1,465 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* 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. - -- 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 (Nat.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 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. - exact (CRlt_asym _ _ imaj (CRinv_0_lt_compat R _ (inr H2) H2)). - + specialize (pmaj (max (S i) (S p)) (Nat.le_trans p (S p) _ (le_S p p (Nat.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. - 2: exact H2. - rewrite CRinv_r in imaj. - destruct (Q_dec (r+(1#Pos.of_nat (S i))) q);[|rewrite q0; apply Qle_refl]. - destruct s. - { apply Qlt_le_weak, q0. } - 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 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/stdlib/theories/Reals/Abstract/ConstructiveLimits.v b/stdlib/theories/Reals/Abstract/ConstructiveLimits.v deleted file mode 100644 index 8a90c73ca4a4..000000000000 --- a/stdlib/theories/Reals/Abstract/ConstructiveLimits.v +++ /dev/null @@ -1,525 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* 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, (Nat.le_trans _ _ _ (Nat.le_max_l _ _) H). - * apply jmaj, (Nat.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 _ => 0) (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). 1: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 (Nat.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). exact H. - + 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 (Nat.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). exact H0. - + 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)). - rewrite CRplus_opp_l, CRplus_comm. symmetry. exact H. -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. - -#[global] -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)). - { 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). - * 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]. - - apply CR_of_Q_lt. reflexivity. - - exists p. intros. apply CRlt_asym. apply pmaj. apply H. -Qed. - -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 (Nat.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 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. - + 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 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. - - 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 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 <- (Nat.add_0_l N), Nat.add_assoc. - apply Nat.add_le_mono_r, Nat.le_0_l. - - specialize (H1 (n+N)%nat). apply (CRplus_lt_reg_r (-l)). - assert (n + N >= n)%nat. - + rewrite <- (Nat.add_0_r n), <- Nat.add_assoc. - apply Nat.add_le_mono_l, Nat.le_0_l. - + 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 <- (Nat.add_0_l N). apply Nat.add_le_mono_r, Nat.le_0_l. - - 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 <- (Nat.add_0_r n), <- Nat.add_assoc. - apply Nat.add_le_mono_l, Nat.le_0_l. -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 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 (Nat.le_trans _ (N + k)). 2: exact H. - apply (Nat.le_trans _ (0 + k)). - + apply Nat.le_refl. - + rewrite <- Nat.add_le_mono_r. apply Nat.le_0_l. - - 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. - apply Nat.le_trans with n; [ assumption | apply Nat.le_add_r ]. -Qed. diff --git a/stdlib/theories/Reals/Abstract/ConstructiveMinMax.v b/stdlib/theories/Reals/Abstract/ConstructiveMinMax.v deleted file mode 100644 index 515afa8fc18e..000000000000 --- a/stdlib/theories/Reals/Abstract/ConstructiveMinMax.v +++ /dev/null @@ -1,710 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* 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 CRmult_1_r. - rewrite (CR_of_Q_plus R 1 1), 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. - intro abs. contradict H. - apply (CRle_trans _ (x + y - CRabs R (y - x))). - * rewrite CRabs_left. 2: apply CRlt_asym, abs. - unfold CRminus. rewrite CRopp_involutive, CRplus_comm. - rewrite CRplus_assoc, <- (CRplus_assoc (-x)), CRplus_opp_l. - rewrite CRplus_0_l, (CR_of_Q_plus R 1 1), CRmult_plus_distr_l. - rewrite CRmult_1_r. apply CRle_refl. - * rewrite CRmult_assoc, <- CR_of_Q_mult. - setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. - rewrite CRmult_1_r. apply CRle_refl. -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. - -#[global] -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)). - - 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 CRmult_1_r. - rewrite (CR_of_Q_plus _ 1 1), CRmult_plus_distr_l, 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)). - - 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 CRmult_1_r. - rewrite (CR_of_Q_plus _ 1 1), CRmult_plus_distr_l, 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. 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 CRmult_1_r. - rewrite CRmult_assoc, <- CR_of_Q_mult. - setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. - rewrite CRmult_1_r. - rewrite (CR_of_Q_plus _ 1 1), CRmult_plus_distr_l, 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. 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 CRmult_1_r. - rewrite (CR_of_Q_plus _ 1 1), CRmult_plus_distr_l, 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. 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 CRmult_1_r. - rewrite (CR_of_Q_plus _ 1 1), CRmult_plus_distr_l, 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)). - - 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 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), 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), 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: 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. - * 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. - 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 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)). - - 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 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), 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), 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. - -#[global] -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)). - - 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 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, 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, 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)). - - 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 CRmult_1_r. - setoid_replace 2%Q with (1+1)%Q. - + rewrite CR_of_Q_plus. - 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)). - - 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 CRmult_1_r. - rewrite (CR_of_Q_plus _ 1 1), CRmult_plus_distr_l, 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. 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 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, 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. 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 CRmult_1_r. - rewrite (CR_of_Q_plus _ 1 1), CRmult_plus_distr_l, 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. 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 CRmult_1_r. - rewrite (CR_of_Q_plus _ 1 1), CRmult_plus_distr_l, 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: 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. - * 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. - 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 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)). - - 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 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), 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), 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. - -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. diff --git a/stdlib/theories/Reals/Abstract/ConstructivePower.v b/stdlib/theories/Reals/Abstract/ConstructivePower.v deleted file mode 100644 index 0b9ce492a5dd..000000000000 --- a/stdlib/theories/Reals/Abstract/ConstructivePower.v +++ /dev/null @@ -1,275 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* 1 - | S n => r * (CRpow r n) - end. - -Lemma CRpow_ge_one : 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 CRpow_ge_zero : 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 CRpow_gt_zero : 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 CRpow_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 CRpow_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 CRpow_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 CRpow_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 (CRpow_gt_zero 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 CRpow_gt_zero, xPos. } - rewrite <- (CRinv_mult_distr _ _ _ _ (inr H)). - apply CRinv_morph. reflexivity. -Qed. - -Lemma CRpow_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. - -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. - 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. - 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. - apply CRpow_ge_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 CRpow_ge_zero; apply CR_of_Q_le; discriminate. - apply CRlt_asym. - apply (CRmult_lt_reg_l (CR_of_Q R (Z.pos p # 1))). - - 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 CRpow_gt_zero. - apply CR_of_Q_lt. reflexivity. - + rewrite CRmult_assoc. rewrite CRpow_mult. - rewrite (CRpow_proper (CR_of_Q R (1 # 2) * CR_of_Q R 2) 1), CRpow_one. - * rewrite CRmult_1_r, 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. - -- reflexivity. - -- 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_plus R 1 1). - rewrite CRplus_assoc. - rewrite CRplus_opp_r, CRplus_0_r. 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. - * 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 CRpow_gt_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. - 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. - 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 CRpow_ge_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). - { apply CR_of_Q_lt. reflexivity. } - rewrite (CRpow_proper _ (CRinv R (CR_of_Q R 2) (inr H1))). - -- rewrite CRpow_inv. apply CRlt_asym. - apply (CRmult_lt_reg_l (CRpow (CR_of_Q R 2) i)). - ++ apply CRpow_gt_zero, H1. - ++ rewrite CRinv_r. - apply (CRmult_lt_reg_r (CR_of_Q R (Z.pos n#1))). - ** 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 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 (Nat.le_trans _ _ _ H0). rewrite SuccNat2Pos.id_succ. apply Nat.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. - ** reflexivity. - ** reflexivity. - * apply CRlt_asym, CRpow_gt_zero. - apply CR_of_Q_lt. reflexivity. - + unfold CRminus. rewrite CRplus_comm, <- CRplus_assoc. - rewrite CRplus_opp_l, CRplus_0_l. reflexivity. -Qed. diff --git a/stdlib/theories/Reals/Abstract/ConstructiveReals.v b/stdlib/theories/Reals/Abstract/ConstructiveReals.v deleted file mode 100644 index 76f92e9d6a16..000000000000 --- a/stdlib/theories/Reals/Abstract/ConstructiveReals.v +++ /dev/null @@ -1,1235 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* 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. - - WARNING: this file is experimental and likely to change in future releases. - *) - - -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; - - (* 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_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; - - (* Addition and multiplication *) - CRplus : CRcarrier -> CRcarrier -> CRcarrier; - CRopp : CRcarrier -> CRcarrier; (* Computable opposite, - stronger than Prop-existence of opposite *) - CRmult : CRcarrier -> CRcarrier -> 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)); - CRisRing : ring_theory (CR_of_Q 0) (CR_of_Q 1) 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 (CR_of_Q 0) (CR_of_Q 1); - 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 (CR_of_Q 0) x -> CRlt (CR_of_Q 0) y -> CRlt (CR_of_Q 0) (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 (CR_of_Q 0) -> CRcarrier; - CRinv_l : forall (r:CRcarrier) (rnz : CRapart r (CR_of_Q 0)), - CReq (CRmult (CRinv r rnz) r) (CR_of_Q 1); - CRinv_0_lt_compat : forall (r : CRcarrier) (rnz : CRapart r (CR_of_Q 0)), - CRlt (CR_of_Q 0) r -> CRlt (CR_of_Q 0) (CRinv r rnz); - - (* 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" := (CR_of_Q _ 0) : ConstructiveReals. -Notation "1" := (CR_of_Q _ 1) : ConstructiveReals. -Notation "2" := (CR_of_Q _ 2) : ConstructiveReals. -Notation "3" := (CR_of_Q _ 3) : ConstructiveReals. -Notation "4" := (CR_of_Q _ 4) : ConstructiveReals. -Notation "5" := (CR_of_Q _ 5) : ConstructiveReals. -Notation "6" := (CR_of_Q _ 6) : ConstructiveReals. -Notation "7" := (CR_of_Q _ 7) : ConstructiveReals. -Notation "8" := (CR_of_Q _ 8) : ConstructiveReals. -Notation "9" := (CR_of_Q _ 9) : ConstructiveReals. -Notation "10" := (CR_of_Q _ 10) : 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. -Qed. - -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. -Qed. - -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. - -#[global] -Instance CReq_relT : forall {R : ConstructiveReals}, - CRelationClasses.Equivalence (CReq R). -Proof. - split. - - exact CReq_refl. - - exact CReq_sym. - - exact CReq_trans. -Qed. - -#[global] -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. - -#[global] -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. - -#[global] -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. - -#[global] -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. - -#[global] -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 (CR_of_Q R 0). - - 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 _ 0). - - 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 (CR_of_Q R 0). 1:apply Ropp_def. - transitivity (r2 + r1 + (-r1 + -r2)). - 1:transitivity (r2 + (r1 + (-r1 + -r2))). - 1:transitivity (r2 + - r2). - - apply CReq_sym. apply Ropp_def. - - apply Radd_ext. - + apply CReq_refl. - + transitivity (0 + - 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 (CR_of_Q R 0). 1:apply Ropp_def. - transitivity (r1 * (r2 + - r2)). - 2: apply CRmult_plus_distr_l. - transitivity (r1 * 0). - 1: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). - 1: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 _ 0). - 1:apply (Ropp_def (CRisRing R)). - apply (CRlt_le_trans _ (CRplus R (CRmult R r2 r) (CRmult R (CRopp R r1) r))). - 1: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))). - 1:apply (CRle_trans _ (CRplus R r2 0)). - * 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 ā‰¶ 0), - 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 1)). - + 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))) 1). - + 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 _ 0 _ c). - apply CRplus_opp_l. - + intro abs. apply H0. apply CRopp_lt_cancel. - apply (CRle_lt_trans _ (CRmult R r2 (CRopp R r))). - 1: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). - 1:apply (Radd_0_l (CRisRing R)). - apply (CRlt_le_trans _ 0 _ 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. - -#[global] -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_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 (CR_of_Q R 0). - - transitivity (CR_of_Q R (q-q)). - + apply CReq_sym, CR_of_Q_plus. - + apply CR_of_Q_morph. ring. - - 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 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. - 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. - { 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 Znat.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. - 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. - -#[global] -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/stdlib/theories/Reals/Abstract/ConstructiveRealsMorphisms.v b/stdlib/theories/Reals/Abstract/ConstructiveRealsMorphisms.v deleted file mode 100644 index 85aa2d482fe8..000000000000 --- a/stdlib/theories/Reals/Abstract/ConstructiveRealsMorphisms.v +++ /dev/null @@ -1,1217 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* 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. - - WARNING: this file is experimental and likely to change in future releases. -*) - -Require Import QArith. -Require Import Qabs. -Require Import Znat. -Require Import ConstructiveReals. -Require Import ConstructiveLimits. -Require Import ConstructiveAbs. - -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. reflexivity. - - apply CRmorph_rat. -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. reflexivity. - - apply CRmorph_rat. -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 0)). - - apply CRplus_0_r. - - apply CRplus_lt_compat_l. - apply (CRle_lt_trans _ (CR_of_Q R 0)). - + apply CRle_refl. - + apply CR_of_Q_lt. exact H. -Qed. - -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 0)). 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 CRle_refl. -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 0)). - -- 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 0)). - -- 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))). - 2: apply CRmorph_rat. - apply (CRplus_lt_reg_r (CR_of_Q R2 q)). - apply (CRlt_le_trans _ _ _ H). - 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 0)). 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)) 0)). - * 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 _ 0). - + apply (CReq_trans _ (CRmorph f 0)). - 2: apply CRmorph_zero. apply CRmorph_proper. - apply (CReq_trans _ (CRmult R1 x 0)). - 2: apply CRmult_0_r. apply Rmul_ext. * apply CReq_refl. * reflexivity. - + apply (CReq_trans _ (CRmult R2 (CRmorph f x) 0)). - * apply CReq_sym, CRmult_0_r. - * destruct (CRisRingExt R2). - apply Rmul_ext0. - -- apply CReq_refl. - -- reflexivity. - - destruct (CRisRingExt R1), (CRisRingExt R2). - transitivity (CRmorph f (CRplus R1 x (CRmult R1 x (CR_of_Q R1 (Z.of_nat n # 1))))). - + apply CRmorph_proper. - transitivity (CRmult R1 x (CRplus R1 1 (CR_of_Q R1 (Z.of_nat n # 1)))). - * apply Rmul_ext. - -- reflexivity. - -- transitivity (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. - ++ rewrite CR_of_Q_plus. reflexivity. - * transitivity (CRplus R1 (CRmult R1 x 1) - (CRmult R1 x (CR_of_Q R1 (Z.of_nat n # 1)))). - -- apply CRmult_plus_distr_l. - -- apply Radd_ext. - ++ apply CRmult_1_r. - ++ reflexivity. - + 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 1 (CR_of_Q R2 (Z.of_nat n # 1))))). - 1:apply (CReq_trans - _ (CRplus R2 (CRmult R2 (CRmorph f x) 1) - (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)))). - 1:apply (CReq_trans _ (CRplus R2 (CR_of_Q R2 1) (CR_of_Q R2 (Z.of_nat n # 1)))). - { apply Radd_ext0; reflexivity. } - { 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)). - 1:apply CRle_refl. apply CR_of_Q_lt. reflexivity. - - apply (CReq_trans _ (CRmorph f x)). - 1: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 1)). - { apply (Rmul_ext (CRisRingExt R1)). 1: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)). - 2:reflexivity. - apply CR_of_Q_morph. reflexivity. - } - 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) 1)). - { apply CReq_sym, CRmult_1_r. } - apply (Rmul_ext (CRisRingExt R2)). - * apply CReq_refl. - * apply (CReq_trans _ (CR_of_Q R2 1)). - -- reflexivity. - -- 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 0 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. - 2:field. - field_simplify. - - reflexivity. - - 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 0)). - 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 _ 0). - 1: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: apply CRle_refl. - 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)). - 1:apply CRle_refl. 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. - exact H. - 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))). - 1:apply (CRle_trans _ (CRplus R2 (CRmult R2 (CRmorph f x) (CRmorph f y)) - (CR_of_Q R2 (q-r)))). - 1: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))))). - 1:apply (CRle_lt_trans _ (CR_of_Q R2 0)). - - apply CRle_refl. - - 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)))). - 1:apply (CRle_trans _ (CR_of_Q R2 (-(Z.pos A # 1)))). - 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 1) (CRmorph f y))). - 1:apply (CRle_trans _ (CRopp R2 (CRmult R2 1 (CRmorph f y)))). - * destruct (Ropp_ext (CRisRingExt R2) (CRmorph f y) - (CRmult R2 1 (CRmorph f y))). - -- apply CReq_sym, (Rmul_1_l (CRisRing R2)). - -- exact H4. - * destruct (CRopp_mult_distr_l 1 (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 0)). - + apply CRmorph_zero. - + apply CRmorph_increasing. exact H. - - apply (CRle_trans _ (CR_of_Q R2 ((/ ((r - q) * (1 # A))) - * ((q - r) * (1 # A))))). - 1:apply (CRle_trans _ (CR_of_Q R2 (-1))). - 1:apply (CRle_trans _ (CRopp R2 (CR_of_Q R2 1))). - + destruct (Ropp_ext (CRisRingExt R2) 1 (CR_of_Q R2 1)). - * reflexivity. - * 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 0)). - ++ 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)))). - 1: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 0)). - * 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 0 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 0)). - + apply CRplus_0_r. - + apply CRplus_lt_compat_l. - apply (CRle_lt_trans _ (CR_of_Q R1 0)). - * apply CRle_refl. - * 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. - 2:{ apply (CRle_lt_trans _ (CRmorph f 0)). - - apply CRmorph_zero. - - apply CRmorph_increasing. exact H. } - 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))). - 1: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 0)). - + 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 CRle_refl. } - 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 1 (CRmorph f y))). - ++ apply CRmult_le_compat_r_half. - { apply (CRle_lt_trans _ (CRmorph f 0)). - { 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. - } - apply CRle_refl. - ++ destruct (Rmul_1_l (CRisRing R2) (CRmorph f y)). - intro H5. contradiction. - -- apply (CRlt_le_trans _ (CR_of_Q R2 (Z.pos A # 1))). - 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. -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 0)). - + apply CRmorph_increasing. exact c. - + exact (proj2 (CRmorph_zero f)). - - right. apply (CRle_lt_trans _ (CRmorph f 0)). - + 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 _ 1). - 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_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. - * 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 Nat.le_refl. - -- rewrite (Nat2Pos.id (S n0)). - ++ apply -> Nat.succ_le_mono; apply Nat.le_0_l. - ++ discriminate. - * destruct n0. - -- exfalso; inversion H1. - -- rewrite Nat2Pos.id, Nat2Pos.id. - ++ exact H1. - ++ discriminate. - ++ discriminate. - - specialize (nmaj n (Nat.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. diff --git a/stdlib/theories/Reals/Abstract/ConstructiveSum.v b/stdlib/theories/Reals/Abstract/ConstructiveSum.v deleted file mode 100644 index 55097468682a..000000000000 --- a/stdlib/theories/Reals/Abstract/ConstructiveSum.v +++ /dev/null @@ -1,699 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* CRcarrier R) (N:nat) : CRcarrier R := - match N with - | O => f 0%nat - | S i => CRsum f i + f (S i) - 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 (Nat.le_refl _)). - - intros. simpl. apply CRplus_morph. - + apply IHN. - intros. apply H. apply (Nat.le_trans _ N _ H0), le_S, Nat.le_refl. - + apply H, Nat.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 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 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 Nat.le_refl. - - intros. simpl. apply CRplus_le_compat. - + apply IHn. - intros. apply H. apply (Nat.le_trans _ n _ H0). apply le_S, Nat.le_refl. - + apply H. apply Nat.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. 2:assumption. - rewrite min_l. 2:assumption. - 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. - -- 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. - - destruct (Nat.le_exists_sub p n) as [k [maj _]]. - + unfold lt in l. - apply (Nat.le_trans p (S p)). - * apply le_S. apply Nat.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 (Nat.le_trans p (S p)). - ++ apply le_S. apply Nat.le_refl. - ++ assumption. - * apply (Nat.le_trans p (S p)). - -- apply le_S. apply Nat.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 Nat.add_comm. - destruct x. - - rewrite Nat.add_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, Nat.le_0_l. -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 -> Nat.succ_le_mono; apply Nat.le_0_l. -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. - -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 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 (Nat.le_trans _ i). { assumption. } apply Nat.le_max_l. - ** rewrite CRabs_opp. apply maj. - apply Nat.min_case. - { apply (Nat.le_trans _ i). - assumption. - apply Nat.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))), H. - apply CRabs_pos. - ** apply (Nat.le_trans _ i), Nat.le_max_l. apply Nat.le_min_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_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 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_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_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 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 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 Nat.add_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 Nat.add_comm. apply lim. apply (Nat.le_trans N i). - + assumption. - + rewrite <- (Nat.add_0_r i), <- Nat.add_assoc. - apply Nat.add_le_mono_l, Nat.le_0_l. - - apply CR_cv_plus. 2: apply CR_cv_const. intros eps. - specialize (H0 eps) as [N lim]. - exists N. intros. rewrite Nat.add_comm. apply lim. apply (Nat.le_trans N i). - + assumption. - + rewrite <- (Nat.add_0_r i), <- Nat.add_assoc. - apply Nat.add_le_mono_l, Nat.le_0_l. -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 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 (Nat.le_trans _ (S k + 0)). - + rewrite Nat.add_0_r. apply Nat.le_refl. - + apply (Nat.le_trans _ (S k + n)). - * apply Nat.add_le_mono_l, Nat.le_0_l. - * 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 Nat.add_0_r. reflexivity. - + apply H. - - apply (CR_cv_eq _ (fun n => CRsum un (n + S p) - CRsum un p)). - + intros. rewrite Nat.add_comm. unfold CRminus. - rewrite sum_assoc. simpl. rewrite CRplus_comm, <- CRplus_assoc. - rewrite CRplus_opp_l, CRplus_0_l. - apply CRsum_eq. intros. rewrite (Nat.add_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. - -- apply CR_of_Q_le. discriminate. - -- apply CRle_refl. -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_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_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_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/stdlib/theories/Reals/Alembert.v b/stdlib/theories/Reals/Alembert.v deleted file mode 100644 index f3319c057407..000000000000 --- a/stdlib/theories/Reals/Alembert.v +++ /dev/null @@ -1,633 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* R, - (forall n:nat, 0 < An n) -> - Un_cv (fun n:nat => Rabs (An (S n) / An n)) 0 -> - { l:R | Un_cv (fun N:nat => sum_f_R0 An N) l }. -Proof. - intros An H H0. - assert - (X:{ l:R | is_lub (EUn (fun N:nat => sum_f_R0 An N)) l } -> - { l:R | Un_cv (fun N:nat => sum_f_R0 An N) l }). { - intros (x,H1). - exists x; apply Un_cv_crit_lub; - [ unfold Un_growing; intro; rewrite tech5; - pattern (sum_f_R0 An n) at 1; rewrite <- Rplus_0_r; - apply Rplus_le_compat_l; left; apply H - | apply H1 ]. - } - apply X. - apply completeness. - 2:{ exists (sum_f_R0 An 0); unfold EUn; exists 0%nat; reflexivity. } - unfold Un_cv in H0; unfold bound; cut (0 < / 2); - [ intro | apply Rinv_0_lt_compat; prove_sup0 ]. - elim (H0 (/ 2) H1); intros. - exists (sum_f_R0 An x + 2 * An (S x)). - unfold is_upper_bound; intros; unfold EUn in H3; destruct H3 as (x1,->). - destruct (lt_eq_lt_dec x1 x) as [[| -> ]|]. - - replace (sum_f_R0 An x) with - (sum_f_R0 An x1 + sum_f_R0 (fun i:nat => An (S x1 + i)%nat) (x - S x1)). - 2:{ symmetry; apply tech2; assumption. } - pattern (sum_f_R0 An x1) at 1; rewrite <- Rplus_0_r; - rewrite Rplus_assoc; apply Rplus_le_compat_l. - left; apply Rplus_lt_0_compat. - + apply tech1; intros; apply H. - + apply Rmult_lt_0_compat; [ prove_sup0 | apply H ]. - - pattern (sum_f_R0 An x) at 1; rewrite <- Rplus_0_r; - apply Rplus_le_compat_l. - left; apply Rmult_lt_0_compat; [ prove_sup0 | apply H ]. - - replace (sum_f_R0 An x1) with - (sum_f_R0 An x + sum_f_R0 (fun i:nat => An (S x + i)%nat) (x1 - S x)). - 2:{ symmetry; apply tech2; assumption. } - apply Rplus_le_compat_l. - cut - (sum_f_R0 (fun i:nat => An (S x + i)%nat) (x1 - S x) <= - An (S x) * sum_f_R0 (fun i:nat => (/ 2) ^ i) (x1 - S x)). - { intro; - apply Rle_trans with - (An (S x) * sum_f_R0 (fun i:nat => (/ 2) ^ i) (x1 - S x)). - - assumption. - - rewrite <- (Rmult_comm (An (S x))); apply Rmult_le_compat_l. - + left; apply H. - + rewrite tech3. - * replace (1 - / 2) with (/ 2). - -- unfold Rdiv; rewrite Rinv_inv. - pattern 2 at 3; rewrite <- Rmult_1_r; rewrite <- (Rmult_comm 2); - apply Rmult_le_compat_l. - ++ left; prove_sup0. - ++ left; apply Rplus_lt_reg_l with ((/ 2) ^ S (x1 - S x)). - replace ((/ 2) ^ S (x1 - S x) + (1 - (/ 2) ^ S (x1 - S x))) with 1; - [ idtac | ring ]. - rewrite <- (Rplus_comm 1); pattern 1 at 1; rewrite <- Rplus_0_r; - apply Rplus_lt_compat_l. - apply pow_lt; apply Rinv_0_lt_compat; prove_sup0. - -- field. - * replace 1 with (/ 1); - [ apply tech7; discrR | apply Rinv_1 ]. - } - replace (An (S x)) with (An (S x + 0)%nat) by (f_equal; ring). - apply (tech6 (fun i:nat => An (S x + i)%nat) (/ 2)). - { left; apply Rinv_0_lt_compat; prove_sup0. } - intro; cut (forall n:nat, (n >= x)%nat -> An (S n) < / 2 * An n). - { intro H4; replace (S x + S i)%nat with (S (S x + i)) by auto with zarith. - apply H4; unfold ge; apply tech8. } - intros; unfold Rdist in H2; apply Rmult_lt_reg_l with (/ An n). - { apply Rinv_0_lt_compat; apply H. } - do 2 rewrite (Rmult_comm (/ An n)); rewrite Rmult_assoc; - rewrite Rinv_r. - 2:{ intro H5; assert (H8 := H n); rewrite H5 in H8; - elim (Rlt_irrefl _ H8). } - rewrite Rmult_1_r; - replace (An (S n) * / An n) with (Rabs (Rabs (An (S n) / An n) - 0)). - { apply H2; assumption. } - unfold Rminus; rewrite Ropp_0; rewrite Rplus_0_r; - rewrite Rabs_Rabsolu; rewrite Rabs_right. - { unfold Rdiv; reflexivity. } - left; unfold Rdiv; change (0 < An (S n) * / An n); - apply Rmult_lt_0_compat; [ apply H | apply Rinv_0_lt_compat; apply H ]. -Qed. - -Lemma Alembert_C2_aux_positivity : - forall Xn : nat -> R, - let Yn i := (2 * Rabs (Xn i) + Xn i) / 2 in - (forall n, Xn n <> 0) -> - forall n, 0 < Yn n. -Proof. - intros Xn Yn H n; unfold Yn; unfold Rdiv; rewrite <- (Rmult_0_r (/ 2)); - rewrite <- (Rmult_comm (/ 2)); apply Rmult_lt_compat_l. - - apply Rinv_0_lt_compat; prove_sup0. - - apply Rplus_lt_reg_l with (- Xn n); rewrite Rplus_0_r; unfold Rminus; - rewrite (Rplus_comm (- Xn n)); rewrite Rplus_assoc; - rewrite Rplus_opp_r; rewrite Rplus_0_r; - apply Rle_lt_trans with (Rabs (Xn n)). - + rewrite <- Rabs_Ropp; apply RRle_abs. - + rewrite <-Rplus_diag; pattern (Rabs (Xn n)) at 1; rewrite <- Rplus_0_r; - apply Rplus_lt_compat_l; apply Rabs_pos_lt; apply H. -Qed. - -Lemma Alembert_C2_aux_Un_cv : - forall Xn : nat -> R, - let Yn i := (2 * Rabs (Xn i) + Xn i) / 2 in - (forall n, Xn n <> 0) -> - Un_cv (fun n:nat => Rabs (Xn (S n) / Xn n)) 0 -> - Un_cv (fun n => Rabs (Yn (S n) / Yn n)) 0. -Proof. - intros An Vn H H0. - pose proof (Alembert_C2_aux_positivity An H); fold Vn in H1. - pose proof tt as H2. (* <- stupid name compat hack *) - cut (forall n:nat, / 2 * Rabs (An n) <= Vn n <= 3 * / 2 * Rabs (An n)). - 1:intro; cut (forall n:nat, / Vn n <= 2 * / Rabs (An n)). - 1:intro; cut (forall n:nat, Vn (S n) / Vn n <= 3 * Rabs (An (S n) / An n)). - + intro; unfold Un_cv; intros; unfold Un_cv in H1; assert (0 < eps / 3). - { unfold Rdiv; apply Rmult_lt_0_compat; - [ assumption | apply Rinv_0_lt_compat; prove_sup0 ]. } - elim (H0 (eps / 3) H7); intros. - exists x; intros. - assert (H10 := H8 n H9). - unfold Rdist; unfold Rminus; rewrite Ropp_0; - rewrite Rplus_0_r; rewrite Rabs_Rabsolu; unfold Rdist in H10; - unfold Rminus in H10; rewrite Ropp_0 in H10; rewrite Rplus_0_r in H10; - rewrite Rabs_Rabsolu in H10; rewrite Rabs_right. - 2:{ left; change (0 < Vn (S n) / Vn n); unfold Rdiv; - apply Rmult_lt_0_compat. - - apply H1. - - apply Rinv_0_lt_compat; apply H1. } - apply Rle_lt_trans with (3 * Rabs (An (S n) / An n)). - { apply H5. } - apply Rmult_lt_reg_l with (/ 3). - { apply Rinv_0_lt_compat; prove_sup0. } - rewrite <- Rmult_assoc; rewrite Rinv_l; [ idtac | discrR ]; - rewrite Rmult_1_l; rewrite <- (Rmult_comm eps); unfold Rdiv in H10; - exact H10. - + intro; unfold Rdiv; rewrite Rabs_mult; rewrite <- Rmult_assoc; - replace 3 with (2 * (3 * / 2)); - [ idtac | rewrite <- Rmult_assoc; apply Rmult_inv_r_id_m; discrR ]; - apply Rle_trans with (Vn (S n) * 2 * / Rabs (An n)). - { rewrite Rmult_assoc; apply Rmult_le_compat_l. - - left; apply H1. - - apply H4. } - rewrite Rabs_inv. - replace (Vn (S n) * 2 * / Rabs (An n)) with (2 * / Rabs (An n) * Vn (S n)) by ring; - replace (2 * (3 * / 2) * Rabs (An (S n)) * / Rabs (An n)) with - (2 * / Rabs (An n) * (3 * / 2 * Rabs (An (S n)))) by ring; - apply Rmult_le_compat_l. - { left; apply Rmult_lt_0_compat. - - prove_sup0. - - apply Rinv_0_lt_compat; apply Rabs_pos_lt; apply H. } - elim (H3 (S n)); intros; assumption. - + intro; apply Rmult_le_reg_l with (Vn n). - { apply H1. } - rewrite Rinv_r. - 2:{ red; intro; assert (H5 := H1 n); rewrite H4 in H5; - elim (Rlt_irrefl _ H5). } - apply Rmult_le_reg_l with (Rabs (An n)). - { apply Rabs_pos_lt; apply H. } - rewrite Rmult_1_r; - replace (Rabs (An n) * (Vn n * (2 * / Rabs (An n)))) with - (2 * Vn n * (Rabs (An n) * / Rabs (An n))); [ idtac | ring ]; - rewrite Rinv_r. - 2:{ apply Rabs_no_R0; apply H. } - rewrite Rmult_1_r; apply Rmult_le_reg_l with (/ 2). - { apply Rinv_0_lt_compat; prove_sup0. } - rewrite <- Rmult_assoc; rewrite Rinv_l. - * rewrite Rmult_1_l; elim (H3 n); intros; assumption. - * discrR. - + intro; split. - * unfold Vn; unfold Rdiv; rewrite <- (Rmult_comm (/ 2)); - apply Rmult_le_compat_l. - { left; apply Rinv_0_lt_compat; prove_sup0. } - pattern (Rabs (An n)) at 1; rewrite <- Rplus_0_r; rewrite <-Rplus_diag; - rewrite Rplus_assoc; apply Rplus_le_compat_l. - apply Rplus_le_reg_l with (- An n); rewrite Rplus_0_r; - rewrite <- (Rplus_comm (An n)); rewrite <- Rplus_assoc; - rewrite Rplus_opp_l; rewrite Rplus_0_l; rewrite <- Rabs_Ropp; - apply RRle_abs. - * unfold Vn; unfold Rdiv; repeat rewrite <- (Rmult_comm (/ 2)); - repeat rewrite Rmult_assoc; apply Rmult_le_compat_l. - { left; apply Rinv_0_lt_compat; prove_sup0. } - unfold Rminus; rewrite <-Rplus_diag; - replace (3 * Rabs (An n)) with (Rabs (An n) + Rabs (An n) + Rabs (An n)); - [ idtac | ring ]; repeat rewrite Rplus_assoc; repeat apply Rplus_le_compat_l; - apply RRle_abs. -Qed. - -Lemma Alembert_C2 : - forall An:nat -> R, - (forall n:nat, An n <> 0) -> - Un_cv (fun n:nat => Rabs (An (S n) / An n)) 0 -> - { l:R | Un_cv (fun N:nat => sum_f_R0 An N) l }. -Proof. - intros. - set (Vn := fun i:nat => (2 * Rabs (An i) + An i) / 2). - set (Wn := fun i:nat => (2 * Rabs (An i) - An i) / 2). - assert (forall n:nat, 0 < Vn n). { apply Alembert_C2_aux_positivity;assumption. } - assert (Wn_aux : Wn = fun i => (2 * Rabs (- An i) + (- An i)) / 2). { - apply FunctionalExtensionality.functional_extensionality. intros n. - unfold Wn,Rminus. do 3 f_equal. - symmetry;apply Rabs_Ropp. - } - assert (forall n:nat, 0 < Wn n). { - rewrite Wn_aux. apply Alembert_C2_aux_positivity. - intros;apply Ropp_neq_0_compat, H. - } - assert (Un_cv (fun n:nat => Rabs (Vn (S n) / Vn n)) 0). { apply Alembert_C2_aux_Un_cv;assumption. } - assert (Un_cv (fun n:nat => Rabs (Wn (S n) / Wn n)) 0). { - rewrite Wn_aux. apply (Alembert_C2_aux_Un_cv (fun n => - An n)). - - intros;apply Ropp_neq_0_compat, H. - - replace (fun n : nat => Rabs (- An (S n) / - An n)) with - (fun n : nat => Rabs (An (S n) / An n));[assumption|]. - apply FunctionalExtensionality.functional_extensionality. intros n. - f_equal. field;trivial. - } - pose proof (Alembert_C1 Vn H1 H3) as (x,p). - pose proof (Alembert_C1 Wn H2 H4) as (x0,p0). - exists (x - x0); unfold Un_cv; unfold Un_cv in p; - unfold Un_cv in p0; intros; assert (H6:0 < eps / 2). - { unfold Rdiv; apply Rmult_lt_0_compat; - [ assumption | apply Rinv_0_lt_compat; prove_sup0 ]. } - destruct (p (eps / 2) H6) as (x1,H8). clear p. - destruct (p0 (eps / 2) H6) as (x2,H9). clear p0. - set (N := max x1 x2). - exists N; intros; - replace (sum_f_R0 An n) with (sum_f_R0 Vn n - sum_f_R0 Wn n). - 2:{ symmetry ; apply tech11; intro; unfold Vn, Wn; - unfold Rdiv; do 2 rewrite <- (Rmult_comm (/ 2)); - apply Rmult_eq_reg_l with 2. - - rewrite Rmult_minus_distr_l; repeat rewrite <- Rmult_assoc; - rewrite Rinv_r. - + ring. - + discrR. - - discrR. } - unfold Rdist; - replace (sum_f_R0 Vn n - sum_f_R0 Wn n - (x - x0)) with - (sum_f_R0 Vn n - x + - (sum_f_R0 Wn n - x0)) by ring; - apply Rle_lt_trans with - (Rabs (sum_f_R0 Vn n - x) + Rabs (- (sum_f_R0 Wn n - x0))). - { apply Rabs_triang. } - rewrite Rabs_Ropp; apply Rlt_le_trans with (eps / 2 + eps / 2). - + apply Rplus_lt_compat. - * unfold Rdist in H8; apply H8; unfold ge; apply Nat.le_trans with N; - [ unfold N; apply Nat.le_max_l | assumption ]. - * unfold Rdist in H9; apply H9; unfold ge; apply Nat.le_trans with N; - [ unfold N; apply Nat.le_max_r | assumption ]. - + right; apply Rplus_half_diag. -Qed. - -Lemma AlembertC3_step1 : - forall (An:nat -> R) (x:R), - x <> 0 -> - (forall n:nat, An n <> 0) -> - Un_cv (fun n:nat => Rabs (An (S n) / An n)) 0 -> - { l:R | Pser An x l }. -Proof. - intros; set (Bn := fun i:nat => An i * x ^ i). - assert (forall n:nat, Bn n <> 0). { - intro; unfold Bn; apply prod_neq_R0; - [ apply H0 | apply pow_nonzero; assumption ]. - } - cut (Un_cv (fun n:nat => Rabs (Bn (S n) / Bn n)) 0). - { intro; destruct (Alembert_C2 Bn H2 H3) as (x0,H4). - exists x0; unfold Bn in H4; apply tech12; assumption. } - unfold Un_cv; intros; unfold Un_cv in H1; cut (0 < eps / Rabs x). - 2:{ unfold Rdiv; apply Rmult_lt_0_compat; - [ assumption | apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption ]. } - intro; elim (H1 (eps / Rabs x) H4); intros. - exists x0; intros; unfold Rdist; unfold Rminus; - rewrite Ropp_0; rewrite Rplus_0_r; rewrite Rabs_Rabsolu; - unfold Bn; - replace (An (S n) * x ^ S n / (An n * x ^ n)) with (An (S n) / An n * x). - 2:{ replace (S n) with (n + 1)%nat by ring; rewrite pow_add; - unfold Rdiv; rewrite Rinv_mult. - replace (An (n + 1)%nat * (x ^ n * x ^ 1) * (/ An n * / x ^ n)) with - (An (n + 1)%nat * x ^ 1 * / An n * (x ^ n * / x ^ n)) by ring; - rewrite Rinv_r. - - simpl; ring. - - apply pow_nonzero; assumption. } - rewrite Rabs_mult; apply Rmult_lt_reg_l with (/ Rabs x). - { apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption. } - rewrite <- (Rmult_comm (Rabs x)); rewrite <- Rmult_assoc; - rewrite Rinv_l. - 2:{ apply Rabs_no_R0; assumption. } - rewrite Rmult_1_l; rewrite <- (Rmult_comm eps); unfold Rdiv in H5; - replace (Rabs (An (S n) / An n)) with (Rdist (Rabs (An (S n) * / An n)) 0). - { apply H5; assumption. } - unfold Rdist; unfold Rminus; rewrite Ropp_0; - rewrite Rplus_0_r; rewrite Rabs_Rabsolu; unfold Rdiv; - reflexivity. -Qed. - -Lemma AlembertC3_step2 : - forall (An:nat -> R) (x:R), x = 0 -> { l:R | Pser An x l }. -Proof. - intros; exists (An 0%nat). - unfold Pser; unfold infinite_sum; intros; exists 0%nat; intros; - replace (sum_f_R0 (fun n0:nat => An n0 * x ^ n0) n) with (An 0%nat). - - unfold Rdist; unfold Rminus; rewrite Rplus_opp_r; - rewrite Rabs_R0; assumption. - - induction n as [| n Hrecn]. - + simpl; ring. - + rewrite tech5; rewrite Hrecn; - [ rewrite H; simpl; ring | unfold ge; apply Nat.le_0_l ]. -Qed. - -(** A useful criterion of convergence for power series *) -Theorem Alembert_C3 : - forall (An:nat -> R) (x:R), - (forall n:nat, An n <> 0) -> - Un_cv (fun n:nat => Rabs (An (S n) / An n)) 0 -> - { l:R | Pser An x l }. -Proof. - intros; destruct (total_order_T x 0) as [[Hlt|Heq]|Hgt]. - - cut (x <> 0). - + intro; apply AlembertC3_step1; assumption. - + red; intro; rewrite H1 in Hlt; elim (Rlt_irrefl _ Hlt). - - apply AlembertC3_step2; assumption. - - cut (x <> 0). - + intro; apply AlembertC3_step1; assumption. - + red; intro; rewrite H1 in Hgt; elim (Rlt_irrefl _ Hgt). -Qed. - -Lemma Alembert_C4 : - forall (An:nat -> R) (k:R), - 0 <= k < 1 -> - (forall n:nat, 0 < An n) -> - Un_cv (fun n:nat => Rabs (An (S n) / An n)) k -> - { l:R | Un_cv (fun N:nat => sum_f_R0 An N) l }. -Proof. - intros An k Hyp H H0. - assert - (X:{ l:R | is_lub (EUn (fun N:nat => sum_f_R0 An N)) l } -> - { l:R | Un_cv (fun N:nat => sum_f_R0 An N) l }). { - intros (x,H1). - exists x; apply Un_cv_crit_lub; - [ unfold Un_growing; intro; rewrite tech5; - pattern (sum_f_R0 An n) at 1; rewrite <- Rplus_0_r; - apply Rplus_le_compat_l; left; apply H - | apply H1]. - } - apply X. - apply completeness. - 2:{ exists (sum_f_R0 An 0); unfold EUn; exists 0%nat; reflexivity. } - assert (H1 := tech13 _ _ Hyp H0). - elim H1; intros. - elim H2; intros. - elim H4; intros. - unfold bound; exists (sum_f_R0 An x0 + / (1 - x) * An (S x0)). - unfold is_upper_bound; intros; unfold EUn in H6. - elim H6; intros. - rewrite H7. - destruct (lt_eq_lt_dec x2 x0) as [[| -> ]|]. - - replace (sum_f_R0 An x0) with - (sum_f_R0 An x2 + sum_f_R0 (fun i:nat => An (S x2 + i)%nat) (x0 - S x2)). - 2:{ symmetry ; apply tech2; assumption. } - pattern (sum_f_R0 An x2) at 1; rewrite <- Rplus_0_r. - rewrite Rplus_assoc; apply Rplus_le_compat_l. - left; apply Rplus_lt_0_compat. - + apply tech1. - intros; apply H. - + apply Rmult_lt_0_compat. - * apply Rinv_0_lt_compat; apply Rplus_lt_reg_l with x; rewrite Rplus_0_r; - replace (x + (1 - x)) with 1 by ring; elim H3; intros; assumption. - * apply H. - - pattern (sum_f_R0 An x0) at 1; rewrite <- Rplus_0_r; - apply Rplus_le_compat_l. - left; apply Rmult_lt_0_compat. - + apply Rinv_0_lt_compat; apply Rplus_lt_reg_l with x; rewrite Rplus_0_r; - replace (x + (1 - x)) with 1 by ring; elim H3; intros; assumption. - + apply H. - - replace (sum_f_R0 An x2) with - (sum_f_R0 An x0 + sum_f_R0 (fun i:nat => An (S x0 + i)%nat) (x2 - S x0)). - 2:{ symmetry ; apply tech2; assumption. } - apply Rplus_le_compat_l. - cut - (sum_f_R0 (fun i:nat => An (S x0 + i)%nat) (x2 - S x0) <= - An (S x0) * sum_f_R0 (fun i:nat => x ^ i) (x2 - S x0)). - { intro; - apply Rle_trans with (An (S x0) * sum_f_R0 (fun i:nat => x ^ i) (x2 - S x0)). - { assumption. } - rewrite <- (Rmult_comm (An (S x0))); apply Rmult_le_compat_l. - { left; apply H. } - rewrite tech3. - 2:{ lra. } - unfold Rdiv; apply Rmult_le_reg_l with (1 - x). - { lra. } - do 2 rewrite (Rmult_comm (1 - x)). - rewrite Rmult_assoc; rewrite Rinv_l. - 2:{ lra. } - rewrite Rmult_1_r; apply Rplus_le_reg_l with (x ^ S (x2 - S x0)). - replace (x ^ S (x2 - S x0) + (1 - x ^ S (x2 - S x0))) with 1 by ring. - rewrite <- (Rplus_comm 1); pattern 1 at 1; rewrite <- Rplus_0_r; - apply Rplus_le_compat_l. - left; apply pow_lt. - lra. - } - replace (An (S x0)) with (An (S x0 + 0)%nat) by (f_equal;ring). - apply (tech6 (fun i:nat => An (S x0 + i)%nat) x). - { lra. } - intro. - cut (forall n:nat, (n >= x0)%nat -> An (S n) < x * An n). - { intro H9. - replace (S x0 + S i)%nat with (S (S x0 + i)) by ring. - apply H9. - unfold ge. - apply tech8. } - intros. - apply Rmult_lt_reg_l with (/ An n). - { apply Rinv_0_lt_compat; apply H. } - do 2 rewrite (Rmult_comm (/ An n)). - rewrite Rmult_assoc. - rewrite Rinv_r. - 2:{ assert (H11 := H n). lra. } - rewrite Rmult_1_r. - replace (An (S n) * / An n) with (Rabs (An (S n) / An n)). - { apply H5; assumption. } - rewrite Rabs_right. - { unfold Rdiv; reflexivity. } - left; unfold Rdiv; change (0 < An (S n) * / An n); - apply Rmult_lt_0_compat. - + apply H. - + apply Rinv_0_lt_compat; apply H. -Qed. - -Lemma Alembert_C5 : - forall (An:nat -> R) (k:R), - 0 <= k < 1 -> - (forall n:nat, An n <> 0) -> - Un_cv (fun n:nat => Rabs (An (S n) / An n)) k -> - { l:R | Un_cv (fun N:nat => sum_f_R0 An N) l }. -Proof. - intros. - assert - (Hyp0:{ l:R | Un_cv (fun N:nat => sum_f_R0 An N) l } -> - { l:R | Un_cv (fun N:nat => sum_f_R0 An N) l }). - { intro X. - elim X; intros. - exists x. - assumption. } - apply Hyp0. - apply cv_cauchy_2. - apply cauchy_abs. - apply cv_cauchy_1. - assert - (Hyp:{ l:R | Un_cv (fun N:nat => sum_f_R0 (fun i:nat => Rabs (An i)) N) l } -> - { l:R | Un_cv (fun N:nat => sum_f_R0 (fun i:nat => Rabs (An i)) N) l }). - { intro X. - elim X; intros. - exists x. - assumption. } - apply Hyp. - apply (Alembert_C4 (fun i:nat => Rabs (An i)) k). - - assumption. - - intro; apply Rabs_pos_lt; apply H0. - - unfold Un_cv. - unfold Un_cv in H1. - unfold Rdiv. - intros. - elim (H1 eps H2); intros. - exists x; intros. - rewrite <- Rabs_inv. - rewrite <- Rabs_mult. - rewrite Rabs_Rabsolu. - unfold Rdiv in H3; apply H3; assumption. -Qed. - -(** Convergence of power series in D(O,1/k) - k=0 is described in Alembert_C3 *) -Lemma Alembert_C6 : - forall (An:nat -> R) (x k:R), - 0 < k -> - (forall n:nat, An n <> 0) -> - Un_cv (fun n:nat => Rabs (An (S n) / An n)) k -> - Rabs x < / k -> { l:R | Pser An x l }. -Proof. - intros. - cut { l:R | Un_cv (fun N:nat => sum_f_R0 (fun i:nat => An i * x ^ i) N) l }. - { intro X. - elim X; intros. - exists x0. - apply tech12; assumption. } - destruct (total_order_T x 0) as [[Hlt|Heq]|Hgt]. - - eapply Alembert_C5 with (k * Rabs x). - + split. - * unfold Rdiv; apply Rmult_le_pos. - { lra. } - left; apply Rabs_pos_lt. - lra. - * apply Rmult_lt_reg_l with (/ k). - { apply Rinv_0_lt_compat; assumption. } - rewrite <- Rmult_assoc. - rewrite Rinv_l. - 2:{ lra. } - rewrite Rmult_1_l. - rewrite Rmult_1_r; assumption. - + intro; apply prod_neq_R0. - { apply H0. } - apply pow_nonzero. - lra. - + unfold Un_cv; unfold Un_cv in H1. - intros. - assert (0 < eps / Rabs x). { - unfold Rdiv; apply Rmult_lt_0_compat. - - assumption. - - apply Rinv_0_lt_compat; apply Rabs_pos_lt. lra. - } - elim (H1 (eps / Rabs x) H4); intros. - exists x0. - intros. - replace (An (S n) * x ^ S n / (An n * x ^ n)) with (An (S n) / An n * x). - 2:{ unfold Rdiv; replace (S n) with (n + 1)%nat by ring. - rewrite pow_add. - simpl. - rewrite Rmult_1_r. - rewrite Rinv_mult. - replace (An (n + 1)%nat * (x ^ n * x) * (/ An n * / x ^ n)) with - (An (n + 1)%nat * / An n * x * (x ^ n * / x ^ n)) by ring. - rewrite Rinv_r. - { lra. } - apply pow_nonzero;lra. } - unfold Rdist. - rewrite Rabs_mult. - replace (Rabs (An (S n) / An n) * Rabs x - k * Rabs x) with - (Rabs x * (Rabs (An (S n) / An n) - k)) by ring. - rewrite Rabs_mult. - rewrite Rabs_Rabsolu. - apply Rmult_lt_reg_l with (/ Rabs x). - { apply Rinv_0_lt_compat; apply Rabs_pos_lt. lra. } - rewrite <- Rmult_assoc. - rewrite Rinv_l. - 2:{ apply Rabs_no_R0; lra. } - rewrite Rmult_1_l. - rewrite <- (Rmult_comm eps). - unfold Rdist in H5. - unfold Rdiv; unfold Rdiv in H5; apply H5; assumption. - - exists (An 0%nat). - unfold Un_cv. - intros. - exists 0%nat. - intros. - unfold Rdist. - replace (sum_f_R0 (fun i:nat => An i * x ^ i) n) with (An 0%nat). - { unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0; assumption. } - induction n as [| n Hrecn]. - + simpl; ring. - + rewrite tech5. - rewrite <- Hrecn,Heq;simpl. - * ring. - * unfold ge; apply Nat.le_0_l. - - eapply Alembert_C5 with (k * Rabs x). - + split. - * unfold Rdiv; apply Rmult_le_pos. - { left; assumption. } - left; apply Rabs_pos_lt. lra. - * apply Rmult_lt_reg_l with (/ k). - { apply Rinv_0_lt_compat; assumption. } - rewrite <- Rmult_assoc. - rewrite Rinv_l. - 2:{ lra. } - rewrite Rmult_1_l. - rewrite Rmult_1_r; assumption. - + intro; apply prod_neq_R0. - * apply H0. - * apply pow_nonzero. lra. - + unfold Un_cv; unfold Un_cv in H1. - intros. - assert (0 < eps / Rabs x). { - unfold Rdiv; apply Rmult_lt_0_compat. - - assumption. - - apply Rinv_0_lt_compat; apply Rabs_pos_lt. - lra. - } - elim (H1 (eps / Rabs x) H4); intros. - exists x0. - intros. - replace (An (S n) * x ^ S n / (An n * x ^ n)) with (An (S n) / An n * x). - 2:{ unfold Rdiv; replace (S n) with (n + 1)%nat by ring. - rewrite pow_add. - simpl. - rewrite Rmult_1_r. - rewrite Rinv_mult. - replace (An (n + 1)%nat * (x ^ n * x) * (/ An n * / x ^ n)) with - (An (n + 1)%nat * / An n * x * (x ^ n * / x ^ n)) by ring. - rewrite Rinv_r. - { lra. } - apply pow_nonzero;lra. } - unfold Rdist. - rewrite Rabs_mult. - replace (Rabs (An (S n) / An n) * Rabs x - k * Rabs x) with - (Rabs x * (Rabs (An (S n) / An n) - k)); [ idtac | ring ]. - rewrite Rabs_mult. - rewrite Rabs_Rabsolu. - apply Rmult_lt_reg_l with (/ Rabs x). - { apply Rinv_0_lt_compat; apply Rabs_pos_lt. - lra. } - rewrite <- Rmult_assoc. - rewrite Rinv_l. - 2:{ apply Rabs_no_R0. lra. } - rewrite Rmult_1_l. - rewrite <- (Rmult_comm eps). - unfold Rdist in H5. - unfold Rdiv; unfold Rdiv in H5; apply H5; assumption. -Qed. diff --git a/stdlib/theories/Reals/AltSeries.v b/stdlib/theories/Reals/AltSeries.v deleted file mode 100644 index 36379576028f..000000000000 --- a/stdlib/theories/Reals/AltSeries.v +++ /dev/null @@ -1,416 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* R) (i:nat) : R := (-1) ^ i * Un i. -Definition positivity_seq (Un:nat -> R) : Prop := forall n:nat, 0 <= Un n. - -Lemma CV_ALT_step0 : - forall Un:nat -> R, - Un_decreasing Un -> - Un_growing (fun N:nat => sum_f_R0 (tg_alt Un) (S (2 * N))). -Proof. - intros; unfold Un_growing; intro. - cut ((2 * S n)%nat = S (S (2 * n))). - - intro; rewrite H0. - do 4 rewrite tech5; repeat rewrite Rplus_assoc; apply Rplus_le_compat_l. - pattern (tg_alt Un (S (2 * n))) at 1; rewrite <- Rplus_0_r. - apply Rplus_le_compat_l. - unfold tg_alt; rewrite <- H0; rewrite pow_1_odd; rewrite pow_1_even; - rewrite Rmult_1_l. - apply Rplus_le_reg_l with (Un (S (2 * S n))). - rewrite Rplus_0_r; - replace (Un (S (2 * S n)) + (Un (2 * S n)%nat + -1 * Un (S (2 * S n)))) with - (Un (2 * S n)%nat); [ idtac | ring ]. - apply H. - - cut (forall n:nat, S n = (n + 1)%nat); [ intro | intro; ring ]. - rewrite (H0 n); rewrite (H0 (S (2 * n))); rewrite (H0 (2 * n)%nat); ring. -Qed. - -Lemma CV_ALT_step1 : - forall Un:nat -> R, - Un_decreasing Un -> - Un_decreasing (fun N:nat => sum_f_R0 (tg_alt Un) (2 * N)). -Proof. - intros; unfold Un_decreasing; intro. - cut ((2 * S n)%nat = S (S (2 * n))). - - intro; rewrite H0; do 2 rewrite tech5; repeat rewrite Rplus_assoc. - pattern (sum_f_R0 (tg_alt Un) (2 * n)) at 2; rewrite <- Rplus_0_r. - apply Rplus_le_compat_l. - unfold tg_alt; rewrite <- H0; rewrite pow_1_odd; rewrite pow_1_even; - rewrite Rmult_1_l. - apply Rplus_le_reg_l with (Un (S (2 * n))). - rewrite Rplus_0_r; - replace (Un (S (2 * n)) + (-1 * Un (S (2 * n)) + Un (2 * S n)%nat)) with - (Un (2 * S n)%nat); [ idtac | ring ]. - rewrite H0; apply H. - - cut (forall n:nat, S n = (n + 1)%nat); [ intro | intro; ring ]. - rewrite (H0 n); rewrite (H0 (S (2 * n))); rewrite (H0 (2 * n)%nat); ring. -Qed. - -(**********) -Lemma CV_ALT_step2 : - forall (Un:nat -> R) (N:nat), - Un_decreasing Un -> - positivity_seq Un -> - sum_f_R0 (fun i:nat => tg_alt Un (S i)) (S (2 * N)) <= 0. -Proof. - intros; induction N as [| N HrecN]. - - simpl; unfold tg_alt; simpl; rewrite Rmult_1_r. - replace (-1 * -1 * Un 2%nat) with (Un 2%nat); [ idtac | ring ]. - apply Rplus_le_reg_l with (Un 1%nat); rewrite Rplus_0_r. - replace (Un 1%nat + (-1 * Un 1%nat + Un 2%nat)) with (Un 2%nat); - [ apply H | ring ]. - - cut (S (2 * S N) = S (S (S (2 * N)))). - + intro; rewrite H1; do 2 rewrite tech5. - apply Rle_trans with (sum_f_R0 (fun i:nat => tg_alt Un (S i)) (S (2 * N))). - * pattern (sum_f_R0 (fun i:nat => tg_alt Un (S i)) (S (2 * N))) at 2; - rewrite <- Rplus_0_r. - rewrite Rplus_assoc; apply Rplus_le_compat_l. - unfold tg_alt; rewrite <- H1. - rewrite pow_1_odd. - cut (S (S (2 * S N)) = (2 * S (S N))%nat). - -- intro; rewrite H2; rewrite pow_1_even; rewrite Rmult_1_l; rewrite <- H2. - apply Rplus_le_reg_l with (Un (S (2 * S N))). - rewrite Rplus_0_r; - replace (Un (S (2 * S N)) + (-1 * Un (S (2 * S N)) + Un (S (S (2 * S N))))) - with (Un (S (S (2 * S N)))); [ idtac | ring ]. - apply H. - -- ring. - * apply HrecN. - + ring. -Qed. - -(** A more general inequality *) -Lemma CV_ALT_step3 : - forall (Un:nat -> R) (N:nat), - Un_decreasing Un -> - positivity_seq Un -> sum_f_R0 (fun i:nat => tg_alt Un (S i)) N <= 0. -Proof. - intros; induction N as [| N HrecN]. - - simpl; unfold tg_alt; simpl; rewrite Rmult_1_r. - apply Rplus_le_reg_l with (Un 1%nat). - rewrite Rplus_0_r; replace (Un 1%nat + -1 * Un 1%nat) with 0; - [ apply H0 | ring ]. - - assert (H1 := even_odd_cor N). - elim H1; intros. - elim H2; intro. - + rewrite H3; apply CV_ALT_step2; assumption. - + rewrite H3; rewrite tech5. - apply Rle_trans with (sum_f_R0 (fun i:nat => tg_alt Un (S i)) (S (2 * x))). - * pattern (sum_f_R0 (fun i:nat => tg_alt Un (S i)) (S (2 * x))) at 2; - rewrite <- Rplus_0_r. - apply Rplus_le_compat_l. - unfold tg_alt; simpl. - replace (x + (x + 0))%nat with (2 * x)%nat; [ idtac | ring ]. - rewrite pow_1_even. - replace (-1 * (-1 * (-1 * 1)) * Un (S (S (S (2 * x))))) with - (- Un (S (S (S (2 * x))))); [ idtac | ring ]. - apply Rplus_le_reg_l with (Un (S (S (S (2 * x))))). - rewrite Rplus_0_r; rewrite Rplus_opp_r. - apply H0. - * apply CV_ALT_step2; assumption. -Qed. - - (**********) -Lemma CV_ALT_step4 : - forall Un:nat -> R, - Un_decreasing Un -> - positivity_seq Un -> - has_ub (fun N:nat => sum_f_R0 (tg_alt Un) (S (2 * N))). -Proof. - intros; unfold has_ub; unfold bound. - exists (Un 0%nat). - unfold is_upper_bound; intros; elim H1; intros. - rewrite H2; rewrite decomp_sum. - - replace (tg_alt Un 0) with (Un 0%nat). - + pattern (Un 0%nat) at 2; rewrite <- Rplus_0_r. - apply Rplus_le_compat_l. - apply CV_ALT_step3; assumption. - + unfold tg_alt; simpl; ring. - - apply Nat.lt_0_succ. -Qed. - -(** This lemma gives an interesting result about alternated series *) -Lemma CV_ALT : - forall Un:nat -> R, - Un_decreasing Un -> - positivity_seq Un -> - Un_cv Un 0 -> - { l:R | Un_cv (fun N:nat => sum_f_R0 (tg_alt Un) N) l }. -Proof. - intros. - assert (H2 := CV_ALT_step0 _ H). - assert (H3 := CV_ALT_step4 _ H H0). - destruct (growing_cv _ H2 H3) as (x,p). - exists x. - unfold Un_cv; unfold Rdist; unfold Un_cv in H1; - unfold Rdist in H1; unfold Un_cv in p; unfold Rdist in p. - intros; cut (0 < eps / 2); - [ intro - | unfold Rdiv; apply Rmult_lt_0_compat; - [ assumption | apply Rinv_0_lt_compat; prove_sup0 ] ]. - elim (H1 (eps / 2) H5); intros N2 H6. - elim (p (eps / 2) H5); intros N1 H7. - set (N := max (S (2 * N1)) N2). - exists N; intros. - assert (H9 := even_odd_cor n). - elim H9; intros P H10. - assert (N1 <= P)%nat. { - elim H10; intro; apply le_double. - - rewrite <- H11; apply Nat.le_trans with N. - + unfold N; apply Nat.le_trans with (S (2 * N1)); - [ apply Nat.le_succ_diag_r | apply Nat.le_max_l ]. - + assumption. - - apply Nat.lt_succ_r. - rewrite <- H11. - apply Nat.lt_le_trans with N. - + unfold N; apply Nat.lt_le_trans with (S (2 * N1)). - * apply Nat.lt_succ_diag_r. - * apply Nat.le_max_l. - + assumption. - } - elim H10; intro. - - replace (sum_f_R0 (tg_alt Un) n - x) with - (sum_f_R0 (tg_alt Un) (S n) - x + - tg_alt Un (S n)). - + apply Rle_lt_trans with - (Rabs (sum_f_R0 (tg_alt Un) (S n) - x) + Rabs (- tg_alt Un (S n))). - * apply Rabs_triang. - * rewrite <-(Rplus_half_diag eps); apply Rplus_lt_compat. - -- rewrite H12; apply H7; assumption. - -- rewrite Rabs_Ropp; unfold tg_alt; rewrite Rabs_mult; - rewrite pow_1_abs; rewrite Rmult_1_l; unfold Rminus in H6; - rewrite Ropp_0 in H6; rewrite <- (Rplus_0_r (Un (S n))); - apply H6. - unfold ge; apply Nat.le_trans with n. - ++ apply Nat.le_trans with N; [ unfold N; apply Nat.le_max_r | assumption ]. - ++ apply Nat.le_succ_diag_r. - + rewrite tech5; ring. - - rewrite H12; apply Rlt_trans with (eps / 2). - + apply H7; assumption. - + unfold Rdiv; apply Rmult_lt_reg_l with 2. - * prove_sup0. - * rewrite (Rmult_comm 2); rewrite Rmult_assoc; rewrite Rinv_l; - [ rewrite Rmult_1_r | discrR ]. - rewrite <-Rplus_diag. - pattern eps at 1; rewrite <- (Rplus_0_r eps); apply Rplus_lt_compat_l; - assumption. - -Qed. - - -(*************************************************) -(** * Convergence of alternated series *) -Theorem alternated_series : - forall Un:nat -> R, - Un_decreasing Un -> - Un_cv Un 0 -> - { l:R | Un_cv (fun N:nat => sum_f_R0 (tg_alt Un) N) l }. -Proof. - intros; apply CV_ALT. - - assumption. - - unfold positivity_seq; apply decreasing_ineq; assumption. - - assumption. -Qed. - -Theorem alternated_series_ineq : - forall (Un:nat -> R) (l:R) (N:nat), - Un_decreasing Un -> - Un_cv Un 0 -> - Un_cv (fun N:nat => sum_f_R0 (tg_alt Un) N) l -> - sum_f_R0 (tg_alt Un) (S (2 * N)) <= l <= sum_f_R0 (tg_alt Un) (2 * N). -Proof. - intros. - assert (Un_cv (fun N:nat => sum_f_R0 (tg_alt Un) (2 * N)) l). { - unfold Un_cv; unfold Rdist; unfold Un_cv in H1; - unfold Rdist in H1; intros. - elim (H1 eps H2); intros. - exists x; intros. - apply H3. - apply Nat.le_trans with n; [ assumption | ]. - rewrite <- Nat.double_twice; apply Nat.le_add_r. - } - assert (Un_cv (fun N:nat => sum_f_R0 (tg_alt Un) (S (2 * N))) l). { - unfold Un_cv; unfold Rdist; unfold Un_cv in H1; - unfold Rdist in H1; intros. - elim (H1 eps H3); intros. - exists x; intros. - apply H4. - apply Nat.le_trans with n; [ assumption | ]. - apply Nat.le_le_succ_r. - rewrite <- Nat.double_twice; apply Nat.le_add_r. - } - intros; split. - - apply (growing_ineq (fun N:nat => sum_f_R0 (tg_alt Un) (S (2 * N)))). - + apply CV_ALT_step0; assumption. - + assumption. - - apply (decreasing_ineq (fun N:nat => sum_f_R0 (tg_alt Un) (2 * N))). - + apply CV_ALT_step1; assumption. - + assumption. -Qed. - -(***************************************) -(** * Application : construction of PI *) -(***************************************) - -Definition PI_tg (n:nat) := / INR (2 * n + 1). - -Lemma PI_tg_pos : forall n:nat, 0 <= PI_tg n. -Proof. - intro; unfold PI_tg; left; apply Rinv_0_lt_compat; apply lt_INR_0; - replace (2 * n + 1)%nat with (S (2 * n)); [ apply Nat.lt_0_succ | ring ]. -Qed. - -Lemma PI_tg_decreasing : Un_decreasing PI_tg. -Proof. - unfold PI_tg, Un_decreasing; intro. - apply Rmult_le_reg_l with (INR (2 * n + 1)). - - apply lt_INR_0. - replace (2 * n + 1)%nat with (S (2 * n)); [ apply Nat.lt_0_succ | ring ]. - - rewrite Rinv_r. - + apply Rmult_le_reg_l with (INR (2 * S n + 1)). - * apply lt_INR_0. - replace (2 * S n + 1)%nat with (S (2 * S n)); [ apply Nat.lt_0_succ | ring ]. - * rewrite (Rmult_comm (INR (2 * S n + 1))); rewrite Rmult_assoc; - rewrite Rinv_l. - -- do 2 rewrite Rmult_1_r; apply le_INR. - replace (2 * S n + 1)%nat with (S (S (2 * n + 1))). - ++ apply Nat.le_trans with (S (2 * n + 1)); apply Nat.le_succ_diag_r. - ++ ring. - -- apply not_O_INR; discriminate. - + apply not_O_INR; replace (2 * n + 1)%nat with (S (2 * n)); - [ discriminate | ring ]. -Qed. - -Lemma PI_tg_cv : Un_cv PI_tg 0. -Proof. - unfold Un_cv; unfold Rdist; intros. - assert (0 < 2 * eps) by lra. - assert (H1 := archimed (/ (2 * eps))). - assert (0 <= up (/ (2 * eps)))%Z. { - apply le_IZR. - left; apply Rlt_trans with (/ (2 * eps)). - - apply Rinv_0_lt_compat; assumption. - - elim H1; intros; assumption. - } - assert (H3 := IZN (up (/ (2 * eps))) H2). - elim H3; intros N H4. - assert (0 < N)%nat. { - elim H1; intros H5 _. - destruct (lt_eq_lt_dec 0 N) as [[| <- ]|H6]. - - assumption. - - rewrite H4 in H5. - simpl in H5. - cut (0 < / (2 * eps)); [ intro | apply Rinv_0_lt_compat; assumption ]. - elim (Rlt_irrefl _ (Rlt_trans _ _ _ H6 H5)). - - elim (Nat.nlt_0_r _ H6). - } - exists N; intros. - assert (0 < n)%nat by (apply Nat.lt_le_trans with N; assumption). - unfold Rminus; rewrite Ropp_0; rewrite Rplus_0_r; - rewrite Rabs_right. - 2:{ apply Rle_ge; apply PI_tg_pos. } - unfold PI_tg; apply Rlt_trans with (/ INR (2 * n)). - - apply Rmult_lt_reg_l with (INR (2 * n)). - { apply lt_INR_0. auto with zarith. } - rewrite Rinv_r. - 2:{ replace n with (S (pred n)). - - apply not_O_INR; discriminate. - - apply Nat.lt_succ_pred with 0%nat. - assumption. } - apply Rmult_lt_reg_l with (INR (2 * n + 1)). - { apply lt_INR_0. - replace (2 * n + 1)%nat with (S (2 * n)) by ring; apply Nat.lt_0_succ. } - rewrite (Rmult_comm (INR (2 * n + 1))). - rewrite Rmult_assoc; rewrite Rinv_l. - 2:{ apply not_O_INR; replace (2 * n + 1)%nat with (S (2 * n)); - [ discriminate | ring ]. } - do 2 rewrite Rmult_1_r; apply lt_INR. - replace (2 * n + 1)%nat with (S (2 * n)) by ring; apply Nat.lt_succ_diag_r. - - - apply Rle_lt_trans with (/ INR (2 * N)). - + apply Rinv_le_contravar. - * rewrite mult_INR; apply Rmult_lt_0_compat; - [ simpl; prove_sup0 | apply lt_INR_0; assumption ]. - * apply le_INR. - now apply Nat.mul_le_mono_nonneg_l; [ apply Nat.le_0_l | ]. - + rewrite mult_INR. - apply Rmult_lt_reg_l with (INR N / eps). - * apply Rdiv_lt_0_compat with (2 := H). - now apply (lt_INR 0). - * replace (_ */ _) with (/(2 * eps)). - -- replace (_ / _ * _) with (INR N). - ++ rewrite INR_IZR_INZ. - now rewrite <- H4. - ++ field. - now apply Rgt_not_eq. - -- simpl (INR 2); field; split. - ++ now apply Rgt_not_eq, (lt_INR 0). - ++ now apply Rgt_not_eq. - -Qed. - -Lemma exist_PI : - { l:R | Un_cv (fun N:nat => sum_f_R0 (tg_alt PI_tg) N) l }. -Proof. - apply alternated_series. - - apply PI_tg_decreasing. - - apply PI_tg_cv. -Qed. - -(** Now, PI is defined *) -Definition Alt_PI : R := 4 * (let (a,_) := exist_PI in a). - -(** We can get an approximation of PI with the following inequality *) -Lemma Alt_PI_ineq : - forall N:nat, - sum_f_R0 (tg_alt PI_tg) (S (2 * N)) <= Alt_PI / 4 <= - sum_f_R0 (tg_alt PI_tg) (2 * N). -Proof. - intro; apply alternated_series_ineq. - - apply PI_tg_decreasing. - - apply PI_tg_cv. - - unfold Alt_PI; case exist_PI; intro. - replace (4 * x / 4) with x. - + trivial. - + unfold Rdiv; rewrite (Rmult_comm 4); rewrite Rmult_assoc; - rewrite Rinv_r; [ rewrite Rmult_1_r; reflexivity | discrR ]. -Qed. - -Lemma Alt_PI_RGT_0 : 0 < Alt_PI. -Proof. - assert (H := Alt_PI_ineq 0). - apply Rmult_lt_reg_l with (/ 4). - - apply Rinv_0_lt_compat; prove_sup0. - - rewrite Rmult_0_r; rewrite Rmult_comm. - elim H; clear H; intros H _. - unfold Rdiv in H; - apply Rlt_le_trans with (sum_f_R0 (tg_alt PI_tg) (S (2 * 0))). - + simpl; unfold tg_alt; simpl; rewrite Rmult_1_l; - rewrite Rmult_1_r; apply Rplus_lt_reg_l with (PI_tg 1). - rewrite Rplus_0_r; - replace (PI_tg 1 + (PI_tg 0 + -1 * PI_tg 1)) with (PI_tg 0); - [ unfold PI_tg | ring ]. - simpl; apply Rinv_lt_contravar. - * rewrite Rmult_1_l; replace (2 + 1) with 3; [ prove_sup0 | ring ]. - * rewrite Rplus_comm; pattern 1 at 1; rewrite <- Rplus_0_r; - apply Rplus_lt_compat_l; prove_sup0. - + assumption. -Qed. diff --git a/stdlib/theories/Reals/ArithProp.v b/stdlib/theories/Reals/ArithProp.v deleted file mode 100644 index 30d1fdb0730d..000000000000 --- a/stdlib/theories/Reals/ArithProp.v +++ /dev/null @@ -1,157 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* (n - i)%nat <> 0%nat. -Proof. - intros n i Hlt. - apply Nat.neq_0_lt_0, Nat.lt_add_lt_sub_r; assumption. -Qed. - -Lemma le_minusni_n : forall n i:nat, (i <= n)%nat -> (n - i <= n)%nat. -Proof. - intros n i _. - induction i as [ | i IHi ]. - - rewrite Nat.sub_0_r; reflexivity. - - etransitivity; [ | apply IHi ]. - rewrite Nat.sub_succ_r. - apply Nat.le_pred_l. -Qed. - -Lemma lt_minus_O_lt : forall m n:nat, (m < n)%nat -> (0 < n - m)%nat. -Proof. - intros n i Hlt. - apply Nat.lt_add_lt_sub_r; assumption. -Qed. - -Lemma even_odd_cor : - forall n:nat, exists p : nat, n = (2 * p)%nat \/ n = S (2 * p). -Proof. - intros n; exists (Nat.div2 n). - case_eq (Nat.odd n); intros H; [right|left]. - - assert (Nat.b2n (Nat.odd n) = 1%nat) as Hb by now rewrite H. - rewrite Nat.div2_odd at 1; rewrite Hb, Nat.add_1_r; reflexivity. - - assert (Nat.b2n (Nat.odd n) = 0%nat) as Hb by now rewrite H. - rewrite Nat.div2_odd at 1; rewrite Hb, Nat.add_0_r; reflexivity. -Qed. - - (* 2m <= 2n => m<=n *) -Lemma le_double : forall m n:nat, (2 * m <= 2 * n)%nat -> (m <= n)%nat. -Proof. - intros; apply INR_le. - assert (H1 := le_INR _ _ H). - do 2 rewrite mult_INR in H1. - apply Rmult_le_reg_l with (INR 2). - - apply lt_0_INR. apply Nat.lt_0_2. - - assumption. -Qed. - -(** Here, we have the euclidian division *) -(** This lemma is used in the proof of sin_eq_0 : (sin x)=0<->x=kPI *) -Lemma euclidian_division : - forall x y:R, - y <> 0 -> - exists k : Z, (exists r : R, x = IZR k * y + r /\ 0 <= r < Rabs y). -Proof. - intros. - set - (k0 := - match Rcase_abs y with - | left _ => (1 - up (x / - y))%Z - | right _ => (up (x / y) - 1)%Z - end). - exists k0. - exists (x - IZR k0 * y). - split. - - ring. - - unfold k0; case (Rcase_abs y) as [Hlt|Hge]. - + assert (H0 := archimed (x / - y)); rewrite <- Z_R_minus; simpl; - unfold Rminus. - replace (- ((1 + - IZR (up (x / - y))) * y)) with - ((IZR (up (x / - y)) - 1) * y); [ idtac | ring ]. - split. - * apply Rmult_le_reg_l with (/ - y). - -- apply Rinv_0_lt_compat; apply Ropp_0_gt_lt_contravar; exact Hlt. - -- rewrite Rmult_0_r; rewrite (Rmult_comm (/ - y)); rewrite Rmult_plus_distr_r; - rewrite Rinv_opp. - rewrite Rmult_assoc; repeat rewrite Ropp_mult_distr_r_reverse; - rewrite Rinv_r; [ rewrite Rmult_1_r | assumption ]. - apply Rplus_le_reg_l with (IZR (up (x / - y)) - x / - y). - rewrite Rplus_0_r; unfold Rdiv; pattern (/ - y) at 4; - rewrite Rinv_opp. - replace - (IZR (up (x * / - y)) - x * - / y + - (- (x * / y) + - (IZR (up (x * / - y)) - 1))) with 1; - [ idtac | ring ]. - elim H0; intros _ H1; unfold Rdiv in H1; exact H1. - * rewrite (Rabs_left _ Hlt); apply Rmult_lt_reg_l with (/ - y). - -- apply Rinv_0_lt_compat; apply Ropp_0_gt_lt_contravar; exact Hlt. - -- rewrite Rinv_l. - ++ rewrite (Rmult_comm (/ - y)); rewrite Rmult_plus_distr_r; - rewrite Rinv_opp. - rewrite Rmult_assoc; repeat rewrite Ropp_mult_distr_r_reverse; - rewrite Rinv_r; [ rewrite Rmult_1_r | assumption ]; - apply Rplus_lt_reg_l with (IZR (up (x / - y)) - 1). - replace (IZR (up (x / - y)) - 1 + 1) with (IZR (up (x / - y))); - [ idtac | ring ]. - replace (IZR (up (x / - y)) - 1 + (- (x * / y) + - (IZR (up (x / - y)) - 1))) - with (- (x * / y)); [ idtac | ring ]. - rewrite <- Ropp_mult_distr_r_reverse; rewrite <- Rinv_opp; elim H0; - unfold Rdiv; intros H1 _; exact H1. - ++ apply Ropp_neq_0_compat; assumption. - + assert (H0 := archimed (x / y)); rewrite <- Z_R_minus; simpl; - cut (0 < y). - * intro; unfold Rminus; - replace (- ((IZR (up (x / y)) + -(1)) * y)) with ((1 - IZR (up (x / y))) * y); - [ idtac | ring ]. - split. - -- apply Rmult_le_reg_l with (/ y). - ++ apply Rinv_0_lt_compat; assumption. - ++ rewrite Rmult_0_r; rewrite (Rmult_comm (/ y)); rewrite Rmult_plus_distr_r; - rewrite Rmult_assoc; rewrite Rinv_r; - [ rewrite Rmult_1_r | assumption ]; - apply Rplus_le_reg_l with (IZR (up (x / y)) - x / y); - rewrite Rplus_0_r; unfold Rdiv; - replace - (IZR (up (x * / y)) - x * / y + (x * / y + (1 - IZR (up (x * / y))))) with - 1; [ idtac | ring ]; elim H0; intros _ H2; unfold Rdiv in H2; - exact H2. - -- rewrite (Rabs_right _ Hge); apply Rmult_lt_reg_l with (/ y). - ++ apply Rinv_0_lt_compat; assumption. - ++ rewrite (Rinv_l _ H); rewrite (Rmult_comm (/ y)); - rewrite Rmult_plus_distr_r; rewrite Rmult_assoc; rewrite Rinv_r; - [ rewrite Rmult_1_r | assumption ]; - apply Rplus_lt_reg_l with (IZR (up (x / y)) - 1); - replace (IZR (up (x / y)) - 1 + 1) with (IZR (up (x / y))); - [ idtac | ring ]; - replace (IZR (up (x / y)) - 1 + (x * / y + (1 - IZR (up (x / y))))) with - (x * / y); [ idtac | ring ]; elim H0; unfold Rdiv; - intros H2 _; exact H2. - * destruct (total_order_T 0 y) as [[Hlt|Heq]|Hgt]. - -- assumption. - -- elim H; symmetry ; exact Heq. - -- apply Rge_le in Hge; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ Hge Hgt)). -Qed. - -Lemma tech8 : forall n i:nat, (n <= S n + i)%nat. -Proof. - intros; induction i as [| i Hreci]. - - replace (S n + 0)%nat with (S n); [ apply Nat.le_succ_diag_r | ring ]. - - replace (S n + S i)%nat with (S (S n + i)). - + apply le_S; assumption. - + apply INR_eq; rewrite S_INR; do 2 rewrite plus_INR; do 2 rewrite S_INR; ring. -Qed. diff --git a/stdlib/theories/Reals/Binomial.v b/stdlib/theories/Reals/Binomial.v deleted file mode 100644 index 0d968410de2d..000000000000 --- a/stdlib/theories/Reals/Binomial.v +++ /dev/null @@ -1,192 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* C n i = C n (n - i). -Proof. - intros; unfold C; replace (n - (n - i))%nat with i. - - rewrite Rmult_comm. - reflexivity. - - symmetry; apply Nat.add_sub_eq_l, Nat.sub_add; assumption. -Qed. - -Lemma pascal_step2 : - forall n i:nat, - (i <= n)%nat -> C (S n) i = INR (S n) / INR (S n - i) * C n i. -Proof. - intros; unfold C; replace (S n - i)%nat with (S (n - i)). - - cut (forall n:nat, fact (S n) = (S n * fact n)%nat). - + intro; repeat rewrite H0. - unfold Rdiv; repeat rewrite mult_INR; repeat rewrite Rinv_mult. - ring. - + intro; reflexivity. - - symmetry; apply Nat.sub_succ_l; assumption. -Qed. - -Lemma pascal_step3 : - forall n i:nat, (i < n)%nat -> C n (S i) = INR (n - i) / INR (S i) * C n i. -Proof. - intros; unfold C. - cut (forall n:nat, fact (S n) = (S n * fact n)%nat). - - intro. - cut ((n - i)%nat = S (n - S i)). - + intro. - pattern (n - i)%nat at 2; rewrite H1. - repeat rewrite H0; unfold Rdiv; repeat rewrite mult_INR; - repeat rewrite Rinv_mult. - rewrite <- H1; rewrite (Rmult_comm (/ INR (n - i))); - repeat rewrite Rmult_assoc; rewrite (Rmult_comm (INR (n - i))); - repeat rewrite Rmult_assoc; rewrite Rinv_l. - * ring. - * apply not_O_INR; apply minus_neq_O; assumption. - + rewrite <- Nat.sub_succ_l. - * simpl; reflexivity. - * apply -> Nat.le_succ_l; assumption. - - intro; reflexivity. -Qed. - - (**********) -Lemma pascal : - forall n i:nat, (i < n)%nat -> C n i + C n (S i) = C (S n) (S i). -Proof. - intros. - rewrite pascal_step3; [ idtac | assumption ]. - replace (C n i + INR (n - i) / INR (S i) * C n i) with - (C n i * (1 + INR (n - i) / INR (S i))) by ring. - replace (1 + INR (n - i) / INR (S i)) with (INR (S n) / INR (S i)). - - rewrite pascal_step1. - + rewrite Rmult_comm; replace (S i) with (S n - (n - i))%nat. - * rewrite <- pascal_step2. - -- apply pascal_step1. - apply Nat.le_trans with n. - ++ apply le_minusni_n. - apply Nat.lt_le_incl; assumption. - ++ apply Nat.le_succ_diag_r. - -- apply le_minusni_n. - apply Nat.lt_le_incl; assumption. - * rewrite Nat.sub_succ_l. - -- cut ((n - (n - i))%nat = i). - ++ intro; rewrite H0; reflexivity. - ++ apply Nat.add_sub_eq_l, Nat.sub_add. - apply Nat.lt_le_incl; assumption. - -- apply le_minusni_n; apply Nat.lt_le_incl; assumption. - + apply Nat.lt_le_incl; assumption. - - unfold Rdiv. - repeat rewrite S_INR. - rewrite minus_INR. - + cut (INR i + 1 <> 0). - * intro. - apply Rmult_eq_reg_l with (INR i + 1); [ idtac | assumption ]. - rewrite Rmult_plus_distr_l. - rewrite Rmult_1_r. - do 2 rewrite (Rmult_comm (INR i + 1)). - repeat rewrite Rmult_assoc. - rewrite Rinv_l; [ idtac | assumption ]. - ring. - * rewrite <- S_INR. - apply not_O_INR; discriminate. - + apply Nat.lt_le_incl; assumption. -Qed. - - (*********************) - (*********************) -Lemma binomial : - forall (x y:R) (n:nat), - (x + y) ^ n = sum_f_R0 (fun i:nat => C n i * x ^ i * y ^ (n - i)) n. -Proof. - intros; induction n as [| n Hrecn]. - - unfold C; simpl; unfold Rdiv; - repeat rewrite Rmult_1_r; rewrite Rinv_1; ring. - - pattern (S n) at 1; replace (S n) with (n + 1)%nat; [ idtac | ring ]. - rewrite pow_add; rewrite Hrecn. - replace ((x + y) ^ 1) with (x + y); [ idtac | simpl; ring ]. - rewrite tech5. - cut (forall p:nat, C p p = 1). - 1:cut (forall p:nat, C p 0 = 1). - + intros; rewrite H0; rewrite Nat.sub_diag; rewrite Rmult_1_l. - replace (y ^ 0) with 1; [ rewrite Rmult_1_r | simpl; reflexivity ]. - induction n as [| n Hrecn0]. - * simpl; do 2 rewrite H; ring. - * (* N >= 1 *) - set (N := S n). - rewrite Rmult_plus_distr_l. - replace (sum_f_R0 (fun i:nat => C N i * x ^ i * y ^ (N - i)) N * x) with - (sum_f_R0 (fun i:nat => C N i * x ^ S i * y ^ (N - i)) N). - 1: replace (sum_f_R0 (fun i:nat => C N i * x ^ i * y ^ (N - i)) N * y) with - (sum_f_R0 (fun i:nat => C N i * x ^ i * y ^ (S N - i)) N). - -- rewrite (decomp_sum (fun i:nat => C (S N) i * x ^ i * y ^ (S N - i)) N). - ++ rewrite H; replace (x ^ 0) with 1; [ idtac | reflexivity ]. - do 2 rewrite Rmult_1_l. - replace (S N - 0)%nat with (S N); [ idtac | reflexivity ]. - set (An := fun i:nat => C N i * x ^ S i * y ^ (N - i)). - set (Bn := fun i:nat => C N (S i) * x ^ S i * y ^ (N - i)). - replace (pred N) with n. - 1:replace (sum_f_R0 (fun i:nat => C (S N) (S i) * x ^ S i * y ^ (S N - S i)) n) - with (sum_f_R0 (fun i:nat => An i + Bn i) n). - ** rewrite plus_sum. - replace (x ^ S N) with (An (S n)). - { rewrite (Rplus_comm (sum_f_R0 An n)). - repeat rewrite Rplus_assoc. - rewrite <- tech5. - fold N. - set (Cn := fun i:nat => C N i * x ^ i * y ^ (S N - i)). - cut (forall i:nat, (i < N)%nat -> Cn (S i) = Bn i). - - intro; replace (sum_f_R0 Bn n) with (sum_f_R0 (fun i:nat => Cn (S i)) n). - + replace (y ^ S N) with (Cn 0%nat). - * rewrite <- Rplus_assoc; rewrite (decomp_sum Cn N). - -- replace (pred N) with n. - ++ ring. - ++ unfold N; simpl; reflexivity. - -- unfold N; apply Nat.lt_0_succ. - * unfold Cn; rewrite H; simpl; ring. - + apply sum_eq. - intros; apply H1. - unfold N; apply Nat.le_lt_trans with n; [ assumption | apply Nat.lt_succ_diag_r ]. - - reflexivity. - } - unfold An; fold N; rewrite Nat.sub_diag; rewrite H0; - simpl; ring. - ** apply sum_eq. - intros; unfold An, Bn. - change (S N - S i)%nat with (N - i)%nat. - rewrite <- pascal; - [ ring - | apply Nat.le_lt_trans with n; [ assumption | unfold N; apply Nat.lt_succ_diag_r ] ]. - ** unfold N; reflexivity. - ++ unfold N; apply Nat.lt_0_succ. - -- rewrite <- (Rmult_comm y); rewrite scal_sum; apply sum_eq. - intros; replace (S N - i)%nat with (S (N - i)). - ++ replace (S (N - i)) with (N - i + 1)%nat; [ idtac | ring ]. - rewrite pow_add; replace (y ^ 1) with y; [ idtac | simpl; ring ]; - ring. - ++ symmetry; apply Nat.sub_succ_l; assumption. - -- rewrite <- (Rmult_comm x); rewrite scal_sum; apply sum_eq. - intros; replace (S i) with (i + 1)%nat; [ idtac | ring ]; rewrite pow_add; - replace (x ^ 1) with x; [ idtac | simpl; ring ]; - ring. - + intro; unfold C. - replace (INR (fact 0)) with 1; [ idtac | reflexivity ]. - replace (p - 0)%nat with p; [ idtac | symmetry; apply Nat.sub_0_r ]. - rewrite Rmult_1_l; unfold Rdiv; rewrite Rinv_r; - [ reflexivity | apply INR_fact_neq_0 ]. - + intro; unfold C. - replace (p - p)%nat with 0%nat; [ idtac | symmetry; apply Nat.sub_diag ]. - replace (INR (fact 0)) with 1; [ idtac | reflexivity ]. - rewrite Rmult_1_r; unfold Rdiv; rewrite Rinv_r; - [ reflexivity | apply INR_fact_neq_0 ]. -Qed. diff --git a/stdlib/theories/Reals/Cauchy/ConstructiveCauchyAbs.v b/stdlib/theories/Reals/Cauchy/ConstructiveCauchyAbs.v deleted file mode 100644 index 2ab36eadd729..000000000000 --- a/stdlib/theories/Reals/Cauchy/ConstructiveCauchyAbs.v +++ /dev/null @@ -1,983 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* ring_simplify a end. - -Local Ltac simplify_Qlt := - match goal with |- (?l < ?r)%Q => ring_simplify l; ring_simplify r end. - -Local Lemma Qopp_mult_mone : forall q : Q, - (-1 * q == -q)%Q. -Proof. - intros; ring. -Qed. - -Local Lemma Qabs_involutive: forall q : Q, - (Qabs (Qabs q) == Qabs q)%Q. -Proof. - intros q; apply Qabs_case; intros Hcase. - - reflexivity. - - pose proof Qabs_nonneg q as Habspos. - pose proof Qle_antisym _ _ Hcase Habspos as Heq0. - setoid_rewrite Heq0. - reflexivity. -Qed. - -(** - 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. - - WARNING: this file is experimental and likely to change in future releases. -*) - - -(* 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 -*) - -Definition CReal_abs_seq (x : CReal) (n : Z) := Qabs (seq x n). - -Definition CReal_abs_scale (x : CReal) := scale x. - -Lemma CReal_abs_cauchy: forall (x : CReal), - QCauchySeq (CReal_abs_seq x). -Proof. - intros x n p q Hp Hq. - pose proof (cauchy x n p q Hp Hq) as Hxbnd. - apply (Qle_lt_trans _ (Qabs (seq x p - seq x q))). - 2: exact Hxbnd. apply Qabs_Qle_condition. split. - 2: apply Qabs_triangle_reverse. - apply (Qplus_le_r _ _ (Qabs (seq x q))). - rewrite <- Qabs_opp. - apply (Qle_trans _ _ _ (Qabs_triangle_reverse _ _)). - ring_simplify. - unfold CReal_abs_seq. - simplify_Qabs; setoid_rewrite Qopp_mult_mone. - do 2 rewrite Qabs_opp. - lra. -Qed. - -Lemma CReal_abs_bound : forall (x : CReal), - QBound (CReal_abs_seq x) (CReal_abs_scale x). -Proof. - intros x n. - unfold CReal_abs_seq, CReal_abs_scale. - rewrite Qabs_involutive. - apply (bound x). -Qed. - -Definition CReal_abs (x : CReal) : CReal := -{| - seq := CReal_abs_seq x; - scale := CReal_abs_scale x; - cauchy := CReal_abs_cauchy x; - bound := CReal_abs_bound x -|}. - -Lemma CRealLt_RQ_from_single_dist : forall (r : CReal) (q : Q) (n :Z), - (2^n < q - seq r n)%Q - -> r < inject_Q q. -Proof. - intros r q n Hapart. - pose proof Qpower_0_lt 2 n ltac:(lra) as H2npos. - destruct (QarchimedeanLowExp2_Z (q - seq r n - 2^n) ltac:(lra)) as [k Hk]. - unfold CRealLt; exists (Z.min n (k-1))%Z. - unfold inject_Q; rewrite CReal_red_seq. - pose proof cauchy r n n (Z.min n (k-1))%Z ltac:(lia) ltac:(lia) as Hrbnd. - pose proof Qpower_le_compat_l 2 (Z.min n (k - 1))%Z (k-1)%Z ltac:(lia) ltac:(lra). - apply (Qmult_le_l _ _ 2 ltac:(lra)) in H. - apply (Qle_lt_trans _ _ _ H); clear H. - rewrite Qpower_minus_pos. - simplify_Qlt. - apply Qabs_Qlt_condition in Hrbnd. - lra. -Qed. - -Lemma CRealLe_0R_to_single_dist : forall (x : CReal) (n : Z), - 0 <= x -> (-(2^n) <= seq x n)%Q. -Proof. - intros x n Hxnonneg. - destruct (Qlt_le_dec (seq x n) (-(2^n))) as [Hdec|Hdec]. - - exfalso; apply Hxnonneg. - apply (CRealLt_RQ_from_single_dist x 0 n); lra. - - exact Hdec. -Qed. - -Lemma CReal_abs_right : forall x : CReal, 0 <= x -> CReal_abs x == x. -Proof. - intros x Hxnonneg; apply CRealEq_diff; intro n. - unfold CReal_abs, CReal_abs_seq, CReal_abs_scale; - rewrite CReal_red_seq. - pose proof CRealLe_0R_to_single_dist x n Hxnonneg. - pose proof Qpower_0_lt 2 n ltac:(lra) as Hpowpos. - do 2 apply Qabs_case; intros H1 H2; lra. -Qed. - -Lemma CReal_le_abs : forall x : CReal, x <= CReal_abs x. -Proof. - intros x [n nmaj]. - unfold CReal_abs, CReal_abs_seq, CReal_abs_scale in nmaj; - rewrite CReal_red_seq in nmaj. - apply (Qle_not_lt _ _ (Qle_Qabs (seq x n))). - apply Qlt_minus_iff. apply (Qlt_trans _ (2*2^n)). - - pose proof Qpower_0_lt 2 n ltac:(lra); lra. - - exact nmaj. -Qed. - -Lemma CReal_abs_pos : forall x : CReal, 0 <= CReal_abs x. -Proof. - intros x [n nmaj]. - unfold CReal_abs, CReal_abs_seq, CReal_abs_scale in nmaj; - rewrite CReal_red_seq in nmaj. - apply (Qle_not_lt _ _ (Qabs_nonneg (seq x n))). - apply Qlt_minus_iff. apply (Qlt_trans _ (2*2^n)). - - pose proof Qpower_0_lt 2 n ltac:(lra); lra. - - exact nmaj. -Qed. - -Lemma CReal_abs_opp : forall x : CReal, CReal_abs (-x) == CReal_abs x. -Proof. - intros x; apply CRealEq_diff; intro n. - unfold CReal_abs, CReal_abs_seq, CReal_abs_scale; - unfold CReal_opp, CReal_opp_seq, CReal_opp_scale; - do 3 rewrite CReal_red_seq. - rewrite Qabs_opp. simplify_Qabs. - rewrite Qabs_pos by lra. - pose proof Qpower_0_lt 2 n; lra. -Qed. - -Lemma CReal_abs_left : forall x : CReal, x <= 0 -> CReal_abs x == -x. -Proof. - intros x Hxnonpos. - apply CReal_opp_ge_le_contravar in Hxnonpos. rewrite CReal_opp_0 in Hxnonpos. - rewrite <- CReal_abs_opp. apply CReal_abs_right, Hxnonpos. -Qed. - -Lemma CReal_abs_appart_0 : forall x : CReal, - 0 < CReal_abs x -> x # 0. -Proof. - intros x [n nmaj]. - unfold CReal_abs, CReal_abs_seq, CReal_abs_scale in nmaj; - rewrite CReal_red_seq in nmaj. - destruct (Qlt_le_dec (seq x n) 0) as [Hdec|Hdec]. - - left. exists n. cbn in nmaj |- * . - rewrite Qabs_neg in nmaj; lra. - - right. exists n. cbn. rewrite Qabs_pos in nmaj. - + exact nmaj. - + exact Hdec. -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]. - unfold CReal_abs, CReal_abs_seq, CReal_abs_scale in nmaj; - rewrite CReal_red_seq in nmaj. - destruct (Qlt_le_dec (seq a n) 0) as [Hdec|Hdec]. - - rewrite Qabs_neg in nmaj by lra. destruct H as [Hl Hr]. apply Hl. clear Hl Hr. - exists n; cbn. - unfold CReal_opp_seq; lra. - - rewrite Qabs_pos in nmaj. - + destruct H as [Hl Hr]. apply Hr. clear Hl Hr. - exists n; cbn. exact nmaj. - + exact Hdec. -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]. - unfold CReal_abs, CReal_abs_seq, CReal_abs_scale in nmaj; - rewrite CReal_red_seq in nmaj. - assert (seq x n < 0)%Q. - { destruct (Qlt_le_dec (seq x n) 0) as [Hdec|Hdec]. - - exact Hdec. - - exfalso. rewrite Qabs_pos in nmaj by apply Hdec. - pose proof Qpower_0_lt 2 n; lra. } - rewrite Qabs_neg in nmaj by apply Qlt_le_weak, H. - apply (CRealLt_RQ_from_single_dist _ _ n); lra. -Qed. - -Lemma Rabs_def1 : forall x y : CReal, - x < y -> -x < y -> CReal_abs x < y. -Proof. - intros x y Hxlty Hmxlty. - - apply CRealLt_above in Hxlty. apply CRealLt_above in Hmxlty. - destruct Hxlty as [i imaj]. destruct Hmxlty as [j jmaj]. - specialize (imaj (Z.min i j) ltac:(lia)). - specialize (jmaj (Z.min i j) ltac:(lia)). - cbn in jmaj; unfold CReal_opp_seq in jmaj. - - exists (Z.min i j). - unfold CReal_abs, CReal_abs_seq, CReal_abs_scale; - rewrite CReal_red_seq. - - pose proof Qpower_0_lt 2 (Z.min i j)%Z ltac:(lra) as Hpowij. - pose proof Qpower_le_compat_l 2 (Z.min i j)%Z i ltac:(lia) ltac:(lra) as Hpowlei. - pose proof Qpower_le_compat_l 2 (Z.min i j)%Z j ltac:(lia) ltac:(lra) as Hpowlej. - apply Qabs_case; intros Hcase; lra. -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/stdlib/theories/Reals/Cauchy/ConstructiveCauchyReals.v b/stdlib/theories/Reals/Cauchy/ConstructiveCauchyReals.v deleted file mode 100644 index 65c2a478cae3..000000000000 --- a/stdlib/theories/Reals/Cauchy/ConstructiveCauchyReals.v +++ /dev/null @@ -1,1001 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* un O) (fun q => O) - which says nothing about the limit of un. - - We define sequences as Z -> Q instead of nat -> Q, - so that we can compute arguments like 2^n fast. - - Todo: doc for Z->Q - - WARNING: this module is not meant to be imported directly, - please import `Reals.Abstract.ConstructiveReals` instead. - - WARNING: this file is experimental and likely to change in future releases. - *) - -Definition QCauchySeq (xn : Z -> Q) - : Prop - := forall (k : Z) (p q : Z), - Z.le p k - -> Z.le q k - -> Qabs (xn p - xn q) < 2 ^ k. - -Definition QBound (xn : Z -> Q) (scale : Z) - : Prop - := forall (k : Z), - Qabs (xn k) < 2 ^ scale. - -(* A Cauchy real is a sequence with a proof that the sequence is Cauchy *) -Record CReal := mkCReal { - seq : Z -> Q; - scale : Z; - cauchy : QCauchySeq seq; - bound : QBound seq scale -}. - -Declare Scope CReal_scope. - -(* Declare Scope R_scope with Key R *) -Delimit Scope CReal_scope with CReal. - -(* Automatically open scope R_scope for arguments of type R *) -Bind Scope CReal_scope with CReal. - -Local Open Scope CReal_scope. - -Definition CRealLt (x y : CReal) : Set - := { n : Z | Qlt (2 * 2 ^ n) (seq y n - seq x n) }. - -Definition CRealLtProp (x y : CReal) : Prop - := exists n : Z, Qlt (2 * 2 ^ n)(seq y n - seq x n). - -Definition CRealGt (x y : CReal) := CRealLt y x. -Definition CReal_appart (x y : CReal) := sum (CRealLt x y) (CRealLt y x). - -Infix "<" := CRealLt : CReal_scope. -Infix ">" := CRealGt : CReal_scope. -Infix "#" := CReal_appart : CReal_scope. - -(* This Prop can be extracted as a sigma type *) -Lemma CRealLtEpsilon : forall x y : CReal, - CRealLtProp x y -> x < y. -Proof. - intros x y H. unfold CRealLtProp in H. - apply constructive_indefinite_ground_description_Z in H. - - apply H. - - intros n. - pose proof Qlt_le_dec (2 * 2 ^ n) (seq y n - seq x n) as Hdec. - destruct Hdec as [H1|H1]. - + left; exact H1. - + right; apply Qle_not_lt in H1; exact H1. -Qed. - -Lemma CRealLtForget : forall x y : CReal, - x < y -> CRealLtProp x y. -Proof. - intros. destruct H. exists x0. exact q. -Qed. - -(* CRealLt is decided by the LPO in Type, - which is a non-constructive oracle. *) -Lemma CRealLt_lpo_dec : forall x y : CReal, - (forall (P : nat -> Prop), (forall n:nat, {P n} + {~P n}) - -> {n | ~P n} + {forall n, P n}) - -> CRealLt x y + (CRealLt x y -> False). -Proof. - intros x y lpo. - destruct (lpo (fun n:nat => - seq y (Z_inj_nat_rev n) - seq x (Z_inj_nat_rev n) <= 2 * 2 ^ (Z_inj_nat_rev n) - )). - - intro n. destruct (Qlt_le_dec (2 * 2 ^ (Z_inj_nat_rev n)) - (seq y (Z_inj_nat_rev n) - seq x (Z_inj_nat_rev n))). - + right; lra. - + left; lra. - - left; destruct s as [n nmaj]; exists (Z_inj_nat_rev n); lra. - - right; intro abs; destruct abs as [n majn]. - specialize (q (Z_inj_nat n)). - rewrite Z_inj_nat_id in q. - pose proof (Qle_not_lt _ _ q). contradiction. -Qed. - -(* Alias the large order *) -Definition CRealLe (x y : CReal) : Prop - := CRealLt y x -> False. - -Definition CRealGe (x y : CReal) := CRealLe y x. - -Infix "<=" := CRealLe : CReal_scope. -Infix ">=" := CRealGe : CReal_scope. - -Notation "x <= y <= z" := (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. -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 : Z, (seq x n - seq y n <= 2 * 2 ^ n)%Q) - <-> x <= y. -Proof. - intros. split. - - intros H H0. - destruct H0 as [n H0]; specialize (H n); lra. - - intros H n. - destruct (Qlt_le_dec (2 * 2 ^ n) (seq x n - seq y n)). - + exfalso. apply H. exists n. assumption. - + assumption. -Qed. - -Lemma CRealEq_diff : forall (x y : CReal), - CRealEq x y - <-> forall n:Z, ((Qabs (seq x n - seq y n)) <= (2 * 2 ^ n))%Q. -Proof. - intros x y; split. - - intros H n; destruct H as [Hyx Hxy]. - pose proof (CRealLe_not_lt x y) as [_ Hxy']. specialize (Hxy' Hxy n). - pose proof (CRealLe_not_lt y x) as [_ Hyx']. specialize (Hyx' Hyx n). - apply Qabs_Qle_condition; lra. - - intros H; split; - apply CRealLe_not_lt; intro n; specialize (H n); - apply Qabs_Qle_condition in H; lra. -Qed. - -(** If the elements x(n) and y(n) of two Cauchy sequences x and are apart by - at least 2*eps(n), we can find a k such that all further elements of - the sequences are apart by at least 2*eps(k) *) - -Lemma CRealLt_aboveSig : forall (x y : CReal) (n : Z), - (2 * 2^n < seq y n - seq x n)%Q - -> let (k, _) := QarchimedeanExp2_Z (/(seq y n - seq x n - (2 * 2 ^ n)%Q)) - in forall p:Z, - (p <= n)%Z - -> (2^(-k) < seq y p - seq x p)%Q. -Proof. - intros x y n maj. - destruct (QarchimedeanExp2_Z (/((seq y) n - (seq x) n - (2*2^n)%Q))) as [k kmaj]. - intros p Hp. - apply Qinv_lt_contravar in kmaj. - 3: apply Qpower_0_lt; lra. - 2: apply Qinv_lt_0_compat; lra. - rewrite Qinv_involutive, <- Qpower_opp in kmaj; clear maj. - pose proof ((cauchy x) n n p ltac:(lia) ltac:(lia)) as HCSx. - pose proof ((cauchy y) n p n ltac:(lia) ltac:(lia)) as HCSy. - rewrite Qabs_Qlt_condition in HCSx, HCSy. - lra. -Qed. - -(** This is a weakened form of CRealLt_aboveSig which a special shape of eps needed below *) - -Lemma CRealLt_aboveSig' : forall (x y : CReal) (n : Z), - (2 * 2^n < seq y n - seq x n)%Q - -> let (k, _) := QarchimedeanExp2_Z (/(seq y n - seq x n - (2 * 2 ^ n)%Q)) - in forall p:Z, - (p <= n)%Z - -> (2 * 2^(Z.min (-k-1) n) < seq y p - seq x p)%Q. -Proof. - intros x y n Hapart. - pose proof CRealLt_aboveSig x y n Hapart. - destruct (QarchimedeanExp2_Z (/ (seq y n - seq x n - (2 * 2 ^ n)))) - as [k kmaj]. - intros p Hp; specialize (H p Hp). - pose proof Qpower_le_compat_l 2 (Z.min (- k -1) n) (- k-1) (Z.le_min_l _ _) ltac:(lra) as H1. - rewrite Qpower_minus_pos in H1. - apply (Qmult_le_compat_r _ _ 2) in H1. - 2: lra. - ring_simplify in H1. - exact (Qle_lt_trans _ _ _ H1 H). -Qed. - -Lemma CRealLt_above : forall (x y : CReal), - CRealLt x y - -> { n : Z | forall p : Z, - (p <= n)%Z -> (2 * 2 ^ n < seq y p - seq x p)%Q }. -Proof. - intros x y [n maj]. - pose proof (CRealLt_aboveSig' x y n maj) as H. - destruct (QarchimedeanExp2_Z (/ (seq y n - seq x n - (2 * 2 ^ n)))) - as [k kmaj]. - exists (Z.min (-k - 1) n)%Z; intros p Hp. - apply H. - lia. -Qed. - -(* The CRealLt index separates the Cauchy sequences *) -Lemma CRealLt_above_same : forall (x y : CReal) (n : Z), - (2 * 2 ^ n < seq y n - seq x n)%Q - -> forall p:Z, (p <= n)%Z -> Qlt (seq x p) (seq y p). -Proof. - intros x y n inf p H. - simpl in inf |- *. - pose proof ((cauchy x) n p n ltac:(lia) ltac:(lia)). - pose proof ((cauchy y) n p n ltac:(lia) ltac:(lia)). - rewrite Qabs_Qlt_condition in *. - lra. -Qed. - -Lemma CRealLt_asym : forall x y : CReal, x < y -> x <= y. -Proof. - intros x y H [n q]. - apply CRealLt_above in H. destruct H as [p H]. - pose proof (CRealLt_above_same y x n q). - apply (Qlt_not_le (seq y (Z.min n p)) - (seq x (Z.min n p))). - - apply H0. apply Z.le_min_l. - - apply Qlt_le_weak. apply (Qplus_lt_l _ _ (-seq x (Z.min n p))). - rewrite Qplus_opp_r. apply (Qlt_trans _ (2*2^p)). - + pose proof Qpower_0_lt 2 p ltac:(lra). lra. - + apply H. lia. - (* ToDo: use lra *) -Qed. - -Lemma CRealLt_irrefl : forall x:CReal, x < x -> False. -Proof. - intros x abs. exact (CRealLt_asym x x abs abs). -Qed. - -Lemma CRealLe_refl : forall x : CReal, x <= x. -Proof. - intros. intro abs. - pose proof (CRealLt_asym x x abs). contradiction. -Qed. - -Lemma CRealEq_refl : forall x : CReal, x == x. -Proof. - intros. split; apply CRealLe_refl. -Qed. - -Lemma CRealEq_sym : forall x y : CReal, CRealEq x y -> CRealEq y x. -Proof. - intros. destruct H. split; intro abs; contradiction. -Qed. - -Lemma CRealLt_dec : forall x y z : CReal, - x < y -> sum (x < z) (z < y). -Proof. - intros x y z [n inf]. - destruct (QarchimedeanExp2_Z (/((seq y) n - (seq x) n - (2 * 2 ^ n)))) as [k kmaj]. - rewrite Qinv_lt_contravar, Qinv_involutive, <- Qpower_opp in kmaj. - 3: apply Qpower_0_lt; lra. - 2: apply Qinv_lt_0_compat; lra. - - destruct (Qlt_le_dec ((1#2) * ((seq y) n + (seq x) n)) ((seq z) (Z.min n (- k - 2)))) - as [Hxyltz|Hzlexy]; [left; pose (cauchy x) as HCS|right; pose (cauchy y) as HCS]. - - all: exists (Z.min (n)%Z (-k - 2))%Z. - all: specialize (HCS n n (Z.min n (-k-2))%Z ltac:(lia) ltac:(lia)). - all: rewrite Qabs_Qlt_condition in HCS. - all: assert (2 ^ Z.min n (- k - 2) <= 2 ^ (- k - 2))%Q as Hpowmin - by (apply Qpower_le_compat_l; [lia|lra]). - all: rewrite Qpower_minus_pos in Hpowmin; lra. -Qed. - -Definition linear_order_T x y z := CRealLt_dec x z y. - -Lemma CReal_le_lt_trans : forall x y z : CReal, - x <= y -> y < z -> x < z. -Proof. - intros x y z Hle Hlt. - destruct (linear_order_T y x z Hlt) as [Hyltx|Hxltz]. - - contradiction. - - exact Hxltz. -Qed. - -Lemma CReal_lt_le_trans : forall x y z : CReal, - x < y -> y <= z -> x < z. -Proof. - intros x y z Hlt Hle. - destruct (linear_order_T x z y Hlt) as [Hxltz|Hzlty]. - - exact Hxltz. - - contradiction. -Qed. - -Lemma CReal_le_trans : forall x y z : CReal, - x <= y -> y <= z -> x <= z. -Proof. - intros x y z Hxley Hylez contra. - apply Hylez. - apply (CReal_lt_le_trans _ x); assumption. -Qed. - -Lemma CReal_lt_trans : forall x y z : CReal, - x < y -> y < z -> x < z. -Proof. - intros x y z Hxlty Hyltz. - apply (CReal_lt_le_trans _ y _ Hxlty). - apply CRealLt_asym; exact Hyltz. -Qed. - -Lemma CRealEq_trans : forall x y z : CReal, - CRealEq x y -> CRealEq y z -> CRealEq x z. -Proof. - intros x y z Hxeqy Hyeqz. - destruct Hxeqy as [Hylex Hxley]. - destruct Hyeqz as [Hzley Hylez]. - split. - - intro contra. destruct (CRealLt_dec _ _ y contra); contradiction. - - intro contra. destruct (CRealLt_dec _ _ y contra); contradiction. -Qed. - -Add Parametric Relation : CReal CRealEq - reflexivity proved by CRealEq_refl - symmetry proved by CRealEq_sym - transitivity proved by CRealEq_trans - as CRealEq_rel. - -#[global] -Instance CRealEq_relT : CRelationClasses.Equivalence CRealEq. -Proof. - split. - - exact CRealEq_refl. - - exact CRealEq_sym. - - exact CRealEq_trans. -Qed. - -#[global] -Instance CRealLt_morph - : CMorphisms.Proper - (CMorphisms.respectful CRealEq (CMorphisms.respectful CRealEq CRelationClasses.iffT)) CRealLt. -Proof. - intros x y Hxeqy x0 y0 Hx0eqy0. - destruct Hxeqy as [Hylex Hxley]. - destruct Hx0eqy0 as [Hy0lex0 Hx0ley0]. - split. - - intro Hxltx0; destruct (CRealLt_dec x x0 y). - + assumption. - + contradiction. - + destruct (CRealLt_dec y x0 y0). - * assumption. - * assumption. - * contradiction. - - intro Hylty0; destruct (CRealLt_dec y y0 x). - + assumption. - + contradiction. - + destruct (CRealLt_dec x y0 x0). - * assumption. - * assumption. - * contradiction. -Qed. - -#[global] -Instance CRealGt_morph - : CMorphisms.Proper - (CMorphisms.respectful CRealEq (CMorphisms.respectful CRealEq CRelationClasses.iffT)) CRealGt. -Proof. - intros x y Hxeqy x0 y0 Hx0eqy0. apply CRealLt_morph; assumption. -Qed. - -#[global] -Instance CReal_appart_morph - : CMorphisms.Proper - (CMorphisms.respectful CRealEq (CMorphisms.respectful CRealEq CRelationClasses.iffT)) CReal_appart. -Proof. - intros x y Hxeqy x0 y0 Hx0eqy0. - split. - - intros Hapart. destruct Hapart as [Hxltx0|Hx0ltx]. - + left. rewrite <- Hx0eqy0, <- Hxeqy. exact Hxltx0. - + right. rewrite <- Hx0eqy0, <- Hxeqy. exact Hx0ltx. - - intros Hapart. destruct Hapart as [Hylty0|Hy0lty]. - + left. rewrite Hx0eqy0, Hxeqy. exact Hylty0. - + right. rewrite Hx0eqy0, Hxeqy. exact Hy0lty. -Qed. - -Add Parametric Morphism : CRealLtProp - with signature CRealEq ==> CRealEq ==> iff - as CRealLtProp_morph. -Proof. - intros x y Hxeqy x0 y0 Hx0eqy0. - split. - - intro Hxltpx0. apply CRealLtForget. apply CRealLtEpsilon in Hxltpx0. - rewrite <- Hxeqy, <- Hx0eqy0. exact Hxltpx0. - - intro Hylty0. apply CRealLtForget. apply CRealLtEpsilon in Hylty0. - rewrite Hxeqy, Hx0eqy0. exact Hylty0. -Qed. - -Add Parametric Morphism : CRealLe - with signature CRealEq ==> CRealEq ==> iff - as CRealLe_morph. -Proof. - intros x y Hxeqy x0 y0 Hx0eqy0. - split. - - intros Hxlex0 Hyley0. unfold CRealLe in Hxlex0. - rewrite <- Hx0eqy0 in Hyley0. rewrite <- Hxeqy in Hyley0. contradiction. - - intros Hxlex0 Hyley0. unfold CRealLe in Hxlex0. - rewrite Hx0eqy0 in Hyley0. rewrite Hxeqy in Hyley0. contradiction. -Qed. - -Add Parametric Morphism : CRealGe - with signature CRealEq ==> CRealEq ==> iff - as CRealGe_morph. -Proof. - intros x y Hxeqy x0 y0 Hx0eqy0. - unfold CRealGe. apply CRealLe_morph; assumption. -Qed. - -Lemma CRealLt_proper_l : forall x y z : CReal, - CRealEq x y - -> CRealLt x z -> CRealLt y z. -Proof. - intros x y z Hxeqy Hxltz. - apply (CRealLt_morph x y Hxeqy z z). - - apply CRealEq_refl. - - apply Hxltz. -Qed. - -Lemma CRealLt_proper_r : forall x y z : CReal, - CRealEq x y - -> CRealLt z x -> CRealLt z y. -Proof. - intros x y z Hxeqy Hzltx. - apply (CRealLt_morph z z (CRealEq_refl z) x y). - - apply Hxeqy. - - apply Hzltx. -Qed. - -Lemma CRealLe_proper_l : forall x y z : CReal, - CRealEq x y - -> CRealLe x z -> CRealLe y z. -Proof. - intros x y z Hxeqy Hxlez. - apply (CRealLe_morph x y Hxeqy z z). - - apply CRealEq_refl. - - apply Hxlez. -Qed. - -Lemma CRealLe_proper_r : forall x y z : CReal, - CRealEq x y - -> CRealLe z x -> CRealLe z y. -Proof. - intros x y z Hxeqy Hzlex. - apply (CRealLe_morph z z (CRealEq_refl z) x y). - - apply Hxeqy. - - apply Hzlex. -Qed. - - - -(* Injection of Q into CReal *) - -Lemma inject_Q_cauchy : forall q : Q, QCauchySeq (fun _ => q). -Proof. - intros q k p r Hp Hr. - apply Qabs_Qlt_condition. - pose proof Qpower_0_lt 2 k; lra. -Qed. - -Definition inject_Q (q : Q) : CReal := -{| - seq := (fun n : Z => q); - scale := Qbound_ltabs_ZExp2 q; - cauchy := inject_Q_cauchy q; - bound := (fun _ : Z => Qbound_ltabs_ZExp2_spec q) -|}. - -Definition inject_Z : Z -> CReal - := fun n => inject_Q (n # 1). - -Notation "0" := (inject_Q 0) : CReal_scope. -Notation "1" := (inject_Q 1) : CReal_scope. -Notation "2" := (inject_Q 2) : CReal_scope. - -Lemma CRealLt_0_1 : CRealLt (inject_Q 0) (inject_Q 1). -Proof. - exists (-2)%Z; cbn; lra. -Qed. - -Lemma CReal_injectQPos : forall q : Q, - (0 < q)%Q -> CRealLt (inject_Q 0) (inject_Q q). -Proof. - intros q Hq. destruct (QarchimedeanExp2_Z ((2#1) / q)) as [k Hk]. - exists (-k)%Z; cbn. - apply (Qmult_lt_compat_r _ _ q) in Hk. - 2: assumption. - apply (Qmult_lt_compat_r _ _ (2^(-k))) in Hk. - 2: apply Qpower_0_lt; lra. - field_simplify in Hk. - 2: lra. - (* ToDo: field_simplify should collect powers - the next 3 lines ... *) - rewrite <- Qmult_assoc, <- Qpower_plus in Hk by lra. - ring_simplify (-k +k)%Z in Hk. - rewrite Qpower_0_r in Hk. - lra. -Qed. - -Lemma inject_Q_compare : forall (x : CReal) (p : Z), - x <= inject_Q (seq x p + (2^p)). -Proof. - intros x p [n nmaj]. - cbn in nmaj. - assert(2^n>0)%Q by (apply Qpower_0_lt; lra). - assert(2^p>0)%Q by (apply Qpower_0_lt; lra). - pose proof x.(cauchy) as xcau. - destruct (Z.min_dec p n); - [ specialize (xcau n n p ltac:(lia) ltac:(lia)) | - specialize (xcau p n p ltac:(lia) ltac:(lia)) ]. - all: apply Qabs_Qlt_condition in xcau; lra. -Qed. - -Add Parametric Morphism : inject_Q - with signature Qeq ==> CRealEq - as inject_Q_morph. -Proof. - intros x y Heq; split. - all: intros [n Hapart]; cbn in Hapart; rewrite Heq in Hapart. - all: assert(2^n>0)%Q by (apply Qpower_0_lt; lra); lra. -Qed. - -#[global] -Instance inject_Q_morph_T - : CMorphisms.Proper - (CMorphisms.respectful Qeq CRealEq) inject_Q. -Proof. - intros x y Heq; split. - all: intros [n Hapart]; cbn in Hapart; rewrite Heq in Hapart. - all: assert(2^n>0)%Q by (apply Qpower_0_lt; lra); lra. -Qed. - - - -(** * Algebraic operations *) - -(** We reduce the rational numbers to accelerate calculations. *) -Definition CReal_plus_seq (x y : CReal) := - (fun n : Z => Qred (seq x (n-1)%Z + seq y (n-1)%Z)). - -Definition CReal_plus_scale (x y : CReal) : Z := - Z.max x.(scale) y.(scale) + 1. - -Lemma CReal_plus_cauchy : forall (x y : CReal), - QCauchySeq (CReal_plus_seq x y). -Proof. - intros x y n p q Hp Hq. - unfold CReal_plus_seq. - pose proof ((cauchy x) (n-1)%Z (p-1)%Z (q-1)%Z ltac:(lia) ltac:(lia)) as Hxbnd. - pose proof ((cauchy y) (n-1)%Z (p-1)%Z (q-1)%Z ltac:(lia) ltac:(lia)) as Hybnd. - do 2 rewrite Qred_correct. - rewrite Qabs_Qlt_condition in Hxbnd, Hybnd |- *. - rewrite Qpower_minus_pos in Hxbnd, Hybnd. - lra. -Qed. - -Lemma CReal_plus_bound : forall (x y : CReal), - QBound (CReal_plus_seq x y) (CReal_plus_scale x y). -Proof. - intros x y k. - unfold CReal_plus_seq, CReal_plus_scale. - pose proof (bound x (k-1)%Z) as Hxbnd. - pose proof (bound y (k-1)%Z) as Hybnd. - rewrite Qpower_plus by lra. - pose proof Qpower_le_compat_l 2 (scale x) (Z.max (scale x) (scale y)) ltac:(lia) ltac:(lra) as Hxmax. - pose proof Qpower_le_compat_l 2 (scale y) (Z.max (scale x) (scale y)) ltac:(lia) ltac:(lra) as Hymax. - rewrite Qabs_Qlt_condition in Hxbnd, Hybnd |- *. - rewrite Qred_correct. - lra. -Qed. - -Definition CReal_plus (x y : CReal) : CReal := -{| - seq := CReal_plus_seq x y; - scale := CReal_plus_scale x y; - cauchy := CReal_plus_cauchy x y; - bound := CReal_plus_bound x y -|}. - -Infix "+" := CReal_plus : CReal_scope. - -Definition CReal_opp_seq (x : CReal) := - (fun n : Z => - seq x n). - -Definition CReal_opp_scale (x : CReal) : Z := - x.(scale). - -Lemma CReal_opp_cauchy : forall (x : CReal), - QCauchySeq (CReal_opp_seq x). -Proof. - intros x n p q Hp Hq; unfold CReal_opp_seq. - pose proof ((cauchy x) n p q ltac:(lia) ltac:(lia)) as Hxbnd. - rewrite Qabs_Qlt_condition in Hxbnd |- *. - lra. -Qed. - -Lemma CReal_opp_bound : forall (x : CReal), - QBound (CReal_opp_seq x) (CReal_opp_scale x). -Proof. - intros x k. - unfold CReal_opp_seq, CReal_opp_scale. - pose proof (bound x k) as Hxbnd. - rewrite Qabs_Qlt_condition in Hxbnd |- *. - lra. -Qed. - -Definition CReal_opp (x : CReal) : CReal := -{| - seq := CReal_opp_seq x; - scale := CReal_opp_scale x; - cauchy := CReal_opp_cauchy x; - bound := CReal_opp_bound x -|}. - -Notation "- x" := (CReal_opp x) : CReal_scope. - -Definition CReal_minus (x y : CReal) : CReal - := CReal_plus x (CReal_opp y). - -Infix "-" := CReal_minus : CReal_scope. - -(* ToDo: make a tactic for this *) -Lemma CReal_red_seq: forall (a : Z -> Q) (b : Z) (c : QCauchySeq a) (d : QBound a b), - seq (mkCReal a b c d) = a. -Proof. - reflexivity. -Qed. - -Lemma CReal_plus_assoc : forall (x y z : CReal), - (x + y) + z == x + (y + z). -Proof. - intros x y z; apply CRealEq_diff; intro n. - unfold CReal_plus, CReal_plus_seq. do 4 rewrite CReal_red_seq. - do 4 rewrite Qred_correct. - ring_simplify (n-1-1)%Z. - pose proof ((cauchy x) (n-1)%Z (n-2)%Z (n-1)%Z ltac:(lia) ltac:(lia)) as Hxbnd. - specialize ((cauchy z) (n-1)%Z (n-2)%Z (n-1)%Z ltac:(lia) ltac:(lia)) as Hzbnd. - apply Qlt_le_weak. - rewrite Qabs_Qlt_condition in Hxbnd, Hzbnd |- *. - rewrite Qpower_minus_pos in Hxbnd, Hzbnd. - lra. -Qed. - -Lemma CReal_plus_comm : forall x y : CReal, - x + y == y + x. -Proof. - intros x y; apply CRealEq_diff; intros n. - unfold CReal_plus, CReal_plus_seq. do 2 rewrite CReal_red_seq. - do 2 rewrite Qred_correct. - pose proof ((cauchy x) (n-1)%Z (n-1)%Z (n-1)%Z ltac:(lia) ltac:(lia)) as Hxbnd. - pose proof ((cauchy y) (n-1)%Z (n-1)%Z (n-1)%Z ltac:(lia) ltac:(lia)) as Hybnd. - apply Qlt_le_weak. - rewrite Qabs_Qlt_condition in Hxbnd, Hybnd |- *. - rewrite Qpower_minus_pos in Hxbnd, Hybnd. - lra. -Qed. - -Lemma CReal_plus_0_l : forall r : CReal, - inject_Q 0 + r == r. -Proof. - intros x; apply CRealEq_diff; intros n. - unfold CReal_plus, CReal_plus_seq, inject_Q. do 2 rewrite CReal_red_seq. - rewrite Qred_correct. - pose proof ((cauchy x) (n)%Z (n-1)%Z (n)%Z ltac:(lia) ltac:(lia)) as Hxbnd. - apply Qlt_le_weak. - rewrite Qabs_Qlt_condition in Hxbnd |- *. - lra. -Qed. - -Lemma CReal_plus_0_r : forall r : CReal, - r + 0 == r. -Proof. - intro r. rewrite CReal_plus_comm. apply CReal_plus_0_l. -Qed. - -Lemma CReal_plus_lt_compat_l : - forall x y z : CReal, y < z -> x + y < x + z. -Proof. - intros x y z Hlt. - apply CRealLt_above in Hlt; destruct Hlt as [n Hapart]; exists n. - unfold CReal_plus, CReal_plus_seq in Hapart |- *. do 2 rewrite CReal_red_seq. - do 2 rewrite Qred_correct. - specialize (Hapart (n-1)%Z ltac:(lia)). - lra. -Qed. - -Lemma CReal_plus_lt_compat_r : - forall x y z : CReal, y < z -> y + x < z + x. -Proof. - intros x y z. - do 2 rewrite <- (CReal_plus_comm x). - apply CReal_plus_lt_compat_l. -Qed. - -Lemma CReal_plus_lt_reg_l : - forall x y z : CReal, x + y < x + z -> y < z. -Proof. - intros x y z Hlt. - destruct Hlt as [n maj]; exists (n - 1)%Z. - setoid_replace (seq z (n - 1)%Z - seq y (n - 1)%Z)%Q - with (seq (CReal_plus x z) n - seq (CReal_plus x y) n)%Q. - - rewrite Qpower_minus_pos. - assert (2 ^ n > 0)%Q by (apply Qpower_0_lt; lra); lra. - - unfold CReal_plus, CReal_plus_seq in maj |- *. - do 2 rewrite CReal_red_seq in maj |- *. - do 2 rewrite Qred_correct; ring. -Qed. - -Lemma CReal_plus_lt_reg_r : - forall x y z : CReal, y + x < z + x -> y < z. -Proof. - intros x y z Hlt. - rewrite (CReal_plus_comm y), (CReal_plus_comm z) in Hlt. - apply CReal_plus_lt_reg_l in Hlt; exact Hlt. -Qed. - -Lemma CReal_plus_le_reg_l : - forall x y z : CReal, x + y <= x + z -> y <= z. -Proof. - intros x y z Hlt contra. - apply Hlt. - apply CReal_plus_lt_compat_l; exact contra. -Qed. - -Lemma CReal_plus_le_reg_r : - forall x y z : CReal, y + x <= z + x -> y <= z. -Proof. - intros x y z Hlt contra. - apply Hlt. - apply CReal_plus_lt_compat_r; exact contra. -Qed. - -Lemma CReal_plus_le_compat_l : forall r r1 r2, r1 <= r2 -> r + r1 <= r + r2. -Proof. - intros x y z Hlt contra. - apply Hlt. - apply CReal_plus_lt_reg_l in contra; exact contra. -Qed. - -Lemma CReal_plus_le_lt_compat : - forall r1 r2 r3 r4 : CReal, r1 <= r2 -> r3 < r4 -> r1 + r3 < r2 + r4. -Proof. - intros r1 r2 r3 r4 Hr1ler2 Hr3ltr4. - apply CReal_le_lt_trans with (r2 + r3). - - intro contra; rewrite CReal_plus_comm, (CReal_plus_comm r1) in contra. - apply CReal_plus_lt_reg_l in contra. contradiction. - - apply CReal_plus_lt_compat_l. exact Hr3ltr4. -Qed. - -Lemma CReal_plus_le_compat : - forall r1 r2 r3 r4 : CReal, r1 <= r2 -> r3 <= r4 -> r1 + r3 <= r2 + r4. -Proof. - intros r1 r2 r3 r4 Hr1ler2 Hr3ler4. - apply CReal_le_trans with (r2 + r3). - - intro contra; rewrite CReal_plus_comm, (CReal_plus_comm r1) in contra. - apply CReal_plus_lt_reg_l in contra. contradiction. - - apply CReal_plus_le_compat_l; exact Hr3ler4. -Qed. - -Lemma CReal_plus_opp_r : forall x : CReal, - x + - x == 0. -Proof. - intros x; apply CRealEq_diff; intros n. - unfold CReal_plus, CReal_plus_seq, CReal_opp, CReal_opp_seq, inject_Q. - do 3 rewrite CReal_red_seq. - rewrite Qred_correct. - pose proof ((cauchy x) (n)%Z (n-1)%Z (n)%Z ltac:(lia) ltac:(lia)) as Hxbnd. - apply Qlt_le_weak. - rewrite Qabs_Qlt_condition in Hxbnd |- *. - lra. -Qed. - -Lemma CReal_plus_opp_l : forall x : CReal, - - x + x == 0. -Proof. - intro x. rewrite CReal_plus_comm. apply CReal_plus_opp_r. -Qed. - -Lemma CReal_plus_proper_r : forall x y z : CReal, - CRealEq x y -> CRealEq (CReal_plus x z) (CReal_plus y z). -Proof. - intros. apply (CRealEq_trans _ (CReal_plus z x)). - - apply CReal_plus_comm. - - apply (CRealEq_trans _ (CReal_plus z y)). - 2: apply CReal_plus_comm. - split. - + intro abs. apply CReal_plus_lt_reg_l in abs. - destruct H. contradiction. - + intro abs. apply CReal_plus_lt_reg_l in abs. - destruct H. contradiction. -Qed. - -Lemma CReal_plus_proper_l : forall x y z : CReal, - CRealEq x y -> CRealEq (CReal_plus z x) (CReal_plus z y). -Proof. - intros. split. - - intro abs. apply CReal_plus_lt_reg_l in abs. - destruct H. contradiction. - - intro abs. apply CReal_plus_lt_reg_l in abs. - destruct H. contradiction. -Qed. - -Add Parametric Morphism : CReal_plus - with signature CRealEq ==> CRealEq ==> CRealEq - as CReal_plus_morph. -Proof. - intros x y H z t H0. apply (CRealEq_trans _ (CReal_plus x t)). - - destruct H0. - split. - + intro abs. apply CReal_plus_lt_reg_l in abs. contradiction. - + intro abs. apply CReal_plus_lt_reg_l in abs. contradiction. - - apply CReal_plus_proper_r. apply H. -Qed. - -#[global] -Instance CReal_plus_morph_T - : CMorphisms.Proper - (CMorphisms.respectful CRealEq (CMorphisms.respectful CRealEq CRealEq)) CReal_plus. -Proof. - intros x y H z t H0. apply (CRealEq_trans _ (CReal_plus x t)). - - destruct H0. - split. - + intro abs. apply CReal_plus_lt_reg_l in abs. contradiction. - + intro abs. apply CReal_plus_lt_reg_l in abs. contradiction. - - apply CReal_plus_proper_r. apply H. -Qed. - -Lemma CReal_plus_eq_reg_l : forall (r r1 r2 : CReal), - r + r1 == r + r2 -> r1 == r2. -Proof. - intros. destruct H. split. - - intro abs. apply (CReal_plus_lt_compat_l r) in abs. contradiction. - - intro abs. apply (CReal_plus_lt_compat_l r) in abs. contradiction. -Qed. - -Lemma CReal_opp_0 : -0 == 0. -Proof. - apply (CReal_plus_eq_reg_l 0). - rewrite CReal_plus_0_r, CReal_plus_opp_r. reflexivity. -Qed. - -Lemma CReal_opp_plus_distr : forall r1 r2, - (r1 + r2) == - r1 + - r2. -Proof. - intros. apply (CReal_plus_eq_reg_l (r1+r2)). - rewrite CReal_plus_opp_r, (CReal_plus_comm (-r1)), CReal_plus_assoc. - rewrite <- (CReal_plus_assoc r2), CReal_plus_opp_r, CReal_plus_0_l. - rewrite CReal_plus_opp_r. reflexivity. -Qed. - -Lemma CReal_opp_involutive : forall x:CReal, --x == x. -Proof. - intros. apply (CReal_plus_eq_reg_l (-x)). - rewrite CReal_plus_opp_l, CReal_plus_opp_r. reflexivity. -Qed. - -Lemma CReal_opp_gt_lt_contravar : forall r1 r2, r1 > r2 -> - r1 < - r2. -Proof. - unfold CRealGt; intros. - apply (CReal_plus_lt_reg_l (r2 + r1)). - rewrite CReal_plus_assoc, CReal_plus_opp_r, CReal_plus_0_r. - rewrite CReal_plus_comm, <- CReal_plus_assoc, CReal_plus_opp_l. - rewrite CReal_plus_0_l. exact H. -Qed. - -Lemma CReal_opp_ge_le_contravar : forall r1 r2, r1 >= r2 -> - r1 <= - r2. -Proof. - intros. intro abs. apply H. clear H. - apply (CReal_plus_lt_reg_r (-r1-r2)). - unfold CReal_minus. rewrite <- CReal_plus_assoc, CReal_plus_opp_r, CReal_plus_0_l. - rewrite (CReal_plus_comm (-r1)), <- CReal_plus_assoc, CReal_plus_opp_r, CReal_plus_0_l. - exact abs. -Qed. - -Lemma inject_Q_plus : forall q r : Q, - inject_Q (q + r) == inject_Q q + inject_Q r. -Proof. - intros q r. - split. - all: intros [n nmaj]; unfold CReal_plus, CReal_plus_seq, inject_Q in nmaj. - all: do 4 rewrite CReal_red_seq in nmaj. - all: rewrite Qred_correct in nmaj. - all: assert(2^n>0)%Q by (apply Qpower_0_lt; lra); lra. -Qed. - -Lemma inject_Q_one : inject_Q 1 == 1. -Proof. - split. - all: intros [n nmaj]; cbn in nmaj. - all: assert(2^n>0)%Q by (apply Qpower_0_lt; lra); lra. -Qed. - -Lemma inject_Q_lt : forall q r : Q, - Qlt q r -> inject_Q q < inject_Q r. -Proof. - intros q r Hlt. - destruct (QarchimedeanExp2_Z (/(r-q))) as [n Hn]. - rewrite Qinv_lt_contravar, Qinv_involutive, <- Qpower_opp in Hn. - - exists (-n-1)%Z; cbn. - rewrite Qpower_minus_pos; lra. - - apply Qlt_shift_inv_l; lra. - - apply Qpower_0_lt; lra. -Qed. - -Lemma opp_inject_Q : forall q : Q, - inject_Q (-q) == - inject_Q q. -Proof. - intros q. - split. - all: intros [n maj]; cbn in maj. - all: unfold CReal_opp_seq, inject_Q in maj. - all: rewrite CReal_red_seq in maj. - all: assert(2^n>0)%Q by (apply Qpower_0_lt; lra); lra. -Qed. - -Lemma lt_inject_Q : forall q r : Q, - inject_Q q < inject_Q r -> (q < r)%Q. -Proof. - intros q r [n Hn]; cbn in Hn. - apply Qlt_minus_iff. - assert(2^n>0)%Q by (apply Qpower_0_lt; lra); lra. -Qed. - -Lemma le_inject_Q : forall q r : Q, - inject_Q q <= inject_Q r -> (q <= r)%Q. -Proof. - intros q r Hle. - destruct (Qlt_le_dec r q) as [Hdec|Hdec]. - - exfalso. - apply Hle; apply inject_Q_lt; exact Hdec. - - exact Hdec. -Qed. - -Lemma inject_Q_le : forall q r : Q, - (q <= r)%Q -> inject_Q q <= inject_Q r. -Proof. - intros q r Hle [n maj]; cbn in maj. - assert(2^n>0)%Q by (apply Qpower_0_lt; lra); lra. -Qed. - -Lemma inject_Z_plus : forall q r : Z, - inject_Z (q + r) == inject_Z q + inject_Z r. -Proof. - intros q r; unfold inject_Z. - setoid_replace (q + r # 1)%Q with ((q#1) + (r#1))%Q. - - apply inject_Q_plus. - - rewrite Qinv_plus_distr; reflexivity. -Qed. - -Lemma opp_inject_Z : forall n : Z, - inject_Z (-n) == - inject_Z n. -Proof. - intros n; unfold inject_Z. - setoid_replace (-n # 1)%Q with (-(n#1))%Q. - - rewrite opp_inject_Q; reflexivity. - - reflexivity. -Qed. diff --git a/stdlib/theories/Reals/Cauchy/ConstructiveCauchyRealsMult.v b/stdlib/theories/Reals/Cauchy/ConstructiveCauchyRealsMult.v deleted file mode 100644 index 6dc1654d1852..000000000000 --- a/stdlib/theories/Reals/Cauchy/ConstructiveCauchyRealsMult.v +++ /dev/null @@ -1,1128 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* seq x (n - scale y - 1)%Z - * seq y (n - scale x - 1)%Z). - -Definition CReal_mult_scale (x y : CReal) : Z := - x.(scale) + y.(scale). - -Local Ltac simplify_Qpower_exponent := - match goal with |- context [(_ ^ ?a)%Q] => ring_simplify a end. - -Local Ltac simplify_Qabs := - match goal with |- context [(Qabs ?a)%Q] => ring_simplify a end. - -Local Ltac simplify_Qabs_in H := - match type of H with context [(Qabs ?a)%Q] => ring_simplify a in H end. - -Local Ltac field_simplify_Qabs := - match goal with |- context [(Qabs ?a)%Q] => field_simplify a end. - -Local Ltac pose_Qabs_pos := - match goal with |- context [(Qabs ?a)%Q] => pose proof Qabs_nonneg a end. - -Local Ltac simplify_Qle := - match goal with |- (?l <= ?r)%Q => ring_simplify l; ring_simplify r end. - -Local Ltac simplify_Qle_in H := - match type of H with (?l <= ?r)%Q => ring_simplify l in H; ring_simplify r in H end. - -Local Ltac simplify_Qlt := - match goal with |- (?l < ?r)%Q => ring_simplify l; ring_simplify r end. - -Local Ltac simplify_Qlt_in H := - match type of H with (?l < ?r)%Q => ring_simplify l in H; ring_simplify r in H end. - -Local Ltac simplify_seq_idx := - match goal with |- context [seq ?x ?n] => progress ring_simplify n end. - -Local Lemma Weaken_Qle_QpowerAddExp: forall (q : Q) (n m : Z), - (m >= 0)%Z - -> (q <= 2^n)%Q - -> (q <= 2^(n+m))%Q. -Proof. - intros q n m Hmpos Hle. - pose proof Qpower_le_compat_l 2 n (n+m) ltac:(lia) ltac:(lra). - lra. -Qed. - -Local Lemma Weaken_Qle_QpowerRemSubExp: forall (q : Q) (n m : Z), - (m >= 0)%Z - -> (q <= 2^(n-m))%Q - -> (q <= 2^n)%Q. -Proof. - intros q n m Hmpos Hle. - pose proof Qpower_le_compat_l 2 (n-m) n ltac:(lia) ltac:(lra). - lra. -Qed. - -Local Lemma Weaken_Qle_QpowerFac: forall (q r : Q) (n : Z), - (r >= 1)%Q - -> (q <= 2^n)%Q - -> (q <= r * 2^n)%Q. -Proof. - intros q r n Hrge1 Hle. - rewrite <- (Qmult_1_l (2^n)%Q) in Hle. - pose proof Qmult_le_compat_r 1 r (2^n)%Q Hrge1 (Qpower_pos 2 n ltac:(lra)) as Hpow. - lra. -Qed. - -Lemma CReal_mult_cauchy: forall (x y : CReal), - QCauchySeq (CReal_mult_seq x y). -Proof. - intros x y n p q Hp Hq. - unfold CReal_mult_seq. - - assert(forall xp xq yp yq : Q, xp * yp - xq * yq == (xp - xq) * yp + xq * (yp - yq))%Q - as H by (intros; ring). - rewrite H; clear H. - - apply (Qle_lt_trans _ _ _ (Qabs_triangle _ _)). - do 2 rewrite Qabs_Qmult. - - replace n with ((n-1)+1)%Z by ring. - rewrite Qpower_plus by lra. - setoid_replace (2 ^ (n - 1) * 2 ^1)%Q with (2 ^ (n - 1) + 2 ^ (n - 1))%Q by ring. - - apply Qplus_lt_le_compat. - - apply (Qle_lt_trans _ ((2 ^ (n - scale y - 1)) * Qabs (seq y (p - scale x - 1)))). - + apply Qmult_le_compat_r. - 2: apply Qabs_nonneg. - apply Qlt_le_weak. apply (cauchy x); lia. - + apply (Qmult_lt_l _ _ (2 ^ -(n - scale y - 1))%Q). - { apply Qpower_0_lt; lra. } - rewrite Qmult_assoc, <- Qpower_plus by lra. - rewrite <- Qpower_plus by lra. - simplify_Qpower_exponent; rewrite Qpower_0_r, Qmult_1_l. - simplify_Qpower_exponent. - apply (bound y). - - apply Qlt_le_weak. - apply (Qle_lt_trans _ ((2 ^ (n - scale x - 1)) * Qabs (seq x (q - scale y - 1)))). - + rewrite Qmult_comm; apply Qmult_le_compat_r. - 2: apply Qabs_nonneg. - apply Qlt_le_weak; apply (cauchy y); lia. - + apply (Qmult_lt_l _ _ (2 ^ -(n - scale x - 1))%Q). - { apply Qpower_0_lt; lra. } - rewrite Qmult_assoc, <- Qpower_plus by lra. - rewrite <- Qpower_plus by lra. - simplify_Qpower_exponent; rewrite Qpower_0_r, Qmult_1_l. - simplify_Qpower_exponent. - apply (bound x). -Qed. - -Lemma CReal_mult_bound : forall (x y : CReal), - QBound (CReal_mult_seq x y) (CReal_mult_scale x y). -Proof. - intros x y k. - unfold CReal_mult_seq, CReal_mult_scale. - pose proof (bound x (k - scale y - 1)%Z) as Hxbnd. - pose proof (bound y (k - scale x - 1)%Z) as Hybnd. - pose proof Qabs_nonneg (seq x (k - scale y - 1)) as Habsx. - pose proof Qabs_nonneg (seq y (k - scale x - 1)) as Habsy. - rewrite Qabs_Qmult; rewrite Qpower_plus by lra. - apply Qmult_lt_compat_nonneg; lra. -Qed. - -Definition CReal_mult (x y : CReal) : CReal := -{| - seq := CReal_mult_seq x y; - scale := CReal_mult_scale x y; - cauchy := CReal_mult_cauchy x y; - bound := CReal_mult_bound x y -|}. - -Infix "*" := CReal_mult : CReal_scope. - -Lemma CReal_mult_comm : forall x y : CReal, x * y == y * x. -Proof. - assert (forall x y : CReal, x * y <= y * x) as H. - { intros x y [n nmaj]. apply (Qlt_not_le _ _ nmaj). clear nmaj. - unfold CReal_mult, CReal_mult_seq; do 2 rewrite CReal_red_seq. - ring_simplify. - pose proof Qpower_0_lt 2 n ltac:(lra); lra. } - split; apply H. -Qed. - -(* ToDo: make a tactic for this *) -Lemma CReal_red_scale: forall (a : Z -> Q) (b : Z) (c : QCauchySeq a) (d : QBound a b), - scale (mkCReal a b c d) = b. -Proof. - reflexivity. -Qed. - -Lemma CReal_mult_proper_0_l : forall x y : CReal, - y == 0 -> x * y == 0. -Proof. - intros x y Hyeq0. - - apply CRealEq_diff; intros n. - unfold CReal_mult, CReal_mult_seq, inject_Q; do 2 rewrite CReal_red_seq. - simplify_Qabs. - - rewrite CRealEq_diff in Hyeq0. - unfold inject_Q in Hyeq0; rewrite CReal_red_seq in Hyeq0. - specialize (Hyeq0 (n - scale x - 1)%Z). - simplify_Qabs_in Hyeq0. - rewrite Qpower_minus_pos in Hyeq0 by lra; simplify_Qle_in Hyeq0. - - pose proof bound x (n - scale y - 1)%Z as Hxbnd. - apply Weaken_Qle_QpowerFac; [lra|]. - - (* Now split the power of 2 and solve the goal*) - replace n with ((scale x) + (n - scale x))%Z at 3 by ring. - rewrite Qpower_plus by lra. - rewrite Qabs_Qmult. - apply Qmult_le_compat_nonneg; - (pose_Qabs_pos; lra). -Qed. - -Lemma CReal_mult_0_r : forall r, r * 0 == 0. -Proof. - intros. apply CReal_mult_proper_0_l. reflexivity. -Qed. - -Lemma CReal_mult_0_l : forall r, 0 * r == 0. -Proof. - intros. rewrite CReal_mult_comm. apply CReal_mult_0_r. -Qed. - -Lemma CReal_scale_sep0_limit : forall (x : CReal) (n : Z), - (2 * (2^n)%Q < seq x n)%Q - -> (n <= scale x - 2)%Z. -Proof. - intros x n Hnx. - pose proof bound x n as Hxbnd. - apply Qabs_Qlt_condition in Hxbnd. - destruct Hxbnd as [_ Hxbnd]. - apply (Qlt_trans _ _ _ Hnx) in Hxbnd. - replace n with ((n+1)-1)%Z in Hxbnd by lia. - rewrite Qpower_minus_pos in Hxbnd by lra. - simplify_Qlt_in Hxbnd. - apply (Qpower_lt_compat_l_inv) in Hxbnd. - - lia. - - lra. -Qed. - -(* Correctness lemma for the Definition CReal_mult_lt_0_compat below. *) -Lemma CReal_mult_lt_0_compat_correct - : forall (x y : CReal) (Hx : 0 < x) (Hy : 0 < y), - (2 * 2^(proj1_sig Hx + proj1_sig Hy - 1)%Z < - seq (x * y)%CReal (proj1_sig Hx + proj1_sig Hy - 1)%Z - - seq (inject_Q 0) (proj1_sig Hx + proj1_sig Hy - 1)%Z)%Q. -Proof. - intros x y Hx Hy. - destruct Hx as [nx Hx], Hy as [ny Hy]; unfold proj1_sig. - unfold inject_Q, Qminus in Hx. rewrite CReal_red_seq, Qplus_0_r in Hx. - unfold inject_Q, Qminus in Hy. rewrite CReal_red_seq, Qplus_0_r in Hy. - - unfold CReal_mult, CReal_mult_seq, inject_Q; do 2 rewrite CReal_red_seq. - rewrite Qpower_minus_pos by lra. - rewrite Qpower_plus by lra. - simplify_Qlt. - do 2 simplify_seq_idx. - apply Qmult_lt_compat_nonneg. - - split. - + pose proof Qpower_0_lt 2 nx; lra. - + pose proof CReal_scale_sep0_limit y ny Hy as Hlimy. - pose proof cauchy x nx nx (nx + ny - scale y - 2)%Z ltac:(lia) ltac:(lia) as Hbndx. - apply Qabs_Qlt_condition in Hbndx. - lra. - - split. - + pose proof Qpower_0_lt 2 ny; lra. - + pose proof CReal_scale_sep0_limit x nx Hx as Hlimx. - pose proof cauchy y ny ny (nx + ny - scale x - 2)%Z ltac:(lia) ltac:(lia) as Hbndy. - apply Qabs_Qlt_condition in Hbndy. - lra. -Qed. - -(* Strict inequality on CReal is in sort Type, for example - used in the computation of division. *) -Definition CReal_mult_lt_0_compat : forall x y : CReal, - 0 < x -> 0 < y -> 0 < x * y - := fun x y Hx Hy => exist _ (proj1_sig Hx + proj1_sig Hy - 1)%Z - (CReal_mult_lt_0_compat_correct - x y Hx Hy). - -Lemma CReal_mult_plus_distr_l : forall r1 r2 r3 : CReal, - r1 * (r2 + r3) == (r1 * r2) + (r1 * r3). -Proof. - intros x y z; apply CRealEq_diff; intros n. - unfold CReal_mult, CReal_mult_seq, CReal_mult_scale, CReal_plus, CReal_plus_seq, CReal_plus_scale. - do 5 rewrite CReal_red_seq. - do 1 rewrite CReal_red_scale. - do 2 rewrite Qred_correct. - do 5 simplify_seq_idx. - simplify_Qabs. - assert (forall y' z': CReal, - Qabs ( - seq x (n - Z.max (scale y') (scale z') - 2) * seq y' (n - scale x - 2) - - seq x (n - scale y' - 2) * seq y' (n - scale x - 2)) - <= 2 ^ n )%Q as Hdiffbnd. - { - intros y' z'. - assert (forall a b c : Q, a*c-b*c==(a-b)*c)%Q as H by (intros; ring). - rewrite H; clear H. - pose proof cauchy x (n - (scale y') - 2)%Z (n - Z.max (scale y') (scale z') - 2)%Z (n - scale y' - 2)%Z - ltac:(lia) ltac:(lia) as Hxbnd. - pose proof bound y' (n - scale x - 2)%Z as Hybnd. - replace n with ((n - scale y' - 2) + scale y' + 2)%Z at 4 by lia. - apply Weaken_Qle_QpowerAddExp. - { lia. } - rewrite Qpower_plus, Qabs_Qmult by lra. - apply Qmult_le_compat_nonneg; (split; [apply Qabs_nonneg | lra]). - } - pose proof Hdiffbnd y z as Hyz. - pose proof Hdiffbnd z y as Hzy; clear Hdiffbnd. - pose proof Qplus_le_compat _ _ _ _ Hyz Hzy as Hcomb; clear Hyz Hzy. - apply (Qle_trans _ _ _ (Qabs_triangle _ _)) in Hcomb. - rewrite (Z.max_comm (scale z) (scale y)) in Hcomb . - rewrite Qabs_Qle_condition in Hcomb |- *. - lra. -Qed. - -Lemma CReal_mult_plus_distr_r : forall r1 r2 r3 : CReal, - (r2 + r3) * r1 == (r2 * r1) + (r3 * r1). -Proof. - intros. - rewrite CReal_mult_comm, CReal_mult_plus_distr_l, - <- (CReal_mult_comm r1), <- (CReal_mult_comm r1). - reflexivity. -Qed. - -Lemma CReal_opp_mult_distr_r - : forall r1 r2 : CReal, - (r1 * r2) == r1 * (- r2). -Proof. - intros. apply (CReal_plus_eq_reg_l (r1*r2)). - rewrite CReal_plus_opp_r, <- CReal_mult_plus_distr_l. - symmetry. apply CReal_mult_proper_0_l. - apply CReal_plus_opp_r. -Qed. - -Lemma CReal_mult_proper_l : forall x y z : CReal, - y == z -> x * y == x * z. -Proof. - intros. apply (CReal_plus_eq_reg_l (-(x*z))). - rewrite CReal_plus_opp_l, CReal_opp_mult_distr_r. - rewrite <- CReal_mult_plus_distr_l. - apply CReal_mult_proper_0_l. rewrite H. apply CReal_plus_opp_l. -Qed. - -Lemma CReal_mult_proper_r : forall x y z : CReal, - y == z -> y * x == z * x. -Proof. - intros. rewrite CReal_mult_comm, (CReal_mult_comm z). - apply CReal_mult_proper_l, H. -Qed. - -Lemma CReal_mult_assoc : forall x y z : CReal, - (x * y) * z == x * (y * z). -Proof. - intros x y z; apply CRealEq_diff; intros n. - - (* Expand and simplify the goal *) - unfold CReal_mult, CReal_mult_seq, CReal_mult_scale. - do 4 rewrite CReal_red_seq. - do 2 rewrite CReal_red_scale. - do 6 simplify_seq_idx. - (* Todo: it is a bug in ring_simplify that the scales are not sorted *) - replace (n - scale z - scale y)%Z with (n - scale y - scale z)%Z by ring. - replace (n - scale z - scale x)%Z with (n - scale x - scale z)%Z by ring. - simplify_Qabs. - - (* Rearrange the goal such that it used only scale and cauchy bounds *) - (* Todo: it is also a bug in ring_simplify that the seq terms are not sorted by the first variable *) - assert (forall a1 a2 b c1 c2 : Q, a1*b*c1+(-1)*b*a2*c2==(a1*c1-a2*c2)*b)%Q as H by (intros; ring). - rewrite H; clear H. - remember (seq x (n - scale y - scale z - 1) - seq x (n - scale y - scale z - 2))%Q as dx eqn:Heqdx. - remember (seq z (n - scale x - scale y - 1) - seq z (n - scale x - scale y - 2))%Q as dz eqn:Heqdz. - setoid_replace (seq x (n - scale y - scale z - 1)) with (seq x (n - scale y - scale z - 2) + dx)%Q - by (rewrite Heqdx; ring). - setoid_replace (seq z (n - scale x - scale y - 1)) with (seq z (n - scale x - scale y - 2) + dz)%Q - by (rewrite Heqdz; ring). - match goal with |- (Qabs (?a * _) <= _)%Q => ring_simplify a end. - - (* Now pose the scale and cauchy bounds we need to prove this, so that we see how to split the deviation budget *) - pose proof bound x (n - scale y - scale z - 2)%Z as Hbndx. - pose proof bound z (n - scale x - scale y - 2)%Z as Hbndz. - pose proof bound y (n - scale x - scale z - 2)%Z as Hbndy. - pose proof cauchy x (n - scale y - scale z - 1)%Z (n - scale y - scale z - 1)%Z (n - scale y - scale z - 2)%Z - ltac:(lia) ltac:(lia) as Hbnddx; rewrite <- Heqdx in Hbnddx; clear Heqdx. - pose proof cauchy z (n - scale x - scale y - 1)%Z (n - scale x - scale y - 1)%Z (n - scale x - scale y - 2)%Z - ltac:(lia) ltac:(lia) as Hbnddz; rewrite <- Heqdz in Hbnddz; clear Heqdz. - - (* The rest is elementary arithmetic ... *) - rewrite Qabs_Qmult. - replace n with ((n - scale y) + scale y)%Z at 4 by lia. - rewrite Qpower_plus by lra. - rewrite Qmult_assoc. - apply Qmult_le_compat_nonneg. - 2: (split; [apply Qabs_nonneg | lra]). - - split; [apply Qabs_nonneg|]. - apply (Qle_trans _ _ _ (Qabs_triangle _ _)). - setoid_replace (2 * 2 ^ (n - scale y))%Q with (2 ^ (n - scale y) + 2 ^ (n - scale y))%Q by ring. - apply Qplus_le_compat. - - rewrite Qabs_Qmult. - replace (n - scale y)%Z with (scale x + (n - scale x - scale y))%Z at 2 by lia. - rewrite Qpower_plus by lra. - apply Qmult_le_compat_nonneg. - + (split; [apply Qabs_nonneg | lra]). - + split; [apply Qabs_nonneg|]. - apply (Weaken_Qle_QpowerRemSubExp _ _ 1 ltac:(lia)), Qlt_le_weak, Hbnddz. - - rewrite Qabs_Qmult. - replace (n - scale y)%Z with (scale z + (n - scale y - scale z))%Z by lia. - rewrite Qpower_plus by lra. - apply Qmult_le_compat_nonneg. - + split; [apply Qabs_nonneg|]. - rewrite <- Qabs_opp; simplify_Qabs; lra. - + split; [apply Qabs_nonneg|]. - apply (Weaken_Qle_QpowerRemSubExp _ _ 1 ltac:(lia)), Qlt_le_weak, Hbnddx. -Qed. - -Lemma CReal_mult_1_l : forall r: CReal, - 1 * r == r. -Proof. - intros r; apply CRealEq_diff; intros n. - - unfold inject_Q, CReal_mult, CReal_mult_seq, CReal_mult_scale. - do 2 rewrite CReal_red_seq. - do 1 rewrite CReal_red_scale. - change (Qbound_ltabs_ZExp2 1)%Z with 1%Z. - do 1 simplify_seq_idx. - simplify_Qabs. - - pose proof cauchy r n (n-2)%Z n ltac:(lia) ltac:(lia) as Hrbnd. - apply Qabs_Qlt_condition in Hrbnd. - apply Qabs_Qle_condition. - lra. -Qed. - -Lemma CReal_isRingExt : ring_eq_ext CReal_plus CReal_mult CReal_opp CRealEq. -Proof. - split. - - intros x y H z t H0. apply CReal_plus_morph; assumption. - - intros x y H z t H0. apply (CRealEq_trans _ (CReal_mult x t)). - + apply CReal_mult_proper_l. apply H0. - + apply (CRealEq_trans _ (CReal_mult t x)). { apply CReal_mult_comm. } - apply (CRealEq_trans _ (CReal_mult t y)). - * apply CReal_mult_proper_l. apply H. - * apply CReal_mult_comm. - - intros x y H. apply (CReal_plus_eq_reg_l x). - apply (CRealEq_trans _ (inject_Q 0)). { apply CReal_plus_opp_r. } - apply (CRealEq_trans _ (CReal_plus y (CReal_opp y))). - + apply CRealEq_sym. apply CReal_plus_opp_r. - + apply CReal_plus_proper_r. apply CRealEq_sym. apply H. -Qed. - -Lemma CReal_isRing : ring_theory (inject_Q 0) (inject_Q 1) - CReal_plus CReal_mult - CReal_minus CReal_opp - CRealEq. -Proof. - intros. split. - - apply CReal_plus_0_l. - - apply CReal_plus_comm. - - intros x y z. symmetry. apply CReal_plus_assoc. - - apply CReal_mult_1_l. - - apply CReal_mult_comm. - - intros x y z. symmetry. apply CReal_mult_assoc. - - intros x y z. rewrite <- (CReal_mult_comm z). - rewrite CReal_mult_plus_distr_l. - apply (CRealEq_trans _ (CReal_plus (CReal_mult x z) (CReal_mult z y))). - + apply CReal_plus_proper_r. apply CReal_mult_comm. - + apply CReal_plus_proper_l. apply CReal_mult_comm. - - intros x y. apply CRealEq_refl. - - apply CReal_plus_opp_r. -Qed. - -Add Parametric Morphism : CReal_mult - with signature CRealEq ==> CRealEq ==> CRealEq - as CReal_mult_morph. -Proof. - apply CReal_isRingExt. -Qed. - -#[global] -Instance CReal_mult_morph_T - : CMorphisms.Proper - (CMorphisms.respectful CRealEq (CMorphisms.respectful CRealEq CRealEq)) CReal_mult. -Proof. - apply CReal_isRingExt. -Qed. - -Add Parametric Morphism : CReal_opp - with signature CRealEq ==> CRealEq - as CReal_opp_morph. -Proof. - apply (Ropp_ext CReal_isRingExt). -Qed. - -#[global] -Instance CReal_opp_morph_T - : CMorphisms.Proper - (CMorphisms.respectful CRealEq CRealEq) CReal_opp. -Proof. - apply CReal_isRingExt. -Qed. - -Add Parametric Morphism : CReal_minus - with signature CRealEq ==> CRealEq ==> CRealEq - as CReal_minus_morph. -Proof. - intros. unfold CReal_minus. rewrite H,H0. reflexivity. -Qed. - -#[global] -Instance CReal_minus_morph_T - : CMorphisms.Proper - (CMorphisms.respectful CRealEq (CMorphisms.respectful CRealEq CRealEq)) CReal_minus. -Proof. - intros x y exy z t ezt. unfold CReal_minus. rewrite exy,ezt. reflexivity. -Qed. - -Add Ring CRealRing : CReal_isRing. - -(**********) -Lemma CReal_mult_1_r : forall r, r * 1 == r. -Proof. - intro; ring. -Qed. - -Lemma CReal_opp_mult_distr_l - : forall r1 r2 : CReal, - (r1 * r2) == (- r1) * r2. -Proof. - intros. ring. -Qed. - -Lemma CReal_mult_lt_compat_l : forall x y z : CReal, - 0 < x -> y < z -> x*y < x*z. -Proof. - intros. apply (CReal_plus_lt_reg_l - (CReal_opp (CReal_mult x y))). - rewrite CReal_plus_comm. pose proof CReal_plus_opp_r. - unfold CReal_minus in H1. rewrite H1. - rewrite CReal_mult_comm, CReal_opp_mult_distr_l, CReal_mult_comm. - rewrite <- CReal_mult_plus_distr_l. - apply CReal_mult_lt_0_compat. - - exact H. - - apply (CReal_plus_lt_reg_l y). - rewrite CReal_plus_comm, CReal_plus_0_l. - rewrite <- CReal_plus_assoc, H1, CReal_plus_0_l. exact H0. -Qed. - -Lemma CReal_mult_lt_compat_r : forall x y z : CReal, - 0 < x -> y < z -> y*x < z*x. -Proof. - intros. rewrite <- (CReal_mult_comm x), <- (CReal_mult_comm x). - apply (CReal_mult_lt_compat_l x); assumption. -Qed. - -Lemma CReal_mult_eq_reg_l : forall (r r1 r2 : CReal), - r # 0 - -> r * r1 == r * r2 - -> r1 == r2. -Proof. - intros. destruct H; split. - - intro abs. apply (CReal_mult_lt_compat_l (-r)) in abs. - + rewrite <- CReal_opp_mult_distr_l, <- CReal_opp_mult_distr_l, H0 in abs. - exact (CRealLe_refl _ abs). - + apply (CReal_plus_lt_reg_l r). - rewrite CReal_plus_opp_r, CReal_plus_comm, CReal_plus_0_l. exact c. - - intro abs. apply (CReal_mult_lt_compat_l (-r)) in abs. - + rewrite <- CReal_opp_mult_distr_l, <- CReal_opp_mult_distr_l, H0 in abs. - exact (CRealLe_refl _ abs). - + apply (CReal_plus_lt_reg_l r). - rewrite CReal_plus_opp_r, CReal_plus_comm, CReal_plus_0_l. exact c. - - intro abs. apply (CReal_mult_lt_compat_l r) in abs. - + rewrite H0 in abs. - exact (CRealLe_refl _ abs). - + exact c. - - intro abs. apply (CReal_mult_lt_compat_l r) in abs. - + rewrite H0 in abs. - exact (CRealLe_refl _ abs). - + exact c. -Qed. - -Lemma CReal_abs_appart_zero : forall (x : CReal) (n : Z), - (2*2^n < Qabs (seq x n))%Q - -> 0 # x. -Proof. - intros x n Hapart. - unfold CReal_appart. - destruct (Qlt_le_dec 0 (seq x n)). - - left; exists n; cbn. - rewrite Qabs_pos in Hapart; lra. - - right; exists n; cbn. - rewrite Qabs_neg in Hapart; lra. -Qed. - -(*********************************************************) -(** * Field *) -(*********************************************************) - -Lemma CRealArchimedean - : forall x:CReal, { n:Z & x < inject_Z n < x+2 }. -Proof. - intros x. - (* We add 3/2: 1/2 for the average rounding of floor + 1 to center in the interval. - This gives a margin of 1/2 in each inequality. - Since we need margin for Qlt of 2*2^-n plus 2^-n for the real addition, we need n=-3 *) - remember (seq x (-3)%Z + (3#2))%Q as q eqn: Heqq. - pose proof (Qlt_floor q) as Hltfloor; unfold QArith_base.inject_Z in Hltfloor. - pose proof (Qfloor_le q) as Hfloorle; unfold QArith_base.inject_Z in Hfloorle. - exists (Qfloor q); split. - - unfold inject_Z, inject_Q, CRealLt. rewrite CReal_red_seq. - exists (-3)%Z. - setoid_replace (2 * 2 ^ (-3))%Q with (1#4)%Q by reflexivity. - subst q; rewrite <- Qinv_plus_distr in Hltfloor. - lra. - - unfold inject_Z, inject_Q, CReal_plus, CReal_plus_seq, CRealLt. do 3 rewrite CReal_red_seq. - exists (-3)%Z. - setoid_replace (2 * 2 ^ (-3))%Q with (1#4)%Q by reflexivity. - simplify_seq_idx; rewrite Qred_correct. - pose proof cauchy x (-3)%Z (-3)%Z (-4)%Z ltac:(lia) ltac:(lia) as Hbnddx. - rewrite Qabs_Qlt_condition in Hbnddx. - setoid_replace (2 ^ (-3))%Q with (1#8)%Q in Hbnddx by reflexivity. - subst q; rewrite <- Qinv_plus_distr in Hltfloor. - lra. -Qed. - -(* ToDo: This is not efficient. - We take the n for the 2^n lower bound fro x>0. - This limit can be arbitrarily small and far away from beeing tight. - To make this really computational, we need to compute a tight - limit starting from scale x and going down in steps of say 16 bits, - something which is still easy to compute but likely to succeed. *) - -Definition CRealLowerBound (x : CReal) (xPos : 0 (seq x p > 2^(CRealLowerBound x xPos))%Q. -Proof. - intros x xPos p Hp. - unfold CRealLowerBound in *. - destruct xPos as [n Hn]; unfold proj1_sig in *. - unfold inject_Q in Hn; rewrite CReal_red_seq in Hn. - ring_simplify in Hn. - pose proof cauchy x n n p ltac:(lia) ltac:(lia) as Hxbnd. - rewrite Qabs_Qlt_condition in Hxbnd. - lra. -Qed. - -Lemma CRealLowerBound_lt_scale: forall (r : CReal) (Hrpos : 0 < r), - (CRealLowerBound r Hrpos < scale r)%Z. -Proof. - intros r Hrpos. - pose proof CRealLowerBoundSpec r Hrpos (CRealLowerBound r Hrpos) ltac:(lia) as Hlow. - pose proof bound r (CRealLowerBound r Hrpos) as Hup; unfold QBound in Hup. - apply Qabs_Qlt_condition in Hup. destruct Hup as [_ Hup]. - pose proof Qlt_trans _ _ _ Hlow Hup as Hpow. - apply Qpower_lt_compat_l_inv in Hpow. - 2: lra. - exact Hpow. -Qed. - -(** -Note on the convergence modulus for x when computing 1/x: -Thinking in terms of absolute and relative errors and scales we get: -- 2^n is absolute error of 1/x (the requested error) -- 2^k is a lower bound of x -> 2^-k is an upper bound of 1/x -For simplicity letsā€™ say 2^k is the scale of x and 2^-k is the scale of 1/x. - -With this we get: -- relative error of 1/x = absolute error of 1/x / scale of 1/x = 2^n / 2^-k = 2^(n+k) -- 1/x maintains relative error -- relative error of x = relative error 1/x = 2^(n+k) -- absolute error of x = relative error x * scale of x = 2^(n+k) * 2^k -- absolute error of x = 2^(n+2*k) -*) - -Definition CReal_inv_pos_cm (x : CReal) (xPos : 0 < x) (n : Z):= - (Z.min (CRealLowerBound x xPos) (n + 2 * (CRealLowerBound x xPos)))%Z. - -Definition CReal_inv_pos_seq (x : CReal) (xPos : 0 < x) (n : Z) := - (/ seq x (CReal_inv_pos_cm x xPos n))%Q. - -Definition CReal_inv_pos_scale (x : CReal) (xPos : 0 < x) : Z := - (- (CRealLowerBound x xPos))%Z. - -Lemma CReal_inv_pos_cauchy: forall (x : CReal) (xPos : 0 < x), - QCauchySeq (CReal_inv_pos_seq x xPos). -Proof. - intros x Hxpos n p q Hp Hq; unfold CReal_inv_pos_seq. - unfold CReal_inv_pos_cm; remember (CRealLowerBound x Hxpos) as k. - - (* These auxilliary lemmas are required a few times below *) - assert (forall m:Z, (2^k < seq x (Z.min k (m + 2 * k))))%Q as AuxAppart. - { - intros m. - pose proof CRealLowerBoundSpec x Hxpos (Z.min k (m + 2 * k))%Z ltac:(lia) as H1. - rewrite Heqk at 1. - lra. - } - assert (forall m:Z, (0 < seq x (Z.min k (m + 2 * k))))%Q as AuxPos. - { - intros m. - pose proof AuxAppart m as H1. - pose proof Qpower_0_lt 2 k as H2. - lra. - } - - assert( forall a b : Q, (a>0)%Q -> (b>0)%Q -> (/a - /b == (b - a) / (a * b))%Q ) - as H by (intros; field; lra); rewrite H by apply AuxPos; clear H. - - setoid_rewrite Qabs_Qmult; setoid_rewrite Qabs_Qinv. - apply Qlt_shift_div_r. - - setoid_rewrite <- (Qmult_0_l 0); setoid_rewrite Qabs_Qmult. - apply Qmult_lt_compat_nonneg. - 1,2: split; [lra | apply Qabs_gt, AuxPos]. - - assert( forall r:Q, (r == (r/2^k/2^k)*(2^k*2^k))%Q ) - as H by (intros r; field; apply Qpower_not_0; lra); rewrite H; clear H. - apply Qmult_lt_compat_nonneg. - + split. - * do 2 (apply Qle_shift_div_l; [ apply Qpower_0_lt; lra | rewrite Qmult_0_l ]). - apply Qabs_nonneg. - * do 2 (apply Qlt_shift_div_r; [apply Qpower_0_lt; lra|]). - do 2 rewrite <- Qpower_plus by lra. - apply (cauchy x (n+k+k)%Z); lia. - + split. - * rewrite <- Qpower_plus by lra. - apply Qpower_pos; lra. - * setoid_rewrite Qabs_Qmult; apply Qmult_lt_compat_nonneg. - 1,2: split; [apply Qpower_pos; lra | ]. - 1,2: apply Qabs_gt, AuxAppart. -Qed. - -Lemma CReal_inv_pos_bound : forall (x : CReal) (Hxpos : 0 < x), - QBound (CReal_inv_pos_seq x Hxpos) (CReal_inv_pos_scale x Hxpos). -Proof. - intros x Hxpos n. - unfold CReal_inv_pos_seq, CReal_inv_pos_scale, CReal_inv_pos_cm. - remember (CRealLowerBound x Hxpos) as k. - pose proof CRealLowerBoundSpec x Hxpos (Z.min k (n + 2 * k))%Z ltac:(lia) as Hlb. - rewrite <- Heqk in Hlb. - rewrite Qabs_pos. - 2: apply Qinv_le_0_compat; pose proof Qpower_pos 2 k; lra. - rewrite Qpower_opp; apply -> Qinv_lt_contravar. - - exact Hlb. - - pose proof Qpower_0_lt 2 k; lra. - - apply Qpower_0_lt; lra. -Qed. - -Definition CReal_inv_pos (x : CReal) (Hxpos : 0 < x) : CReal := -{| - seq := CReal_inv_pos_seq x Hxpos; - scale := CReal_inv_pos_scale x Hxpos; - cauchy := CReal_inv_pos_cauchy x Hxpos; - bound := CReal_inv_pos_bound x Hxpos -|}. - -Definition CReal_neg_lt_pos : forall x : CReal, x < 0 -> 0 < -x. -Proof. - intros x [n nmaj]. exists n. - simpl in *. unfold CReal_opp_seq, Qminus. - abstract now rewrite Qplus_0_r, <- (Qplus_0_l (- seq x n)). -Defined. - -Definition CReal_inv (x : CReal) (xnz : x # 0) : CReal - := match xnz with - | inl xNeg => - CReal_inv_pos (-x) (CReal_neg_lt_pos x xNeg) - | inr xPos => CReal_inv_pos x xPos - end. - -Notation "/ x" := (CReal_inv x) (at level 35, right associativity) : CReal_scope. - -Lemma CReal_inv_0_lt_compat - : forall (r : CReal) (rnz : r # 0), - 0 < r -> 0 < ((/ r) rnz). -Proof. - intros r Hrnz Hrpos; unfold CReal_inv; cbn. - destruct Hrnz. - - exfalso. apply CRealLt_asym in Hrpos. contradiction. - - unfold CRealLt. - exists (- (scale r) - 1)%Z. - unfold inject_Q; rewrite CReal_red_seq; simplify_Qlt. - unfold CReal_inv_pos; rewrite CReal_red_seq. - unfold CReal_inv_pos_seq. - pose proof bound r as Hrbnd; unfold QBound in Hrbnd. - rewrite Qpower_minus by lra. - field_simplify (2 * (2 ^ (- scale r) / 2 ^ 1))%Q. - rewrite Qpower_opp; apply -> Qinv_lt_contravar. - + setoid_rewrite Qabs_Qlt_condition in Hrbnd. - specialize (Hrbnd (CReal_inv_pos_cm r c (- scale r - 1))%Z). - lra. - + apply Qpower_0_lt; lra. - + unfold CReal_inv_pos_cm. - pose proof CRealLowerBoundSpec r c - ((Z.min (CRealLowerBound r c) (- scale r - 1 + 2 * CRealLowerBound r c)))%Z ltac:(lia) as Hlowbnd. - pose proof Qpower_0_lt 2 (CRealLowerBound r c) as Hpow. - lra. -Qed. - -Lemma CReal_inv_l_pos : forall (r:CReal) (Hrpos : 0 < r), - (CReal_inv_pos r Hrpos) * r == 1. -Proof. - intros r Hrpos; apply CRealEq_diff; intros n. - unfold CReal_mult, CReal_mult_seq, CReal_mult_scale; - unfold CReal_inv_pos, CReal_inv_pos_seq, CReal_inv_pos_scale, CReal_inv_pos_cm; - unfold inject_Q. - do 3 rewrite CReal_red_seq. - do 1 rewrite CReal_red_scale. - simplify_seq_idx. - - (* This is needed several times below *) - remember (Z.min (CRealLowerBound r Hrpos) (n - scale r - 1 + 2 * CRealLowerBound r Hrpos))%Z as k. - assert (0 < seq r k)%Q as Hrseqpos. - { pose proof Qpower_0_lt 2 (CRealLowerBound r Hrpos)%Z ltac:(lra) as Hpow. - pose proof CRealLowerBoundSpec r Hrpos k ltac:(lia) as Hlowbnd. - lra. - } - field_simplify_Qabs; [|lra]; unfold Qdiv. - rewrite Qabs_Qmult, Qabs_Qinv. - apply Qle_shift_div_r. - 1: apply Qabs_gt; lra. - - pose proof cauchy r (n + CRealLowerBound r Hrpos)%Z - (n + CRealLowerBound r Hrpos - 1)%Z k as Hrbnd. - pose proof CRealLowerBound_lt_scale r Hrpos as Hscale_lowbnd. - specialize (Hrbnd ltac:(lia) ltac:(lia)). - simplify_Qabs_in Hrbnd; simplify_Qabs. - rewrite Qplus_comm in Hrbnd. - apply Qlt_le_weak in Hrbnd. - apply (Qle_trans _ _ _ Hrbnd). - - pose proof CRealLowerBoundSpec r Hrpos k ltac:(lia) as Hlowbnd. - - rewrite Qpower_plus; [|lra]. - apply Qmult_le_compat_nonneg. - { pose proof Qpower_pos 2 n; split; lra. } - split. - - apply Qpower_pos; lra. - - rewrite Qabs_pos; [lra|]. - pose proof Qpower_0_lt 2 (CRealLowerBound r Hrpos)%Z ltac:(lra) as Hpow. - lra. -Qed. - -Lemma CReal_inv_l : forall (r:CReal) (rnz : r # 0), - ((/ r) rnz) * r == 1. -Proof. - intros. unfold CReal_inv. destruct rnz. - - rewrite <- CReal_opp_mult_distr_l, CReal_opp_mult_distr_r. - apply CReal_inv_l_pos. - - apply CReal_inv_l_pos. -Qed. - -Lemma CReal_inv_r : forall (r:CReal) (rnz : r # 0), - r * ((/ r) rnz) == 1. -Proof. - intros. rewrite CReal_mult_comm, CReal_inv_l. - reflexivity. -Qed. - -Lemma CReal_inv_1 : forall nz : 1 # 0, (/ 1) nz == 1. -Proof. - intros. rewrite <- (CReal_mult_1_l ((/1) nz)). rewrite CReal_inv_r. - reflexivity. -Qed. - -Lemma CReal_inv_mult_distr : - forall r1 r2 (r1nz : r1 # 0) (r2nz : r2 # 0) (rmnz : (r1*r2) # 0), - (/ (r1 * r2)) rmnz == (/ r1) r1nz * (/ r2) r2nz. -Proof. - intros. apply (CReal_mult_eq_reg_l r1). - - exact r1nz. - - rewrite <- CReal_mult_assoc. rewrite CReal_inv_r. rewrite CReal_mult_1_l. - apply (CReal_mult_eq_reg_l r2). - + exact r2nz. - + rewrite CReal_inv_r. rewrite <- CReal_mult_assoc. - rewrite (CReal_mult_comm r2 r1). rewrite CReal_inv_r. - reflexivity. -Qed. - -Lemma Rinv_eq_compat : forall x y (rxnz : x # 0) (rynz : y # 0), - x == y - -> (/ x) rxnz == (/ y) rynz. -Proof. - intros. apply (CReal_mult_eq_reg_l x). - - exact rxnz. - - rewrite CReal_inv_r, H, CReal_inv_r. reflexivity. -Qed. - -Lemma CReal_mult_lt_reg_l : forall r r1 r2, 0 < r -> r * r1 < r * r2 -> r1 < r2. -Proof. - intros z x y H H0. - apply (CReal_mult_lt_compat_l ((/z) (inr H))) in H0. - - repeat rewrite <- CReal_mult_assoc in H0. rewrite CReal_inv_l in H0. - repeat rewrite CReal_mult_1_l in H0. apply H0. - - apply CReal_inv_0_lt_compat. exact H. -Qed. - -Lemma CReal_mult_lt_reg_r : forall r r1 r2, 0 < r -> r1 * r < r2 * r -> r1 < r2. -Proof. - intros. - apply CReal_mult_lt_reg_l with r. - - exact H. - - now rewrite 2!(CReal_mult_comm r). -Qed. - -Lemma CReal_mult_eq_reg_r : forall r r1 r2, r1 * r == r2 * r -> r # 0 -> r1 == r2. -Proof. - intros. apply (CReal_mult_eq_reg_l r). - - exact H0. - - now rewrite 2!(CReal_mult_comm r). -Qed. - -Lemma CReal_mult_eq_compat_l : forall r r1 r2, r1 == r2 -> r * r1 == r * r2. -Proof. - intros. rewrite H. reflexivity. -Qed. - -Lemma CReal_mult_eq_compat_r : forall r r1 r2, r1 == r2 -> r1 * r == r2 * r. -Proof. - intros. rewrite H. reflexivity. -Qed. - -(* In particular x * y == 1 implies that 0 # x, 0 # y and - that x and y are inverses of each other. *) -Lemma CReal_mult_pos_appart_zero : forall x y : CReal, 0 < x * y -> 0 # x. -Proof. - intros x y H0ltxy. - unfold CRealLt, CReal_mult, CReal_mult_seq, CReal_mult_scale in H0ltxy; - rewrite CReal_red_seq in H0ltxy. - destruct H0ltxy as [n nmaj]. - cbn in nmaj; setoid_rewrite Qplus_0_r in nmaj. - destruct (Q_dec 0 (seq y (n - scale x - 1)))%Q as [[H0lty|Hylt0]|Hyeq0]. - - apply (Qmult_lt_compat_r _ _ (/(seq y (n - scale x - 1)))%Q ) in nmaj. - 2: apply Qinv_lt_0_compat, H0lty. - setoid_rewrite <- Qmult_assoc in nmaj at 2. - setoid_rewrite Qmult_inv_r in nmaj. - 2: lra. - setoid_rewrite Qmult_1_r in nmaj. - pose proof bound y (n - scale x - 1)%Z as Hybnd. - apply Qabs_Qlt_condition, proj2 in Hybnd. - apply Qinv_lt_contravar in Hybnd. - 3: apply Qpower_0_lt; lra. - 2: exact H0lty. - apply (Qmult_lt_l _ _ (2 * (2 ^ n))) in Hybnd. - 2: pose proof Qpower_0_lt 2 n; lra. - apply (Qlt_trans _ _ _ Hybnd) in nmaj; clear Hybnd. - rewrite <- Qpower_opp, <- Qmult_assoc, <- Qpower_plus in nmaj by lra. - apply (CReal_abs_appart_zero x (n - scale y - 1)%Z), Qabs_gt. - rewrite Qpower_minus_pos. - ring_simplify. ring_simplify (n + - scale y)%Z in nmaj. - pose proof Qpower_0_lt 2 (n - scale y)%Z; lra. - - (* This proof is the same as above, except that we swap the signs of x and y *) - (* ToDo: maybe assert teh goal for arbitrary y>0 and then apply twice *) - assert (forall a b : Q, ((-a)*(-b)==a*b)%Q) by (intros; ring). - setoid_rewrite <- H in nmaj at 2; clear H. - apply (Qmult_lt_compat_r _ _ (/-(seq y (n - scale x - 1)))%Q ) in nmaj. - 2: apply Qinv_lt_0_compat; lra. - setoid_rewrite <- Qmult_assoc in nmaj at 2. - setoid_rewrite Qmult_inv_r in nmaj. - 2: lra. - setoid_rewrite Qmult_1_r in nmaj. - pose proof bound y (n - scale x - 1)%Z as Hybnd. - apply Qabs_Qlt_condition, proj1 in Hybnd. - apply Qopp_lt_compat in Hybnd; rewrite Qopp_involutive in Hybnd. - apply Qinv_lt_contravar in Hybnd. - 3: apply Qpower_0_lt; lra. - 2: lra. - apply (Qmult_lt_l _ _ (2 * (2 ^ n))) in Hybnd. - 2: pose proof Qpower_0_lt 2 n; lra. - apply (Qlt_trans _ _ _ Hybnd) in nmaj; clear Hybnd. - rewrite <- Qpower_opp, <- Qmult_assoc, <- Qpower_plus in nmaj by lra. - apply (CReal_abs_appart_zero x (n - scale y - 1)%Z). - pose proof Qpower_0_lt 2 (n + - scale y)%Z ltac:(lra) as Hpowpos. - rewrite Qabs_neg by lra. - rewrite Qpower_minus_pos. - ring_simplify. ring_simplify (n + - scale y)%Z in nmaj. - pose proof Qpower_0_lt 2 (n - scale y)%Z; lra. - - pose proof Qpower_0_lt 2 n ltac:(lra). - rewrite <- Hyeq0 in nmaj. lra. -Qed. - -Fixpoint pow (r:CReal) (n:nat) : CReal := - match n with - | O => 1 - | S n => r * (pow r n) - end. - - -Lemma CReal_mult_le_compat_l_half : forall r r1 r2, - 0 < r -> r1 <= r2 -> r * r1 <= r * r2. -Proof. - intros. intro abs. apply (CReal_mult_lt_reg_l) in abs. - - contradiction. - - apply H. -Qed. - -Lemma CReal_invQ : forall (b : positive) (pos : Qlt 0 (Z.pos b # 1)), - CReal_inv (inject_Q (Z.pos b # 1)) (inr (CReal_injectQPos (Z.pos b # 1) pos)) - == inject_Q (1 # b). -Proof. - intros. - apply (CReal_mult_eq_reg_l (inject_Q (Z.pos b # 1))). - - right. apply CReal_injectQPos. exact pos. - - rewrite CReal_mult_comm, CReal_inv_l. - apply CRealEq_diff. intro n. simpl. - do 2 rewrite Pos.mul_1_r. rewrite Z.pos_sub_diag. - pose proof Qpower_pos 2 n ltac:(lra). rewrite Z.abs_0, Qreduce_zero. lra. -Qed. - -Definition CRealQ_dense (a b : CReal) - : a < b -> { q : Q & a < inject_Q q < b }. -Proof. - (* Locate a and b at the index given by a 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 -> Nat.succ_le_mono; apply Nat.le_0_l. } - 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/stdlib/theories/Reals/Cauchy/ConstructiveExtra.v b/stdlib/theories/Reals/Cauchy/ConstructiveExtra.v deleted file mode 100644 index 0307a6a644db..000000000000 --- a/stdlib/theories/Reals/Cauchy/ConstructiveExtra.v +++ /dev/null @@ -1,76 +0,0 @@ -Require Import ZArith. -Require Import ConstructiveEpsilon. - -Definition Z_inj_nat (z : Z) : nat := - match z with - | Z0 => 0 - | Zpos p => Pos.to_nat (p~0) - | Zneg p => Pos.to_nat (Pos.pred_double p) - end. - -Definition Z_inj_nat_rev (n : nat) : Z := - match n with - | O => 0 - | S n' => match Pos.of_nat n with - | xH => Zneg xH - | xO p => Zpos p - | xI p => Zneg (Pos.succ p) - end - end. - -Lemma Pos_pred_double_inj: forall (p q : positive), - Pos.pred_double p = Pos.pred_double q -> p = q. -Proof. - intros p q H. - apply (f_equal Pos.succ) in H. - do 2 rewrite Pos.succ_pred_double in H. - inversion H; reflexivity. -Qed. - -Lemma Z_inj_nat_id: forall (z : Z), - Z_inj_nat_rev (Z_inj_nat z) = z. -Proof. - intros z. - unfold Z_inj_nat, Z_inj_nat_rev. - destruct z eqn:Hdz. - - reflexivity. - - rewrite Pos2Nat.id. - destruct (Pos.to_nat p~0) eqn:Hd. - + pose proof Pos2Nat.is_pos p~0 as H. - rewrite <- Nat.neq_0_lt_0 in H. - exfalso; apply H, Hd. - + reflexivity. - - rewrite Pos2Nat.id. - destruct (Pos.to_nat (Pos.pred_double p)) eqn: Hd. - + pose proof Pos2Nat.is_pos (Pos.pred_double p) as H. - rewrite <- Nat.neq_0_lt_0 in H. - exfalso; apply H, Hd. - + destruct (Pos.pred_double p) eqn:Hd2. - * rewrite <- Pos.pred_double_succ in Hd2. - apply Pos_pred_double_inj in Hd2. - rewrite Hd2; reflexivity. - * apply (f_equal Pos.succ) in Hd2. - rewrite Pos.succ_pred_double in Hd2. - rewrite <- Pos.xI_succ_xO in Hd2. - inversion Hd2. - * change xH with (Pos.pred_double xH) in Hd2. - apply Pos_pred_double_inj in Hd2. - rewrite Hd2; reflexivity. -Qed. - -Lemma Z_inj_nat_inj: forall (x y : Z), - Z_inj_nat x = Z_inj_nat y -> x = y. -Proof. - intros x y H. - apply (f_equal Z_inj_nat_rev) in H. - do 2 rewrite Z_inj_nat_id in H. - assumption. -Qed. - -Lemma constructive_indefinite_ground_description_Z: - forall P : Z -> Prop, - (forall z : Z, {P z} + {~ P z}) -> - (exists z : Z, P z) -> {z : Z | P z}. -Proof. - apply (constructive_indefinite_ground_description Z Z_inj_nat Z_inj_nat_rev Z_inj_nat_id). -Qed. diff --git a/stdlib/theories/Reals/Cauchy/ConstructiveRcomplete.v b/stdlib/theories/Reals/Cauchy/ConstructiveRcomplete.v deleted file mode 100644 index d9b0157f631a..000000000000 --- a/stdlib/theories/Reals/Cauchy/ConstructiveRcomplete.v +++ /dev/null @@ -1,751 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* CReal) (l : CReal) : Set - := forall p : positive, - { n : nat | forall i:nat, le n i -> CReal_abs (un i - l) <= inject_Q (1#p) }. - -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. intro p. specialize (H p) as [n H]. - exists n. intros. rewrite <- H0. apply H, H1. -Qed. - -#[global] -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. - - -(* Sharpen the archimedean property : constructive versions of - the usual floor and ceiling functions. *) -Definition Rfloor (a : CReal) - : { p : Z & inject_Q (p#1) < a < inject_Q (p#1) + 2 }. -Proof. - destruct (CRealArchimedean a) as [n [H H0]]. - exists (n-2)%Z. split. - - setoid_replace (n - 2 # 1)%Q with ((n#1) + - 2)%Q. - + rewrite inject_Q_plus, (opp_inject_Q 2). - apply (CReal_plus_lt_reg_r 2). ring_simplify. - rewrite CReal_plus_comm. exact H0. - + rewrite Qinv_plus_distr. reflexivity. - - setoid_replace (n - 2 # 1)%Q with ((n#1) + - 2)%Q. - + rewrite inject_Q_plus, (opp_inject_Q 2). - ring_simplify. exact H. - + rewrite Qinv_plus_distr. reflexivity. -Qed. - -(* ToDo: Move to ConstructiveCauchyAbs.v *) -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. - -Lemma Qlt_trans_swap_hyp: forall x y z : Q, - (y < z)%Q -> (x < y)%Q -> (x < z)%Q. -Proof. - intros x y z H1 H2. - apply (Qlt_trans x y z); assumption. -Qed. - -Lemma Qle_trans_swap_hyp: forall x y z : Q, - (y <= z)%Q -> (x <= y)%Q -> (x <= z)%Q. -Proof. - intros x y z H1 H2. - apply (Qle_trans x y z); assumption. -Qed. - -(** This inequality is tight since it is equal for n=1 and n=2 *) - -Lemma Qpower_2powneg_le_inv: forall (n : positive), - (2 * 2 ^ Z.neg n <= 1 # n)%Q. -Proof. - intros n. - induction n using Pos.peano_ind. - - cbn. lra. - - rewrite <- Pos2Z.opp_pos, Pos2Z.inj_succ, Z.opp_succ, Pos2Z.opp_pos, <- Z.sub_1_r. - rewrite Qpower_minus_pos. - ring_simplify. - apply (Qmult_le_l _ _ (1#2)) in IHn. - 2: lra. - ring_simplify in IHn. - apply (Qle_trans _ _ _ IHn). - unfold Qle, Qmult, Qnum, Qden. - ring_simplify; rewrite Pos2Z.inj_succ, <- Z.add_1_l. - clear IHn; induction n using Pos.peano_ind. - + reflexivity. - + rewrite Pos2Z.inj_succ, <- Z.add_1_l. - (* ToDo: does this lemma really need to be named like this and have this statement? *) - rewrite <- POrderedType.Positive_as_OT.add_1_l. - rewrite POrderedType.Positive_as_OT.mul_add_distr_l. - rewrite Pos2Z.inj_add. - apply Z.add_le_mono. - * lia. - * exact IHn. -Qed. - -Lemma Pospow_lin_le_2pow: forall (n : positive), - (2 * n <= 2 ^ n)%positive. -Proof. - intros n. - induction n using Pos.peano_ind. - - cbn. lia. - - rewrite Pos.mul_succ_r, Pos.pow_succ_r. - lia. -Qed. - -Lemma CReal_cv_self : forall (x : CReal) (n : positive), - CReal_abs (x - inject_Q (seq x (Z.neg n))) <= inject_Q (1#n). -Proof. - intros x n. - (* ToDo: CRealLt_asym should be names CRealLt_Le_weak and asym should be x False *) - apply CRealLt_asym. - apply (CRealLt_RQ_from_single_dist _ _ (Z.neg n - 1)%Z). - unfold CReal_abs, CReal_abs_seq, CReal_abs_scale. - unfold CReal_minus, CReal_plus, CReal_plus_seq, CReal_abs_scale. - unfold CReal_opp, CReal_opp_seq, CReal_opp_scale. - unfold inject_Q. - do 4 rewrite CReal_red_seq; rewrite Qred_correct. - ring_simplify (Z.neg n - 1 - 1)%Z. - pose proof cauchy x (Z.neg n) (Z.neg n - 2)%Z (Z.neg n) ltac:(lia) ltac:(lia) as Hxbnd. - apply Qopp_lt_compat in Hxbnd. - apply (Qplus_lt_r _ _ (1#n)) in Hxbnd. - apply (Qlt_trans_swap_hyp _ _ _ Hxbnd); clear Hxbnd x. - rewrite Qpower_minus_pos. - apply (Qplus_lt_r _ _ (2 ^ Z.neg n)%Q); ring_simplify. - pose proof Qpower_2powneg_le_inv n as Hpowinv. - pose proof Qpower_0_lt 2 (Z.neg n) ltac:(lra) as Hpowpos. - lra. -Qed. - -Lemma CReal_cv_self' : forall (x : CReal) (n : Z), - CReal_abs (x - inject_Q (seq x n)) <= inject_Q (2^n). -Proof. - intros x n [k kmaj]. - unfold CReal_abs, CReal_abs_seq, CReal_abs_scale in kmaj. - unfold CReal_minus, CReal_plus, CReal_plus_seq, CReal_abs_scale in kmaj. - unfold CReal_opp, CReal_opp_seq, CReal_opp_scale in kmaj. - unfold inject_Q in kmaj. - do 4 rewrite CReal_red_seq in kmaj; rewrite Qred_correct in kmaj. - apply (Qlt_not_le _ _ kmaj). clear kmaj. - rewrite CReal_red_seq. - apply (Qplus_le_l _ _ (2^n)%Q); ring_simplify. - pose proof cauchy x (Z.max (k-1)%Z n) (k-1)%Z n ltac:(lia) ltac:(lia) as Hxbnd. - apply Qlt_le_weak in Hxbnd. - apply (Qle_trans _ _ _ Hxbnd); clear Hxbnd. - apply Z.max_case. - - rewrite <- Qplus_0_l; apply Qplus_le_compat. - + apply Qpower_pos; lra. - + rewrite Qpower_minus_pos. - pose proof (Qpower_0_lt 2 k)%Q; lra. - - rewrite <- Qplus_0_r; apply Qplus_le_compat. - + lra. - + pose proof (Qpower_0_lt 2 k)%Q; lra. -Qed. - -Definition QCauchySeqLin (un : positive -> Q) - : Prop - := forall (k : positive) (p q : positive), - Pos.le k p - -> Pos.le k q - -> Qlt (Qabs (un p - un q)) (1 # k). - -(* We can probably reduce the factor 4. *) -Lemma Rcauchy_limit : forall (xn : nat -> CReal) (xcau : Un_cauchy_mod xn), - QCauchySeqLin - (fun n : positive => - let (p, _) := xcau (4 * n)%positive in seq (xn p) (4 * Z.neg n)%Z). -Proof. - intros xn xcau n p q Hp Hq. - destruct (xcau (4 * p)%positive) as [i imaj], - (xcau (4 * q)%positive) as [j jmaj]. - assert (CReal_abs (xn i - xn j) <= inject_Q (1 # 4 * n)). - { destruct (Nat.leb_spec i j) as [l|l]. - - apply (CReal_le_trans _ _ _ (imaj i j (Nat.le_refl _) l)). - apply inject_Q_le. unfold Qle, Qnum, Qden. - rewrite Z.mul_1_l, Z.mul_1_l. apply Pos2Z.pos_le_pos. - apply Pos.mul_le_mono_l, Hp. - - apply le_S, le_S_n in l. - apply (CReal_le_trans _ _ _ (jmaj i j l (Nat.le_refl _))). - apply inject_Q_le. unfold Qle, Qnum, Qden. - rewrite Z.mul_1_l, Z.mul_1_l. apply Pos2Z.pos_le_pos. - apply Pos.mul_le_mono_l, Hq. } - clear jmaj imaj. - setoid_replace (1#n)%Q with ((1#(3*n)) + ((1#(3*n)) + (1#(3*n))))%Q. - 2: rewrite Qinv_plus_distr, Qinv_plus_distr; reflexivity. - apply lt_inject_Q. rewrite inject_Q_plus. - rewrite Qabs_Rabs. - apply (CReal_le_lt_trans _ (CReal_abs (inject_Q (seq (xn i) (4 * Z.neg p)%Z) - xn i) + CReal_abs (xn i - inject_Q(seq (xn j) (4 * Z.neg q)%Z)))). - - unfold Qminus. - rewrite inject_Q_plus, opp_inject_Q. - setoid_replace (inject_Q (seq (xn i) (4 * Z.neg p)%Z) + - - inject_Q (seq (xn j) (4 * Z.neg q)%Z)) - with (inject_Q (seq (xn i) (4 * Z.neg p)%Z) - xn i - + (xn i - inject_Q (seq (xn j) (4 * Z.neg q)%Z))). - 2: ring. - apply CReal_abs_triang. - - apply CReal_plus_le_lt_compat. - + rewrite CReal_abs_minus_sym. apply (CReal_le_trans _ (inject_Q (1# 4*p))). - * apply CReal_cv_self. - * apply inject_Q_le. unfold Qle, Qnum, Qden. - rewrite Z.mul_1_l, Z.mul_1_l. - apply Pos2Z.pos_le_pos. apply (Pos.le_trans _ (4*n)). - -- apply Pos.mul_le_mono_r. discriminate. - -- apply Pos.mul_le_mono_l. exact Hp. - + apply (CReal_le_lt_trans - _ (CReal_abs (xn i - xn j + (xn j - inject_Q (seq (xn j) (4 * Z.neg q)%Z))))). - * apply CReal_abs_morph. ring. - * apply (CReal_le_lt_trans _ _ _ (CReal_abs_triang _ _)). - rewrite inject_Q_plus. apply CReal_plus_le_lt_compat. - -- apply (CReal_le_trans _ _ _ H). apply inject_Q_le. - unfold Qle, Qnum, Qden. rewrite Z.mul_1_l, Z.mul_1_l. - apply Pos2Z.pos_le_pos. apply Pos.mul_le_mono_r. discriminate. - -- apply (CReal_le_lt_trans _ (inject_Q (1#4*q))). - ++ apply CReal_cv_self. - ++ apply inject_Q_lt. unfold Qlt, Qnum, Qden. - rewrite Z.mul_1_l, Z.mul_1_l. - apply Pos2Z.pos_lt_pos. apply (Pos.lt_le_trans _ (4*n)). - ** apply Pos.mul_lt_mono_r. reflexivity. - ** apply Pos.mul_le_mono_l. exact Hq. -Qed. - -Definition CReal_from_cauchy_cm (n : Z) : positive := - match n with - | Z0 - | Zpos _ => 1%positive - | Zneg p => p - end. - -Lemma CReal_from_cauchy_cm_mono : forall (n p : Z), - (p <= n)%Z - -> (CReal_from_cauchy_cm n <= CReal_from_cauchy_cm p)%positive. -Proof. - intros n p Hpn. - unfold CReal_from_cauchy_cm; destruct n; destruct p; lia. -Qed. - -Definition CReal_from_cauchy_seq (xn : nat -> CReal) (xcau : Un_cauchy_mod xn) (n : Z) : Q := - let p := CReal_from_cauchy_cm n in - let (q, _) := xcau (4 * 2^p)%positive in - seq (xn q) (Z.neg p - 2)%Z. - -Lemma CReal_from_cauchy_cauchy : forall (xn : nat -> CReal) (xcau : Un_cauchy_mod xn), - QCauchySeq (CReal_from_cauchy_seq xn xcau). -Proof. - intros xn xcau n p q Hp Hq. - remember (CReal_from_cauchy_cm n) as n'. - remember (CReal_from_cauchy_cm p) as p'. - remember (CReal_from_cauchy_cm q) as q'. - unfold CReal_from_cauchy_seq. - rewrite <- Heqp', <- Heqq'. - destruct (xcau (4 * 2^p')%positive) as [i imaj]. - destruct (xcau (4 * 2^q')%positive) as [j jmaj]. - assert (CReal_abs (xn i - xn j) <= inject_Q (1 # 4 * 2^n')). - { destruct (Nat.leb_spec i j) as [l|l]. - - apply (CReal_le_trans _ _ _ (imaj i j (Nat.le_refl _) l)). - apply inject_Q_le. unfold Qle, Qnum, Qden. - rewrite Z.mul_1_l, Z.mul_1_l. apply Pos2Z.pos_le_pos. - subst; apply Pos.mul_le_mono_l, Pos_pow_le_mono_r, CReal_from_cauchy_cm_mono, Hp. - - apply le_S, le_S_n in l. - apply (CReal_le_trans _ _ _ (jmaj i j l (Nat.le_refl _))). - apply inject_Q_le. unfold Qle, Qnum, Qden. - rewrite Z.mul_1_l, Z.mul_1_l. apply Pos2Z.pos_le_pos. - subst; apply Pos.mul_le_mono_l, Pos_pow_le_mono_r, CReal_from_cauchy_cm_mono, Hq. - } - clear jmaj imaj. - setoid_replace (2^n)%Q with ((1#3)*2^n + ((1#3)*2^n + (1#3)*2^n))%Q by ring. - apply lt_inject_Q. rewrite inject_Q_plus. - rewrite Qabs_Rabs. - apply (CReal_le_lt_trans _ (CReal_abs (inject_Q (seq (xn i) (Z.neg p' - 2)%Z) - xn i) + CReal_abs (xn i - inject_Q(seq (xn j) (Z.neg q' - 2)%Z)))). - { - unfold Qminus. - rewrite inject_Q_plus, opp_inject_Q. - setoid_replace (inject_Q (seq (xn i) (Z.neg p' - 2)%Z) + - - inject_Q (seq (xn j) (Z.neg q' - 2)%Z)) - with (inject_Q (seq (xn i) (Z.neg p' - 2)%Z) - xn i - + (xn i - inject_Q (seq (xn j) (Z.neg q' - 2)%Z))). - 2: ring. - apply CReal_abs_triang. - } - apply CReal_plus_le_lt_compat. - { - rewrite CReal_abs_minus_sym. - apply (CReal_le_trans _ (inject_Q ((1#4)*2^(Z.neg p')))). - - change (1#4)%Q with ((1#2)^2)%Q. - rewrite Qmult_comm, <- Qpower_minus_pos. - apply CReal_cv_self'. - - apply inject_Q_le. - apply Qmult_le_compat_nonneg. - + lra. - + { split. - - apply Qpower_pos; lra. - - apply Qpower_le_compat_l. - + subst; unfold CReal_from_cauchy_cm; destruct p; lia. - + lra. } - } - apply (CReal_le_lt_trans - _ (CReal_abs (xn i - xn j + (xn j - inject_Q (seq (xn j) (Z.neg q' - 2)%Z))))). - 1: apply CReal_abs_morph; ring. - apply (CReal_le_lt_trans _ _ _ (CReal_abs_triang _ _)). - rewrite inject_Q_plus. - apply CReal_plus_le_lt_compat. - { - apply (CReal_le_trans _ _ _ H). apply inject_Q_le. - rewrite Qmult_frac_l. - rewrite <- (Z.pow_1_l (Z.pos n')) at 2 by lia. - rewrite <- (Qpower_decomp_pos). - change (1#2)%Q with (/2)%Q; rewrite Qinv_power, <- Qpower_opp. - apply Qmult_le_compat_nonneg. - - lra. - - { split. - - apply Qpower_pos; lra. - - apply Qpower_le_compat_l. - + subst; unfold CReal_from_cauchy_cm; destruct n; lia. - + lra. } - } - apply (CReal_le_lt_trans _ (inject_Q ((1#4)*2^(Z.neg q')))). - { - change (1#4)%Q with ((1#2)^2)%Q. - rewrite Qmult_comm, <- Qpower_minus_pos. - apply CReal_cv_self'. - } - apply inject_Q_lt. - setoid_rewrite Qmult_comm at 1 2. - apply Qmult_le_lt_compat_pos. - + { split. - - apply Qpower_0_lt; lra. - - apply Qpower_le_compat_l. - + subst; unfold CReal_from_cauchy_cm. destruct q; lia. - + lra. } - + lra. -Qed. - -Lemma Rup_pos (x : CReal) - : { n : positive & x < inject_Q (Z.pos n # 1) }. -Proof. - intros. destruct (CRealArchimedean x) as [p [maj _]]. - destruct p. - - exists 1%positive. apply (CReal_lt_trans _ 0 _ maj). apply CRealLt_0_1. - - exists p. exact maj. - - exists 1%positive. apply (CReal_lt_trans _ (inject_Q (Z.neg p # 1)) _ maj). - apply (CReal_lt_trans _ 0). - + apply inject_Q_lt. reflexivity. - + apply CRealLt_0_1. -Qed. - -Lemma CReal_abs_upper_bound (x : CReal) - : { n : positive & CReal_abs x < inject_Q (Z.pos n # 1) }. -Proof. - intros. - destruct (Rup_pos x) as [np Hnp]. - destruct (Rup_pos (-x)) as [nn Hnn]. - exists (Pos.max np nn). - apply Rabs_def1. - - apply (CReal_lt_le_trans _ _ _ Hnp), inject_Q_le. - unfold Qle, Qnum, Qden; ring_simplify. lia. - - apply (CReal_lt_le_trans _ _ _ Hnn), inject_Q_le. - unfold Qle, Qnum, Qden; ring_simplify. lia. -Qed. - -Require Import Qminmax. - -Lemma CRealLt_QR_from_single_dist : forall (q : Q) (r : CReal) (n :Z), - (2^n < seq r n - q)%Q - -> inject_Q q < r . -Proof. - intros q r n Hapart. - pose proof Qpower_0_lt 2 n ltac:(lra) as H2npos. - destruct (QarchimedeanLowExp2_Z (seq r n - q - 2^n) ltac:(lra)) as [k Hk]. - unfold CRealLt; exists (Z.min n (k-1))%Z. - unfold inject_Q; rewrite CReal_red_seq. - pose proof cauchy r n n (Z.min n (k-1))%Z ltac:(lia) ltac:(lia) as Hrbnd. - pose proof Qpower_le_compat_l 2 (Z.min n (k - 1))%Z (k-1)%Z ltac:(lia) ltac:(lra). - apply (Qmult_le_l _ _ 2 ltac:(lra)) in H. - apply (Qle_lt_trans _ _ _ H); clear H. - rewrite Qpower_minus_pos. - ring_simplify. - apply Qabs_Qlt_condition in Hrbnd. - lra. -Qed. - -Lemma CReal_abs_Qabs: forall (x : CReal) (q : Q) (n : Z), - CReal_abs x <= inject_Q q - -> (Qabs (seq x n) <= q + 2^n)%Q. -Proof. - intros x q n Hr. - unfold CRealLe in Hr. - apply Qnot_lt_le; intros Hq; apply Hr; clear Hr. - apply (CRealLt_QR_from_single_dist _ _ n%Z). - unfold CReal_abs, CReal_abs_seq; rewrite CReal_red_seq. - lra. -Qed. - -Lemma CReal_abs_Qabs_seq: forall (x : CReal) (n : Z), - (seq (CReal_abs x) n == Qabs (seq x n))%Q. -Proof. - intros x n. - unfold CReal_abs, CReal_abs_seq; rewrite CReal_red_seq. - reflexivity. -Qed. - -Lemma CReal_abs_Qabs_diff: forall (x y : CReal) (q : Q) (n : Z), - CReal_abs (x - y) <= inject_Q q - -> (Qabs (seq x n - seq y n) <= q + 2*2^n)%Q. -Proof. - intros x y q n Hr. - unfold CRealLe in Hr. - apply Qnot_lt_le; intros Hq; apply Hr; clear Hr. - apply (CRealLt_QR_from_single_dist _ _ (n+1)%Z). - unfold CReal_abs, CReal_abs_seq; rewrite CReal_red_seq. - unfold CReal_minus, CReal_plus, CReal_plus_seq; rewrite CReal_red_seq, Qred_correct. - unfold CReal_opp, CReal_opp_seq; rewrite CReal_red_seq. - ring_simplify (n + 1 - 1)%Z. - rewrite Qpower_plus by lra. - ring_simplify; change (seq x n + - seq y n)%Q with (seq x n - seq y n)%Q. - lra. -Qed. - -(** Note: the <= in the conclusion is likely tight *) - -Lemma CRealLt_QR_to_single_dist : forall (q : Q) (x : CReal) (n : Z), - inject_Q q < x -> (-(2^n) <= seq x n - q)%Q. -Proof. - intros q x n Hqltx. - destruct (Qlt_le_dec (seq x n - q) (-(2^n)) ) as [Hdec|Hdec]. - - exfalso. - pose proof CRealLt_RQ_from_single_dist x q n ltac:(lra) as contra. - apply CRealLt_asym in contra. apply contra, Hqltx. - - apply Hdec. -Qed. - -Lemma CRealLt_RQ_to_single_dist : forall (x : CReal) (q : Q) (n : Z), - x < inject_Q q -> (-(2^n) <= q - seq x n)%Q. -Proof. - intros x q n Hxltq. - destruct (Qlt_le_dec (q - seq x n) (-(2^n)) ) as [Hdec|Hdec]. - - exfalso. - pose proof CRealLt_QR_from_single_dist q x n ltac:(lra) as contra. - apply CRealLt_asym in contra. apply contra, Hxltq. - - apply Hdec. -Qed. - -Lemma Pos2Z_pos_is_pos : forall (p : positive), - (1 <= Z.pos p)%Z. -Proof. - intros p. - lia. -Qed. - -Lemma Qabs_Qgt_condition: forall x y : Q, - (x < Qabs y)%Q <-> (x < y \/ x < -y)%Q. -Proof. - intros x y. - apply Qabs_case; lra. -Qed. - -Lemma CReal_from_cauchy_seq_bound : - forall (xn : nat -> CReal) (xcau : Un_cauchy_mod xn) (i j : Z), - (Qabs (CReal_from_cauchy_seq xn xcau i - CReal_from_cauchy_seq xn xcau j) <= 1)%Q. -Proof. - intros xn xcau i j. - unfold CReal_from_cauchy_seq. - destruct (xcau (4 * 2 ^ CReal_from_cauchy_cm i)%positive) as [i' imaj]. - destruct (xcau (4 * 2 ^ CReal_from_cauchy_cm j)%positive) as [j' jmaj]. - - assert (CReal_abs (xn i' - xn j') <= inject_Q (1#4)) as Hxij. - { - destruct (Nat.leb_spec i' j') as [l|l]. - - apply (CReal_le_trans _ _ _ (imaj i' j' (Nat.le_refl _) l)). - apply inject_Q_le; unfold Qle, Qnum, Qden; ring_simplify. - apply Pos2Z_pos_is_pos. - - apply le_S, le_S_n in l. - apply (CReal_le_trans _ _ _ (jmaj i' j' l (Nat.le_refl _))). - apply inject_Q_le; unfold Qle, Qnum, Qden; ring_simplify. - apply Pos2Z_pos_is_pos. - } - clear imaj jmaj. - unfold CReal_abs, CReal_abs_seq in Hxij. - unfold CRealLe, CRealLt in Hxij. - rewrite CReal_red_seq in Hxij. - apply Qnot_lt_le; intros Hxij'; apply Hxij; clear Hxij. - exists (-2)%Z. - unfold inject_Q; rewrite CReal_red_seq. - unfold CReal_minus, CReal_plus, CReal_plus_seq; rewrite CReal_red_seq, Qred_correct. - unfold CReal_opp, CReal_opp_seq; rewrite CReal_red_seq. - change (2 * 2 ^ (-2))%Q with (2#4)%Q. - pose proof cauchy (xn i') (-3)%Z (-3)%Z (Z.neg (CReal_from_cauchy_cm i) - 2)%Z - ltac:(lia) ltac:(unfold CReal_from_cauchy_cm; destruct i; lia) as Hxibnd. - pose proof cauchy (xn j') (-3)%Z (-3)%Z (Z.neg (CReal_from_cauchy_cm j) - 2)%Z - ltac:(lia) ltac:(unfold CReal_from_cauchy_cm; destruct j; lia) as Hxjbnd. - apply (Qplus_lt_l _ _ (1 # 4)%Q); ring_simplify. - (* ToDo: ring_simplify should return reduced fractions *) - setoid_replace (12#16)%Q with (3#4)%Q by ring. - change (2^(-3))%Q with (1#8)%Q in Hxibnd, Hxjbnd. - change (-2-1)%Z with (-3)%Z. - apply Qabs_Qlt_condition in Hxibnd. - apply Qabs_Qlt_condition in Hxjbnd. - apply Qabs_Qgt_condition. - apply Qabs_Qgt_condition in Hxij'. - lra. -Qed. - -Definition CReal_from_cauchy_scale (xn : nat -> CReal) (xcau : Un_cauchy_mod xn) : Z := - Qbound_lt_ZExp2 (Qabs (CReal_from_cauchy_seq xn xcau (-1)) + 2)%Q. - -Lemma CReal_from_cauchy_bound : forall (xn : nat -> CReal) (xcau : Un_cauchy_mod xn), - QBound (CReal_from_cauchy_seq xn xcau) (CReal_from_cauchy_scale xn xcau). -Proof. - intros xn xcau n. - unfold CReal_from_cauchy_scale. - - (* Use the spec of Qbound_lt_ZExp2 to linearize the RHS *) - apply (Qlt_trans_swap_hyp _ _ _ (Qbound_lt_ZExp2_spec _)). - - (* Massage the goal so that CReal_from_cauchy_seq_bound can be applied *) - apply (Qplus_lt_l _ _ (-Qabs (CReal_from_cauchy_seq xn xcau (-1)))%Q); ring_simplify. - assert(forall x y : Q, (x + -1*y == x-y)%Q) as Aux - by (intros x y; lra); rewrite Aux; clear Aux. - apply (Qle_lt_trans _ _ _ (Qabs_triangle_reverse _ _)). - apply (Qle_lt_trans _ 1%Q _). - 2: lra. - apply CReal_from_cauchy_seq_bound. -Qed. - -Definition CReal_from_cauchy (xn : nat -> CReal) (xcau : Un_cauchy_mod xn) : CReal := -{| - seq := CReal_from_cauchy_seq xn xcau; - scale := CReal_from_cauchy_scale xn xcau; - cauchy := CReal_from_cauchy_cauchy xn xcau; - bound := CReal_from_cauchy_bound xn xcau -|}. - -Lemma Rcauchy_complete : forall (xn : nat -> CReal), - Un_cauchy_mod xn - -> { l : CReal & seq_cv xn l }. -Proof. - intros xn cau. - exists (CReal_from_cauchy xn cau). - - intro p. - pose proof (CReal_cv_self' (CReal_from_cauchy xn cau) (Z.neg p - 1)%Z) as H. - - pose proof (cau (2*p)%positive) as [k cv]. - - rewrite CReal_abs_minus_sym in H. - unfold CReal_from_cauchy at 1 in H. - rewrite CReal_red_seq in H. - unfold CReal_from_cauchy_seq in H. - remember (CReal_from_cauchy_cm (Z.neg p - 1))%positive as i'. - destruct (cau (4 * 2 ^ i')%positive) as [i imaj]. - exists (max k i). - - intros j H0. - setoid_replace (xn j - CReal_from_cauchy xn cau) - with (xn j - inject_Q (seq (xn i) (Z.neg i' - 2)%Z) - + (inject_Q (seq (xn i) (Z.neg i' - 2)%Z) - CReal_from_cauchy xn cau)). - 2: ring. - apply (CReal_le_trans _ _ _ (CReal_abs_triang _ _)). - apply (CReal_le_trans _ (inject_Q (1#2*p) + inject_Q (1#2*p))). - - apply CReal_plus_le_compat. - 2: { apply (CReal_le_trans _ _ _ H). apply inject_Q_le. - rewrite Qpower_minus_pos. - assert(forall (n:Z) (p q : positive), n#(p*q) == (n#p) * (1#q))%Q as Aux - by ( intros; unfold Qeq, Qmult, Qnum, Qden; ring ); rewrite Aux; clear Aux. - rewrite Qmult_comm; apply Qmult_le_l; [lra|]. - pose proof Qpower_2powneg_le_inv p. - pose proof Qpower_0_lt 2 (Z.neg p)%Z; lra. } - - (* Use imaj to relate xn i and xn j *) - specialize (imaj j i (Nat.le_trans _ _ _ (Nat.le_max_r _ _) H0) (Nat.le_refl _)). - apply (CReal_le_trans _ (inject_Q (1 # 4 * p) + inject_Q (1 # 4 * p))). - + setoid_replace (xn j - inject_Q (seq (xn i) (Z.neg i' - 2))) - with (xn j - xn i + (xn i - inject_Q (seq (xn i) (Z.neg i' - 2)))). - 2: ring. - apply (CReal_le_trans _ _ _ (CReal_abs_triang _ _)). - apply CReal_plus_le_compat. - * apply (CReal_le_trans _ _ _ imaj). - rewrite Heqi'. change (Z.neg p - 1)%Z with (Z.neg (p + 1))%Z. - unfold CReal_from_cauchy_cm. - apply inject_Q_le. - unfold Qle, Qnum, Qden. - rewrite Z.mul_1_l, Z.mul_1_l. - apply Pos2Z.pos_le_pos, Pos.mul_le_mono_l. - pose proof Pospow_lin_le_2pow p. - rewrite Pos.add_1_r, Pos.pow_succ_r. - lia. - * clear imaj. - - (* Use CReal_cv_self' to relate xn i and seq (xn i) (...) *) - pose proof CReal_cv_self' (xn i) (Z.neg i' - 2). - apply (CReal_le_trans _ _ _ H1). - apply inject_Q_le. - rewrite Heqi'. change (Z.neg p - 1)%Z with (Z.neg (p + 1))%Z. - unfold CReal_from_cauchy_cm. - change (Z.neg (p + 1))%Z with (Z.neg p - 1)%Z. - ring_simplify (Z.neg p - 1 - 2)%Z. - rewrite Qpower_minus_pos. - assert(forall (n:Z) (p q : positive), n#(p*q) == (n#p) * (1#q))%Q as Aux - by ( intros; unfold Qeq, Qmult, Qnum, Qden; ring ); rewrite Aux; clear Aux. - pose proof Qpower_2powneg_le_inv p. - pose proof Qpower_0_lt 2 (Z.neg p)%Z; lra. - - + (* Solve remaining aux goals *) - rewrite <- inject_Q_plus. rewrite (inject_Q_morph _ (1#2*p)). - * apply CRealLe_refl. - * rewrite Qinv_plus_distr; reflexivity. - - rewrite <- inject_Q_plus. rewrite (inject_Q_morph _ (1#p)). - + apply CRealLe_refl. - + rewrite Qinv_plus_distr; reflexivity. -Qed. - -Lemma CRealLtIsLinear : isLinearOrder CRealLt. -Proof. - 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. -Qed. - -Lemma Qnot_le_iff_lt: forall x y : Q, - ~ (x <= y)%Q <-> (y < x)%Q. -Proof. - intros x y; split. - - apply Qnot_le_lt. - - apply Qlt_not_le. -Qed. - -Lemma Qnot_lt_iff_le: forall x y : Q, - ~ (x < y)%Q <-> (y <= x)%Q. -Proof. - intros x y; split. - - apply Qnot_lt_le. - - apply Qle_not_lt. -Qed. - -Lemma CRealLtDisjunctEpsilon : forall a b c d : CReal, - (CRealLtProp a b \/ CRealLtProp c d) -> CRealLt a b + CRealLt c d. -Proof. - intros. - (* Combine both existentials into one *) - assert (exists n : Z, 2*2^n < seq b n - seq a n \/ 2*2^n < seq d n - seq c n)%Q. - { destruct H. - - destruct H as [n maj]. exists n. left. apply maj. - - destruct H as [n maj]. exists n. right. apply maj. } - apply constructive_indefinite_ground_description_Z in H0. - - destruct H0 as [n maj]. - destruct (Qlt_le_dec (2 * 2^n) (seq b n - seq a n)). - + left. exists n. apply q. - + assert (2 * 2^n < seq d n - seq c n)%Q. - { destruct maj. - - exfalso. - apply (Qlt_not_le (2 * 2^n) (seq b n - seq a n)); assumption. - - assumption. } - clear maj. right. exists n. - apply H0. - - clear H0 H. intro n. - destruct (Qlt_le_dec (2 * 2 ^ n)%Q (seq b n - seq a n)%Q) as [H1|H1]. - + now left; left. - + destruct (Qlt_le_dec (2 * 2 ^ n)%Q (seq d n - seq c n)%Q) as [H2|H2]. - * now left; right. - * now right; intros [H3|H3]; apply Qle_not_lt with (2 := H3). -Qed. - -Definition CRealConstructive : ConstructiveReals - := Build_ConstructiveReals - CReal CRealLt CRealLtIsLinear CRealLtProp - CRealLtEpsilon CRealLtForget CRealLtDisjunctEpsilon - inject_Q inject_Q_lt lt_inject_Q - CReal_plus CReal_opp CReal_mult - inject_Q_plus inject_Q_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 - CRealQ_dense Rup_pos CReal_abs CRealAbsLUB CRealComplete. diff --git a/stdlib/theories/Reals/Cauchy/PosExtra.v b/stdlib/theories/Reals/Cauchy/PosExtra.v deleted file mode 100644 index 8f4d5c4fa469..000000000000 --- a/stdlib/theories/Reals/Cauchy/PosExtra.v +++ /dev/null @@ -1,32 +0,0 @@ -Require Import PArith. -Require Import ZArith. -Require Import Lia. - -Lemma Pos_pow_1_r: forall p : positive, - (1^p = 1)%positive. -Proof. - intros p. - assert (forall q:positive, Pos.iter id 1 q = 1)%positive as H1. - { intros q; apply Pos.iter_invariant; tauto. } - induction p. - - cbn; rewrite IHp, H1; reflexivity. - - cbn; rewrite IHp, H1; reflexivity. - - reflexivity. -Qed. - -Lemma Pos_le_multiple : forall n p : positive, (n <= p * n)%positive. -Proof. - intros n p. - rewrite <- (Pos.mul_1_l n) at 1. - apply Pos.mul_le_mono_r. - destruct p; discriminate. -Qed. - -Lemma Pos_pow_le_mono_r : forall a b c : positive, - (b <= c)%positive - -> (a ^ b <= a ^ c)%positive. -Proof. - intros a b c. - pose proof Z.pow_le_mono_r (Z.pos a) (Z.pos b) (Z.pos c). - lia. -Qed. diff --git a/stdlib/theories/Reals/Cauchy/QExtra.v b/stdlib/theories/Reals/Cauchy/QExtra.v deleted file mode 100644 index 190c9b38dcc6..000000000000 --- a/stdlib/theories/Reals/Cauchy/QExtra.v +++ /dev/null @@ -1,257 +0,0 @@ -Require Import QArith. -Require Import Qpower. -Require Import Qabs. -Require Import Qround. -Require Import Zorder. -Require Import Lia. -Require Import Lqa. (* This is only used in a few places and could be avoided *) -Require Import PosExtra. - -(** * Power of 2 open and closed upper and lower bounds for [q : Q] *) - -Fixpoint Pos_log2floor_plus1 (p : positive) : positive := - match p with - | (p'~1)%positive => Pos.succ (Pos_log2floor_plus1 p') - | (p'~0)%positive => Pos.succ (Pos_log2floor_plus1 p') - | 1%positive => 1 - end. - -Lemma Pos_log2floor_plus1_spec : forall (p : positive), - (Pos.pow 2 (Pos_log2floor_plus1 p) <= 2 * p < 2 * Pos.pow 2 (Pos_log2floor_plus1 p))%positive. -Proof. - intros p. - split. - - induction p. - + cbn. rewrite Pos.pow_succ_r. lia. - + cbn. rewrite Pos.pow_succ_r. lia. - + cbn. lia. - - induction p. - + cbn. rewrite Pos.pow_succ_r. lia. - + cbn. rewrite Pos.pow_succ_r. lia. - + cbn. lia. -Qed. - -Fixpoint Pos_log2ceil_plus1 (p : positive) : positive := - match p with - | (p'~1)%positive => Pos.succ (Pos.succ (Pos_log2floor_plus1 p')) - | (p'~0)%positive => Pos.succ (Pos_log2ceil_plus1 p') - | 1%positive => 1 - end. - -Lemma Pos_log2ceil_plus1_spec : forall (p : positive), - (Pos.pow 2 (Pos_log2ceil_plus1 p) < 4 * p <= 2 * Pos.pow 2 (Pos_log2ceil_plus1 p))%positive. -Proof. - intros p. - split. - - induction p. - + cbn. do 2 rewrite Pos.pow_succ_r. - pose proof Pos_log2floor_plus1_spec p. lia. - + cbn. rewrite Pos.pow_succ_r. lia. - + cbn. lia. - - induction p. - + cbn. do 2 rewrite Pos.pow_succ_r. - pose proof Pos_log2floor_plus1_spec p. lia. - + cbn. rewrite Pos.pow_succ_r. lia. - + cbn. lia. -Qed. - -Fixpoint Pos_is_pow2 (p : positive) : bool := - match p with - | (p'~1)%positive => false - | (p'~0)%positive => Pos_is_pow2 p' - | 1%positive => true - end. - -(** ** Power of two closed upper bound [q <= 2^z] *) - -Definition Qbound_le_ZExp2 (q : Q) : Z := - match Qnum q with - (* The -1000 is a compromise between a tight Archimedian and avoiding too large numbers *) - | Z0 => -1000 - | Zneg p => 0 - | Zpos p => (Z.pos (Pos_log2ceil_plus1 p) - Z.pos (Pos_log2floor_plus1 (Qden q)))%Z - end. - -Lemma Qbound_le_ZExp2_spec : forall (q : Q), - (q <= 2^(Qbound_le_ZExp2 q))%Q. -Proof. - intros q. - destruct q as [num den]; unfold Qbound_le_ZExp2, Qnum; destruct num. - - intros contra; inversion contra. - - rewrite Qpower_minus by lra. - apply Qle_shift_div_l. - + apply Qpower_0_lt; lra. - + do 2 rewrite Qpower_decomp_pos, Pos_pow_1_r. - unfold Qle, Qmult, Qnum, Qden. - rewrite Pos.mul_1_r, Z.mul_1_r. - pose proof Pos_log2ceil_plus1_spec p as Hnom. - pose proof Pos_log2floor_plus1_spec den as Hden. - - apply (Zorder.Zmult_le_reg_r _ _ 2). - * lia. - * replace (Z.pos p * 2 ^ Z.pos (Pos_log2floor_plus1 den) * 2)%Z - with ((Z.pos p * 2) * 2 ^ Z.pos (Pos_log2floor_plus1 den))%Z by ring. - replace (2 ^ Z.pos (Pos_log2ceil_plus1 p) * Z.pos den * 2)%Z - with (2 ^ Z.pos (Pos_log2ceil_plus1 p) * (Z.pos den * 2))%Z by ring. - apply Z.mul_le_mono_nonneg; lia. - - intros contra; inversion contra. -Qed. - -Definition Qbound_leabs_ZExp2 (q : Q) : Z := Qbound_le_ZExp2 (Qabs q). - -Lemma Qbound_leabs_ZExp2_spec : forall (q : Q), - (Qabs q <= 2^(Qbound_leabs_ZExp2 q))%Q. -Proof. - intros q. - unfold Qbound_leabs_ZExp2; apply Qabs_case; intros. - 1,2: apply Qbound_le_ZExp2_spec. -Qed. - -(** ** Power of two open upper bound [q < 2^z] and [Qabs q < 2^z] *) - -(** Compute a z such that q<2^z. - z shall be close to as small as possible, but we need a compromise between - the tighness of the bound and the computation speed and proof complexity. - Looking just at the log2 of the numerator and denominator, this is a tight bound - except when the numerator is a power of 2 and the denomintor is not. - E.g. this return 4/5 < 2^1 instead of 4/5< 2^0. - If q==0, we return -1000, because as binary integer this has just 10 bits but - 2^-1000 should be smaller than almost any number in practice. - If numbers are much smaller, computations might be inefficient. *) - -Definition Qbound_lt_ZExp2 (q : Q) : Z := - match Qnum q with - (* The -1000 is a compromise between a tight Archimedian and avoiding too large numbers *) - | Z0 => -1000 - | Zneg p => 0 - | Zpos p => Z.pos_sub (Pos.succ (Pos_log2floor_plus1 p)) (Pos_log2floor_plus1 (Qden q)) - end. - -Remark Qbound_lt_ZExp2_test_1 : Qbound_lt_ZExp2 (4#4) = 1%Z. reflexivity. Qed. -Remark Qbound_lt_ZExp2_test_2 : Qbound_lt_ZExp2 (5#4) = 1%Z. reflexivity. Qed. -Remark Qbound_lt_ZExp2_test_3 : Qbound_lt_ZExp2 (4#5) = 1%Z. reflexivity. Qed. -Remark Qbound_lt_ZExp2_test_4 : Qbound_lt_ZExp2 (7#5) = 1%Z. reflexivity. Qed. - -Lemma Qbound_lt_ZExp2_spec : forall (q : Q), - (q < 2^(Qbound_lt_ZExp2 q))%Q. -Proof. - intros q. - destruct q as [num den]; unfold Qbound_lt_ZExp2, Qnum; destruct num. - - reflexivity. - - (* Todo: A lemma like Pos2Z.add_neg_pos for minus would be nice *) - change - (Z.pos_sub (Pos.succ (Pos_log2floor_plus1 p)) (Pos_log2floor_plus1 (Qden (Z.pos p # den))))%Z - with - ((Z.pos (Pos.succ (Pos_log2floor_plus1 p)) - Z.pos (Pos_log2floor_plus1 (Qden (Z.pos p # den)))))%Z. - rewrite Qpower_minus by lra. - apply Qlt_shift_div_l. - + apply Qpower_0_lt; lra. - + do 2 rewrite Qpower_decomp_pos, Pos_pow_1_r. - unfold Qlt, Qmult, Qnum, Qden. - rewrite Pos.mul_1_r, Z.mul_1_r. - pose proof Pos_log2floor_plus1_spec p as Hnom. - pose proof Pos_log2floor_plus1_spec den as Hden. - apply (Zmult_lt_reg_r _ _ 2). - * lia. - * rewrite Pos2Z.inj_succ, <- Z.add_1_r. - rewrite Z.pow_add_r by lia. - - replace (Z.pos p * 2 ^ Z.pos (Pos_log2floor_plus1 den) * 2)%Z - with (2 ^ Z.pos (Pos_log2floor_plus1 den) * (Z.pos p * 2))%Z by ring. - replace (2 ^ Z.pos (Pos_log2floor_plus1 p) * 2 ^ 1 * Z.pos den * 2)%Z - with ((Z.pos den * 2) * (2 * 2 ^ Z.pos (Pos_log2floor_plus1 p)))%Z by ring. - - (* ToDo: this is weaker than neccessary: Z.mul_lt_mono_nonneg. *) - apply Zmult_lt_compat2; lia. - - cbn. - (* ToDo: lra could know that negative fractions are negative *) - assert (Z.neg p # den < 0) as Hnegfrac by (unfold Qlt, Qnum, Qden; lia). - lra. -Qed. - -Definition Qbound_ltabs_ZExp2 (q : Q) : Z := Qbound_lt_ZExp2 (Qabs q). - -Lemma Qbound_ltabs_ZExp2_spec : forall (q : Q), - (Qabs q < 2^(Qbound_ltabs_ZExp2 q))%Q. -Proof. - intros q. - unfold Qbound_ltabs_ZExp2; apply Qabs_case; intros. - 1,2: apply Qbound_lt_ZExp2_spec. -Qed. - -(** ** Power of 2 open lower bounds for [2^z < q] and [2^z < Qabs q] *) - -(** Note: the -2 is required cause of the Qlt limit. - In case q is a power of two, the lower and upper bound must be a factor of 4 apart *) -Definition Qlowbound_ltabs_ZExp2 (q : Q) : Z := -2 + Qbound_ltabs_ZExp2 q. - -Lemma Qlowbound_ltabs_ZExp2_inv: forall q : Q, - q > 0 - -> Qlowbound_ltabs_ZExp2 q = (- Qbound_ltabs_ZExp2 (/q))%Z. -Proof. - intros q Hqgt0. - destruct q as [n d]. - unfold Qlowbound_ltabs_ZExp2, Qbound_ltabs_ZExp2, Qbound_lt_ZExp2, Qnum. - destruct n. - - inversion Hqgt0. - - unfold Qabs, Z.abs, Qinv, Qnum, Qden. - rewrite -> Z.pos_sub_opp. - do 2 rewrite <- Pos2Z.add_pos_neg. - lia. - - inversion Hqgt0. -Qed. - -Lemma Qlowbound_ltabs_ZExp2_opp: forall q : Q, - (Qlowbound_ltabs_ZExp2 q = Qlowbound_ltabs_ZExp2 (-q))%Z. -Proof. - intros q. - destruct q as [[|n|n] d]; reflexivity. -Qed. - -Lemma Qlowbound_lt_ZExp2_spec : forall (q : Q) (Hqgt0 : q > 0), - (2^(Qlowbound_ltabs_ZExp2 q) < q)%Q. -Proof. - intros q Hqgt0. - pose proof Qbound_ltabs_ZExp2_spec (/q) as Hspecub. - rewrite Qlowbound_ltabs_ZExp2_inv by exact Hqgt0. - rewrite Qpower_opp. - setoid_rewrite <- (Qinv_involutive q) at 2. - apply -> Qinv_lt_contravar. - - rewrite Qabs_pos in Hspecub. - + exact Hspecub. - + apply Qlt_le_weak, Qinv_lt_0_compat, Hqgt0. - - apply Qpower_0_lt; lra. - - apply Qinv_lt_0_compat, Hqgt0. -Qed. - -Lemma Qlowbound_ltabs_ZExp2_spec : forall (q : Q) (Hqgt0 : ~ q == 0), - (2^(Qlowbound_ltabs_ZExp2 q) < Qabs q)%Q. -Proof. - intros q Hqgt0. - destruct (Q_dec 0 q) as [[H|H]|H]. - - rewrite Qabs_pos by lra. - apply Qlowbound_lt_ZExp2_spec, H. - - rewrite Qabs_neg by lra. - rewrite Qlowbound_ltabs_ZExp2_opp. - apply Qlowbound_lt_ZExp2_spec. - lra. - - lra. -Qed. - -(** ** Existential formulations of power of 2 lower and upper bounds *) - -Definition QarchimedeanExp2_Z (q : Q) - : {z : Z | (q < 2^z)%Q} - := exist _ (Qbound_lt_ZExp2 q) (Qbound_lt_ZExp2_spec q). - -Definition QarchimedeanAbsExp2_Z (q : Q) - : {z : Z | (Qabs q < 2^z)%Q} - := exist _ (Qbound_ltabs_ZExp2 q) (Qbound_ltabs_ZExp2_spec q). - -Definition QarchimedeanLowExp2_Z (q : Q) (Hqgt0 : q > 0) - : {z : Z | (2^z < q)%Q} - := exist _ (Qlowbound_ltabs_ZExp2 q) (Qlowbound_lt_ZExp2_spec q Hqgt0). - -Definition QarchimedeanLowAbsExp2_Z (q : Q) (Hqgt0 : ~ q == 0) - : {z : Z | (2^z < Qabs q)%Q} - := exist _ (Qlowbound_ltabs_ZExp2 q) (Qlowbound_ltabs_ZExp2_spec q Hqgt0). diff --git a/stdlib/theories/Reals/Cauchy_prod.v b/stdlib/theories/Reals/Cauchy_prod.v deleted file mode 100644 index f699c89e9554..000000000000 --- a/stdlib/theories/Reals/Cauchy_prod.v +++ /dev/null @@ -1,234 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* R) (N:nat), - (0 < N)%nat -> sum_f_R0 An N = sum_f_R0 An (pred N) + An N. -Proof. - intros. - replace N with (S (pred N)). - - rewrite tech5. - reflexivity. - - apply Nat.lt_succ_pred with 0%nat; assumption. -Qed. - - (**********) -Lemma sum_plus : - forall (An Bn:nat -> R) (N:nat), - sum_f_R0 (fun l:nat => An l + Bn l) N = sum_f_R0 An N + sum_f_R0 Bn N. -Proof. - intros. - induction N as [| N HrecN]. - - reflexivity. - - do 3 rewrite tech5. - rewrite HrecN; ring. -Qed. - - (* The main result *) -Theorem cauchy_finite : - forall (An Bn:nat -> R) (N:nat), - (0 < N)%nat -> - sum_f_R0 An N * sum_f_R0 Bn N = - sum_f_R0 (fun k:nat => sum_f_R0 (fun p:nat => An p * Bn (k - p)%nat) k) N + - sum_f_R0 - (fun k:nat => - sum_f_R0 (fun l:nat => An (S (l + k)) * Bn (N - l)%nat) - (pred (N - k))) (pred N). -Proof. - intros; induction N as [| N HrecN]. - { elim (Nat.lt_irrefl _ H). } - assert (H0:N = 0%nat \/ (0 < N)%nat). { - inversion H. - - left; reflexivity. - - right; apply Nat.lt_le_trans with 1%nat; [ apply Nat.lt_succ_diag_r | exact H1 ]. - } - elim H0; intro. - { rewrite H1; simpl; ring. } - replace (pred (S N)) with (S (pred N)) - by (simpl; apply Nat.lt_succ_pred with 0%nat; assumption). - do 5 rewrite tech5. - rewrite Rmult_plus_distr_r; rewrite Rmult_plus_distr_l; rewrite (HrecN H1). - repeat rewrite Rplus_assoc; apply Rplus_eq_compat_l. - replace (pred (S N - S (pred N))) with 0%nat by auto with zarith. - rewrite Rmult_plus_distr_l; - replace - (sum_f_R0 (fun l:nat => An (S (l + S (pred N))) * Bn (S N - l)%nat) 0) with - (An (S N) * Bn (S N)). - 2:{ simpl. replace (S (pred N)) with N by auto with zarith. - reflexivity. } - repeat rewrite <- Rplus_assoc; - do 2 rewrite <- (Rplus_comm (An (S N) * Bn (S N))); - repeat rewrite Rplus_assoc; apply Rplus_eq_compat_l. - rewrite Nat.sub_diag; assert (H2:N = 1%nat \/ (2 <= N)%nat). - { inversion H1. - - left; reflexivity. - - right; apply le_n_S; assumption. } - elim H2; intro. - { rewrite H3; simpl; ring. } - replace - (sum_f_R0 - (fun k:nat => - sum_f_R0 (fun l:nat => An (S (l + k)) * Bn (N - l)%nat) (pred (N - k))) - (pred N)) with - (sum_f_R0 - (fun k:nat => - sum_f_R0 (fun l:nat => An (S (S (l + k))) * Bn (N - l)%nat) - (pred (pred (N - k)))) (pred (pred N)) - + sum_f_R0 (fun l:nat => An (S l) * Bn (N - l)%nat) (pred N)). - 2:{ rewrite Rplus_comm. - rewrite - (decomp_sum - (fun k:nat => - sum_f_R0 (fun l:nat => An (S (l + k)) * Bn (N - l)%nat) (pred (N - k))) - (pred N)). - 2:{ auto with zarith. } - rewrite Nat.sub_0_r. - replace (sum_f_R0 (fun l:nat => An (S (l + 0)) * Bn (N - l)%nat) (pred N)) - with (sum_f_R0 (fun l:nat => An (S l) * Bn (N - l)%nat) (pred N)). - 2:{ apply sum_eq; intros. - replace (i + 0)%nat with i by trivial; reflexivity. } - apply Rplus_eq_compat_l. - apply sum_eq; intros. - replace (pred (N - S i)) with (pred (pred (N - i))) by auto with zarith. - apply sum_eq; intros. - replace (i0 + S i)%nat with (S (i0 + i)) by auto with zarith. - reflexivity. - } - replace (sum_f_R0 (fun p:nat => An p * Bn (S N - p)%nat) N) with - (sum_f_R0 (fun l:nat => An (S l) * Bn (N - l)%nat) (pred N) + - An 0%nat * Bn (S N)). - 2:{ rewrite Rplus_comm. - rewrite (decomp_sum (fun p:nat => An p * Bn (S N - p)%nat) N). - - reflexivity. - - assumption. - } - repeat rewrite <- Rplus_assoc; - rewrite <- - (Rplus_comm (sum_f_R0 (fun l:nat => An (S l) * Bn (N - l)%nat) (pred N))) - ; repeat rewrite Rplus_assoc; apply Rplus_eq_compat_l. - replace - (sum_f_R0 - (fun k:nat => - sum_f_R0 (fun l:nat => An (S (l + k)) * Bn (S N - l)%nat) - (pred (S N - k))) (pred N)) with - (sum_f_R0 - (fun k:nat => - sum_f_R0 (fun l:nat => An (S (S (l + k))) * Bn (N - l)%nat) - (pred (N - k))) (pred N) + - Bn (S N) * sum_f_R0 (fun l:nat => An (S l)) (pred N)). - 2:{ replace - (sum_f_R0 - (fun k:nat => - sum_f_R0 (fun l:nat => An (S (l + k)) * Bn (S N - l)%nat) - (pred (S N - k))) (pred N)) with - (sum_f_R0 - (fun k:nat => - sum_f_R0 (fun l:nat => An (S (S (l + k))) * Bn (N - l)%nat) - (pred (N - k)) + An (S k) * Bn (S N)) (pred N)). - { rewrite - (sum_plus - (fun k:nat => - sum_f_R0 (fun l:nat => An (S (S (l + k))) * Bn (N - l)%nat) - (pred (N - k))) (fun k:nat => An (S k) * Bn (S N))). - apply Rplus_eq_compat_l. - rewrite scal_sum; reflexivity. - } - apply sum_eq; intros; rewrite Rplus_comm; - rewrite - (decomp_sum (fun l:nat => An (S (l + i)) * Bn (S N - l)%nat) - (pred (S N - i))). - 2:{ auto with zarith. } - replace (0 + i)%nat with i by ring. - rewrite Nat.sub_0_r; apply Rplus_eq_compat_l. - replace (pred (pred (S N - i))) with (pred (N - i)) by auto with zarith. - apply sum_eq; intros. - replace (S N - S i0)%nat with (N - i0)%nat; [ idtac | reflexivity ]. - replace (S i0 + i)%nat with (S (i0 + i)) by auto with zarith. - reflexivity. - } - rewrite (decomp_sum An N H1); rewrite Rmult_plus_distr_r; - repeat rewrite <- Rplus_assoc; rewrite <- (Rplus_comm (An 0%nat * Bn (S N))); - repeat rewrite Rplus_assoc; apply Rplus_eq_compat_l. - repeat rewrite <- Rplus_assoc; - rewrite <- (Rplus_comm (sum_f_R0 (fun i:nat => An (S i)) (pred N) * Bn (S N))); - rewrite <- (Rplus_comm (Bn (S N) * sum_f_R0 (fun i:nat => An (S i)) (pred N))); - rewrite (Rmult_comm (Bn (S N))); repeat rewrite Rplus_assoc; - apply Rplus_eq_compat_l. - replace - (sum_f_R0 - (fun k:nat => - sum_f_R0 (fun l:nat => An (S (S (l + k))) * Bn (N - l)%nat) - (pred (N - k))) (pred N)) with - (sum_f_R0 - (fun k:nat => - sum_f_R0 (fun l:nat => An (S (S (l + k))) * Bn (N - l)%nat) - (pred (pred (N - k)))) (pred (pred N)) + - An (S N) * sum_f_R0 (fun l:nat => Bn (S l)) (pred N)). - { rewrite (decomp_sum Bn N H1); rewrite Rmult_plus_distr_l. - set - (Z := - sum_f_R0 - (fun k:nat => - sum_f_R0 (fun l:nat => An (S (S (l + k))) * Bn (N - l)%nat) - (pred (pred (N - k)))) (pred (pred N))); - set (Z2 := sum_f_R0 (fun i:nat => Bn (S i)) (pred N)); - ring. - } - rewrite - (sum_N_predN - (fun k:nat => - sum_f_R0 (fun l:nat => An (S (S (l + k))) * Bn (N - l)%nat) - (pred (N - k))) (pred N)). - 2:{ auto with zarith. } - replace - (sum_f_R0 - (fun k:nat => - sum_f_R0 (fun l:nat => An (S (S (l + k))) * Bn (N - l)%nat) - (pred (N - k))) (pred (pred N))) with - (sum_f_R0 - (fun k:nat => - sum_f_R0 (fun l:nat => An (S (S (l + k))) * Bn (N - l)%nat) - (pred (pred (N - k))) + An (S N) * Bn (S k)) ( - pred (pred N))). - 2:{ apply sum_eq; intros; - rewrite - (sum_N_predN (fun l:nat => An (S (S (l + i))) * Bn (N - l)%nat) - (pred (N - i))). - 2:{ auto with zarith. } - replace (S (S (pred (N - i) + i))) with (S N) by auto with zarith. - replace (N - pred (N - i))%nat with (S i) by auto with zarith. - reflexivity. - } - rewrite - (sum_plus - (fun k:nat => - sum_f_R0 (fun l:nat => An (S (S (l + k))) * Bn (N - l)%nat) - (pred (pred (N - k)))) (fun k:nat => An (S N) * Bn (S k)) - (pred (pred N))). - repeat rewrite Rplus_assoc; apply Rplus_eq_compat_l. - replace (pred (N - pred N)) with 0%nat by auto with zarith. - simpl; rewrite Nat.sub_0_r. - replace (S (pred N)) with N by auto with zarith. - replace (sum_f_R0 (fun k:nat => An (S N) * Bn (S k)) (pred (pred N))) with - (sum_f_R0 (fun k:nat => Bn (S k) * An (S N)) (pred (pred N))). - 2:{ apply sum_eq; intros; apply Rmult_comm. } - rewrite <- (scal_sum (fun l:nat => Bn (S l)) (pred (pred N)) (An (S N))); - rewrite (sum_N_predN (fun l:nat => Bn (S l)) (pred N)). - 2:{ auto with zarith. } - replace (S (pred N)) with N by auto with zarith. - ring. -Qed. diff --git a/stdlib/theories/Reals/ClassicalConstructiveReals.v b/stdlib/theories/Reals/ClassicalConstructiveReals.v deleted file mode 100644 index b48d5e55780a..000000000000 --- a/stdlib/theories/Reals/ClassicalConstructiveReals.v +++ /dev/null @@ -1,333 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* (a < b)%R + (c < d)%R. -Proof. - intros. destruct (total_order_T a b). - - destruct s. - + left. exact r. - + right. destruct H. - * exfalso. subst a. exact (Rlt_asym b b H H). - * exact H. - - right. destruct H. - + exfalso. exact (Rlt_asym _ _ H r). - + exact H. -Qed. - -(* The constructive equality on R. *) -Definition Req_constr (x y : R) : Prop - := (x < y -> False) /\ (y < x -> False). - -Lemma Req_constr_refl : forall x:R, Req_constr x x. -Proof. - split. - - intro H. exact (Rlt_asym _ _ H H). - - intro H. exact (Rlt_asym _ _ H H). -Qed. - -Lemma Req_constr_leibniz : forall x y:R, Req_constr x y -> x = y. -Proof. - intros. destruct (total_order_T x y). 1:destruct s. - - exfalso. destruct H. contradiction. - - exact e. - - exfalso. destruct H. contradiction. -Qed. - -Definition IQR (q : Q) := Rabst (inject_Q q). - -Lemma IQR_zero_quot : Req_constr (IQR 0) R0. -Proof. - unfold IQR. rewrite R0_def. apply Req_constr_refl. -Qed. - -(* Not RealField.RTheory, because it uses Leibniz equality. *) -Lemma Rring : ring_theory (IQR 0) (IQR 1) Rplus Rmult - (fun x y : R => (x + - y)%R) Ropp Req_constr. -Proof. - split. - - intro x. replace (IQR 0 + x) with x. - + apply Req_constr_refl. - + apply Rquot1. rewrite Rrepr_plus. unfold IQR. rewrite Rquot2. - rewrite CReal_plus_0_l. reflexivity. - - intros. replace (x + y) with (y + x). - + apply Req_constr_refl. - + apply Rquot1. do 2 rewrite Rrepr_plus. apply CReal_plus_comm. - - intros. replace (x + (y + z)) with (x + y + z). - + apply Req_constr_refl. - + apply Rquot1. - do 4 rewrite Rrepr_plus. apply CReal_plus_assoc. - - intro x. replace (IQR 1 * x) with x. - + apply Req_constr_refl. - + unfold IQR. - apply Rquot1. rewrite Rrepr_mult, Rquot2, CReal_mult_1_l. reflexivity. - - intros. replace (x * y) with (y * x). - + apply Req_constr_refl. - + apply Rquot1. do 2 rewrite Rrepr_mult. apply CReal_mult_comm. - - intros. replace (x * (y * z)) with (x * y * z). - + apply Req_constr_refl. - + apply Rquot1. - do 4 rewrite Rrepr_mult. apply CReal_mult_assoc. - - intros. replace ((x + y) * z) with (x * z + y * z). - + apply Req_constr_refl. - + apply Rquot1. - rewrite Rrepr_mult, Rrepr_plus, Rrepr_plus, Rrepr_mult, Rrepr_mult. - symmetry. apply CReal_mult_plus_distr_r. - - intros. apply Req_constr_refl. - - intros. replace (x + - x) with R0. - + unfold IQR. - rewrite R0_def. apply Req_constr_refl. - + apply Rquot1. rewrite Rrepr_plus, Rrepr_opp, CReal_plus_opp_r, Rrepr_0. - reflexivity. -Qed. - -Lemma RringExt : ring_eq_ext Rplus Rmult Ropp Req_constr. -Proof. - split. - - intros x y H z t H0. apply Req_constr_leibniz in H. - apply Req_constr_leibniz in H0. destruct H, H0. apply Req_constr_refl. - - intros x y H z t H0. apply Req_constr_leibniz in H. - apply Req_constr_leibniz in H0. destruct H, H0. apply Req_constr_refl. - - intros x y H. apply Req_constr_leibniz in H. destruct H. apply Req_constr_refl. -Qed. - -Lemma Rleft_inverse : - forall r : R, (sum (r < IQR 0) (IQR 0 < r)) -> Req_constr (/ r * r) (IQR 1). -Proof. - intros. rewrite Rinv_l. - - unfold IQR. rewrite <- R1_def. apply Req_constr_refl. - - destruct H. - + intro abs. subst r. unfold IQR in r0. rewrite <- R0_def in r0. - apply (Rlt_asym _ _ r0 r0). - + intro abs. subst r. unfold IQR in r0. rewrite <- R0_def in r0. - apply (Rlt_asym _ _ r0 r0). -Qed. - -Lemma Rinv_pos : forall r : R, (sum (r < IQR 0) (IQR 0 < r)) -> IQR 0 < r -> IQR 0 < / r. -Proof. - intros. rewrite Rlt_def. apply CRealLtForget. - rewrite Rlt_def in H0. apply CRealLtEpsilon in H0. - unfold IQR in H0. rewrite Rquot2 in H0. - rewrite (Rrepr_inv r (inr H0)). unfold IQR. rewrite Rquot2. - apply CReal_inv_0_lt_compat, H0. -Qed. - -Lemma Rmult_pos : forall x y : R, IQR 0 < x -> IQR 0 < y -> IQR 0 < x * y. -Proof. - intros. rewrite Rlt_def. apply CRealLtForget. - unfold IQR. rewrite Rquot2. - rewrite Rrepr_mult. apply CReal_mult_lt_0_compat. - - rewrite Rlt_def in H. apply CRealLtEpsilon in H. - unfold IQR in H. rewrite Rquot2 in H. exact H. - - unfold IQR in H0. rewrite Rlt_def in H0. apply CRealLtEpsilon in H0. - rewrite Rquot2 in H0. exact H0. -Qed. - -Lemma Rplus_reg_l : forall r r1 r2, r + r1 < r + r2 -> r1 < r2. -Proof. - intros. rewrite Rlt_def in H. apply CRealLtEpsilon in H. - rewrite Rrepr_plus, Rrepr_plus in H. - apply CReal_plus_lt_reg_l in H. rewrite Rlt_def. - apply CRealLtForget. exact H. -Qed. - -Lemma Rzero_lt_one : IQR 0 < IQR 1. -Proof. - rewrite Rlt_def. apply CRealLtForget. - unfold IQR. rewrite Rquot2, Rquot2. - apply CRealLt_0_1. -Qed. - -Lemma plus_IQR : forall q r : Q, - IQR (q + r) = IQR q + IQR r. -Proof. - intros. unfold IQR. apply Rquot1. - rewrite Rquot2, Rrepr_plus, Rquot2, Rquot2. apply inject_Q_plus. -Qed. - -Lemma mult_IQR : forall q r : Q, - IQR (q * r) = IQR q * IQR r. -Proof. - intros. unfold IQR. apply Rquot1. - rewrite Rquot2, Rrepr_mult, Rquot2, Rquot2. apply inject_Q_mult. -Qed. - -Lemma IQR_lt : forall n m:Q, (n < m)%Q -> IQR n < IQR m. -Proof. - intros. rewrite Rlt_def. apply CRealLtForget. - unfold IQR. rewrite Rquot2, Rquot2. apply inject_Q_lt, H. -Qed. - -Lemma lt_IQR : forall n m:Q, IQR n < IQR m -> (n < m)%Q. -Proof. - intros. rewrite Rlt_def in H. apply CRealLtEpsilon in H. - unfold IQR in H. rewrite Rquot2, Rquot2 in H. - apply lt_inject_Q, H. -Qed. - -Lemma IQR_plus_quot : forall q r : Q, Req_constr (IQR (q + r)) (IQR q + IQR r). -Proof. - intros. rewrite plus_IQR. apply Req_constr_refl. -Qed. - -Lemma IQR_mult_quot : forall q r : Q, Req_constr (IQR (q * r)) (IQR q * IQR r). -Proof. - intros. rewrite mult_IQR. apply Req_constr_refl. -Qed. - -Lemma Rabove_pos : forall x : R, {n : positive & x < IQR (Z.pos n # 1)}. -Proof. - intros. destruct (Rup_nat (Rrepr x)) as [n nmaj]. - exists (Pos.of_nat n). unfold IQR. rewrite Rlt_def, Rquot2. - apply CRealLtForget. apply (CReal_lt_le_trans _ _ _ nmaj). - apply inject_Q_le. unfold Qle, Qnum, Qden. - do 2 rewrite Z.mul_1_r. destruct n. - - discriminate. - - rewrite <- positive_nat_Z. rewrite Nat2Pos.id. - + apply Z.le_refl. - + discriminate. -Qed. - -Lemma Rarchimedean : forall x y : R, x < y -> {q : Q & ((x < IQR q) * (IQR q < y))%type}. -Proof. - intros. rewrite Rlt_def in H. apply CRealLtEpsilon in H. - apply CRealQ_dense in H. destruct H as [q [H2 H3]]. - exists q. split. - - rewrite Rlt_def. apply CRealLtForget. - unfold IQR. rewrite Rquot2. exact H2. - - rewrite Rlt_def. apply CRealLtForget. - unfold IQR. rewrite Rquot2. exact H3. -Qed. - -Lemma RabsLUB : forall x y : R, (y < x -> False) /\ (y < - x -> False) <-> (y < Rabst (CReal_abs (Rrepr x)) -> False). -Proof. - split. - - intros. rewrite Rlt_def in H0. - apply CRealLtEpsilon in H0. rewrite Rquot2 in H0. - destruct H. apply (CReal_abs_le (Rrepr x) (Rrepr y)). 2: exact H0. - split. - + apply (CReal_plus_le_reg_l (Rrepr y - Rrepr x)). - ring_simplify. intro abs2. apply H1. rewrite Rlt_def. - apply CRealLtForget. rewrite Rrepr_opp. exact abs2. - + intro abs2. apply H. rewrite Rlt_def. - apply CRealLtForget. exact abs2. - - intros. split. - + intro abs. apply H. - rewrite Rlt_def. apply CRealLtForget. rewrite Rquot2. - rewrite Rlt_def in abs. apply CRealLtEpsilon in abs. - apply (CReal_lt_le_trans _ _ _ abs). apply CReal_le_abs. - + intro abs. apply H. - rewrite Rlt_def. apply CRealLtForget. rewrite Rquot2. - rewrite Rlt_def in abs. apply CRealLtEpsilon in abs. - apply (CReal_lt_le_trans _ _ _ abs). - rewrite <- CReal_abs_opp, Rrepr_opp. apply CReal_le_abs. -Qed. - -Lemma Rcomplete : forall xn : nat -> R, - (forall p : positive, - {n : nat | - forall i j : nat, - (n <= i)%nat -> (n <= j)%nat -> IQR (1 # p) < Rabst (CReal_abs (Rrepr (xn i + - xn j))) -> False}) -> - {l : R & - forall p : positive, - {n : nat | - forall i : nat, (n <= i)%nat -> IQR (1 # p) < Rabst (CReal_abs (Rrepr (xn i + - l))) -> False}}. -Proof. - intros. destruct (Rcauchy_complete (fun n => Rrepr (xn n))) as [l llim]. - - intro p. specialize (H p) as [n nmaj]. exists n. intros. - specialize (nmaj i j H H0). unfold IQR in nmaj. - intro abs. apply nmaj. rewrite Rlt_def. apply CRealLtForget. - rewrite Rquot2, Rquot2. apply (CReal_lt_le_trans _ _ _ abs). - rewrite Rrepr_plus, Rrepr_opp. apply CRealLe_refl. - - exists (Rabst l). intros. specialize (llim p) as [n nmaj]. - exists n. intros. specialize (nmaj i H0). - unfold IQR in H1. apply nmaj. rewrite Rlt_def in H1. - apply CRealLtEpsilon in H1. rewrite Rquot2, Rquot2 in H1. - apply (CReal_lt_le_trans _ _ _ H1). - rewrite Rrepr_plus, Rrepr_opp, Rquot2. apply CRealLe_refl. -Qed. - -Definition Rabs_quot (x : R) := Rabst (CReal_abs (Rrepr x)). -Definition Rinv_quot (x : R) (xnz : sum (x < IQR 0) (IQR 0 < x)) := Rinv x. -Definition Rlt_epsilon (x y : R) (H : x < y) := H. - -Definition DRealConstructive : ConstructiveReals - := Build_ConstructiveReals - R Rlt RisLinearOrder Rlt - Rlt_epsilon Rlt_epsilon - RdisjunctEpsilon IQR IQR_lt lt_IQR - Rplus Ropp Rmult - IQR_plus_quot IQR_mult_quot - Rring RringExt Rzero_lt_one - Rplus_lt_compat_l Rplus_reg_l Rmult_pos - Rinv_quot Rleft_inverse Rinv_pos - Rarchimedean Rabove_pos - Rabs_quot RabsLUB Rcomplete. - -Definition Rrepr_morphism - : @ConstructiveRealsMorphism DRealConstructive CRealConstructive. -Proof. - apply (Build_ConstructiveRealsMorphism - DRealConstructive CRealConstructive Rrepr). - - intro q. simpl. unfold IQR. rewrite Rquot2. apply CRealEq_refl. - - intros. simpl. simpl in H. rewrite Rlt_def in H. - apply CRealLtEpsilon in H. exact H. -Defined. - -Definition Rabst_morphism - : @ConstructiveRealsMorphism CRealConstructive DRealConstructive. -Proof. - apply (Build_ConstructiveRealsMorphism - CRealConstructive DRealConstructive Rabst). - - intro q. apply Req_constr_refl. - - intros. simpl. simpl in H. rewrite Rlt_def. - apply CRealLtForget. rewrite Rquot2, Rquot2. exact H. -Defined. diff --git a/stdlib/theories/Reals/ClassicalDedekindReals.v b/stdlib/theories/Reals/ClassicalDedekindReals.v deleted file mode 100644 index 9b6317cd8358..000000000000 --- a/stdlib/theories/Reals/ClassicalDedekindReals.v +++ /dev/null @@ -1,718 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* 1 - | S n' => 2 * (PosPow2_nat n') - end. - -Local Lemma Qpower_2_neg_eq_pospow_inv : forall n : nat, - (2 ^ (- Z.of_nat n) == 1#(PosPow2_nat n)%positive)%Q. -Proof. - intros n; induction n. - - reflexivity. - - change (PosPow2_nat (S n)) with (2*(PosPow2_nat n))%positive. - rewrite <- Qmult_frac_l. - rewrite Nat2Z.inj_succ, Z.opp_succ, <- Z.sub_1_r. - rewrite Qpower_minus_pos. - change ((1 # 2) ^ 1)%Q with (1 # 2)%Q. - rewrite Qmult_comm, IHn; reflexivity. -Qed. -*) - -Local Lemma Qpower_2_neg_eq_natpow_inv : forall n : nat, - (2 ^ (- Z.of_nat n) == 1#(Pos.of_nat (2^n)%nat))%Q. -Proof. - intros n; induction n. - - reflexivity. - - rewrite Nat.pow_succ_r'. - rewrite Nat2Pos.inj_mul. - 3: apply Nat.pow_nonzero; intros contra; inversion contra. - 2: intros contra; inversion contra. - change (Pos.of_nat 2)%nat with 2%positive. - rewrite Qmult_frac_l. - rewrite Nat2Z.inj_succ, Z.opp_succ, <- Z.sub_1_r. - rewrite Qpower_minus_pos. - change ((1 # 2) ^ 1)%Q with (1 # 2)%Q. - rewrite Qmult_comm, IHn; reflexivity. -Qed. - - -Local Lemma Qpower_2_invneg_le_pow : forall n : Z, - (1 # Pos.of_nat (2 ^ Z.to_nat (- n)) <= 2 ^ n)%Q. -Proof. - intros n; destruct n. - - intros contra; inversion contra. - - (* ToDo: find out why this works - somehow 1#(...) seems to be coereced to 1 *) - apply (Qpower_1_le_pos 2 p ltac:(lra)). - - rewrite <- Qpower_2_neg_eq_natpow_inv. - rewrite Z2Nat.id by lia. - rewrite Z.opp_involutive. - apply Qle_refl. -Qed. - -Local Lemma Qpower_2_neg_le_one : forall n : nat, - (2 ^ (- Z.of_nat n) <= 1)%Q. -Proof. - intros n; induction n. - - intros contra; inversion contra. - - rewrite Nat2Z.inj_succ, Z.opp_succ, <- Z.sub_1_r. - rewrite Qpower_minus_pos. - lra. -Qed. - -(*****************************************************************************) -(** * Dedekind cuts *) -(*****************************************************************************) - -(** ** Definition *) - -(** - Classical Dedekind reals. With the 3 logical axioms funext, - sig_forall_dec and sig_not_dec, the lower cuts defined as - functions Q -> bool have all the classical properties of the - real numbers. - - We could prove operations and theorems about them directly, - but instead we notice that they are a quotient of the - constructive Cauchy reals, from which they inherit many properties. -*) - -(* The limited principle of omniscience *) -Axiom sig_forall_dec - : forall (P : nat -> Prop), - (forall n, {P n} + {~P n}) - -> {n | ~P n} + {forall n, P n}. - -Axiom sig_not_dec : forall P : Prop, { ~~P } + { ~P }. - -(* Try to find a surjection CReal -> lower cuts. *) -Definition isLowerCut (f : Q -> bool) : Prop - := (forall q r:Q, Qle q r -> f r = true -> f q = true) (* interval *) - /\ ~(forall q:Q, f q = true) (* avoid positive infinity *) - /\ ~(forall q:Q, f q = false) (* avoid negative infinity *) - (* openness, the cut contains rational numbers - strictly lower than a real number. *) - /\ (forall q:Q, f q = true -> ~(forall r:Q, Qle r q \/ f r = false)). - -(** ** Properties *) - -Lemma isLowerCut_hprop : forall (f : Q -> bool), - IsHProp (isLowerCut f). -Proof. - intro f. apply and_hprop. - 2: apply and_hprop. 2: apply not_hprop. - 2: apply and_hprop. 2: apply not_hprop. - - apply forall_hprop. intro x. - apply forall_hprop. intro y. - apply impl_hprop. apply impl_hprop. - intros p q. apply eq_proofs_unicity_on. - intro b. destruct (f x), b. - + left. reflexivity. - + right. discriminate. - + right. discriminate. - + left. reflexivity. - - apply forall_hprop. intro q. apply impl_hprop. apply not_hprop. -Qed. - -Lemma lowerCutBelow : forall f : Q -> bool, - isLowerCut f -> { q : Q | f q = true }. -Proof. - intros. - destruct (sig_forall_dec (fun n:nat => f (-(Z.of_nat n # 1))%Q = false)). - - intro n. destruct (f (-(Z.of_nat n # 1))%Q). - + right. discriminate. - + left. reflexivity. - - destruct s. exists (-(Z.of_nat x # 1))%Q. - destruct (f (-(Z.of_nat x # 1))%Q). - + reflexivity. - + exfalso. apply n. reflexivity. - - exfalso. destruct H, H0, H1. apply H1. intro q. - destruct (f q) eqn:des. 2: reflexivity. exfalso. - destruct (Qarchimedean (-q)) as [p pmaj]. - rewrite <- (Qplus_lt_l _ _ (q-(Z.pos p # 1))) in pmaj. - ring_simplify in pmaj. - specialize (H (- (Z.pos p#1))%Q q). - specialize (e (Pos.to_nat p)). - rewrite positive_nat_Z in e. rewrite H in e. - + discriminate. - + ring_simplify. apply Qlt_le_weak, pmaj. - + exact des. -Qed. - -Lemma lowerCutAbove : forall f : Q -> bool, - isLowerCut f -> { q : Q | f q = false }. -Proof. - intros. - destruct (sig_forall_dec (fun n => f (Z.of_nat n # 1)%Q = true)). - - intro n. destruct (f (Z.of_nat n # 1)%Q). - + left. reflexivity. - + right. discriminate. - - destruct s. exists (Z.of_nat x # 1)%Q. destruct (f (Z.of_nat x # 1)%Q). - + exfalso. apply n. reflexivity. - + reflexivity. - - exfalso. destruct H, H0, H1. apply H0. intro q. - destruct (Qarchimedean q) as [p pmaj]. - apply (H q (Z.of_nat (Pos.to_nat p) # 1)%Q). - + rewrite positive_nat_Z. apply Qlt_le_weak, pmaj. - + apply e. -Qed. - -Lemma lowerUpper : forall (f : Q -> bool) (q r : Q), - isLowerCut f -> Qle q r -> f q = false -> f r = false. -Proof. - intros. destruct H. specialize (H q r H0). destruct (f r) eqn:desR. - 2: reflexivity. exfalso. specialize (H (eq_refl _)). - rewrite H in H1. discriminate. -Qed. - -Lemma UpperAboveLower : forall (f : Q -> bool) (q r : Q), - isLowerCut f - -> f q = true - -> f r = false - -> Qlt q r. -Proof. - intros. destruct H. apply Qnot_le_lt. intro abs. - rewrite (H r q abs) in H1. - - discriminate. - - exact H0. -Qed. - -(*****************************************************************************) -(** * Classical Dedekind reals *) -(*****************************************************************************) - -(** ** Definition *) - -Definition DReal : Set - := { f : Q -> bool | isLowerCut f }. - -(** ** Induction principle *) - -Fixpoint DRealQlim_rec (f : Q -> bool) (low : isLowerCut f) (n p : nat) { struct p } - : f (proj1_sig (lowerCutBelow f low) + (Z.of_nat p # Pos.of_nat (S n)))%Q = false - -> { q : Q | f q = true /\ f (q + (1 # Pos.of_nat (S n)))%Q = false }. -Proof. - intros. destruct p. - - exfalso. destruct (lowerCutBelow f low); unfold proj1_sig in H. - destruct low. rewrite (H0 _ x) in H. - + discriminate. - + simpl. - apply (Qplus_le_l _ _ (-x)). ring_simplify. discriminate. - + exact e. - - destruct (f (proj1_sig (lowerCutBelow f low) + (Z.of_nat p # Pos.of_nat (S n)))%Q) eqn:des. - + exists (proj1_sig (lowerCutBelow f low) + (Z.of_nat p # Pos.of_nat (S n)))%Q. - split. - * exact des. - * destruct (f (proj1_sig (lowerCutBelow f low) - + (Z.of_nat p # Pos.of_nat (S n)) + (1 # Pos.of_nat (S n)))%Q) eqn:d. - 2: reflexivity. exfalso. - destruct low. - rewrite (e _ (proj1_sig (lowerCutBelow f (conj e a)) + (Z.of_nat p # Pos.of_nat (S n)) + (1 # Pos.of_nat (S n))))%Q in H. - -- discriminate. - -- rewrite <- Qplus_assoc, Qplus_le_r. - rewrite Qinv_plus_distr. - replace (Z.of_nat p + 1)%Z with (Z.of_nat (S p))%Z. - ++ apply Qle_refl. - ++ replace 1%Z with (Z.of_nat 1). - ** rewrite <- (Nat2Z.inj_add p 1). - apply f_equal. rewrite Nat.add_comm. reflexivity. - ** reflexivity. - -- exact d. - + destruct (DRealQlim_rec f low n p des) as [q qmaj]. - exists q. exact qmaj. -Qed. - -(** ** Conversion to and from constructive Cauchy real CReal *) - -(** *** Conversion from CReal to DReal *) - -Lemma DRealAbstr_aux : - forall x H, - isLowerCut (fun q : Q => - if sig_forall_dec (fun n : nat => seq x (- Z.of_nat n) <= q + 2 ^ (- Z.of_nat n)) (H q) - then true else false). -Proof. - repeat split. - - intros. - destruct (sig_forall_dec (fun n : nat => (seq x (-Z.of_nat n) <= q + (2^-Z.of_nat n))%Q) - (H q)). - + reflexivity. - + exfalso. - destruct (sig_forall_dec (fun n : nat => (seq x (-Z.of_nat n) <= r + (2^-Z.of_nat n))%Q) - (H r)). - * destruct s. apply n. - apply (Qle_trans _ _ _ (q0 x0)). - apply Qplus_le_l. exact H0. - * discriminate. - - intro abs. destruct (Rfloor x) as [z [_ zmaj]]. - specialize (abs (z+3 # 1)%Q). - destruct (sig_forall_dec (fun n : nat => (seq x (-Z.of_nat n) <= (z+3 # 1) + (2^-Z.of_nat n))%Q) - (H (z+3 # 1)%Q)). - 2: exfalso; discriminate. clear abs. destruct s as [n nmaj]. apply nmaj. - rewrite <- (inject_Q_plus (z#1) 2) in zmaj. - apply CRealLt_asym in zmaj. rewrite <- CRealLe_not_lt in zmaj. - specialize (zmaj (-Z.of_nat n)%Z). - unfold inject_Q in zmaj; rewrite CReal_red_seq in zmaj. - destruct x as [xn xcau]; rewrite CReal_red_seq in H, nmaj, zmaj |- *. - rewrite Qinv_plus_distr in zmaj. - apply (Qplus_le_l _ _ (-(z + 2 # 1))). apply (Qle_trans _ _ _ zmaj). - apply (Qplus_le_l _ _ (-(2^-Z.of_nat n))). apply (Qle_trans _ 1). - + ring_simplify. apply Qpower_2_neg_le_one. - + ring_simplify. rewrite <- (Qinv_plus_distr z 3 1), <- (Qinv_plus_distr z 2 1). lra. - - intro abs. destruct (Rfloor x) as [z [zmaj _]]. - specialize (abs (z-4 # 1)%Q). - destruct (sig_forall_dec (fun n : nat => (seq x (-Z.of_nat n) <= (z-4 # 1) + (2^-Z.of_nat n))%Q) - (H (z-4 # 1)%Q)). - + exfalso; discriminate. - + clear abs. - apply CRealLt_asym in zmaj. apply zmaj. clear zmaj. - exists 0%Z. unfold inject_Q; rewrite CReal_red_seq. - specialize (q O). - destruct x as [xn xcau]. - rewrite CReal_red_seq in H, q |- *. - unfold Z.of_nat in q. - change (2 ^ (- 0))%Q with 1%Q in q. change (-0)%Z with 0%Z in q. - rewrite <- Qinv_minus_distr in q. - change (2^0)%Q with 1%Q. - lra. - - intros q H0 abs. - destruct (sig_forall_dec (fun n : nat => (seq x (-Z.of_nat n) <= q + (2^-Z.of_nat n))%Q) (H q)). - 2: exfalso; discriminate. clear H0. - destruct s as [n nmaj]. - (* We have that q < x as real numbers. The middle - (q + xSn - 1/Sn)/2 is also lower than x, witnessed by the same index n. *) - specialize (abs ((q + seq x (-Z.of_nat n) - (2^-Z.of_nat n)%Q)/2)%Q). - destruct abs. - + apply (Qmult_le_r _ _ 2) in H0. - * field_simplify in H0. - apply (Qplus_le_r _ _ ((2^-Z.of_nat n) - q)) in H0. - ring_simplify in H0. apply nmaj. rewrite Qplus_comm. exact H0. - * reflexivity. - + destruct (sig_forall_dec - (fun n0 : nat => - (seq x (-Z.of_nat n0) <= (q + seq x (-Z.of_nat n) - (2^-Z.of_nat n)) / 2 + (2^-Z.of_nat n0))%Q) - (H ((q + seq x (-Z.of_nat n) - (2^-Z.of_nat n)) / 2)%Q)). - * discriminate. - * clear H0. specialize (q0 n). - apply (Qmult_le_l _ _ 2) in q0. - -- field_simplify in q0. - apply (Qplus_le_l _ _ (-seq x (-Z.of_nat n))) in q0. ring_simplify in q0. - contradiction. - -- reflexivity. -Qed. - -Definition DRealAbstr : CReal -> DReal. -Proof. - intro x. - assert (forall (q : Q) (n : nat), - {(fun n0 : nat => (seq x (-Z.of_nat n0) <= q + (2^-Z.of_nat n0))%Q) n} + - {~ (fun n0 : nat => (seq x (-Z.of_nat n0) <= q + (2^-Z.of_nat n0))%Q) n}). - { intros. destruct (Qlt_le_dec (q + (2^-Z.of_nat n)) (seq x (-Z.of_nat n))). - - right. apply (Qlt_not_le _ _ q0). - - left. exact q0. } - - exists (fun q:Q => if sig_forall_dec (fun n:nat => Qle (seq x (-Z.of_nat n)) (q + (2^-Z.of_nat n))) (H q) - then true else false). - apply DRealAbstr_aux. -Defined. - -(** *** Conversion from DReal to CReal *) - -Definition DRealQlim (x : DReal) (n : nat) - : { q : Q | proj1_sig x q = true /\ proj1_sig x (q + (1# Pos.of_nat (S n)))%Q = false }. -Proof. - destruct x as [f low]. - destruct (lowerCutAbove f low). - destruct (Qarchimedean (x - proj1_sig (lowerCutBelow f low))) as [p pmaj]. - apply (DRealQlim_rec f low n ((S n) * Pos.to_nat p)). - destruct (lowerCutBelow f low); unfold proj1_sig; unfold proj1_sig in pmaj. - destruct (f (x0 + (Z.of_nat (S n * Pos.to_nat p) # Pos.of_nat (S n)))%Q) eqn:des. - 2: reflexivity. exfalso. destruct low. - rewrite (H _ (x0 + (Z.of_nat (S n * Pos.to_nat p) # Pos.of_nat (S n)))%Q) in e. - - discriminate. - - setoid_replace (Z.of_nat (S n * Pos.to_nat p) # Pos.of_nat (S n))%Q with (Z.pos p # 1)%Q. - + apply (Qplus_lt_l _ _ x0) in pmaj. ring_simplify in pmaj. - apply Qlt_le_weak, pmaj. - + rewrite Nat2Z.inj_mul, positive_nat_Z. - unfold Qeq, Qnum, Qden. rewrite Z.mul_1_r, Z.mul_comm. - replace (Z.of_nat (S n)) with (Z.pos (Pos.of_nat (S n))). - * reflexivity. - * simpl. destruct n. - -- reflexivity. - -- apply f_equal. - apply Pos.succ_of_nat. discriminate. - - exact des. -Qed. - -Definition DRealQlimExp2 (x : DReal) (n : nat) - : { q : Q | proj1_sig x q = true /\ proj1_sig x (q + (1#(Pos.of_nat (2^n)%nat)))%Q = false }. -Proof. - destruct (DRealQlim x (pred (2^n))%nat) as [q qmaj]. - exists q. - rewrite Nat.succ_pred_pos in qmaj. - 2: apply Nat.neq_0_lt_0, Nat.pow_nonzero; intros contra; inversion contra. - exact qmaj. -Qed. - -Definition CReal_of_DReal_seq (x : DReal) (n : Z) := - proj1_sig (DRealQlimExp2 x (Z.to_nat (-n))). - -Lemma CReal_of_DReal_cauchy (x : DReal) : - QCauchySeq (CReal_of_DReal_seq x). -Proof. - unfold QCauchySeq, CReal_of_DReal_seq. - intros n k l Hk Hl. - destruct (DRealQlimExp2 x (Z.to_nat (-k))) as [q Hq]. - destruct (DRealQlimExp2 x (Z.to_nat (-l))) as [r Hr]. - destruct x as [f Hflc]. - unfold proj1_sig in *. - apply Qabs_case. - - intros. apply (Qlt_le_trans _ (1 # Pos.of_nat (2 ^ Z.to_nat (-l)))). - + apply (Qplus_lt_l _ _ r); ring_simplify. - apply (UpperAboveLower f). - * exact Hflc. - * apply Hq. - * apply Hr. - + apply (Qle_trans _ _ _ (Qpower_2_invneg_le_pow _)). - apply Qpower_le_compat_l; [lia|lra]. - - intros. apply (Qlt_le_trans _ (1 # Pos.of_nat (2 ^ Z.to_nat (-k)))). - + apply (Qplus_lt_l _ _ q); ring_simplify. - apply (UpperAboveLower f). - * exact Hflc. - * apply Hr. - * apply Hq. - + apply (Qle_trans _ _ _ (Qpower_2_invneg_le_pow _)). - apply Qpower_le_compat_l; [lia|lra]. -Qed. - -Lemma CReal_of_DReal_seq_max_prec_1 : forall (x : DReal) (n : Z), - (n>=0)%Z -> CReal_of_DReal_seq x n = CReal_of_DReal_seq x 0. -Proof. - intros x n Hngt0. - unfold CReal_of_DReal_seq. - destruct n. - - reflexivity. - - reflexivity. - - lia. -Qed. - -Lemma CReal_of_DReal_seq_bound : - forall (x : DReal) (i j : Z), - (Qabs (CReal_of_DReal_seq x i - CReal_of_DReal_seq x j) <= 1)%Q. -Proof. - intros x i j. - pose proof CReal_of_DReal_cauchy x 0%Z as Hcau. - apply Qlt_le_weak; change (2^0)%Q with 1%Q in Hcau. - (* Either i, j are >= 0 in which case we can rewrite with CReal_of_DReal_seq_max_prec_1, - or they are <0, in which case Hcau can be used immediately *) - destruct (Z_gt_le_dec i 0) as [Hi|Hi]; - destruct (Z_gt_le_dec j 0) as [Hj|Hj]. - all: try rewrite (CReal_of_DReal_seq_max_prec_1 x i) by lia; - try rewrite (CReal_of_DReal_seq_max_prec_1 x j) by lia; - apply Hcau; lia. - (* ToDo: check if for CReal_from_cauchy_seq_bound a similar simple proof is possible *) -Qed. - -Definition CReal_of_DReal_scale (x : DReal) : Z := - Qbound_lt_ZExp2 (Qabs (CReal_of_DReal_seq x (-1)) + 2)%Q. - -Lemma CReal_of_DReal_bound : forall (x : DReal), - QBound (CReal_of_DReal_seq x) (CReal_of_DReal_scale x). -Proof. - intros x n. - unfold CReal_of_DReal_scale. - - (* Use the spec of Qbound_lt_ZExp2 to linearize the RHS *) - apply (Qlt_trans_swap_hyp _ _ _ (Qbound_lt_ZExp2_spec _)). - - (* Massage the goal so that CReal_of_DReal_seq_bound can be applied *) - apply (Qplus_lt_l _ _ (-Qabs (CReal_of_DReal_seq x (-1)))%Q); ring_simplify. - assert(forall r s : Q, (r + -1*s == r-s)%Q) as Aux - by (intros; lra); rewrite Aux; clear Aux. - apply (Qle_lt_trans _ _ _ (Qabs_triangle_reverse _ _)). - apply (Qle_lt_trans _ 1%Q _). - 2: lra. - apply CReal_of_DReal_seq_bound. -Qed. - -Definition DRealRepr (x : DReal) : CReal := -{| - seq := CReal_of_DReal_seq x; - scale := CReal_of_DReal_scale x; - cauchy := CReal_of_DReal_cauchy x; - bound := CReal_of_DReal_bound x -|}. - -(** ** Order for DReal *) - -Definition Rle (x y : DReal) - := forall q:Q, proj1_sig x q = true -> proj1_sig y q = true. - -Lemma Rle_antisym : forall x y : DReal, - Rle x y - -> Rle y x - -> x = y. -Proof. - intros [f cf] [g cg] H H0. unfold Rle in H,H0; simpl in H, H0. - assert (f = g). - { apply functional_extensionality. intro q. - specialize (H q). specialize (H0 q). - destruct (f q), (g q). - - reflexivity. - - exfalso. specialize (H (eq_refl _)). discriminate. - - exfalso. specialize (H0 (eq_refl _)). discriminate. - - reflexivity. } - subst g. replace cg with cf. - - reflexivity. - - apply isLowerCut_hprop. -Qed. - -Lemma DRealOpen : forall (x : DReal) (q : Q), - proj1_sig x q = true - -> { r : Q | Qlt q r /\ proj1_sig x r = true }. -Proof. - intros. - destruct (sig_forall_dec (fun n => Qle (proj1_sig (DRealQlim x n)) q)). - - intro n. destruct (DRealQlim x n); unfold proj1_sig. - destruct (Qlt_le_dec q x0). - + right. exact (Qlt_not_le _ _ q0). - + left. exact q0. - - destruct s. apply Qnot_le_lt in n. - destruct (DRealQlim x x0); unfold proj1_sig in n. - exists x1. split. - + exact n. - + apply a. - - exfalso. destruct x as [f low]. unfold proj1_sig in H, q0. - destruct low, a, a. apply (n1 q H). intros. - destruct (Qlt_le_dec q r). 2: left; exact q1. right. - destruct (Qarchimedean (/(r - q))) as [p pmaj]. - specialize (q0 (Pos.to_nat p)). - destruct (DRealQlim (exist _ f (conj e (conj n (conj n0 n1)))) (Pos.to_nat p)) - as [s smaj]. - unfold proj1_sig in smaj. - apply (lowerUpper f (s + (1 # Pos.of_nat (S (Pos.to_nat p))))). - + exact (conj e (conj n (conj n0 n1))). - + apply (Qle_trans _ (s + (r-q))). - * apply Qplus_le_r. apply (Qle_trans _ (1 # p)). - -- unfold Qle, Qnum, Qden. do 2 rewrite Z.mul_1_l. - apply Pos2Z.pos_le_pos. apply Pos2Nat.inj_le. - rewrite Nat2Pos.id. - ++ apply le_S, Nat.le_refl. - ++ discriminate. - -- apply (Qmult_le_l _ _ ( (Z.pos p # 1) / (r-q))). - ++ rewrite <- (Qmult_0_r (Z.pos p #1)). apply Qmult_lt_l. - ** reflexivity. - ** apply Qinv_lt_0_compat. - unfold Qminus. rewrite <- Qlt_minus_iff. exact q1. - ++ unfold Qdiv. rewrite Qmult_comm, <- Qmult_assoc. - rewrite (Qmult_comm (/(r-q))), Qmult_inv_r, Qmult_assoc. - ** setoid_replace ((1 # p) * (Z.pos p # 1))%Q with 1%Q. - 2: reflexivity. rewrite Qmult_1_l, Qmult_1_r. - apply Qlt_le_weak, pmaj. - ** intro abs. apply Qlt_minus_iff in q1. - rewrite abs in q1. apply (Qlt_not_le _ _ q1), Qle_refl. - * apply (Qplus_le_l _ _ (q-r)). ring_simplify. exact q0. - + apply smaj. -Qed. - -Lemma DRealReprQ : forall (x : DReal) (q : Q), - proj1_sig x q = true - -> CRealLt (inject_Q q) (DRealRepr x). -Proof. - intros x q H. - - (* expand and simplify goal and hypothesis *) - destruct (DRealOpen x q H) as [r rmaj]. - destruct (QarchimedeanLowExp2_Z ((1#4)*(r - q))) as [p pmaj]. - 1: lra. - exists (p)%Z. - destruct x as [f low]; unfold DRealRepr, CReal_of_DReal_seq, inject_Q; do 2 rewrite CReal_red_seq. - destruct (DRealQlimExp2 (exist _ f low) (Z.to_nat (-p))) as [s smaj]. - unfold proj1_sig in smaj, rmaj, H |- * . - rewrite <- (Qmult_lt_l _ _ 4%Q) in pmaj by lra. - setoid_replace (4 * ((1 # 4) * (r - q)))%Q with (r-q)%Q in pmaj by ring. - apply proj2 in rmaj. - apply proj2 in smaj. - - (* Use the fact that s+eps is above the cut and r is below the cut. - This limits the distance between s and r. *) - pose proof UpperAboveLower f _ _ low rmaj smaj as Hrltse; clear rmaj smaj. - pose proof Qpower_2_invneg_le_pow p as Hpowcut. - pose proof Qpower_0_lt 2 p ltac:(lra) as Hpowpos. - lra. -Qed. - -Lemma DRealReprQup : forall (x : DReal) (q : Q), - proj1_sig x q = false - -> CRealLe (DRealRepr x) (inject_Q q). -Proof. - intros x q H [p pmaj]. - - (* expand and simplify goal and hypothesis *) - unfold inject_Q, DRealRepr, CReal_of_DReal_seq in pmaj. do 2 rewrite CReal_red_seq in pmaj. - destruct (DRealQlimExp2 x (Z.to_nat (- p))) as [r rmaj]. - destruct x as [f low]. - unfold proj1_sig in pmaj, rmaj, H. - apply proj1 in rmaj. - - (* Use the fact that q is above the cut and r is below the cut. *) - pose proof UpperAboveLower f _ _ low rmaj H as Hrltse. - pose proof Qpower_0_lt 2 p ltac:(lra) as Hpowpos. - lra. -Qed. - -Lemma DRealQuot1 : forall x y:DReal, CRealEq (DRealRepr x) (DRealRepr y) -> x = y. -Proof. - intros. destruct H. apply Rle_antisym. - - clear H. intros q H1. destruct (proj1_sig y q) eqn:des. - + reflexivity. - + exfalso. apply H0. - apply (CReal_le_lt_trans _ (inject_Q q)). - * apply DRealReprQup. - exact des. - * apply DRealReprQ. exact H1. - - clear H0. intros q H1. destruct (proj1_sig x q) eqn:des. - + reflexivity. - + exfalso. apply H. - apply (CReal_le_lt_trans _ (inject_Q q)). - * apply DRealReprQup. - exact des. - * apply DRealReprQ. exact H1. -Qed. - -Lemma DRealAbstrFalse : forall (x : CReal) (q : Q) (n : nat), - proj1_sig (DRealAbstr x) q = false - -> (seq x (- Z.of_nat n) <= q + 2 ^ (- Z.of_nat n))%Q. -Proof. - intros x q n H. - unfold DRealAbstr, proj1_sig in H. - match type of H with context [ if ?a then _ else _ ] => destruct a as [H'|H']end. - - discriminate. - - apply H'. -Qed. - -(** For arbitrary n:Z, we need to relaxe the bound *) - -Lemma DRealAbstrFalse' : forall (x : CReal) (q : Q) (n : Z), - proj1_sig (DRealAbstr x) q = false - -> (seq x n <= q + 2*2^n)%Q. -Proof. - intros x q n H. - unfold DRealAbstr, proj1_sig in H. - match type of H with context [ if ?a then _ else _ ] => destruct a as [H'|H']end. - - discriminate. - - destruct (Z_le_gt_dec n 0) as [Hdec|Hdec]. - + specialize (H' (Z.to_nat (-n) )). - rewrite (Z2Nat.id (-n)%Z ltac:(lia)), Z.opp_involutive in H'. - pose proof Qpower_0_lt 2 n; lra. - + specialize (H' (Z.to_nat (0) )). cbn in H'. - pose proof cauchy x n%Z 0%Z n ltac:(lia) ltac:(lia) as Hxbnd. - apply Qabs_Qlt_condition in Hxbnd. - pose proof Qpower_1_le 2 n ltac:(lra) ltac:(lia). - lra. -Qed. - -Lemma DRealAbstrFalse'' : forall (x : CReal) (q : Q) (n : Z), - proj1_sig (DRealAbstr x) q = false - -> (seq x n <= q + 2^n + 1)%Q. -Proof. - intros x q n H. - unfold DRealAbstr, proj1_sig in H. - match type of H with context [ if ?a then _ else _ ] => destruct a as [H'|H']end. - - discriminate. - - destruct (Z_le_gt_dec n 0) as [Hdec|Hdec]. - + specialize (H' (Z.to_nat (-n) )). - rewrite (Z2Nat.id (-n)%Z ltac:(lia)), Z.opp_involutive in H'. - pose proof Qpower_0_lt 2 n; lra. - + specialize (H' (Z.to_nat (0) )). cbn in H'. - pose proof cauchy x n%Z 0%Z n ltac:(lia) ltac:(lia) as Hxbnd. - apply Qabs_Qlt_condition in Hxbnd. - lra. -Qed. - -Lemma DRealQuot2 : forall x:CReal, CRealEq (DRealRepr (DRealAbstr x)) x. -Proof. - split. - - intros [p pmaj]. - unfold DRealRepr in pmaj. - rewrite CReal_red_seq in pmaj. - destruct (Z_ge_lt_dec 0 p) as [Hdec|Hdec]. - + (* The usual case that p<=0 and 2^p is small *) - (* In this case the conversion of Z to nat and back is id *) - unfold CReal_of_DReal_seq in pmaj. - destruct (DRealQlimExp2 (DRealAbstr x) (Z.to_nat (- p))) as [q [Hql Hqr]]. - unfold proj1_sig in pmaj. - pose proof (DRealAbstrFalse x _ (Z.to_nat (- p)) Hqr) as Hq; clear Hql Hqr. - rewrite <- Qpower_2_neg_eq_natpow_inv in Hq. - rewrite Z2Nat.id, Z.opp_involutive in Hq by lia; clear Hdec. - lra. - + (* The case that p>0 and 2^p is large *) - (* In this case we use CReal_of_DReal_seq_max_prec_1 to rewrite the index to 0 *) - rewrite CReal_of_DReal_seq_max_prec_1 in pmaj by lia. - unfold CReal_of_DReal_seq in pmaj. - change (Z.to_nat (-0))%Z with 0%nat in pmaj. - destruct (DRealQlimExp2 (DRealAbstr x) 0) as [q [Hql Hqr]]. - unfold proj1_sig in pmaj. - pose proof (DRealAbstrFalse'' x _ p%nat Hqr) as Hq; clear Hql Hqr. - rewrite <- Qpower_2_neg_eq_natpow_inv in Hq. - change (- Z.of_nat 0)%Z with 0%Z in Hq. - pose proof (Qpower_le_compat_l 2 1 p ltac:(lia) ltac:(lra)) as Hpowle. - change (2^1)%Q with 2%Q in Hpowle. - lra. - - intros [p pmaj]. - unfold DRealRepr in pmaj. - rewrite CReal_red_seq in pmaj. - unfold CReal_of_DReal_seq in pmaj. - destruct (DRealQlimExp2 (DRealAbstr x) (Z.to_nat (- p))) as [q [Hql Hqr]]. - unfold proj1_sig in pmaj. - unfold DRealAbstr, proj1_sig in Hql. - match type of Hql with context [ if ?a then _ else _ ] => destruct a as [H'|H']end. - 2: discriminate. clear Hql Hqr. - destruct H' as [n nmaj]. apply nmaj; clear nmaj. - apply (Qplus_lt_l _ _ (seq x p + 2 ^ (- Z.of_nat n))) in pmaj. - ring_simplify in pmaj. apply Qlt_le_weak. rewrite Qplus_comm. - apply (Qlt_trans _ ((2 * 2^p) + seq x p + (2 ^ (- Z.of_nat n)))). - 2: exact pmaj. clear pmaj. - apply (Qplus_lt_l _ _ (-seq x p)). - apply (Qle_lt_trans _ _ _ (Qle_Qabs _)). - destruct (Z_le_gt_dec p (- Z.of_nat n)). - + apply (Qlt_trans _ (2 ^ (- Z.of_nat n))). - 1: apply (cauchy x). - 1, 2: lia. - pose proof Qpower_0_lt 2 p; lra. - + apply (Qlt_trans _ (2^p)). - 1: apply (cauchy x). - 1, 2: lia. - pose proof Qpower_0_lt 2 (- Z.of_nat n). - pose proof Qpower_0_lt 2 p. - lra. -Qed. diff --git a/stdlib/theories/Reals/Cos_plus.v b/stdlib/theories/Reals/Cos_plus.v deleted file mode 100644 index 17f01634b02f..000000000000 --- a/stdlib/theories/Reals/Cos_plus.v +++ /dev/null @@ -1,718 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* Rabs (Reste1 x y N) <= Majxy x y (pred N). -Proof. - intros. - set (C := Rmax 1 (Rmax (Rabs x) (Rabs y))). - unfold Reste1. - apply Rle_trans with - (sum_f_R0 - (fun k:nat => - Rabs - (sum_f_R0 - (fun l:nat => - (-1) ^ S (l + k) / INR (fact (2 * S (l + k))) * - x ^ (2 * S (l + k)) * - ((-1) ^ (N - l) / INR (fact (2 * (N - l)))) * - y ^ (2 * (N - l))) (pred (N - k)))) ( - pred N)). - { apply - (Rsum_abs - (fun k:nat => - sum_f_R0 - (fun l:nat => - (-1) ^ S (l + k) / INR (fact (2 * S (l + k))) * - x ^ (2 * S (l + k)) * ((-1) ^ (N - l) / INR (fact (2 * (N - l)))) * - y ^ (2 * (N - l))) (pred (N - k))) (pred N)). } - apply Rle_trans with - (sum_f_R0 - (fun k:nat => - sum_f_R0 - (fun l:nat => - Rabs - ((-1) ^ S (l + k) / INR (fact (2 * S (l + k))) * - x ^ (2 * S (l + k)) * - ((-1) ^ (N - l) / INR (fact (2 * (N - l)))) * - y ^ (2 * (N - l)))) (pred (N - k))) ( - pred N)). - { apply sum_Rle. - intros. - apply - (Rsum_abs - (fun l:nat => - (-1) ^ S (l + n) / INR (fact (2 * S (l + n))) * x ^ (2 * S (l + n)) * - ((-1) ^ (N - l) / INR (fact (2 * (N - l)))) * - y ^ (2 * (N - l))) (pred (N - n))). } - apply Rle_trans with - (sum_f_R0 - (fun k:nat => - sum_f_R0 - (fun l:nat => - / INR (fact (2 * S (l + k)) * fact (2 * (N - l))) * - C ^ (2 * S (N + k))) (pred (N - k))) (pred N)). - { apply sum_Rle; intros. - apply sum_Rle; intros. - unfold Rdiv; repeat rewrite Rabs_mult. - do 2 rewrite pow_1_abs. - do 2 rewrite Rmult_1_l. - rewrite (Rabs_right (/ INR (fact (2 * S (n0 + n))))). - 2:apply Rle_ge; left; apply Rinv_0_lt_compat; apply INR_fact_lt_0. - rewrite (Rabs_right (/ INR (fact (2 * (N - n0))))). - 2:apply Rle_ge; left; apply Rinv_0_lt_compat; apply INR_fact_lt_0. - rewrite mult_INR. - rewrite Rinv_mult. - repeat rewrite Rmult_assoc. - apply Rmult_le_compat_l. - { left; apply Rinv_0_lt_compat; apply INR_fact_lt_0. } - rewrite <- Rmult_assoc. - rewrite <- (Rmult_comm (/ INR (fact (2 * (N - n0))))). - rewrite Rmult_assoc. - apply Rmult_le_compat_l. - { left; apply Rinv_0_lt_compat; apply INR_fact_lt_0. } - do 2 rewrite <- RPow_abs. - apply Rle_trans with (Rabs x ^ (2 * S (n0 + n)) * C ^ (2 * (N - n0))). - { apply Rmult_le_compat_l. - { apply pow_le; apply Rabs_pos. } - apply pow_incr. - split. - { apply Rabs_pos. } - unfold C. - apply Rle_trans with (Rmax (Rabs x) (Rabs y)); apply RmaxLess2. } - apply Rle_trans with (C ^ (2 * S (n0 + n)) * C ^ (2 * (N - n0))). - { do 2 rewrite <- (Rmult_comm (C ^ (2 * (N - n0)))). - apply Rmult_le_compat_l. - { apply pow_le. - apply Rle_trans with 1. - { left; apply Rlt_0_1. } - unfold C; apply RmaxLess1. } - apply pow_incr. - split. - { apply Rabs_pos. } - unfold C; apply Rle_trans with (Rmax (Rabs x) (Rabs y)). - - apply RmaxLess1. - - apply RmaxLess2. } - right. - replace (2 * S (N + n))%nat with (2 * (N - n0) + 2 * S (n0 + n))%nat by lia. - rewrite pow_add. - apply Rmult_comm. } - apply Rle_trans with - (sum_f_R0 - (fun k:nat => - sum_f_R0 - (fun l:nat => - / INR (fact (2 * S (l + k)) * fact (2 * (N - l))) * C ^ (4 * N)) - (pred (N - k))) (pred N)). - { apply sum_Rle; intros. - apply sum_Rle; intros. - apply Rmult_le_compat_l. - { left; apply Rinv_0_lt_compat. - rewrite mult_INR; apply Rmult_lt_0_compat; apply INR_fact_lt_0. } - apply Rle_pow. - { unfold C; apply RmaxLess1. } - lia. } - apply Rle_trans with - (sum_f_R0 - (fun k:nat => - sum_f_R0 (fun l:nat => C ^ (4 * N) * Rsqr (/ INR (fact (S (N + k))))) - (pred (N - k))) (pred N)). - { apply sum_Rle; intros. - apply sum_Rle; intros. - rewrite <- (Rmult_comm (C ^ (4 * N))). - apply Rmult_le_compat_l. - { apply pow_le. - left; apply Rlt_le_trans with 1. - { apply Rlt_0_1. } - unfold C; apply RmaxLess1. } - replace (/ INR (fact (2 * S (n0 + n)) * fact (2 * (N - n0)))) with - (Binomial.C (2 * S (N + n)) (2 * S (n0 + n)) / INR (fact (2 * S (N + n)))). - 2:{ unfold Rdiv; rewrite Rmult_comm. - unfold Binomial.C. - unfold Rdiv; repeat rewrite <- Rmult_assoc. - rewrite Rinv_l. - { rewrite Rmult_1_l. - replace (2 * S (N + n) - 2 * S (n0 + n))%nat with (2 * (N - n0))%nat by lia. - rewrite mult_INR. - reflexivity. } - apply INR_fact_neq_0. } - apply Rle_trans with - (Binomial.C (2 * S (N + n)) (S (N + n)) / INR (fact (2 * S (N + n)))). - { unfold Rdiv; - do 2 rewrite <- (Rmult_comm (/ INR (fact (2 * S (N + n))))). - apply Rmult_le_compat_l. - { left; apply Rinv_0_lt_compat; apply INR_fact_lt_0. } - apply C_maj. - lia. } - right. - unfold Rdiv; rewrite Rmult_comm. - unfold Binomial.C. - unfold Rdiv; repeat rewrite <- Rmult_assoc. - rewrite Rinv_l. - 2:apply INR_fact_neq_0. - rewrite Rmult_1_l. - replace (2 * S (N + n) - S (N + n))%nat with (S (N + n)) by lia. - rewrite Rinv_mult. - unfold Rsqr; reflexivity. - } - apply Rle_trans with - (sum_f_R0 (fun k:nat => INR N / INR (fact (S N)) * C ^ (4 * N)) (pred N)). - { apply sum_Rle; intros. - rewrite <- (scal_sum (fun _:nat => C ^ (4 * N)) (pred (N - n)) - (Rsqr (/ INR (fact (S (N + n)))))). - rewrite sum_cte. - rewrite <- Rmult_assoc. - do 2 rewrite <- (Rmult_comm (C ^ (4 * N))). - rewrite Rmult_assoc. - apply Rmult_le_compat_l. - { apply pow_le. - left; apply Rlt_le_trans with 1. - { apply Rlt_0_1. } - unfold C; apply RmaxLess1. } - apply Rle_trans with (Rsqr (/ INR (fact (S (N + n)))) * INR N). - { apply Rmult_le_compat_l. - { apply Rle_0_sqr. } - apply le_INR. - lia. } - rewrite Rmult_comm; unfold Rdiv; apply Rmult_le_compat_l. - { apply pos_INR. } - apply Rle_trans with (/ INR (fact (S (N + n)))). - { pattern (/ INR (fact (S (N + n)))) at 2; rewrite <- Rmult_1_r. - unfold Rsqr. - apply Rmult_le_compat_l. - { left; apply Rinv_0_lt_compat; apply INR_fact_lt_0. } - apply Rmult_le_reg_l with (INR (fact (S (N + n)))). - { apply INR_fact_lt_0. } - rewrite Rinv_r. - { rewrite Rmult_1_r. - apply (le_INR 1). - apply Nat.le_succ_l. - apply INR_lt; apply INR_fact_lt_0. } - apply INR_fact_neq_0. } - apply Rmult_le_reg_l with (INR (fact (S (N + n)))). - { apply INR_fact_lt_0. } - rewrite Rinv_r. - 2:apply INR_fact_neq_0. - apply Rmult_le_reg_l with (INR (fact (S N))). - { apply INR_fact_lt_0. } - rewrite Rmult_1_r. - rewrite (Rmult_comm (INR (fact (S N)))). - rewrite Rmult_assoc. - rewrite Rinv_l. - 2:apply INR_fact_neq_0. - rewrite Rmult_1_r. - apply le_INR. - apply fact_le. - apply -> Nat.succ_le_mono. - apply Nat.le_add_r. - } - rewrite sum_cte. - apply Rle_trans with (C ^ (4 * N) / INR (fact (pred N))). - 2:{ right. - unfold Majxy. - unfold C. - replace (S (pred N)) with N by lia. - reflexivity. } - rewrite <- (Rmult_comm (C ^ (4 * N))). - unfold Rdiv; rewrite Rmult_assoc; apply Rmult_le_compat_l. - { apply pow_le. - left; apply Rlt_le_trans with 1. - { apply Rlt_0_1. } - unfold C; apply RmaxLess1. } - assert (S (pred N) = N) by lia. - rewrite H0. - pattern N at 2; rewrite <- H0. - do 2 rewrite fact_simpl. - rewrite H0. - repeat rewrite mult_INR. - repeat rewrite Rinv_mult. - rewrite (Rmult_comm (/ INR (S N))). - repeat rewrite <- Rmult_assoc. - rewrite Rinv_r. - 2:apply not_O_INR;lia. - rewrite Rmult_1_l. - pattern (/ INR (fact (pred N))) at 2; rewrite <- Rmult_1_r. - rewrite Rmult_assoc. - apply Rmult_le_compat_l. - { left; apply Rinv_0_lt_compat; apply INR_fact_lt_0. } - apply Rmult_le_reg_l with (INR (S N)). - { apply lt_INR_0; apply Nat.lt_0_succ. } - rewrite <- Rmult_assoc; rewrite Rinv_r. - { rewrite Rmult_1_r; rewrite Rmult_1_l. - apply le_INR; apply Nat.le_succ_diag_r. } - apply not_O_INR; discriminate. -Qed. - -Lemma reste2_maj : - forall (x y:R) (N:nat), (0 < N)%nat -> Rabs (Reste2 x y N) <= Majxy x y N. -Proof. - intros. - set (C := Rmax 1 (Rmax (Rabs x) (Rabs y))). - unfold Reste2. - apply Rle_trans with - (sum_f_R0 - (fun k:nat => - Rabs - (sum_f_R0 - (fun l:nat => - (-1) ^ S (l + k) / INR (fact (2 * S (l + k) + 1)) * - x ^ (2 * S (l + k) + 1) * - ((-1) ^ (N - l) / INR (fact (2 * (N - l) + 1))) * - y ^ (2 * (N - l) + 1)) (pred (N - k)))) ( - pred N)). - { apply - (Rsum_abs - (fun k:nat => - sum_f_R0 - (fun l:nat => - (-1) ^ S (l + k) / INR (fact (2 * S (l + k) + 1)) * - x ^ (2 * S (l + k) + 1) * - ((-1) ^ (N - l) / INR (fact (2 * (N - l) + 1))) * - y ^ (2 * (N - l) + 1)) (pred (N - k))) ( - pred N)). } - apply Rle_trans with - (sum_f_R0 - (fun k:nat => - sum_f_R0 - (fun l:nat => - Rabs - ((-1) ^ S (l + k) / INR (fact (2 * S (l + k) + 1)) * - x ^ (2 * S (l + k) + 1) * - ((-1) ^ (N - l) / INR (fact (2 * (N - l) + 1))) * - y ^ (2 * (N - l) + 1))) (pred (N - k))) ( - pred N)). - { apply sum_Rle. - intros. - apply - (Rsum_abs - (fun l:nat => - (-1) ^ S (l + n) / INR (fact (2 * S (l + n) + 1)) * - x ^ (2 * S (l + n) + 1) * - ((-1) ^ (N - l) / INR (fact (2 * (N - l) + 1))) * - y ^ (2 * (N - l) + 1)) (pred (N - n))). } - apply Rle_trans with - (sum_f_R0 - (fun k:nat => - sum_f_R0 - (fun l:nat => - / INR (fact (2 * S (l + k) + 1) * fact (2 * (N - l) + 1)) * - C ^ (2 * S (S (N + k)))) (pred (N - k))) ( - pred N)). - { apply sum_Rle; intros. - apply sum_Rle; intros. - unfold Rdiv; repeat rewrite Rabs_mult. - do 2 rewrite pow_1_abs. - do 2 rewrite Rmult_1_l. - rewrite (Rabs_right (/ INR (fact (2 * S (n0 + n) + 1)))). - 2:{ apply Rle_ge; left; apply Rinv_0_lt_compat. - apply INR_fact_lt_0. } - rewrite (Rabs_right (/ INR (fact (2 * (N - n0) + 1)))). - 2:{ apply Rle_ge; left; apply Rinv_0_lt_compat. - apply INR_fact_lt_0. } - rewrite mult_INR. - rewrite Rinv_mult. - repeat rewrite Rmult_assoc. - apply Rmult_le_compat_l. - { left; apply Rinv_0_lt_compat; apply INR_fact_lt_0. } - rewrite <- Rmult_assoc. - rewrite <- (Rmult_comm (/ INR (fact (2 * (N - n0) + 1)))). - rewrite Rmult_assoc. - apply Rmult_le_compat_l. - { left; apply Rinv_0_lt_compat; apply INR_fact_lt_0. } - do 2 rewrite <- RPow_abs. - apply Rle_trans with (Rabs x ^ (2 * S (n0 + n) + 1) * C ^ (2 * (N - n0) + 1)). - { apply Rmult_le_compat_l. - { apply pow_le; apply Rabs_pos. } - apply pow_incr. - split. - { apply Rabs_pos. } - unfold C. - apply Rle_trans with (Rmax (Rabs x) (Rabs y)); apply RmaxLess2. } - apply Rle_trans with (C ^ (2 * S (n0 + n) + 1) * C ^ (2 * (N - n0) + 1)). - 2:{ right. - replace (2 * S (S (N + n)))%nat with - (2 * (N - n0) + 1 + (2 * S (n0 + n) + 1))%nat by lia. - repeat rewrite pow_add. - ring. } - do 2 rewrite <- (Rmult_comm (C ^ (2 * (N - n0) + 1))). - apply Rmult_le_compat_l. - { apply pow_le. - apply Rle_trans with 1. - { left; apply Rlt_0_1. } - unfold C; apply RmaxLess1. } - apply pow_incr. - split. - { apply Rabs_pos. } - unfold C; apply Rle_trans with (Rmax (Rabs x) (Rabs y)). - - apply RmaxLess1. - - apply RmaxLess2. } - apply Rle_trans with - (sum_f_R0 - (fun k:nat => - sum_f_R0 - (fun l:nat => - / INR (fact (2 * S (l + k) + 1) * fact (2 * (N - l) + 1)) * - C ^ (4 * S N)) (pred (N - k))) (pred N)). - { apply sum_Rle; intros. - apply sum_Rle; intros. - apply Rmult_le_compat_l. - { left; apply Rinv_0_lt_compat. - rewrite mult_INR; apply Rmult_lt_0_compat; apply INR_fact_lt_0. } - apply Rle_pow. - { unfold C; apply RmaxLess1. } - lia. } - apply Rle_trans with - (sum_f_R0 - (fun k:nat => - sum_f_R0 - (fun l:nat => C ^ (4 * S N) * Rsqr (/ INR (fact (S (S (N + k)))))) - (pred (N - k))) (pred N)). - { apply sum_Rle; intros. - apply sum_Rle; intros. - rewrite <- (Rmult_comm (C ^ (4 * S N))). - apply Rmult_le_compat_l. - { apply pow_le. - left; apply Rlt_le_trans with 1. - { apply Rlt_0_1. } - unfold C; apply RmaxLess1. } - replace (/ INR (fact (2 * S (n0 + n) + 1) * fact (2 * (N - n0) + 1))) with - (Binomial.C (2 * S (S (N + n))) (2 * S (n0 + n) + 1) / - INR (fact (2 * S (S (N + n))))). - 2:{ unfold Rdiv; rewrite Rmult_comm. - unfold Binomial.C. - unfold Rdiv; repeat rewrite <- Rmult_assoc. - rewrite Rinv_l. - 2:{ apply INR_fact_neq_0. } - rewrite Rmult_1_l. - replace (2 * S (S (N + n)) - (2 * S (n0 + n) + 1))%nat with - (2 * (N - n0) + 1)%nat by lia. - rewrite mult_INR. - reflexivity. } - apply Rle_trans with - (Binomial.C (2 * S (S (N + n))) (S (S (N + n))) / - INR (fact (2 * S (S (N + n))))). - { unfold Rdiv; - do 2 rewrite <- (Rmult_comm (/ INR (fact (2 * S (S (N + n)))))). - apply Rmult_le_compat_l. - { left; apply Rinv_0_lt_compat; apply INR_fact_lt_0. } - apply C_maj. - lia. } - right. - unfold Rdiv; rewrite Rmult_comm. - unfold Binomial.C. - unfold Rdiv; repeat rewrite <- Rmult_assoc. - rewrite Rinv_l. - 2:{ apply INR_fact_neq_0. } - rewrite Rmult_1_l. - replace (2 * S (S (N + n)) - S (S (N + n)))%nat with (S (S (N + n))) by lia. - rewrite Rinv_mult. - unfold Rsqr; reflexivity. } - apply Rle_trans with - (sum_f_R0 (fun k:nat => INR N / INR (fact (S (S N))) * C ^ (4 * S N)) - (pred N)). - { apply sum_Rle; intros. - rewrite <- - (scal_sum (fun _:nat => C ^ (4 * S N)) (pred (N - n)) - (Rsqr (/ INR (fact (S (S (N + n))))))). - rewrite sum_cte. - rewrite <- Rmult_assoc. - do 2 rewrite <- (Rmult_comm (C ^ (4 * S N))). - rewrite Rmult_assoc. - apply Rmult_le_compat_l. - { apply pow_le. - left; apply Rlt_le_trans with 1. - { apply Rlt_0_1. } - unfold C; apply RmaxLess1. } - apply Rle_trans with (Rsqr (/ INR (fact (S (S (N + n))))) * INR N). - { apply Rmult_le_compat_l. - { apply Rle_0_sqr. } - apply le_INR. - lia. } - rewrite Rmult_comm; unfold Rdiv; apply Rmult_le_compat_l. - { apply pos_INR. } - apply Rle_trans with (/ INR (fact (S (S (N + n))))). - { pattern (/ INR (fact (S (S (N + n))))) at 2; rewrite <- Rmult_1_r. - unfold Rsqr. - apply Rmult_le_compat_l. - { left; apply Rinv_0_lt_compat; apply INR_fact_lt_0. } - apply Rmult_le_reg_l with (INR (fact (S (S (N + n))))). - { apply INR_fact_lt_0. } - rewrite Rinv_r. - { rewrite Rmult_1_r. - apply (le_INR 1). - apply Nat.le_succ_l. - apply INR_lt; apply INR_fact_lt_0. } - apply INR_fact_neq_0. } - apply Rmult_le_reg_l with (INR (fact (S (S (N + n))))). - { apply INR_fact_lt_0. } - rewrite Rinv_r. - 2:{ apply INR_fact_neq_0. } - apply Rmult_le_reg_l with (INR (fact (S (S N)))). - { apply INR_fact_lt_0. } - rewrite Rmult_1_r. - rewrite (Rmult_comm (INR (fact (S (S N))))). - rewrite Rmult_assoc. - rewrite Rinv_l. - 2:{ apply INR_fact_neq_0. } - rewrite Rmult_1_r. - apply le_INR. - apply fact_le. - lia. } - rewrite sum_cte. - apply Rle_trans with (C ^ (4 * S N) / INR (fact N)). - 2:{ right. - unfold Majxy. - unfold C. - reflexivity. } - rewrite <- (Rmult_comm (C ^ (4 * S N))). - unfold Rdiv; rewrite Rmult_assoc; apply Rmult_le_compat_l. - { apply pow_le. - left; apply Rlt_le_trans with 1. - { apply Rlt_0_1. } - unfold C; apply RmaxLess1. } - assert (S (pred N) = N) by lia. - rewrite H0. - do 2 rewrite fact_simpl. - repeat rewrite mult_INR. - repeat rewrite Rinv_mult. - apply Rle_trans with - (INR (S (S N)) * (/ INR (S (S N)) * (/ INR (S N) * / INR (fact N))) * INR N). - { repeat rewrite Rmult_assoc. - rewrite (Rmult_comm (INR N)). - rewrite (Rmult_comm (INR (S (S N)))). - apply Rmult_le_compat_l. - 2:{ apply le_INR. lia. } - repeat apply Rmult_le_pos; - left; try apply Rinv_0_lt_compat; try apply INR_fact_lt_0; apply lt_INR_0; try lia. } - repeat rewrite <- Rmult_assoc. - rewrite Rinv_r. - 2:{ apply not_O_INR; discriminate. } - rewrite Rmult_1_l. - apply Rle_trans with (/ INR (S N) * / INR (fact N) * INR (S N)). - { repeat rewrite Rmult_assoc. - repeat apply Rmult_le_compat_l. - 3:{ apply le_INR; apply Nat.le_succ_diag_r. } - 1,2:left; apply Rinv_0_lt_compat. - { apply lt_INR_0;lia. } - apply INR_fact_lt_0. } - rewrite (Rmult_comm (/ INR (S N))). - rewrite Rmult_assoc. - rewrite Rinv_l. - 2:{ apply not_O_INR; discriminate. } - rewrite Rmult_1_r; right; reflexivity. -Qed. - -Lemma reste1_cv_R0 : forall x y:R, Un_cv (Reste1 x y) 0. -Proof. - intros. - assert (H := Majxy_cv_R0 x y). - unfold Un_cv in H; unfold Rdist in H. - unfold Un_cv; unfold Rdist; intros. - elim (H eps H0); intros N0 H1. - exists (S N0); intros. - unfold Rminus; rewrite Ropp_0; rewrite Rplus_0_r. - apply Rle_lt_trans with (Rabs (Majxy x y (pred n))). - - rewrite (Rabs_right (Majxy x y (pred n))). - + apply reste1_maj. - apply Nat.lt_le_trans with (S N0). - * apply Nat.lt_0_succ. - * assumption. - + apply Rle_ge. - unfold Majxy. - unfold Rdiv; apply Rmult_le_pos. - * apply pow_le. - apply Rle_trans with 1. - -- left; apply Rlt_0_1. - -- apply RmaxLess1. - * left; apply Rinv_0_lt_compat; apply INR_fact_lt_0. - - replace (Majxy x y (pred n)) with (Majxy x y (pred n) - 0); [ idtac | ring ]. - apply H1. - unfold ge; apply le_S_n. - replace (S (pred n)) with n. - + assumption. - + symmetry; apply Nat.lt_succ_pred with 0%nat. - apply Nat.lt_le_trans with (S N0); [ apply Nat.lt_0_succ | assumption ]. -Qed. - -Lemma reste2_cv_R0 : forall x y:R, Un_cv (Reste2 x y) 0. -Proof. - intros. - assert (H := Majxy_cv_R0 x y). - unfold Un_cv in H; unfold Rdist in H. - unfold Un_cv; unfold Rdist; intros. - elim (H eps H0); intros N0 H1. - exists (S N0); intros. - unfold Rminus; rewrite Ropp_0; rewrite Rplus_0_r. - apply Rle_lt_trans with (Rabs (Majxy x y n)). - - rewrite (Rabs_right (Majxy x y n)). - + apply reste2_maj. - apply Nat.lt_le_trans with (S N0). - * apply Nat.lt_0_succ. - * assumption. - + apply Rle_ge. - unfold Majxy. - unfold Rdiv; apply Rmult_le_pos. - * apply pow_le. - apply Rle_trans with 1. - -- left; apply Rlt_0_1. - -- apply RmaxLess1. - * left; apply Rinv_0_lt_compat; apply INR_fact_lt_0. - - replace (Majxy x y n) with (Majxy x y n - 0); [ idtac | ring ]. - apply H1. - unfold ge; apply Nat.le_trans with (S N0). - + apply Nat.le_succ_diag_r. - + exact H2. -Qed. - -Lemma reste_cv_R0 : forall x y:R, Un_cv (Reste x y) 0. -Proof. - intros. - unfold Reste. - set (An := fun n:nat => Reste2 x y n). - set (Bn := fun n:nat => Reste1 x y (S n)). - cut - (Un_cv (fun n:nat => An n - Bn n) (0 - 0) -> - Un_cv (fun N:nat => Reste2 x y N - Reste1 x y (S N)) 0). - - intro. - apply H. - apply CV_minus. - + unfold An. - replace (fun n:nat => Reste2 x y n) with (Reste2 x y). - * apply reste2_cv_R0. - * reflexivity. - + unfold Bn. - assert (H0 := reste1_cv_R0 x y). - unfold Un_cv in H0; unfold Rdist in H0. - unfold Un_cv; unfold Rdist; intros. - elim (H0 eps H1); intros N0 H2. - exists N0; intros. - apply H2. - unfold ge; apply Nat.le_trans with (S N0). - * apply Nat.le_succ_diag_r. - * apply -> Nat.succ_le_mono; assumption. - - unfold An, Bn. - intro. - replace 0 with (0 - 0); [ idtac | ring ]. - exact H. -Qed. - -Theorem cos_plus : forall x y:R, cos (x + y) = cos x * cos y - sin x * sin y. -Proof. - intros. - cut (Un_cv (C1 x y) (cos x * cos y - sin x * sin y)). - { assert (Un_cv (C1 x y) (cos (x + y))) by apply C1_cvg. - intros. - apply UL_sequence with (C1 x y); assumption. } - unfold Un_cv; unfold Rdist. - intros. - assert (H0 := A1_cvg x). - assert (H1 := A1_cvg y). - assert (H2 := B1_cvg x). - assert (H3 := B1_cvg y). - assert (H4 := CV_mult _ _ _ _ H0 H1). - assert (H5 := CV_mult _ _ _ _ H2 H3). - assert (H6 := reste_cv_R0 x y). - unfold Un_cv in H4; unfold Un_cv in H5; unfold Un_cv in H6. - unfold Rdist in H4; unfold Rdist in H5; unfold Rdist in H6. - cut (0 < eps / 3); - [ intro - | unfold Rdiv; apply Rmult_lt_0_compat; - [ assumption | apply Rinv_0_lt_compat; prove_sup0 ] ]. - elim (H4 (eps / 3) H7); intros N1 H8. - elim (H5 (eps / 3) H7); intros N2 H9. - elim (H6 (eps / 3) H7); intros N3 H10. - set (N := S (S (max (max N1 N2) N3))). - exists N. - intros. - assert (n = S (pred n)) by lia. - rewrite H12. - rewrite <- cos_plus_form. - 2:lia. - rewrite <- H12. - apply Rle_lt_trans with - (Rabs (A1 x n * A1 y n - cos x * cos y) + - Rabs (sin x * sin y - B1 x (pred n) * B1 y (pred n) + Reste x y (pred n))). - { replace - (A1 x n * A1 y n - B1 x (pred n) * B1 y (pred n) + Reste x y (pred n) - - (cos x * cos y - sin x * sin y)) with - (A1 x n * A1 y n - cos x * cos y + - (sin x * sin y - B1 x (pred n) * B1 y (pred n) + Reste x y (pred n))); - [ apply Rabs_triang | ring ]. } - replace eps with (eps / 3 + (eps / 3 + eps / 3)) by field. - apply Rplus_lt_compat. - { apply H8. lia. } - apply Rle_lt_trans with - (Rabs (sin x * sin y - B1 x (pred n) * B1 y (pred n)) + - Rabs (Reste x y (pred n))). - { apply Rabs_triang. } - apply Rplus_lt_compat. - { rewrite <- Rabs_Ropp. - rewrite Ropp_minus_distr. - apply H9. lia. } - replace (Reste x y (pred n)) with (Reste x y (pred n) - 0) by ring. - apply H10. lia. -Qed. diff --git a/stdlib/theories/Reals/Cos_rel.v b/stdlib/theories/Reals/Cos_rel.v deleted file mode 100644 index e32b124f32e8..000000000000 --- a/stdlib/theories/Reals/Cos_rel.v +++ /dev/null @@ -1,324 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* (-1) ^ k / INR (fact (2 * k)) * x ^ (2 * k)) N. - -Definition B1 (x:R) (N:nat) : R := - sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k + 1)) * x ^ (2 * k + 1)) - N. - -Definition C1 (x y:R) (N:nat) : R := - sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k)) * (x + y) ^ (2 * k)) N. - -Definition Reste1 (x y:R) (N:nat) : R := - sum_f_R0 - (fun k:nat => - sum_f_R0 - (fun l:nat => - (-1) ^ S (l + k) / INR (fact (2 * S (l + k))) * - x ^ (2 * S (l + k)) * ((-1) ^ (N - l) / INR (fact (2 * (N - l)))) * - y ^ (2 * (N - l))) (pred (N - k))) (pred N). - -Definition Reste2 (x y:R) (N:nat) : R := - sum_f_R0 - (fun k:nat => - sum_f_R0 - (fun l:nat => - (-1) ^ S (l + k) / INR (fact (2 * S (l + k) + 1)) * - x ^ (2 * S (l + k) + 1) * - ((-1) ^ (N - l) / INR (fact (2 * (N - l) + 1))) * - y ^ (2 * (N - l) + 1)) (pred (N - k))) ( - pred N). - -Definition Reste (x y:R) (N:nat) : R := Reste2 x y N - Reste1 x y (S N). - -(* Here is the main result that will be used to prove that (cos (x+y))=(cos x)(cos y)-(sin x)(sin y) *) -Theorem cos_plus_form : - forall (x y:R) (n:nat), - (0 < n)%nat -> - A1 x (S n) * A1 y (S n) - B1 x n * B1 y n + Reste x y n = C1 x y (S n). -Proof. -intros. -unfold A1, B1. -rewrite - (cauchy_finite (fun k:nat => (-1) ^ k / INR (fact (2 * k)) * x ^ (2 * k)) - (fun k:nat => (-1) ^ k / INR (fact (2 * k)) * y ^ (2 * k)) ( - S n)). -2:nia. -rewrite - (cauchy_finite - (fun k:nat => (-1) ^ k / INR (fact (2 * k + 1)) * x ^ (2 * k + 1)) - (fun k:nat => (-1) ^ k / INR (fact (2 * k + 1)) * y ^ (2 * k + 1)) n H). -unfold Reste. -replace - (sum_f_R0 - (fun k:nat => - sum_f_R0 - (fun l:nat => - (-1) ^ S (l + k) / INR (fact (2 * S (l + k))) * - x ^ (2 * S (l + k)) * - ((-1) ^ (S n - l) / INR (fact (2 * (S n - l))) * - y ^ (2 * (S n - l)))) (pred (S n - k))) ( - pred (S n))) with (Reste1 x y (S n)). -2:{ unfold Reste1; apply sum_eq; intros. - apply sum_eq; intros. nra. } -replace - (sum_f_R0 - (fun k:nat => - sum_f_R0 - (fun l:nat => - (-1) ^ S (l + k) / INR (fact (2 * S (l + k) + 1)) * - x ^ (2 * S (l + k) + 1) * - ((-1) ^ (n - l) / INR (fact (2 * (n - l) + 1)) * - y ^ (2 * (n - l) + 1))) (pred (n - k))) ( - pred n)) with (Reste2 x y n). -2:{ unfold Reste2; apply sum_eq; intros. - apply sum_eq; intros. nra. } -replace - (sum_f_R0 - (fun k:nat => - sum_f_R0 - (fun p:nat => - (-1) ^ p / INR (fact (2 * p)) * x ^ (2 * p) * - ((-1) ^ (k - p) / INR (fact (2 * (k - p))) * y ^ (2 * (k - p)))) - k) (S n)) with - (sum_f_R0 - (fun k:nat => - (-1) ^ k / INR (fact (2 * k)) * - sum_f_R0 - (fun l:nat => C (2 * k) (2 * l) * x ^ (2 * l) * y ^ (2 * (k - l))) k) - (S n)). -2:{ apply sum_eq; intros. - rewrite scal_sum. - apply sum_eq; intros. - unfold Rdiv. - repeat rewrite <- Rmult_assoc. - rewrite <- (Rmult_comm (/ INR (fact (2 * i)))). - repeat rewrite <- Rmult_assoc. - replace (/ INR (fact (2 * i)) * C (2 * i) (2 * i0)) with - (/ INR (fact (2 * i0)) * / INR (fact (2 * (i - i0)))). - { replace ((-1) ^ i) with ((-1) ^ i0 * (-1) ^ (i - i0)). - - ring. - - pattern i at 2; replace i with (i0 + (i - i0))%nat by nia. - rewrite pow_add. - ring. } - unfold C. - unfold Rdiv; repeat rewrite <- Rmult_assoc. - rewrite Rinv_l. - 2:apply INR_fact_neq_0. - rewrite Rmult_1_l. - rewrite Rinv_mult. - replace (2 * i - 2 * i0)%nat with (2 * (i - i0))%nat by lia. - reflexivity. } -pose - (sin_nnn := - fun n:nat => - match n with - | O => 0 - | S p => - (-1) ^ S p / INR (fact (2 * S p)) * - sum_f_R0 - (fun l:nat => - C (2 * S p) (S (2 * l)) * x ^ S (2 * l) * y ^ S (2 * (p - l))) p - end). -ring_simplify. -unfold Rminus. -replace -(* (- old ring compat *) - (- - sum_f_R0 - (fun k:nat => - sum_f_R0 - (fun p:nat => - (-1) ^ p / INR (fact (2 * p + 1)) * x ^ (2 * p + 1) * - ((-1) ^ (k - p) / INR (fact (2 * (k - p) + 1)) * - y ^ (2 * (k - p) + 1))) k) n) with (sum_f_R0 sin_nnn (S n)). -- rewrite <- sum_plus. - unfold C1. - apply sum_eq; intros. - induction i as [| i Hreci]. - { unfold C; simpl. nra. } - unfold sin_nnn. - rewrite <- Rmult_plus_distr_l. - apply Rmult_eq_compat_l. - rewrite binomial. - pose (Wn := fun i0:nat => C (2 * S i) i0 * x ^ i0 * y ^ (2 * S i - i0)). - replace - (sum_f_R0 - (fun l:nat => C (2 * S i) (2 * l) * x ^ (2 * l) * y ^ (2 * (S i - l))) - (S i)) with (sum_f_R0 (fun l:nat => Wn (2 * l)%nat) (S i)). - 2:{ apply sum_eq; intros. - unfold Wn. - apply Rmult_eq_compat_l. - replace (2 * S i - 2 * i0)%nat with (2 * (S i - i0))%nat by lia. - reflexivity. } - replace - (sum_f_R0 - (fun l:nat => - C (2 * S i) (S (2 * l)) * x ^ S (2 * l) * y ^ S (2 * (i - l))) i) with - (sum_f_R0 (fun l:nat => Wn (S (2 * l))) i). - { apply sum_decomposition. } - apply sum_eq; intros. - unfold Wn. - apply Rmult_eq_compat_l. - replace (2 * S i - S (2 * i0))%nat with (S (2 * (i - i0))) by lia. - reflexivity. -- match goal with - |- _ = - ?r => - replace (- r) with (-1 * r) by ring - end. - rewrite scal_sum. - rewrite decomp_sum. - 2:nia. - replace (sin_nnn 0%nat) with 0 by reflexivity. - rewrite Rplus_0_l. - change (pred (S n)) with n. - apply sum_eq; intros. - rewrite Rmult_comm. - unfold sin_nnn. - rewrite scal_sum. - rewrite scal_sum. - apply sum_eq; intros. - unfold Rdiv. - repeat rewrite <- Rmult_assoc. - rewrite <- (Rmult_comm (/ INR (fact (2 * S i)))). - repeat rewrite <- Rmult_assoc. - replace (/ INR (fact (2 * S i)) * C (2 * S i) (S (2 * i0))) with - (/ INR (fact (2 * i0 + 1)) * / INR (fact (2 * (i - i0) + 1))). - { replace (S (2 * i0)) with (2 * i0 + 1)%nat; [ idtac | ring ]. - replace (S (2 * (i - i0))) with (2 * (i - i0) + 1)%nat; [ idtac | ring ]. - replace ((-1) ^ S i) with (-1 * (-1) ^ i0 * (-1) ^ (i - i0)). - { ring. } - simpl. - pattern i at 2; replace i with (i0 + (i - i0))%nat by nia. - rewrite pow_add. - ring. } - unfold C. - unfold Rdiv; repeat rewrite <- Rmult_assoc. - rewrite Rinv_l. - 2:apply INR_fact_neq_0. - rewrite Rmult_1_l. - rewrite Rinv_mult. - replace (S (2 * i0)) with (2 * i0 + 1)%nat; - [ apply Rmult_eq_compat_l | ring ]. - replace (2 * S i - (2 * i0 + 1))%nat with (2 * (i - i0) + 1)%nat by lia. - reflexivity. -Qed. - -Lemma pow_sqr : forall (x:R) (i:nat), x ^ (2 * i) = (x * x) ^ i. -Proof. -intros. -assert (H := pow_Rsqr x i). -unfold Rsqr in H; exact H. -Qed. - -Lemma A1_cvg : forall x:R, Un_cv (A1 x) (cos x). -Proof. -intro. -unfold cos; destruct (exist_cos (Rsqr x)) as (x0,p). -unfold cos_in, cos_n, infinite_sum, Rdist in p. -unfold Un_cv, Rdist; intros. -destruct (p eps H) as (x1,H0). -exists x1; intros. -unfold A1. -replace - (sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k)) * x ^ (2 * k)) n) with - (sum_f_R0 (fun i:nat => (-1) ^ i / INR (fact (2 * i)) * (x * x) ^ i) n). -- apply H0; assumption. -- apply sum_eq. - intros. - replace ((x * x) ^ i) with (x ^ (2 * i)). - + reflexivity. - + apply pow_sqr. -Qed. - -Lemma C1_cvg : forall x y:R, Un_cv (C1 x y) (cos (x + y)). -Proof. -intros. -unfold cos. -destruct (exist_cos (Rsqr (x + y))) as (x0,p). -unfold cos_in, cos_n, infinite_sum, Rdist in p. -unfold Un_cv, Rdist; intros. -destruct (p eps H) as (x1,H0). -exists x1; intros. -unfold C1. -replace - (sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k)) * (x + y) ^ (2 * k)) n) - with - (sum_f_R0 - (fun i:nat => (-1) ^ i / INR (fact (2 * i)) * ((x + y) * (x + y)) ^ i) n). -- apply H0; assumption. -- apply sum_eq. - intros. - replace (((x + y) * (x + y)) ^ i) with ((x + y) ^ (2 * i)). - + reflexivity. - + apply pow_sqr. -Qed. - -Lemma B1_cvg : forall x:R, Un_cv (B1 x) (sin x). -Proof. -intro. -case (Req_dec x 0); intro. -{ rewrite H. - rewrite sin_0. - unfold B1. - unfold Un_cv; unfold Rdist; intros; exists 0%nat; intros. - replace (sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k + 1)) * 0 ^ (2 * k + 1)) n) with 0. - { unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0; assumption. } - - induction n as [| n Hrecn]. - { simpl; ring. } - rewrite tech5; rewrite <- Hrecn. - { simpl; ring. } - unfold ge; apply Nat.le_0_l. } -unfold sin. destruct (exist_sin (Rsqr x)) as (x0,p). -unfold sin_in, sin_n, infinite_sum, Rdist in p. -unfold Un_cv, Rdist; intros. -cut (0 < eps / Rabs x); - [ intro - | unfold Rdiv; apply Rmult_lt_0_compat; - [ assumption | apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption ] ]. -destruct (p (eps / Rabs x) H1) as (x1,H2). -exists x1; intros. -unfold B1. -replace - (sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k + 1)) * x ^ (2 * k + 1)) - n) with - (x * - sum_f_R0 (fun i:nat => (-1) ^ i / INR (fact (2 * i + 1)) * (x * x) ^ i) n). -2:{ rewrite scal_sum. - apply sum_eq. - intros. - rewrite pow_add. - rewrite pow_sqr. - simpl. - ring. } -replace - (x * - sum_f_R0 (fun i:nat => (-1) ^ i / INR (fact (2 * i + 1)) * (x * x) ^ i) n - - x * x0) with - (x * - (sum_f_R0 (fun i:nat => (-1) ^ i / INR (fact (2 * i + 1)) * (x * x) ^ i) n - - x0)); [ idtac | ring ]. -rewrite Rabs_mult. -apply Rmult_lt_reg_l with (/ Rabs x). -{ apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption. } -rewrite <- Rmult_assoc, Rinv_l, Rmult_1_l, <- (Rmult_comm eps). -- apply H2; assumption. -- apply Rabs_no_R0; assumption. -Qed. diff --git a/stdlib/theories/Reals/DiscrR.v b/stdlib/theories/Reals/DiscrR.v deleted file mode 100644 index 333a97ad86c8..000000000000 --- a/stdlib/theories/Reals/DiscrR.v +++ /dev/null @@ -1,69 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* IZR z1 = IZR z2. -Proof. -intros; rewrite H; reflexivity. -Qed. - -Ltac discrR := - try - match goal with - | |- (?X1 <> ?X2) => - repeat - rewrite <- plus_IZR || - rewrite <- mult_IZR || - rewrite <- Ropp_Ropp_IZR || rewrite Z_R_minus; - apply eq_IZR_contrapositive; try discriminate - end. - -Ltac prove_sup0 := - match goal with - | |- (0 < 1) => apply Rlt_0_1 - | |- (0 < ?X1) => - repeat - (apply Rmult_lt_0_compat || apply Rplus_lt_pos; - try apply Rlt_0_1 || apply Rlt_R0_R2) - | |- (?X1 > 0) => change (0 < X1); prove_sup0 - end. - -Ltac omega_sup := - repeat - rewrite <- plus_IZR || - rewrite <- mult_IZR || rewrite <- Ropp_Ropp_IZR || rewrite Z_R_minus; - apply IZR_lt; lia. - -Ltac prove_sup := - match goal with - | |- (?X1 > ?X2) => change (X2 < X1); prove_sup - | |- (0 < ?X1) => prove_sup0 - | |- (- ?X1 < 0) => rewrite <- Ropp_0; prove_sup - | |- (- ?X1 < - ?X2) => apply Ropp_lt_gt_contravar; prove_sup - | |- (- ?X1 < ?X2) => apply Rlt_trans with 0; prove_sup - | |- (?X1 < ?X2) => omega_sup - | _ => idtac - end. - -Ltac Rcompute := - repeat - rewrite <- plus_IZR || - rewrite <- mult_IZR || rewrite <- Ropp_Ropp_IZR || rewrite Z_R_minus; - apply IZR_eq; try reflexivity. diff --git a/stdlib/theories/Reals/Exp_prop.v b/stdlib/theories/Reals/Exp_prop.v deleted file mode 100644 index 45ffc363d917..000000000000 --- a/stdlib/theories/Reals/Exp_prop.v +++ /dev/null @@ -1,755 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* / INR (fact k) * x ^ k) N. - -Lemma E1_cvg : forall x:R, Un_cv (E1 x) (exp x). -Proof. - intro; unfold exp; unfold projT1. - case (exist_exp x); intro. - unfold exp_in, Un_cv; unfold infinite_sum, E1; trivial. -Qed. - -Definition Reste_E (x y:R) (N:nat) : R := - sum_f_R0 - (fun k:nat => - sum_f_R0 - (fun l:nat => - / INR (fact (S (l + k))) * x ^ S (l + k) * - (/ INR (fact (N - l)) * y ^ (N - l))) ( - pred (N - k))) (pred N). - -Lemma exp_form : - forall (x y:R) (n:nat), - (0 < n)%nat -> E1 x n * E1 y n - Reste_E x y n = E1 (x + y) n. -Proof. - intros; unfold E1. - rewrite cauchy_finite. - - unfold Reste_E; unfold Rminus; rewrite Rplus_assoc; - rewrite Rplus_opp_r; rewrite Rplus_0_r; apply sum_eq; - intros. - rewrite binomial. - rewrite scal_sum; apply sum_eq; intros. - unfold C; unfold Rdiv; repeat rewrite Rmult_assoc; - rewrite (Rmult_comm (INR (fact i))); repeat rewrite Rmult_assoc; - rewrite Rinv_l. - + rewrite Rmult_1_r; rewrite Rinv_mult. - ring. - + apply INR_fact_neq_0. - - apply H. -Qed. - -Definition maj_Reste_E (x y:R) (N:nat) : R := - 4 * - (Rmax 1 (Rmax (Rabs x) (Rabs y)) ^ (2 * N) / - Rsqr (INR (fact (Nat.div2 (pred N))))). - -(**********) -Lemma div2_double : forall N:nat, Nat.div2 (2 * N) = N. -Proof. exact Nat.div2_double. Qed. - -Lemma div2_S_double : forall N:nat, Nat.div2 (S (2 * N)) = N. -Proof. - intro; induction N as [| N HrecN]. - - reflexivity. - - replace (2 * S N)%nat with (S (S (2 * N))). - + simpl; simpl in HrecN; rewrite HrecN; reflexivity. - + ring. -Qed. - -Lemma div2_not_R0 : forall N:nat, (1 < N)%nat -> (0 < Nat.div2 N)%nat. -Proof. - intros; induction N as [| N HrecN]. - - elim (Nat.nlt_0_r _ H). - - cut ((1 < N)%nat \/ N = 1%nat). - { intro; elim H0; intro. - - destruct N; cbn; [ auto | apply Nat.lt_0_succ ]. - - subst N; simpl; apply Nat.lt_0_succ. } - inversion H. - + right; reflexivity. - + left; apply Nat.lt_le_trans with 2%nat; [ apply Nat.lt_succ_diag_r | assumption ]. -Qed. - -Lemma Reste_E_maj : - forall (x y:R) (N:nat), - (0 < N)%nat -> Rabs (Reste_E x y N) <= maj_Reste_E x y N. -Proof. - intros; set (M := Rmax 1 (Rmax (Rabs x) (Rabs y))). - assert (HM1 : 1 <= M) by apply RmaxLess1. - assert (HMx : Rabs x <= M) by (eapply Rle_trans;[apply RmaxLess1|apply RmaxLess2]). - assert (HMy : Rabs y <= M) by (eapply Rle_trans;[apply RmaxLess2|apply RmaxLess2]). - pose proof (Rabs_pos x) as HPosAbsx. - pose proof (Rabs_pos y) as HPosAbsy. - apply Rle_trans with - (M ^ (2 * N) * - sum_f_R0 - (fun k:nat => - sum_f_R0 (fun l:nat => / Rsqr (INR (fact (Nat.div2 (S N))))) - (pred (N - k))) (pred N)). - - unfold Reste_E. - apply Rle_trans with - (sum_f_R0 - (fun k:nat => - Rabs - (sum_f_R0 - (fun l:nat => - / INR (fact (S (l + k))) * x ^ S (l + k) * - (/ INR (fact (N - l)) * y ^ (N - l))) ( - pred (N - k)))) (pred N)). - { apply - (Rsum_abs - (fun k:nat => - sum_f_R0 - (fun l:nat => - / INR (fact (S (l + k))) * x ^ S (l + k) * - (/ INR (fact (N - l)) * y ^ (N - l))) ( - pred (N - k))) (pred N)). } - apply Rle_trans with - (sum_f_R0 - (fun k:nat => - sum_f_R0 - (fun l:nat => - Rabs - (/ INR (fact (S (l + k))) * x ^ S (l + k) * - (/ INR (fact (N - l)) * y ^ (N - l)))) ( - pred (N - k))) (pred N)). - { apply sum_Rle; intros. - apply - (Rsum_abs - (fun l:nat => - / INR (fact (S (l + n))) * x ^ S (l + n) * - (/ INR (fact (N - l)) * y ^ (N - l)))). } - apply Rle_trans with - (sum_f_R0 - (fun k:nat => - sum_f_R0 - (fun l:nat => - M ^ (2 * N) * / INR (fact (S l)) * / INR (fact (N - l))) - (pred (N - k))) (pred N)). - + apply sum_Rle; intros. - apply sum_Rle; intros. - repeat rewrite Rabs_mult. - do 2 rewrite <- RPow_abs. - rewrite (Rabs_right (/ INR (fact (S (n0 + n))))). - 2:{ apply Rle_ge; left; apply Rinv_0_lt_compat; apply INR_fact_lt_0. } - rewrite (Rabs_right (/ INR (fact (N - n0)))). - 2:{ apply Rle_ge; left; apply Rinv_0_lt_compat; apply INR_fact_lt_0. } - replace - (/ INR (fact (S (n0 + n))) * Rabs x ^ S (n0 + n) * - (/ INR (fact (N - n0)) * Rabs y ^ (N - n0))) with - (/ INR (fact (N - n0)) * / INR (fact (S (n0 + n))) * Rabs x ^ S (n0 + n) * - Rabs y ^ (N - n0)) - by ring. - rewrite <- (Rmult_comm (/ INR (fact (N - n0)))). - repeat rewrite Rmult_assoc. - apply Rmult_le_compat_l. - { left; apply Rinv_0_lt_compat; apply INR_fact_lt_0. } - apply Rle_trans with - (/ INR (fact (S n0)) * Rabs x ^ S (n0 + n) * Rabs y ^ (N - n0)). - { rewrite (Rmult_comm (/ INR (fact (S (n0 + n))))); - rewrite (Rmult_comm (/ INR (fact (S n0)))); repeat rewrite Rmult_assoc; - apply Rmult_le_compat_l. - { apply pow_le; apply Rabs_pos. } - rewrite (Rmult_comm (/ INR (fact (S n0)))); apply Rmult_le_compat_l. - { apply pow_le; apply Rabs_pos. } - apply Rinv_le_contravar. - { apply INR_fact_lt_0. } - apply le_INR; apply fact_le; lia. } - rewrite (Rmult_comm (M ^ (2 * N))); rewrite Rmult_assoc; - apply Rmult_le_compat_l. - { left; apply Rinv_0_lt_compat; apply INR_fact_lt_0. } - apply Rle_trans with (M ^ S (n0 + n) * Rabs y ^ (N - n0)). - { do 2 rewrite <- (Rmult_comm (Rabs y ^ (N - n0))). - apply Rmult_le_compat_l. - { apply pow_le; apply Rabs_pos. } - apply pow_incr; split;lra. } - apply Rle_trans with (M ^ S (n0 + n) * M ^ (N - n0)). - { apply Rmult_le_compat_l. - { apply pow_le; lra. } - apply pow_incr; split; lra. } - rewrite <- pow_add; replace (S (n0 + n) + (N - n0))%nat with (N + S n)%nat by lia. - apply Rle_pow. - { assumption. } - lia. - + rewrite scal_sum. - apply sum_Rle; intros. - rewrite <- Rmult_comm. - rewrite scal_sum. - apply sum_Rle; intros. - rewrite (Rmult_comm (/ Rsqr (INR (fact (Nat.div2 (S N)))))). - rewrite Rmult_assoc; apply Rmult_le_compat_l. - { apply pow_le. lra. } - assert (H2 := even_odd_cor N). - elim H2; intros N0 H3. - elim H3; intro. - * apply Rle_trans with (/ INR (fact n0) * / INR (fact (N - n0))). - { do 2 rewrite <- (Rmult_comm (/ INR (fact (N - n0)))). - apply Rmult_le_compat_l. - { left; apply Rinv_0_lt_compat; apply INR_fact_lt_0. } - apply Rinv_le_contravar. - { apply INR_fact_lt_0. } - apply le_INR. - apply fact_le. - apply Nat.le_succ_diag_r. } - replace (/ INR (fact n0) * / INR (fact (N - n0))) with - (C N n0 / INR (fact N)). - 2:{ unfold C, Rdiv. - rewrite (Rmult_comm (INR (fact N))). - repeat rewrite Rmult_assoc. - rewrite Rinv_r. - 2:{ apply INR_fact_neq_0. } - rewrite Rinv_mult. - rewrite Rmult_1_r; ring. } - pattern N at 1; rewrite H4. - apply Rle_trans with (C N N0 / INR (fact N)). - { unfold Rdiv; do 2 rewrite <- (Rmult_comm (/ INR (fact N))). - apply Rmult_le_compat_l. - { left; apply Rinv_0_lt_compat; apply INR_fact_lt_0. } - rewrite H4. - apply C_maj. - lia. } - replace (C N N0 / INR (fact N)) with (/ Rsqr (INR (fact N0))). - { rewrite H4; rewrite div2_S_double; right; reflexivity. } - unfold Rsqr, C, Rdiv. - repeat rewrite Rinv_mult. - rewrite (Rmult_comm (INR (fact N))). - repeat rewrite Rmult_assoc. - rewrite Rinv_r. - 2:apply INR_fact_neq_0. - replace (N - N0)%nat with N0 by lia. - ring. - * replace (/ INR (fact (S n0)) * / INR (fact (N - n0))) with - (C (S N) (S n0) / INR (fact (S N))). - 2:{ unfold C, Rdiv. - rewrite (Rmult_comm (INR (fact (S N)))). - rewrite Rmult_assoc; rewrite Rinv_r. - 2:{ apply INR_fact_neq_0. } - rewrite Rmult_1_r; rewrite Rinv_mult. - reflexivity. } - apply Rle_trans with (C (S N) (S N0) / INR (fact (S N))). - 2:{ assert (S N = (2 * S N0)%nat) by lia. - replace (C (S N) (S N0) / INR (fact (S N))) with (/ Rsqr (INR (fact (S N0)))). - { rewrite H5; rewrite div2_double. - right; reflexivity. } - unfold Rsqr, C, Rdiv. - repeat rewrite Rinv_mult. - replace (S N - S N0)%nat with (S N0) by lia. - rewrite (Rmult_comm (INR (fact (S N)))). - repeat rewrite Rmult_assoc. - rewrite Rinv_r. - 2:apply INR_fact_neq_0. - ring. } - unfold Rdiv; do 2 rewrite <- (Rmult_comm (/ INR (fact (S N)))). - apply Rmult_le_compat_l. - { left; apply Rinv_0_lt_compat; apply INR_fact_lt_0. } - assert (S N = (2 * S N0)%nat) by (rewrite H4; ring). - rewrite H5; apply C_maj. - lia. - - unfold maj_Reste_E. fold M. - unfold Rdiv; rewrite (Rmult_comm 4). - rewrite Rmult_assoc. - apply Rmult_le_compat_l. - { apply pow_le. lra. } - apply Rle_trans with - (sum_f_R0 (fun k:nat => INR (N - k) * / Rsqr (INR (fact (Nat.div2 (S N))))) - (pred N)). - { apply sum_Rle; intros. - rewrite sum_cte. - replace (S (pred (N - n))) with (N - n)%nat by lia. - right; apply Rmult_comm. } - apply Rle_trans with - (sum_f_R0 (fun k:nat => INR N * / Rsqr (INR (fact (Nat.div2 (S N))))) (pred N)). - { apply sum_Rle; intros. - do 2 rewrite <- (Rmult_comm (/ Rsqr (INR (fact (Nat.div2 (S N)))))). - apply Rmult_le_compat_l. - { left; apply Rinv_0_lt_compat; apply Rsqr_pos_lt. - apply INR_fact_neq_0. } - apply le_INR. - lia. } - rewrite sum_cte; replace (S (pred N)) with N by lia. - assert (Nat.div2 (S N) = S (Nat.div2 (pred N))). { - assert (H0 := even_odd_cor N). - elim H0; intros N0 H1. - elim H1; intro. - - assert (0 < N0)%nat by lia. - rewrite H2. - rewrite div2_S_double. - replace (2 * N0)%nat with (S (S (2 * pred N0))) by lia. - replace (pred (S (S (2 * pred N0)))) with (S (2 * pred N0)) by lia. - rewrite div2_S_double. - lia. - - rewrite H2. - change (pred (S (2 * N0))) with (2 * N0)%nat. - replace (S (S (2 * N0))) with (2 * S N0)%nat by ring. - do 2 rewrite div2_double. - reflexivity. - } - rewrite H0. - rewrite fact_simpl; rewrite Nat.mul_comm; rewrite mult_INR; rewrite Rsqr_mult. - rewrite Rinv_mult. - rewrite (Rmult_comm (INR N)); repeat rewrite Rmult_assoc; - apply Rmult_le_compat_l. - { left; apply Rinv_0_lt_compat; apply Rsqr_pos_lt; apply INR_fact_neq_0. } - rewrite <- H0. - assert (INR N <= INR (2 * Nat.div2 (S N))). { - assert (H1 := even_odd_cor N). - elim H1; intros N0 H2. - elim H2; intro. - - pattern N at 2; rewrite H3. - rewrite div2_S_double. - rewrite H3. apply Rle_refl. - - pattern N at 2; rewrite H3. - replace (S (S (2 * N0))) with (2 * S N0)%nat by lia. - rewrite div2_double. - apply le_INR. lia. - } - apply Rmult_le_reg_l with (Rsqr (INR (Nat.div2 (S N)))). - { apply Rsqr_pos_lt. - apply not_O_INR; red; intro. - PreOmega.zify; PreOmega.Z.to_euclidean_division_equations; lia. } - repeat rewrite <- Rmult_assoc. - rewrite Rinv_r. - 2:{ unfold Rsqr; apply prod_neq_R0; apply not_O_INR; - PreOmega.zify; PreOmega.Z.to_euclidean_division_equations; lia. } - rewrite Rmult_1_l. - change 4 with (Rsqr 2). - rewrite <- Rsqr_mult. - apply Rsqr_incr_1. - { change 2 with (INR 2). - rewrite Rmult_comm, <- mult_INR; apply H1. } - { left; apply lt_INR_0; apply H. } - change 2 with (INR 2). - rewrite <- mult_INR. - apply pos_INR. -Qed. - -Lemma maj_Reste_cv_R0 : forall x y:R, Un_cv (maj_Reste_E x y) 0. -Proof. - intros; assert (H := Majxy_cv_R0 x y). - unfold Un_cv in H; unfold Un_cv; intros. - cut (0 < eps / 4); - [ intro - | unfold Rdiv; apply Rmult_lt_0_compat; - [ assumption | apply Rinv_0_lt_compat; prove_sup0 ] ]. - elim (H _ H1); intros N0 H2. - exists (max (2 * S N0) 2); intros. - unfold Rdist in H2; unfold Rdist; rewrite Rminus_0_r; - unfold Majxy in H2; unfold maj_Reste_E. - set (M := Rmax 1 (Rmax (Rabs x) (Rabs y))) in *. - assert (HM1 : 1 <= M) by apply RmaxLess1. - assert (HMx : Rabs x <= M) by (eapply Rle_trans;[apply RmaxLess1|apply RmaxLess2]). - assert (HMy : Rabs y <= M) by (eapply Rle_trans;[apply RmaxLess2|apply RmaxLess2]). - pose proof (Rabs_pos x) as HPosAbsx. - pose proof (Rabs_pos y) as HPosAbsy. - rewrite Rabs_right. - 2:{ apply Rle_ge. - unfold Rdiv; apply Rmult_le_pos. - { left; prove_sup0. } - apply Rmult_le_pos. - { apply pow_le. lra. } - left; apply Rinv_0_lt_compat; apply Rsqr_pos_lt; apply INR_fact_neq_0. } - apply Rle_lt_trans with - (4 * - (M ^ (4 * S (Nat.div2 (pred n))) / - INR (fact (Nat.div2 (pred n))))). - - apply Rmult_le_compat_l. - { left; prove_sup0. } - unfold Rdiv, Rsqr; rewrite Rinv_mult. - rewrite (Rmult_comm (M ^ (2 * n))); - rewrite - (Rmult_comm (M ^ (4 * S (Nat.div2 (pred n))))) - ; rewrite Rmult_assoc; apply Rmult_le_compat_l. - { left; apply Rinv_0_lt_compat; apply INR_fact_lt_0. } - apply Rle_trans with (M ^ (2 * n)). - { rewrite Rmult_comm; - pattern (M ^ (2 * n)) at 2; - rewrite <- Rmult_1_r; apply Rmult_le_compat_l. - { apply pow_le; lra. } - apply Rmult_le_reg_l with (INR (fact (Nat.div2 (pred n)))). - { apply INR_fact_lt_0. } - rewrite Rmult_1_r; rewrite Rinv_r. - { apply (le_INR 1). - apply Nat.le_succ_l. - apply INR_lt. - apply INR_fact_lt_0. } - apply INR_fact_neq_0. } - apply Rle_pow. - { apply RmaxLess1. } - assert (H4 := even_odd_cor n). - elim H4; intros N1 H5. - elim H5; intro. - { assert (0 < N1)%nat by lia. - rewrite H6. - replace (pred (2 * N1)) with (S (2 * pred N1)) by lia. - rewrite div2_S_double. - lia. } - rewrite H6. - replace (pred (S (2 * N1))) with (2 * N1)%nat by lia. - rewrite div2_double. - lia. - - apply Rmult_lt_reg_l with (/ 4). - { apply Rinv_0_lt_compat; prove_sup0. } - rewrite <- Rmult_assoc; rewrite Rinv_l. - 2:discrR. - rewrite Rmult_1_l; rewrite Rmult_comm. - replace - (M ^ (4 * S (Nat.div2 (pred n))) / - INR (fact (Nat.div2 (pred n)))) with - (Rabs - (M ^ (4 * S (Nat.div2 (pred n))) / - INR (fact (Nat.div2 (pred n))) - 0)). - 2:{ rewrite Rminus_0_r; apply Rabs_right. - apply Rle_ge. - unfold Rdiv; apply Rmult_le_pos. - { apply pow_le. lra. } - left; apply Rinv_0_lt_compat; apply INR_fact_lt_0. } - apply H2; unfold ge. - assert (2 * S N0 <= n)%nat by lia. - apply le_S_n. - apply INR_le; apply Rmult_le_reg_l with (INR 2). - { simpl; prove_sup0. } - do 2 rewrite <- mult_INR; apply le_INR. - apply Nat.le_trans with n. - { apply H4. } - assert (H5 := even_odd_cor n). - elim H5; intros N1 H6. - elim H6; intro. - { assert (0 < N1)%nat by lia. - rewrite H7. - apply Nat.mul_le_mono_nonneg_l. - { apply Nat.le_0_l. } - replace (pred (2 * N1)) with (S (2 * pred N1)) by lia. - rewrite div2_S_double. - lia. } - rewrite H7. - change (pred (S (2 * N1))) with (2 * N1)%nat. - rewrite div2_double. - lia. -Qed. - -(**********) -Lemma Reste_E_cv : forall x y:R, Un_cv (Reste_E x y) 0. -Proof. - intros; assert (H := maj_Reste_cv_R0 x y). - unfold Un_cv in H; unfold Un_cv; intros; elim (H _ H0); intros. - exists (max x0 1); intros. - unfold Rdist; rewrite Rminus_0_r. - apply Rle_lt_trans with (maj_Reste_E x y n). - - apply Reste_E_maj. - apply Nat.lt_le_trans with 1%nat. - + apply Nat.lt_0_succ. - + apply Nat.le_trans with (max x0 1). - * apply Nat.le_max_r. - * apply H2. - - replace (maj_Reste_E x y n) with (Rdist (maj_Reste_E x y n) 0). - + apply H1. - unfold ge; apply Nat.le_trans with (max x0 1). - * apply Nat.le_max_l. - * apply H2. - + unfold Rdist; rewrite Rminus_0_r; apply Rabs_right. - apply Rle_ge; apply Rle_trans with (Rabs (Reste_E x y n)). - * apply Rabs_pos. - * apply Reste_E_maj. - apply Nat.lt_le_trans with 1%nat. - -- apply Nat.lt_0_succ. - -- apply Nat.le_trans with (max x0 1). - ++ apply Nat.le_max_r. - ++ apply H2. -Qed. - -(**********) -Lemma exp_plus : forall x y:R, exp (x + y) = exp x * exp y. -Proof. - intros; assert (H0 := E1_cvg x). - assert (H := E1_cvg y). - assert (H1 := E1_cvg (x + y)). - eapply UL_sequence. - - apply H1. - - assert (H2 := CV_mult _ _ _ _ H0 H). - assert (H3 := CV_minus _ _ _ _ H2 (Reste_E_cv x y)). - unfold Un_cv; unfold Un_cv in H3; intros. - elim (H3 _ H4); intros. - exists (S x0); intros. - rewrite <- (exp_form x y n). - + rewrite Rminus_0_r in H5. - apply H5. - unfold ge; apply Nat.le_trans with (S x0). - * apply Nat.le_succ_diag_r. - * apply H6. - + apply Nat.lt_le_trans with (S x0). - * apply Nat.lt_0_succ. - * apply H6. -Qed. - -(**********) -Lemma exp_pos_pos : forall x:R, 0 < x -> 0 < exp x. -Proof. - intros; set (An := fun N:nat => / INR (fact N) * x ^ N). - cut (Un_cv (fun n:nat => sum_f_R0 An n) (exp x)). - - intro; apply Rlt_le_trans with (sum_f_R0 An 0). - + unfold An; simpl; rewrite Rinv_1; rewrite Rmult_1_r; - apply Rlt_0_1. - + apply sum_incr. - * assumption. - * intro; unfold An; left; apply Rmult_lt_0_compat. - -- apply Rinv_0_lt_compat; apply INR_fact_lt_0. - -- apply (pow_lt _ n H). - - unfold exp; unfold projT1; case (exist_exp x); intro. - unfold exp_in; unfold infinite_sum, Un_cv; trivial. -Qed. - -(**********) -Lemma exp_pos : forall x:R, 0 < exp x. -Proof. - intro; destruct (total_order_T 0 x) as [[Hlt|<-]|Hgt]. - - apply (exp_pos_pos _ Hlt). - - rewrite exp_0; apply Rlt_0_1. - - replace (exp x) with (1 / exp (- x)). - + unfold Rdiv; apply Rmult_lt_0_compat. - * apply Rlt_0_1. - * apply Rinv_0_lt_compat; apply exp_pos_pos. - apply (Ropp_0_gt_lt_contravar _ Hgt). - + cut (exp (- x) <> 0). - * intro; unfold Rdiv; apply Rmult_eq_reg_l with (exp (- x)). - -- rewrite Rmult_1_l; rewrite Rinv_r. - ++ rewrite <- exp_plus. - rewrite Rplus_opp_l; rewrite exp_0; reflexivity. - ++ apply H. - -- apply H. - * assert (H := exp_plus x (- x)). - rewrite Rplus_opp_r in H; rewrite exp_0 in H. - red; intro; rewrite H0 in H. - rewrite Rmult_0_r in H. - elim R1_neq_R0; assumption. -Qed. - -(* ((exp h)-1)/h -> 0 quand h->0 *) -Lemma derivable_pt_lim_exp_0 : derivable_pt_lim exp 0 1. -Proof. - unfold derivable_pt_lim; intros. - set (fn := fun (N:nat) (x:R) => x ^ N / INR (fact (S N))). - cut (CVN_R fn). - - intro; assert (cv:forall x:R, { l:R | Un_cv (fun N:nat => SP fn N x) l }) by apply (CVN_R_CVS _ X). - assert (forall n:nat, continuity (fn n)). { - intro; unfold fn. - replace (fun x:R => x ^ n / INR (fact (S n))) with - (pow_fct n / fct_cte (INR (fact (S n))))%F; [ idtac | reflexivity ]. - apply continuity_div. - - apply derivable_continuous; apply (derivable_pow n). - - apply derivable_continuous; apply derivable_const. - - intro; unfold fct_cte; apply INR_fact_neq_0. - } - assert (continuity (SFL fn cv)) by (apply SFL_continuity; assumption). - unfold continuity in H1. - assert (H2 := H1 0). - unfold continuity_pt in H2; unfold continue_in in H2; unfold limit1_in in H2; - unfold limit_in in H2; simpl in H2; unfold Rdist in H2. - elim (H2 _ H); intros alp H3. - elim H3; intros. - exists (mkposreal _ H4); intros. - rewrite Rplus_0_l; rewrite exp_0. - replace ((exp h - 1) / h) with (SFL fn cv h). - + replace 1 with (SFL fn cv 0). - { apply H5. - split. - - unfold D_x, no_cond; split. - + trivial. - + apply (not_eq_sym H6). - - rewrite Rminus_0_r; apply H7. } - unfold SFL. - case (cv 0) as (x,Hu). - eapply UL_sequence. - { apply Hu. } - unfold Un_cv, SP in |- *. - intros; exists 1%nat; intros. - unfold Rdist; rewrite decomp_sum. - 2:lia. - rewrite Rplus_comm. - replace (fn 0%nat 0) with 1. - 2:{ unfold fn; simpl. - unfold Rdiv; rewrite Rinv_1; rewrite Rmult_1_r; reflexivity. } - unfold Rminus; rewrite Rplus_assoc; rewrite Rplus_opp_r; - rewrite Rplus_0_r. - replace (sum_f_R0 (fun i:nat => fn (S i) 0) (pred n)) with 0. - { rewrite Rabs_R0; apply H8. } - symmetry ; apply sum_eq_R0; intros. - unfold fn. - simpl. - unfold Rdiv; do 2 rewrite Rmult_0_l; reflexivity. - + unfold SFL, exp. - case (cv h) as (x0,Hu); case (exist_exp h) as (x,Hexp); simpl. - eapply UL_sequence. - { apply Hu. } - unfold Un_cv; intros. - unfold exp_in, infinite_sum in Hexp. - assert (0 < eps0 * Rabs h). { - apply Rmult_lt_0_compat. - - apply H8. - - apply Rabs_pos_lt; assumption. - } - elim (Hexp _ H9); intros N0 H10. - exists N0; intros. - unfold Rdist. - apply Rmult_lt_reg_l with (Rabs h). - { apply Rabs_pos_lt; assumption. } - rewrite <- Rabs_mult. - rewrite Rmult_minus_distr_l. - replace (h * ((x - 1) / h)) with (x - 1). - 2:{ field. assumption. } - unfold Rdist in H10. - replace (h * SP fn n h - (x - 1)) with - (sum_f_R0 (fun i:nat => / INR (fact i) * h ^ i) (S n) - x). - { rewrite (Rmult_comm (Rabs h)). - apply H10. - unfold ge. - apply Nat.le_trans with (S N0). - - apply Nat.le_succ_diag_r. - - apply -> Nat.succ_le_mono; apply H11. } - rewrite decomp_sum. - 2:apply Nat.lt_0_succ. - replace (/ INR (fact 0) * h ^ 0) with 1. - 2:simpl; rewrite Rinv_1; rewrite Rmult_1_r; reflexivity. - unfold Rminus. - rewrite Ropp_plus_distr. - rewrite Ropp_involutive. - rewrite <- (Rplus_comm (- x)). - rewrite <- (Rplus_comm (- x + 1)). - rewrite Rplus_assoc; repeat apply Rplus_eq_compat_l. - replace (pred (S n)) with n; [ idtac | reflexivity ]. - unfold SP. - rewrite scal_sum. - apply sum_eq; intros. - unfold fn. - replace (h ^ S i) with (h * h ^ i) by (simpl;ring). - unfold Rdiv; ring. - - assert (H0 := Alembert_exp). - unfold CVN_R. - intro; unfold CVN_r. - exists (fun N:nat => r ^ N / INR (fact (S N))). - cut - { l:R | - Un_cv - (fun n:nat => - sum_f_R0 (fun k:nat => Rabs (r ^ k / INR (fact (S k)))) n) l }. - { intros (x,p). - exists x; intros. - split. - { assumption. } - unfold Boule; intros. - rewrite Rminus_0_r in H1. - unfold fn. - unfold Rdiv; rewrite Rabs_mult. - assert (0 < INR (fact (S n))). - { apply INR_fact_lt_0. } - rewrite (Rabs_right (/ INR (fact (S n)))). - 2:{ apply Rle_ge; left; apply Rinv_0_lt_compat; apply H2. } - do 2 rewrite <- (Rmult_comm (/ INR (fact (S n)))). - apply Rmult_le_compat_l. - { left; apply Rinv_0_lt_compat; apply H2. } - rewrite <- RPow_abs. - apply pow_maj_Rabs. - rewrite Rabs_Rabsolu; left; apply H1. } - assert ((r:R) <> 0). { - assert (H1 := cond_pos r); red; intro; rewrite H2 in H1; - elim (Rlt_irrefl _ H1). - } - apply Alembert_C2. - { intro; apply Rabs_no_R0. - unfold Rdiv; apply prod_neq_R0. - { apply pow_nonzero; assumption. } - apply Rinv_neq_0_compat; apply INR_fact_neq_0. } - unfold Un_cv in H0. - unfold Un_cv; intros. - cut (0 < eps0 / r); - [ intro - | unfold Rdiv; apply Rmult_lt_0_compat; - [ assumption | apply Rinv_0_lt_compat; apply (cond_pos r) ] ]. - elim (H0 _ H3); intros N0 H4. - exists N0; intros. - assert (hyp_sn:(S n >= N0)%nat) by lia. - assert (H6 := H4 _ hyp_sn). - unfold Rdist in H6; rewrite Rminus_0_r in H6. - rewrite Rabs_Rabsolu in H6. - unfold Rdist; rewrite Rminus_0_r. - rewrite Rabs_Rabsolu. - replace - (Rabs (r ^ S n / INR (fact (S (S n)))) / Rabs (r ^ n / INR (fact (S n)))) - with (r * / INR (fact (S (S n))) * / / INR (fact (S n))). - { rewrite Rmult_assoc; rewrite Rabs_mult. - rewrite (Rabs_right r). - 2:{ apply Rle_ge; left; apply (cond_pos r). } - apply Rmult_lt_reg_l with (/ r). - { apply Rinv_0_lt_compat; apply (cond_pos r). } - rewrite <- Rmult_assoc; rewrite Rinv_l. - 2:assumption. - rewrite Rmult_1_l; rewrite <- (Rmult_comm eps0). - apply H6. } - unfold Rdiv. - repeat rewrite Rabs_mult. - repeat rewrite Rabs_inv. - rewrite Rinv_mult. - repeat rewrite Rabs_right. - 2,4:match goal with |- context[fact ?x] => pose proof (INR_fact_lt_0 x) end;lra. - 2,3:apply Rle_ge; left; apply pow_lt; apply (cond_pos r). - rewrite Rinv_inv. - rewrite (Rmult_comm r). - rewrite (Rmult_comm (r ^ S n)). - repeat rewrite Rmult_assoc. - apply Rmult_eq_compat_l. - rewrite (Rmult_comm r). - rewrite <- Rmult_assoc; rewrite <- (Rmult_comm (INR (fact (S n)))). - apply Rmult_eq_compat_l. - simpl. - rewrite Rmult_assoc; rewrite Rinv_r. - 2:{ apply pow_nonzero; assumption. } - ring. -Qed. - -(**********) -Lemma derivable_pt_lim_exp : forall x:R, derivable_pt_lim exp x (exp x). -Proof. - intro; assert (H0 := derivable_pt_lim_exp_0). - unfold derivable_pt_lim in H0; unfold derivable_pt_lim; intros. - cut (0 < eps / exp x); - [ intro - | unfold Rdiv; apply Rmult_lt_0_compat; - [ apply H | apply Rinv_0_lt_compat; apply exp_pos ] ]. - elim (H0 _ H1); intros del H2. - exists del; intros. - assert (H5 := H2 _ H3 H4). - rewrite Rplus_0_l in H5; rewrite exp_0 in H5. - replace ((exp (x + h) - exp x) / h - exp x) with - (exp x * ((exp h - 1) / h - 1)). - - rewrite Rabs_mult; rewrite (Rabs_right (exp x)). - + apply Rmult_lt_reg_l with (/ exp x). - * apply Rinv_0_lt_compat; apply exp_pos. - * rewrite <- Rmult_assoc; rewrite Rinv_l. - -- rewrite Rmult_1_l; rewrite <- (Rmult_comm eps). - apply H5. - -- assert (H6 := exp_pos x); red; intro; rewrite H7 in H6; - elim (Rlt_irrefl _ H6). - + apply Rle_ge; left; apply exp_pos. - - rewrite Rmult_minus_distr_l. - rewrite Rmult_1_r; unfold Rdiv; rewrite <- Rmult_assoc; - rewrite Rmult_minus_distr_l. - rewrite Rmult_1_r; rewrite exp_plus; reflexivity. -Qed. diff --git a/stdlib/theories/Reals/Integration.v b/stdlib/theories/Reals/Integration.v deleted file mode 100644 index 02befa318445..000000000000 --- a/stdlib/theories/Reals/Integration.v +++ /dev/null @@ -1,13 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* R) (a b:R) (pr1:forall c:R, a < c < b -> derivable_pt f c) - (pr2:forall c:R, a < c < b -> derivable_pt g c), - a < b -> - (forall c:R, a <= c <= b -> continuity_pt f c) -> - (forall c:R, a <= c <= b -> continuity_pt g c) -> - exists c : R, - (exists P : a < c < b, - (g b - g a) * derive_pt f c (pr1 c P) = - (f b - f a) * derive_pt g c (pr2 c P)). -Proof. - intros; assert (H2 := Rlt_le _ _ H). - set (h := fun y:R => (g b - g a) * f y - (f b - f a) * g y). - assert (X:forall c:R, a < c < b -> derivable_pt h c). { - intros; - change - (derivable_pt ((fct_cte (g b - g a) * f)%F - (fct_cte (f b - f a) * g)%F) - c). - apply derivable_pt_minus; apply derivable_pt_mult. - - apply derivable_pt_const. - - apply (pr1 _ H3). - - apply derivable_pt_const. - - apply (pr2 _ H3). - } - assert (forall c:R, a <= c <= b -> continuity_pt h c). { - intros; unfold h; - change - (continuity_pt ((fct_cte (g b - g a) * f)%F - (fct_cte (f b - f a) * g)%F) - c). - apply continuity_pt_minus; apply continuity_pt_mult. - - apply derivable_continuous_pt; apply derivable_const. - - apply H0; apply H3. - - apply derivable_continuous_pt; apply derivable_const. - - apply H1; apply H3. - } - assert (H4 := continuity_ab_maj h a b H2 H3). - assert (H5 := continuity_ab_min h a b H2 H3). - elim H4; intros Mx H6. - elim H5; intros mx H7. - assert (h a = h b) by (unfold h;ring). - set (M := h Mx); set (m := h mx). - assert - (forall (c:R) (P:a < c < b), - derive_pt h c (X c P) = - (g b - g a) * derive_pt f c (pr1 c P) - - (f b - f a) * derive_pt g c (pr2 c P)). { - intros; unfold h; - replace - (derive_pt (fun y:R => (g b - g a) * f y - (f b - f a) * g y) c (X c P)) - with - (derive_pt ((fct_cte (g b - g a) * f)%F - (fct_cte (f b - f a) * g)%F) c - (derivable_pt_minus _ _ _ - (derivable_pt_mult _ _ _ (derivable_pt_const (g b - g a) c) (pr1 c P)) - (derivable_pt_mult _ _ _ (derivable_pt_const (f b - f a) c) (pr2 c P)))); - [ idtac | apply pr_nu ]. - rewrite derive_pt_minus; do 2 rewrite derive_pt_mult; - do 2 rewrite derive_pt_const; do 2 rewrite Rmult_0_l; - do 2 rewrite Rplus_0_l; reflexivity. - } - case (Req_dec (h a) M); intro. - 1:case (Req_dec (h a) m); intro. - - (*** h constant ***) - assert (forall c:R, a <= c <= b -> h c = M). { - intros; elim H6; intros H13 _. - elim H7; intros H14 _. - apply Rle_antisym. - - apply H13; apply H12. - - rewrite H10 in H11; rewrite H11; apply H14; apply H12. - } - assert (a < (a + b) / 2 < b). { - split. - - apply Rmult_lt_reg_l with 2. - + prove_sup0. - + unfold Rdiv; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc; - rewrite Rinv_r. - * rewrite Rmult_1_l; rewrite <-Rplus_diag; apply Rplus_lt_compat_l; apply H. - * discrR. - - apply Rmult_lt_reg_l with 2. - + prove_sup0. - + unfold Rdiv; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc; - rewrite Rinv_r. - * rewrite Rmult_1_l; rewrite Rplus_comm; rewrite <-Rplus_diag; - apply Rplus_lt_compat_l; apply H. - * discrR. - } - exists ((a + b) / 2). - exists H13. - apply Rminus_diag_uniq; rewrite <- H9; apply deriv_constant2 with a b. - + elim H13; intros; assumption. - + elim H13; intros; assumption. - + intros; rewrite (H12 ((a + b) / 2)). - * apply H12; split; left; assumption. - * elim H13; intros; split; left; assumption. - - - (*** h admet un minimum global sur [a,b] ***) - assert (a < mx < b). { - elim H7; intros _ H12; elim H12; intros; split. - - inversion H13. - + apply H15. - + rewrite H15 in H11; elim H11; reflexivity. - - inversion H14. - + apply H15. - + rewrite H8 in H11; rewrite <- H15 in H11; elim H11; reflexivity. - } - exists mx. - exists H12. - apply Rminus_diag_uniq; rewrite <- H9; apply deriv_minimum with a b. - + elim H12; intros; assumption. - + elim H12; intros; assumption. - + intros; elim H7; intros. - apply H15; split; left; assumption. - - - (*** h admet un maximum global sur [a,b] ***) - assert (a < Mx < b). { - elim H6; intros _ H11; elim H11; intros; split. - - inversion H12. - + apply H14. - + rewrite H14 in H10; elim H10; reflexivity. - - inversion H13. - + apply H14. - + rewrite H8 in H10; rewrite <- H14 in H10; elim H10; reflexivity. - } - exists Mx. - exists H11. - apply Rminus_diag_uniq; rewrite <- H9; apply deriv_maximum with a b. - + elim H11; intros; assumption. - + elim H11; intros; assumption. - + intros; elim H6; intros; apply H14. - split; left; assumption. -Qed. - -(* Corollaries ... *) -Lemma MVT_cor1 : - forall (f:R -> R) (a b:R) (pr:derivable f), - a < b -> - exists c : R, f b - f a = derive_pt f c (pr c) * (b - a) /\ a < c < b. -Proof. - intros f a b pr H; cut (forall c:R, a < c < b -> derivable_pt f c); - [ intro X | intros; apply pr ]. - cut (forall c:R, a < c < b -> derivable_pt id c); - [ intro X0 | intros; apply derivable_pt_id ]. - cut (forall c:R, a <= c <= b -> continuity_pt f c); - [ intro | intros; apply derivable_continuous_pt; apply pr ]. - cut (forall c:R, a <= c <= b -> continuity_pt id c); - [ intro | intros; apply derivable_continuous_pt; apply derivable_id ]. - assert (H2 := MVT f id a b X X0 H H0 H1). - destruct H2 as (c & P & H4). - exists c; split. - - cut (derive_pt id c (X0 c P) = derive_pt id c (derivable_pt_id c)); - [ intro H5 | apply pr_nu ]. - rewrite H5 in H4; rewrite (derive_pt_id c) in H4; rewrite Rmult_1_r in H4; - rewrite <- H4; replace (derive_pt f c (X c P)) with (derive_pt f c (pr c)); - [ idtac | apply pr_nu ]; apply Rmult_comm. - - apply P. -Qed. - -Theorem MVT_cor2 : - forall (f f':R -> R) (a b:R), - a < b -> - (forall c:R, a <= c <= b -> derivable_pt_lim f c (f' c)) -> - exists c : R, f b - f a = f' c * (b - a) /\ a < c < b. -Proof. - intros f f' a b H H0; cut (forall c:R, a <= c <= b -> derivable_pt f c). - 1:intro X; cut (forall c:R, a < c < b -> derivable_pt f c). - 1:intro X0; cut (forall c:R, a <= c <= b -> continuity_pt f c). - 1:intro; cut (forall c:R, a <= c <= b -> derivable_pt id c). - 1:intro X1; cut (forall c:R, a < c < b -> derivable_pt id c). - 1:intro X2; cut (forall c:R, a <= c <= b -> continuity_pt id c). - - intro; elim (MVT f id a b X0 X2 H H1 H2); intros x (P,H3). - exists x; split. - + cut (derive_pt id x (X2 x P) = 1). - 1:cut (derive_pt f x (X0 x P) = f' x). - * intros; rewrite H4 in H3; rewrite H5 in H3; unfold id in H3; - rewrite Rmult_1_r in H3; rewrite Rmult_comm; symmetry ; - assumption. - * apply derive_pt_eq_0; apply H0; elim P; intros; split; left; assumption. - * apply derive_pt_eq_0; apply derivable_pt_lim_id. - + assumption. - - intros; apply derivable_continuous_pt; apply X1; assumption. - - intros; apply derivable_pt_id. - - intros; apply derivable_pt_id. - - intros; apply derivable_continuous_pt; apply X; assumption. - - intros; elim H1; intros; apply X; split; left; assumption. - - intros; unfold derivable_pt; exists (f' c); apply H0; - apply H1. -Qed. - -Lemma MVT_cor3 : - forall (f f':R -> R) (a b:R), - a < b -> - (forall x:R, a <= x -> x <= b -> derivable_pt_lim f x (f' x)) -> - exists c : R, a <= c /\ c <= b /\ f b = f a + f' c * (b - a). -Proof. - intros f f' a b H H0; - assert (H1 : exists c : R, f b - f a = f' c * (b - a) /\ a < c < b); - [ apply MVT_cor2; [ apply H | intros; elim H1; intros; apply (H0 _ H2 H3) ] - | elim H1; intros; exists x; elim H2; intros; elim H4; intros; split; - [ left; assumption | split; [ left; assumption | rewrite <- H3; ring ] ] ]. -Qed. - -Lemma Rolle : - forall (f:R -> R) (a b:R) (pr:forall x:R, a < x < b -> derivable_pt f x), - (forall x:R, a <= x <= b -> continuity_pt f x) -> - a < b -> - f a = f b -> - exists c : R, (exists P : a < c < b, derive_pt f c (pr c P) = 0). -Proof. - intros; assert (H2 : forall x:R, a < x < b -> derivable_pt id x). - - intros; apply derivable_pt_id. - - assert (H3 := MVT f id a b pr H2 H0 H); - assert (H4 : forall x:R, a <= x <= b -> continuity_pt id x). - + intros; apply derivable_continuous; apply derivable_id. - + destruct (H3 H4) as (c & P & H6). exists c; exists P; rewrite H1 in H6. - unfold id in H6; unfold Rminus in H6; rewrite Rplus_opp_r in H6. - rewrite Rmult_0_l in H6; apply Rmult_eq_reg_l with (b - a); - [ rewrite Rmult_0_r; apply H6 - | apply Rminus_eq_contra; red; intro H7; rewrite H7 in H0; - elim (Rlt_irrefl _ H0) ]. -Qed. - -(**********) -Lemma nonneg_derivative_1 : - forall (f:R -> R) (pr:derivable f), - (forall x:R, 0 <= derive_pt f x (pr x)) -> increasing f. -Proof. - intros. - unfold increasing. - intros. - destruct (total_order_T x y) as [[H1| ->]|H1]. - - apply Rplus_le_reg_l with (- f x). - rewrite Rplus_opp_l; rewrite Rplus_comm. - pose proof (MVT_cor1 f _ _ pr H1) as (c & H3 & H4). - unfold Rminus in H3. - rewrite H3. - apply Rmult_le_pos. - + apply H. - + apply Rplus_le_reg_l with x. - rewrite Rplus_0_r; replace (x + (y + - x)) with y; [ assumption | ring ]. - - right; reflexivity. - - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H0 H1)). -Qed. - -(**********) -Lemma nonpos_derivative_0 : - forall (f:R -> R) (pr:derivable f), - decreasing f -> forall x:R, derive_pt f x (pr x) <= 0. -Proof. - intros f pr H x; assert (H0 := H); unfold decreasing in H0; - generalize (derivable_derive f x (pr x)); intro; elim H1; - intros l H2. - rewrite H2; case (Rtotal_order l 0); intro. - { left; assumption. } - elim H3; intro. - { right; assumption. } - generalize (derive_pt_eq_1 f x l (pr x) H2); intros; assert (0 < l / 2). { - unfold Rdiv; apply Rmult_lt_0_compat; - [ apply H4 | apply Rinv_0_lt_compat; prove_sup0 ]. - } - elim (H5 (l / 2) H6); intros delta H7; - assert (delta / 2 <> 0 /\ 0 < delta / 2 /\ Rabs (delta / 2) < delta). { - split;[|split]. - - unfold Rdiv; apply prod_neq_R0. - + generalize (cond_pos delta); intro; red; intro H9; rewrite H9 in H8; - elim (Rlt_irrefl 0 H8). - + apply Rinv_neq_0_compat; discrR. - - unfold Rdiv; destruct delta;simpl; lra. - - rewrite Rabs_right. - + unfold Rdiv; apply Rmult_lt_reg_l with 2. - { prove_sup0. } - rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc; rewrite Rinv_r. - 2:{ discrR. } - rewrite Rmult_1_l; rewrite <-Rplus_diag; pattern (pos delta) at 1; - rewrite <- Rplus_0_r. - apply Rplus_lt_compat_l; apply (cond_pos delta). - + apply Rle_ge; unfold Rdiv; left; apply Rmult_lt_0_compat. - * apply (cond_pos delta). - * apply Rinv_0_lt_compat; prove_sup0. - } - decompose [and] H8; intros; generalize (H7 (delta / 2) H9 H12); - assert ((f (x + delta / 2) - f x) / (delta / 2) <= 0). { - replace ((f (x + delta / 2) - f x) / (delta / 2)) with - (- ((f x - f (x + delta / 2)) / (delta / 2))). - - rewrite <- Ropp_0. - apply Ropp_ge_le_contravar. - apply Rle_ge. - unfold Rdiv; apply Rmult_le_pos. - + cut (x <= x + delta * / 2). - * intro; generalize (H0 x (x + delta * / 2) H10); intro. - generalize - (Rplus_le_compat_l (- f (x + delta / 2)) (f (x + delta / 2)) (f x) H13); - rewrite Rplus_opp_l; rewrite Rplus_comm; intro; assumption. - * pattern x at 1; rewrite <- (Rplus_0_r x); apply Rplus_le_compat_l; - left; assumption. - + left; apply Rinv_0_lt_compat; assumption. - - unfold Rdiv; rewrite <- Ropp_mult_distr_l_reverse. - rewrite Ropp_minus_distr. - reflexivity. - } - assert (0 < - ((f (x + delta / 2) - f x) / (delta / 2) - l)) by lra. - unfold Rabs; - case (Rcase_abs ((f (x + delta / 2) - f x) / (delta / 2) - l)) as [Hlt|Hge]; lra. -Qed. - -(**********) -Lemma increasing_decreasing_opp : - forall f:R -> R, increasing f -> decreasing (- f)%F. -Proof. - unfold increasing, decreasing, opp_fct; intros; generalize (H x y H0); - intro; apply Ropp_ge_le_contravar; apply Rle_ge; assumption. -Qed. - -(**********) -Lemma nonpos_derivative_1 : - forall (f:R -> R) (pr:derivable f), - (forall x:R, derive_pt f x (pr x) <= 0) -> decreasing f. -Proof. - intros. - assert (forall h:R, - - f h = f h) by (intros;ring). - generalize (increasing_decreasing_opp (- f)%F). - unfold decreasing. - unfold opp_fct. - intros. - rewrite <- (H0 x); rewrite <- (H0 y). - apply H1. - 2:{ assumption. } - assert (forall x:R, 0 <= derive_pt (- f) x (derivable_opp f pr x)). { - intro. - assert (H3 := derive_pt_opp f x0 (pr x0)). - assert - (derive_pt (- f) x0 (derivable_pt_opp f x0 (pr x0)) = - derive_pt (- f) x0 (derivable_opp f pr x0)) by apply pr_nu. - rewrite <- H4. - rewrite H3. - rewrite <- Ropp_0; apply Ropp_ge_le_contravar; apply Rle_ge; apply (H x0). - } - replace (fun x:R => - f x) with (- f)%F; [ idtac | reflexivity ]. - apply (nonneg_derivative_1 (- f)%F (derivable_opp f pr) H3). -Qed. - -(**********) -Lemma positive_derivative : - forall (f:R -> R) (pr:derivable f), - (forall x:R, 0 < derive_pt f x (pr x)) -> strict_increasing f. -Proof. - intros. - unfold strict_increasing. - intros. - apply Rplus_lt_reg_l with (- f x). - rewrite Rplus_opp_l; rewrite Rplus_comm. - assert (H1 := MVT_cor1 f _ _ pr H0). - elim H1; intros. - elim H2; intros. - unfold Rminus in H3. - rewrite H3. - apply Rmult_lt_0_compat. - - apply H. - - apply Rplus_lt_reg_l with x. - rewrite Rplus_0_r; replace (x + (y + - x)) with y; [ assumption | ring ]. -Qed. - -(**********) -Lemma strictincreasing_strictdecreasing_opp : - forall f:R -> R, strict_increasing f -> strict_decreasing (- f)%F. -Proof. - unfold strict_increasing, strict_decreasing, opp_fct; intros; - generalize (H x y H0); intro; apply Ropp_lt_gt_contravar; - assumption. -Qed. - -(**********) -Lemma negative_derivative : - forall (f:R -> R) (pr:derivable f), - (forall x:R, derive_pt f x (pr x) < 0) -> strict_decreasing f. -Proof. - intros. - assert (forall h:R, - - f h = f h) by (intros;ring). - generalize (strictincreasing_strictdecreasing_opp (- f)%F). - unfold strict_decreasing, opp_fct. - intros. - rewrite <- (H0 x). - rewrite <- (H0 y). - apply H1; [ idtac | assumption ]. - cut (forall x:R, 0 < derive_pt (- f) x (derivable_opp f pr x)). - { intros; eapply positive_derivative; apply H3. } - intro. - assert (H3 := derive_pt_opp f x0 (pr x0)). - assert - (derive_pt (- f) x0 (derivable_pt_opp f x0 (pr x0)) = - derive_pt (- f) x0 (derivable_opp f pr x0)) by apply pr_nu. - rewrite <- H4; rewrite H3. - rewrite <- Ropp_0; apply Ropp_lt_gt_contravar; apply (H x0). -Qed. - -(**********) -Lemma null_derivative_0 : - forall (f:R -> R) (pr:derivable f), - constant f -> forall x:R, derive_pt f x (pr x) = 0. -Proof. - intros. - unfold constant in H. - apply derive_pt_eq_0. - intros; exists (mkposreal 1 Rlt_0_1); simpl; intros. - rewrite (H x (x + h)); unfold Rminus; unfold Rdiv; - rewrite Rplus_opp_r; rewrite Rmult_0_l; rewrite Rplus_opp_r; - rewrite Rabs_R0; assumption. -Qed. - -(**********) -Lemma increasing_decreasing : - forall f:R -> R, increasing f -> decreasing f -> constant f. -Proof. - unfold increasing, decreasing, constant; intros; - case (Rtotal_order x y); intro. - - generalize (Rlt_le x y H1); intro; - apply (Rle_antisym (f x) (f y) (H x y H2) (H0 x y H2)). - - elim H1; intro. - + rewrite H2; reflexivity. - + generalize (Rlt_le y x H2); intro; symmetry ; - apply (Rle_antisym (f y) (f x) (H y x H3) (H0 y x H3)). -Qed. - -(**********) -Lemma null_derivative_1 : - forall (f:R -> R) (pr:derivable f), - (forall x:R, derive_pt f x (pr x) = 0) -> constant f. -Proof. - intros. - cut (forall x:R, derive_pt f x (pr x) <= 0). - - cut (forall x:R, 0 <= derive_pt f x (pr x)). - + intros. - assert (H2 := nonneg_derivative_1 f pr H0). - assert (H3 := nonpos_derivative_1 f pr H1). - apply increasing_decreasing; assumption. - + intro; right; symmetry ; apply (H x). - - intro; right; apply (H x). -Qed. - -(**********) -Lemma derive_increasing_interv_ax : - forall (a b:R) (f:R -> R) (pr:derivable f), - a < b -> - ((forall t:R, a < t < b -> 0 < derive_pt f t (pr t)) -> - forall x y:R, a <= x <= b -> a <= y <= b -> x < y -> f x < f y) /\ - ((forall t:R, a < t < b -> 0 <= derive_pt f t (pr t)) -> - forall x y:R, a <= x <= b -> a <= y <= b -> x < y -> f x <= f y). -Proof. - intros. - split; intros. - - apply Rplus_lt_reg_l with (- f x). - rewrite Rplus_opp_l; rewrite Rplus_comm. - assert (H4 := MVT_cor1 f _ _ pr H3). - elim H4; intros. - elim H5; intros. - unfold Rminus in H6. - rewrite H6. - apply Rmult_lt_0_compat. - 2:{ lra. } - apply H0. - lra. - - apply Rplus_le_reg_l with (- f x). - rewrite Rplus_opp_l; rewrite Rplus_comm. - assert (H4 := MVT_cor1 f _ _ pr H3). - elim H4; intros. - elim H5; intros. - unfold Rminus in H6. - rewrite H6. - apply Rmult_le_pos. - 2:{ lra. } - apply H0. - lra. -Qed. - -(**********) -Lemma derive_increasing_interv : - forall (a b:R) (f:R -> R) (pr:derivable f), - a < b -> - (forall t:R, a < t < b -> 0 < derive_pt f t (pr t)) -> - forall x y:R, a <= x <= b -> a <= y <= b -> x < y -> f x < f y. -Proof. - intros. - generalize (derive_increasing_interv_ax a b f pr H); intro. - elim H4; intros H5 _; apply (H5 H0 x y H1 H2 H3). -Qed. - -(**********) -Lemma derive_increasing_interv_var : - forall (a b:R) (f:R -> R) (pr:derivable f), - a < b -> - (forall t:R, a < t < b -> 0 <= derive_pt f t (pr t)) -> - forall x y:R, a <= x <= b -> a <= y <= b -> x < y -> f x <= f y. -Proof. - intros a b f pr H H0 x y H1 H2 H3; - generalize (derive_increasing_interv_ax a b f pr H); - intro; elim H4; intros _ H5; apply (H5 H0 x y H1 H2 H3). -Qed. - -(**********) -(**********) -Theorem IAF : - forall (f:R -> R) (a b k:R) (pr:derivable f), - a <= b -> - (forall c:R, a <= c <= b -> derive_pt f c (pr c) <= k) -> - f b - f a <= k * (b - a). -Proof. - intros. - destruct (total_order_T a b) as [[H1| -> ]|H1]. - - pose proof (MVT_cor1 f _ _ pr H1) as (c & -> & H4). - do 2 rewrite <- (Rmult_comm (b - a)). - apply Rmult_le_compat_l. - + apply Rplus_le_reg_l with a; rewrite Rplus_0_r. - replace (a + (b - a)) with b; [ assumption | ring ]. - + apply H0. - elim H4; intros. - split; left; assumption. - - unfold Rminus; do 2 rewrite Rplus_opp_r. - rewrite Rmult_0_r; right; reflexivity. - - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H H1)). -Qed. - -Lemma IAF_var : - forall (f g:R -> R) (a b:R) (pr1:derivable f) (pr2:derivable g), - a <= b -> - (forall c:R, a <= c <= b -> derive_pt g c (pr2 c) <= derive_pt f c (pr1 c)) -> - g b - g a <= f b - f a. -Proof. - intros. - assert (X:derivable (g - f)) by (apply derivable_minus; assumption). - assert (forall c:R, a <= c <= b -> derive_pt (g - f) c (X c) <= 0). { - intros. - assert - (derive_pt (g - f) c (X c) = - derive_pt (g - f) c (derivable_pt_minus _ _ _ (pr2 c) (pr1 c))) by apply pr_nu. - rewrite H2. - rewrite derive_pt_minus. - apply Rplus_le_reg_l with (derive_pt f c (pr1 c)). - rewrite Rplus_0_r. - replace - (derive_pt f c (pr1 c) + (derive_pt g c (pr2 c) - derive_pt f c (pr1 c))) - with (derive_pt g c (pr2 c)); [ idtac | ring ]. - apply H0; assumption. - } - assert (H2 := IAF (g - f)%F a b 0 X H H1). - unfold minus_fct in H2. - lra. -Qed. - -(* If f has a null derivative in ]a,b[ and is continue in [a,b], *) -(* then f is constant on [a,b] *) -Lemma null_derivative_loc : - forall (f:R -> R) (a b:R) (pr:forall x:R, a < x < b -> derivable_pt f x), - (forall x:R, a <= x <= b -> continuity_pt f x) -> - (forall (x:R) (P:a < x < b), derive_pt f x (pr x P) = 0) -> - constant_D_eq f (fun x:R => a <= x <= b) (f a). -Proof. - intros; unfold constant_D_eq; intros; destruct (total_order_T a b) as [[Hlt|Heq]|Hgt]. - - assert (H2 : forall y:R, a < y < x -> derivable_pt id y). - { intros; apply derivable_pt_id. } - assert (H3 : forall y:R, a <= y <= x -> continuity_pt id y). - { intros; apply derivable_continuous; apply derivable_id. } - assert (H4 : forall y:R, a < y < x -> derivable_pt f y). - { intros; apply pr; elim H4; intros; split. - - assumption. - - elim H1; intros; apply Rlt_le_trans with x; assumption. } - assert (H5 : forall y:R, a <= y <= x -> continuity_pt f y). - { intros; apply H; elim H5; intros; split. - - assumption. - - elim H1; intros; apply Rle_trans with x; assumption. } - elim H1; clear H1; intros; elim H1; clear H1; intro. - + assert (H7 := MVT f id a x H4 H2 H1 H5 H3). - destruct H7 as (c & P & H9). - assert (H10 : a < c < b). - { split. - - apply P. - - apply Rlt_le_trans with x; [apply P|assumption]. } - assert (H11 : derive_pt f c (H4 c P) = 0). - { replace (derive_pt f c (H4 c P)) with (derive_pt f c (pr c H10)); - [ apply H0 | apply pr_nu ]. } - assert (H12 : derive_pt id c (H2 c P) = 1). - { apply derive_pt_eq_0; apply derivable_pt_lim_id. } - rewrite H11 in H9; rewrite H12 in H9; rewrite Rmult_0_r in H9; - rewrite Rmult_1_r in H9; apply Rminus_diag_uniq; symmetry ; - assumption. - + rewrite H1; reflexivity. - - assert (H2 : x = a). - { rewrite <- Heq in H1; elim H1; intros; apply Rle_antisym; assumption. } - rewrite H2; reflexivity. - - elim H1; intros; - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ (Rle_trans _ _ _ H2 H3) Hgt)). -Qed. - -(* Unicity of the antiderivative *) -Lemma antiderivative_Ucte : - forall (f g1 g2:R -> R) (a b:R), - antiderivative f g1 a b -> - antiderivative f g2 a b -> - exists c : R, (forall x:R, a <= x <= b -> g1 x = g2 x + c). -Proof. - unfold antiderivative; intros; elim H; clear H; intros; elim H0; - clear H0; intros H0 _; exists (g1 a - g2 a); intros; - assert (H3 : forall x:R, a <= x <= b -> derivable_pt g1 x). - { intros; unfold derivable_pt; exists (f x0); elim (H x0 H3); - intros; eapply derive_pt_eq_1; symmetry ; - apply H4. } - assert (H4 : forall x:R, a <= x <= b -> derivable_pt g2 x). - { intros; unfold derivable_pt; exists (f x0); - elim (H0 x0 H4); intros; eapply derive_pt_eq_1; symmetry ; - apply H5. } - assert (H5 : forall x:R, a < x < b -> derivable_pt (g1 - g2) x). - { intros; elim H5; intros; apply derivable_pt_minus; - [ apply H3; split; left; assumption | apply H4; split; left; assumption ]. } - assert (H6 : forall x:R, a <= x <= b -> continuity_pt (g1 - g2) x). - { intros; apply derivable_continuous_pt; apply derivable_pt_minus; - [ apply H3 | apply H4 ]; assumption. } - assert (H7 : forall (x:R) (P:a < x < b), derive_pt (g1 - g2) x (H5 x P) = 0). - { intros; elim P; intros; apply derive_pt_eq_0; replace 0 with (f x0 - f x0); - [ idtac | ring ]. - assert (H9 : a <= x0 <= b). - { split; left; assumption. } - apply derivable_pt_lim_minus; [ elim (H _ H9) | elim (H0 _ H9) ]; intros; - eapply derive_pt_eq_1; symmetry ; apply H10. } - assert (H8 := null_derivative_loc (g1 - g2)%F a b H5 H6 H7); - unfold constant_D_eq in H8; assert (H9 := H8 _ H2); - unfold minus_fct in H9; rewrite <- H9; ring. -Qed. - -(* A variant of MVT using absolute values. *) -Lemma MVT_abs : - forall (f f' : R -> R) (a b : R), - (forall c : R, Rmin a b <= c <= Rmax a b -> - derivable_pt_lim f c (f' c)) -> - exists c : R, Rabs (f b - f a) = Rabs (f' c) * Rabs (b - a) /\ - Rmin a b <= c <= Rmax a b. -Proof. -intros f f' a b. -destruct (Rle_dec a b) as [aleb | blta]. -- destruct (Req_dec a b) as [ab | anb]. - + unfold Rminus; intros _; exists a; split. - * now rewrite <- ab, !Rplus_opp_r, Rabs_R0, Rmult_0_r. - * split;[apply Rmin_l | apply Rmax_l]. - + rewrite Rmax_right, Rmin_left; auto; intros derv. - destruct (MVT_cor2 f f' a b) as [c [hc intc]]; - [destruct aleb;[assumption | contradiction] | apply derv | ]. - exists c; rewrite hc, Rabs_mult;split; - [reflexivity | unfold Rle; tauto]. -- assert (b < a) by (apply Rnot_le_gt; assumption). - assert (b <= a) by (apply Rlt_le; assumption). - rewrite Rmax_left, Rmin_right; try assumption; intros derv. - destruct (MVT_cor2 f f' b a) as [c [hc intc]]; - [assumption | apply derv | ]. - exists c; rewrite <- Rabs_Ropp, Ropp_minus_distr, hc, Rabs_mult. - split;[now rewrite <- (Rabs_Ropp (b - a)), Ropp_minus_distr| unfold Rle; tauto]. -Qed. diff --git a/stdlib/theories/Reals/Machin.v b/stdlib/theories/Reals/Machin.v deleted file mode 100644 index 25cd805effe1..000000000000 --- a/stdlib/theories/Reals/Machin.v +++ /dev/null @@ -1,184 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* 0 -> -PI/2 < atan u - atan v < PI/2 -> - -PI/2 < atan (atan_sub u v) < PI/2 -> - atan u = atan v + atan (atan_sub u v). -Proof. -intros u v pn0 uvint aint. -assert (cos (atan u) <> 0). -{ destruct (atan_bound u); apply Rgt_not_eq, cos_gt_0; auto. - rewrite <- Rdiv_opp_l; assumption. } -assert (cos (atan v) <> 0). -{ destruct (atan_bound v); apply Rgt_not_eq, cos_gt_0; auto. - rewrite <- Rdiv_opp_l; assumption. } -assert (t : forall a b c, a - b = c -> a = b + c) by (intros; subst; field). -apply t, tan_inj; clear t; try assumption. -rewrite tan_minus; auto. -- rewrite !tan_atan; reflexivity. -- apply Rgt_not_eq, cos_gt_0; rewrite <- ?Rdiv_opp_l; tauto. -- rewrite !tan_atan; assumption. -Qed. - -Lemma tech : forall x y , -1 <= x <= 1 -> -1 < y < 1 -> - -PI/2 < atan x - atan y < PI/2. -Proof. -assert (ut := PI_RGT_0). -intros x y [xm1 x1] [ym1 y1]. -assert (-(PI/4) <= atan x). -{ destruct xm1 as [xm1 | xm1]. - { rewrite <- atan_1, <- atan_opp; apply Rlt_le, atan_increasing. - assumption. } - solve[rewrite <- xm1; change (-1) with (-(1)); rewrite atan_opp, atan_1; apply Rle_refl]. } -assert (-(PI/4) < atan y). -{ rewrite <- atan_1, <- atan_opp; apply atan_increasing. - assumption. } -assert (atan x <= PI/4). -{ destruct x1 as [x1 | x1]. - { rewrite <- atan_1; apply Rlt_le, atan_increasing. - assumption. } - solve[rewrite x1, atan_1; apply Rle_refl]. } -assert (atan y < PI/4). -{ rewrite <- atan_1; apply atan_increasing. - assumption. } -rewrite Rdiv_opp_l; split; lra. -Qed. - -(* A simple formula, reasonably efficient. *) -Lemma Machin_2_3 : PI/4 = atan(/2) + atan(/3). -Proof. -assert (utility : 0 < PI/2) by (apply PI2_RGT_0). -rewrite <- atan_1. -rewrite (atan_sub_correct 1 (/2)). -- apply f_equal, f_equal; unfold atan_sub; field. -- apply Rgt_not_eq; lra. -- apply tech; try split; try lra. -- apply atan_bound. -Qed. - -Lemma Machin_4_5_239 : PI/4 = 4 * atan (/5) - atan(/239). -Proof. -rewrite <- atan_1. -rewrite (atan_sub_correct 1 (/5)); - [ | apply Rgt_not_eq; lra | apply tech; try split; lra | - apply atan_bound ]. -replace (4 * atan (/5) - atan (/239)) with - (atan (/5) + (atan (/5) + (atan (/5) + (atan (/5) + - - atan (/239))))) by ring. -apply f_equal. -replace (atan_sub 1 (/5)) with (2/3) by - (unfold atan_sub; field). -rewrite (atan_sub_correct (2/3) (/5)); - [apply f_equal | apply Rgt_not_eq; lra | apply tech; try split; lra | - apply atan_bound ]. -replace (atan_sub (2/3) (/5)) with (7/17) by - (unfold atan_sub; field). -rewrite (atan_sub_correct (7/17) (/5)); - [apply f_equal | apply Rgt_not_eq; lra | apply tech; try split; lra | - apply atan_bound ]. -replace (atan_sub (7/17) (/5)) with (9/46) by - (unfold atan_sub; field). -rewrite (atan_sub_correct (9/46) (/5)); - [apply f_equal | apply Rgt_not_eq; lra | apply tech; try split; lra | - apply atan_bound ]. -rewrite <- atan_opp; apply f_equal. -unfold atan_sub; field. -Qed. - -Lemma Machin_2_3_7 : PI/4 = 2 * atan(/3) + (atan (/7)). -Proof. -rewrite <- atan_1. -rewrite (atan_sub_correct 1 (/3)); - [ | apply Rgt_not_eq; lra | apply tech; try split; lra | - apply atan_bound ]. -replace (2 * atan (/3) + atan (/7)) with - (atan (/3) + (atan (/3) + atan (/7))) by ring. -apply f_equal. -replace (atan_sub 1 (/3)) with (/2) by - (unfold atan_sub; field). -rewrite (atan_sub_correct (/2) (/3)); - [apply f_equal | apply Rgt_not_eq; lra | apply tech; try split; lra | - apply atan_bound ]. -apply f_equal; unfold atan_sub; field. -Qed. - -(* More efficient way to compute approximations of PI. *) - -Definition PI_2_3_7_tg n := - 2 * Ratan_seq (/3) n + Ratan_seq (/7) n. - -Lemma PI_2_3_7_ineq : - forall N : nat, - sum_f_R0 (tg_alt PI_2_3_7_tg) (S (2 * N)) <= PI / 4 <= - sum_f_R0 (tg_alt PI_2_3_7_tg) (2 * N). -Proof. -assert (dec3 : 0 <= /3 <= 1) by (split; lra). -assert (dec7 : 0 <= /7 <= 1) by (split; lra). -assert (decr : Un_decreasing PI_2_3_7_tg). -{ apply Ratan_seq_decreasing in dec3. - apply Ratan_seq_decreasing in dec7. - intros n; apply Rplus_le_compat. - { apply Rmult_le_compat_l; [ lra | exact (dec3 n)]. } - exact (dec7 n). } -assert (cv : Un_cv PI_2_3_7_tg 0). -{ apply Ratan_seq_converging in dec3. - apply Ratan_seq_converging in dec7. - intros eps ep. - assert (ep' : 0 < eps /3) by lra. - destruct (dec3 _ ep') as [N1 Pn1]; destruct (dec7 _ ep') as [N2 Pn2]. - exists (N1 + N2)%nat; intros n Nn. - unfold PI_2_3_7_tg. - rewrite <- (Rplus_0_l 0). - apply Rle_lt_trans with - (1 := Rdist_plus (2 * Ratan_seq (/3) n) 0 (Ratan_seq (/7) n) 0). - replace eps with (2 * eps/3 + eps/3) by field. - apply Rplus_lt_compat. - { unfold Rdist, Rminus, Rdiv. - rewrite <- (Rmult_0_r 2), <- Ropp_mult_distr_r_reverse. - rewrite <- Rmult_plus_distr_l, Rabs_mult, (Rabs_pos_eq 2);[|lra]. - rewrite Rmult_assoc; apply Rmult_lt_compat_l;[lra | ]. - apply (Pn1 n); lia. } - apply (Pn2 n); lia. } -rewrite Machin_2_3_7. -rewrite !atan_eq_ps_atan; try (split; lra). -unfold ps_atan; destruct (in_int (/3)); destruct (in_int (/7)); - try match goal with id : ~ _ |- _ => case id; split; lra end. -destruct (ps_atan_exists_1 (/3)) as [v3 Pv3]. -destruct (ps_atan_exists_1 (/7)) as [v7 Pv7]. -assert (main : Un_cv (sum_f_R0 (tg_alt PI_2_3_7_tg)) (2 * v3 + v7)). -{ assert (main :Un_cv (fun n => 2 * sum_f_R0 (tg_alt (Ratan_seq (/3))) n + - sum_f_R0 (tg_alt (Ratan_seq (/7))) n) (2 * v3 + v7)). - { apply CV_plus;[ | assumption]. - apply CV_mult;[ | assumption]. - exists 0%nat; intros; rewrite Rdist_eq; assumption. } - apply Un_cv_ext with (2 := main). - intros n; rewrite scal_sum, <- plus_sum; apply sum_eq; intros. - rewrite Rmult_comm; unfold PI_2_3_7_tg, tg_alt; field. } -intros N; apply (alternated_series_ineq _ _ _ decr cv main). -Qed. diff --git a/stdlib/theories/Reals/NewtonInt.v b/stdlib/theories/Reals/NewtonInt.v deleted file mode 100644 index a0271725f825..000000000000 --- a/stdlib/theories/Reals/NewtonInt.v +++ /dev/null @@ -1,753 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* R) (a b:R) : Type := - { g:R -> R | antiderivative f g a b \/ antiderivative f g b a }. - -Definition NewtonInt (f:R -> R) (a b:R) (pr:Newton_integrable f a b) : R := - let (g,_) := pr in g b - g a. - -(* If f is differentiable, then f' is Newton integrable (Tautology ?) *) -Lemma FTCN_step1 : - forall (f:Differential) (a b:R), - Newton_integrable (fun x:R => derive_pt f x (cond_diff f x)) a b. -Proof. - intros f a b; unfold Newton_integrable; exists (d1 f); - unfold antiderivative; intros; case (Rle_dec a b); - intro; - [ left; split; [ intros; exists (cond_diff f x); reflexivity | assumption ] - | right; split; - [ intros; exists (cond_diff f x); reflexivity | auto with real ] ]. -Defined. - -(* By definition, we have the Fondamental Theorem of Calculus *) -Lemma FTC_Newton : - forall (f:Differential) (a b:R), - NewtonInt (fun x:R => derive_pt f x (cond_diff f x)) a b - (FTCN_step1 f a b) = f b - f a. -Proof. - intros; unfold NewtonInt; reflexivity. -Qed. - -(* $\int_a^a f$ exists forall a:R and f:R->R *) -Lemma NewtonInt_P1 : forall (f:R -> R) (a:R), Newton_integrable f a a. -Proof. -intros f a; unfold Newton_integrable; - exists (fct_cte (f a) * id)%F; left; - unfold antiderivative; split. -2:right;reflexivity. -intros; assert (H1 : derivable_pt (fct_cte (f a) * id) x). -{ apply derivable_pt_mult. - { apply derivable_pt_const. } - apply derivable_pt_id. } -exists H1; assert (H2 : x = a). -{ elim H; intros; apply Rle_antisym; assumption. } -symmetry ; apply derive_pt_eq_0; - replace (f x) with (0 * id x + fct_cte (f a) x * 1); - [ apply (derivable_pt_lim_mult (fct_cte (f a)) id x); - [ apply derivable_pt_lim_const | apply derivable_pt_lim_id ] - | unfold id, fct_cte; rewrite H2; ring ]. -Qed. - -(* $\int_a^a f = 0$ *) -Lemma NewtonInt_P2 : - forall (f:R -> R) (a:R), NewtonInt f a a (NewtonInt_P1 f a) = 0. -Proof. - intros; unfold NewtonInt; simpl; - unfold mult_fct, fct_cte, id. - destruct NewtonInt_P1 as [g _]. - now apply Rminus_diag_eq. -Qed. - -(* If $\int_a^b f$ exists, then $\int_b^a f$ exists too *) -Lemma NewtonInt_P3 : - forall (f:R -> R) (a b:R) (X:Newton_integrable f a b), - Newton_integrable f b a. -Proof. - unfold Newton_integrable; intros; elim X; intros g H; - exists g; tauto. -Defined. - -(* $\int_a^b f = -\int_b^a f$ *) -Lemma NewtonInt_P4 : - forall (f:R -> R) (a b:R) (pr:Newton_integrable f a b), - NewtonInt f a b pr = - NewtonInt f b a (NewtonInt_P3 f a b pr). -Proof. - intros f a b (x,H). unfold NewtonInt, NewtonInt_P3; simpl; ring. -Qed. - -(* The set of Newton integrable functions is a vectorial space *) -Lemma NewtonInt_P5 : - forall (f g:R -> R) (l a b:R), - Newton_integrable f a b -> - Newton_integrable g a b -> - Newton_integrable (fun x:R => l * f x + g x) a b. -Proof. -unfold Newton_integrable; intros f g l a b X X0; - elim X; intros x p; elim X0; intros x0 p0; - exists (fun y:R => l * x y + x0 y). -elim p; intro; elim p0; intro. -- left; unfold antiderivative; unfold antiderivative in H, H0; elim H; - clear H; intros; elim H0; clear H0; intros H0 _. - split. 2:assumption. - intros; elim (H _ H2); elim (H0 _ H2); intros. - assert (H5 : derivable_pt (fun y:R => l * x y + x0 y) x1). - { reg. } - exists H5; symmetry ; reg; rewrite <- H3; rewrite <- H4; reflexivity. -- unfold antiderivative in H, H0; elim H; elim H0; intros; elim H4; intro. - { elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ H5 H2)). } - left; rewrite <- H5; unfold antiderivative; split. - 2:right;reflexivity. - intros; elim H6; intros; assert (H9 : x1 = a). - { apply Rle_antisym; assumption. } - assert (H10 : a <= x1 <= b). - { split; right; [ symmetry ; assumption | rewrite <- H5; assumption ]. } - assert (H11 : b <= x1 <= a). - { split; right; [ rewrite <- H5; symmetry ; assumption | assumption ]. } - assert (H12 : derivable_pt x x1). - { unfold derivable_pt; exists (f x1); elim (H3 _ H10); intros; - eapply derive_pt_eq_1; symmetry ; apply H12. } - assert (H13 : derivable_pt x0 x1). - { unfold derivable_pt; exists (g x1); elim (H1 _ H11); intros; - eapply derive_pt_eq_1; symmetry ; apply H13. } - assert (H14 : derivable_pt (fun y:R => l * x y + x0 y) x1). - { reg. } - exists H14; symmetry ; reg. - assert (H15 : derive_pt x0 x1 H13 = g x1). - { elim (H1 _ H11); intros; rewrite H15; apply pr_nu. } - assert (H16 : derive_pt x x1 H12 = f x1). - { elim (H3 _ H10); intros; rewrite H16; apply pr_nu. } - rewrite H15; rewrite H16; ring. -- unfold antiderivative in H, H0; elim H; elim H0; intros; elim H4; intro. - { elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ H5 H2)). } - left; rewrite H5; unfold antiderivative; split. - 2:{ right;reflexivity. } - intros; elim H6; intros; assert (H9 : x1 = a). - { apply Rle_antisym; assumption. } - assert (H10 : a <= x1 <= b). - { split; right; [ symmetry ; assumption | rewrite H5; assumption ]. } - assert (H11 : b <= x1 <= a). - { split; right; [ rewrite H5; symmetry ; assumption | assumption ]. } - assert (H12 : derivable_pt x x1). - { unfold derivable_pt; exists (f x1); elim (H3 _ H11); intros; - eapply derive_pt_eq_1; symmetry ; apply H12. } - assert (H13 : derivable_pt x0 x1). - { unfold derivable_pt; exists (g x1); elim (H1 _ H10); intros; - eapply derive_pt_eq_1; symmetry ; apply H13. } - assert (H14 : derivable_pt (fun y:R => l * x y + x0 y) x1). - { reg. } - exists H14; symmetry ; reg. - assert (H15 : derive_pt x0 x1 H13 = g x1). - { elim (H1 _ H10); intros; rewrite H15; apply pr_nu. } - assert (H16 : derive_pt x x1 H12 = f x1). - { elim (H3 _ H11); intros; rewrite H16; apply pr_nu. } - rewrite H15; rewrite H16; ring. -- right; unfold antiderivative; unfold antiderivative in H, H0; elim H; - clear H; intros; elim H0; clear H0; intros H0 _; split. - 2:assumption. - intros; elim (H _ H2); elim (H0 _ H2); intros. - assert (H5 : derivable_pt (fun y:R => l * x y + x0 y) x1). - { reg. } - exists H5; symmetry ; reg; rewrite <- H3; rewrite <- H4; reflexivity. -Qed. - -(**********) -Lemma antiderivative_P1 : - forall (f g F G:R -> R) (l a b:R), - antiderivative f F a b -> - antiderivative g G a b -> - antiderivative (fun x:R => l * f x + g x) (fun x:R => l * F x + G x) a b. -Proof. - unfold antiderivative; intros; elim H; elim H0; clear H H0; intros; - split. - { intros; elim (H _ H3); elim (H1 _ H3); intros. - assert (H6 : derivable_pt (fun x:R => l * F x + G x) x). - { reg. } - exists H6; symmetry ; reg; rewrite <- H4; rewrite <- H5; ring. } - assumption. -Qed. - -(* $\int_a^b \lambda f + g = \lambda \int_a^b f + \int_a^b f *) -Lemma NewtonInt_P6 : - forall (f g:R -> R) (l a b:R) (pr1:Newton_integrable f a b) - (pr2:Newton_integrable g a b), - NewtonInt (fun x:R => l * f x + g x) a b (NewtonInt_P5 f g l a b pr1 pr2) = - l * NewtonInt f a b pr1 + NewtonInt g a b pr2. -Proof. -intros f g l a b pr1 pr2; unfold NewtonInt; - destruct (NewtonInt_P5 f g l a b pr1 pr2) as (x,o); destruct pr1 as (x0,o0); - destruct pr2 as (x1,o1); destruct (total_order_T a b) as [[Hlt|Heq]|Hgt]. -- elim o; intro. - 2:{ unfold antiderivative in H; elim H; intros; - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H1 Hlt)). } - elim o0; intro. - 2:{ unfold antiderivative in H0; elim H0; intros; - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H2 Hlt)). } - elim o1; intro. - 2:{ unfold antiderivative in H1; elim H1; intros; - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H3 Hlt)). } - assert (H2 := antiderivative_P1 f g x0 x1 l a b H0 H1); - assert (H3 := antiderivative_Ucte _ _ _ _ _ H H2); - elim H3; intros; assert (H5 : a <= a <= b). - { split; [ right; reflexivity | left; assumption ]. } - assert (H6 : a <= b <= b). - { split; [ left; assumption | right; reflexivity ]. } - assert (H7 := H4 _ H5); assert (H8 := H4 _ H6); rewrite H7; rewrite H8; ring. -- rewrite Heq; ring. -- elim o; intro. - { unfold antiderivative in H; elim H; intros; - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H1 Hgt)). } - elim o0; intro. - { unfold antiderivative in H0; elim H0; intros; - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H2 Hgt)). } - elim o1; intro. - { unfold antiderivative in H1; elim H1; intros; - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H3 Hgt)). } - assert (H2 := antiderivative_P1 f g x0 x1 l b a H0 H1); - assert (H3 := antiderivative_Ucte _ _ _ _ _ H H2); - elim H3; intros; assert (H5 : b <= a <= a). - { split; [ left; assumption | right; reflexivity ]. } - assert (H6 : b <= b <= a). - { split; [ right; reflexivity | left; assumption ]. } - assert (H7 := H4 _ H5); assert (H8 := H4 _ H6); rewrite H7; rewrite H8; ring. -Qed. - -Lemma antiderivative_P2 : - forall (f F0 F1:R -> R) (a b c:R), - antiderivative f F0 a b -> - antiderivative f F1 b c -> - antiderivative f - (fun x:R => - match Rle_dec x b with - | left _ => F0 x - | right _ => F1 x + (F0 b - F1 b) - end) a c. -Proof. -intros; destruct H as (H,H1), H0 as (H0,H2); split. -2: apply Rle_trans with b; assumption. -intros x (H3,H4); destruct (total_order_T x b) as [[Hlt|Heq]|Hgt]. -- assert (H5 : a <= x <= b). - { split; [ assumption | left; assumption ]. } - destruct (H _ H5) as (x0,H6). - assert - (H7 : - derivable_pt_lim - (fun x:R => - match Rle_dec x b with - | left _ => F0 x - | right _ => F1 x + (F0 b - F1 b) - end) x (f x)). - { unfold derivable_pt_lim. intros eps H9. - assert (H7 : derive_pt F0 x x0 = f x) by (symmetry; assumption). - destruct (derive_pt_eq_1 F0 x (f x) x0 H7 _ H9) as (x1,H10); set (D := Rmin x1 (b - x)). - assert (H11 : 0 < D). - { unfold D, Rmin; case (Rle_dec x1 (b - x)); intro. - { apply (cond_pos x1). } - apply Rlt_0_minus; assumption. } - exists (mkposreal _ H11); intros h H12 H13. case (Rle_dec x b) as [|[]]. - 2:left;assumption. - case (Rle_dec (x + h) b) as [|[]]. - { apply H10. - { assumption. } - apply Rlt_le_trans with D; [ assumption | unfold D; apply Rmin_l ]. } - left; apply Rlt_le_trans with (x + D). - { apply Rplus_lt_compat_l; apply Rle_lt_trans with (Rabs h). - { apply RRle_abs. } - apply H13. } - apply Rplus_le_reg_l with (- x); rewrite <- Rplus_assoc; rewrite Rplus_opp_l; - rewrite Rplus_0_l; rewrite Rplus_comm; unfold D; - apply Rmin_r. } - assert - (H8 : - derivable_pt - (fun x:R => - match Rle_dec x b with - | left _ => F0 x - | right _ => F1 x + (F0 b - F1 b) - end) x). - { unfold derivable_pt; exists (f x); apply H7. } - exists H8; symmetry ; apply derive_pt_eq_0; apply H7. -- assert (H5 : a <= x <= b). - { split; [ assumption | right; assumption ]. } - assert (H6 : b <= x <= c). - { split; [ right; symmetry ; assumption | assumption ]. } - elim (H _ H5); elim (H0 _ H6); intros; assert (H9 : derive_pt F0 x x1 = f x). - { symmetry ; assumption. } - assert (H10 : derive_pt F1 x x0 = f x). - { symmetry ; assumption. } - assert (H11 := derive_pt_eq_1 F0 x (f x) x1 H9); - assert (H12 := derive_pt_eq_1 F1 x (f x) x0 H10); - assert - (H13 : - derivable_pt_lim - (fun x:R => - match Rle_dec x b with - | left _ => F0 x - | right _ => F1 x + (F0 b - F1 b) - end) x (f x)). - { unfold derivable_pt_lim; unfold derivable_pt_lim in H11, H12; intros; - elim (H11 _ H13); elim (H12 _ H13); intros; set (D := Rmin x2 x3); - assert (H16 : 0 < D). - { unfold D; unfold Rmin; case (Rle_dec x2 x3); intro. - { apply (cond_pos x2). } - apply (cond_pos x3). } - exists (mkposreal _ H16); intros; case (Rle_dec x b) as [|[]]. - 2:right;assumption. - case (Rle_dec (x + h) b); intro. - { apply H15. - { assumption. } - apply Rlt_le_trans with D; [ assumption | unfold D; apply Rmin_r ]. } - replace (F1 (x + h) + (F0 b - F1 b) - F0 x) with (F1 (x + h) - F1 x). - { apply H14. - { assumption. } - apply Rlt_le_trans with D; [ assumption | unfold D; apply Rmin_l ]. } - rewrite Heq; ring. } - assert - (H14 : - derivable_pt - (fun x:R => - match Rle_dec x b with - | left _ => F0 x - | right _ => F1 x + (F0 b - F1 b) - end) x). - { unfold derivable_pt; exists (f x); apply H13. } - exists H14; symmetry ; apply derive_pt_eq_0; apply H13. -- assert (H5 : b <= x <= c). - { split; [ left; assumption | assumption ]. } - assert (H6 := H0 _ H5); elim H6; clear H6; intros; - assert - (H7 : - derivable_pt_lim - (fun x:R => - match Rle_dec x b with - | left _ => F0 x - | right _ => F1 x + (F0 b - F1 b) - end) x (f x)). - { unfold derivable_pt_lim; assert (H7 : derive_pt F1 x x0 = f x). - { symmetry ; assumption. } - assert (H8 := derive_pt_eq_1 F1 x (f x) x0 H7); unfold derivable_pt_lim in H8; - intros; elim (H8 _ H9); intros; set (D := Rmin x1 (x - b)); - assert (H11 : 0 < D). - { unfold D; unfold Rmin; case (Rle_dec x1 (x - b)); intro. - { apply (cond_pos x1). } - apply Rlt_0_minus; assumption. } - exists (mkposreal _ H11); intros; destruct (Rle_dec x b) as [Hle|Hnle]. - { elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ Hle Hgt)). } - destruct (Rle_dec (x + h) b) as [Hle'|Hnle']. - { cut (b < x + h). - { intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ Hle' H14)). } - apply Rplus_lt_reg_l with (- h - b); replace (- h - b + b) with (- h); - [ idtac | ring ]; replace (- h - b + (x + h)) with (x - b); - [ idtac | ring ]; apply Rle_lt_trans with (Rabs h). - { rewrite <- Rabs_Ropp; apply RRle_abs. } - apply Rlt_le_trans with D. - { apply H13. } - unfold D; apply Rmin_r. } - replace (F1 (x + h) + (F0 b - F1 b) - (F1 x + (F0 b - F1 b))) with - (F1 (x + h) - F1 x); [ idtac | ring ]; apply H10. - { assumption. } - apply Rlt_le_trans with D. - { assumption. } - unfold D; apply Rmin_l. } - assert - (H8 : - derivable_pt - (fun x:R => - match Rle_dec x b with - | left _ => F0 x - | right _ => F1 x + (F0 b - F1 b) - end) x). - { unfold derivable_pt; exists (f x); apply H7. } - exists H8; symmetry ; apply derive_pt_eq_0; apply H7. -Qed. - -Lemma antiderivative_P3 : - forall (f F0 F1:R -> R) (a b c:R), - antiderivative f F0 a b -> - antiderivative f F1 c b -> - antiderivative f F1 c a \/ antiderivative f F0 a c. -Proof. -intros; unfold antiderivative in H, H0; elim H; clear H; elim H0; clear H0; - intros; destruct (total_order_T a c) as [[Hle|Heq]|Hgt]. -- right; unfold antiderivative; split. - { intros; apply H1; elim H3; intros; split; - [ assumption | apply Rle_trans with c; assumption ]. } - left; assumption. -- right; unfold antiderivative; split. - { intros; apply H1; elim H3; intros; split; - [ assumption | apply Rle_trans with c; assumption ]. } - right; assumption. -- left; unfold antiderivative; split. - { intros; apply H; elim H3; intros; split; - [ assumption | apply Rle_trans with a; assumption ]. } - left; assumption. -Qed. - -Lemma antiderivative_P4 : - forall (f F0 F1:R -> R) (a b c:R), - antiderivative f F0 a b -> - antiderivative f F1 a c -> - antiderivative f F1 b c \/ antiderivative f F0 c b. -Proof. -intros; unfold antiderivative in H, H0; elim H; clear H; elim H0; clear H0; - intros; destruct (total_order_T c b) as [[Hlt|Heq]|Hgt]. -- right; unfold antiderivative; split. - { intros; apply H1; elim H3; intros; split; - [ apply Rle_trans with c; assumption | assumption ]. } - left; assumption. -- right; unfold antiderivative; split. - { intros; apply H1; elim H3; intros; split; - [ apply Rle_trans with c; assumption | assumption ]. } - right; assumption. -- left; unfold antiderivative; split. - { intros; apply H; elim H3; intros; split; - [ apply Rle_trans with b; assumption | assumption ]. } - left; assumption. -Qed. - -Lemma NewtonInt_P7 : - forall (f:R -> R) (a b c:R), - a < b -> - b < c -> - Newton_integrable f a b -> - Newton_integrable f b c -> Newton_integrable f a c. -Proof. -unfold Newton_integrable; intros f a b c Hab Hbc X X0; elim X; - clear X; intros F0 H0; elim X0; clear X0; intros F1 H1; - set - (g := - fun x:R => - match Rle_dec x b with - | left _ => F0 x - | right _ => F1 x + (F0 b - F1 b) - end); - exists g; left; unfold g; - apply antiderivative_P2. -{ elim H0; intro. - { assumption. } - unfold antiderivative in H; elim H; clear H; intros; - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H2 Hab)). } -elim H1; intro. -{ assumption. } -unfold antiderivative in H; elim H; clear H; intros; - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H2 Hbc)). -Qed. - -Lemma NewtonInt_P8 : - forall (f:R -> R) (a b c:R), - Newton_integrable f a b -> - Newton_integrable f b c -> Newton_integrable f a c. -Proof. -intros. -elim X; intros F0 H0. -elim X0; intros F1 H1. -destruct (total_order_T a b) as [[Hlt|Heq]|Hgt]. -- destruct (total_order_T b c) as [[Hlt'|Heq']|Hgt']. - + (* a - match Rle_dec x b with - | left _ => F0 x - | right _ => F1 x + (F0 b - F1 b) - end). - elim H0; intro. - { elim H1; intro. - { left; apply antiderivative_P2; assumption. } - unfold antiderivative in H2; elim H2; clear H2; intros _ H2. - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H2 Hlt')). } - unfold antiderivative in H; elim H; clear H; intros _ H. - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H Hlt)). - + (* ac *) - destruct (total_order_T a c) as [[Hlt''|Heq'']|Hgt'']. - * unfold Newton_integrable; exists F0. - left. - elim H1; intro. - { unfold antiderivative in H; elim H; clear H; intros _ H. - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H Hgt')). } - elim H0; intro. - { assert (H3 := antiderivative_P3 f F0 F1 a b c H2 H). - elim H3; intro. - { unfold antiderivative in H4; elim H4; clear H4; intros _ H4. - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H4 Hlt'')). } - assumption. } - unfold antiderivative in H2; elim H2; clear H2; intros _ H2. - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H2 Hlt)). - * rewrite Heq''; apply NewtonInt_P1. - * unfold Newton_integrable; exists F1. - right. - elim H1; intro. - { unfold antiderivative in H; elim H; clear H; intros _ H. - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H Hgt')). } - elim H0; intro. - { assert (H3 := antiderivative_P3 f F0 F1 a b c H2 H). - elim H3; intro. - { assumption. } - unfold antiderivative in H4; elim H4; clear H4; intros _ H4. - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H4 Hgt'')). } - unfold antiderivative in H2; elim H2; clear H2; intros _ H2. - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H2 Hlt)). -- (* a=b *) - rewrite Heq; apply X0. -- destruct (total_order_T b c) as [[Hlt'|Heq']|Hgt']. - (* a>b & bb & b=c *) - rewrite Heq' in X; apply X. - + (* a>b & b>c *) - assert (X1 := NewtonInt_P3 f a b X). - assert (X2 := NewtonInt_P3 f b c X0). - apply NewtonInt_P3. - apply NewtonInt_P7 with b; assumption. -Qed. - -(* Chasles' relation *) -Lemma NewtonInt_P9 : - forall (f:R -> R) (a b c:R) (pr1:Newton_integrable f a b) - (pr2:Newton_integrable f b c), - NewtonInt f a c (NewtonInt_P8 f a b c pr1 pr2) = - NewtonInt f a b pr1 + NewtonInt f b c pr2. -Proof. -intros; unfold NewtonInt. -case (NewtonInt_P8 f a b c pr1 pr2) as (x,Hor). -case pr1 as (x0,Hor0). -case pr2 as (x1,Hor1). -destruct (total_order_T a b) as [[Hlt|Heq]|Hgt]. -- destruct (total_order_T b c) as [[Hlt'|Heq']|Hgt']. - + (* a - match Rle_dec x b with - | left _ => x0 x - | right _ => x1 x + (x0 b - x1 b) - end) a c H1 H2). - elim H3; intros. - assert (H5 : a <= a <= c). - { split; [ right; reflexivity | left; apply Rlt_trans with b; assumption ]. } - assert (H6 : a <= c <= c). - { split; [ left; apply Rlt_trans with b; assumption | right; reflexivity ]. } - rewrite (H4 _ H5); rewrite (H4 _ H6). - destruct (Rle_dec a b) as [Hlea|Hnlea]. - { destruct (Rle_dec c b) as [Hlec|Hnlec]. - { elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ Hlec Hlt')). } - ring. } - elim Hnlea; left; assumption. - + (* ac *) - elim Hor1; intro. - { unfold antiderivative in H; elim H; clear H; intros _ H. - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H Hgt')). } - elim Hor0; intro. - 2:{ unfold antiderivative in H0; elim H0; clear H0; intros _ H0. - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H0 Hlt)). } - elim Hor; intro. - * assert (H2 := antiderivative_P2 f x x1 a c b H1 H). - assert (H3 := antiderivative_Ucte _ _ _ a b H0 H2). - elim H3; intros. - rewrite (H4 a). - { rewrite (H4 b). - { destruct (Rle_dec b c) as [Hle|Hnle]. - { elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ Hle Hgt')). } - destruct (Rle_dec a c) as [Hle'|Hnle']. - { ring. } - elim Hnle'; unfold antiderivative in H1; elim H1; intros; assumption. } - split; [ left; assumption | right; reflexivity ]. } - split; [ right; reflexivity | left; assumption ]. - * assert (H2 := antiderivative_P2 _ _ _ _ _ _ H1 H0). - assert (H3 := antiderivative_Ucte _ _ _ c b H H2). - elim H3; intros. - rewrite (H4 c). - { rewrite (H4 b). - { destruct (Rle_dec b a) as [Hle|Hnle]. - { elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ Hle Hlt)). } - destruct (Rle_dec c a) as [Hle'|[]]. - { ring. } - unfold antiderivative in H1; elim H1; intros; assumption. } - split; [ left; assumption | right; reflexivity ]. } - split; [ right; reflexivity | left; assumption ]. -- (* a=b *) - rewrite Heq in Hor |- *. - elim Hor; intro. - + elim Hor1; intro. - * assert (H1 := antiderivative_Ucte _ _ _ b c H H0). - elim H1; intros. - assert (H3 : b <= c). - { unfold antiderivative in H; elim H; intros; assumption. } - rewrite (H2 b). - { rewrite (H2 c). - { ring. } - split; [ assumption | right; reflexivity ]. } - split; [ right; reflexivity | assumption ]. - * assert (H1 : b = c). - { unfold antiderivative in H, H0; elim H; elim H0; intros; apply Rle_antisym; - assumption. } - rewrite H1; ring. - + elim Hor1; intro. - * assert (H1 : b = c). - { unfold antiderivative in H, H0; elim H; elim H0; intros; apply Rle_antisym; - assumption. } - rewrite H1; ring. - * assert (H1 := antiderivative_Ucte _ _ _ c b H H0). - elim H1; intros. - assert (H3 : c <= b). - { unfold antiderivative in H; elim H; intros; assumption. } - rewrite (H2 c). - { rewrite (H2 b). - { ring. } - split; [ assumption | right; reflexivity ]. } - split; [ right; reflexivity | assumption ]. -- (* a>b & bb & b=c *) - rewrite <- Heq'. - unfold Rminus; rewrite Rplus_opp_r; rewrite Rplus_0_r. - rewrite <- Heq' in Hor. - elim Hor0; intro. - { unfold antiderivative in H; elim H; clear H; intros _ H. - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H Hgt)). } - elim Hor; intro. - { unfold antiderivative in H0; elim H0; clear H0; intros _ H0. - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H0 Hgt)). } - assert (H1 := antiderivative_Ucte f x x0 b a H0 H). - elim H1; intros. - rewrite (H2 b). - { rewrite (H2 a). - { ring. } - split; [ left; assumption | right; reflexivity ]. } - split; [ right; reflexivity | left; assumption ]. - + (* a>b & b>c *) - elim Hor0; intro. - { unfold antiderivative in H; elim H; clear H; intros _ H. - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H Hgt)). } - elim Hor1; intro. - { unfold antiderivative in H0; elim H0; clear H0; intros _ H0. - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H0 Hgt')). } - elim Hor; intro. - { unfold antiderivative in H1; elim H1; clear H1; intros _ H1. - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H1 (Rlt_trans _ _ _ Hgt' Hgt))). } - assert (H2 := antiderivative_P2 _ _ _ _ _ _ H0 H). - assert (H3 := antiderivative_Ucte _ _ _ c a H1 H2). - elim H3; intros. - assert (H5 : c <= a). - { unfold antiderivative in H1; elim H1; intros; assumption. } - rewrite (H4 c). - { rewrite (H4 a). - { destruct (Rle_dec a b) as [Hle|Hnle]. - { elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ Hle Hgt)). } - destruct (Rle_dec c b) as [|[]]. - { ring. } - left; assumption. } - split; [ assumption | right; reflexivity ]. } - split; [ right; reflexivity | assumption ]. -Qed. diff --git a/stdlib/theories/Reals/PSeries_reg.v b/stdlib/theories/Reals/PSeries_reg.v deleted file mode 100644 index 8a9e33c09f05..000000000000 --- a/stdlib/theories/Reals/PSeries_reg.v +++ /dev/null @@ -1,611 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* Boule c d y -> x <= z <= y -> Boule c d z. -Proof. -intros c d x y z bx b_y intz. -unfold Boule in bx, b_y; apply Rabs_def2 in bx; -apply Rabs_def2 in b_y; apply Rabs_def1; - [apply Rle_lt_trans with (y - c);[apply Rplus_le_compat_r|]| - apply Rlt_le_trans with (x - c);[|apply Rplus_le_compat_r]];tauto. -Qed. - -Definition boule_of_interval x y (h : x < y) : - {c :R & {r : posreal | c - r = x /\ c + r = y}}. -Proof. -exists ((x + y)/2). -assert (radius : 0 < (y - x)/2). -- unfold Rdiv; apply Rmult_lt_0_compat. - + apply Rlt_0_minus; assumption. - + now apply Rinv_0_lt_compat, Rlt_0_2. -- exists (mkposreal _ radius). - simpl; split; unfold Rdiv; field. -Qed. - -Definition boule_in_interval x y z (h : x < z < y) : - {c : R & {r | Boule c r z /\ x < c - r /\ c + r < y}}. -Proof. -assert (cmp : x * /2 + z * /2 < z * /2 + y * /2). { - destruct h as [h1 h2]. - rewrite Rplus_comm; apply Rplus_lt_compat_l, Rmult_lt_compat_r. - - apply Rinv_0_lt_compat, Rlt_0_2. - - apply Rlt_trans with z; assumption. -} -destruct (boule_of_interval _ _ cmp) as [c [r [P1 P2]]]. -assert (0 < /2) by (apply Rinv_0_lt_compat, Rlt_0_2). -exists c, r; split. -- destruct h; unfold Boule; simpl; apply Rabs_def1. - + apply Rplus_lt_reg_l with c; rewrite P2; - replace (c + (z - c)) with (z * / 2 + z * / 2) by field. - apply Rplus_lt_compat_l, Rmult_lt_compat_r;assumption. - + apply Rplus_lt_reg_l with c; change (c + - r) with (c - r); - rewrite P1; - replace (c + (z - c)) with (z * / 2 + z * / 2) by field. - apply Rplus_lt_compat_r, Rmult_lt_compat_r;assumption. -- destruct h; split. - + replace x with (x * / 2 + x * / 2) by field; rewrite P1. - apply Rplus_lt_compat_l, Rmult_lt_compat_r;assumption. - + replace y with (y * / 2 + y * /2) by field; rewrite P2. - apply Rplus_lt_compat_r, Rmult_lt_compat_r;assumption. -Qed. - -Lemma Ball_in_inter : forall c1 c2 r1 r2 x, - Boule c1 r1 x -> Boule c2 r2 x -> - {r3 : posreal | forall y, Boule x r3 y -> Boule c1 r1 y /\ Boule c2 r2 y}. -Proof. -intros c1 c2 [r1 r1p] [r2 r2p] x; unfold Boule; simpl; intros in1 in2. -assert (Rmax (c1 - r1)(c2 - r2) < x). { - apply Rmax_lub_lt;[revert in1 | revert in2]; intros h; - apply Rabs_def2 in h; destruct h as [_ u]; - apply (fun h => Rplus_lt_reg_r _ _ _ (Rle_lt_trans _ _ _ h u)), Req_le; ring. } -assert (x < Rmin (c1 + r1) (c2 + r2)). { - apply Rmin_glb_lt;[revert in1 | revert in2]; intros h; - apply Rabs_def2 in h; destruct h as [u _]; - apply (fun h => Rplus_lt_reg_r _ _ _ (Rlt_le_trans _ _ _ u h)), Req_le; ring. } -assert (t: 0 < Rmin (x - Rmax (c1 - r1) (c2 - r2)) - (Rmin (c1 + r1) (c2 + r2) - x)). { - apply Rmin_glb_lt; apply Rlt_0_minus; assumption. } -exists (mkposreal _ t). -apply Rabs_def2 in in1; destruct in1. -apply Rabs_def2 in in2; destruct in2. -assert (c1 - r1 <= Rmax (c1 - r1) (c2 - r2)) by apply Rmax_l. -assert (c2 - r2 <= Rmax (c1 - r1) (c2 - r2)) by apply Rmax_r. -assert (Rmin (c1 + r1) (c2 + r2) <= c1 + r1) by apply Rmin_l. -assert (Rmin (c1 + r1) (c2 + r2) <= c2 + r2) by apply Rmin_r. -assert (Rmin (x - Rmax (c1 - r1) (c2 - r2)) - (Rmin (c1 + r1) (c2 + r2) - x) <= x - Rmax (c1 - r1) (c2 - r2)) - by apply Rmin_l. -assert (Rmin (x - Rmax (c1 - r1) (c2 - r2)) - (Rmin (c1 + r1) (c2 + r2) - x) <= Rmin (c1 + r1) (c2 + r2) - x) - by apply Rmin_r. -simpl. -intros y h; apply Rabs_def2 in h; destruct h as [h h']. -apply Rmin_Rgt in h; destruct h as [cmp1 cmp2]. -apply Rplus_lt_reg_r in cmp2; apply Rmin_Rgt in cmp2. -rewrite Ropp_Rmin, Ropp_minus_distr in h'. -apply Rmax_Rlt in h'; destruct h' as [cmp3 cmp4]; -apply Rplus_lt_reg_r in cmp3; apply Rmax_Rlt in cmp3; -split; apply Rabs_def1. -- apply (fun h => Rplus_lt_reg_l _ _ _ (Rle_lt_trans _ _ _ h (proj1 cmp2))), Req_le; - ring. -- apply (fun h => Rplus_lt_reg_l _ _ _ (Rlt_le_trans _ _ _ (proj1 cmp3) h)), Req_le; - ring. -- apply (fun h => Rplus_lt_reg_l _ _ _ (Rle_lt_trans _ _ _ h (proj2 cmp2))), Req_le; - ring. -- apply (fun h => Rplus_lt_reg_l _ _ _ (Rlt_le_trans _ _ _ (proj2 cmp3) h)), Req_le; - ring. -Qed. - -Lemma Boule_center : forall x r, Boule x r x. -Proof. -intros x [r rpos]; unfold Boule, Rminus; simpl; rewrite Rplus_opp_r. -rewrite Rabs_pos_eq;[assumption | apply Rle_refl]. -Qed. - -(** Uniform convergence *) -Definition CVU (fn:nat -> R -> R) (f:R -> R) (x:R) - (r:posreal) : Prop := - forall eps:R, - 0 < eps -> - exists N : nat, - (forall (n:nat) (y:R), - (N <= n)%nat -> Boule x r y -> Rabs (f y - fn n y) < eps). - -(** Normal convergence *) -Definition CVN_r (fn:nat -> R -> R) (r:posreal) : Type := - { An:nat -> R & - { l:R | - Un_cv (fun n:nat => sum_f_R0 (fun k:nat => Rabs (An k)) n) l /\ - (forall (n:nat) (y:R), Boule 0 r y -> Rabs (fn n y) <= An n) } }. - -Definition CVN_R (fn:nat -> R -> R) : Type := forall r:posreal, CVN_r fn r. - -Definition SFL (fn:nat -> R -> R) - (cv:forall x:R, { l:R | Un_cv (fun N:nat => SP fn N x) l }) - (y:R) : R := let (a,_) := cv y in a. - -(** In a complete space, normal convergence implies uniform convergence *) -Lemma CVN_CVU : - forall (fn:nat -> R -> R) - (cv:forall x:R, {l:R | Un_cv (fun N:nat => SP fn N x) l }) - (r:posreal), CVN_r fn r -> CVU (fun n:nat => SP fn n) (SFL fn cv) 0 r. -Proof. - intros; unfold CVU; intros. - unfold CVN_r in X. - elim X; intros An X0. - elim X0; intros s H0. - elim H0; intros. - assert (Un_cv (fun n:nat => sum_f_R0 (fun k:nat => Rabs (An k)) n - s) 0). { - unfold Un_cv in H1; unfold Un_cv; intros. - elim (H1 _ H3); intros. - exists x; intros. - unfold Rdist; unfold Rdist in H4. - rewrite Rminus_0_r; apply H4; assumption. - } - unfold Un_cv in H3. - elim (H3 eps H); intros N0 H4. - exists N0; intros. - apply Rle_lt_trans with (Rabs (sum_f_R0 (fun k:nat => Rabs (An k)) n - s)). - 2:{ unfold Rdist in H4; unfold Rminus in H4; rewrite Ropp_0 in H4. - assert (H7 := H4 n H5). - rewrite Rplus_0_r in H7; apply H7. } - rewrite <- (Rabs_Ropp (sum_f_R0 (fun k:nat => Rabs (An k)) n - s)); - rewrite Ropp_minus_distr; - rewrite (Rabs_right (s - sum_f_R0 (fun k:nat => Rabs (An k)) n)). - { eapply sum_maj1. - - unfold SFL; case (cv y); intro. - trivial. - - apply H1. - - intro; elim H0; intros. - rewrite (Rabs_right (An n0)). - + apply H8; apply H6. - + apply Rle_ge; apply Rle_trans with (Rabs (fn n0 y)). - * apply Rabs_pos. - * apply H8; apply H6. } - apply Rle_ge; - apply Rplus_le_reg_l with (sum_f_R0 (fun k:nat => Rabs (An k)) n). - rewrite Rplus_0_r; unfold Rminus; rewrite (Rplus_comm s); - rewrite <- Rplus_assoc; rewrite Rplus_opp_r; rewrite Rplus_0_l; - apply sum_incr. - - apply H1. - - intro; apply Rabs_pos. -Qed. - -(** Each limit of a sequence of functions which converges uniformly is continue *) -Lemma CVU_continuity : - forall (fn:nat -> R -> R) (f:R -> R) (x:R) (r:posreal), - CVU fn f x r -> - (forall (n:nat) (y:R), Boule x r y -> continuity_pt (fn n) y) -> - forall y:R, Boule x r y -> continuity_pt f y. -Proof. - intros; unfold continuity_pt; unfold continue_in; - unfold limit1_in; unfold limit_in; - simpl; unfold Rdist; intros. - unfold CVU in H. - cut (0 < eps / 3); - [ intro - | unfold Rdiv; apply Rmult_lt_0_compat; - [ assumption | apply Rinv_0_lt_compat; prove_sup0 ] ]. - elim (H _ H3); intros N0 H4. - assert (H5 := H0 N0 y H1). - assert (exists del : posreal, (forall h:R, Rabs h < del -> Boule x r (y + h))). { - assert (0 < r - Rabs (x - y)). { - unfold Boule in H1; rewrite <- (Rabs_Ropp (x - y)); rewrite Ropp_minus_distr; - apply Rplus_lt_reg_l with (Rabs (y - x)). - rewrite Rplus_0_r; replace (Rabs (y - x) + (r - Rabs (y - x))) with (pos r); - [ apply H1 | ring ]. - } - exists (mkposreal _ H6). - simpl; intros. - unfold Boule; replace (y + h - x) with (h + (y - x)); - [ idtac | ring ]; apply Rle_lt_trans with (Rabs h + Rabs (y - x)). - { apply Rabs_triang. } - apply Rplus_lt_reg_l with (- Rabs (x - y)). - rewrite <- (Rabs_Ropp (y - x)); rewrite Ropp_minus_distr. - replace (- Rabs (x - y) + r) with (r - Rabs (x - y)) by ring. - replace (- Rabs (x - y) + (Rabs h + Rabs (x - y))) with (Rabs h) by ring. - apply H7. - } - elim H6; intros del1 H7. - unfold continuity_pt in H5; unfold continue_in in H5; unfold limit1_in in H5; - unfold limit_in in H5; simpl in H5; unfold Rdist in H5. - elim (H5 _ H3); intros del2 H8. - set (del := Rmin del1 del2). - exists del; intros. - split. - { unfold del; unfold Rmin; case (Rle_dec del1 del2); intro. - - apply (cond_pos del1). - - elim H8; intros; assumption. } - intros; - apply Rle_lt_trans with (Rabs (f x0 - fn N0 x0) + Rabs (fn N0 x0 - f y)). - { replace (f x0 - f y) with (f x0 - fn N0 x0 + (fn N0 x0 - f y)); - [ apply Rabs_triang | ring ]. } - apply Rle_lt_trans with - (Rabs (f x0 - fn N0 x0) + Rabs (fn N0 x0 - fn N0 y) + Rabs (fn N0 y - f y)). - { rewrite Rplus_assoc; apply Rplus_le_compat_l. - replace (fn N0 x0 - f y) with (fn N0 x0 - fn N0 y + (fn N0 y - f y)); - [ apply Rabs_triang | ring ]. } - replace eps with (eps / 3 + eps / 3 + eps / 3) by field. - repeat apply Rplus_lt_compat. - - apply H4. - + apply le_n. - + replace x0 with (y + (x0 - y)); [ idtac | ring ]; apply H7. - elim H9; intros. - apply Rlt_le_trans with del. - * assumption. - * unfold del; apply Rmin_l. - - elim H8; intros. - apply H11. - split. - + elim H9; intros; assumption. - + elim H9; intros; apply Rlt_le_trans with del. - * assumption. - * unfold del; apply Rmin_r. - - rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; apply H4. - + apply le_n. - + assumption. -Qed. - -(**********) -Lemma continuity_pt_finite_SF : - forall (fn:nat -> R -> R) (N:nat) (x:R), - (forall n:nat, (n <= N)%nat -> continuity_pt (fn n) x) -> - continuity_pt (fun y:R => sum_f_R0 (fun k:nat => fn k y) N) x. -Proof. - intros; induction N as [| N HrecN]. - - simpl; apply (H 0%nat); apply le_n. - - simpl; - replace (fun y:R => sum_f_R0 (fun k:nat => fn k y) N + fn (S N) y) with - ((fun y:R => sum_f_R0 (fun k:nat => fn k y) N) + (fun y:R => fn (S N) y))%F; - [ idtac | reflexivity ]. - apply continuity_pt_plus. - + apply HrecN. - intros; apply H. - apply Nat.le_trans with N; [ assumption | apply Nat.le_succ_diag_r ]. - + apply (H (S N)); apply le_n. -Qed. - -(** Continuity and normal convergence *) -Lemma SFL_continuity_pt : - forall (fn:nat -> R -> R) - (cv:forall x:R, { l:R | Un_cv (fun N:nat => SP fn N x) l }) - (r:posreal), - CVN_r fn r -> - (forall (n:nat) (y:R), Boule 0 r y -> continuity_pt (fn n) y) -> - forall y:R, Boule 0 r y -> continuity_pt (SFL fn cv) y. -Proof. - intros; eapply CVU_continuity. - - apply CVN_CVU. - apply X. - - intros; unfold SP; apply continuity_pt_finite_SF. - intros; apply H. - apply H1. - - apply H0. -Qed. - -Lemma SFL_continuity : - forall (fn:nat -> R -> R) - (cv:forall x:R, { l:R | Un_cv (fun N:nat => SP fn N x) l }), - CVN_R fn -> (forall n:nat, continuity (fn n)) -> continuity (SFL fn cv). -Proof. - intros; unfold continuity; intro. - cut (0 < Rabs x + 1); - [ intro | apply Rplus_le_lt_0_compat; [ apply Rabs_pos | apply Rlt_0_1 ] ]. - cut (Boule 0 (mkposreal _ H0) x). - - intro; eapply SFL_continuity_pt with (mkposreal _ H0). - + apply X. - + intros; apply (H n y). - + apply H1. - - unfold Boule; simpl; rewrite Rminus_0_r; - pattern (Rabs x) at 1; rewrite <- Rplus_0_r; - apply Rplus_lt_compat_l; apply Rlt_0_1. -Qed. - -(** As R is complete, normal convergence implies that (fn) is simply-uniformly convergent *) -Lemma CVN_R_CVS : - forall fn:nat -> R -> R, - CVN_R fn -> forall x:R, { l:R | Un_cv (fun N:nat => SP fn N x) l }. -Proof. - intros; apply R_complete. - unfold SP; set (An := fun N:nat => fn N x). - change (Cauchy_crit_series An). - apply cauchy_abs. - unfold Cauchy_crit_series; apply CV_Cauchy. - pose proof (Rabs_pos x) as Rabs_pos_x. - unfold CVN_R in X; cut (0 < Rabs x + 1). - 2:{ lra. } - intro; assert (H0 := X (mkposreal _ H)). - unfold CVN_r in H0; elim H0; intros Bn H1. - elim H1; intros l H2. - elim H2; intros. - apply Rseries_CV_comp with Bn. - { intro; split. - { apply Rabs_pos. } - unfold An; apply H4; unfold Boule; simpl; - rewrite Rminus_0_r. - lra. } - exists l. - assert (forall n:nat, 0 <= Bn n). { - intro; apply Rle_trans with (Rabs (An n)). - { apply Rabs_pos. } - unfold An; apply H4; unfold Boule; simpl; - rewrite Rminus_0_r; lra. - } - unfold Un_cv in H3; unfold Un_cv; intros. - elim (H3 _ H6); intros. - exists x0; intros. - replace (sum_f_R0 Bn n) with (sum_f_R0 (fun k:nat => Rabs (Bn k)) n). - - apply H7; assumption. - - apply sum_eq; intros; apply Rabs_right; apply Rle_ge; apply H5. -Qed. - -(* Uniform convergence implies pointwise simple convergence *) -Lemma CVU_cv : forall f g c d, CVU f g c d -> - forall x, Boule c d x -> Un_cv (fun n => f n x) (g x). -Proof. -intros f g c d cvu x bx eps ep; destruct (cvu eps ep) as [N Pn]. - exists N; intros n nN; rewrite Rdist_sym; apply Pn; assumption. -Qed. - -(* convergence is preserved through extensional equality *) -Lemma CVU_ext_lim : - forall f g1 g2 c d, CVU f g1 c d -> (forall x, Boule c d x -> g1 x = g2 x) -> - CVU f g2 c d. -Proof. -intros f g1 g2 c d cvu q eps ep; destruct (cvu _ ep) as [N Pn]. -exists N; intros; rewrite <- q; auto. -Qed. - -(* When a sequence of derivable functions converge pointwise towards - a function g, with the derivatives converging uniformly towards - a function g', then the function g' is the derivative of g. *) - -Lemma CVU_derivable : - forall f f' g g' c d, - CVU f' g' c d -> - (forall x, Boule c d x -> Un_cv (fun n => f n x) (g x)) -> - (forall n x, Boule c d x -> derivable_pt_lim (f n) x (f' n x)) -> - forall x, Boule c d x -> derivable_pt_lim g x (g' x). -Proof. -intros f f' g g' c d cvu cvp dff' x bx. -set (rho_ := - fun n y => - if Req_dec_T y x then - f' n x - else ((f n y - f n x)/ (y - x))). -set (rho := fun y => - if Req_dec_T y x then - g' x - else (g y - g x)/(y - x)). -assert (ctrho : forall n z, Boule c d z -> continuity_pt (rho_ n) z). { - intros n z bz. - destruct (Req_dec_T x z) as [xz | xnz]. - - rewrite <- xz. - intros eps' ep'. - destruct (dff' n x bx eps' ep') as [alp Pa]. - exists (pos alp);split;[apply cond_pos | ]. - intros z'; unfold rho_, D_x, dist, R_met; simpl; intros [[_ xnz'] dxz']. - destruct (Req_dec_T z' x) as [abs | _]. - { case xnz'; symmetry; exact abs. } - destruct (Req_dec_T x x) as [_ | abs];[ | case abs; reflexivity]. - pattern z' at 1; replace z' with (x + (z' - x)) by ring. - apply Pa;[intros h; case xnz'; - replace z' with (z' - x + x) by ring; rewrite h, Rplus_0_l; - reflexivity | exact dxz']. - - destruct (Ball_in_inter c c d d z bz bz) as [delta Pd]. - assert (dz : 0 < Rmin delta (Rabs (z - x))). { - now apply Rmin_glb_lt;[apply cond_pos - | apply Rabs_pos_lt; intros zx0; case xnz; - replace z with (z - x + x) by ring; rewrite zx0, Rplus_0_l]. - } - assert (t' : forall y : R, - Rdist y z < Rmin delta (Rabs (z - x)) -> - (fun z : R => (f n z - f n x) / (z - x)) y = rho_ n y). { - intros y dyz; unfold rho_; destruct (Req_dec_T y x) as [xy | xny]. - - rewrite xy in dyz. - destruct (Rle_dec delta (Rabs (z - x))). - + rewrite Rmin_left, Rdist_sym in dyz; unfold Rdist in dyz; lra. - + rewrite Rmin_right, Rdist_sym in dyz; unfold Rdist in dyz; - [case (Rlt_irrefl _ dyz) |apply Rlt_le, Rnot_le_gt; assumption]. - - reflexivity. - } - apply (continuity_pt_locally_ext (fun z => (f n z - f n x)/(z - x)) - (rho_ n) _ z dz t'); clear t'. - apply continuity_pt_div. - 1:apply continuity_pt_minus. - 1:apply derivable_continuous_pt; eapply exist; apply dff'; assumption. - 1:apply continuity_pt_const; intro; intro; reflexivity. - 1:apply continuity_pt_minus; - [apply derivable_continuous_pt; exists 1; apply derivable_pt_lim_id - | apply continuity_pt_const; intro; reflexivity]. - lra. -} -assert (CVU rho_ rho c d ). { - intros eps ep. - assert (ep8 : 0 < eps/8) by lra. - destruct (cvu _ ep8) as [N Pn1]. - assert (cauchy1 : forall n p, (N <= n)%nat -> (N <= p)%nat -> - forall z, Boule c d z -> Rabs (f' n z - f' p z) < eps/4). { - intros n p nN pN z bz; replace (eps/4) with (eps/8 + eps/8) by field. - rewrite <- Rabs_Ropp. - replace (-(f' n z - f' p z)) with (g' z - f' n z - (g' z - f' p z)) by ring. - apply Rle_lt_trans with (1 := Rabs_triang _ _); rewrite Rabs_Ropp. - apply Rplus_lt_compat; apply Pn1; assumption. - } - assert (step_2 : forall n p, (N <= n)%nat -> (N <= p)%nat -> - forall y, Boule c d y -> x <> y -> - Rabs ((f n y - f n x)/(y - x) - (f p y - f p x)/(y - x)) < eps/4). { - intros n p nN pN y b_y xny. - assert (mm0 : (Rmin x y = x /\ Rmax x y = y) \/ - (Rmin x y = y /\ Rmax x y = x)). { - destruct (Rle_dec x y) as [H | H]. - - rewrite Rmin_left, Rmax_right. - + left; split; reflexivity. - + assumption. - + assumption. - - rewrite Rmin_right, Rmax_left. - + right; split; reflexivity. - + apply Rlt_le, Rnot_le_gt; assumption. - + apply Rlt_le, Rnot_le_gt; assumption. - } - assert (mm : Rmin x y < Rmax x y). { - destruct mm0 as [[q1 q2] | [q1 q2]]; generalize (Rminmax x y); rewrite q1, q2. - - intros h; destruct h;[ assumption| contradiction]. - - intros h; destruct h as [h | h];[assumption | rewrite h in xny; case xny; reflexivity]. - } - assert (dm : forall z, Rmin x y <= z <= Rmax x y -> - derivable_pt_lim (fun x => f n x - f p x) z (f' n z - f' p z)). { - intros z intz; apply derivable_pt_lim_minus. - - apply dff'; apply Boule_convex with (Rmin x y) (Rmax x y); - destruct mm0 as [[q1 q2] | [q1 q2]]; revert intz; rewrite ?q1, ?q2; intros; - try assumption. - - apply dff'; apply Boule_convex with (Rmin x y) (Rmax x y); - destruct mm0 as [[q1 q2] | [q1 q2]]; revert intz; rewrite ?q1, ?q2; intros; - try assumption. - } - - replace ((f n y - f n x) / (y - x) - (f p y - f p x) / (y - x)) - with (((f n y - f p y) - (f n x - f p x))/(y - x)) by - (field; intros yx0; case xny; replace y with (y - x + x) by ring; - rewrite yx0, Rplus_0_l; reflexivity). - destruct (MVT_cor2 (fun x => f n x - f p x) (fun x => f' n x - f' p x) - (Rmin x y) (Rmax x y) mm dm) as [z [Pz inz]]. - destruct mm0 as [[q1 q2] | [q1 q2]]. - - replace ((f n y - f p y - (f n x - f p x))/(y - x)) with - ((f n (Rmax x y) - f p (Rmax x y) - (f n (Rmin x y) - f p (Rmin x y))) - / (Rmax x y - Rmin x y)) by (rewrite q1, q2; reflexivity). - unfold Rdiv; rewrite Pz, Rmult_assoc, Rinv_r, Rmult_1_r. - + apply cauchy1; auto. - apply Boule_convex with (Rmin x y) (Rmax x y); - revert inz; rewrite ?q1, ?q2; intros; - try assumption. - split; apply Rlt_le; tauto. - + rewrite q1, q2; apply Rminus_eq_contra, not_eq_sym; assumption. - - replace ((f n y - f p y - (f n x - f p x))/(y - x)) with - ((f n (Rmax x y) - f p (Rmax x y) - (f n (Rmin x y) - f p (Rmin x y)))/ - (Rmax x y - Rmin x y)). - + unfold Rdiv; rewrite Pz, Rmult_assoc, Rinv_r, Rmult_1_r. - * apply cauchy1; auto. - apply Boule_convex with (Rmin x y) (Rmax x y); - revert inz; rewrite ?q1, ?q2; intros; - try assumption; split; apply Rlt_le; tauto. - * rewrite q1, q2; apply Rminus_eq_contra; assumption. - + rewrite q1, q2; field; split; - apply Rminus_eq_contra;[apply not_eq_sym |]; assumption. - } - assert (unif_ac : - forall n p, (N <= n)%nat -> (N <= p)%nat -> - forall y, Boule c d y -> - Rabs (rho_ n y - rho_ p y) <= eps/2). { - intros n p nN pN y b_y. - destruct (Req_dec_T x y) as [xy | xny]. - - destruct (Ball_in_inter c c d d x bx bx) as [delta Pdelta]. - destruct (ctrho n y b_y _ ep8) as [d' [dp Pd]]. - destruct (ctrho p y b_y _ ep8) as [d2 [dp2 Pd2]]. - assert (mmpos : 0 < (Rmin (Rmin d' d2) delta)/2). { - apply Rmult_lt_0_compat; repeat apply Rmin_glb_lt; try assumption. - { apply cond_pos. } - apply Rinv_0_lt_compat, Rlt_0_2. } - apply Rle_trans with (1 := Rdist_tri _ _ (rho_ n (y + Rmin (Rmin d' d2) delta/2))). - replace (eps/2) with (eps/8 + (eps/4 + eps/8)) by field. - apply Rplus_le_compat. - + rewrite Rdist_sym; apply Rlt_le, Pd;split;[split;[exact I | ] | ]. - * symmetry; apply Rminus_not_eq; rewrite Rplus_comm; unfold Rminus; - rewrite Rplus_assoc, Rplus_opp_r, Rplus_0_r; apply Rgt_not_eq; assumption. - * simpl; unfold Rdist. - unfold Rminus; rewrite (Rplus_comm y), Rplus_assoc, Rplus_opp_r, Rplus_0_r. - rewrite Rabs_pos_eq;[ |apply Rlt_le; assumption ]. - apply Rlt_le_trans with (Rmin (Rmin d' d2) delta);[lra | ]. - apply Rle_trans with (Rmin d' d2); apply Rmin_l. - + apply Rle_trans with (1 := Rdist_tri _ _ (rho_ p (y + Rmin (Rmin d' d2) delta/2))). - apply Rplus_le_compat. - * apply Rlt_le. - replace (rho_ n (y + Rmin (Rmin d' d2) delta / 2)) with - ((f n (y + Rmin (Rmin d' d2) delta / 2) - f n x)/ - ((y + Rmin (Rmin d' d2) delta / 2) - x)). - 1:replace (rho_ p (y + Rmin (Rmin d' d2) delta / 2)) with - ((f p (y + Rmin (Rmin d' d2) delta / 2) - f p x)/ - ((y + Rmin (Rmin d' d2) delta / 2) - x)). - 2,3:unfold rho_; - destruct (Req_dec_T (y + Rmin (Rmin d' d2) delta / 2) x) as [ymx | ymnx]; - [case (RIneq.Rle_not_lt _ _ (Req_le _ _ ymx)); lra - |reflexivity]. - apply step_2; auto; try lra. - assert (0 < pos delta) by (apply cond_pos). - apply Boule_convex with y (y + delta/2). - -- assumption. - -- destruct (Pdelta (y + delta/2)); auto. - rewrite xy; unfold Boule; rewrite Rabs_pos_eq; try lra; auto. - -- split; try lra. - apply Rplus_le_compat_l, Rmult_le_compat_r;[ | apply Rmin_r]. - now apply Rlt_le, Rinv_0_lt_compat, Rlt_0_2. - - * apply Rlt_le, Pd2; split;[split;[exact I | apply Rlt_not_eq; lra] | ]. - simpl; unfold Rdist. - unfold Rminus; rewrite (Rplus_comm y), Rplus_assoc, Rplus_opp_r, Rplus_0_r. - rewrite Rabs_pos_eq;[ | lra]. - apply Rlt_le_trans with (Rmin (Rmin d' d2) delta); [lra |]. - apply Rle_trans with (Rmin d' d2). - -- solve[apply Rmin_l]. - -- solve[apply Rmin_r]. - - apply Rlt_le, Rlt_le_trans with (eps/4);[ | lra]. - unfold rho_; destruct (Req_dec_T y x); solve[auto]. - } - assert (unif_ac' : forall p, (N <= p)%nat -> - forall y, Boule c d y -> Rabs (rho y - rho_ p y) < eps). { - assert (cvrho : forall y, Boule c d y -> Un_cv (fun n => rho_ n y) (rho y)). { - intros y b_y; unfold rho_, rho; destruct (Req_dec_T y x). - - intros eps' ep'; destruct (cvu eps' ep') as [N2 Pn2]. - exists N2; intros n nN2; rewrite Rdist_sym; apply Pn2; assumption. - - apply CV_mult. - + apply CV_minus. - * apply cvp; assumption. - * apply cvp; assumption. - + intros eps' ep'; simpl; exists 0%nat; intros; rewrite Rdist_eq; assumption. - } - intros p pN y b_y. - replace eps with (eps/2 + eps/2) by field. - assert (ep2 : 0 < eps/2) by lra. - destruct (cvrho y b_y _ ep2) as [N2 Pn2]. - apply Rle_lt_trans with (1 := Rdist_tri _ _ (rho_ (max N N2) y)). - apply Rplus_lt_le_compat. - - solve[rewrite Rdist_sym; apply Pn2, Nat.le_max_r]. - - apply unif_ac; auto; solve [apply Nat.le_max_l]. - } - exists N; intros; apply unif_ac'; solve[auto]. -} -intros eps ep. -destruct (CVU_continuity _ _ _ _ H ctrho x bx eps ep) as [delta [dp Pd]]. -exists (mkposreal _ dp); intros h hn0 dh. -replace ((g (x + h) - g x) / h) with (rho (x + h)). -- replace (g' x) with (rho x). - + apply Pd; unfold D_x, no_cond;split;[split;[solve[auto] | ] | ]. - * intros xxh; case hn0; replace h with (x + h - x) by ring; rewrite <- xxh; ring. - * simpl; unfold Rdist; replace (x + h - x) with h by ring; exact dh. - + unfold rho; destruct (Req_dec_T x x) as [ _ | abs];[ | case abs]; reflexivity. -- unfold rho; destruct (Req_dec_T (x + h) x) as [abs | _];[ | ]. - + case hn0; replace h with (x + h - x) by ring; rewrite abs; ring. - + replace (x + h - x) with h by ring; reflexivity. -Qed. diff --git a/stdlib/theories/Reals/PartSum.v b/stdlib/theories/Reals/PartSum.v deleted file mode 100644 index 202f8e0faf00..000000000000 --- a/stdlib/theories/Reals/PartSum.v +++ /dev/null @@ -1,623 +0,0 @@ - -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* R) (N:nat), - (forall n:nat, (n <= N)%nat -> 0 < An n) -> 0 < sum_f_R0 An N. -Proof. - intros; induction N as [| N HrecN]. - - simpl; apply H; apply le_n. - - simpl; apply Rplus_lt_0_compat. - + apply HrecN; intros; apply H; apply le_S; assumption. - + apply H; apply le_n. -Qed. - -(* Chasles' relation *) -Lemma tech2 : - forall (An:nat -> R) (m n:nat), - (m < n)%nat -> - sum_f_R0 An n = - sum_f_R0 An m + sum_f_R0 (fun i:nat => An (S m + i)%nat) (n - S m). -Proof. - intros; induction n as [| n Hrecn]. - - elim (Nat.nlt_0_r _ H). - - cut ((m < n)%nat \/ m = n). - + intro; elim H0; intro. - * replace (sum_f_R0 An (S n)) with (sum_f_R0 An n + An (S n)); - [ idtac | reflexivity ]. - replace (S n - S m)%nat with (S (n - S m)). - -- replace (sum_f_R0 (fun i:nat => An (S m + i)%nat) (S (n - S m))) with - (sum_f_R0 (fun i:nat => An (S m + i)%nat) (n - S m) + - An (S m + S (n - S m))%nat); [ idtac | reflexivity ]. - replace (S m + S (n - S m))%nat with (S n). - ++ rewrite (Hrecn H1). - ring. - ++ apply INR_eq; rewrite S_INR; rewrite plus_INR; do 2 rewrite S_INR; - rewrite minus_INR. - ** rewrite S_INR; ring. - ** apply Nat.le_succ_l; assumption. - -- apply INR_eq; rewrite S_INR; repeat rewrite minus_INR. - ++ repeat rewrite S_INR; ring. - ++ apply le_n_S; apply Nat.lt_le_incl; assumption. - ++ apply Nat.le_succ_l; assumption. - * rewrite H1; rewrite Nat.sub_diag; simpl. - replace (n + 0)%nat with n; [ reflexivity | ring ]. - + inversion H. - * right; reflexivity. - * left; apply Nat.lt_le_trans with (S m); [ apply Nat.lt_succ_diag_r | assumption ]. -Qed. - -(* Sum of geometric sequences *) -Lemma tech3 : - forall (k:R) (N:nat), - k <> 1 -> sum_f_R0 (fun i:nat => k ^ i) N = (1 - k ^ S N) / (1 - k). -Proof. - intros; cut (1 - k <> 0). - - intro; induction N as [| N HrecN]. - + simpl; rewrite Rmult_1_r; unfold Rdiv; rewrite Rinv_r. - * reflexivity. - * apply H0. - + replace (sum_f_R0 (fun i:nat => k ^ i) (S N)) with - (sum_f_R0 (fun i:nat => k ^ i) N + k ^ S N); [ idtac | reflexivity ]; - rewrite HrecN; - replace ((1 - k ^ S N) / (1 - k) + k ^ S N) with - ((1 - k ^ S N + (1 - k) * k ^ S N) / (1 - k)). - * apply Rmult_eq_reg_l with (1 - k). - -- unfold Rdiv; do 2 rewrite <- (Rmult_comm (/ (1 - k))); - repeat rewrite <- Rmult_assoc; rewrite Rinv_r; - [ do 2 rewrite Rmult_1_l; simpl; ring | apply H0 ]. - -- apply H0. - * unfold Rdiv; rewrite Rmult_plus_distr_r; rewrite (Rmult_comm (1 - k)); - repeat rewrite Rmult_assoc; rewrite Rinv_r. - -- rewrite Rmult_1_r; reflexivity. - -- apply H0. - - apply Rminus_eq_contra; red; intro; elim H; symmetry ; - assumption. -Qed. - -Lemma tech4 : - forall (An:nat -> R) (k:R) (N:nat), - 0 <= k -> (forall i:nat, An (S i) < k * An i) -> An N <= An 0%nat * k ^ N. -Proof. - intros; induction N as [| N HrecN]. - - simpl; right; ring. - - apply Rle_trans with (k * An N). - + left; apply (H0 N). - + replace (S N) with (N + 1)%nat; [ idtac | ring ]. - rewrite pow_add; simpl; rewrite Rmult_1_r; - replace (An 0%nat * (k ^ N * k)) with (k * (An 0%nat * k ^ N)); - [ idtac | ring ]; apply Rmult_le_compat_l. - * assumption. - * apply HrecN. -Qed. - -Lemma tech5 : - forall (An:nat -> R) (N:nat), sum_f_R0 An (S N) = sum_f_R0 An N + An (S N). -Proof. - intros; reflexivity. -Qed. - -Lemma tech6 : - forall (An:nat -> R) (k:R) (N:nat), - 0 <= k -> - (forall i:nat, An (S i) < k * An i) -> - sum_f_R0 An N <= An 0%nat * sum_f_R0 (fun i:nat => k ^ i) N. -Proof. - intros; induction N as [| N HrecN]. - - simpl; right; ring. - - apply Rle_trans with (An 0%nat * sum_f_R0 (fun i:nat => k ^ i) N + An (S N)). - + rewrite tech5; do 2 rewrite <- (Rplus_comm (An (S N))); - apply Rplus_le_compat_l. - apply HrecN. - + rewrite tech5; rewrite Rmult_plus_distr_l; apply Rplus_le_compat_l. - apply tech4; assumption. -Qed. - -Lemma tech7 : forall r1 r2:R, r1 <> 0 -> r2 <> 0 -> r1 <> r2 -> / r1 <> / r2. -Proof. - intros; red; intro. - assert (H3 := Rmult_eq_compat_l r1 _ _ H2). - rewrite Rinv_r in H3; [ idtac | assumption ]. - assert (H4 := Rmult_eq_compat_l r2 _ _ H3). - rewrite Rmult_1_r in H4; rewrite <- Rmult_assoc in H4. - rewrite Rmult_inv_r_id_m in H4; [ idtac | assumption ]. - elim H1; symmetry ; assumption. -Qed. - -Lemma tech11 : - forall (An Bn Cn:nat -> R) (N:nat), - (forall i:nat, An i = Bn i - Cn i) -> - sum_f_R0 An N = sum_f_R0 Bn N - sum_f_R0 Cn N. -Proof. - intros; induction N as [| N HrecN]. - - simpl; apply H. - - do 3 rewrite tech5; rewrite HrecN; rewrite (H (S N)); ring. -Qed. - -Lemma tech12 : - forall (An:nat -> R) (x l:R), - Un_cv (fun N:nat => sum_f_R0 (fun i:nat => An i * x ^ i) N) l -> - Pser An x l. -Proof. - intros; unfold Pser; unfold infinite_sum; unfold Un_cv in H; - assumption. -Qed. - -Lemma scal_sum : - forall (An:nat -> R) (N:nat) (x:R), - x * sum_f_R0 An N = sum_f_R0 (fun i:nat => An i * x) N. -Proof. - intros; induction N as [| N HrecN]. - - simpl; ring. - - do 2 rewrite tech5. - rewrite Rmult_plus_distr_l; rewrite <- HrecN; ring. -Qed. - -Lemma decomp_sum : - forall (An:nat -> R) (N:nat), - (0 < N)%nat -> - sum_f_R0 An N = An 0%nat + sum_f_R0 (fun i:nat => An (S i)) (pred N). -Proof. - intros; induction N as [| N HrecN]. - - elim (Nat.lt_irrefl _ H). - - cut ((0 < N)%nat \/ N = 0%nat). - + intro; elim H0; intro. - * cut (S (pred N) = pred (S N)). - -- intro; rewrite <- H2. - do 2 rewrite tech5. - replace (S (S (pred N))) with (S N). - ++ rewrite (HrecN H1); ring. - ++ rewrite H2; simpl; reflexivity. - -- destruct (O_or_S N) as [(m,<-)|<-]. - ++ simpl; reflexivity. - ++ elim (Nat.lt_irrefl _ H1). - * rewrite H1; simpl; reflexivity. - + inversion H. - * right; reflexivity. - * left; apply Nat.lt_le_trans with 1%nat; [ apply Nat.lt_0_succ | assumption ]. -Qed. - -Lemma plus_sum : - forall (An Bn:nat -> R) (N:nat), - sum_f_R0 (fun i:nat => An i + Bn i) N = sum_f_R0 An N + sum_f_R0 Bn N. -Proof. - intros; induction N as [| N HrecN]. - - simpl; ring. - - do 3 rewrite tech5; rewrite HrecN; ring. -Qed. - -Lemma sum_eq : - forall (An Bn:nat -> R) (N:nat), - (forall i:nat, (i <= N)%nat -> An i = Bn i) -> - sum_f_R0 An N = sum_f_R0 Bn N. -Proof. - intros; induction N as [| N HrecN]. - - simpl; apply H; apply le_n. - - do 2 rewrite tech5; rewrite HrecN. - + rewrite (H (S N)); [ reflexivity | apply le_n ]. - + intros; apply H; apply Nat.le_trans with N; [ assumption | apply Nat.le_succ_diag_r ]. -Qed. - -(* Unicity of the limit defined by convergent series *) -Lemma uniqueness_sum : - forall (An:nat -> R) (l1 l2:R), - infinite_sum An l1 -> infinite_sum An l2 -> l1 = l2. -Proof. - unfold infinite_sum; intros. - case (Req_dec l1 l2); intro. - - assumption. - - cut (0 < Rabs ((l1 - l2) / 2)); [ intro | apply Rabs_pos_lt ]. - + elim (H (Rabs ((l1 - l2) / 2)) H2); intros. - elim (H0 (Rabs ((l1 - l2) / 2)) H2); intros. - set (N := max x0 x); cut (N >= x0)%nat. - * cut (N >= x)%nat. - -- intros; assert (H7 := H3 N H5); assert (H8 := H4 N H6). - cut (Rabs (l1 - l2) <= Rdist (sum_f_R0 An N) l1 + Rdist (sum_f_R0 An N) l2). - ++ intro; assert (H10 := Rplus_lt_compat _ _ _ _ H7 H8); - assert (H11 := Rle_lt_trans _ _ _ H9 H10); unfold Rdiv in H11; - rewrite Rabs_mult in H11. - cut (Rabs (/ 2) = / 2). - ** intro; rewrite H12 in H11; assert (H13 := Rplus_half_diag); unfold Rdiv in H13; - rewrite H13 in H11. - elim (Rlt_irrefl _ H11). - ** apply Rabs_right; left; change (0 < / 2); apply Rinv_0_lt_compat; - cut (0%nat <> 2%nat); - [ intro H20; generalize (lt_INR_0 2 (proj1 (Nat.neq_0_lt_0 2) (Nat.neq_sym 0 2 H20))); unfold INR; - intro; assumption - | discriminate ]. - ++ unfold Rdist; rewrite <- (Rabs_Ropp (sum_f_R0 An N - l1)); - rewrite Ropp_minus_distr. - replace (l1 - l2) with (l1 - sum_f_R0 An N + (sum_f_R0 An N - l2)); - [ idtac | ring ]. - apply Rabs_triang. - -- unfold ge; unfold N; apply Nat.le_max_r. - * unfold ge; unfold N; apply Nat.le_max_l. - + unfold Rdiv; apply prod_neq_R0. - * apply Rminus_eq_contra; assumption. - * apply Rinv_neq_0_compat; discrR. -Qed. - -Lemma minus_sum : - forall (An Bn:nat -> R) (N:nat), - sum_f_R0 (fun i:nat => An i - Bn i) N = sum_f_R0 An N - sum_f_R0 Bn N. -Proof. - intros; induction N as [| N HrecN]. - - simpl; ring. - - do 3 rewrite tech5; rewrite HrecN; ring. -Qed. - -Lemma sum_decomposition : - forall (An:nat -> R) (N:nat), - sum_f_R0 (fun l:nat => An (2 * l)%nat) (S N) + - sum_f_R0 (fun l:nat => An (S (2 * l))) N = sum_f_R0 An (2 * S N). -Proof. - intros. - induction N as [| N HrecN]. - - simpl; ring. - - rewrite tech5. - rewrite (tech5 (fun l:nat => An (S (2 * l))) N). - replace (2 * S (S N))%nat with (S (S (2 * S N))). - + rewrite (tech5 An (S (2 * S N))). - rewrite (tech5 An (2 * S N)). - rewrite <- HrecN. - ring. - + ring. -Qed. - -Lemma sum_Rle : - forall (An Bn:nat -> R) (N:nat), - (forall n:nat, (n <= N)%nat -> An n <= Bn n) -> - sum_f_R0 An N <= sum_f_R0 Bn N. -Proof. - intros. - induction N as [| N HrecN]. - - simpl; apply H. - apply le_n. - - do 2 rewrite tech5. - apply Rle_trans with (sum_f_R0 An N + Bn (S N)). - + apply Rplus_le_compat_l. - apply H. - apply le_n. - + do 2 rewrite <- (Rplus_comm (Bn (S N))). - apply Rplus_le_compat_l. - apply HrecN. - intros; apply H. - apply Nat.le_trans with N; [ assumption | apply Nat.le_succ_diag_r ]. -Qed. - -Lemma Rsum_abs : - forall (An:nat -> R) (N:nat), - Rabs (sum_f_R0 An N) <= sum_f_R0 (fun l:nat => Rabs (An l)) N. -Proof. - intros. - induction N as [| N HrecN]. - - simpl. - right; reflexivity. - - do 2 rewrite tech5. - apply Rle_trans with (Rabs (sum_f_R0 An N) + Rabs (An (S N))). - + apply Rabs_triang. - + do 2 rewrite <- (Rplus_comm (Rabs (An (S N)))). - apply Rplus_le_compat_l. - apply HrecN. -Qed. - -Lemma sum_cte : - forall (x:R) (N:nat), sum_f_R0 (fun _:nat => x) N = x * INR (S N). -Proof. - intros. - induction N as [| N HrecN]. - - simpl; ring. - - rewrite tech5. - rewrite HrecN; repeat rewrite S_INR; ring. -Qed. - -(**********) -Lemma sum_growing : - forall (An Bn:nat -> R) (N:nat), - (forall n:nat, An n <= Bn n) -> sum_f_R0 An N <= sum_f_R0 Bn N. -Proof. - intros. - induction N as [| N HrecN]. - - simpl; apply H. - - do 2 rewrite tech5. - apply Rle_trans with (sum_f_R0 An N + Bn (S N)). - + apply Rplus_le_compat_l; apply H. - + do 2 rewrite <- (Rplus_comm (Bn (S N))). - apply Rplus_le_compat_l; apply HrecN. -Qed. - -(**********) -Lemma Rabs_triang_gen : - forall (An:nat -> R) (N:nat), - Rabs (sum_f_R0 An N) <= sum_f_R0 (fun i:nat => Rabs (An i)) N. -Proof. - intros. - induction N as [| N HrecN]. - - simpl. - right; reflexivity. - - do 2 rewrite tech5. - apply Rle_trans with (Rabs (sum_f_R0 An N) + Rabs (An (S N))). - + apply Rabs_triang. - + do 2 rewrite <- (Rplus_comm (Rabs (An (S N)))). - apply Rplus_le_compat_l; apply HrecN. -Qed. - -(**********) -Lemma cond_pos_sum : - forall (An:nat -> R) (N:nat), - (forall n:nat, 0 <= An n) -> 0 <= sum_f_R0 An N. -Proof. - intros. - induction N as [| N HrecN]. - - simpl; apply H. - - rewrite tech5. - apply Rplus_le_le_0_compat. - + apply HrecN. - + apply H. -Qed. - -(* Cauchy's criterion for series *) -Definition Cauchy_crit_series (An:nat -> R) : Prop := - Cauchy_crit (fun N:nat => sum_f_R0 An N). - -(* If (|An|) satisfies the Cauchy's criterion for series, then (An) too *) -Lemma cauchy_abs : - forall An:nat -> R, - Cauchy_crit_series (fun i:nat => Rabs (An i)) -> Cauchy_crit_series An. -Proof. - unfold Cauchy_crit_series; unfold Cauchy_crit. - intros. - elim (H eps H0); intros. - exists x. - intros. - cut - (Rdist (sum_f_R0 An n) (sum_f_R0 An m) <= - Rdist (sum_f_R0 (fun i:nat => Rabs (An i)) n) - (sum_f_R0 (fun i:nat => Rabs (An i)) m)). - - intro. - apply Rle_lt_trans with - (Rdist (sum_f_R0 (fun i:nat => Rabs (An i)) n) - (sum_f_R0 (fun i:nat => Rabs (An i)) m)). - + assumption. - + apply H1; assumption. - - destruct (lt_eq_lt_dec n m) as [[ | -> ]|]. - + rewrite (tech2 An n m); [ idtac | assumption ]. - rewrite (tech2 (fun i:nat => Rabs (An i)) n m); [ idtac | assumption ]. - unfold Rdist. - unfold Rminus. - do 2 rewrite Ropp_plus_distr. - do 2 rewrite <- Rplus_assoc. - do 2 rewrite Rplus_opp_r. - do 2 rewrite Rplus_0_l. - do 2 rewrite Rabs_Ropp. - rewrite - (Rabs_right (sum_f_R0 (fun i:nat => Rabs (An (S n + i)%nat)) (m - S n))) - . - * set (Bn := fun i:nat => An (S n + i)%nat). - replace (fun i:nat => Rabs (An (S n + i)%nat)) with - (fun i:nat => Rabs (Bn i)). - -- apply Rabs_triang_gen. - -- unfold Bn; reflexivity. - * apply Rle_ge. - apply cond_pos_sum. - intro; apply Rabs_pos. - + unfold Rdist. - unfold Rminus; do 2 rewrite Rplus_opp_r. - rewrite Rabs_R0; right; reflexivity. - + rewrite (tech2 An m n); [ idtac | assumption ]. - rewrite (tech2 (fun i:nat => Rabs (An i)) m n); [ idtac | assumption ]. - unfold Rdist. - unfold Rminus. - do 2 rewrite Rplus_assoc. - rewrite (Rplus_comm (sum_f_R0 An m)). - rewrite (Rplus_comm (sum_f_R0 (fun i:nat => Rabs (An i)) m)). - do 2 rewrite Rplus_assoc. - do 2 rewrite Rplus_opp_l. - do 2 rewrite Rplus_0_r. - rewrite - (Rabs_right (sum_f_R0 (fun i:nat => Rabs (An (S m + i)%nat)) (n - S m))) - . - * set (Bn := fun i:nat => An (S m + i)%nat). - replace (fun i:nat => Rabs (An (S m + i)%nat)) with - (fun i:nat => Rabs (Bn i)). - -- apply Rabs_triang_gen. - -- unfold Bn; reflexivity. - * apply Rle_ge. - apply cond_pos_sum. - intro; apply Rabs_pos. -Qed. - -(**********) -Lemma cv_cauchy_1 : - forall An:nat -> R, - { l:R | Un_cv (fun N:nat => sum_f_R0 An N) l } -> - Cauchy_crit_series An. -Proof. - intros An (x,p). - unfold Un_cv in p. - unfold Cauchy_crit_series; unfold Cauchy_crit. - intros. - cut (0 < eps / 2). - - intro. - elim (p (eps / 2) H0); intros. - exists x0. - intros. - apply Rle_lt_trans with (Rdist (sum_f_R0 An n) x + Rdist (sum_f_R0 An m) x). - + unfold Rdist. - replace (sum_f_R0 An n - sum_f_R0 An m) with - (sum_f_R0 An n - x + - (sum_f_R0 An m - x)); [ idtac | ring ]. - rewrite <- (Rabs_Ropp (sum_f_R0 An m - x)). - apply Rabs_triang. - + apply Rlt_le_trans with (eps / 2 + eps / 2). - * apply Rplus_lt_compat. - -- apply H1; assumption. - -- apply H1; assumption. - * right; apply Rplus_half_diag. - - unfold Rdiv; apply Rmult_lt_0_compat; - [ assumption | apply Rinv_0_lt_compat; prove_sup0 ]. -Qed. - -Lemma cv_cauchy_2 : - forall An:nat -> R, - Cauchy_crit_series An -> - { l:R | Un_cv (fun N:nat => sum_f_R0 An N) l }. -Proof. - intros. - apply R_complete. - unfold Cauchy_crit_series in H. - exact H. -Qed. - -(**********) -Lemma sum_eq_R0 : - forall (An:nat -> R) (N:nat), - (forall n:nat, (n <= N)%nat -> An n = 0) -> sum_f_R0 An N = 0. -Proof. - intros; induction N as [| N HrecN]. - - simpl; apply H; apply le_n. - - rewrite tech5; rewrite HrecN; - [ rewrite Rplus_0_l; apply H; apply le_n - | intros; apply H; apply Nat.le_trans with N; [ assumption | apply Nat.le_succ_diag_r ] ]. -Qed. - -Definition SP (fn:nat -> R -> R) (N:nat) (x:R) : R := - sum_f_R0 (fun k:nat => fn k x) N. - -(**********) -Lemma sum_incr : - forall (An:nat -> R) (N:nat) (l:R), - Un_cv (fun n:nat => sum_f_R0 An n) l -> - (forall n:nat, 0 <= An n) -> sum_f_R0 An N <= l. -Proof. - intros; destruct (total_order_T (sum_f_R0 An N) l) as [[Hlt|Heq]|Hgt]. - - left; apply Hlt. - - right; apply Heq. - - cut (Un_growing (fun n:nat => sum_f_R0 An n)). - + intro; set (l1 := sum_f_R0 An N) in Hgt. - unfold Un_cv in H; cut (0 < l1 - l). - * intro; elim (H _ H2); intros. - set (N0 := max x N); cut (N0 >= x)%nat. - -- intro; assert (H5 := H3 N0 H4). - cut (l1 <= sum_f_R0 An N0). - ++ intro; unfold Rdist in H5; rewrite Rabs_right in H5. - ** cut (sum_f_R0 An N0 < l1). - { intro; elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ H7 H6)). } - apply Rplus_lt_reg_l with (- l). - do 2 rewrite (Rplus_comm (- l)). - apply H5. - ** apply Rle_ge; apply Rplus_le_reg_l with l. - rewrite Rplus_0_r; replace (l + (sum_f_R0 An N0 - l)) with (sum_f_R0 An N0); - [ idtac | ring ]; apply Rle_trans with l1. - { left; apply Hgt. } - apply H6. - ++ unfold l1; apply Rge_le; - apply (growing_prop (fun k:nat => sum_f_R0 An k)). - ** apply H1. - ** unfold ge, N0; apply Nat.le_max_r. - -- unfold ge, N0; apply Nat.le_max_l. - * apply Rplus_lt_reg_l with l; rewrite Rplus_0_r; - replace (l + (l1 - l)) with l1; [ apply Hgt | ring ]. - + unfold Un_growing; intro; simpl; - pattern (sum_f_R0 An n) at 1; rewrite <- Rplus_0_r; - apply Rplus_le_compat_l; apply H0. -Qed. - -(**********) -Lemma sum_cv_maj : - forall (An:nat -> R) (fn:nat -> R -> R) (x l1 l2:R), - Un_cv (fun n:nat => SP fn n x) l1 -> - Un_cv (fun n:nat => sum_f_R0 An n) l2 -> - (forall n:nat, Rabs (fn n x) <= An n) -> Rabs l1 <= l2. -Proof. - intros; destruct (total_order_T (Rabs l1) l2) as [[Hlt|Heq]|Hgt]. - - left; apply Hlt. - - right; apply Heq. - - cut (forall n0:nat, Rabs (SP fn n0 x) <= sum_f_R0 An n0). - { intro; cut (0 < (Rabs l1 - l2) / 2). - - intro; unfold Un_cv in H, H0. - elim (H _ H3); intros Na H4. - elim (H0 _ H3); intros Nb H5. - set (N := max Na Nb). - unfold Rdist in H4, H5. - cut (Rabs (sum_f_R0 An N - l2) < (Rabs l1 - l2) / 2). - 1:intro; cut (Rabs (Rabs l1 - Rabs (SP fn N x)) < (Rabs l1 - l2) / 2). - 1:intro; cut (sum_f_R0 An N < (Rabs l1 + l2) / 2). - 1:intro; cut ((Rabs l1 + l2) / 2 < Rabs (SP fn N x)). - 1:intro; cut (sum_f_R0 An N < Rabs (SP fn N x)). - 1:intro; assert (H11 := H2 N). - + elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H11 H10)). - + apply Rlt_trans with ((Rabs l1 + l2) / 2); assumption. - + destruct (Rcase_abs (Rabs l1 - Rabs (SP fn N x))) as [Hlt|Hge]. - * apply Rlt_trans with (Rabs l1). - -- apply Rmult_lt_reg_l with 2. - ++ prove_sup0. - ++ unfold Rdiv; rewrite (Rmult_comm 2); rewrite Rmult_assoc; - rewrite Rinv_l. - ** rewrite Rmult_1_r; rewrite <-Rplus_diag; apply Rplus_lt_compat_l; apply Hgt. - ** discrR. - -- apply (Rminus_lt _ _ Hlt). - * rewrite (Rabs_right _ Hge) in H7. - apply Rplus_lt_reg_l with ((Rabs l1 - l2) / 2 - Rabs (SP fn N x)). - replace ((Rabs l1 - l2) / 2 - Rabs (SP fn N x) + (Rabs l1 + l2) / 2) with - (Rabs l1 - Rabs (SP fn N x)). - -- unfold Rminus; rewrite Rplus_assoc; rewrite Rplus_opp_l; - rewrite Rplus_0_r; apply H7. - -- unfold Rdiv; rewrite Rmult_plus_distr_r; - rewrite <- (Rmult_comm (/ 2)); rewrite Rmult_minus_distr_l; - repeat rewrite (Rmult_comm (/ 2)); pattern (Rabs l1) at 1; - rewrite <-Rplus_half_diag; unfold Rdiv in |- *; ring. - + destruct (Rcase_abs (sum_f_R0 An N - l2)) as [Hlt|Hge]. - * apply Rlt_trans with l2. - -- apply (Rminus_lt _ _ Hlt). - -- apply Rmult_lt_reg_l with 2. - ++ prove_sup0. - ++ rewrite <-(Rplus_diag l2); unfold Rdiv; rewrite (Rmult_comm 2); - rewrite Rmult_assoc; rewrite Rinv_l. - ** rewrite Rmult_1_r; rewrite (Rplus_comm (Rabs l1)); apply Rplus_lt_compat_l; - apply Hgt. - ** discrR. - * rewrite (Rabs_right _ Hge) in H6; apply Rplus_lt_reg_l with (- l2). - replace (- l2 + (Rabs l1 + l2) / 2) with ((Rabs l1 - l2) / 2). - -- rewrite Rplus_comm; apply H6. - -- unfold Rdiv; rewrite <- (Rmult_comm (/ 2)); - rewrite Rmult_minus_distr_l; rewrite Rmult_plus_distr_r; - pattern l2 at 2; rewrite <-Rplus_half_diag; - repeat rewrite (Rmult_comm (/ 2)); rewrite Ropp_plus_distr; - unfold Rdiv; ring. - + apply Rle_lt_trans with (Rabs (SP fn N x - l1)). - * rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; apply Rabs_triang_inv2. - * apply H4; unfold ge, N; apply Nat.le_max_l. - + apply H5; unfold ge, N; apply Nat.le_max_r. - - unfold Rdiv; apply Rmult_lt_0_compat. - + apply Rplus_lt_reg_l with l2. - rewrite Rplus_0_r; replace (l2 + (Rabs l1 - l2)) with (Rabs l1); - [ apply Hgt | ring ]. - + apply Rinv_0_lt_compat; prove_sup0. - } - intros; induction n0 as [| n0 Hrecn0]. - + unfold SP; simpl; apply H1. - + unfold SP; simpl. - apply Rle_trans with - (Rabs (sum_f_R0 (fun k:nat => fn k x) n0) + Rabs (fn (S n0) x)). - * apply Rabs_triang. - * apply Rle_trans with (sum_f_R0 An n0 + Rabs (fn (S n0) x)). - -- do 2 rewrite <- (Rplus_comm (Rabs (fn (S n0) x))). - apply Rplus_le_compat_l; apply Hrecn0. - -- apply Rplus_le_compat_l; apply H1. -Qed. diff --git a/stdlib/theories/Reals/RIneq.v b/stdlib/theories/Reals/RIneq.v deleted file mode 100644 index eaeebc28a9d7..000000000000 --- a/stdlib/theories/Reals/RIneq.v +++ /dev/null @@ -1,2865 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* ], [<=] and [>=] - - injective morphisms: - - [INR : nat -> R] - - [IPR : positive -> R] - - [IZR : Z -> R] - - All those lemmas are proved using a set of 17 "primitive" lemmas in - [Raxioms.v] (plus the convenient choice that the inverse of 0 is 0 in - [Rdefinitions.v]). These "primitive" lemmas are: - - [Rplus_comm], [Rplus_assoc], [Rplus_0_l], [Rplus_opp_l] - - [Rmult_comm], [Rmult_assoc], [Rmult_1_l], [Rinv_l] - - [Rmult_plus_distr_l], [R1_neq_R0] - - [Rlt_trans], [Rlt_asym], [Rplus_lt_compat_l], [Rmult_lt_compat_l] - - [total_order_T] - - [completeness], [archimed] - - This makes this file independent of the actual construction of the real - numbers, since these 17 axioms characterize, up to isomorphism, the ordered - field of real numbers. - *) - -Require Import RelationClasses. -Require Export Raxioms. -Require Import Rpow_def. -Require Import ZArith. -Require Export ZArithRing. -Require Export RealField. - -Local Open Scope Z_scope. -Local Open Scope R_scope. - -(*********************************************************) -(** ** Relation between orders and equality *) -(*********************************************************) - -(** Reflexivity of the large orders *) - -Lemma Rle_refl : forall r, r <= r. -Proof. now intros r; right. Qed. -#[global] -Hint Immediate Rle_refl: rorders. - -#[export] Instance Rle_Reflexive : Reflexive Rle | 10 := Rle_refl. - -Lemma Rge_refl : forall r, r >= r. -Proof. now intros r; right. Qed. -#[global] -Hint Immediate Rge_refl: rorders. - -#[export] Instance Rge_Reflexive : Reflexive Rge | 10 := Rge_refl. - -Lemma Req_le : forall r1 r2, r1 = r2 -> r1 <= r2. -Proof. now intros r1 r2 H; right. Qed. -#[global] -Hint Immediate Req_le: real. - -Lemma Req_ge : forall r1 r2, r1 = r2 -> r1 >= r2. -Proof. now intros r1 r2 H; right. Qed. -#[global] -Hint Immediate Req_ge: real. - -(** Irreflexivity of the strict orders *) - -Lemma Rlt_irrefl : forall r, ~ r < r. -Proof. intros r H; now apply (Rlt_asym r r). Qed. -#[global] -Hint Resolve Rlt_irrefl: real. - -#[export] Instance Rlt_Irreflexive : Irreflexive Rlt | 10 := Rlt_irrefl. - -Lemma Rgt_irrefl : forall r, ~ r > r. -Proof. exact Rlt_irrefl. Qed. - -#[export] Instance Rgt_Irreflexive : Irreflexive Rgt | 10 := Rgt_irrefl. - -Lemma Rlt_not_eq : forall r1 r2, r1 < r2 -> r1 <> r2. -Proof. now intros r1 r2 H H0; apply (Rlt_irrefl r1); rewrite H0 at 2. Qed. - -Lemma Rgt_not_eq : forall r1 r2, r1 > r2 -> r1 <> r2. -Proof. now intros r1 r2 H1 H2%eq_sym; apply (Rlt_not_eq r2 r1). Qed. - -Lemma Rlt_dichotomy_converse : forall r1 r2, r1 < r2 \/ r1 > r2 -> r1 <> r2. -Proof. - intros r1 r2 [Hlt | Hgt]. - - now apply Rlt_not_eq. - - now apply Rgt_not_eq. -Qed. -#[global] -Hint Resolve Rlt_dichotomy_converse: real. - -(** Reasoning by case on equality and order *) - -(* We should use Rtotal_order in proofs and total_order_T in definitions. *) -Lemma Rtotal_order : forall r1 r2, r1 < r2 \/ r1 = r2 \/ r1 > r2. -Proof. - intros r1 r2; destruct (total_order_T r1 r2) as [[Hlt | Heq] | Hgt]. - - now left. - - now right; left. - - now right; right. -Qed. - -Lemma Req_dec : forall r1 r2:R, r1 = r2 \/ r1 <> r2. -Proof. - intros r1 r2; destruct (Rtotal_order r1 r2) as [Hlt | [Heq | Hgt]]. - - now right; apply Rlt_not_eq. - - now left. - - now right; apply Rgt_not_eq. -Qed. -#[global] -Hint Resolve Req_dec: real. - -Lemma Rdichotomy : forall r1 r2, r1 <> r2 -> r1 < r2 \/ r1 > r2. -Proof. - intros r1 r2 r1_neq_r2; destruct (Rtotal_order r1 r2) as [Hlt | [Heq | Hgt]]. - - now left. - - now exfalso. - - now right. -Qed. - -(*********************************************************) -(** ** Strong decidable equality *) -(*********************************************************) - -Lemma Req_dec_T : forall r1 r2:R, {r1 = r2} + {r1 <> r2}. -Proof. - intros r1 r2; destruct (total_order_T r1 r2) as [[H | ] | H]. - - now right; intros ->; apply (Rlt_irrefl r2). - - now left. - - now right; intros ->; apply (Rlt_irrefl r2 H). -Qed. - -(*********************************************************) -(** ** Relating [<], [>], [<=] and [>=] *) -(*********************************************************) - -(** *** Relating strict and large orders *) - -Lemma Rlt_le : forall r1 r2, r1 < r2 -> r1 <= r2. -Proof. now intros r1 r2 H; left. Qed. -#[global] -Hint Resolve Rlt_le: real. - -Lemma Rgt_ge : forall r1 r2, r1 > r2 -> r1 >= r2. -Proof. now intros r1 r2; left. Qed. - -Lemma Rle_ge : forall r1 r2, r1 <= r2 -> r2 >= r1. -Proof. now intros r1 r2 [H1 | H2]; [left | right]. Qed. -#[global] -Hint Immediate Rle_ge: real. -#[global] -Hint Resolve Rle_ge: rorders. - -Lemma Rge_le : forall r1 r2, r1 >= r2 -> r2 <= r1. -Proof. now intros r1 r2 [Hge | Heq]; [left | right]. Qed. -#[global] -Hint Resolve Rge_le: real. -#[global] -Hint Immediate Rge_le: rorders. - -Lemma Rlt_gt : forall r1 r2, r1 < r2 -> r2 > r1. -Proof. now unfold Rgt. Qed. -#[global] -Hint Resolve Rlt_gt: rorders. - -Lemma Rgt_lt : forall r1 r2, r1 > r2 -> r2 < r1. -Proof. now unfold Rgt. Qed. -#[global] -Hint Immediate Rgt_lt: rorders. - -Lemma Rnot_le_lt : forall r1 r2, ~ r1 <= r2 -> r2 < r1. -Proof. - intros r1 r2 r1_nle_r2; destruct (Rtotal_order r1 r2) as [Hlt | [Heq | Hgt]]. - - now exfalso; apply r1_nle_r2; left. - - now exfalso; apply r1_nle_r2; right. - - assumption. -Qed. -#[global] -Hint Immediate Rnot_le_lt: real. - -Lemma Rnot_ge_gt : forall r1 r2, ~ r1 >= r2 -> r2 > r1. -Proof. now intros r1 r2 H; apply Rnot_le_lt; intros H'%Rle_ge. Qed. - -Lemma Rnot_le_gt : forall r1 r2, ~ r1 <= r2 -> r1 > r2. -Proof. now intros r1 r2 H; apply Rnot_le_lt. Qed. - -Lemma Rnot_ge_lt : forall r1 r2, ~ r1 >= r2 -> r1 < r2. -Proof. now intros r1 r2 H; apply Rnot_le_lt; intros H'%Rle_ge. Qed. - -Lemma Rnot_lt_le : forall r1 r2, ~ r1 < r2 -> r2 <= r1. -Proof. - intros r1 r2 H; destruct (Rtotal_order r1 r2) as [Hlt | [Heq | Hgt]]. - - now exfalso. - - now right. - - now left. -Qed. - -Lemma Rnot_gt_le : forall r1 r2, ~ r1 > r2 -> r1 <= r2. -Proof. now intros r1 r2 H; apply Rnot_lt_le. Qed. - -Lemma Rnot_gt_ge : forall r1 r2, ~ r1 > r2 -> r2 >= r1. -Proof. now intros r1 r2 H; apply Rle_ge, Rnot_lt_le. Qed. - -Lemma Rnot_lt_ge : forall r1 r2, ~ r1 < r2 -> r1 >= r2. -Proof. now intros r1 r2 H; apply Rnot_gt_ge. Qed. - -Lemma Rlt_not_le : forall r1 r2, r2 < r1 -> ~ r1 <= r2. -Proof. - intros r1 r2 Hgt [Hlt | Hle%eq_sym]. - - now apply (Rlt_asym r1 r2). - - now apply Rlt_not_eq in Hgt. -Qed. -#[global] -Hint Immediate Rlt_not_le: real. - -Lemma Rgt_not_le : forall r1 r2, r1 > r2 -> ~ r1 <= r2. -Proof. exact Rlt_not_le. Qed. - -Lemma Rlt_not_ge : forall r1 r2, r1 < r2 -> ~ r1 >= r2. -Proof. now intros r1 r2 Hlt%Rlt_not_le Hge%Rge_le. Qed. -#[global] -Hint Immediate Rlt_not_ge: real. - -Lemma Rgt_not_ge : forall r1 r2, r2 > r1 -> ~ r1 >= r2. -Proof. exact Rlt_not_ge. Qed. - -Lemma Rle_not_lt : forall r1 r2, r2 <= r1 -> ~ r1 < r2. -Proof. - intros r1 r2 [Hlt | Heq%eq_sym]; intros Hgt. - - now apply (Rlt_asym r1 r2). - - now apply Rlt_not_eq in Hgt. -Qed. - -Lemma Rge_not_lt : forall r1 r2, r1 >= r2 -> ~ r1 < r2. -Proof. now intros r1 r2 Hge; apply Rle_not_lt, Rge_le. Qed. - -Lemma Rle_not_gt : forall r1 r2, r1 <= r2 -> ~ r1 > r2. -Proof. now intros r1 r2 Hle; apply Rle_not_lt. Qed. - -Lemma Rge_not_gt : forall r1 r2, r2 >= r1 -> ~ r1 > r2. -Proof. now intros r1 r2 Hge; apply Rge_not_lt. Qed. - -(* TODO: We may want to deprecate it but cannot because of the hint used in - external libs (the stdlib can already be compiled without it) *) -Lemma Req_le_sym : forall r1 r2, r2 = r1 -> r1 <= r2. -Proof. now intros r1 r2; right. Qed. -#[global] -Hint Immediate Req_le_sym: real. - -(* TODO: We may want to deprecate it but cannot because of the hint used in - external libs (the stdlib can already be compiled without it) *) -Lemma Req_ge_sym : forall r1 r2, r2 = r1 -> r1 >= r2. -Proof. now intros r1 r2; right. Qed. -#[global] -Hint Immediate Req_ge_sym: real. - -(** *** Asymmetry *) - -(** Remark: [Rlt_asym] is in [Raxioms.v] *) - -#[export] Instance Rlt_Asymmetric : Asymmetric Rlt | 10 := Rlt_asym. - -Lemma Rgt_asym : forall r1 r2, r1 > r2 -> ~ r2 > r1. -Proof. now intros r1 r2; apply Rlt_asym. Qed. - -#[export] Instance Rgt_Asymmetric : Asymmetric Rgt | 10 := Rgt_asym. - -(** *** Antisymmetry *) - -Lemma Rle_antisym : forall r1 r2, r1 <= r2 -> r2 <= r1 -> r1 = r2. -Proof. - intros r1 r2 [Hlt | Heq] [Hgt | Heq']; try easy. - now exfalso; apply (Rlt_asym r1 r2). -Qed. -#[global] -Hint Resolve Rle_antisym: real. - -#[export] Instance Rle_Antisymmetric : Antisymmetric R eq Rle | 10 := Rle_antisym. - -Lemma Rge_antisym : forall r1 r2, r1 >= r2 -> r2 >= r1 -> r1 = r2. -Proof. now intros r1 r2 H1%Rge_le H2%Rge_le; apply Rle_antisym. Qed. - -#[export] Instance Rge_Antisymmetric : Antisymmetric R eq Rge | 10 := Rge_antisym. - -Lemma Rle_le_eq : forall r1 r2, r1 <= r2 /\ r2 <= r1 <-> r1 = r2. -Proof. - intros r1 r2; split. - - now intros [H1 H2]; apply Rle_antisym. - - now intros ->; split; apply Rle_refl. -Qed. - -Lemma Rge_ge_eq : forall r1 r2, r1 >= r2 /\ r2 >= r1 <-> r1 = r2. -Proof. - intros r1 r2; split. - - now intros [H1 H2]; apply Rge_antisym. - - now intros ->; split; apply Rge_refl. -Qed. - -(** *** Compatibility with equality *) - -Lemma Rlt_eq_compat : - forall r1 r2 r3 r4, r1 = r2 -> r2 < r4 -> r4 = r3 -> r1 < r3. -Proof. now intros r1 r2 r3 r4 -> Hlt <-. Qed. - -Lemma Rgt_eq_compat : - forall r1 r2 r3 r4, r1 = r2 -> r2 > r4 -> r4 = r3 -> r1 > r3. -Proof. now intros r1 r2 r3 r4 -> Hgt <-. Qed. - -(** *** Transitivity *) - -(** Remark: [Rlt_trans] is in Raxioms *) -#[export] Instance Rlt_Transitive : Transitive Rlt | 10 := Rlt_trans. - -Lemma Rle_trans : forall r1 r2 r3, r1 <= r2 -> r2 <= r3 -> r1 <= r3. -Proof. - intros r1 r2 r3 [Hlt | ->]; try easy. - intros [Hlt' | ->]. - - now left; apply (Rlt_trans _ r2). - - now left. -Qed. - -#[export] Instance Rle_Transitive : Transitive Rle | 10 := Rle_trans. - -Lemma Rge_trans : forall r1 r2 r3, r1 >= r2 -> r2 >= r3 -> r1 >= r3. -Proof. - intros r1 r2 r3 H1%Rge_le H2%Rge_le. - now apply Rle_ge, (Rle_trans _ r2). -Qed. - -#[export] Instance Rge_Transitive : Transitive Rge | 10 := Rge_trans. - -Lemma Rgt_trans : forall r1 r2 r3, r1 > r2 -> r2 > r3 -> r1 > r3. -Proof. now intros r1 r2 r3 H H'; apply (Rlt_trans _ r2). Qed. - -#[export] Instance Rgt_Transitive : Transitive Rgt | 10 := Rgt_trans. - -Lemma Rle_lt_trans : forall r1 r2 r3, r1 <= r2 -> r2 < r3 -> r1 < r3. -Proof. now intros r1 r2 r3 [Hlt | ->]; try easy; apply (Rlt_trans _ r2). Qed. - -Lemma Rlt_le_trans : forall r1 r2 r3, r1 < r2 -> r2 <= r3 -> r1 < r3. -Proof. now intros r1 r2 r3 H1 [Hlt | ->]; try easy; apply (Rlt_trans _ r2). Qed. - -Lemma Rge_gt_trans : forall r1 r2 r3, r1 >= r2 -> r2 > r3 -> r1 > r3. -Proof. now intros r1 r2 r3 H1%Rge_le H2%Rgt_lt; apply (Rlt_le_trans _ r2). Qed. - -Lemma Rgt_ge_trans : forall r1 r2 r3, r1 > r2 -> r2 >= r3 -> r1 > r3. -Proof. now intros r1 r2 r3 H1%Rgt_lt H2%Rge_le; apply (Rle_lt_trans _ r2). Qed. - -(** *** (Classical) decidability with sumbool types *) - -Lemma Rlt_dec : forall r1 r2, {r1 < r2} + {~ r1 < r2}. -Proof. - intros r1 r2; destruct (total_order_T r1 r2) as [[Hlt | Heq] | Hgt]. - - now left. - - now right; apply Rge_not_lt; right. - - now right; apply Rge_not_lt; left. -Qed. - -Lemma Rle_dec : forall r1 r2, {r1 <= r2} + {~ r1 <= r2}. -Proof. - intros r1 r2; destruct (Rlt_dec r2 r1) as [H%Rlt_not_le | H%Rnot_lt_le]. - - now right. - - now left. -Qed. - -Lemma Rgt_dec : forall r1 r2, {r1 > r2} + {~ r1 > r2}. -Proof. now intros r1 r2; apply Rlt_dec. Qed. - -Lemma Rge_dec : forall r1 r2, {r1 >= r2} + {~ r1 >= r2}. -Proof. - intros r1 r2; destruct (Rlt_dec r1 r2) as [H%Rlt_not_ge | H%Rnot_lt_ge]. - - now right. - - now left. -Qed. - -Lemma Rlt_le_dec : forall r1 r2, {r1 < r2} + {r2 <= r1}. -Proof. - intros r1 r2; destruct (Rlt_dec r1 r2) as [Hlt | H%Rnot_lt_le]. - - now left. - - now right. -Qed. - -Lemma Rlt_ge_dec : forall r1 r2, {r1 < r2} + {r1 >= r2}. -Proof. - intros r1 r2; destruct (Rlt_le_dec r1 r2) as [Hlt | H%Rle_ge]. - - now left. - - now right. -Qed. - -Lemma Rgt_ge_dec : forall r1 r2, {r1 > r2} + {r2 >= r1}. -Proof. - intros r1 r2; destruct (Rgt_dec r1 r2) as [Hgt | H%Rnot_gt_ge]. - - now left. - - now right. -Qed. - -Lemma Rgt_le_dec : forall r1 r2, {r1 > r2} + {r1 <= r2}. -Proof. - intros r1 r2; destruct (Rgt_ge_dec r1 r2) as [Hgt | H%Rge_le]. - - now left. - - now right. -Qed. - -Lemma Rle_lt_dec : forall r1 r2, {r1 <= r2} + {r2 < r1}. -Proof. - intros r1 r2; destruct (Rle_dec r1 r2) as [Hle | H%Rnot_le_lt]. - - now left. - - now right. -Qed. - -Lemma Rle_gt_dec : forall r1 r2, {r1 <= r2} + {r1 > r2}. -Proof. - intros r1 r2; destruct (Rle_lt_dec r1 r2) as [Hle | H%Rlt_gt]. - - now left. - - now right. -Qed. - -Lemma Rge_gt_dec : forall r1 r2, {r1 >= r2} + {r2 > r1}. -Proof. - intros r1 r2; destruct (Rle_dec r2 r1) as [Hle | H%Rnot_le_lt]. - - now left; apply Rle_ge. - - now right; apply Rlt_gt. -Qed. - -Lemma Rge_lt_dec : forall r1 r2, {r1 >= r2} + {r1 < r2}. -Proof. - intros r1 r2; destruct (Rge_gt_dec r1 r2) as [Hge | H%Rgt_lt]. - - now left. - - now right. -Qed. - -Lemma Rle_lt_or_eq_dec : forall r1 r2, r1 <= r2 -> {r1 < r2} + {r1 = r2}. -Proof. - intros r1 r2 H; destruct (total_order_T r1 r2) as [[Hlt | Heq] | Hgt]. - - now left. - - now right. - - now exfalso; apply (Rgt_not_le r1 r2). -Qed. - -Lemma Rge_gt_or_eq_dec : forall r1 r2, r1 >= r2 -> {r1 > r2} + {r1 = r2}. -Proof. - intros r1 r2 H%Rge_le. - now destruct (Rle_lt_or_eq_dec r2 r1 H) as [Hle | Heq]; [left | right]. -Qed. - -(** *** Same theorems with disjunctions instead of sumbools *) - -(* TODO: add this to [Init/Specif.v] ? *) -Lemma Private_sumbool_to_or {A B : Prop} : {A} + {B} -> A \/ B. -Proof. now intros [HA | HB]; [left | right]. Qed. - -Lemma Rlt_or_not_lt : forall r1 r2, r1 < r2 \/ ~(r1 < r2). -Proof. now intros r1 r2; apply Private_sumbool_to_or, Rlt_dec. Qed. - -Lemma Rle_or_not_le : forall r1 r2, r1 <= r2 \/ ~(r1 <= r2). -Proof. now intros r1 r2; apply Private_sumbool_to_or, Rle_dec. Qed. - -Lemma Rgt_or_not_gt : forall r1 r2, r1 > r2 \/ ~(r1 > r2). -Proof. now intros r1 r2; apply Private_sumbool_to_or, Rgt_dec. Qed. - -Lemma Rge_or_not_ge : forall r1 r2, r1 >= r2 \/ ~(r1 >= r2). -Proof. now intros r1 r2; apply Private_sumbool_to_or, Rge_dec. Qed. - -Lemma Rlt_or_le : forall r1 r2, r1 < r2 \/ r2 <= r1. -Proof. now intros r1 r2; apply Private_sumbool_to_or, Rlt_le_dec. Qed. - -Lemma Rgt_or_ge : forall r1 r2, r1 > r2 \/ r2 >= r1. -Proof. now intros r1 r2; apply Private_sumbool_to_or, Rgt_ge_dec. Qed. - -Lemma Rle_or_lt : forall r1 r2, r1 <= r2 \/ r2 < r1. -Proof. now intros r1 r2; apply Private_sumbool_to_or, Rle_lt_dec. Qed. - -Lemma Rge_or_gt : forall r1 r2, r1 >= r2 \/ r2 > r1. -Proof. now intros r1 r2; apply Private_sumbool_to_or, Rge_gt_dec. Qed. - -Lemma Rlt_or_ge : forall r1 r2, r1 < r2 \/ r1 >= r2. -Proof. now intros r1 r2; apply Private_sumbool_to_or, Rlt_ge_dec. Qed. - -Lemma Rgt_or_le : forall r1 r2, r1 > r2 \/ r1 <= r2. -Proof. now intros r1 r2; apply Private_sumbool_to_or, Rgt_le_dec. Qed. - -Lemma Rle_or_gt : forall r1 r2, r1 <= r2 \/ r1 > r2. -Proof. now intros r1 r2; apply Private_sumbool_to_or, Rle_gt_dec. Qed. - -Lemma Rge_or_lt : forall r1 r2, r1 >= r2 \/ r1 < r2. -Proof. now intros r1 r2; apply Private_sumbool_to_or, Rge_lt_dec. Qed. - -Lemma Rle_lt_or_eq : forall r1 r2, r1 <= r2 -> r1 < r2 \/ r1 = r2. -Proof. now intros r1 r2 H; apply Private_sumbool_to_or, Rle_lt_or_eq_dec. Qed. - -Lemma Rge_gt_or_eq : forall r1 r2, r1 >= r2 -> r1 > r2 \/ r1 = r2. -Proof. now intros r1 r2 H; apply Private_sumbool_to_or, Rge_gt_or_eq_dec. Qed. - -(*********************************************************) -(** ** Addition *) -(*********************************************************) - -Lemma Rplus_eq_compat_l : forall r r1 r2, r1 = r2 -> r + r1 = r + r2. -Proof. now intros r r1 r2 H; f_equal. Qed. - -Lemma Rplus_eq_compat_r : forall r r1 r2, r1 = r2 -> r1 + r = r2 + r. -Proof. now intros r r1 r2 H; f_equal. Qed. - -(** Remark: the following primitive lemmas are in [Raxioms.v] - - [Rplus_0_l]; - - [Rplus_comm]; - - [Rplus_opp_r] and - - [Rplus_assoc] *) - -Lemma Rplus_0_r : forall r, r + 0 = r. -Proof. now intros r; rewrite Rplus_comm, Rplus_0_l. Qed. -#[global] -Hint Resolve Rplus_0_r: real. - -Lemma Rplus_ne : forall r, r + 0 = r /\ 0 + r = r. -Proof. now intros r; split; [apply Rplus_0_r | apply Rplus_0_l]. Qed. -#[global] -Hint Resolve Rplus_ne: real. - -Lemma Rplus_opp_l : forall r, - r + r = 0. -Proof. now intros r; rewrite Rplus_comm; apply Rplus_opp_r. Qed. -#[global] -Hint Resolve Rplus_opp_l: real. - -Lemma Rplus_opp_r_uniq : forall r1 r2, r1 + r2 = 0 -> r2 = - r1. -Proof. - intros r1 r2 H%(Rplus_eq_compat_l (- r1)). - now rewrite <-Rplus_assoc, Rplus_opp_l, Rplus_0_l, Rplus_0_r in H. -Qed. - -Definition f_equal_R := (f_equal (A:=R)). -#[global] -Hint Resolve f_equal_R : real. - -Lemma Rplus_eq_reg_l : forall r r1 r2, r + r1 = r + r2 -> r1 = r2. -Proof. - intros r r1 r2 H%(Rplus_eq_compat_l (- r)). - now rewrite <-2Rplus_assoc, Rplus_opp_l, 2Rplus_0_l in H. -Qed. -#[global] -Hint Resolve Rplus_eq_reg_l: real. - -Lemma Rplus_eq_reg_r : forall r r1 r2, r1 + r = r2 + r -> r1 = r2. -Proof. - intros r r1 r2 H; rewrite 2(Rplus_comm _ r) in H. - now apply (Rplus_eq_reg_l r). -Qed. - -Lemma Rplus_0_r_uniq : forall r r1, r + r1 = r -> r1 = 0. -Proof. now intros r r1; rewrite <-(Rplus_0_r r) at 2; apply Rplus_eq_reg_l. Qed. - -Lemma Rplus_0_l_uniq : forall r r1, r1 + r = r -> r1 = 0. -Proof. now intros r r1; rewrite Rplus_comm; apply Rplus_0_r_uniq. Qed. - -(*********************************************************) -(** ** Opposite *) -(*********************************************************) - -Lemma Ropp_eq_compat : forall r1 r2, r1 = r2 -> - r1 = - r2. -Proof. now intros r1 r2 H; f_equal. Qed. -#[global] -Hint Resolve Ropp_eq_compat: real. - -Lemma Ropp_0 : -0 = 0. -Proof. now apply (Rplus_0_r_uniq 0), Rplus_opp_r. Qed. -#[global] -Hint Resolve Ropp_0: real. - -Lemma Ropp_eq_0_compat : forall r, r = 0 -> - r = 0. -Proof. now intros r ->; apply Ropp_0. Qed. -#[global] -Hint Resolve Ropp_eq_0_compat: real. - -Lemma Ropp_involutive : forall r, - - r = r. -Proof. now intros r; symmetry; apply (Rplus_opp_r_uniq (- r)), Rplus_opp_l. Qed. -#[global] -Hint Resolve Ropp_involutive: real. - -Lemma Ropp_eq_reg : forall r1 r2, - r1 = - r2 -> r1 = r2. -Proof. - intros r1 r2 H; rewrite <-(Ropp_involutive r1), <-(Ropp_involutive r2). - now apply Ropp_eq_compat. -Qed. - -Lemma Ropp_neq_0_compat : forall r, r <> 0 -> - r <> 0. -Proof. - intros r H H'%Ropp_eq_compat. - now rewrite Ropp_involutive, Ropp_0 in H'. -Qed. -#[global] -Hint Resolve Ropp_neq_0_compat: real. - -Lemma Ropp_plus_distr : forall r1 r2, - (r1 + r2) = - r1 + - r2. -Proof. - intros r1 r2; symmetry. - apply Rplus_opp_r_uniq. - rewrite (Rplus_comm r1), Rplus_assoc, <-(Rplus_assoc r1), Rplus_opp_r. - now rewrite Rplus_0_l, Rplus_opp_r. -Qed. -#[global] -Hint Resolve Ropp_plus_distr: real. - -(*********************************************************) -(** ** Multiplication *) -(*********************************************************) - -Lemma Rmult_eq_compat_l : forall r r1 r2, r1 = r2 -> r * r1 = r * r2. -Proof. now intros r r1 r2 H; f_equal. Qed. - -Lemma Rmult_eq_compat_r : forall r r1 r2, r1 = r2 -> r1 * r = r2 * r. -Proof. now intros r r1 r2 H; f_equal. Qed. - -(** Remark: the following primitive lemmas are in [Raxioms.v] - - [Rmult_comm]; - - [Rinv_l]; - - [Rmult_assoc]; - - [Rmult_1_l] and - - [Rmult_plus_distr_l] *) - -Lemma Rinv_r : forall r, r <> 0 -> r * / r = 1. -Proof. now intros r H; rewrite Rmult_comm, Rinv_l. Qed. -#[global] -Hint Resolve Rinv_r: real. - - -(* TODO: We may want to deprecate it but cannot because of the hint used in - external libs (the stdlib can already be compiled without it) *) -Lemma Rinv_l_sym : forall r, r <> 0 -> 1 = / r * r. -Proof. now intros r H; symmetry; apply Rinv_l. Qed. -#[global] -Hint Resolve Rinv_l_sym: real. - -(* TODO: We may want to deprecate it but cannot because of the hint used in - external libs (the stdlib can already be compiled without it) *) -Lemma Rinv_r_sym : forall r, r <> 0 -> 1 = r * / r. -Proof. now intros r H; symmetry; apply Rinv_r. Qed. -#[global] -Hint Resolve Rinv_r_sym: real. - -(* For consistency with Rplus_opp_r and Rplus_opp_l. *) -Definition Rmult_inv_r := Rinv_r. -Definition Rmult_inv_l := Rinv_l. - -Lemma Rmult_1_r : forall r, r * 1 = r. -Proof. now intros r; rewrite Rmult_comm, Rmult_1_l. Qed. -#[global] -Hint Resolve Rmult_1_r: real. - -Lemma Rmult_ne : forall r, r * 1 = r /\ 1 * r = r. -Proof. now intros r; split; [apply Rmult_1_r | apply Rmult_1_l]. Qed. -#[global] -Hint Resolve Rmult_ne: real. - -Lemma Rmult_eq_reg_l : forall r r1 r2, r * r1 = r * r2 -> r <> 0 -> r1 = r2. -Proof. - intros r r1 r2 H r_not_0. - apply (Rmult_eq_compat_l (/ r)) in H. - now rewrite <-2Rmult_assoc, Rinv_l, 2Rmult_1_l in H. -Qed. - -Lemma Rmult_eq_reg_r : forall r r1 r2, r1 * r = r2 * r -> r <> 0 -> r1 = r2. -Proof. - intros r r1 r2 H1 H2. - apply Rmult_eq_reg_l with (2 := H2). - now rewrite 2!(Rmult_comm r). -Qed. - -Lemma Rmult_plus_distr_r : - forall r1 r2 r3, (r1 + r2) * r3 = r1 * r3 + r2 * r3. -Proof. - intros r1 r2 r3. - now rewrite 3(Rmult_comm _ r3); apply Rmult_plus_distr_l. -Qed. - -Lemma Rmult_0_r : forall r, r * 0 = 0. -Proof. - intros r; apply (Rplus_eq_reg_l r). - rewrite <-(Rmult_1_r r) at 1; rewrite <-Rmult_plus_distr_l. - now rewrite 2Rplus_0_r, Rmult_1_r. -Qed. -#[global] -Hint Resolve Rmult_0_r: real. - -Lemma Rmult_0_l : forall r, 0 * r = 0. -Proof. now intros r; rewrite Rmult_comm, Rmult_0_r. Qed. -#[global] -Hint Resolve Rmult_0_l: real. - -Lemma Rmult_integral : forall r1 r2, r1 * r2 = 0 -> r1 = 0 \/ r2 = 0. -Proof. - intros; destruct (Req_dec r1 0) as [Hz | Hnz]; [left | right]; try easy. - apply (Rmult_eq_compat_l (/ r1)) in H. - now rewrite <-Rmult_assoc, Rinv_l, Rmult_1_l, Rmult_0_r in H. -Qed. - -Lemma Rmult_eq_0_compat : forall r1 r2, r1 = 0 \/ r2 = 0 -> r1 * r2 = 0. -Proof. now intros r1 r2 [-> | ->]; [apply Rmult_0_l | apply Rmult_0_r]. Qed. -#[global] -Hint Resolve Rmult_eq_0_compat: real. - -Lemma Rmult_eq_0_compat_r : forall r1 r2, r1 = 0 -> r1 * r2 = 0. -Proof. now intros r1 r2 ->; apply Rmult_0_l. Qed. - -Lemma Rmult_eq_0_compat_l : forall r1 r2, r2 = 0 -> r1 * r2 = 0. -Proof. now intros r1 r2 ->; apply Rmult_0_r. Qed. - -Lemma Rmult_neq_0_reg : forall r1 r2, r1 * r2 <> 0 -> r1 <> 0 /\ r2 <> 0. -Proof. - intros r1 r2 H; split; intros Heq0; rewrite Heq0 in H. - - now rewrite Rmult_0_l in H. - - now rewrite Rmult_0_r in H. -Qed. - -Lemma Rmult_integral_contrapositive : - forall r1 r2, r1 <> 0 /\ r2 <> 0 -> r1 * r2 <> 0. -Proof. now intros r1 r2 [H1 H2] [r10 | r20]%Rmult_integral. Qed. -#[global] -Hint Resolve Rmult_integral_contrapositive: real. - -Lemma Rmult_integral_contrapositive_currified : - forall r1 r2, r1 <> 0 -> r2 <> 0 -> r1 * r2 <> 0. -Proof. now intros r1 r2 H1 H2; apply Rmult_integral_contrapositive. Qed. - -(*********************************************************) -(** ** Opposite and multiplication *) -(*********************************************************) - -Lemma Ropp_mult_distr_l : forall r1 r2, - (r1 * r2) = - r1 * r2. -Proof. - intros r1 r2; symmetry; apply Rplus_opp_r_uniq. - now rewrite <-Rmult_plus_distr_r, Rplus_opp_r, Rmult_0_l. -Qed. - -Lemma Ropp_mult_distr_r : forall r1 r2, - (r1 * r2) = r1 * - r2. -Proof. now intros r1 r2; rewrite 2(Rmult_comm r1); apply Ropp_mult_distr_l. Qed. - -Lemma Ropp_mult_distr_l_reverse : forall r1 r2, - r1 * r2 = - (r1 * r2). -Proof. now intros r1 r2; symmetry; apply Ropp_mult_distr_l. Qed. -#[global] -Hint Resolve Ropp_mult_distr_l_reverse: real. - -Lemma Rmult_opp_opp : forall r1 r2, - r1 * - r2 = r1 * r2. -Proof. - intros r1 r2. - now rewrite <-Ropp_mult_distr_l, <-Ropp_mult_distr_r, Ropp_involutive. -Qed. -#[global] -Hint Resolve Rmult_opp_opp: real. - -Lemma Ropp_mult_distr_r_reverse : forall r1 r2, r1 * - r2 = - (r1 * r2). -Proof. now intros r1 r2; symmetry; apply Ropp_mult_distr_r. Qed. - -(*********************************************************) -(** ** Subtraction *) -(*********************************************************) - -Lemma Rminus_def : forall r1 r2, r1 - r2 = r1 + - r2. -Proof. now unfold Rminus. Qed. - -Lemma Rminus_eq_compat_l : forall r r1 r2, r1 = r2 -> r - r1 = r - r2. -Proof. - now unfold Rminus; intros r r1 r2 H%Ropp_eq_compat; apply Rplus_eq_compat_l. -Qed. - -Lemma Rminus_eq_compat_r : forall r r1 r2, r1 = r2 -> r1 - r = r2 - r. -Proof. now unfold Rminus; intros r r1 r2;apply Rplus_eq_compat_r. Qed. - -Lemma Rminus_eq_reg_l : forall r r1 r2, r - r1 = r - r2 -> r1 = r2. -Proof. - now unfold Rminus; intros r r1 r2 H%Rplus_eq_reg_l; apply Ropp_eq_reg. -Qed. - -Lemma Rminus_eq_reg_r : forall r r1 r2, r1 - r = r2 - r -> r1 = r2. -Proof. now unfold Rminus; intros r r1 r2; apply Rplus_eq_reg_r. Qed. - -Lemma Rminus_0_r : forall r, r - 0 = r. -Proof. now unfold Rminus; intros r; rewrite Ropp_0, Rplus_0_r. Qed. -#[global] -Hint Resolve Rminus_0_r: real. - -Lemma Rminus_0_l : forall r, 0 - r = - r. -Proof. now unfold Rminus; intros r; rewrite Rplus_0_l. Qed. -#[global] -Hint Resolve Rminus_0_l: real. - -Lemma Ropp_minus_distr : forall r1 r2, - (r1 - r2) = r2 - r1. -Proof. - unfold Rminus; intros r1 r2. - now rewrite Ropp_plus_distr, Ropp_involutive, Rplus_comm. -Qed. -#[global] -Hint Resolve Ropp_minus_distr: real. - -Lemma Rminus_diag_eq : forall r1 r2, r1 = r2 -> r1 - r2 = 0. -Proof. now unfold Rminus; intros r1 r2 ->; rewrite Rplus_opp_r. Qed. -#[global] -Hint Resolve Rminus_diag_eq: real. - -Lemma Rminus_diag : forall r, r - r = 0. -Proof. now intros r; apply Rminus_diag_eq. Qed. - -Lemma Rminus_diag_uniq : forall r1 r2, r1 - r2 = 0 -> r1 = r2. -Proof. - unfold Rminus; intros r1 r2 H%(Rplus_eq_compat_r r2). - now rewrite Rplus_assoc, Rplus_opp_l, Rplus_0_l, Rplus_0_r in H. -Qed. -#[global] -Hint Immediate Rminus_diag_uniq: real. - -(* TODO: We may want to deprecate it but cannot because of the hint used in - external libs (the stdlib can already be compiled without it) *) -Lemma Rminus_diag_uniq_sym : forall r1 r2, r2 - r1 = 0 -> r1 = r2. -Proof. now intros r1 r2; symmetry;apply Rminus_diag_uniq. Qed. -#[global] -Hint Immediate Rminus_diag_uniq_sym: real. - - -Lemma Rplus_minus : forall r1 r2, r1 + (r2 - r1) = r2. -Proof. - unfold Rminus; intros r1 r2. - now rewrite Rplus_comm, Rplus_assoc, Rplus_opp_l, Rplus_0_r. -Qed. -#[global] -Hint Resolve Rplus_minus: real. - -Lemma Rminus_eq_contra : forall r1 r2, r1 <> r2 -> r1 - r2 <> 0. -Proof. now intros r1 r2 H H0%Rminus_diag_uniq. Qed. -#[global] -Hint Resolve Rminus_eq_contra: real. - -Lemma Rminus_not_eq : forall r1 r2, r1 - r2 <> 0 -> r1 <> r2. -Proof. now intros r1 r2 H Heq; apply H, Rminus_diag_eq. Qed. -#[global] -Hint Resolve Rminus_not_eq: real. - -(* TODO: We may want to deprecate it but cannot because of the hint used in - external libs (the stdlib can already be compiled without it) *) -Lemma Rminus_not_eq_right : forall r1 r2, r2 - r1 <> 0 -> r1 <> r2. -Proof. now intros r1 r2 H; apply not_eq_sym, Rminus_not_eq. Qed. -#[global] -Hint Resolve Rminus_not_eq_right: real. - -Lemma Rmult_minus_distr_l : - forall r1 r2 r3, r1 * (r2 - r3) = r1 * r2 - r1 * r3. -Proof. - unfold Rminus; intros r1 r2 r3; rewrite Rmult_plus_distr_l. - now rewrite Ropp_mult_distr_r. -Qed. - -Lemma Rmult_minus_distr_r : - forall r1 r2 r3, (r2 - r3) * r1 = r2 * r1 - r3 * r1. -Proof. - intros r1 r2 r3; rewrite 3(Rmult_comm _ r1). - now apply Rmult_minus_distr_l. -Qed. - -Lemma Rplus_minus_r : forall r1 r2, r1 + r2 - r2 = r1. -Proof. - now intros r1 r2; unfold Rminus; rewrite Rplus_assoc, Rplus_opp_r, Rplus_0_r. -Qed. - -Lemma Rplus_minus_l : forall r1 r2, r1 + r2 - r1 = r2. -Proof. now intros r1 r2; rewrite Rplus_comm, Rplus_minus_r. Qed. - -Lemma Rplus_minus_assoc : forall r1 r2 r3, r1 + (r2 - r3) = (r1 + r2) - r3. -Proof. now unfold Rminus; intros r1 r2 r3; rewrite Rplus_assoc. Qed. - -Lemma Rplus_minus_swap : forall r1 r2 r3, (r1 + r2) - r3 = (r1 - r3) + r2. -Proof. - unfold Rminus; intros r1 r2 r3. - now rewrite Rplus_assoc, (Rplus_comm r2), <-Rplus_assoc. -Qed. - -Lemma Rminus_plus_distr : forall r1 r2 r3, r1 - (r2 + r3) = (r1 - r2) - r3. -Proof. - now unfold Rminus; intros r1 r2 r3; rewrite Ropp_plus_distr, Rplus_assoc. -Qed. - -Lemma Rminus_plus_r_r : forall r r1 r2, (r1 + r) - (r2 + r) = r1 - r2. -Proof. - intros r r1 r2; rewrite Rminus_plus_distr, Rplus_comm. - now rewrite <-Rplus_minus_assoc, Rplus_minus_l. -Qed. - -Lemma Rminus_plus_l_r : forall r r1 r2, (r + r1) - (r2 + r) = r1 - r2. -Proof. now intros r r1 r2; rewrite (Rplus_comm r), Rminus_plus_r_r. Qed. - -Lemma Rminus_plus_r_l : forall r r1 r2, (r1 + r) - (r + r2) = r1 - r2. -Proof. now intros r r1 r2; rewrite (Rplus_comm r), Rminus_plus_r_r. Qed. - -Lemma Rminus_plus_l_l : forall r r1 r2, (r + r1) - (r + r2) = r1 - r2. -Proof. now intros r r1 r2; rewrite (Rplus_comm _ r1), Rminus_plus_r_l. Qed. - -(*********************************************************) -(** ** Inverse *) -(*********************************************************) - -Lemma Rinv_0 : / 0 = 0. -Proof. - rewrite RinvImpl.Rinv_def. - destruct (Req_appart_dec 0 R0) as [eq0 | [lt0 | gt0]]; try easy; - now exfalso; apply (Rlt_irrefl 0). -Qed. - -Lemma Rmult_inv_r_uniq : - forall r1 r2, r1 <> 0 -> r1 * r2 = 1 -> r2 = / r1. -Proof. - intros r1 r2 Hn0 H%(Rmult_eq_compat_l (/ r1)). - now rewrite <-Rmult_assoc, Rinv_l, Rmult_1_r, Rmult_1_l in H. -Qed. - -Lemma Rinv_eq_compat : forall r1 r2, r1 = r2 -> / r1 = / r2. -Proof. now intros r1 r2 H; f_equal. Qed. - -Lemma Rinv_1 : / 1 = 1. -Proof. - symmetry; apply Rmult_inv_r_uniq. - - exact R1_neq_R0. - - now rewrite Rmult_1_r. -Qed. -#[global] -Hint Resolve Rinv_1: real. - -Lemma Rinv_neq_0_compat : forall r, r <> 0 -> / r <> 0. -Proof. - intros r H H'; apply R1_neq_R0. - now rewrite <-(Rinv_l r), H', Rmult_0_l. -Qed. -#[global] -Hint Resolve Rinv_neq_0_compat: real. - -Lemma Rinv_inv r : / / r = r. -Proof. -destruct (Req_dec r 0) as [-> | H]. -- now rewrite Rinv_0, Rinv_0. -- symmetry; apply Rmult_inv_r_uniq. - * now apply Rinv_neq_0_compat. - * now rewrite Rinv_l. -Qed. -#[global] -Hint Resolve Rinv_inv: real. - -Lemma Rinv_eq_reg : forall r1 r2, / r1 = / r2 -> r1 = r2. -Proof. now intros r1 r2 H%Rinv_eq_compat; rewrite !Rinv_inv in H. Qed. - -Lemma Rinv_mult r1 r2 : / (r1 * r2) = / r1 * / r2. -Proof. -destruct (Req_dec r1 0) as [-> | H1]. -- now rewrite Rinv_0, 2!Rmult_0_l, Rinv_0. -- destruct (Req_dec r2 0) as [-> | H2]. - + now rewrite Rinv_0, 2!Rmult_0_r, Rinv_0. - + symmetry; apply Rmult_inv_r_uniq. - { now apply Rmult_integral_contrapositive_currified. } - rewrite (Rmult_comm r1), Rmult_assoc, <-(Rmult_assoc r1). - now rewrite Rinv_r, Rmult_1_l, Rinv_r. -Qed. - -Lemma Rinv_opp r : / - r = - / r. -Proof. - destruct (Req_dec r 0) as [-> | H]. - - now rewrite Ropp_0, Rinv_0, Ropp_0. - - symmetry; apply Rmult_inv_r_uniq. - { now apply Ropp_neq_0_compat. } - now rewrite Rmult_opp_opp, Rinv_r. -Qed. - -Lemma Rmult_inv_m_id_r : forall r1 r2, r1 <> 0 -> r1 * / r1 * r2 = r2. -Proof. now intros r1 r2 r1n0; rewrite Rinv_r, Rmult_1_l. Qed. - -Lemma Rmult_inv_r_id_l : forall r1 r2, r1 <> 0 -> r2 * r1 * / r1 = r2. -Proof. now intros r1 r2 r1n0; rewrite Rmult_assoc, Rinv_r, Rmult_1_r. Qed. - -Lemma Rmult_inv_r_id_m : forall r1 r2, r1 <> 0 -> r1 * r2 * / r1 = r2. -Proof. now intros r1 r2 r1n0; rewrite (Rmult_comm r1), Rmult_inv_r_id_l. Qed. -#[global] -Hint Resolve Rmult_inv_m_id_r Rmult_inv_r_id_l Rmult_inv_r_id_m: real. - - -(*********************************************************) -(** ** Square function *) -(*********************************************************) - -Definition Rsqr r : R := r * r. -Notation "r Ā²" := (Rsqr r) (at level 1, format "r Ā²") : R_scope. - -(* Useful to fold Rsqr *) -Lemma Rsqr_def : forall r, rĀ² = r * r. -Proof. now unfold Rsqr; intros r. Qed. - -Lemma Rsqr_0 : Rsqr 0 = 0. -Proof. now unfold Rsqr; apply Rmult_0_r. Qed. - -Lemma Rsqr_0_uniq : forall r, Rsqr r = 0 -> r = 0. -Proof. now unfold Rsqr; intros r [-> | ->]%Rmult_integral. Qed. - -(*********************************************************) -(** ** Order and addition *) -(*********************************************************) - -(** *** Compatibility *) - -(** Remark: [Rplus_lt_compat_l] is in [Raxioms.v] *) - -Lemma Rplus_gt_compat_l : forall r r1 r2, r1 > r2 -> r + r1 > r + r2. -Proof. now intros r r1 r2; apply Rplus_lt_compat_l. Qed. -#[global] -Hint Resolve Rplus_gt_compat_l: real. - -Lemma Rplus_lt_compat_r : forall r r1 r2, r1 < r2 -> r1 + r < r2 + r. -Proof. - intros r r1 r2 r1_lt_r2; rewrite (Rplus_comm r1), (Rplus_comm r2). - now apply Rplus_lt_compat_l. -Qed. -#[global] -Hint Resolve Rplus_lt_compat_r: real. - -Lemma Rplus_gt_compat_r : forall r r1 r2, r1 > r2 -> r1 + r > r2 + r. -Proof. now intros r r1 r2; apply Rplus_lt_compat_r. Qed. - -Lemma Rplus_le_compat_l : forall r r1 r2, r1 <= r2 -> r + r1 <= r + r2. -Proof. - unfold Rle; intros r r1 r2 [Hlt | ->]. - - now left; apply Rplus_lt_compat_l. - - now right. -Qed. - -Lemma Rplus_ge_compat_l : forall r r1 r2, r1 >= r2 -> r + r1 >= r + r2. -Proof. now intros r r1 r2 H%Rge_le; apply Rle_ge, Rplus_le_compat_l. Qed. -#[global] -Hint Resolve Rplus_ge_compat_l: real. - -Lemma Rplus_le_compat_r : forall r r1 r2, r1 <= r2 -> r1 + r <= r2 + r. -Proof. - intros r r1 r2 H. - now rewrite 2(Rplus_comm _ r); apply Rplus_le_compat_l. -Qed. - -#[global] -Hint Resolve Rplus_le_compat_l Rplus_le_compat_r: real. - -Lemma Rplus_ge_compat_r : forall r r1 r2, r1 >= r2 -> r1 + r >= r2 + r. -Proof. now intros r r1 r2 H%Rge_le; apply Rle_ge, Rplus_le_compat_r. Qed. - -Lemma Rplus_lt_compat : - forall r1 r2 r3 r4, r1 < r2 -> r3 < r4 -> r1 + r3 < r2 + r4. -Proof. - intros r1 r2 r3 r4 r1_lt_r2 r3_lt_r4; apply (Rlt_trans _ (r2 + r3)). - - now apply Rplus_lt_compat_r. - - now apply Rplus_lt_compat_l. -Qed. -#[global] -Hint Immediate Rplus_lt_compat: real. - -Lemma Rplus_le_compat : - forall r1 r2 r3 r4, r1 <= r2 -> r3 <= r4 -> r1 + r3 <= r2 + r4. -Proof. - intros r1 r2 r3 r4 r1_lt_r2 r3_lt_r4; apply (Rle_trans _ (r2 + r3)). - - now apply Rplus_le_compat_r. - - now apply Rplus_le_compat_l. -Qed. -#[global] -Hint Immediate Rplus_le_compat: real. - -Lemma Rplus_gt_compat : - forall r1 r2 r3 r4, r1 > r2 -> r3 > r4 -> r1 + r3 > r2 + r4. -Proof. now intros r1 r2 r3 r4; apply Rplus_lt_compat. Qed. - -Lemma Rplus_ge_compat : - forall r1 r2 r3 r4, r1 >= r2 -> r3 >= r4 -> r1 + r3 >= r2 + r4. -Proof. - now intros r1 r2 r3 r4 H1%Rge_le H2%Rge_le; apply Rle_ge, Rplus_le_compat. -Qed. - -Lemma Rplus_lt_le_compat : - forall r1 r2 r3 r4, r1 < r2 -> r3 <= r4 -> r1 + r3 < r2 + r4. -Proof. - intros r1 r2 r3 r4 Hlt Hle; apply (Rlt_le_trans _ (r2 + r3)). - - now apply Rplus_lt_compat_r. - - now apply Rplus_le_compat_l. -Qed. - -Lemma Rplus_le_lt_compat : - forall r1 r2 r3 r4, r1 <= r2 -> r3 < r4 -> r1 + r3 < r2 + r4. -Proof. - intros r1 r2 r3 r4 H H'; rewrite (Rplus_comm r1), (Rplus_comm r2). - now apply Rplus_lt_le_compat. -Qed. -#[global] -Hint Immediate Rplus_lt_le_compat Rplus_le_lt_compat: real. - -Lemma Rplus_gt_ge_compat : - forall r1 r2 r3 r4, r1 > r2 -> r3 >= r4 -> r1 + r3 > r2 + r4. -Proof. now intros r1 r2 r3 r4 H H'%Rge_le; apply Rplus_lt_le_compat. Qed. - -Lemma Rplus_ge_gt_compat : - forall r1 r2 r3 r4, r1 >= r2 -> r3 > r4 -> r1 + r3 > r2 + r4. -Proof. now intros r1 r2 r3 r4 H%Rge_le H'; apply Rplus_le_lt_compat. Qed. - -Lemma Rplus_lt_0_compat : forall r1 r2, 0 < r1 -> 0 < r2 -> 0 < r1 + r2. -Proof. - now intros r1 r2 I I'; rewrite <-(Rplus_0_r 0); apply Rplus_lt_compat. -Qed. - -Lemma Rplus_le_lt_0_compat : forall r1 r2, 0 <= r1 -> 0 < r2 -> 0 < r1 + r2. -Proof. - now intros r1 r2 I I'; rewrite <-(Rplus_0_r 0); apply Rplus_le_lt_compat. -Qed. - -Lemma Rplus_lt_le_0_compat : forall r1 r2, 0 < r1 -> 0 <= r2 -> 0 < r1 + r2. -Proof. - now intros r1 r2 I I'; rewrite <-(Rplus_0_r 0); apply Rplus_lt_le_compat. -Qed. - -Lemma Rplus_le_le_0_compat : forall r1 r2, 0 <= r1 -> 0 <= r2 -> 0 <= r1 + r2. -Proof. - now intros r1 r2 I I'; rewrite <-(Rplus_0_r 0); apply Rplus_le_compat. -Qed. - -Lemma Rplus_eq_0_l : - forall r1 r2, 0 <= r1 -> 0 <= r2 -> r1 + r2 = 0 -> r1 = 0. -Proof. - intros r1 r2 [Hlt | <-]; try easy. - intros [Hlt' | <-] H. - - exfalso; apply (Rgt_not_eq (r1 + r2) 0); try easy. - now rewrite <-(Rplus_0_r 0); apply Rplus_lt_compat. - - now rewrite Rplus_0_r in H. -Qed. - -Lemma Rplus_eq_0 : - forall r1 r2, 0 <= r1 -> 0 <= r2 -> r1 + r2 = 0 -> r1 = 0 /\ r2 = 0. -Proof. - intros r1 r2 H1 H2 Hp; split. - - now apply (Rplus_eq_0_l _ r2). - - now rewrite Rplus_comm in Hp; apply (Rplus_eq_0_l r2 r1). -Qed. - -(** *** Cancellation *) - -Lemma Rplus_lt_reg_l : forall r r1 r2, r + r1 < r + r2 -> r1 < r2. -Proof. - intros r r1 r2 H%(Rplus_lt_compat_l (-r)). - now rewrite <-2Rplus_assoc, Rplus_opp_l, 2Rplus_0_l in H. -Qed. - -Lemma Rplus_lt_reg_r : forall r r1 r2, r1 + r < r2 + r -> r1 < r2. -Proof. - intros r r1 r2 H. - rewrite (Rplus_comm r1), (Rplus_comm r2) in H. - now apply (Rplus_lt_reg_l r). -Qed. - -Lemma Rplus_le_reg_l : forall r r1 r2, r + r1 <= r + r2 -> r1 <= r2. -Proof. - intros r r1 r2 [Ilt | Eq]. - - left; apply (Rplus_lt_reg_l r r1 r2 Ilt). - - right; apply (Rplus_eq_reg_l r r1 r2 Eq). -Qed. - -Lemma Rplus_le_reg_r : forall r r1 r2, r1 + r <= r2 + r -> r1 <= r2. -Proof. - intros r r1 r2 H. - now apply (Rplus_le_reg_l r); rewrite 2(Rplus_comm r). -Qed. - -Lemma Rplus_gt_reg_l : forall r r1 r2, r + r1 > r + r2 -> r1 > r2. -Proof. now intros r r1 r2 H; apply (Rplus_lt_reg_l r r2 r1 H). Qed. - -Lemma Rplus_gt_reg_r : forall r r1 r2, r1 + r > r2 + r -> r1 > r2. -Proof. now intros r r1 r2 H; apply (Rplus_lt_reg_r r r2 r1 H). Qed. - -Lemma Rplus_ge_reg_l : forall r r1 r2, r + r1 >= r + r2 -> r1 >= r2. -Proof. now intros r r1 r2 H%Rge_le; apply Rle_ge, (Rplus_le_reg_l r). Qed. - -Lemma Rplus_ge_reg_r : forall r r1 r2, r1 + r >= r2 + r -> r1 >= r2. -Proof. now intros r r1 r2 H%Rge_le; apply Rle_ge, (Rplus_le_reg_r r). Qed. - -Lemma Rplus_le_reg_pos_r : - forall r1 r2 r3, 0 <= r2 -> r1 + r2 <= r3 -> r1 <= r3. -Proof. - intros r1 r2 r3 H H'. - apply (Rle_trans _ (r1 + r2)); try easy. - now rewrite <-(Rplus_0_r r1) at 1; apply Rplus_le_compat_l. -Qed. - -Lemma Rplus_lt_reg_pos_r : forall r1 r2 r3, 0 <= r2 -> r1 + r2 < r3 -> r1 < r3. -Proof. - intros r1 r2 r3 H H'. - apply (Rle_lt_trans _ (r1 + r2)); try easy. - now rewrite <-(Rplus_0_r r1) at 1; apply Rplus_le_compat_l. -Qed. - -Lemma Rplus_ge_reg_neg_r : - forall r1 r2 r3, 0 >= r2 -> r1 + r2 >= r3 -> r1 >= r3. -Proof. - intros r1 r2 r3 H H'. - apply (Rge_trans _ (r1 + r2)); try easy. - now rewrite <-(Rplus_0_r r1) at 1; apply Rplus_ge_compat_l. -Qed. - -Lemma Rplus_gt_reg_neg_r : forall r1 r2 r3, 0 >= r2 -> r1 + r2 > r3 -> r1 > r3. -Proof. - intros r1 r2 r3 H H'. - apply (Rge_gt_trans _ (r1 + r2)); try easy. - now rewrite <-(Rplus_0_r r1) at 1; apply Rplus_ge_compat_l. -Qed. - -Lemma Rplus_le_lt_0_neq_0 : forall r1 r2, 0 <= r1 -> 0 < r2 -> r1 + r2 <> 0. -Proof. - intros r1 r2 H1 H2; apply not_eq_sym, Rlt_not_eq. - now rewrite <-(Rplus_0_l 0); apply Rplus_le_lt_compat. -Qed. -#[global] -Hint Immediate Rplus_le_lt_0_neq_0: real. - -(** *** Comparison of addition with left operand *) - -Lemma Rplus_pos_gt : forall r1 r2, r2 > 0 -> r1 + r2 > r1. -Proof. - now intros r1 r2 H; rewrite <-(Rplus_0_r r1) at 2; apply Rplus_gt_compat_l. -Qed. - -Lemma Rplus_nneg_ge : forall r1 r2, r2 >= 0 -> r1 + r2 >= r1. -Proof. - now intros r1 r2 H; rewrite <-(Rplus_0_r r1) at 2; apply Rplus_ge_compat_l. -Qed. - -Lemma Rplus_neg_lt : forall r1 r2, r2 < 0 -> r1 + r2 < r1. -Proof. - now intros r1 r2 H; rewrite <-(Rplus_0_r r1) at 2; apply Rplus_lt_compat_l. -Qed. - -Lemma Rplus_npos_le : forall r1 r2, r2 <= 0 -> r1 + r2 <= r1. -Proof. - now intros r1 r2 H; rewrite <-(Rplus_0_r r1) at 2; apply Rplus_le_compat_l. -Qed. - -(** *** Sign of addition *) - -Lemma Rplus_pos_pos : forall r1 r2, r1 > 0 -> r2 > 0 -> r1 + r2 > 0. -Proof. now intros r1 r2; apply Rplus_lt_0_compat. Qed. - -Lemma Rplus_neg_neg : forall r1 r2, r1 < 0 -> r2 < 0 -> r1 + r2 < 0. -Proof. - now intros r1 r2 H1 H2; rewrite <-(Rplus_0_l 0); apply Rplus_lt_compat. -Qed. - -Lemma Rplus_nneg_nneg : forall r1 r2, r1 >= 0 -> r2 >= 0 -> r1 + r2 >= 0. -Proof. - now intros r1 r2 H1 H2; rewrite <-(Rplus_0_l 0); apply Rplus_ge_compat. -Qed. - -Lemma Rplus_npos_npos : forall r1 r2, r1 <= 0 -> r2 <= 0 -> r1 + r2 <= 0. -Proof. - now intros r1 r2 H1 H2; rewrite <-(Rplus_0_l 0); apply Rplus_le_compat. -Qed. - -Lemma Rplus_pos_nneg : forall r1 r2, r1 > 0 -> r2 >= 0 -> r1 + r2 > 0. -Proof. - now intros r1 r2 H1 H2; rewrite <-(Rplus_0_l 0); apply Rplus_gt_ge_compat. -Qed. - -Lemma Rplus_nneg_pos : forall r1 r2, r1 >= 0 -> r2 > 0 -> r1 + r2 > 0. -Proof. - now intros r1 r2 H1 H2; rewrite <-(Rplus_0_l 0); apply Rplus_ge_gt_compat. -Qed. - -Lemma Rplus_neg_npos : forall r1 r2, r1 < 0 -> r2 <= 0 -> r1 + r2 < 0. -Proof. - now intros r1 r2 H1 H2; rewrite <-(Rplus_0_l 0); apply Rplus_lt_le_compat. -Qed. - -Lemma Rplus_npos_neg : forall r1 r2, r1 <= 0 -> r2 < 0 -> r1 + r2 < 0. -Proof. - now intros r1 r2 H1 H2; rewrite <-(Rplus_0_l 0); apply Rplus_le_lt_compat. -Qed. - -(*********************************************************) -(** ** Order and opposite *) -(*********************************************************) - -(** *** Contravariant compatibility *) - -Lemma Ropp_gt_lt_contravar : forall r1 r2, r1 > r2 -> - r1 < - r2. -Proof. - intros r1 r2 H. - apply (Rplus_lt_reg_l r1), (Rplus_lt_reg_r r2). - now rewrite Rplus_opp_r, Rplus_0_l, Rplus_assoc, Rplus_opp_l, Rplus_0_r. -Qed. -#[global] -(* TODO: why core? *) -Hint Resolve Ropp_gt_lt_contravar : core. - -Lemma Ropp_lt_gt_contravar : forall r1 r2, r1 < r2 -> - r1 > - r2. -Proof. now intros r1 r2 H; apply Ropp_gt_lt_contravar. Qed. -#[global] -Hint Resolve Ropp_lt_gt_contravar: real. - -Lemma Ropp_lt_contravar : forall r1 r2, r2 < r1 -> - r1 < - r2. -Proof. now intros r1 r2; apply Ropp_lt_gt_contravar. Qed. -#[global] -Hint Resolve Ropp_lt_contravar: real. - -Lemma Ropp_gt_contravar : forall r1 r2, r2 > r1 -> - r1 > - r2. -Proof. now intros r1 r2; apply Ropp_lt_gt_contravar. Qed. - -Lemma Ropp_le_ge_contravar : forall r1 r2, r1 <= r2 -> - r1 >= - r2. -Proof. - now intros r1 r2 [I | ->]; [left | right; easy]; apply Ropp_lt_contravar. -Qed. -#[global] -Hint Resolve Ropp_le_ge_contravar: real. - -Lemma Ropp_ge_le_contravar : forall r1 r2, r1 >= r2 -> - r1 <= - r2. -Proof. now intros r1 r2 I%Rge_le; apply Rge_le, Ropp_le_ge_contravar. Qed. -#[global] -Hint Resolve Ropp_ge_le_contravar: real. - -Lemma Ropp_le_contravar : forall r1 r2, r2 <= r1 -> - r1 <= - r2. -Proof. now intros r1 r2 I; apply Rge_le, Ropp_le_ge_contravar. Qed. -#[global] -Hint Resolve Ropp_le_contravar: real. - -Lemma Ropp_ge_contravar : forall r1 r2, r2 >= r1 -> - r1 >= - r2. -Proof. now intros r1 r2 I; apply Rle_ge, Ropp_ge_le_contravar. Qed. - -Lemma Ropp_0_lt_gt_contravar : forall r, 0 < r -> 0 > - r. -Proof. now intros r I; rewrite <-Ropp_0; apply Ropp_lt_contravar. Qed. -#[global] -Hint Resolve Ropp_0_lt_gt_contravar: real. - -Lemma Ropp_0_gt_lt_contravar : forall r, 0 > r -> 0 < - r. -Proof. now intros r I; rewrite <-Ropp_0; apply Ropp_lt_contravar. Qed. -#[global] -Hint Resolve Ropp_0_gt_lt_contravar: real. - -Lemma Ropp_lt_gt_0_contravar : forall r, r > 0 -> - r < 0. -Proof. now intros r I; rewrite <-Ropp_0; apply Ropp_lt_contravar. Qed. -#[global] -Hint Resolve Ropp_lt_gt_0_contravar: real. - -Lemma Ropp_gt_lt_0_contravar : forall r, r < 0 -> - r > 0. -Proof. now intros r I; rewrite <-Ropp_0; apply Ropp_lt_contravar. Qed. -#[global] -Hint Resolve Ropp_gt_lt_0_contravar: real. - -Lemma Ropp_0_le_ge_contravar : forall r, 0 <= r -> 0 >= - r. -Proof. now intros r I; rewrite <-Ropp_0; apply Ropp_le_ge_contravar. Qed. -#[global] -Hint Resolve Ropp_0_le_ge_contravar: real. - -Lemma Ropp_0_ge_le_contravar : forall r, 0 >= r -> 0 <= - r. -Proof. now intros r I; rewrite <-Ropp_0; apply Ropp_ge_le_contravar. Qed. -#[global] -Hint Resolve Ropp_0_ge_le_contravar: real. - -(** *** Cancellation *) - -Lemma Ropp_lt_cancel : forall r1 r2, - r2 < - r1 -> r1 < r2. -Proof. now intros r1 r2 I%Ropp_lt_contravar; rewrite 2Ropp_involutive in I. Qed. -#[global] -Hint Immediate Ropp_lt_cancel: real. - -Lemma Ropp_gt_cancel : forall r1 r2, - r2 > - r1 -> r1 > r2. -Proof. now intros r1 r2; apply Ropp_lt_cancel. Qed. - -Lemma Ropp_le_cancel : forall r1 r2, - r2 <= - r1 -> r1 <= r2. -Proof. now intros r1 r2 I%Ropp_le_contravar; rewrite 2Ropp_involutive in I. Qed. -#[global] -Hint Immediate Ropp_le_cancel: real. - -Lemma Ropp_ge_cancel : forall r1 r2, - r2 >= - r1 -> r1 >= r2. -Proof. now intros r1 r2 I%Rge_le; apply Rle_ge, Ropp_le_cancel. Qed. - -(** *** Sign of opposite *) - -Lemma Ropp_pos : forall r, r > 0 -> - r < 0. -Proof. now intros r H; rewrite <-Ropp_0; apply Ropp_lt_contravar. Qed. - -Lemma Ropp_neg : forall r, r < 0 -> - r > 0. -Proof. now intros r H; rewrite <-Ropp_0; apply Ropp_lt_contravar. Qed. - -(*********************************************************) -(** ** Order and multiplication *) -(*********************************************************) - -(** Remark: [Rmult_lt_compat_l] is in [Raxioms.v] *) - -(** *** Covariant compatibility *) - -Lemma Rmult_lt_compat_r : forall r r1 r2, 0 < r -> r1 < r2 -> r1 * r < r2 * r. -Proof. - intros r r1 r2; rewrite 2(Rmult_comm _ r); apply Rmult_lt_compat_l. -Qed. -#[global] -(* TODO: why core? *) -Hint Resolve Rmult_lt_compat_r : core. - -Lemma Rmult_gt_compat_r : forall r r1 r2, r > 0 -> r1 > r2 -> r1 * r > r2 * r. -Proof. now intros r r1 r2; apply Rmult_lt_compat_r. Qed. - -Lemma Rmult_gt_compat_l : forall r r1 r2, r > 0 -> r1 > r2 -> r * r1 > r * r2. -Proof. now intros r r1 r2; apply Rmult_lt_compat_l. Qed. - -Lemma Rmult_le_compat_l : - forall r r1 r2, 0 <= r -> r1 <= r2 -> r * r1 <= r * r2. -Proof. - intros r r1 r2 [I | <-] [I' | ->]; try rewrite 2Rmult_0_l; try apply Rle_refl. - now left; apply Rmult_lt_compat_l. -Qed. -#[global] -Hint Resolve Rmult_le_compat_l: real. - -Lemma Rmult_le_compat_r : - forall r r1 r2, 0 <= r -> r1 <= r2 -> r1 * r <= r2 * r. -Proof. - now intros r r1 r2 H; rewrite 2(Rmult_comm _ r); apply Rmult_le_compat_l. -Qed. -#[global] -Hint Resolve Rmult_le_compat_r: real. - -Lemma Rmult_ge_compat_l : - forall r r1 r2, r >= 0 -> r1 >= r2 -> r * r1 >= r * r2. -Proof. - now intros r r1 r2 I%Rge_le J%Rge_le; apply Rle_ge, Rmult_le_compat_l. -Qed. - -Lemma Rmult_ge_compat_r : - forall r r1 r2, r >= 0 -> r1 >= r2 -> r1 * r >= r2 * r. -Proof. - now intros r r1 r2; rewrite 2(Rmult_comm _ r); apply Rmult_ge_compat_l. -Qed. - -Lemma Rmult_le_compat : - forall r1 r2 r3 r4, - 0 <= r1 -> 0 <= r3 -> r1 <= r2 -> r3 <= r4 -> r1 * r3 <= r2 * r4. -Proof. - intros r1 r2 r3 r4 H1 H2 I J; apply (Rle_trans _ (r2 * r3)). - - now apply Rmult_le_compat_r. - - assert (H3 : 0 <= r2) by now apply (Rle_trans _ r1). - now apply Rmult_le_compat_l. -Qed. -#[global] -Hint Resolve Rmult_le_compat: real. - -Lemma Rmult_le_pos : forall r1 r2, 0 <= r1 -> 0 <= r2 -> 0 <= r1 * r2. -Proof. - now intros r1 r2 I I'; rewrite <-(Rmult_0_l 0); apply Rmult_le_compat; - try apply Rle_refl. -Qed. - -Lemma Rmult_ge_compat : - forall r1 r2 r3 r4, - r2 >= 0 -> r4 >= 0 -> r1 >= r2 -> r3 >= r4 -> r1 * r3 >= r2 * r4. -Proof. - intros r1 r2 r3 r4 H1%Rge_le H2%Rge_le I%Rge_le J%Rge_le; apply Rle_ge. - now apply Rmult_le_compat. -Qed. - -Lemma Rmult_ge_0_gt_0_lt_compat : - forall r1 r2 r3 r4, - r3 >= 0 -> r2 > 0 -> r1 < r2 -> r3 < r4 -> r1 * r3 < r2 * r4. -Proof. - intros r1 r2 r3 r4 H1%Rge_le H2 I J; apply (Rle_lt_trans _ (r2 * r3)). - - now apply Rmult_le_compat_r; try apply (Rlt_le r1). - - now apply Rmult_lt_compat_l. -Qed. - -Lemma Rmult_gt_0_lt_compat : - forall r1 r2 r3 r4, - r3 > 0 -> r2 > 0 -> r1 < r2 -> r3 < r4 -> r1 * r3 < r2 * r4. -Proof. now intros r1 r2 r3 r4 H1%Rgt_ge; apply Rmult_ge_0_gt_0_lt_compat. Qed. - -Lemma Rmult_le_0_lt_compat : - forall r1 r2 r3 r4, - 0 <= r1 -> 0 <= r3 -> r1 < r2 -> r3 < r4 -> r1 * r3 < r2 * r4. -Proof. - intros r1 r2 r3 r4 H1 H2 I J; apply Rle_lt_trans with (r2 * r3). - - now apply Rlt_le in I; apply Rmult_le_compat_r. - - assert (H3 : 0 < r2) by now apply (Rle_lt_trans _ r1). - now apply Rmult_lt_compat_l. -Qed. - -(** *** Contravariant compatibility *) - -Lemma Rmult_le_compat_neg_l : - forall r r1 r2, r <= 0 -> r1 <= r2 -> r * r2 <= r * r1. -Proof. - intros r r1 r2 I%Ropp_le_contravar J; rewrite Ropp_0 in I. - now apply Ropp_le_cancel; rewrite 2Ropp_mult_distr_l; apply Rmult_le_compat_l. -Qed. -#[global] -Hint Resolve Rmult_le_compat_neg_l: real. - -Lemma Rmult_le_ge_compat_neg_l : - forall r r1 r2, r <= 0 -> r1 <= r2 -> r * r1 >= r * r2. -Proof. now intros r r1 r2 H I; apply Rle_ge, Rmult_le_compat_neg_l. Qed. -#[global] -Hint Resolve Rmult_le_ge_compat_neg_l: real. - -Lemma Rmult_lt_gt_compat_neg_l : - forall r r1 r2, r < 0 -> r1 < r2 -> r * r1 > r * r2. -Proof. - intros r r1 r2 I%Ropp_lt_contravar J; rewrite Ropp_0 in I. - now apply Ropp_lt_cancel; rewrite 2Ropp_mult_distr_l; apply Rmult_lt_compat_l. -Qed. - -(** *** Sign of multiplication *) - -Lemma Rmult_lt_0_compat : forall r1 r2, 0 < r1 -> 0 < r2 -> 0 < r1 * r2. -Proof. - now intros r1 r2 I J; rewrite <-(Rmult_0_l 0); apply Rmult_le_0_lt_compat; - try apply Rle_refl. -Qed. - -Lemma Rmult_gt_0_compat : forall r1 r2, r1 > 0 -> r2 > 0 -> r1 * r2 > 0. -Proof. exact Rmult_lt_0_compat. Qed. - -Definition Rmult_pos_pos := Rmult_gt_0_compat. - -Lemma Rmult_neg_neg : forall r1 r2, r1 < 0 -> r2 < 0 -> r1 * r2 > 0. -Proof. - intros r1 r2 H1%Ropp_lt_contravar H2%Ropp_lt_contravar. - rewrite Ropp_0 in H1, H2; rewrite <-Rmult_opp_opp. - now apply Rmult_lt_0_compat. -Qed. - -Lemma Rmult_neg_pos : forall r1 r2, r1 < 0 -> r2 > 0 -> r1 * r2 < 0. -Proof. - intros r1 r2 H1 H2. - now rewrite <-(Rmult_0_r r1); apply Rmult_lt_gt_compat_neg_l. -Qed. - -Lemma Rmult_pos_neg : forall r1 r2, r1 > 0 -> r2 < 0 -> r1 * r2 < 0. -Proof. now intros r1 r2 H1 H2; rewrite Rmult_comm; apply Rmult_neg_pos. Qed. - -Lemma Rmult_pos_cases : - forall r1 r2, r1 * r2 > 0 -> (r1 > 0 /\ r2 > 0) \/ (r1 < 0 /\ r2 < 0). -Proof. - intros r1 r2. - destruct (Rtotal_order r1 0) as [Hlt1 | [-> | Hgt1]]; cycle 1. - - now intros H; exfalso; rewrite Rmult_0_l in H; apply (Rlt_irrefl 0). - - destruct (Rtotal_order r2 0) as [Hlt2 | [-> | Hgt2]]; cycle 1. - + now intros H; exfalso; rewrite Rmult_0_r in H; apply (Rlt_irrefl 0). - + now intros _; left. - + intros H; exfalso; apply (Rgt_not_le (r1 * r2) 0); try easy. - now left; apply Rmult_pos_neg. - - destruct (Rtotal_order r2 0) as [Hlt2 | [-> | Hgt2]]; cycle 1. - + now intros H; exfalso; rewrite Rmult_0_r in H; apply (Rlt_irrefl 0). - + intros H; exfalso; apply (Rgt_not_le (r1 * r2) 0); try easy. - now left; apply Rmult_neg_pos. - + now intros _; right. -Qed. - -Lemma Rmult_neg_cases : - forall r1 r2, r1 * r2 < 0 -> (r1 > 0 /\ r2 < 0) \/ (r1 < 0 /\ r2 > 0). -Proof. - intros r1 r2 H%Ropp_lt_contravar%Rlt_gt. - rewrite Ropp_0, Ropp_mult_distr_l in H. - apply Rmult_pos_cases in H as - [[H1%Ropp_lt_contravar H2] | [H1%Ropp_lt_contravar H2]]. - - now right; split; [| assumption]; rewrite Ropp_involutive, Ropp_0 in H1. - - now left; split; [| assumption]; rewrite Ropp_involutive, Ropp_0 in H1. -Qed. - -(** *** Order and square function *) - -Lemma Rle_0_sqr : forall r, 0 <= Rsqr r. -Proof. - unfold Rsqr; intros r. - destruct (Rlt_le_dec r 0) as [Hneg%Ropp_lt_contravar%Rlt_le | Hge0]. - - rewrite Ropp_0 in Hneg; rewrite <-Rmult_opp_opp, <-(Rmult_0_l 0). - now apply Rmult_le_compat; try apply Rle_refl. - - now rewrite <-(Rmult_0_l 0); apply Rmult_le_compat; try apply Rle_refl. -Qed. - -Lemma Rlt_0_sqr : forall r, r <> 0 -> 0 < Rsqr r. -Proof. - now intros r Hr; destruct (Rle_0_sqr r) as [Hle | Eq%eq_sym%Rsqr_0_uniq]. -Qed. -#[global] -Hint Resolve Rle_0_sqr Rlt_0_sqr: real. - -Lemma Rplus_sqr_eq_0 : - forall r1 r2, Rsqr r1 + Rsqr r2 = 0 -> r1 = 0 /\ r2 = 0. -Proof. - assert (E : forall r1 r2, Rsqr r1 + Rsqr r2 = 0 -> r1 = 0). { - intros r1 r2 H; apply Rsqr_0_uniq, Rplus_eq_0_l with (3 := H); - now apply Rle_0_sqr. - } - intros r1 r2 H; split. - - now apply (E _ r2). - - now rewrite Rplus_comm in H; apply (E _ r1). -Qed. - -(** *** Zero is less than one *) - -Lemma Rlt_0_1 : 0 < 1. -Proof. now rewrite <-(Rmult_1_r 1), <-Rsqr_def; apply Rlt_0_sqr, R1_neq_R0. Qed. -#[global] -Hint Resolve Rlt_0_1: real. - -Lemma Rle_0_1 : 0 <= 1. -Proof. left; exact Rlt_0_1. Qed. - -(** *** Sign of inverse *) - -Lemma Rinv_0_lt_compat : forall r, 0 < r -> 0 < / r. -Proof. - intros r Hr. - destruct (Rlt_or_le 0 (/ r)) as [Hlt | Hle]; try easy. - exfalso; apply (Rle_not_lt 0 1); try apply Rlt_0_1. - rewrite <-(Rinv_l r), <-(Rmult_0_r (/ r)); cycle 1. - { now apply not_eq_sym, Rlt_not_eq. } - now apply Rlt_le in Hr; apply Rmult_le_compat_neg_l. -Qed. -#[global] -Hint Resolve Rinv_0_lt_compat: real. - -Lemma Rinv_lt_0_compat : forall r, r < 0 -> / r < 0. -Proof. - intros r H%Ropp_lt_contravar; apply Ropp_lt_cancel. - now rewrite Ropp_0 in H |- *; rewrite <-Rinv_opp; apply Rinv_0_lt_compat. -Qed. -#[global] -Hint Resolve Rinv_lt_0_compat: real. - -(** *** Cancellation in inequalities of products *) - -Lemma Rmult_lt_reg_l : forall r r1 r2, 0 < r -> r * r1 < r * r2 -> r1 < r2. -Proof. - intros r r1 r2 Hr I%(Rmult_lt_compat_l (/ r)); try now apply Rinv_0_lt_compat. - rewrite <-2(Rmult_assoc (/ r)), Rinv_l, 2Rmult_1_l in I; try easy. - now apply not_eq_sym, Rlt_not_eq. -Qed. - -Lemma Rmult_lt_reg_r : forall r r1 r2 : R, 0 < r -> r1 * r < r2 * r -> r1 < r2. -Proof. - intros r r1 r2 H I; apply (Rmult_lt_reg_l r); try easy. - now rewrite 2(Rmult_comm r). -Qed. - -Lemma Rmult_gt_reg_l : forall r r1 r2, 0 < r -> r * r1 < r * r2 -> r1 < r2. -Proof. now intros r r1 r2; apply Rmult_lt_reg_l. Qed. - -Lemma Rmult_gt_reg_r : forall r r1 r2, r > 0 -> r1 * r > r2 * r -> r1 > r2. -Proof. now intros r r1 r2; apply Rmult_lt_reg_r. Qed. - -Lemma Rmult_le_reg_l : forall r r1 r2, 0 < r -> r * r1 <= r * r2 -> r1 <= r2. -Proof. - intros r r1 r2 Hr [I | E]. - - now left; apply (Rmult_lt_reg_l r). - - now apply Rlt_not_eq, not_eq_sym in Hr; right; apply (Rmult_eq_reg_l r). -Qed. - -Lemma Rmult_le_reg_r : forall r r1 r2, 0 < r -> r1 * r <= r2 * r -> r1 <= r2. -Proof. - intros r r1 r2 Hr I; rewrite 2(Rmult_comm _ r) in I. - now apply (Rmult_le_reg_l r). -Qed. - -(** *** Order and inverse *) - -Lemma Rinv_0_lt_contravar : forall r1 r2, 0 < r1 -> r1 < r2 -> / r2 < / r1. -Proof. - intros r1 r2 H1 I. - assert (H2 : 0 < r2) by now apply (Rlt_trans _ r1). - apply (Rmult_lt_reg_l r2); try easy. - rewrite Rinv_r by now apply Rgt_not_eq. - apply (Rmult_lt_reg_r r1); try easy. - rewrite Rmult_assoc, Rinv_l by now apply Rgt_not_eq. - now rewrite Rmult_1_r, Rmult_1_l. -Qed. -#[global] -Hint Resolve Rinv_0_lt_contravar: real. - -Lemma Rinv_lt_0_contravar : forall r1 r2, r2 < 0 -> r1 < r2 -> / r2 < / r1. -Proof. - intros r1 r2 H2%Ropp_lt_contravar I%Ropp_lt_contravar. - apply Ropp_lt_cancel. - rewrite Ropp_0 in H2. - now rewrite <-2(Rinv_opp); apply Rinv_0_lt_contravar. -Qed. -#[global] -Hint Resolve Rinv_lt_0_contravar: real. - -(* TODO: We may want to deprecate it but cannot because of the hint used in - external libs (the stdlib can already be compiled without it) *) -Lemma Rinv_1_lt_contravar : forall r1 r2, 1 <= r1 -> r1 < r2 -> / r2 < / r1. -Proof. - intros r1 r2 H1 I. - apply Rlt_le_trans with (1 := Rlt_0_1) in H1. - now apply Rinv_0_lt_contravar. -Qed. -#[global] -Hint Resolve Rinv_1_lt_contravar: real. - -Lemma Rinv_lt_contravar : forall r1 r2, 0 < r1 * r2 -> r1 < r2 -> / r2 < / r1. -Proof. - intros r1 r2 [[H1 H2] | [H1 H2]]%Rmult_pos_cases. - - now apply Rinv_0_lt_contravar. - - now apply Rinv_lt_0_contravar. -Qed. - -(* NOTE: keeping inconsistent variable names for backward compatibility. *) -Lemma Rinv_le_contravar : - forall x y, 0 < x -> x <= y -> / y <= / x. -Proof. - intros r1 r2 H1 [H2 | ->]. - - now apply Rlt_le, Rinv_0_lt_contravar. - - now apply Rle_refl. -Qed. - -(** *** Sign of inverse *) - -Lemma Rinv_pos : forall r, r > 0 -> / r > 0. -Proof. now intros r; apply Rinv_0_lt_compat. Qed. - -Lemma Rinv_neg : forall r, r < 0 -> / r < 0. -Proof. now intros r; apply Rinv_lt_0_compat. Qed. - -(*********************************************************) -(** ** Order and subtraction *) -(*********************************************************) - -Lemma Rlt_minus : forall r1 r2, r1 < r2 -> r1 - r2 < 0. -Proof. - unfold Rminus; intros r1 r2 H%(Rplus_lt_compat_r (-r2)). - now rewrite Rplus_opp_r in H. -Qed. -#[global] -Hint Resolve Rlt_minus: real. - -Lemma Rgt_minus : forall r1 r2, r1 > r2 -> r1 - r2 > 0. -Proof. - unfold Rminus; intros r1 r2 H%(Rplus_lt_compat_r (-r2)). - now rewrite Rplus_opp_r in H. -Qed. - -Lemma Rle_minus : forall r1 r2, r1 <= r2 -> r1 - r2 <= 0. -Proof. - unfold Rminus; intros r1 r2 H%(Rplus_le_compat_r (-r2)). - now rewrite Rplus_opp_r in H. -Qed. - -Lemma Rge_minus : forall r1 r2, r1 >= r2 -> r1 - r2 >= 0. -Proof. - unfold Rminus; intros r1 r2 H%(Rplus_ge_compat_r (-r2)). - now rewrite Rplus_opp_r in H. -Qed. - -Lemma Rminus_lt : forall r1 r2, r1 - r2 < 0 -> r1 < r2. -Proof. - unfold Rminus; intros r1 r2 H. - now apply (Rplus_lt_reg_r (-r2)); rewrite Rplus_opp_r. -Qed. - -Lemma Rminus_gt : forall r1 r2, r1 - r2 > 0 -> r1 > r2. -Proof. - unfold Rminus; intros r1 r2 H. - now apply (Rplus_lt_reg_r (-r2)); rewrite Rplus_opp_r. -Qed. - -Lemma Rlt_minus_0 : forall r1 r2, r1 - r2 < 0 <-> r1 < r2. -Proof. - intros r1 r2; split. - - now apply Rminus_lt. - - now apply Rlt_minus. -Qed. - -Lemma Rlt_0_minus : forall r1 r2, 0 < r2 - r1 <-> r1 < r2. -Proof. - intros r1 r2; split. - - now apply Rminus_gt. - - now apply Rgt_minus. -Qed. - -Lemma Rminus_le : forall r1 r2, r1 - r2 <= 0 -> r1 <= r2. -Proof. - unfold Rminus; intros r1 r2 H. - now apply (Rplus_le_reg_r (-r2)); rewrite Rplus_opp_r. -Qed. - -Lemma Rminus_ge : forall r1 r2, r1 - r2 >= 0 -> r1 >= r2. -Proof. - unfold Rminus; intros r1 r2 H. - now apply (Rplus_ge_reg_r (-r2)); rewrite Rplus_opp_r. -Qed. - -Lemma Rgt_minus_pos : forall r1 r2, 0 < r2 -> r1 > r1 - r2. -Proof. - intros r1 r2 H%Ropp_lt_contravar; rewrite Ropp_0 in H. - now rewrite <-(Rplus_0_r r1) at 1; apply (Rplus_lt_compat_l r1). -Qed. - -(*********************************************************) -(** ** Division *) -(*********************************************************) - -Lemma Rdiv_def : forall r1 r2, r1 / r2 = r1 * / r2. -Proof. now unfold Rdiv. Qed. - -Lemma Rdiv_eq_compat_l : forall r r1 r2, r1 = r2 -> r / r1 = r / r2. -Proof. - now unfold Rdiv; intros r r1 r2 H%Rinv_eq_compat; apply Rmult_eq_compat_l. -Qed. - -Lemma Rdiv_eq_compat_r : forall r r1 r2, r1 = r2 -> r1 / r = r2 / r. -Proof. now unfold Rdiv; intros r r1 r2; apply Rmult_eq_compat_r. Qed. - -Lemma Rdiv_eq_reg_l : forall r r1 r2, r / r1 = r / r2 -> r <> 0 -> r1 = r2. -Proof. - now unfold Rdiv; intros r r1 r2 H H'; apply Rinv_eq_reg, (Rmult_eq_reg_l r). -Qed. - -Lemma Rdiv_eq_reg_r : forall r r1 r2, r1 / r = r2 / r -> r <> 0 -> r1 = r2. -Proof. - now unfold Rdiv; intros r r1 r2 H H'%Rinv_neq_0_compat; - apply (Rmult_eq_reg_r (/ r)). -Qed. - -Lemma Rdiv_0_l : forall r, 0 / r = 0. -Proof. now unfold Rdiv; intros r; rewrite Rmult_0_l. Qed. - -Lemma Rdiv_0_r : forall r, r / 0 = 0. -Proof. now unfold Rdiv; intros r; rewrite Rinv_0, Rmult_0_r. Qed. - -Lemma Rdiv_1_l : forall r, 1 / r = / r. -Proof. now unfold Rdiv; intros r; rewrite Rmult_1_l. Qed. - -Lemma Rdiv_1_r : forall r, r / 1 = r. -Proof. now unfold Rdiv; intros r; rewrite Rinv_1, Rmult_1_r. Qed. - -Lemma Rdiv_diag : forall r, r <> 0 -> r / r = 1. -Proof. now unfold Rdiv; intros r H; rewrite Rinv_r. Qed. - -Lemma Rdiv_diag_eq : forall r1 r2, r2 <> 0 -> r1 = r2 -> r1 / r2 = 1. -Proof. now intros r1 r2 H <-; apply Rdiv_diag. Qed. - -Lemma Rmult_div_l : forall r1 r2, r2 <> 0 -> r1 * r2 / r2 = r1. -Proof. - now unfold Rdiv; intros r1 r2 H; rewrite Rmult_assoc, Rinv_r, Rmult_1_r. -Qed. - -Lemma Rmult_div_r : forall r1 r2, r1 <> 0 -> r1 * r2 / r1 = r2. -Proof. now intros r1 r2 H; rewrite Rmult_comm, Rmult_div_l. Qed. - -Lemma Rmult_div_assoc : forall r1 r2 r3, r1 * (r2 / r3) = r1 * r2 / r3. -Proof. now unfold Rdiv; intros r1 r2 r3; rewrite Rmult_assoc. Qed. - -Lemma Rmult_div_swap : forall r1 r2 r3, r1 * r2 / r3 = r1 / r3 * r2. -Proof. - unfold Rdiv; intros r1 r2 r3. - now rewrite Rmult_assoc, (Rmult_comm r2), <-Rmult_assoc. -Qed. - -Lemma Rdiv_diag_uniq : forall r1 r2, r1 / r2 = 1 -> r1 = r2. -Proof. - intros r1 r2; destruct (Req_dec r2 0) as [-> | Hn0]. - - now intros H; rewrite Rdiv_0_r in H; exfalso; apply R1_neq_R0; symmetry. - - intros H%(Rmult_eq_compat_r r2). - now rewrite <-Rmult_div_swap, Rmult_div_l, Rmult_1_l in H. -Qed. - -Lemma Rdiv_mult_distr : forall r1 r2 r3, r1 / (r2 * r3) = r1 / r2 / r3. -Proof. now unfold Rdiv; intros r1 r2 r3; rewrite Rinv_mult, Rmult_assoc. Qed. - -Lemma Rdiv_mult_r_r : - forall r r1 r2, r <> 0 -> (r1 * r) / (r2 * r) = r1 / r2. -Proof. - intros r r1 r2 H. - rewrite <-Rmult_div_assoc, (Rmult_comm r2), Rdiv_mult_distr. - now rewrite Rdiv_diag by exact H; rewrite Rdiv_1_l, Rdiv_def. -Qed. - -Lemma Rdiv_mult_l_r : - forall r r1 r2, r <> 0 -> (r * r1) / (r2 * r) = r1 / r2. -Proof. - now intros r r1 r2; rewrite (Rmult_comm r); apply Rdiv_mult_r_r. -Qed. - -Lemma Rdiv_mult_l_l : - forall r r1 r2, r <> 0 -> (r * r1) / (r * r2) = r1 / r2. -Proof. - now intros r r1 r2; rewrite (Rmult_comm _ r2); apply Rdiv_mult_l_r. -Qed. - -Lemma Rdiv_mult_r_l : - forall r r1 r2, r <> 0 -> (r1 * r) / (r * r2) = r1 / r2. -Proof. - now intros r r1 r2; rewrite (Rmult_comm r1); apply Rdiv_mult_l_l. -Qed. - -Lemma Ropp_div_distr_l : forall r1 r2, - (r1 / r2) = - r1 / r2. -Proof. unfold Rdiv; intros r1 r2; now apply Ropp_mult_distr_l. Qed. - -Lemma Ropp_div_distr_r : forall r1 r2, r1 / - r2 = - (r1 / r2). -Proof. now unfold Rdiv; intros r1 r2; rewrite Ropp_mult_distr_r, Rinv_opp. Qed. - -(* NOTE: keeping inconsistent variable names for backward compatibility. *) -Lemma Rdiv_plus_distr : forall a b c, (a + b) / c = a / c + b / c. -Proof. intros r1 r2 r; now apply Rmult_plus_distr_r. Qed. - -(* NOTE: keeping inconsistent variable names for backward compatibility. *) -Lemma Rdiv_minus_distr : forall a b c, (a - b) / c = a / c - b / c. -Proof. - unfold Rminus; intros r1 r2 r. - now rewrite Ropp_div_distr_l; apply Rdiv_plus_distr. -Qed. - -(* NOTE: keeping inconsistent variable names for backward compatibility. *) -Lemma Rinv_div x y : / (x / y) = y / x. -Proof. now unfold Rdiv; rewrite Rinv_mult, Rinv_inv; apply Rmult_comm. Qed. - -(* NOTE: keeping inconsistent variable names for backward compatibility. *) -Lemma Rdiv_lt_0_compat : forall a b, 0 < a -> 0 < b -> 0 < a / b. -Proof. - intros r1 r2 r1_pos r2_pos. - now apply (Rmult_lt_0_compat r1 (/ r2) r1_pos), Rinv_0_lt_compat. -Qed. - -Lemma Rdiv_opp_l : forall r1 r2, - r1 / r2 = - (r1 / r2). -Proof. now intros r1 r2; rewrite Ropp_div_distr_l. Qed. - -(* NOTE: keeping inconsistent variable names for backward compatibility. *) -Lemma Rdiv_opp_r : forall x y, x / - y = - (x / y). -Proof. now intros r1 r2; rewrite Ropp_div_distr_r. Qed. - -(** *** Sign of division *) - -Lemma Rdiv_pos_pos : forall r1 r2, r1 > 0 -> r2 > 0 -> r1 / r2 > 0. -Proof. now unfold Rdiv; intros r1 r2 H H'%Rinv_pos; apply Rmult_pos_pos. Qed. - -Lemma Rdiv_pos_neg : forall r1 r2, r1 > 0 -> r2 < 0 -> r1 / r2 < 0. -Proof. now unfold Rdiv; intros r1 r2 H H'%Rinv_neg; apply Rmult_pos_neg. Qed. - -Lemma Rdiv_neg_pos : forall r1 r2, r1 < 0 -> r2 > 0 -> r1 / r2 < 0. -Proof. now unfold Rdiv; intros r1 r2 H H'%Rinv_pos; apply Rmult_neg_pos. Qed. - -Lemma Rdiv_neg_neg : forall r1 r2, r1 < 0 -> r2 < 0 -> r1 / r2 > 0. -Proof. now unfold Rdiv; intros r1 r2 H H'%Rinv_neg; apply Rmult_neg_neg. Qed. - -Lemma Rdiv_pos_cases : - forall r1 r2 : R, r1 / r2 > 0 -> r1 > 0 /\ r2 > 0 \/ r1 < 0 /\ r2 < 0. -Proof. - unfold Rdiv; intros r1 r2 [[I J%Rinv_pos] | [I J%Rinv_neg]]%Rmult_pos_cases. - - now left; rewrite Rinv_inv in J. - - now right; rewrite Rinv_inv in J. -Qed. - -(*********************************************************) -(** ** Miscellaneous *) -(*********************************************************) - -(* This can't be moved to "Order and addition" because of Rlt_0_1 which - is proved using a sign rule. *) - -(* TODO: We may want to deprecate it but cannot because of the hint used in - external libs (the stdlib can already be compiled without it) *) -Lemma Rle_lt_0_plus_1 : forall r, 0 <= r -> 0 < r + 1. -Proof. - intros r H; apply Rlt_le_trans with (1 := Rlt_0_1). - rewrite <-(Rplus_0_l 1) at 1. - apply Rplus_le_compat; try easy. -Qed. -#[global] -Hint Resolve Rle_lt_0_plus_1: real. - -(* TODO: We may want to deprecate it but cannot because of the hint used in - external libs (the stdlib can already be compiled without it) *) -Lemma Rlt_plus_1 : forall r, r < r + 1. -Proof. - intros r; rewrite <-(Rplus_0_r r) at 1; apply Rplus_le_lt_compat. - - now apply Rle_refl. - - exact Rlt_0_1. -Qed. -#[global] -Hint Resolve Rlt_plus_1: real. - -Lemma Rlt_0_2 : 0 < 2. -Proof. - assert (H : 0 < 1) by exact Rlt_0_1. - apply (Rlt_trans _ 1); try easy. - replace 2 with (1 + 1) by reflexivity. - rewrite <-(Rplus_0_l 1) at 1. - apply Rplus_lt_le_compat; try easy. -Qed. - -Lemma Rplus_diag : forall r, r + r = 2 * r. -Proof. - intros r; replace 2 with (1 + 1) by reflexivity. - now rewrite Rmult_plus_distr_r, Rmult_1_l. -Qed. - -Lemma Rplus_half_diag : forall r, r / 2 + r / 2 = r. -Proof. - intros r; rewrite <-Rdiv_plus_distr, Rplus_diag, Rmult_div_r; [easy |]. - now apply not_eq_sym, Rlt_not_eq, Rlt_0_2. -Qed. - -Lemma Rlt_half_plus : forall r1 r2, r1 < r2 -> r1 < (r1 + r2) / 2 < r2. -Proof. - pose proof Rlt_0_2 as two_gt_0. - assert (E : forall r r', (r + r') / 2 * 2 = r + r'). { - now intros r r'; rewrite Rdiv_plus_distr, Rmult_plus_distr_r, - <-2Rmult_div_swap, 2Rmult_div_l by (now apply Rgt_not_eq). - } - intros r1 r2 r1_lt_r2; split; apply Rmult_lt_reg_r with (1 := two_gt_0); - rewrite E, Rmult_comm, <-Rplus_diag. - - now apply Rplus_lt_compat_l. - - now apply Rplus_lt_compat_r. -Qed. - -Lemma Rle_half_plus : forall r1 r2, r1 <= r2 -> r1 <= (r1 + r2) / 2 <= r2. -Proof. - intros r1 r2 [I | ->]. - - now split; left; apply (Rlt_half_plus r1 r2). - - now split; rewrite Rdiv_plus_distr, Rplus_half_diag; apply Rle_refl. -Qed. - -Lemma Rexists_between : forall r1 r2, r1 < r2 -> exists r, r1 < r < r2. -Proof. - intros r1 r2 r1_lt_r2. - exists ((r1 + r2) / 2). - now apply Rlt_half_plus. -Qed. - -Lemma Rle_plus_epsilon : - forall r1 r2, (forall eps:R, 0 < eps -> r1 <= r2 + eps) -> r1 <= r2. -Proof. - intros r1 r2 H. - destruct (Rle_or_lt r1 r2) as [r1_le_r2 | r1_gt_r2]; [assumption |]. - exfalso. - destruct (Rexists_between r2 r1) as [r [r2_lt_r r_lt_r1]]; [assumption |]. - apply (Rlt_irrefl r1), (Rle_lt_trans _ r); [| assumption]. - rewrite <-(Rplus_minus r2 r). - now apply H, Rgt_minus. -Qed. - -(** Remark : a sigma-type version, called [completeness] is in [Raxioms.v] *) -Lemma upper_bound_thm : - forall E : R -> Prop, - bound E -> (exists x : R, E x) -> exists m : R, is_lub E m. -Proof. - intros E E_bnd E_inhab. - destruct (completeness E E_bnd E_inhab) as [x xlub]. - now exists x. -Qed. - -(*********************************************************) -(** ** Injection from [nat] to [R] *) -(*********************************************************) - -Lemma S_INR : forall n, INR (S n) = INR n + 1. -Proof. - intros [| n']. - - now cbv -[IZR]; rewrite Rplus_0_l. - - reflexivity. -Qed. - -Lemma INR_0 : INR 0 = 0. -Proof. reflexivity. Qed. - -Lemma INR_1 : INR 1 = 1. -Proof. reflexivity. Qed. - -Lemma plus_INR : forall n m, INR (n + m) = INR n + INR m. -Proof. - intros n m; induction m as [| m IHm]. - - now rewrite Nat.add_0_r, INR_0, Rplus_0_r. - - now rewrite Nat.add_succ_r, 2S_INR, IHm, Rplus_assoc. -Qed. -#[global] -Hint Resolve plus_INR: real. - -Lemma minus_INR : forall n m, (m <= n)%nat -> INR (n - m) = INR n - INR m. -Proof. - intros n m le; induction le as [|n' H' IH]. - - now rewrite Nat.sub_diag, Rminus_diag. - - rewrite Nat.sub_succ_l by assumption. - now rewrite 2S_INR, IH, Rplus_minus_swap. -Qed. -#[global] -Hint Resolve minus_INR: real. - -Lemma mult_INR : forall n m:nat, INR (n * m) = INR n * INR m. -Proof. - intros n m; induction m as [| m IH]. - - now rewrite Nat.mul_0_r, INR_0, Rmult_0_r. - - now rewrite Nat.mul_succ_r, S_INR, plus_INR, IH, - Rmult_plus_distr_l, Rmult_1_r. -Qed. -#[global] -Hint Resolve mult_INR: real. - -Lemma pow_INR : forall m n:nat, INR (m ^ n) = pow (INR m) n. -Proof. - now intros m n; induction n as [| n IH]; [| simpl; rewrite mult_INR, IH]. -Qed. - -Lemma lt_0_INR : forall n:nat, (0 < n)%nat -> 0 < INR n. -Proof. - induction n as [| [|n ] IHn]; intros H. - - now inversion H. - - now rewrite INR_1; apply Rlt_0_1. - - rewrite S_INR; apply Rplus_lt_0_compat. - + now apply IHn, Nat.lt_0_succ. - + exact Rlt_0_1. -Qed. -#[global] -Hint Resolve lt_0_INR: real. - -Lemma lt_INR : forall n m:nat, (n < m)%nat -> INR n < INR m. -Proof. - induction n as [| n IH]; intros m H. - - now apply lt_0_INR. - - destruct m as [| m']. - + now apply Nat.nlt_0_r in H. - + rewrite 2S_INR. - now apply (Rplus_lt_compat_r 1), IH, Nat.succ_lt_mono. -Qed. -#[global] -Hint Resolve lt_INR: real. - -Lemma lt_1_INR : forall n:nat, (1 < n)%nat -> 1 < INR n. -Proof. now apply lt_INR. Qed. -#[global] -Hint Resolve lt_1_INR: real. - -Lemma pos_INR_nat_of_P : forall p:positive, 0 < INR (Pos.to_nat p). -Proof. now intros p; apply lt_0_INR, Pos2Nat.is_pos. Qed. -#[global] -Hint Resolve pos_INR_nat_of_P: real. - -Lemma pos_INR : forall n:nat, 0 <= INR n. -Proof. - intros [| n]. - - now rewrite INR_0; apply Rle_refl. - - now left; apply lt_0_INR, Nat.lt_0_succ. -Qed. -#[global] -Hint Resolve pos_INR: real. - -Lemma INR_lt : forall n m:nat, INR n < INR m -> (n < m)%nat. -Proof. - intros n m. generalize dependent n. - induction m as [| m IH]; intros n H. - - now exfalso; apply Rlt_not_le with (1 := H), pos_INR. - - destruct n as [| n]. - + apply Nat.lt_0_succ. - + apply ->Nat.succ_lt_mono; apply IH. - rewrite 2!S_INR in H. - now apply Rplus_lt_reg_r with (1 := H). -Qed. -#[global] -Hint Resolve INR_lt: real. - -Lemma le_INR : forall n m:nat, (n <= m)%nat -> INR n <= INR m. -Proof. - intros n m [I | ->]%Nat.le_lteq. - - now left; apply lt_INR. - - now right. -Qed. -#[global] -Hint Resolve le_INR: real. - -Lemma INR_not_0 : forall n:nat, INR n <> 0 -> n <> 0%nat. -Proof. now intros n H ->; apply H, INR_0. Qed. -#[global] -Hint Immediate INR_not_0: real. - -Lemma not_0_INR : forall n:nat, n <> 0%nat -> INR n <> 0. -Proof. - intros [| n'] H. - - now exfalso; apply H. - - rewrite S_INR; apply Rgt_not_eq. - now apply Rplus_le_lt_0_compat with (1 := (pos_INR n')); apply Rlt_0_1. -Qed. -#[global] -Hint Resolve not_0_INR: real. - -Lemma not_INR : forall n m:nat, n <> m -> INR n <> INR m. -Proof. - intros n m [Hlt | Hgt]%Nat.lt_gt_cases. - - now apply Rlt_not_eq, lt_INR. - - now apply not_eq_sym, Rlt_not_eq, lt_INR. -Qed. -#[global] -Hint Resolve not_INR: real. - -Lemma INR_eq : forall n m:nat, INR n = INR m -> n = m. -Proof. - intros n m HR. - destruct (Nat.eq_dec n m) as [E | NE]; [assumption |]. - now apply not_INR in NE. -Qed. - -Lemma INR_le : forall n m:nat, INR n <= INR m -> (n <= m)%nat. -Proof. - intros n m [I | E]. - - now apply Nat.lt_le_incl, INR_lt. - - now apply Nat.eq_le_incl, INR_eq. -Qed. -#[global] -Hint Resolve INR_le: real. - -Lemma not_1_INR : forall n:nat, n <> 1%nat -> INR n <> 1. -Proof. now intros n; apply not_INR. Qed. -#[global] -Hint Resolve not_1_INR: real. - -(*********************************************************) -(** ** Injection from [positive] to [R] *) -(*********************************************************) - -(* NOTES: - - IPR is defined in Rdefinitions, using an auxiliary recursive function - IPR_2. - - positive is the type of positive integers represented in binary. Its 3 - constructors are - * xH : positive, represents 1 - * xO : positive -> positive, add a bit 0 at the end (i.e. multiply by 2) - * xI : positive -> positive, add a bit 1 at the end - (i.e. multiply by 2 and add 1) - 1 is a notation for xH, p~0 is a notation for (xO p), - p~1 is a notation for (xI p). - - definition of positive (and Z) is in Numbers/BinNums.v - - operations and lemmas are in PArith (modules Pos and Pos2Nat) - - Pos.peano_ind gives an alternative induction principle using Pos.succ. *) -Lemma IPR_2_xH : IPR_2 xH = 2. -Proof. reflexivity. Qed. - -Lemma IPR_2_xO : forall p : positive, IPR_2 (p~0) = 2 * (IPR_2 p). -Proof. now intros p. Qed. - -Lemma IPR_2_xI : forall p : positive, IPR_2 (p~1) = 2 * (IPR_2 p) + 2. -Proof. - intros p; simpl. - rewrite (Rplus_comm _ 2), <-(Rmult_1_r 2) at 1. - now rewrite <-(Rmult_plus_distr_l 2). -Qed. - -Lemma IPR_xH : IPR xH = 1. -Proof. reflexivity. Qed. - -Lemma IPR_IPR_2 : forall p : positive, 2 * IPR p = IPR_2 p. -Proof. - unfold IPR; intros [p | p |]. - - rewrite IPR_2_xI, Rplus_comm, Rmult_plus_distr_l. - now rewrite <-(Rmult_1_r 2) at 4. - - now rewrite IPR_2_xO. - - now rewrite IPR_2_xH, Rmult_1_r. -Qed. - -Lemma IPR_xO : forall p : positive, IPR (p~0) = 2 * IPR p. -Proof. - intros p. - apply (Rmult_eq_reg_l 2); cycle 1. - { apply not_eq_sym, Rlt_not_eq, Rlt_0_2. } - now rewrite 2IPR_IPR_2, IPR_2_xO. -Qed. - -Lemma IPR_xI : forall p : positive, IPR (p~1) = 2 * IPR p + 1. -Proof. - intros p. - apply (Rmult_eq_reg_l 2); cycle 1. - { apply not_eq_sym, Rlt_not_eq, Rlt_0_2. } - now rewrite 2IPR_IPR_2, IPR_2_xI, Rmult_plus_distr_l, Rmult_1_r. -Qed. - -Lemma INR_IPR : forall p, INR (Pos.to_nat p) = IPR p. -Proof. - induction p as [p IH | p IH |]. - - now rewrite Pos2Nat.inj_xI, IPR_xI, S_INR, mult_INR, IH. - - now rewrite Pos2Nat.inj_xO, mult_INR, IPR_xO, IH. - - reflexivity. -Qed. - -Lemma succ_IPR : forall p, IPR (Pos.succ p) = IPR 1 + IPR p. -Proof. - induction p as [p IH |p IH |]. - - simpl; rewrite IPR_xO, IPR_xI, IH, IPR_xH, Rmult_plus_distr_l. - now rewrite (Rplus_comm 1), (Rplus_assoc _ 1), Rplus_diag, Rplus_comm. - - now simpl; rewrite IPR_xI, IPR_xO, IPR_xH, Rplus_comm. - - now simpl; rewrite IPR_xO, <-Rplus_diag. -Qed. - -Lemma plus_IPR : forall p q, IPR (p + q) = IPR p + IPR q. -Proof. - intros p q; induction q as [| q IH] using Pos.peano_ind. - - now rewrite Pos.add_1_r, succ_IPR, Rplus_comm. - - rewrite Pos.add_succ_r, 2succ_IPR, IH. - now rewrite <-Rplus_assoc, (Rplus_comm (IPR 1)), Rplus_assoc. -Qed. - -Lemma minus_IPR : forall p q, (q < p)%positive -> IPR (p - q) = IPR p - IPR q. -Proof. - induction p as [| p IH] using Pos.peano_ind. - - now intros q H%Pos.nlt_1_r. - - intros q H; destruct q as [| q] using Pos.peano_ind. - + now rewrite succ_IPR, <-Pos.add_1_r, Pos.add_sub, IPR_xH, Rplus_minus_l. - + rewrite 2succ_IPR, IPR_xH, Rminus_plus_l_l. - rewrite <-2Pos.add_1_r, (Pos.add_comm q). - rewrite Pos.sub_add_distr by (now rewrite Pos.add_1_l, Pos.add_1_r). - now rewrite Pos.add_sub, IH by (now apply Pos.succ_lt_mono). -Qed. - -Lemma mult_IPR : forall p q:positive, IPR (p * q) = IPR p * IPR q. -Proof. - intros p q; induction q as [| q IH] using Pos.peano_ind. - - now rewrite Pos.mul_1_r, IPR_xH, Rmult_1_r. - - now rewrite Pos.mul_succ_r, succ_IPR, plus_IPR, IH, - Rmult_plus_distr_l, Rmult_1_r. -Qed. - -Lemma pow_IPR (q p: positive) : IPR (q ^ p) = pow (IPR q) (Pos.to_nat p). -Proof. - induction p as [| p IH] using Pos.peano_ind. - - now simpl; rewrite Pos.pow_1_r, Rmult_1_r. - - now rewrite Pos.pow_succ_r, mult_IPR, Pos2Nat.inj_succ; simpl; rewrite IH. -Qed. - -Lemma IPR_ge_1 : forall p:positive, 1 <= IPR p. -Proof. - pose proof (Rlt_0_1) as H; pose proof (Rlt_0_2) as H'. - induction p as [p IH | p IH |]. - - rewrite IPR_xI, <-(Rplus_0_l 1) at 1; apply Rplus_le_compat_r. - apply Rmult_le_pos; try now left. - now apply (Rle_trans _ 1); try apply IH; left. - - rewrite IPR_xO, <-Rplus_diag, <-(Rplus_0_l 1); apply Rplus_le_compat; try easy. - now apply (Rle_trans _ 1); try apply IH; left. - - now rewrite IPR_xH; apply Rle_refl. -Qed. - -Lemma IPR_gt_0 : forall p:positive, 0 < IPR p. -Proof. - now intros p; apply (Rlt_le_trans _ 1); [apply Rlt_0_1 | apply IPR_ge_1]. -Qed. - -Lemma lt_IPR : forall p q:positive, (p < q)%positive -> IPR p < IPR q. -Proof. - pose proof IPR_gt_0 as H; pose proof Rlt_0_2 as H'. - induction p as [| p IH] using Pos.peano_ind; intros q Hq. - - rewrite IPR_xH; induction q as [q IH' | [ q | q |] IH' |]. - + rewrite IPR_xI, <-(Rplus_0_l 1) at 1. - now apply Rplus_lt_compat_r, Rmult_lt_0_compat. - + rewrite IPR_xO, <-(Rplus_0_l 1), <-Rplus_diag. - apply Rplus_lt_compat; try easy; apply IH'; constructor. - + rewrite IPR_xO, <-(Rplus_0_l 1), <-Rplus_diag. - apply Rplus_lt_compat; try easy; apply IH'; constructor. - + rewrite IPR_xO, IPR_xH. - rewrite <-(Rplus_0_l 1) at 1; rewrite <-Rplus_diag. - now apply Rplus_lt_compat_r, Rlt_0_1. - + discriminate. - - destruct q as [| q'] using Pos.peano_ind. - + now exfalso; apply (Pos.nlt_1_r (Pos.succ p)). - + now rewrite 2 succ_IPR; apply Rplus_lt_compat_l, IH, Pos.succ_lt_mono. -Qed. - -Lemma lt_1_IPR : forall p:positive, (1 < p)%positive -> 1 < IPR p. -Proof. now apply lt_IPR. Qed. - -Lemma IPR_lt : forall p q:positive, IPR p < IPR q -> (p < q)%positive. -Proof. - intros p q. generalize dependent p. - induction q as [| q IH] using Pos.peano_ind; intros p H. - - rewrite IPR_xH in H; exfalso; apply (Rle_not_lt (IPR p) 1); try easy. - now apply IPR_ge_1. - - destruct p as [| p] using Pos.peano_ind. - + exact (Pos.lt_1_succ q). - + apply ->Pos.succ_lt_mono; apply IH. - rewrite 2!succ_IPR in H. - now apply Rplus_lt_reg_l with (1 := H). -Qed. - -Lemma le_IPR : forall p q:positive, (p <= q)%positive -> IPR p <= IPR q. -Proof. - intros p q [I | ->]%Pos.le_lteq. - - now left; apply lt_IPR. - - now right. -Qed. - -Lemma IPR_not_1 : forall p:positive, IPR p <> 1 -> p <> 1%positive. -Proof. now intros p H ->; apply H, IPR_xH. Qed. - -Lemma not_1_IPR : forall p:positive, p <> 1%positive -> IPR p <> 1. -Proof. - intros p H; destruct p as [| p] using Pos.peano_ind. - - now exfalso; apply H. - - rewrite succ_IPR; apply Rgt_not_eq. - rewrite <-(Rplus_0_r 1), IPR_xH. - now apply Rplus_gt_compat_l, IPR_gt_0. -Qed. - -Lemma not_IPR : forall p q:positive, p <> q -> IPR p <> IPR q. -Proof. - intros p q. - destruct (Pos.lt_total p q) as [Hlt | [Eq | Hgt]]; intros H. - - now apply Rlt_not_eq, lt_IPR. - - easy. - - now apply not_eq_sym, Rlt_not_eq, lt_IPR. -Qed. - -Lemma IPR_eq : forall p q:positive, IPR p = IPR q -> p = q. -Proof. - intros p q HR. - destruct (Pos.eq_dec p q) as [E | NE]; [assumption |]. - now apply not_IPR in NE. -Qed. - -Lemma IPR_le : forall p q:positive, IPR p <= IPR q -> (p <= q)%positive. -Proof. - intros p q [I | E]. - - now apply Pos.lt_le_incl, IPR_lt. - - now apply IPR_eq in E as ->; apply Pos.le_refl. -Qed. - -(*********************************************************) -(** ** Injection from [Z] to [R] *) -(*********************************************************) -(* NOTES: - - Z has 3 constructors : - * Z0 : Z, representing 0 - * Zpos : positive -> Z, for a positive integer - * Zneg : positive -> Z, for a negative integer - - Definition of Z is in Numbers.BinNums - - Operations and lemmas are in ZArith (modules Z, Z2Nat, Nat2Z) -*) -Lemma IZN : forall n:Z, (0 <= n)%Z -> exists m : nat, n = Z.of_nat m. -Proof. now intros n H%Z2Nat.id; exists (Z.to_nat n). Qed. - -Lemma INR_IZR_INZ : forall n:nat, INR n = IZR (Z.of_nat n). -Proof. - intros [| n]. - - reflexivity. - - simpl Z.of_nat; unfold IZR; simpl IZR. - now rewrite <-INR_IPR, SuccNat2Pos.id_succ. -Qed. - -Lemma IZR_NEG : forall p, IZR (Zneg p) = Ropp (IZR (Zpos p)). -Proof. reflexivity. Qed. - -(** The three following lemmas map the default form of numerical - constants to their representation in terms of the axioms of - [R]. This can be a useful intermediate representation for reifying - to another axiomatics of the reals. It is however generally more - convenient to keep constants represented under an [IZR z] form when - working within [R]. *) - -Lemma IZR_POS_xO : forall p, IZR (Zpos (p~0)) = 2 * (IZR (Zpos p)). -Proof. - now unfold IZR, IPR; intros [p | p |]; simpl; try easy; rewrite Rmult_1_r. -Qed. - -Lemma IZR_POS_xI : forall p, IZR (Zpos (xI p)) = 1 + 2 * IZR (Zpos p). -Proof. - now unfold IZR, IPR; intros [p | p |]; simpl; try easy; rewrite Rmult_1_r. -Qed. - -Lemma plus_IZR_NEG_POS : - forall p q:positive, IZR (Zpos p + Zneg q) = IZR (Zpos p) + IZR (Zneg q). -Proof. - unfold IZR; intros p q; simpl; rewrite Z.pos_sub_spec. - destruct (Pos.compare_spec p q) as [-> | Lt | Gt]. - - now rewrite Rplus_opp_r. - - rewrite minus_IPR by (exact Lt); rewrite Ropp_minus_distr. - now unfold Rminus; rewrite Rplus_comm. - - now rewrite minus_IPR by (exact Gt); unfold Rminus. -Qed. - -Lemma plus_IZR : forall n m:Z, IZR (n + m) = IZR n + IZR m. -Proof. - intros [| p | p] [| q | q]; - rewrite ?Rplus_0_l, ?Rplus_0_r, ?Z.add_0_l, ?Z.add_0_r; try easy. - - now unfold IZR; simpl; apply plus_IPR. - - now apply plus_IZR_NEG_POS. - - now rewrite Rplus_comm, Z.add_comm; apply plus_IZR_NEG_POS. - - now unfold IZR; simpl; rewrite plus_IPR, Ropp_plus_distr. -Qed. - -Lemma mult_IZR : forall n m:Z, IZR (n * m) = IZR n * IZR m. -Proof. - intros [| p | p] [| q | q]; - rewrite ?Rmult_0_l, ?Rmult_0_r, ?Z.mul_0_l, ?Z.mul_0_r; try easy; - unfold IZR; simpl. - - now apply mult_IPR. - - now rewrite mult_IPR, Ropp_mult_distr_r. - - now rewrite mult_IPR, Ropp_mult_distr_l. - - now rewrite mult_IPR, Rmult_opp_opp. -Qed. - -Lemma pow_IZR : forall z n, pow (IZR z) n = IZR (Z.pow z (Z.of_nat n)). -Proof. - intros z; induction n as [| n IH]. - - reflexivity. - - rewrite Nat2Z.inj_succ, Z.pow_succ_r by (apply Nat2Z.is_nonneg). - now simpl; rewrite IH, mult_IZR. -Qed. - -Lemma succ_IZR : forall n:Z, IZR (Z.succ n) = IZR n + 1. -Proof. now intros n; unfold Z.succ; apply plus_IZR. Qed. - -Lemma opp_IZR : forall n:Z, IZR (- n) = - IZR n. -Proof. - intros [| p | p]; unfold IZR; simpl. - - now replace R0 with 0 by reflexivity; rewrite Ropp_0. - - reflexivity. - - now rewrite Ropp_involutive. -Qed. - -Definition Ropp_Ropp_IZR := opp_IZR. - -Lemma minus_IZR : forall n m:Z, IZR (n - m) = IZR n - IZR m. -Proof. - now intros n m; unfold Z.sub, Rminus; rewrite <-opp_IZR; apply plus_IZR. -Qed. - -Lemma Z_R_minus : forall n m:Z, IZR n - IZR m = IZR (n - m). -Proof. - intros z1 z2; unfold Rminus, Z.sub. - now rewrite <-(Ropp_Ropp_IZR z2); symmetry; apply plus_IZR. -Qed. - -Lemma lt_0_IZR : forall n:Z, 0 < IZR n -> (0 < n)%Z. -Proof. - intros [| p | p]; simpl; intros H. - - destruct (Rlt_irrefl _ H). - - now constructor. - - destruct (Rlt_not_le _ _ H); unfold IZR; replace R0 with 0 by reflexivity. - rewrite <-Ropp_0; apply Ropp_le_contravar, Rle_trans with (1 := Rle_0_1). - now apply IPR_ge_1. -Qed. - -Lemma lt_IZR : forall n m:Z, IZR n < IZR m -> (n < m)%Z. -Proof. - intros z1 z2 H; apply Z.lt_0_sub. - apply lt_0_IZR. - rewrite <- Z_R_minus. - exact (Rgt_minus (IZR z2) (IZR z1) H). -Qed. - -Lemma eq_IZR_R0 : forall n:Z, IZR n = 0 -> n = 0%Z. -Proof. - intros [| p | p]; unfold IZR; simpl; intros H; try easy. - - exfalso; apply (Rlt_not_eq 0 (IPR p)); try easy; apply IPR_gt_0. - - exfalso; apply (Rlt_not_eq 0 (IPR p)); try apply IPR_gt_0; symmetry. - replace R0 with 0 in H by reflexivity; rewrite <-Ropp_0 in H. - now apply Ropp_eq_reg. -Qed. - -Lemma eq_IZR : forall n m:Z, IZR n = IZR m -> n = m. -Proof. - intros n m H%(Rminus_diag_eq); rewrite Z_R_minus in H. - now apply Zminus_eq, eq_IZR_R0. -Qed. - -Lemma not_0_IZR : forall n:Z, n <> 0%Z -> IZR n <> 0. -Proof. now intros z H H'; apply H, eq_IZR. Qed. - -Lemma le_0_IZR : forall n:Z, 0 <= IZR n -> (0 <= n)%Z. -Proof. - unfold Rle; intros n [H | ->%eq_sym%eq_IZR_R0]. - - now apply Z.lt_le_incl, lt_0_IZR. - - now apply Z.le_refl. -Qed. - -Lemma le_IZR : forall n m:Z, IZR n <= IZR m -> (n <= m)%Z. -Proof. - unfold Rle; intros n m [H%lt_IZR | ->%eq_IZR]. - - now apply Z.lt_le_incl. - - now apply Z.le_refl. -Qed. - -(* NOTE: 1 is a notation for (IZR 1) *) -Lemma le_IZR_R1 : forall n:Z, IZR n <= 1 -> (n <= 1)%Z. -Proof. now intros n; apply le_IZR. Qed. - -Lemma IZR_ge : forall n m:Z, (n >= m)%Z -> IZR n >= IZR m. -Proof. - intros n m H; apply Rnot_lt_ge; intros H2%lt_IZR. - now apply (Zle_not_lt n m). -Qed. - -Lemma IZR_le : forall n m:Z, (n <= m)%Z -> IZR n <= IZR m. -Proof. now intros m n H%Z.le_ge; apply Rge_le, IZR_ge. Qed. - -Lemma IZR_lt : forall n m:Z, (n < m)%Z -> IZR n < IZR m. -Proof. - intros n m H; apply Rnot_le_lt; intros [I | E%eq_IZR]. - - now apply (Z.lt_irrefl m), Z.lt_trans with (2 := H), lt_IZR. - - now apply (Z.lt_irrefl m); rewrite E at 1. -Qed. - -Lemma eq_IZR_contrapositive : forall n m:Z, n <> m -> IZR n <> IZR m. -Proof. now intros n m H1 H2%eq_IZR. Qed. - -#[global] -Hint Extern 0 (IZR _ <= IZR _) => apply IZR_le, Zle_bool_imp_le, eq_refl : real. -#[global] -Hint Extern 0 (IZR _ >= IZR _) => apply Rle_ge, IZR_le, Zle_bool_imp_le, eq_refl : real. -#[global] -Hint Extern 0 (IZR _ < IZR _) => apply IZR_lt, eq_refl : real. -#[global] -Hint Extern 0 (IZR _ > IZR _) => apply IZR_lt, eq_refl : real. -Lemma Private_Zeq_bool_neq : forall x y : Z, (x =? y) = false -> x <> y. -Proof. intros. rewrite <-Z.eqb_eq. congruence. Qed. -#[global] -Hint Extern 0 (IZR _ <> IZR _) => apply eq_IZR_contrapositive, Private_Zeq_bool_neq, eq_refl : real. - -Lemma one_IZR_lt1 : forall n:Z, -1 < IZR n < 1 -> n = 0%Z. -Proof. - intros n [H1 H2]; apply Z.le_antisymm. - - now apply Z.lt_succ_r; apply lt_IZR. - - replace 0%Z with (Z.succ (-1)) by reflexivity. - now apply Z.le_succ_l, lt_IZR. -Qed. - -Lemma one_IZR_r_R1 : - forall r (n m:Z), r < IZR n <= r + 1 -> r < IZR m <= r + 1 -> n = m. -Proof. - intros r n m [H1 H2] [H3 H4]; apply Zminus_eq, one_IZR_lt1. - rewrite <-Z_R_minus; split. - - replace (-1) with (r - (r + 1)) by - (now rewrite Rminus_plus_distr, Rminus_diag, Rminus_0_l). - unfold Rminus; apply Rplus_lt_le_compat; [assumption |]. - now apply Ropp_le_contravar. - - replace 1 with (r + 1 - r) by (now apply Rplus_minus_l). - unfold Rminus; apply Rplus_le_lt_compat; try easy. - now apply Ropp_lt_contravar. -Qed. - -Lemma INR_unbounded : forall A, exists n, INR n > A. -Proof. - intros A; destruct (Rle_or_lt 0 A) as [A_ge0 | A_lt0]; cycle 1. - { now exists 0%nat; simpl. } - destruct (archimed A) as [ar1 _]. - exists (Z.to_nat (up A)). - rewrite INR_IZR_INZ, Z2Nat.id; try assumption. - apply le_IZR, Rle_trans with (1 := A_ge0). - now left. -Qed. - -Lemma INR_archimed : - forall eps A : R, eps > 0 -> exists n : nat, (INR n) * eps > A. -Proof. - intros eps A Heps; destruct (INR_unbounded (A / eps)) as [N HN]. - exists N. - apply (Rmult_gt_reg_r (/ eps)). - { now apply Rinv_0_lt_compat. } - now rewrite Rmult_assoc, Rinv_r by (now apply Rgt_not_eq); rewrite Rmult_1_r. -Qed. - -Lemma R_rm : ring_morph - 0%R 1%R Rplus Rmult Rminus Ropp eq - 0%Z 1%Z Zplus Zmult Zminus Z.opp Z.eqb IZR. -Proof. - constructor; try easy. - - exact plus_IZR. - - exact minus_IZR. - - exact mult_IZR. - - exact opp_IZR. - - now intros x y H; f_equal; apply Z.eqb_eq. -Qed. - -(* NOTE: keeping inconsistent variable names for backward compatibility. *) -#[deprecated(use=Z.eqb_eq, since="9.0")] -Lemma Zeq_bool_IZR : forall x y:Z, IZR x = IZR y -> Z.eqb x y = true. -Proof. now intros n m H; apply Z.eqb_eq, eq_IZR. Qed. - -Local Lemma Private_Zeqb_IZR : forall x y:Z, IZR x = IZR y -> Z.eqb x y = true. -Proof. intros. apply Z.eqb_eq, eq_IZR; trivial. Qed. - -Add Field RField : Rfield - (completeness Private_Zeqb_IZR, morphism R_rm, constants [IZR_tac], power_tac R_power_theory [Rpow_tac]). - -(*********************************************************) -(** * Definitions of new types *) -(*********************************************************) - -Record nonnegreal : Type := mknonnegreal - {nonneg :> R; cond_nonneg : 0 <= nonneg}. - -Record posreal : Type := mkposreal {pos :> R; cond_pos : 0 < pos}. - -Record nonposreal : Type := mknonposreal - {nonpos :> R; cond_nonpos : nonpos <= 0}. - -Record negreal : Type := mknegreal {neg :> R; cond_neg : neg < 0}. - -Record nonzeroreal : Type := mknonzeroreal - {nonzero :> R; cond_nonzero : nonzero <> 0}. - -(** ** A few common instances *) - -Lemma pos_half_prf : 0 < / 2. -Proof. now apply Rinv_0_lt_compat, Rlt_0_2. Qed. - -Definition posreal_one := mkposreal (1) (Rlt_0_1). -Definition posreal_half := mkposreal (/ 2) pos_half_prf. - -(** * Compatibility *) - -Notation prod_neq_R0 := Rmult_integral_contrapositive_currified (only parsing). -Notation minus_Rgt := Rminus_gt (only parsing). -Notation minus_Rge := Rminus_ge (only parsing). -Notation plus_le_is_le := Rplus_le_reg_pos_r (only parsing). -Notation plus_lt_is_lt := Rplus_lt_reg_pos_r (only parsing). -Notation INR_lt_1 := lt_1_INR (only parsing). -Notation lt_INR_0 := lt_0_INR (only parsing). -Notation not_nm_INR := not_INR (only parsing). -Notation INR_pos := pos_INR_nat_of_P (only parsing). -Notation not_INR_O := INR_not_0 (only parsing). -Notation not_O_INR := not_0_INR (only parsing). -Notation not_O_IZR := not_0_IZR (only parsing). -Notation le_O_IZR := le_0_IZR (only parsing). -Notation lt_O_IZR := lt_0_IZR (only parsing). - -Notation tech_Rplus := Rplus_le_lt_0_neq_0 (only parsing). -Notation tech_Rgt_minus := Rgt_minus_pos (only parsing). -Notation le_epsilon := Rle_plus_epsilon (only parsing). -Notation completeness_weak := upper_bound_thm (only parsing). -Notation Req_EM_T := Req_dec_T (only parsing). -Notation Rinv_r_simpl_r := Rmult_inv_m_id_r (only parsing). -Notation Rinv_r_simpl_l := Rmult_inv_r_id_l (only parsing). -Notation Rinv_r_simpl_m := Rmult_inv_r_id_m (only parsing). -Notation Rplus_eq_R0 := Rplus_eq_0 (only parsing). - -Lemma Rinv_involutive_depr : forall r, r <> 0 -> / / r = r. -Proof. now intros r _; apply Rinv_inv. Qed. -#[deprecated(since="8.16",note="Use Rinv_inv.")] -Notation Rinv_involutive := Rinv_involutive_depr (only parsing). - -Lemma Rinv_mult_distr_depr : - forall r1 r2, r1 <> 0 -> r2 <> 0 -> / (r1 * r2) = / r1 * / r2. -Proof. now intros r1 r2 _ _; apply Rinv_mult. Qed. -#[deprecated(since="8.16",note="Use Rinv_mult.")] -Notation Rinv_mult_distr := Rinv_mult_distr_depr (only parsing). - -Lemma Ropp_inv_permute_depr : forall r, r <> 0 -> - / r = / - r. -Proof. now intros r H; apply eq_sym, Rinv_opp. Qed. -#[deprecated(since="8.16",note="Use Rinv_opp.")] -Notation Ropp_inv_permute := Ropp_inv_permute_depr (only parsing). - -Lemma Ropp_div_den_depr : forall x y, y <> 0 -> x / - y = - (x / y). -Proof. now intros r1 r2 _; apply Ropp_div_distr_r. Qed. -#[deprecated(since="8.16",note="Use Rdiv_opp_r.")] -Notation Ropp_div_den := Ropp_div_den_depr (only parsing). - -Lemma inser_trans_R_depr : - forall r1 r2 r3 r4, r1 <= r2 < r3 -> {r1 <= r2 < r4} + {r4 <= r2 < r3}. -Proof. - intros r1 r2 r3 r4 [H1 H2]; destruct (Rlt_le_dec r2 r4) as [Hlt | Hle]. - - now left. - - now right. -Qed. -#[deprecated(since="8.19")] -Notation inser_trans_R := inser_trans_R_depr (only parsing). - -Lemma Ropp_minus_distr'_depr : forall r1 r2, - (r2 - r1) = r1 - r2. -Proof. now intros r1 r2; apply Ropp_minus_distr. Qed. -#[deprecated(since="8.19",note="Use Ropp_minus_distr instead.")] -Notation Ropp_minus_distr' := (fun r1 r2 => (Ropp_minus_distr r2 r1)) (only parsing). - -#[deprecated(since="8.19",note="Use Rminus_diag instead.")] -Notation Rminus_eq_0 := (fun x => Rminus_diag x) (only parsing). - -Lemma sum_inequa_Rle_lt_depr : - forall a x b c y d:R, - a <= x -> x < b -> c < y -> y <= d -> a + c < x + y < b + d. -Proof. - intros; split. - - apply Rlt_le_trans with (a + y); auto with real. - - apply Rlt_le_trans with (b + y); auto with real. -Qed. -#[deprecated(since="8.19")] -Notation sum_inequa_Rle_lt := sum_inequa_Rle_lt_depr (only parsing). - -Lemma Rle_Rinv_depr : forall x y:R, 0 < x -> 0 < y -> x <= y -> / y <= / x. -Proof. now intros r1 r2 H _; apply Rinv_le_contravar. Qed. -#[deprecated(since="8.19",note="Use Rinv_le_contravar.")] -Notation Rle_Rinv := Rle_Rinv_depr (only parsing). - -#[deprecated(since="8.19",note="Use the bidirectional version Rlt_0_minus instead.")] -Notation Rlt_Rminus := (fun a b => proj2 (Rlt_0_minus a b)) (only parsing). - -#[deprecated(since="8.19",note="Use the bidirectional version Rlt_0_minus instead.")] -Notation Rminus_gt_0_lt := (fun a b => proj1 (Rlt_0_minus a b)) (only parsing). - -#[deprecated(since="8.19",note="Use Rdiv_opp_l.")] -Notation Ropp_div := (fun x y => Rdiv_opp_l x y) (only parsing). - -Lemma Rplus_sqr_eq_0_l_depr : forall r1 r2, Rsqr r1 + Rsqr r2 = 0 -> r1 = 0. -Proof. - now intros r1 r2 H; apply Rsqr_0_uniq, (Rplus_eq_0_l _ (r2Ā²)); try easy; - apply Rle_0_sqr. -Qed. -#[deprecated(since="8.19",note="Use Rplus_sqr_eq_0.")] -Notation Rplus_sqr_eq_0_l := Rplus_sqr_eq_0_l_depr (only parsing). - -#[deprecated(since="8.19",note="Use Rplus_diag.")] -Notation double := (fun r1 => eq_sym (Rplus_diag r1)) (only parsing). - -#[deprecated(since="8.19",note="Use Rplus_half_diag.")] -Notation double_var := (fun r1 => eq_sym (Rplus_half_diag r1)) (only parsing). - -#[deprecated(since="8.19",note="Use eq_IZR_contrapositive.")] -Notation IZR_neq := (fun z1 z2 => (eq_IZR_contrapositive z1 z2)) (only parsing). - -Lemma S_O_plus_INR_depr : forall n, INR (1 + n) = INR 1 + INR n. -Proof. - intros [| n']. - - now rewrite INR_0, Rplus_0_r, Nat.add_0_r. - - rewrite Rplus_comm; reflexivity. -Qed. -#[deprecated(since="8.19")] -Notation S_O_plus_INR := S_O_plus_INR_depr (only parsing). - -Lemma single_z_r_R1_depr : - forall r (n m:Z), - r < IZR n -> IZR n <= r + 1 -> r < IZR m -> IZR m <= r + 1 -> n = m. -Proof. now intros r n m Hlt Hle Hlt' Hle'; apply (one_IZR_r_R1 r). Qed. -#[deprecated(since="8.19")] -Notation single_z_r_R1 := single_z_r_R1_depr (only parsing). - -Lemma tech_single_z_r_R1_depr : - forall r (n:Z), - r < IZR n -> - IZR n <= r + 1 -> - (exists s : Z, s <> n /\ r < IZR s /\ IZR s <= r + 1) -> False. -Proof. now intros r z H1 H2 [s [H3 [H4 H5]]]; apply H3, (one_IZR_r_R1 r). Qed. -#[deprecated(since="8.19")] -Notation tech_single_z_r_R1 := tech_single_z_r_R1_depr (only parsing). - -Lemma Rinv_mult_simpl_depr : - forall r1 r2 r3, r1 <> 0 -> r1 * / r2 * (r3 * / r1) = r3 * / r2. -Proof. - intros r1 r2 r3 r1n0. - rewrite (Rmult_comm r3 (/ r1)), Rmult_assoc, <-(Rmult_assoc (/ r2)). - rewrite (Rmult_comm r3), (Rmult_comm (/ r2)), <-2Rmult_assoc. - now rewrite Rinv_r, Rmult_1_l. -Qed. -#[deprecated(since="8.19")] -Notation Rinv_mult_simpl := Rinv_mult_simpl_depr. diff --git a/stdlib/theories/Reals/RList.v b/stdlib/theories/Reals/RList.v deleted file mode 100644 index 8563c6854844..000000000000 --- a/stdlib/theories/Reals/RList.v +++ /dev/null @@ -1,739 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* 0 - | a :: l1 => - match l1 with - | nil => a - | a' :: l2 => Rmax a (MaxRlist l1) - end - end. - -Fixpoint MinRlist (l:list R) : R := - match l with - | nil => 1 - | a :: l1 => - match l1 with - | nil => a - | a' :: l2 => Rmin a (MinRlist l1) - end - end. - -Lemma MaxRlist_P1 : forall (l:list R) (x:R), In x l -> x <= MaxRlist l. -Proof. - intros; induction l as [| r l Hrecl]. - - simpl in H; elim H. - - induction l as [| r0 l Hrecl0]. - + simpl in H; elim H; intro. - * simpl; right; symmetry; assumption. - * elim H0. - + replace (MaxRlist (r :: r0 :: l)) with (Rmax r (MaxRlist (r0 :: l))). - * simpl in H; decompose [or] H. - -- rewrite H0; apply RmaxLess1. - -- unfold Rmax; case (Rle_dec r (MaxRlist (r0 :: l))); intro. - ++ apply Hrecl; simpl; tauto. - ++ apply Rle_trans with (MaxRlist (r0 :: l)); - [ apply Hrecl; simpl; tauto | left; auto with real ]. - -- unfold Rmax; case (Rle_dec r (MaxRlist (r0 :: l))); intro. - ++ apply Hrecl; simpl; tauto. - ++ apply Rle_trans with (MaxRlist (r0 :: l)); - [ apply Hrecl; simpl; tauto | left; auto with real ]. - * reflexivity. -Qed. - -Fixpoint AbsList (l:list R) (x:R) : list R := - match l with - | nil => nil - | a :: l' => (Rabs (a - x) / 2) :: (AbsList l' x) - end. - -Lemma MinRlist_P1 : forall (l:list R) (x:R), In x l -> MinRlist l <= x. -Proof. - intros; induction l as [| r l Hrecl]. - - simpl in H; elim H. - - induction l as [| r0 l Hrecl0]. - + simpl in H; elim H; intro. - * simpl; right; assumption. - * elim H0. - + replace (MinRlist (r :: r0 :: l)) with (Rmin r (MinRlist (r0 :: l))). - * simpl in H; decompose [or] H. - -- rewrite H0; apply Rmin_l. - -- unfold Rmin; case (Rle_dec r (MinRlist (r0 :: l))); intro. - ++ apply Rle_trans with (MinRlist (r0 :: l)). - ** assumption. - ** apply Hrecl; simpl; tauto. - ++ apply Hrecl; simpl; tauto. - -- apply Rle_trans with (MinRlist (r0 :: l)). - ++ apply Rmin_r. - ++ apply Hrecl; simpl; tauto. - * reflexivity. -Qed. - -Lemma AbsList_P1 : - forall (l:list R) (x y:R), In y l -> In (Rabs (y - x) / 2) (AbsList l x). -Proof. - intros; induction l as [| r l Hrecl]. - - elim H. - - simpl; simpl in H; elim H; intro. - + left; rewrite H0; reflexivity. - + right; apply Hrecl; assumption. -Qed. - -Lemma MinRlist_P2 : - forall l:list R, (forall y:R, In y l -> 0 < y) -> 0 < MinRlist l. -Proof. - intros; induction l as [| r l Hrecl]. - - apply Rlt_0_1. - - induction l as [| r0 l Hrecl0]. - + simpl; apply H; simpl; tauto. - + replace (MinRlist (r :: r0 :: l)) with (Rmin r (MinRlist (r0 :: l))). - * unfold Rmin; case (Rle_dec r (MinRlist (r0 :: l))); intro. - -- apply H; simpl; tauto. - -- apply Hrecl; intros; apply H; simpl; simpl in H0; tauto. - * reflexivity. -Qed. - -Lemma AbsList_P2 : - forall (l:list R) (x y:R), - In y (AbsList l x) -> exists z : R, In z l /\ y = Rabs (z - x) / 2. -Proof. - intros; induction l as [| r l Hrecl]. - - elim H. - - elim H; intro. - + exists r; split. - * simpl; tauto. - * symmetry. - assumption. - + assert (H1 := Hrecl H0); elim H1; intros; elim H2; clear H2; intros; - exists x0; simpl; simpl in H2; tauto. -Qed. - -Lemma MaxRlist_P2 : - forall l:list R, (exists y : R, In y l) -> In (MaxRlist l) l. -Proof. - intros; induction l as [| r l Hrecl]. - - simpl in H; elim H; trivial. - - induction l as [| r0 l Hrecl0]. - + simpl; left; reflexivity. - + change (In (Rmax r (MaxRlist (r0 :: l))) (r :: r0 :: l)); - unfold Rmax; case (Rle_dec r (MaxRlist (r0 :: l))); - intro. - * right; apply Hrecl; exists r0; left; reflexivity. - * left; reflexivity. -Qed. - -Fixpoint pos_Rl (l:list R) (i:nat) : R := - match l with - | nil => 0 - | a :: l' => match i with - | O => a - | S i' => pos_Rl l' i' - end - end. - -Lemma pos_Rl_P1 : - forall (l:list R) (a:R), - (0 < length l)%nat -> - pos_Rl (a :: l) (length l) = pos_Rl l (pred (length l)). -Proof. - intros; induction l as [| r l Hrecl]; - [ elim (Nat.nlt_0_r _ H) - | simpl; case (length l); [ reflexivity | intro; reflexivity ] ]. -Qed. - -Lemma pos_Rl_P2 : - forall (l:list R) (x:R), - In x l <-> (exists i : nat, (i < length l)%nat /\ x = pos_Rl l i). -Proof. - intros; induction l as [| r l Hrecl]. - - split; intro; - [ elim H | elim H; intros; elim H0; intros; elim (Nat.nlt_0_r _ H1) ]. - - split; intro. - + elim H; intro. - * exists 0%nat; split; - [ simpl; apply Nat.lt_0_succ | simpl; symmetry; apply H0 ]. - * elim Hrecl; intros; assert (H3 := H1 H0); elim H3; intros; elim H4; intros; - exists (S x0); split; - [ simpl; apply -> Nat.succ_lt_mono; assumption | simpl; assumption ]. - + elim H; intros; elim H0; intros; destruct (zerop x0) as [->|]. - * simpl in H2; left; symmetry; assumption. - * right; elim Hrecl; intros H4 H5; apply H5; assert (H6 : S (pred x0) = x0). - -- apply Nat.lt_succ_pred with 0%nat; assumption. - -- exists (pred x0); split; - [ simpl in H1; apply Nat.succ_lt_mono; rewrite H6; assumption - | rewrite <- H6 in H2; simpl in H2; assumption ]. -Qed. - -Lemma Rlist_P1 : - forall (l:list R) (P:R -> R -> Prop), - (forall x:R, In x l -> exists y : R, P x y) -> - exists l' : list R, - length l = length l' /\ - (forall i:nat, (i < length l)%nat -> P (pos_Rl l i) (pos_Rl l' i)). -Proof. - intros; induction l as [| r l Hrecl]. - - exists nil; intros; split; - [ reflexivity | intros; simpl in H0; elim (Nat.nlt_0_r _ H0) ]. - - assert (H0 : In r (r :: l)). - + simpl; left; reflexivity. - + assert (H1 := H _ H0); - assert (H2 : forall x:R, In x l -> exists y : R, P x y). - * intros; apply H; simpl; right; assumption. - * assert (H3 := Hrecl H2); elim H1; intros; elim H3; intros; exists (x :: x0); - intros; elim H5; clear H5; intros; split. - -- simpl; rewrite H5; reflexivity. - -- intros; destruct (zerop i) as [->|]. - ++ simpl; assumption. - ++ assert (H9 : i = S (pred i)). - ** symmetry; apply Nat.lt_succ_pred with 0%nat; assumption. - ** rewrite H9; simpl; apply H6; simpl in H7; apply Nat.succ_lt_mono; rewrite <- H9; - assumption. -Qed. - -Definition ordered_Rlist (l:list R) : Prop := - forall i:nat, (i < pred (length l))%nat -> pos_Rl l i <= pos_Rl l (S i). - -Fixpoint insert (l:list R) (x:R) : list R := - match l with - | nil => x :: nil - | a :: l' => - match Rle_dec a x with - | left _ => a :: (insert l' x) - | right _ => x :: l - end - end. - -Fixpoint cons_ORlist (k l:list R) : list R := - match k with - | nil => l - | a :: k' => cons_ORlist k' (insert l a) - end. - -Fixpoint mid_Rlist (l:list R) (x:R) : list R := - match l with - | nil => nil - | a :: l' => ((x + a) / 2) :: (mid_Rlist l' a) - end. - -Definition Rtail (l:list R) : list R := - match l with - | nil => nil - | a :: l' => l' - end. - -Definition FF (l:list R) (f:R -> R) : list R := - match l with - | nil => nil - | a :: l' => map f (mid_Rlist l' a) - end. - -Lemma RList_P0 : - forall (l:list R) (a:R), - pos_Rl (insert l a) 0 = a \/ pos_Rl (insert l a) 0 = pos_Rl l 0. -Proof. - intros; induction l as [| r l Hrecl]; - [ left; reflexivity - | simpl; case (Rle_dec r a); intro; - [ right; reflexivity | left; reflexivity ] ]. -Qed. - -Lemma RList_P1 : - forall (l:list R) (a:R), ordered_Rlist l -> ordered_Rlist (insert l a). -Proof. - intros; induction l as [| r l Hrecl]. - - simpl; unfold ordered_Rlist; intros; simpl in H0; - elim (Nat.nlt_0_r _ H0). - - simpl; case (Rle_dec r a); intro. - + assert (H1 : ordered_Rlist l). - * unfold ordered_Rlist; unfold ordered_Rlist in H; intros; - assert (H1 : (S i < pred (length (r :: l)))%nat); - [ simpl; replace (length l) with (S (pred (length l))); - [ apply -> Nat.succ_lt_mono; assumption - | apply Nat.lt_succ_pred with 0%nat; apply Nat.neq_0_lt_0; red; - intro; rewrite H1 in H0; simpl in H0; elim (Nat.nlt_0_r _ H0) ] - | apply (H _ H1) ]. - * assert (H2 := Hrecl H1); unfold ordered_Rlist; intros; - induction i as [| i Hreci]. - -- simpl; assert (H3 := RList_P0 l a); elim H3; intro. - ++ rewrite H4; assumption. - ++ induction l as [| r1 l Hrecl0]; - [ simpl; assumption - | rewrite H4; apply (H 0%nat); simpl; apply Nat.lt_0_succ ]. - -- simpl; apply H2; simpl in H0; apply Nat.succ_lt_mono; - replace (S (pred (length (insert l a)))) with (length (insert l a)); - [ assumption - | symmetry; apply Nat.lt_succ_pred with 0%nat; apply Nat.neq_0_lt_0; red; intro; - rewrite H3 in H0; elim (Nat.nlt_0_r _ H0) ]. - + unfold ordered_Rlist; intros; induction i as [| i Hreci]; - [ simpl; auto with real - | change (pos_Rl (r :: l) i <= pos_Rl (r :: l) (S i)); apply H; - simpl in H0; simpl; apply (proj2 (Nat.succ_lt_mono _ _) H0) ]. -Qed. - -Lemma RList_P2 : - forall l1 l2:list R, ordered_Rlist l2 -> ordered_Rlist (cons_ORlist l1 l2). -Proof. - simple induction l1; - [ intros; simpl; apply H - | intros; simpl; apply H; apply RList_P1; assumption ]. -Qed. - -Lemma RList_P3 : - forall (l:list R) (x:R), - In x l <-> (exists i : nat, x = pos_Rl l i /\ (i < length l)%nat). -Proof. - intros; split; intro; - [ induction l as [| r l Hrecl] | induction l as [| r l Hrecl] ]. - - elim H. - - elim H; intro; - [ exists 0%nat; split; [ symmetry; apply H0 | simpl; apply Nat.lt_0_succ ] - | elim (Hrecl H0); intros; elim H1; clear H1; intros; exists (S x0); split; - [ apply H1 | simpl; apply -> Nat.succ_lt_mono; assumption ] ]. - - elim H; intros; elim H0; intros; elim (Nat.nlt_0_r _ H2). - - simpl; elim H; intros; elim H0; clear H0; intros; - induction x0 as [| x0 Hrecx0]; - [ left; symmetry; apply H0 - | right; apply Hrecl; exists x0; split; - [ apply H0 | simpl in H1; apply Nat.succ_lt_mono; assumption ] ]. -Qed. - -Lemma RList_P4 : - forall (l1:list R) (a:R), ordered_Rlist (a :: l1) -> ordered_Rlist l1. -Proof. - intros; unfold ordered_Rlist; intros; apply (H (S i)); simpl; - replace (length l1) with (S (pred (length l1))); - [ apply -> Nat.succ_lt_mono; assumption - | apply Nat.lt_succ_pred with 0%nat; apply Nat.neq_0_lt_0; red; - intro; rewrite H1 in H0; elim (Nat.nlt_0_r _ H0) ]. -Qed. - -Lemma RList_P5 : - forall (l:list R) (x:R), ordered_Rlist l -> In x l -> pos_Rl l 0 <= x. -Proof. - intros; induction l as [| r l Hrecl]; - [ elim H0 - | simpl; elim H0; intro; - [ rewrite H1; right; reflexivity - | apply Rle_trans with (pos_Rl l 0); - [ apply (H 0%nat); simpl; induction l as [| r0 l Hrecl0]; - [ elim H1 | simpl; apply Nat.lt_0_succ ] - | apply Hrecl; [ eapply RList_P4; apply H | assumption ] ] ] ]. -Qed. - -Lemma RList_P6 : - forall l:list R, - ordered_Rlist l <-> - (forall i j:nat, - (i <= j)%nat -> (j < length l)%nat -> pos_Rl l i <= pos_Rl l j). -Proof. - induction l as [ | r r0 H]; split; intro. - - intros; right; reflexivity. - - unfold ordered_Rlist;intros; simpl in H0; elim (Nat.nlt_0_r _ H0). - - intros; induction i as [| i Hreci]; - [ induction j as [| j Hrecj]; - [ right; reflexivity - | simpl; apply Rle_trans with (pos_Rl r0 0); - [ apply (H0 0%nat); simpl; simpl in H2; apply Nat.neq_0_lt_0; - red; intro; rewrite H3 in H2; - assert (H4 := proj2 (Nat.succ_lt_mono _ _) H2); elim (Nat.nlt_0_r _ H4) - | elim H; intros; apply H3; - [ apply RList_P4 with r; assumption - | apply Nat.le_0_l - | simpl in H2; apply Nat.succ_lt_mono; assumption ] ] ] - | induction j as [| j Hrecj]; - [ elim (Nat.nle_succ_0 _ H1) - | simpl; elim H; intros; apply H3; - [ apply RList_P4 with r; assumption - | apply le_S_n; assumption - | simpl in H2; apply Nat.succ_lt_mono; assumption ] ] ]. - - unfold ordered_Rlist; intros; apply H0; - [ apply Nat.le_succ_diag_r | simpl; simpl in H1; apply -> Nat.succ_lt_mono; assumption ]. -Qed. - -Lemma RList_P7 : - forall (l:list R) (x:R), - ordered_Rlist l -> In x l -> x <= pos_Rl l (pred (length l)). -Proof. - intros; assert (H1 := RList_P6 l); elim H1; intros H2 _; assert (H3 := H2 H); - clear H1 H2; assert (H1 := RList_P3 l x); elim H1; - clear H1; intros; assert (H4 := H1 H0); elim H4; clear H4; - intros; elim H4; clear H4; intros; rewrite H4; - assert (H6 : length l = S (pred (length l))). - - symmetry; apply Nat.lt_succ_pred with 0%nat; apply Nat.neq_0_lt_0; red; intro; - rewrite H6 in H5; elim (Nat.nlt_0_r _ H5). - - apply H3; - [ rewrite H6 in H5; apply Nat.lt_succ_r; assumption - | apply Nat.lt_pred_l; red; intro; rewrite H7 in H5; - elim (Nat.nlt_0_r _ H5) ]. -Qed. - -Lemma RList_P8 : - forall (l:list R) (a x:R), In x (insert l a) <-> x = a \/ In x l. -Proof. - induction l as [ | r r0 H]. - - intros; split; intro; destruct H as [ax | []]; left; symmetry; exact ax. - - intros; split; intro. - + simpl in H0; generalize H0; case (Rle_dec r a); intros. - * simpl in H1; elim H1; intro. - -- right; left; assumption. - -- elim (H a x); intros; elim (H3 H2); intro. - ++ left; assumption. - ++ right; right; assumption. - * simpl in H1; decompose [or] H1. - -- left; symmetry; assumption. - -- right; left; assumption. - -- right; right; assumption. - + simpl; case (Rle_dec r a); intro. - * simpl in H0; decompose [or] H0. - -- right; elim (H a x); intros; apply H3; left. assumption. - -- left. assumption. - -- right; elim (H a x); intros; apply H3; right; assumption. - * simpl in H0; decompose [or] H0; [ left | right; left | right; right]; - trivial; symmetry; assumption. -Qed. - -Lemma RList_P9 : - forall (l1 l2:list R) (x:R), In x (cons_ORlist l1 l2) <-> In x l1 \/ In x l2. -Proof. - induction l1 as [ | r r0 H]. - - intros; split; intro; - [ simpl in H; right; assumption - | simpl; elim H; intro; [ elim H0 | assumption ] ]. - - intros; split. - + simpl; intros; elim (H (insert l2 r) x); intros; assert (H3 := H1 H0); - elim H3; intro. - * left; right; assumption. - * elim (RList_P8 l2 r x); intros H5 _; assert (H6 := H5 H4); elim H6; intro. - -- left; left; symmetry; assumption. - -- right; assumption. - + intro; simpl; elim (H (insert l2 r) x); intros _ H1; apply H1; - elim H0; intro. - * elim H2; intro. - -- right; elim (RList_P8 l2 r x); intros _ H4; apply H4; left. - symmetry; assumption. - -- left; assumption. - * right; elim (RList_P8 l2 r x); intros _ H3; apply H3; right; assumption. -Qed. - -Lemma RList_P10 : - forall (l:list R) (a:R), length (insert l a) = S (length l). -Proof. - intros; induction l as [| r l Hrecl]; - [ reflexivity - | simpl; case (Rle_dec r a); intro; - [ simpl; rewrite Hrecl; reflexivity | reflexivity ] ]. -Qed. - -Lemma RList_P11 : - forall l1 l2:list R, - length (cons_ORlist l1 l2) = (length l1 + length l2)%nat. -Proof. - induction l1 as [ | r r0 H]; - [ intro; reflexivity - | intros; simpl; rewrite (H (insert l2 r)); rewrite RList_P10; - apply INR_eq; rewrite S_INR; do 2 rewrite plus_INR; - rewrite S_INR; ring ]. -Qed. - -Lemma RList_P12 : - forall (l:list R) (i:nat) (f:R -> R), - (i < length l)%nat -> pos_Rl (map f l) i = f (pos_Rl l i). -Proof. - simple induction l; - [ intros; elim (Nat.nlt_0_r _ H) - | intros; induction i as [| i Hreci]; - [ reflexivity | simpl; apply H; apply Nat.succ_lt_mono; apply H0 ] ]. -Qed. - -Lemma RList_P13 : - forall (l:list R) (i:nat) (a:R), - (i < pred (length l))%nat -> - pos_Rl (mid_Rlist l a) (S i) = (pos_Rl l i + pos_Rl l (S i)) / 2. -Proof. - induction l as [ | r r0 H]. - - intros; simpl in H; elim (Nat.nlt_0_r _ H). - - induction r0 as [ | r1 r2 H0]. - + intros; simpl in H0; elim (Nat.nlt_0_r _ H0). - + intros; simpl in H1; induction i as [| i Hreci]. - * reflexivity. - * change - (pos_Rl (mid_Rlist (r1 :: r2) r) (S i) = - (pos_Rl (r1 :: r2) i + pos_Rl (r1 :: r2) (S i)) / 2). - apply H; simpl; apply Nat.succ_lt_mono; assumption. -Qed. - -Lemma RList_P14 : forall (l:list R) (a:R), length (mid_Rlist l a) = length l. -Proof. - induction l as [ | r r0 H]; intros; - [ reflexivity | simpl; rewrite (H r); reflexivity ]. -Qed. - -Lemma RList_P15 : - forall l1 l2:list R, - ordered_Rlist l1 -> - ordered_Rlist l2 -> - pos_Rl l1 0 = pos_Rl l2 0 -> pos_Rl (cons_ORlist l1 l2) 0 = pos_Rl l1 0. -Proof. - intros; apply Rle_antisym. - - induction l1 as [| r l1 Hrecl1]; - [ simpl; simpl in H1; right; symmetry ; assumption - | elim (RList_P9 (r :: l1) l2 (pos_Rl (r :: l1) 0)); intros; - assert - (H4 : - In (pos_Rl (r :: l1) 0) (r :: l1) \/ In (pos_Rl (r :: l1) 0) l2); - [ left; left; reflexivity - | assert (H5 := H3 H4); apply RList_P5; - [ apply RList_P2; assumption | assumption ] ] ]. - - induction l1 as [| r l1 Hrecl1]; - [ simpl; simpl in H1; right; assumption - | assert - (H2 : - In (pos_Rl (cons_ORlist (r :: l1) l2) 0) (cons_ORlist (r :: l1) l2)); - [ elim - (RList_P3 (cons_ORlist (r :: l1) l2) - (pos_Rl (cons_ORlist (r :: l1) l2) 0)); - intros; apply H3; exists 0%nat; split; - [ reflexivity | rewrite RList_P11; simpl; apply Nat.lt_0_succ ] - | elim (RList_P9 (r :: l1) l2 (pos_Rl (cons_ORlist (r :: l1) l2) 0)); - intros; assert (H5 := H3 H2); elim H5; intro; - [ apply RList_P5; assumption - | rewrite H1; apply RList_P5; assumption ] ] ]. -Qed. - -Lemma RList_P16 : - forall l1 l2:list R, - ordered_Rlist l1 -> - ordered_Rlist l2 -> - pos_Rl l1 (pred (length l1)) = pos_Rl l2 (pred (length l2)) -> - pos_Rl (cons_ORlist l1 l2) (pred (length (cons_ORlist l1 l2))) = - pos_Rl l1 (pred (length l1)). -Proof. - intros; apply Rle_antisym. - - induction l1 as [| r l1 Hrecl1]. - + simpl; simpl in H1; right; symmetry ; assumption. - + assert - (H2 : - In - (pos_Rl (cons_ORlist (r :: l1) l2) - (pred (length (cons_ORlist (r :: l1) l2)))) - (cons_ORlist (r :: l1) l2)); - [ elim - (RList_P3 (cons_ORlist (r :: l1) l2) - (pos_Rl (cons_ORlist (r :: l1) l2) - (pred (length (cons_ORlist (r :: l1) l2))))); - intros; apply H3; exists (pred (length (cons_ORlist (r :: l1) l2))); - split; [ reflexivity | rewrite RList_P11; simpl; apply Nat.lt_succ_diag_r ] - | elim - (RList_P9 (r :: l1) l2 - (pos_Rl (cons_ORlist (r :: l1) l2) - (pred (length (cons_ORlist (r :: l1) l2))))); - intros; assert (H5 := H3 H2); elim H5; intro; - [ apply RList_P7; assumption | rewrite H1; apply RList_P7; assumption ] ]. - - induction l1 as [| r l1 Hrecl1]. - + simpl; simpl in H1; right; assumption. - + elim - (RList_P9 (r :: l1) l2 (pos_Rl (r :: l1) (pred (length (r :: l1))))). - intros; - assert - (H4 : - In (pos_Rl (r :: l1) (pred (length (r :: l1)))) (r :: l1) \/ - In (pos_Rl (r :: l1) (pred (length (r :: l1)))) l2); - [ left; change (In (pos_Rl (r :: l1) (length l1)) (r :: l1)); - elim (RList_P3 (r :: l1) (pos_Rl (r :: l1) (length l1))); - intros; apply H5; exists (length l1); split; - [ reflexivity | simpl; apply Nat.lt_succ_diag_r ] - | assert (H5 := H3 H4); apply RList_P7; - [ apply RList_P2; assumption - | elim - (RList_P9 (r :: l1) l2 - (pos_Rl (r :: l1) (pred (length (r :: l1))))); - intros; apply H7; left; - elim - (RList_P3 (r :: l1) - (pos_Rl (r :: l1) (pred (length (r :: l1))))); - intros; apply H9; exists (pred (length (r :: l1))); - split; [ reflexivity | simpl; apply Nat.lt_succ_diag_r ] ] ]. -Qed. - -Lemma RList_P17 : - forall (l1:list R) (x:R) (i:nat), - ordered_Rlist l1 -> - In x l1 -> - pos_Rl l1 i < x -> (i < pred (length l1))%nat -> pos_Rl l1 (S i) <= x. -Proof. - induction l1 as [ | r r0 H]. - - intros; elim H0. - - intros; induction i as [| i Hreci]. - + simpl; elim H1; intro; - [ simpl in H2; rewrite H4 in H2; elim (Rlt_irrefl _ H2) - | apply RList_P5; [ apply RList_P4 with r; assumption | assumption ] ]. - + simpl; simpl in H2; elim H1; intro. - * rewrite <- H4 in H2; assert (H5 : r <= pos_Rl r0 i); - [ apply Rle_trans with (pos_Rl r0 0); - [ apply (H0 0%nat); simpl; simpl in H3; apply Nat.neq_0_lt_0; - red; intro; rewrite H5 in H3; elim (Nat.nlt_0_r _ H3) - | elim (RList_P6 r0); intros; apply H5; - [ apply RList_P4 with r; assumption - | apply Nat.le_0_l - | simpl in H3; apply Nat.succ_lt_mono; apply Nat.lt_trans with (length r0); - [ apply H3 | apply Nat.lt_succ_diag_r ] ] ] - | elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H5 H2)) ]. - * apply H; try assumption; - [ apply RList_P4 with r; assumption - | simpl in H3; apply Nat.succ_lt_mono; - replace (S (pred (length r0))) with (length r0); - [ apply H3 - | symmetry; apply Nat.lt_succ_pred with 0%nat; apply Nat.neq_0_lt_0; red; intro; - rewrite H5 in H3; elim (Nat.nlt_0_r _ H3) ] ]. -Qed. - -Lemma RList_P18 : - forall (l:list R) (f:R -> R), length (map f l) = length l. -Proof. - simple induction l; intros; - [ reflexivity | simpl; rewrite H; reflexivity ]. -Qed. - -Lemma RList_P19 : - forall l:list R, - l <> nil -> exists r : R, (exists r0 : list R, l = r :: r0). -Proof. - intros; induction l as [| r l Hrecl]; - [ elim H; reflexivity | exists r; exists l; reflexivity ]. -Qed. - -Lemma RList_P20 : - forall l:list R, - (2 <= length l)%nat -> - exists r : R, - (exists r1 : R, (exists l' : list R, l = r :: r1 :: l')). -Proof. - intros; induction l as [| r l Hrecl]; - [ simpl in H; elim (Nat.nle_succ_0 _ H) - | induction l as [| r0 l Hrecl0]; - [ simpl in H; elim (Nat.nle_succ_0 _ (le_S_n _ _ H)) - | exists r; exists r0; exists l; reflexivity ] ]. -Qed. - -Lemma RList_P21 : forall l l':list R, l = l' -> Rtail l = Rtail l'. -Proof. - intros; rewrite H; reflexivity. -Qed. - -Lemma RList_P22 : - forall l1 l2:list R, l1 <> nil -> pos_Rl (app l1 l2) 0 = pos_Rl l1 0. -Proof. - simple induction l1; [ intros; elim H; reflexivity | intros; reflexivity ]. -Qed. - -Lemma RList_P24 : - forall l1 l2:list R, - l2 <> nil -> - pos_Rl (app l1 l2) (pred (length (app l1 l2))) = - pos_Rl l2 (pred (length l2)). -Proof. - induction l1 as [ | r r0 H]. - - intros; reflexivity. - - intros; rewrite <- (H l2 H0); induction l2 as [| r1 l2 Hrecl2]. - + elim H0; reflexivity. - + do 2 rewrite length_app; - replace (length (r :: r0) + length (r1 :: l2))%nat with - (S (S (length r0 + length l2))); - [ replace (length r0 + length (r1 :: l2))%nat with - (S (length r0 + length l2)); - [ reflexivity - | simpl; apply INR_eq; rewrite S_INR; do 2 rewrite plus_INR; - rewrite S_INR; ring ] - | simpl; apply INR_eq; do 3 rewrite S_INR; do 2 rewrite plus_INR; - rewrite S_INR; ring ]. -Qed. - -Lemma RList_P25 : - forall l1 l2:list R, - ordered_Rlist l1 -> - ordered_Rlist l2 -> - pos_Rl l1 (pred (length l1)) <= pos_Rl l2 0 -> - ordered_Rlist (app l1 l2). -Proof. - induction l1 as [ | r r0 H]. - - intros; simpl; assumption. - - induction r0 as [ | r1 r2 H0]. - + intros; simpl; simpl in H2; unfold ordered_Rlist; intros; - simpl in H3. - induction i as [| i Hreci]. - * simpl; assumption. - * change (pos_Rl l2 i <= pos_Rl l2 (S i)); apply (H1 i); apply Nat.succ_lt_mono; - replace (S (pred (length l2))) with (length l2); - [ assumption - | symmetry; apply Nat.lt_succ_pred with 0%nat; apply Nat.neq_0_lt_0; red; intro; - rewrite H4 in H3; elim (Nat.nlt_0_r _ H3) ]. - + intros; assert (H4 : ordered_Rlist (app (r1 :: r2) l2)). - * apply H; try assumption. - apply RList_P4 with r; assumption. - * unfold ordered_Rlist; intros i H5; simpl in H5. - induction i as [| i Hreci]. - -- simpl; apply (H1 0%nat); simpl; apply Nat.lt_0_succ. - -- change - (pos_Rl (app (r1 :: r2) l2) i <= - pos_Rl (app (r1 :: r2) l2) (S i)); - apply (H4 i); simpl; apply Nat.succ_lt_mono; assumption. -Qed. - -Lemma RList_P26 : - forall (l1 l2:list R) (i:nat), - (i < length l1)%nat -> pos_Rl (app l1 l2) i = pos_Rl l1 i. -Proof. - simple induction l1. - - intros; elim (Nat.nlt_0_r _ H). - - intros; induction i as [| i Hreci]. - + apply RList_P22; discriminate. - + apply (H l2 i); simpl in H0; apply Nat.succ_lt_mono; assumption. -Qed. - -Lemma RList_P29 : - forall (l2 l1:list R) (i:nat), - (length l1 <= i)%nat -> - (i < length (app l1 l2))%nat -> - pos_Rl (app l1 l2) i = pos_Rl l2 (i - length l1). -Proof. - induction l2 as [ | r r0 H]. - - intros; rewrite app_nil_r in H0; elim (Nat.lt_irrefl _ (Nat.le_lt_trans _ _ _ H H0)). - - intros; - replace (app l1 (r :: r0)) with - (app (app l1 (r :: nil)) r0). - + inversion H0. - * rewrite Nat.sub_diag; simpl; rewrite RList_P26. - -- clear r0 H i H0 H1 H2; induction l1 as [| r0 l1 Hrecl1]. - ++ reflexivity. - ++ simpl; assumption. - -- rewrite length_app; rewrite Nat.add_comm; simpl; apply Nat.lt_succ_diag_r. - * replace (S m - length l1)%nat with (S (S m - S (length l1))). - -- rewrite H3; simpl; - replace (S (length l1)) with (length (app l1 (r :: nil))). - ++ apply (H (app l1 (r :: nil)) i). - ** rewrite length_app; rewrite Nat.add_comm; simpl; rewrite <- H3; - apply le_n_S; assumption. - ** repeat rewrite length_app; simpl; rewrite length_app in H1; - rewrite Nat.add_comm in H1; simpl in H1; rewrite (Nat.add_comm (length l1)); - simpl; rewrite Nat.add_comm; apply H1. - ++ rewrite length_app; rewrite Nat.add_comm; reflexivity. - -- change (S (m - length l1) = (S m - length l1)%nat); - symmetry; apply Nat.sub_succ_l; assumption. - + replace (r :: r0) with (app (r :: nil) r0); - [ symmetry ; apply app_assoc | reflexivity ]. -Qed. diff --git a/stdlib/theories/Reals/ROrderedType.v b/stdlib/theories/Reals/ROrderedType.v deleted file mode 100644 index a611962751c7..000000000000 --- a/stdlib/theories/Reals/ROrderedType.v +++ /dev/null @@ -1,98 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* r2}. -Proof. - intros; generalize (total_order_T r1 r2) Rlt_dichotomy_converse; - intuition eauto. -Qed. - -Definition Reqb r1 r2 := if Req_dec r1 r2 then true else false. -Lemma Reqb_eq : forall r1 r2, Reqb r1 r2 = true <-> r1=r2. -Proof. - intros; unfold Reqb; destruct Req_dec as [EQ|NEQ]; auto with *. - split; try discriminate. intro EQ; elim NEQ; auto. -Qed. - -Module R_as_UBE <: UsualBoolEq. - Definition t := R. - Definition eq := @eq R. - Definition eqb := Reqb. - Definition eqb_eq := Reqb_eq. -End R_as_UBE. - -Module R_as_DT <: UsualDecidableTypeFull := Make_UDTF R_as_UBE. - -(** Note that the last module fulfills by subtyping many other - interfaces, such as [DecidableType] or [EqualityType]. *) - - - -(** Note that [R_as_DT] can also be seen as a [DecidableType] - and a [DecidableTypeOrig]. *) - - - -(** * OrderedType structure for binary integers *) - - - -Definition Rcompare x y := - match total_order_T x y with - | inleft (left _) => Lt - | inleft (right _) => Eq - | inright _ => Gt - end. - -Lemma Rcompare_spec : forall x y, CompareSpec (x=y) (xLogic.eq==>iff) Rlt. - Proof. repeat red; intros; subst; auto. Qed. - - Lemma le_lteq : forall x y, x <= y <-> x < y \/ x = y. - Proof. unfold Rle; auto with *. Qed. - - Definition compare_spec := Rcompare_spec. - -End R_as_OT. - -(** Note that [R_as_OT] can also be seen as a [UsualOrderedType] - and a [OrderedType] (and also as a [DecidableType]). *) - - - -(** * An [order] tactic for real numbers *) - -Module ROrder := OTF_to_OrderTac R_as_OT. -Ltac r_order := ROrder.order. - -(** Note that [r_order] is domain-agnostic: it will not prove - [1<=2] or [x<=x+x], but rather things like [x<=y -> y<=x -> x=y]. *) diff --git a/stdlib/theories/Reals/R_Ifp.v b/stdlib/theories/Reals/R_Ifp.v deleted file mode 100644 index a885cd3a8979..000000000000 --- a/stdlib/theories/Reals/R_Ifp.v +++ /dev/null @@ -1,418 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* IZR z <= r + 1 -> z = up r. -Proof. - intros r z Hlt Hle. - destruct (archimed r) as [Hlt'%Ropp_lt_contravar Hle'%Ropp_le_contravar]. - apply (Rplus_le_compat_l (- r)) in Hle'. - rewrite Ropp_minus_distr, Rminus_def, <-Rplus_assoc, Rplus_opp_l, Rplus_0_l in Hle'. - apply Z.sub_move_0_r, one_IZR_lt1; split; rewrite minus_IZR. - - replace (-1) with (r + (- r + - 1)) - by (now rewrite <-Rplus_assoc, Rplus_opp_r, Rplus_0_l). - now apply Rplus_lt_le_compat. - - replace 1 with (r + 1 + -r) - by (now rewrite (Rplus_comm r), Rplus_assoc, Rplus_opp_r, Rplus_0_r). - now apply Rplus_le_lt_compat. -Qed. - -Lemma Int_part_spec : forall r z, r - 1 < IZR z <= r -> z = Int_part r. -Proof. - unfold Int_part; intros r z [Hle Hlt]; apply Z.add_move_r, tech_up. - - rewrite <-(Rplus_0_r r), <-(Rplus_opp_l 1), <-Rplus_assoc, plus_IZR. - now apply Rplus_lt_compat_r. - - now rewrite plus_IZR; apply Rplus_le_compat_r. -Qed. - -(**********) -Lemma up_tech : - forall (r:R) (z:Z), IZR z <= r -> r < IZR (z + 1) -> (z + 1)%Z = up r. -Proof. - intros. - apply tech_up with (1 := H0). - rewrite plus_IZR. - now apply Rplus_le_compat_r. -Qed. - -(**********) -Lemma fp_R0 : frac_part 0 = 0. -Proof. - unfold frac_part, Int_part. - replace (up 0) with 1%Z. - - now rewrite <- minus_IZR. - - destruct (archimed 0) as [H1 H2]. - apply lt_IZR in H1. - rewrite <- minus_IZR in H2. - apply le_IZR in H2. - Lia.lia. -Qed. - -(**********) -Lemma for_base_fp : forall r:R, IZR (up r) - r > 0 /\ IZR (up r) - r <= 1. -Proof. - intro; split; cut (IZR (up r) > r /\ IZR (up r) - r <= 1). - - intro; elim H; intros. - apply (Rgt_minus (IZR (up r)) r H0). - - apply archimed. - - intro; elim H; intros. - exact H1. - - apply archimed. -Qed. - -(**********) -Lemma base_fp : forall r:R, frac_part r >= 0 /\ frac_part r < 1. -Proof. - intro; unfold frac_part; unfold Int_part; split. - - (*sup a O*) - cut (r - IZR (up r) >= -1). - + rewrite <- Z_R_minus; simpl; intro; unfold Rminus; - rewrite Ropp_plus_distr; rewrite <- Rplus_assoc; - fold (r - IZR (up r)); fold (r - IZR (up r) - -1); - apply Rge_minus; auto with zarith real. - + rewrite <- Ropp_minus_distr; apply Ropp_le_ge_contravar; elim (for_base_fp r); - auto with zarith real. - - (*inf a 1*) - cut (r - IZR (up r) < 0). - + rewrite <- Z_R_minus; simpl; intro; unfold Rminus; - rewrite Ropp_plus_distr; rewrite <- Rplus_assoc; - fold (r - IZR (up r)); rewrite Ropp_involutive; - elim (Rplus_ne 1); intros a b; pattern 1 at 2; - rewrite <- a; clear a b; rewrite (Rplus_comm (r - IZR (up r)) 1); - apply Rplus_lt_compat_l; auto with zarith real. - + elim (for_base_fp r); intros; rewrite <- Ropp_0; rewrite <- Ropp_minus_distr; - apply Ropp_gt_lt_contravar; auto with zarith real. -Qed. - -(*********************************************************) -(** * Properties *) -(*********************************************************) - -(**********) -Lemma base_Int_part : - forall r:R, IZR (Int_part r) <= r /\ IZR (Int_part r) - r > -1. -Proof. - intro; unfold Int_part; elim (archimed r); intros. - split; rewrite <- (Z_R_minus (up r) 1); simpl. - - apply Rminus_le. - replace (IZR (up r) - 1 - r) with (IZR (up r) - r - 1) by ring. - now apply Rle_minus. - - apply Rminus_gt. - replace (IZR (up r) - 1 - r - -1) with (IZR (up r) - r) by ring. - now apply Rgt_minus. -Qed. - -(**********) -Lemma Int_part_INR : forall n:nat, Int_part (INR n) = Z.of_nat n. -Proof. - intros n; unfold Int_part. - cut (up (INR n) = (Z.of_nat n + Z.of_nat 1)%Z). - - intros H'; rewrite H'; simpl; ring. - - symmetry; apply tech_up; auto. - + replace (Z.of_nat n + Z.of_nat 1)%Z with (Z.of_nat (S n)). - * repeat rewrite <- INR_IZR_INZ. - apply lt_INR; auto. - * rewrite Z.add_comm; rewrite <- Znat.Nat2Z.inj_add; simpl; auto. - + rewrite plus_IZR; simpl; auto with real. - repeat rewrite <- INR_IZR_INZ; auto with real. -Qed. - -(**********) -Lemma fp_nat : forall r:R, frac_part r = 0 -> exists c : Z, r = IZR c. -Proof. - unfold frac_part; intros; split with (Int_part r); - apply Rminus_diag_uniq; auto with zarith real. -Qed. - -(**********) -Lemma R0_fp_O : forall r:R, 0 <> frac_part r -> 0 <> r. -Proof. - red; intros; rewrite <- H0 in H; generalize fp_R0; intro; - auto with zarith real. -Qed. - -Lemma Rplus_Int_part_frac_part : forall r, r = IZR (Int_part r) + frac_part r. -Proof. now unfold frac_part; intros r; rewrite Rplus_minus. Qed. - -Lemma Int_part_frac_part_spec : - forall r z f, 0 <= f < 1 -> r = (IZR z) + f -> z = Int_part r /\ f = frac_part r. -Proof. - intros r z f [Hlef Hltf] E%(Rminus_eq_compat_r f); rewrite Rplus_minus_r in E. - assert (IP : z = Int_part r). { - apply Int_part_spec; split. - - now rewrite <-E; apply Rplus_lt_compat_l, Ropp_lt_contravar. - - rewrite <-E; apply (Rplus_le_reg_r f). - rewrite <-Rplus_minus_swap, Rplus_minus_r, <-(Rplus_0_r r) at 1. - now apply Rplus_le_compat_l. - } - split; try easy. - unfold frac_part. - now rewrite <-IP, <-E, Rminus_def, Ropp_minus_distr, Rplus_minus. -Qed. -(**********) -Lemma Rminus_Int_part1 : - forall r1 r2:R, - frac_part r1 >= frac_part r2 -> - Int_part (r1 - r2) = (Int_part r1 - Int_part r2)%Z. -Proof. - intros r1 r2 H; symmetry. - apply (Int_part_frac_part_spec _ _ (frac_part r1 - frac_part r2)). - - split. - + apply (Rplus_le_reg_r (frac_part r2)). - rewrite Rplus_0_l, <-Rplus_minus_swap, Rplus_minus_r. - now apply Rge_le. - + rewrite <-(Rminus_0_r 1); apply Rplus_lt_le_compat. - * now apply base_fp. - * now apply Ropp_le_contravar, Rge_le, base_fp. - - rewrite (Rplus_Int_part_frac_part r1) at 1. - rewrite (Rplus_Int_part_frac_part r2) at 1. - rewrite minus_IZR, Rplus_minus_swap, Rminus_def at 1. - rewrite Ropp_plus_distr, !Rplus_assoc, (Rplus_comm _ (frac_part r1)). - now unfold Rminus; rewrite !Rplus_assoc. -Qed. - -(**********) -Lemma Rminus_Int_part2 : - forall r1 r2:R, - frac_part r1 < frac_part r2 -> - Int_part (r1 - r2) = (Int_part r1 - Int_part r2 - 1)%Z. -Proof. - intros r1 r2 H; symmetry. - apply (Int_part_frac_part_spec _ _ (frac_part r1 - frac_part r2 + 1)). - - split. - + apply (Rplus_le_reg_r (- 1)). - rewrite !Rplus_assoc, Rplus_opp_r, Rplus_0_r. - apply Rplus_le_compat. - * now apply Rge_le, base_fp. - * apply Ropp_le_contravar; left; apply base_fp. - + rewrite <-(Rplus_0_l 1) at 2. - now apply Rplus_lt_compat_r, Rlt_minus_0. - - rewrite (Rplus_Int_part_frac_part r1) at 1. - rewrite (Rplus_Int_part_frac_part r2) at 1. - rewrite !minus_IZR, Rplus_minus_swap, Rminus_def at 1. - rewrite Ropp_plus_distr, !Rplus_assoc, (Rplus_comm _ (frac_part r1)). - unfold Rminus. rewrite (Rplus_assoc _ (- 1)), (Rplus_comm (- 1)). - now rewrite !Rplus_assoc, Rplus_opp_r, Rplus_0_r. -Qed. - -(**********) -Lemma Rminus_fp1 : - forall r1 r2:R, - frac_part r1 >= frac_part r2 -> - frac_part (r1 - r2) = frac_part r1 - frac_part r2. -Proof. - intros r1 r2 H%Rminus_Int_part1; unfold frac_part. - rewrite H, minus_IZR; unfold Rminus; rewrite !Ropp_plus_distr, Ropp_involutive. - rewrite (Rplus_assoc r1), <-(Rplus_assoc (- r2)), (Rplus_comm (- r2)). - now rewrite !Rplus_assoc. -Qed. - -(**********) -Lemma Rminus_fp2 : - forall r1 r2:R, - frac_part r1 < frac_part r2 -> - frac_part (r1 - r2) = frac_part r1 - frac_part r2 + 1. -Proof. - intros r1 r2 H%Rminus_Int_part2; unfold frac_part. - rewrite H, !minus_IZR; unfold Rminus; rewrite !Ropp_plus_distr, !Ropp_involutive. - rewrite (Rplus_assoc r1), <-!(Rplus_assoc (- r2)), (Rplus_comm (- r2)). - now rewrite !Rplus_assoc. -Qed. - -(**********) -Lemma plus_Int_part1 : - forall r1 r2:R, - frac_part r1 + frac_part r2 >= 1 -> - Int_part (r1 + r2) = (Int_part r1 + Int_part r2 + 1)%Z. -Proof. - intros; generalize (Rge_le (frac_part r1 + frac_part r2) 1 H); intro; clear H; - elim (base_fp r1); elim (base_fp r2); intros; clear H H2; - generalize (Rplus_lt_compat_l (frac_part r2) (frac_part r1) 1 H3); - intro; clear H3; generalize (Rplus_lt_compat_l 1 (frac_part r2) 1 H1); - intro; clear H1; rewrite (Rplus_comm 1 (frac_part r2)) in H2; - generalize - (Rlt_trans (frac_part r2 + frac_part r1) (frac_part r2 + 1) 2 H H2); - intro; clear H H2; rewrite (Rplus_comm (frac_part r2) (frac_part r1)) in H1; - unfold frac_part in H0, H1; unfold Rminus in H0, H1; - rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (r2 + - IZR (Int_part r2))) - in H1; rewrite (Rplus_comm r2 (- IZR (Int_part r2))) in H1; - rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- IZR (Int_part r2)) r2) - in H1; - rewrite (Rplus_comm (- IZR (Int_part r1) + - IZR (Int_part r2)) r2) in H1; - rewrite <- (Rplus_assoc r1 r2 (- IZR (Int_part r1) + - IZR (Int_part r2))) - in H1; - rewrite <- (Ropp_plus_distr (IZR (Int_part r1)) (IZR (Int_part r2))) in H1; - rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (r2 + - IZR (Int_part r2))) - in H0; rewrite (Rplus_comm r2 (- IZR (Int_part r2))) in H0; - rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- IZR (Int_part r2)) r2) - in H0; - rewrite (Rplus_comm (- IZR (Int_part r1) + - IZR (Int_part r2)) r2) in H0; - rewrite <- (Rplus_assoc r1 r2 (- IZR (Int_part r1) + - IZR (Int_part r2))) - in H0; - rewrite <- (Ropp_plus_distr (IZR (Int_part r1)) (IZR (Int_part r2))) in H0; - generalize - (Rplus_le_compat_l (IZR (Int_part r1) + IZR (Int_part r2)) 1 - (r1 + r2 + - (IZR (Int_part r1) + IZR (Int_part r2))) H0); - intro; clear H0; - generalize - (Rplus_lt_compat_l (IZR (Int_part r1) + IZR (Int_part r2)) - (r1 + r2 + - (IZR (Int_part r1) + IZR (Int_part r2))) 2 H1); - intro; clear H1; - rewrite (Rplus_comm (r1 + r2) (- (IZR (Int_part r1) + IZR (Int_part r2)))) - in H; - rewrite <- - (Rplus_assoc (IZR (Int_part r1) + IZR (Int_part r2)) - (- (IZR (Int_part r1) + IZR (Int_part r2))) (r1 + r2)) - in H; rewrite (Rplus_opp_r (IZR (Int_part r1) + IZR (Int_part r2))) in H; - elim (Rplus_ne (r1 + r2)); intros a b; rewrite b in H; - clear a b; - rewrite (Rplus_comm (r1 + r2) (- (IZR (Int_part r1) + IZR (Int_part r2)))) - in H0; - rewrite <- - (Rplus_assoc (IZR (Int_part r1) + IZR (Int_part r2)) - (- (IZR (Int_part r1) + IZR (Int_part r2))) (r1 + r2)) - in H0; rewrite (Rplus_opp_r (IZR (Int_part r1) + IZR (Int_part r2))) in H0; - elim (Rplus_ne (r1 + r2)); intros a b; rewrite b in H0; - clear a b; - change 2 with (1 + 1) in H0; - rewrite <- (Rplus_assoc (IZR (Int_part r1) + IZR (Int_part r2)) 1 1) in H0; - auto with real. - rewrite <- (plus_IZR (Int_part r1) (Int_part r2)) in H; - rewrite <- (plus_IZR (Int_part r1) (Int_part r2)) in H0; - rewrite <- (plus_IZR (Int_part r1 + Int_part r2) 1) in H; - rewrite <- (plus_IZR (Int_part r1 + Int_part r2) 1) in H0; - rewrite <- (plus_IZR (Int_part r1 + Int_part r2 + 1) 1) in H0; - generalize (up_tech (r1 + r2) (Int_part r1 + Int_part r2 + 1) H H0); - intro; clear H H0; unfold Int_part at 1. - Lia.lia. -Qed. - -(**********) -Lemma plus_Int_part2 : - forall r1 r2:R, - frac_part r1 + frac_part r2 < 1 -> - Int_part (r1 + r2) = (Int_part r1 + Int_part r2)%Z. -Proof. - intros; elim (base_fp r1); elim (base_fp r2); intros; clear H1 H3; - generalize (Rge_le (frac_part r2) 0 H0); intro; clear H0; - generalize (Rge_le (frac_part r1) 0 H2); intro; clear H2; - generalize (Rplus_le_compat_l (frac_part r1) 0 (frac_part r2) H1); - intro; clear H1; elim (Rplus_ne (frac_part r1)); intros a b; - rewrite a in H2; clear a b; - generalize (Rle_trans 0 (frac_part r1) (frac_part r1 + frac_part r2) H0 H2); - intro; clear H0 H2; unfold frac_part in H, H1; unfold Rminus in H, H1; - rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (r2 + - IZR (Int_part r2))) - in H1; rewrite (Rplus_comm r2 (- IZR (Int_part r2))) in H1; - rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- IZR (Int_part r2)) r2) - in H1; - rewrite (Rplus_comm (- IZR (Int_part r1) + - IZR (Int_part r2)) r2) in H1; - rewrite <- (Rplus_assoc r1 r2 (- IZR (Int_part r1) + - IZR (Int_part r2))) - in H1; - rewrite <- (Ropp_plus_distr (IZR (Int_part r1)) (IZR (Int_part r2))) in H1; - rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (r2 + - IZR (Int_part r2))) - in H; rewrite (Rplus_comm r2 (- IZR (Int_part r2))) in H; - rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- IZR (Int_part r2)) r2) in H; - rewrite (Rplus_comm (- IZR (Int_part r1) + - IZR (Int_part r2)) r2) in H; - rewrite <- (Rplus_assoc r1 r2 (- IZR (Int_part r1) + - IZR (Int_part r2))) - in H; - rewrite <- (Ropp_plus_distr (IZR (Int_part r1)) (IZR (Int_part r2))) in H; - generalize - (Rplus_le_compat_l (IZR (Int_part r1) + IZR (Int_part r2)) 0 - (r1 + r2 + - (IZR (Int_part r1) + IZR (Int_part r2))) H1); - intro; clear H1; - generalize - (Rplus_lt_compat_l (IZR (Int_part r1) + IZR (Int_part r2)) - (r1 + r2 + - (IZR (Int_part r1) + IZR (Int_part r2))) 1 H); - intro; clear H; - rewrite (Rplus_comm (r1 + r2) (- (IZR (Int_part r1) + IZR (Int_part r2)))) - in H1; - rewrite <- - (Rplus_assoc (IZR (Int_part r1) + IZR (Int_part r2)) - (- (IZR (Int_part r1) + IZR (Int_part r2))) (r1 + r2)) - in H1; rewrite (Rplus_opp_r (IZR (Int_part r1) + IZR (Int_part r2))) in H1; - elim (Rplus_ne (r1 + r2)); intros a b; rewrite b in H1; - clear a b; - rewrite (Rplus_comm (r1 + r2) (- (IZR (Int_part r1) + IZR (Int_part r2)))) - in H0; - rewrite <- - (Rplus_assoc (IZR (Int_part r1) + IZR (Int_part r2)) - (- (IZR (Int_part r1) + IZR (Int_part r2))) (r1 + r2)) - in H0; rewrite (Rplus_opp_r (IZR (Int_part r1) + IZR (Int_part r2))) in H0; - elim (Rplus_ne (IZR (Int_part r1) + IZR (Int_part r2))); - intros a b; rewrite a in H0; clear a b; elim (Rplus_ne (r1 + r2)); - intros a b; rewrite b in H0; clear a b. - rewrite <- (plus_IZR (Int_part r1) (Int_part r2)) in H0; - rewrite <- (plus_IZR (Int_part r1) (Int_part r2)) in H1; - rewrite <- (plus_IZR (Int_part r1 + Int_part r2) 1) in H1; - generalize (up_tech (r1 + r2) (Int_part r1 + Int_part r2) H0 H1); - intro; clear H0 H1; unfold Int_part at 1. - Lia.lia. -Qed. - -(**********) -Lemma plus_frac_part1 : - forall r1 r2:R, - frac_part r1 + frac_part r2 >= 1 -> - frac_part (r1 + r2) = frac_part r1 + frac_part r2 - 1. -Proof. - intros; unfold frac_part; generalize (plus_Int_part1 r1 r2 H); intro; - rewrite H0; rewrite (plus_IZR (Int_part r1 + Int_part r2) 1); - rewrite (plus_IZR (Int_part r1) (Int_part r2)); simpl; - unfold Rminus at 3 4; - rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (r2 + - IZR (Int_part r2))); - rewrite (Rplus_comm r2 (- IZR (Int_part r2))); - rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- IZR (Int_part r2)) r2); - rewrite (Rplus_comm (- IZR (Int_part r1) + - IZR (Int_part r2)) r2); - rewrite <- (Rplus_assoc r1 r2 (- IZR (Int_part r1) + - IZR (Int_part r2))); - rewrite <- (Ropp_plus_distr (IZR (Int_part r1)) (IZR (Int_part r2))); - unfold Rminus; - rewrite - (Rplus_assoc (r1 + r2) (- (IZR (Int_part r1) + IZR (Int_part r2))) (-(1))) - ; rewrite <- (Ropp_plus_distr (IZR (Int_part r1) + IZR (Int_part r2)) 1); - trivial with real. -Qed. - -(**********) -Lemma plus_frac_part2 : - forall r1 r2:R, - frac_part r1 + frac_part r2 < 1 -> - frac_part (r1 + r2) = frac_part r1 + frac_part r2. -Proof. - intros; unfold frac_part; generalize (plus_Int_part2 r1 r2 H); intro; - rewrite H0; rewrite (plus_IZR (Int_part r1) (Int_part r2)); - unfold Rminus at 2 3; - rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (r2 + - IZR (Int_part r2))); - rewrite (Rplus_comm r2 (- IZR (Int_part r2))); - rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- IZR (Int_part r2)) r2); - rewrite (Rplus_comm (- IZR (Int_part r1) + - IZR (Int_part r2)) r2); - rewrite <- (Rplus_assoc r1 r2 (- IZR (Int_part r1) + - IZR (Int_part r2))); - rewrite <- (Ropp_plus_distr (IZR (Int_part r1)) (IZR (Int_part r2))); - unfold Rminus; trivial with zarith real. -Qed. diff --git a/stdlib/theories/Reals/R_sqr.v b/stdlib/theories/Reals/R_sqr.v deleted file mode 100644 index 00d3e503fbf9..000000000000 --- a/stdlib/theories/Reals/R_sqr.v +++ /dev/null @@ -1,358 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* x <> 0. -Proof. - intros; red; intro; rewrite H0 in H; rewrite Rsqr_0 in H; - elim (Rlt_irrefl 0 H). -Qed. - -Lemma Rsqr_pos_lt : forall x:R, x <> 0 -> 0 < Rsqr x. -Proof. - intros; case (Rtotal_order 0 x); intro; - [ unfold Rsqr; apply Rmult_lt_0_compat; assumption - | elim H0; intro; - [ elim H; symmetry ; exact H1 - | rewrite Rsqr_neg; generalize (Ropp_lt_gt_contravar x 0 H1); - rewrite Ropp_0; intro; unfold Rsqr; - apply Rmult_lt_0_compat; assumption ] ]. -Qed. - -Lemma Rsqr_div' x y : Rsqr (x / y) = Rsqr x / Rsqr y. -Proof. - unfold Rsqr, Rdiv. - rewrite Rinv_mult. - ring. -Qed. - -Lemma Rsqr_div_depr : forall x y:R, y <> 0 -> Rsqr (x / y) = Rsqr x / Rsqr y. -Proof. - intros x y _. - apply Rsqr_div'. -Qed. - -#[deprecated(since="8.16",note="Use Rsqr_div'.")] -Notation Rsqr_div := Rsqr_div_depr. - -Lemma Rsqr_eq_0 : forall x:R, Rsqr x = 0 -> x = 0. -Proof. - unfold Rsqr; intros; generalize (Rmult_integral x x H); intro; - elim H0; intro; assumption. -Qed. - -Lemma Rsqr_minus_plus : forall a b:R, (a - b) * (a + b) = Rsqr a - Rsqr b. -Proof. - intros; ring_Rsqr. -Qed. - -Lemma Rsqr_plus_minus : forall a b:R, (a + b) * (a - b) = Rsqr a - Rsqr b. -Proof. - intros; ring_Rsqr. -Qed. - -Lemma Rsqr_incr_0 : - forall x y:R, Rsqr x <= Rsqr y -> 0 <= x -> 0 <= y -> x <= y. -Proof. - intros; destruct (Rle_dec x y) as [Hle|Hnle]; - [ assumption - | cut (y < x); - [ intro; unfold Rsqr in H; - generalize (Rmult_le_0_lt_compat y x y x H1 H1 H2 H2); - intro; generalize (Rle_lt_trans (x * x) (y * y) (x * x) H H3); - intro; elim (Rlt_irrefl (x * x) H4) - | auto with real ] ]. -Qed. - -Lemma Rsqr_incr_0_var : forall x y:R, Rsqr x <= Rsqr y -> 0 <= y -> x <= y. -Proof. - intros; destruct (Rle_dec x y) as [Hle|Hnle]; - [ assumption - | cut (y < x); - [ intro; unfold Rsqr in H; - generalize (Rmult_le_0_lt_compat y x y x H0 H0 H1 H1); - intro; generalize (Rle_lt_trans (x * x) (y * y) (x * x) H H2); - intro; elim (Rlt_irrefl (x * x) H3) - | auto with real ] ]. -Qed. - -Lemma Rsqr_incr_1 : - forall x y:R, x <= y -> 0 <= x -> 0 <= y -> Rsqr x <= Rsqr y. -Proof. - intros; unfold Rsqr; apply Rmult_le_compat; assumption. -Qed. - -Lemma Rsqr_incrst_0 : - forall x y:R, Rsqr x < Rsqr y -> 0 <= x -> 0 <= y -> x < y. -Proof. - intros; case (Rtotal_order x y); intro; - [ assumption - | elim H2; intro; - [ rewrite H3 in H; elim (Rlt_irrefl (Rsqr y) H) - | generalize (Rmult_le_0_lt_compat y x y x H1 H1 H3 H3); intro; - unfold Rsqr in H; generalize (Rlt_trans (x * x) (y * y) (x * x) H H4); - intro; elim (Rlt_irrefl (x * x) H5) ] ]. -Qed. - -Lemma Rsqr_incrst_1 : - forall x y:R, x < y -> 0 <= x -> 0 <= y -> Rsqr x < Rsqr y. -Proof. - intros; unfold Rsqr; apply Rmult_le_0_lt_compat; assumption. -Qed. - -Lemma Rsqr_neg_pos_le_0 : - forall x y:R, Rsqr x <= Rsqr y -> 0 <= y -> - y <= x. -Proof. - intros; destruct (Rcase_abs x) as [Hlt|Hle]. - - generalize (Ropp_lt_gt_contravar x 0 Hlt); rewrite Ropp_0; intro; - generalize (Rlt_le 0 (- x) H1); intro; rewrite (Rsqr_neg x) in H; - generalize (Rsqr_incr_0 (- x) y H H2 H0); intro; - rewrite <- (Ropp_involutive x); apply Ropp_ge_le_contravar; - apply Rle_ge; assumption. - - apply Rle_trans with 0; - [ rewrite <- Ropp_0; apply Ropp_ge_le_contravar; apply Rle_ge; assumption - | apply Rge_le; assumption ]. -Qed. - -Lemma Rsqr_neg_pos_le_1 : - forall x y:R, - y <= x -> x <= y -> 0 <= y -> Rsqr x <= Rsqr y. -Proof. - intros x y H H0 H1; destruct (Rcase_abs x) as [Hlt|Hle]. - - apply Ropp_lt_gt_contravar, Rlt_le in Hlt; rewrite Ropp_0 in Hlt; - apply Ropp_le_ge_contravar, Rge_le in H; rewrite Ropp_involutive in H; - rewrite (Rsqr_neg x); apply Rsqr_incr_1; assumption. - - apply Rge_le in Hle; apply Rsqr_incr_1; assumption. -Qed. - -Lemma neg_pos_Rsqr_le : forall x y:R, - y <= x -> x <= y -> Rsqr x <= Rsqr y. -Proof. - intros x y H H0; destruct (Rcase_abs x) as [Hlt|Hle]. - - apply Ropp_lt_gt_contravar, Rlt_le in Hlt; rewrite Ropp_0 in Hlt; - apply Ropp_le_ge_contravar, Rge_le in H; rewrite Ropp_involutive in H. - assert (0 <= y) by (apply Rle_trans with (-x); assumption). - rewrite (Rsqr_neg x); apply Rsqr_incr_1; assumption. - - apply Rge_le in Hle; - assert (0 <= y) by (apply Rle_trans with x; assumption). - apply Rsqr_incr_1; assumption. -Qed. - -Lemma neg_pos_Rsqr_lt : forall x y : R, - y < x -> x < y -> Rsqr x < Rsqr y. -Proof. - intros x y Hneg Hpos. - destruct (Rcase_abs x) as [Hlt|HLe]. - - rewrite (Rsqr_neg x); apply Rsqr_incrst_1. - + rewrite <- (Ropp_involutive y); apply Ropp_lt_contravar; exact Hneg. - + rewrite <- (Ropp_0). apply Ropp_le_contravar, Rlt_le; exact Hlt. - + apply (Rlt_trans _ _ _ Hneg) in Hlt. - rewrite <- (Ropp_0) in Hlt; apply Ropp_lt_cancel in Hlt; apply Rlt_le; exact Hlt. - - apply Rsqr_incrst_1. - + exact Hpos. - + apply Rge_le; exact HLe. - + apply Rge_le in HLe. - apply (Rle_lt_trans _ _ _ HLe), Rlt_le in Hpos; exact Hpos. -Qed. - -Lemma Rsqr_bounds_le : forall a b:R, -a <= b <= a -> 0 <= Rsqr b <= Rsqr a. -Proof. - intros a b [H1 H2]. - split. - - apply Rle_0_sqr. - - apply neg_pos_Rsqr_le; assumption. -Qed. - -Lemma Rsqr_bounds_lt : forall a b:R, -a < b < a -> 0 <= Rsqr b < Rsqr a. -Proof. - intros a b [H1 H2]. - split. - - apply Rle_0_sqr. - - apply neg_pos_Rsqr_lt; assumption. -Qed. - -Lemma Rsqr_abs : forall x:R, Rsqr x = Rsqr (Rabs x). -Proof. - intro; unfold Rabs; case (Rcase_abs x); intro; - [ apply Rsqr_neg | reflexivity ]. -Qed. - -Lemma Rsqr_le_abs_0 : forall x y:R, Rsqr x <= Rsqr y -> Rabs x <= Rabs y. -Proof. - intros; apply Rsqr_incr_0; repeat rewrite <- Rsqr_abs; - [ assumption | apply Rabs_pos | apply Rabs_pos ]. -Qed. - -Lemma Rsqr_le_abs_1 : forall x y:R, Rabs x <= Rabs y -> Rsqr x <= Rsqr y. -Proof. - intros; rewrite (Rsqr_abs x); rewrite (Rsqr_abs y); - apply (Rsqr_incr_1 (Rabs x) (Rabs y) H (Rabs_pos x) (Rabs_pos y)). -Qed. - -Lemma Rsqr_lt_abs_0 : forall x y:R, Rsqr x < Rsqr y -> Rabs x < Rabs y. -Proof. - intros; apply Rsqr_incrst_0; repeat rewrite <- Rsqr_abs; - [ assumption | apply Rabs_pos | apply Rabs_pos ]. -Qed. - -Lemma Rsqr_lt_abs_1 : forall x y:R, Rabs x < Rabs y -> Rsqr x < Rsqr y. -Proof. - intros; rewrite (Rsqr_abs x); rewrite (Rsqr_abs y); - apply (Rsqr_incrst_1 (Rabs x) (Rabs y) H (Rabs_pos x) (Rabs_pos y)). -Qed. - -Lemma Rsqr_inj : forall x y:R, 0 <= x -> 0 <= y -> Rsqr x = Rsqr y -> x = y. -Proof. - intros; generalize (Rle_le_eq (Rsqr x) (Rsqr y)); intro; elim H2; intros _ H3; - generalize (H3 H1); intro; elim H4; intros; apply Rle_antisym; - apply Rsqr_incr_0; assumption. -Qed. - -Lemma Rsqr_eq_abs_0 : forall x y:R, Rsqr x = Rsqr y -> Rabs x = Rabs y. -Proof. - intros; unfold Rabs; case (Rcase_abs x) as [Hltx|Hgex]; - case (Rcase_abs y) as [Hlty|Hgey]. - - rewrite (Rsqr_neg x), (Rsqr_neg y) in H; - generalize (Ropp_lt_gt_contravar y 0 Hlty); - generalize (Ropp_lt_gt_contravar x 0 Hltx); rewrite Ropp_0; - intros; generalize (Rlt_le 0 (- x) H0); generalize (Rlt_le 0 (- y) H1); - intros; apply Rsqr_inj; assumption. - - rewrite (Rsqr_neg x) in H; generalize (Rge_le y 0 Hgey); intro; - generalize (Ropp_lt_gt_contravar x 0 Hltx); rewrite Ropp_0; - intro; generalize (Rlt_le 0 (- x) H1); intro; apply Rsqr_inj; - assumption. - - rewrite (Rsqr_neg y) in H; generalize (Rge_le x 0 Hgex); intro; - generalize (Ropp_lt_gt_contravar y 0 Hlty); rewrite Ropp_0; - intro; generalize (Rlt_le 0 (- y) H1); intro; apply Rsqr_inj; - assumption. - - apply Rsqr_inj; auto using Rge_le. -Qed. - -Lemma Rsqr_eq_asb_1 : forall x y:R, Rabs x = Rabs y -> Rsqr x = Rsqr y. -Proof. - intros; cut (Rsqr (Rabs x) = Rsqr (Rabs y)). - - intro; repeat rewrite <- Rsqr_abs in H0; assumption. - - rewrite H; reflexivity. -Qed. - -Lemma triangle_rectangle : - forall x y z:R, - 0 <= z -> Rsqr x + Rsqr y <= Rsqr z -> - z <= x <= z /\ - z <= y <= z. -Proof. - intros; - generalize (plus_le_is_le (Rsqr x) (Rsqr y) (Rsqr z) (Rle_0_sqr y) H0); - rewrite Rplus_comm in H0; - generalize (plus_le_is_le (Rsqr y) (Rsqr x) (Rsqr z) (Rle_0_sqr x) H0); - intros; split; - [ split; - [ apply Rsqr_neg_pos_le_0; assumption - | apply Rsqr_incr_0_var; assumption ] - | split; - [ apply Rsqr_neg_pos_le_0; assumption - | apply Rsqr_incr_0_var; assumption ] ]. -Qed. - -Lemma triangle_rectangle_lt : - forall x y z:R, - Rsqr x + Rsqr y < Rsqr z -> Rabs x < Rabs z /\ Rabs y < Rabs z. -Proof. - intros; split; - [ generalize (plus_lt_is_lt (Rsqr x) (Rsqr y) (Rsqr z) (Rle_0_sqr y) H); - intro; apply Rsqr_lt_abs_0; assumption - | rewrite Rplus_comm in H; - generalize (plus_lt_is_lt (Rsqr y) (Rsqr x) (Rsqr z) (Rle_0_sqr x) H); - intro; apply Rsqr_lt_abs_0; assumption ]. -Qed. - -Lemma triangle_rectangle_le : - forall x y z:R, - Rsqr x + Rsqr y <= Rsqr z -> Rabs x <= Rabs z /\ Rabs y <= Rabs z. -Proof. - intros; split; - [ generalize (plus_le_is_le (Rsqr x) (Rsqr y) (Rsqr z) (Rle_0_sqr y) H); - intro; apply Rsqr_le_abs_0; assumption - | rewrite Rplus_comm in H; - generalize (plus_le_is_le (Rsqr y) (Rsqr x) (Rsqr z) (Rle_0_sqr x) H); - intro; apply Rsqr_le_abs_0; assumption ]. -Qed. - -Lemma Rsqr_inv' x : Rsqr (/ x) = / Rsqr x. -Proof. - unfold Rsqr. - now rewrite Rinv_mult. -Qed. - -Lemma Rsqr_inv_depr : forall x:R, x <> 0 -> Rsqr (/ x) = / Rsqr x. -Proof. - intros x _. - apply Rsqr_inv'. -Qed. - -#[deprecated(since="8.16",note="Use Rsqr_inv'.")] -Notation Rsqr_inv := Rsqr_inv_depr. - -Lemma canonical_Rsqr : - forall (a:nonzeroreal) (b c x:R), - a * Rsqr x + b * x + c = - a * Rsqr (x + b / (2 * a)) + (4 * a * c - Rsqr b) / (4 * a). -Proof. - intros. - unfold Rsqr. - field. - apply a. -Qed. - -Lemma Rsqr_eq : forall x y:R, Rsqr x = Rsqr y -> x = y \/ x = - y. -Proof. - intros; unfold Rsqr in H; - generalize (Rplus_eq_compat_l (- (y * y)) (x * x) (y * y) H); - rewrite Rplus_opp_l; replace (- (y * y) + x * x) with ((x - y) * (x + y)). - - intro; generalize (Rmult_integral (x - y) (x + y) H0); intro; elim H1; intros. - + left; apply Rminus_diag_uniq; assumption. - + right; apply Rminus_diag_uniq; unfold Rminus; rewrite Ropp_involutive; - assumption. - - ring. -Qed. diff --git a/stdlib/theories/Reals/R_sqrt.v b/stdlib/theories/Reals/R_sqrt.v deleted file mode 100644 index 48456b681718..000000000000 --- a/stdlib/theories/Reals/R_sqrt.v +++ /dev/null @@ -1,486 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* 0 - | right a => Rsqrt (mknonnegreal x (Rge_le _ _ a)) - end. - -Lemma sqrt_pos : forall x : R, 0 <= sqrt x. -Proof. - intros x. - unfold sqrt. - destruct (Rcase_abs x) as [H|H]. - - apply Rle_refl. - - apply Rsqrt_positivity. -Qed. - -Lemma sqrt_positivity : forall x:R, 0 <= x -> 0 <= sqrt x. -Proof. - intros x _. - apply sqrt_pos. -Qed. - -Lemma sqrt_sqrt : forall x:R, 0 <= x -> sqrt x * sqrt x = x. -Proof. - intros. - unfold sqrt. - case (Rcase_abs x) as [Hlt|Hge]. - - elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ Hlt H)). - - rewrite Rsqrt_Rsqrt; reflexivity. -Qed. - -Lemma sqrt_0 : sqrt 0 = 0. -Proof. - apply Rsqr_eq_0; unfold Rsqr; apply sqrt_sqrt; right; reflexivity. -Qed. - -Lemma sqrt_1 : sqrt 1 = 1. -Proof. - apply (Rsqr_inj (sqrt 1) 1); - [ apply sqrt_positivity; left - | left - | unfold Rsqr; rewrite sqrt_sqrt; [ ring | left ] ]; - apply Rlt_0_1. -Qed. - -Lemma sqrt_eq_0 : forall x:R, 0 <= x -> sqrt x = 0 -> x = 0. -Proof. - intros; cut (Rsqr (sqrt x) = 0). - - intro; unfold Rsqr in H1; rewrite sqrt_sqrt in H1; assumption. - - rewrite H0; apply Rsqr_0. -Qed. - -Lemma sqrt_lem_0 : forall x y:R, 0 <= x -> 0 <= y -> sqrt x = y -> y * y = x. -Proof. - intros; rewrite <- H1; apply (sqrt_sqrt x H). -Qed. - -Lemma sqrt_lem_1 : forall x y:R, 0 <= x -> 0 <= y -> y * y = x -> sqrt x = y. -Proof. - intros; apply Rsqr_inj; - [ apply (sqrt_positivity x H) - | assumption - | unfold Rsqr; rewrite H1; apply (sqrt_sqrt x H) ]. -Qed. - -Lemma sqrt_def : forall x:R, 0 <= x -> sqrt x * sqrt x = x. -Proof. - intros; apply (sqrt_sqrt x H). -Qed. - -Lemma sqrt_square : forall x:R, 0 <= x -> sqrt (x * x) = x. -Proof. - intros; - apply - (Rsqr_inj (sqrt (Rsqr x)) x (sqrt_positivity (Rsqr x) (Rle_0_sqr x)) H); - unfold Rsqr; apply (sqrt_sqrt (Rsqr x) (Rle_0_sqr x)). -Qed. - -Lemma sqrt_Rsqr : forall x:R, 0 <= x -> sqrt (Rsqr x) = x. -Proof. - intros; unfold Rsqr; apply sqrt_square; assumption. -Qed. - -Lemma sqrt_pow2 : forall x, 0 <= x -> sqrt (x ^ 2) = x. -intros; simpl; rewrite Rmult_1_r, sqrt_square; auto. -Qed. - -Lemma pow2_sqrt x : 0 <= x -> sqrt x ^ 2 = x. -Proof. now intros x0; simpl; rewrite -> Rmult_1_r, sqrt_sqrt. Qed. - -Lemma sqrt_Rsqr_abs : forall x:R, sqrt (Rsqr x) = Rabs x. -Proof. - intro x; rewrite Rsqr_abs; apply sqrt_Rsqr; apply Rabs_pos. -Qed. - -Lemma Rsqr_sqrt : forall x:R, 0 <= x -> Rsqr (sqrt x) = x. -Proof. - intros x H1; unfold Rsqr; apply (sqrt_sqrt x H1). -Qed. - -Lemma sqrt_mult_alt : - forall x y : R, 0 <= x -> sqrt (x * y) = sqrt x * sqrt y. -Proof. - intros x y Hx. - unfold sqrt at 3. - destruct (Rcase_abs y) as [Hy|Hy]. - - rewrite Rmult_0_r. - destruct Hx as [Hx'|Hx']. - + unfold sqrt. - destruct (Rcase_abs (x * y)) as [Hxy|Hxy]. - * apply eq_refl. - * elim Rge_not_lt with (1 := Hxy). - rewrite <- (Rmult_0_r x). - now apply Rmult_lt_compat_l. - + rewrite <- Hx', Rmult_0_l. - exact sqrt_0. - - apply Rsqr_inj. - + apply sqrt_pos. - + apply Rmult_le_pos. - * apply sqrt_pos. - * apply Rsqrt_positivity. - + rewrite Rsqr_mult, 2!Rsqr_sqrt. - * unfold Rsqr. - now rewrite Rsqrt_Rsqrt. - * exact Hx. - * apply Rmult_le_pos. - -- exact Hx. - -- now apply Rge_le. -Qed. - -Lemma sqrt_mult : - forall x y:R, 0 <= x -> 0 <= y -> sqrt (x * y) = sqrt x * sqrt y. -Proof. - intros x y Hx _. - now apply sqrt_mult_alt. -Qed. - -Lemma sqrt_lt_R0 : forall x:R, 0 < x -> 0 < sqrt x. -Proof. - intros x H1; apply Rsqr_incrst_0; - [ rewrite Rsqr_0; rewrite Rsqr_sqrt; [ assumption | left; assumption ] - | right; reflexivity - | apply (sqrt_positivity x (Rlt_le 0 x H1)) ]. -Qed. - -Lemma Rlt_mult_inv_pos : forall x y:R, 0 < x -> 0 < y -> 0 < x * / y. -intros x y H H0; try assumption. -replace 0 with (x * 0). -- apply Rmult_lt_compat_l; auto with real. -- ring. -Qed. - -Lemma Rle_mult_inv_pos : forall x y:R, 0 <= x -> 0 < y -> 0 <= x * / y. -intros x y H H0; try assumption. -case H; intros. -- red; left. - apply Rlt_mult_inv_pos; auto with real. -- rewrite <- H1. - red; right; ring. -Qed. - -Lemma sqrt_div_alt : - forall x y : R, 0 < y -> sqrt (x / y) = sqrt x / sqrt y. -Proof. - intros x y Hy. - unfold sqrt at 2. - destruct (Rcase_abs x) as [Hx|Hx]. - - unfold Rdiv. - rewrite Rmult_0_l. - unfold sqrt. - destruct (Rcase_abs (x * / y)) as [Hxy|Hxy]. - + apply eq_refl. - + elim Rge_not_lt with (1 := Hxy). - apply Rmult_lt_reg_r with y. - * exact Hy. - * rewrite Rmult_assoc, Rinv_l, Rmult_1_r, Rmult_0_l. - -- exact Hx. - -- now apply Rgt_not_eq. - - set (Hx' := Rge_le x 0 Hx). - clearbody Hx'. clear Hx. - apply Rsqr_inj. - + apply sqrt_pos. - + apply Rle_mult_inv_pos. - * apply Rsqrt_positivity. - * now apply sqrt_lt_R0. - + rewrite Rsqr_div', 2!Rsqr_sqrt. - * unfold Rsqr. - now rewrite Rsqrt_Rsqrt. - * now apply Rlt_le. - * now apply Rle_mult_inv_pos. -Qed. - -Lemma sqrt_div : - forall x y:R, 0 <= x -> 0 < y -> sqrt (x / y) = sqrt x / sqrt y. -Proof. - intros x y _ H. - now apply sqrt_div_alt. -Qed. - -Lemma sqrt_lt_0_alt : - forall x y : R, sqrt x < sqrt y -> x < y. -Proof. - intros x y. - unfold sqrt at 2. - destruct (Rcase_abs y) as [Hy|Hy]. - - intros Hx. - elim Rlt_not_le with (1 := Hx). - apply sqrt_pos. - - set (Hy' := Rge_le y 0 Hy). - clearbody Hy'. clear Hy. - unfold sqrt. - destruct (Rcase_abs x) as [Hx|Hx]. - + intros _. - now apply Rlt_le_trans with R0. - + intros Hxy. - apply Rsqr_incrst_1 in Hxy ; try apply Rsqrt_positivity. - unfold Rsqr in Hxy. - now rewrite 2!Rsqrt_Rsqrt in Hxy. -Qed. - -Lemma sqrt_lt_0 : forall x y:R, 0 <= x -> 0 <= y -> sqrt x < sqrt y -> x < y. -Proof. - intros x y _ _. - apply sqrt_lt_0_alt. -Qed. - -Lemma sqrt_lt_1_alt : - forall x y : R, 0 <= x < y -> sqrt x < sqrt y. -Proof. - intros x y (Hx, Hxy). - apply Rsqr_incrst_0 ; try apply sqrt_pos. - rewrite 2!Rsqr_sqrt. - - exact Hxy. - - apply Rlt_le. - now apply Rle_lt_trans with x. - - exact Hx. -Qed. - -Lemma sqrt_lt_1 : forall x y:R, 0 <= x -> 0 <= y -> x < y -> sqrt x < sqrt y. -Proof. - intros x y Hx _ Hxy. - apply sqrt_lt_1_alt. - now split. -Qed. - -Lemma sqrt_le_0 : - forall x y:R, 0 <= x -> 0 <= y -> sqrt x <= sqrt y -> x <= y. -Proof. - intros x y H1 H2 H3; - generalize - (Rsqr_incr_1 (sqrt x) (sqrt y) H3 (sqrt_positivity x H1) - (sqrt_positivity y H2)); intro H4; rewrite (Rsqr_sqrt x H1) in H4; - rewrite (Rsqr_sqrt y H2) in H4; assumption. -Qed. - -Lemma sqrt_le_1_alt : - forall x y : R, x <= y -> sqrt x <= sqrt y. -Proof. - intros x y [Hxy|Hxy]. - - destruct (Rle_or_lt 0 x) as [Hx|Hx]. - + apply Rlt_le. - apply sqrt_lt_1_alt. - now split. - + unfold sqrt at 1. - destruct (Rcase_abs x) as [Hx'|Hx']. - * apply sqrt_pos. - * now elim Rge_not_lt with (1 := Hx'). - - rewrite Hxy. - apply Rle_refl. -Qed. - -Lemma sqrt_le_1 : - forall x y:R, 0 <= x -> 0 <= y -> x <= y -> sqrt x <= sqrt y. -Proof. - intros x y _ _ Hxy. - now apply sqrt_le_1_alt. -Qed. - -Lemma sqrt_neg_0 x : x <= 0 -> sqrt x = 0. -Proof. - intros Hx. - apply Rle_le_eq; split. - - rewrite <- sqrt_0; apply sqrt_le_1_alt, Hx. - - apply sqrt_pos. -Qed. - -Lemma sqrt_inj : forall x y:R, 0 <= x -> 0 <= y -> sqrt x = sqrt y -> x = y. -Proof. - intros; cut (Rsqr (sqrt x) = Rsqr (sqrt y)). - - intro; rewrite (Rsqr_sqrt x H) in H2; rewrite (Rsqr_sqrt y H0) in H2; - assumption. - - rewrite H1; reflexivity. -Qed. - -Lemma sqrt_less_alt : - forall x : R, 1 < x -> sqrt x < x. -Proof. - intros x Hx. - assert (Hx1 := Rle_lt_trans _ _ _ Rle_0_1 Hx). - assert (Hx2 := Rlt_le _ _ Hx1). - apply Rsqr_incrst_0 ; trivial. - - rewrite Rsqr_sqrt ; trivial. - rewrite <- (Rmult_1_l x) at 1. - now apply Rmult_lt_compat_r. - - apply sqrt_pos. -Qed. - -Lemma sqrt_less : forall x:R, 0 <= x -> 1 < x -> sqrt x < x. -Proof. - intros x _. - apply sqrt_less_alt. -Qed. - -Lemma sqrt_more : forall x:R, 0 < x -> x < 1 -> x < sqrt x. -Proof. - intros x H1 H2; - generalize (sqrt_lt_1 x 1 (Rlt_le 0 x H1) (Rlt_le 0 1 Rlt_0_1) H2); - intro H3; rewrite sqrt_1 in H3; generalize (Rmult_ne (sqrt x)); - intro H4; elim H4; intros H5 H6; rewrite <- H5; pattern x at 1; - rewrite <- (sqrt_def x (Rlt_le 0 x H1)); - apply (Rmult_lt_compat_l (sqrt x) (sqrt x) 1 (sqrt_lt_R0 x H1) H3). -Qed. - -Lemma sqrt_inv x : sqrt (/ x) = / sqrt x. -Proof. -destruct (Rlt_or_le 0 x) as [H|H]. -- assert (sqrt x <> 0). - + apply Rgt_not_eq. - now apply sqrt_lt_R0. - + apply Rmult_eq_reg_r with (sqrt x); auto. - rewrite Rinv_l; auto. - rewrite <- sqrt_mult_alt. - * now rewrite -> Rinv_l, sqrt_1; auto with real. - * apply Rlt_le. - now apply Rinv_0_lt_compat. -- rewrite sqrt_neg_0 with (1 := H). - rewrite sqrt_neg_0. - + apply eq_sym, Rinv_0. - + destruct H as [H| ->]. - * now apply Rlt_le, Rinv_lt_0_compat. - * rewrite Rinv_0. - apply Rle_refl. -Qed. - -Lemma inv_sqrt_depr x : 0 < x -> / sqrt x = sqrt (/ x). -Proof. -intros _. -apply eq_sym, sqrt_inv. -Qed. - -#[deprecated(since="8.16",note="Use sqrt_inv.")] -Notation inv_sqrt := inv_sqrt_depr. - -Lemma sqrt_cauchy : - forall a b c d:R, - a * c + b * d <= sqrt (Rsqr a + Rsqr b) * sqrt (Rsqr c + Rsqr d). -Proof. - intros a b c d; apply Rsqr_incr_0_var; - [ rewrite Rsqr_mult; repeat rewrite Rsqr_sqrt; unfold Rsqr; - [ replace ((a * c + b * d) * (a * c + b * d)) with - (a * a * c * c + b * b * d * d + 2 * a * b * c * d); - [ replace ((a * a + b * b) * (c * c + d * d)) with - (a * a * c * c + b * b * d * d + (a * a * d * d + b * b * c * c)); - [ apply Rplus_le_compat_l; - replace (a * a * d * d + b * b * c * c) with - (2 * a * b * c * d + - (a * a * d * d + b * b * c * c - 2 * a * b * c * d)); - [ pattern (2 * a * b * c * d) at 1; rewrite <- Rplus_0_r; - apply Rplus_le_compat_l; - replace (a * a * d * d + b * b * c * c - 2 * a * b * c * d) - with (Rsqr (a * d - b * c)); - [ apply Rle_0_sqr | unfold Rsqr; ring ] - | ring ] - | ring ] - | ring ] - | apply - (Rplus_le_le_0_compat (Rsqr c) (Rsqr d) (Rle_0_sqr c) (Rle_0_sqr d)) - | apply - (Rplus_le_le_0_compat (Rsqr a) (Rsqr b) (Rle_0_sqr a) (Rle_0_sqr b)) ] - | apply Rmult_le_pos; apply sqrt_positivity; apply Rplus_le_le_0_compat; - apply Rle_0_sqr ]. -Qed. - -(************************************************************) -(** * Resolution of [a*X^2+b*X+c=0] *) -(************************************************************) - -Definition Delta (a:nonzeroreal) (b c:R) : R := Rsqr b - 4 * a * c. - -Definition Delta_is_pos (a:nonzeroreal) (b c:R) : Prop := 0 <= Delta a b c. - -Definition sol_x1 (a:nonzeroreal) (b c:R) : R := - (- b + sqrt (Delta a b c)) / (2 * a). - -Definition sol_x2 (a:nonzeroreal) (b c:R) : R := - (- b - sqrt (Delta a b c)) / (2 * a). - -Lemma Rsqr_sol_eq_0_1 : - forall (a:nonzeroreal) (b c x:R), - Delta_is_pos a b c -> - x = sol_x1 a b c \/ x = sol_x2 a b c -> a * Rsqr x + b * x + c = 0. -Proof. - intros; elim H0; intro. - - rewrite H1. - unfold sol_x1, Delta, Rsqr. - field_simplify. - + rewrite <- (Rsqr_pow2 (sqrt _)), Rsqr_sqrt. - * field. - apply a. - * apply H. - + apply a. - - rewrite H1. - unfold sol_x2, Delta, Rsqr. - field_simplify. - + rewrite <- (Rsqr_pow2 (sqrt _)), Rsqr_sqrt. - * field. - apply a. - * apply H. - + apply a. -Qed. - -Lemma Rsqr_sol_eq_0_0 : - forall (a:nonzeroreal) (b c x:R), - Delta_is_pos a b c -> - a * Rsqr x + b * x + c = 0 -> x = sol_x1 a b c \/ x = sol_x2 a b c. -Proof. - intros; rewrite (canonical_Rsqr a b c x) in H0; rewrite Rplus_comm in H0; - generalize - (Rplus_opp_r_uniq ((4 * a * c - Rsqr b) / (4 * a)) - (a * Rsqr (x + b / (2 * a))) H0); - assert (Rsqr b - 4 * a * c = Delta a b c) by reflexivity. - replace (- ((4 * a * c - Rsqr b) / (4 * a))) with - ((Rsqr b - 4 * a * c) / (4 * a)). - 2:{ unfold Rdiv; rewrite <- Ropp_mult_distr_l_reverse. - rewrite Ropp_minus_distr. - reflexivity. } - rewrite H1; intro; - generalize - (Rmult_eq_compat_l (/ a) (a * Rsqr (x + b / (2 * a))) - (Delta a b c / (4 * a)) H2); - replace (/ a * (a * Rsqr (x + b / (2 * a)))) with (Rsqr (x + b / (2 * a))). - 2:{ rewrite <- Rmult_assoc; rewrite Rinv_l. - - symmetry ; apply Rmult_1_l. - - apply (cond_nonzero a). } - replace (/ a * (Delta a b c / (4 * a))) with - (Rsqr (sqrt (Delta a b c) / (2 * a))). - 2:{ rewrite Rsqr_div'. - rewrite Rsqr_sqrt. - 2:assumption. - unfold Rdiv. - rewrite (Rmult_comm (/ a)). - rewrite Rmult_assoc. - rewrite <- Rinv_mult. - replace (4 * a * a) with (Rsqr (2 * a)) by ring_Rsqr. - reflexivity. } - intro; - generalize (Rsqr_eq (x + b / (2 * a)) (sqrt (Delta a b c) / (2 * a)) H3); - intro; elim H4; intro. - - left; unfold sol_x1; - generalize - (Rplus_eq_compat_l (- (b / (2 * a))) (x + b / (2 * a)) - (sqrt (Delta a b c) / (2 * a)) H5); - replace (- (b / (2 * a)) + (x + b / (2 * a))) with x by ring. - intro; rewrite H6; unfold Rdiv; ring. - - right; unfold sol_x2; - generalize - (Rplus_eq_compat_l (- (b / (2 * a))) (x + b / (2 * a)) - (- (sqrt (Delta a b c) / (2 * a))) H5); - replace (- (b / (2 * a)) + (x + b / (2 * a))) with x by ring. - intro; rewrite H6; unfold Rdiv; ring. -Qed. diff --git a/stdlib/theories/Reals/Ranalysis.v b/stdlib/theories/Reals/Ranalysis.v deleted file mode 100644 index fd22e810b3cd..000000000000 --- a/stdlib/theories/Reals/Ranalysis.v +++ /dev/null @@ -1,30 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* R. - -(****************************************************) -(** * Basic operations on functions *) -(****************************************************) -Definition plus_fct f1 f2 (x:R) : R := f1 x + f2 x. -Definition opp_fct f (x:R) : R := - f x. -Definition mult_fct f1 f2 (x:R) : R := f1 x * f2 x. -Definition mult_real_fct (a:R) f (x:R) : R := a * f x. -Definition minus_fct f1 f2 (x:R) : R := f1 x - f2 x. -Definition div_fct f1 f2 (x:R) : R := f1 x / f2 x. -Definition div_real_fct (a:R) f (x:R) : R := a / f x. -Definition comp f1 f2 (x:R) : R := f1 (f2 x). -Definition inv_fct f (x:R) : R := / f x. -Definition mirr_fct f (x:R) : R := f (- x). - -Declare Scope Rfun_scope. -Delimit Scope Rfun_scope with F. - -Arguments plus_fct (f1 f2)%_F x%_R. -Arguments mult_fct (f1 f2)%_F x%_R. -Arguments minus_fct (f1 f2)%_F x%_R. -Arguments div_fct (f1 f2)%_F x%_R. -Arguments inv_fct f%_F x%_R. -Arguments opp_fct f%_F x%_R. -Arguments mult_real_fct a%_R f%_F x%_R. -Arguments div_real_fct a%_R f%_F x%_R. -Arguments comp (f1 f2)%_F x%_R. -Arguments mirr_fct f%_F x%_R. - -Infix "+" := plus_fct : Rfun_scope. -Notation "- x" := (opp_fct x) : Rfun_scope. -Infix "*" := mult_fct : Rfun_scope. -Infix "-" := minus_fct : Rfun_scope. -Infix "/" := div_fct : Rfun_scope. -Local Notation "f1 'o' f2" := (comp f1 f2) - (at level 20, right associativity) : Rfun_scope. -Notation "/ x" := (inv_fct x) : Rfun_scope. - -Definition fct_cte (a x:R) : R := a. -Definition id (x:R) := x. - -(****************************************************) -(** * Variations of functions *) -(****************************************************) -Definition increasing f : Prop := forall x y:R, x <= y -> f x <= f y. -Definition decreasing f : Prop := forall x y:R, x <= y -> f y <= f x. -Definition strict_increasing f : Prop := forall x y:R, x < y -> f x < f y. -Definition strict_decreasing f : Prop := forall x y:R, x < y -> f y < f x. -Definition constant f : Prop := forall x y:R, f x = f y. - -(**********) -Definition no_cond (x:R) : Prop := True. - -(**********) -Definition constant_D_eq f (D:R -> Prop) (c:R) : Prop := - forall x:R, D x -> f x = c. - -(***************************************************) -(** * Definition of continuity as a limit *) -(***************************************************) - -(**********) -Definition continuity_pt f (x0:R) : Prop := continue_in f no_cond x0. -Definition continuity f : Prop := forall x:R, continuity_pt f x. - -Arguments continuity_pt f%_F x0%_R. -Arguments continuity f%_F. - -Lemma continuity_pt_locally_ext : - forall f g a x, 0 < a -> (forall y, Rdist y x < a -> f y = g y) -> - continuity_pt f x -> continuity_pt g x. -intros f g a x a0 q cf eps ep. -destruct (cf eps ep) as [a' [a'p Pa']]. -exists (Rmin a a'); split. -- unfold Rmin; destruct (Rle_dec a a'). - + assumption. - + assumption. -- intros y cy; rewrite <- !q. - + apply Pa'. - split;[| apply Rlt_le_trans with (Rmin a a');[ | apply Rmin_r]];tauto. - + rewrite Rdist_eq; assumption. - + apply Rlt_le_trans with (Rmin a a');[ | apply Rmin_l]; tauto. -Qed. - - -(**********) -Lemma continuity_pt_plus : - forall f1 f2 (x0:R), - continuity_pt f1 x0 -> continuity_pt f2 x0 -> continuity_pt (f1 + f2) x0. -Proof. - unfold continuity_pt, plus_fct; unfold continue_in; intros; - apply limit_plus; assumption. -Qed. - -Lemma continuity_pt_opp : - forall f (x0:R), continuity_pt f x0 -> continuity_pt (- f) x0. -Proof. - unfold continuity_pt, opp_fct; unfold continue_in; intros; - apply limit_Ropp; assumption. -Qed. - -Lemma continuity_pt_minus : - forall f1 f2 (x0:R), - continuity_pt f1 x0 -> continuity_pt f2 x0 -> continuity_pt (f1 - f2) x0. -Proof. - unfold continuity_pt, minus_fct; unfold continue_in; intros; - apply limit_minus; assumption. -Qed. - -Lemma continuity_pt_mult : - forall f1 f2 (x0:R), - continuity_pt f1 x0 -> continuity_pt f2 x0 -> continuity_pt (f1 * f2) x0. -Proof. - unfold continuity_pt, mult_fct; unfold continue_in; intros; - apply limit_mul; assumption. -Qed. - -Lemma continuity_pt_const : forall f (x0:R), constant f -> continuity_pt f x0. -Proof. - unfold constant, continuity_pt; unfold continue_in; - unfold limit1_in; unfold limit_in; - intros; exists 1; split; - [ apply Rlt_0_1 - | intros; generalize (H x x0); intro; rewrite H2; simpl; - rewrite Rdist_eq; assumption ]. -Qed. - -Lemma continuity_pt_scal : - forall f (a x0:R), - continuity_pt f x0 -> continuity_pt (mult_real_fct a f) x0. -Proof. - unfold continuity_pt, mult_real_fct; unfold continue_in; - intros; apply (limit_mul (fun x:R => a) f (D_x no_cond x0) a (f x0) x0). - - unfold limit1_in; unfold limit_in; intros; exists 1; split. - + apply Rlt_0_1. - + intros; rewrite Rdist_eq; assumption. - - assumption. -Qed. - -Lemma continuity_pt_inv : - forall f (x0:R), continuity_pt f x0 -> f x0 <> 0 -> continuity_pt (/ f) x0. -Proof. - intros. - replace (/ f)%F with (fun x:R => / f x). - - unfold continuity_pt; unfold continue_in; intros; - apply limit_inv; assumption. - - unfold inv_fct; reflexivity. -Qed. - -Lemma div_eq_inv : forall f1 f2, (f1 / f2)%F = (f1 * / f2)%F. -Proof. - intros; reflexivity. -Qed. - -Lemma continuity_pt_div : - forall f1 f2 (x0:R), - continuity_pt f1 x0 -> - continuity_pt f2 x0 -> f2 x0 <> 0 -> continuity_pt (f1 / f2) x0. -Proof. - intros; rewrite (div_eq_inv f1 f2); apply continuity_pt_mult; - [ assumption | apply continuity_pt_inv; assumption ]. -Qed. - -Lemma continuity_pt_comp : - forall f1 f2 (x:R), - continuity_pt f1 x -> continuity_pt f2 (f1 x) -> continuity_pt (f2 o f1) x. -Proof. - unfold continuity_pt; unfold continue_in; intros; - unfold comp. - cut - (limit1_in (fun x0:R => f2 (f1 x0)) - (Dgf (D_x no_cond x) (D_x no_cond (f1 x)) f1) ( - f2 (f1 x)) x -> - limit1_in (fun x0:R => f2 (f1 x0)) (D_x no_cond x) (f2 (f1 x)) x). - - intro; apply H1. - eapply limit_comp. - + apply H. - + apply H0. - - unfold limit1_in; unfold limit_in; unfold dist; - simpl; unfold Rdist; intros. - assert (H3 := H1 eps H2). - elim H3; intros. - exists x0. - split. - + elim H4; intros; assumption. - + intros; case (Req_dec (f1 x) (f1 x1)); intro. - * rewrite H6; unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0; - assumption. - * elim H4; intros; apply H8. - split. - -- unfold Dgf, D_x, no_cond. - split. - ++ split. - ** trivial. - ** elim H5; unfold D_x, no_cond; intros. - elim H9; intros; assumption. - ++ split. - ** trivial. - ** assumption. - -- elim H5; intros; assumption. -Qed. - -(**********) -Lemma continuity_plus : - forall f1 f2, continuity f1 -> continuity f2 -> continuity (f1 + f2). -Proof. - unfold continuity; intros; - apply (continuity_pt_plus f1 f2 x (H x) (H0 x)). -Qed. - -Lemma continuity_opp : forall f, continuity f -> continuity (- f). -Proof. - unfold continuity; intros; apply (continuity_pt_opp f x (H x)). -Qed. - -Lemma continuity_minus : - forall f1 f2, continuity f1 -> continuity f2 -> continuity (f1 - f2). -Proof. - unfold continuity; intros; - apply (continuity_pt_minus f1 f2 x (H x) (H0 x)). -Qed. - -Lemma continuity_mult : - forall f1 f2, continuity f1 -> continuity f2 -> continuity (f1 * f2). -Proof. - unfold continuity; intros; - apply (continuity_pt_mult f1 f2 x (H x) (H0 x)). -Qed. - -Lemma continuity_const : forall f, constant f -> continuity f. -Proof. - unfold continuity; intros; apply (continuity_pt_const f x H). -Qed. - -Lemma continuity_scal : - forall f (a:R), continuity f -> continuity (mult_real_fct a f). -Proof. - unfold continuity; intros; apply (continuity_pt_scal f a x (H x)). -Qed. - -Lemma continuity_inv : - forall f, continuity f -> (forall x:R, f x <> 0) -> continuity (/ f). -Proof. - unfold continuity; intros; apply (continuity_pt_inv f x (H x) (H0 x)). -Qed. - -Lemma continuity_div : - forall f1 f2, - continuity f1 -> - continuity f2 -> (forall x:R, f2 x <> 0) -> continuity (f1 / f2). -Proof. - unfold continuity; intros; - apply (continuity_pt_div f1 f2 x (H x) (H0 x) (H1 x)). -Qed. - -Lemma continuity_comp : - forall f1 f2, continuity f1 -> continuity f2 -> continuity (f2 o f1). -Proof. - unfold continuity; intros. - apply (continuity_pt_comp f1 f2 x (H x) (H0 (f1 x))). -Qed. - - -(*****************************************************) -(** * Derivative's definition using Landau's kernel *) -(*****************************************************) - -Definition derivable_pt_lim f (x l:R) : Prop := - forall eps:R, - 0 < eps -> - exists delta : posreal, - (forall h:R, - h <> 0 -> Rabs h < delta -> Rabs ((f (x + h) - f x) / h - l) < eps). - -Definition derivable_pt_abs f (x l:R) : Prop := derivable_pt_lim f x l. - -Definition derivable_pt f (x:R) := { l:R | derivable_pt_abs f x l }. -Definition derivable f := forall x:R, derivable_pt f x. - -Definition derive_pt f (x:R) (pr:derivable_pt f x) := proj1_sig pr. -Definition derive f (pr:derivable f) (x:R) := derive_pt f x (pr x). - -Arguments derivable_pt_lim f%_F x%_R l. -Arguments derivable_pt_abs f%_F (x l)%_R. -Arguments derivable_pt f%_F x%_R. -Arguments derivable f%_F. -Arguments derive_pt f%_F x%_R pr. -Arguments derive f%_F pr x. - -Definition antiderivative f (g:R -> R) (a b:R) : Prop := - (forall x:R, - a <= x <= b -> exists pr : derivable_pt g x, f x = derive_pt g x pr) /\ - a <= b. -(**************************************) -(** * Class of differential functions *) -(**************************************) -Record Differential : Type := mkDifferential - {d1 :> R -> R; cond_diff : derivable d1}. - -Record Differential_D2 : Type := mkDifferential_D2 - {d2 :> R -> R; - cond_D1 : derivable d2; - cond_D2 : derivable (derive d2 cond_D1)}. - -(**********) -Lemma uniqueness_step1 : - forall f (x l1 l2:R), - limit1_in (fun h:R => (f (x + h) - f x) / h) (fun h:R => h <> 0) l1 0 -> - limit1_in (fun h:R => (f (x + h) - f x) / h) (fun h:R => h <> 0) l2 0 -> - l1 = l2. -Proof. - intros; - apply - (single_limit (fun h:R => (f (x + h) - f x) / h) ( - fun h:R => h <> 0) l1 l2 0); try assumption. - unfold adhDa; intros; exists (alp / 2). - split. - - unfold Rdiv; apply prod_neq_R0. - + red; intro; rewrite H2 in H1; elim (Rlt_irrefl _ H1). - + apply Rinv_neq_0_compat; discrR. - - unfold Rdist; unfold Rminus; rewrite Ropp_0; - rewrite Rplus_0_r; unfold Rdiv; rewrite Rabs_mult. - replace (Rabs (/ 2)) with (/ 2). - + replace (Rabs alp) with alp. - * apply Rmult_lt_reg_l with 2. - -- prove_sup0. - -- rewrite (Rmult_comm 2); rewrite Rmult_assoc; rewrite Rinv_l; - [ idtac | discrR ]; rewrite Rmult_1_r; rewrite <-Rplus_diag; - pattern alp at 1; replace alp with (alp + 0); - [ idtac | ring ]; apply Rplus_lt_compat_l; assumption. - * symmetry ; apply Rabs_right; left; assumption. - + symmetry ; apply Rabs_right; left; change (0 < / 2); - apply Rinv_0_lt_compat; prove_sup0. -Qed. - -Lemma uniqueness_step2 : - forall f (x l:R), - derivable_pt_lim f x l -> - limit1_in (fun h:R => (f (x + h) - f x) / h) (fun h:R => h <> 0) l 0. -Proof. - unfold derivable_pt_lim; intros; unfold limit1_in; - unfold limit_in; intros. - assert (H1 := H eps H0). - elim H1; intros. - exists (pos x0). - split. - - apply (cond_pos x0). - - simpl; unfold Rdist; intros. - elim H3; intros. - apply H2; - [ assumption - | unfold Rminus in H5; rewrite Ropp_0 in H5; rewrite Rplus_0_r in H5; - assumption ]. -Qed. - -Lemma uniqueness_step3 : - forall f (x l:R), - limit1_in (fun h:R => (f (x + h) - f x) / h) (fun h:R => h <> 0) l 0 -> - derivable_pt_lim f x l. -Proof. - unfold limit1_in, derivable_pt_lim; unfold limit_in; - unfold dist; simpl; intros. - elim (H eps H0). - intros; elim H1; intros. - exists (mkposreal x0 H2). - simpl; intros; unfold Rdist in H3; apply (H3 h). - split; - [ assumption - | unfold Rminus; rewrite Ropp_0; rewrite Rplus_0_r; assumption ]. -Qed. - -Lemma uniqueness_limite : - forall f (x l1 l2:R), - derivable_pt_lim f x l1 -> derivable_pt_lim f x l2 -> l1 = l2. -Proof. - intros. - assert (H1 := uniqueness_step2 _ _ _ H). - assert (H2 := uniqueness_step2 _ _ _ H0). - assert (H3 := uniqueness_step1 _ _ _ _ H1 H2). - assumption. -Qed. - -Lemma derive_pt_eq : - forall f (x l:R) (pr:derivable_pt f x), - derive_pt f x pr = l <-> derivable_pt_lim f x l. -Proof. - intros; split. - - intro; assert (H1 := proj2_sig pr); unfold derive_pt in H; rewrite H in H1; - assumption. - - intro; assert (H1 := proj2_sig pr); unfold derivable_pt_abs in H1. - assert (H2 := uniqueness_limite _ _ _ _ H H1). - unfold derive_pt; unfold derivable_pt_abs. - symmetry ; assumption. -Qed. - -(**********) -Lemma derive_pt_eq_0 : - forall f (x l:R) (pr:derivable_pt f x), - derivable_pt_lim f x l -> derive_pt f x pr = l. -Proof. - intros; elim (derive_pt_eq f x l pr); intros. - apply (H1 H). -Qed. - -(**********) -Lemma derive_pt_eq_1 : - forall f (x l:R) (pr:derivable_pt f x), - derive_pt f x pr = l -> derivable_pt_lim f x l. -Proof. - intros; elim (derive_pt_eq f x l pr); intros. - apply (H0 H). -Qed. - - -(**********************************************************************) -(** * Equivalence of this definition with the one using limit concept *) -(**********************************************************************) -Lemma derive_pt_D_in : - forall f (df:R -> R) (x:R) (pr:derivable_pt f x), - D_in f df no_cond x <-> derive_pt f x pr = df x. -Proof. - intros; split. - - unfold D_in; unfold limit1_in; unfold limit_in; - simpl; unfold Rdist; intros. - apply derive_pt_eq_0. - unfold derivable_pt_lim. - intros; elim (H eps H0); intros alpha H1; elim H1; intros; - exists (mkposreal alpha H2); intros; generalize (H3 (x + h)); - intro; cut (x + h - x = h); - [ intro; cut (D_x no_cond x (x + h) /\ Rabs (x + h - x) < alpha); - [ intro; generalize (H6 H8); rewrite H7; intro; assumption - | split; - [ unfold D_x; split; - [ unfold no_cond; trivial - | symmetry; apply Rminus_not_eq; rewrite H7; assumption ] - | rewrite H7; assumption ] ] - | ring ]. - - intro. - assert (H0 := derive_pt_eq_1 f x (df x) pr H). - unfold D_in; unfold limit1_in; unfold limit_in; - unfold dist; simpl; unfold Rdist; - intros. - elim (H0 eps H1); intros alpha H2; exists (pos alpha); split. - + apply (cond_pos alpha). - + intros; elim H3; intros; unfold D_x in H4; elim H4; intros; cut (x0 - x <> 0). - * intro; generalize (H2 (x0 - x) H8 H5); replace (x + (x0 - x)) with x0. - -- intro; assumption. - -- ring. - * auto with real. -Qed. - -Lemma derivable_pt_lim_D_in : - forall f (df:R -> R) (x:R), - D_in f df no_cond x <-> derivable_pt_lim f x (df x). -Proof. - intros; split. - - unfold D_in; unfold limit1_in; unfold limit_in; - simpl; unfold Rdist; intros. - unfold derivable_pt_lim. - intros; elim (H eps H0); intros alpha H1; elim H1; intros; - exists (mkposreal alpha H2); intros; generalize (H3 (x + h)); - intro; cut (x + h - x = h); - [ intro; cut (D_x no_cond x (x + h) /\ Rabs (x + h - x) < alpha); - [ intro; generalize (H6 H8); rewrite H7; intro; assumption - | split; - [ unfold D_x; split; - [ unfold no_cond; trivial - | symmetry; apply Rminus_not_eq; rewrite H7; assumption ] - | rewrite H7; assumption ] ] - | ring ]. - - intro. - unfold derivable_pt_lim in H. - unfold D_in; unfold limit1_in; unfold limit_in; - unfold dist; simpl; unfold Rdist; - intros. - elim (H eps H0); intros alpha H2; exists (pos alpha); split. - + apply (cond_pos alpha). - + intros. - elim H1; intros; unfold D_x in H3; elim H3; intros; cut (x0 - x <> 0). - * intro; generalize (H2 (x0 - x) H7 H4); replace (x + (x0 - x)) with x0. - -- intro; assumption. - -- ring. - * auto with real. -Qed. - -(* Extensionally equal functions have the same derivative. *) - -Lemma derivable_pt_lim_ext : forall f g x l, (forall z, f z = g z) -> - derivable_pt_lim f x l -> derivable_pt_lim g x l. -intros f g x l fg df e ep; destruct (df e ep) as [d pd]; exists d; intros h; -rewrite <- !fg; apply pd. -Qed. - -(* extensionally equal functions have the same derivative, locally. *) - -Lemma derivable_pt_lim_locally_ext : forall f g x a b l, - a < x < b -> - (forall z, a < z < b -> f z = g z) -> - derivable_pt_lim f x l -> derivable_pt_lim g x l. -intros f g x a b l axb fg df e ep. -destruct (df e ep) as [d pd]. -assert (d'h : 0 < Rmin d (Rmin (b - x) (x - a))). -- apply Rmin_pos;[apply cond_pos | apply Rmin_pos; apply Rlt_0_minus; tauto]. -- exists (mkposreal _ d'h); simpl; intros h hn0 cmp. - rewrite <- !fg;[ |assumption | ]. - + apply pd;[assumption |]. - apply Rlt_le_trans with (1 := cmp), Rmin_l. - + assert (-h < x - a). - * apply Rle_lt_trans with (1 := Rle_abs _). - rewrite Rabs_Ropp; apply Rlt_le_trans with (1 := cmp). - rewrite Rmin_assoc; apply Rmin_r. - * assert (h < b - x). - -- apply Rle_lt_trans with (1 := Rle_abs _). - apply Rlt_le_trans with (1 := cmp). - rewrite Rmin_comm, <- Rmin_assoc; apply Rmin_l. - -- split. - ++ apply (Rplus_lt_reg_l (- h)). - replace ((-h) + (x + h)) with x by ring. - apply (Rplus_lt_reg_r (- a)). - replace (((-h) + a) + - a) with (-h) by ring. - assumption. - ++ apply (Rplus_lt_reg_r (- x)). - replace (x + h + - x) with h by ring. - assumption. -Qed. - - -(***********************************) -(** * derivability -> continuity *) -(***********************************) -(**********) -Lemma derivable_derive : - forall f (x:R) (pr:derivable_pt f x), exists l : R, derive_pt f x pr = l. -Proof. - intros; exists (proj1_sig pr). - unfold derive_pt; reflexivity. -Qed. - -Theorem derivable_continuous_pt : - forall f (x:R), derivable_pt f x -> continuity_pt f x. -Proof. - intros f x X. - generalize (derivable_derive f x X); intro. - elim H; intros l H1. - cut (l = fct_cte l x). - - intro. - rewrite H0 in H1. - generalize (derive_pt_D_in f (fct_cte l) x); intro. - elim (H2 X); intros. - generalize (H4 H1); intro. - unfold continuity_pt. - apply (cont_deriv f (fct_cte l) no_cond x H5). - - unfold fct_cte; reflexivity. -Qed. - -Theorem derivable_continuous : forall f, derivable f -> continuity f. -Proof. - unfold derivable, continuity; intros f X x. - apply (derivable_continuous_pt f x (X x)). -Qed. - -(****************************************************************) -(** * Main rules *) -(****************************************************************) - -(** ** Rules for derivable_pt_lim (value of the derivative at a point) *) - -Lemma derivable_pt_lim_id : forall x:R, derivable_pt_lim id x 1. -Proof. - intro; unfold derivable_pt_lim. - intros eps Heps; exists (mkposreal eps Heps); intros h H1 H2; - unfold id; replace ((x + h - x) / h - 1) with 0. - - rewrite Rabs_R0; apply Rle_lt_trans with (Rabs h). - + apply Rabs_pos. - + assumption. - - unfold Rminus; rewrite Rplus_assoc; rewrite (Rplus_comm x); - rewrite Rplus_assoc. - rewrite Rplus_opp_l; rewrite Rplus_0_r; unfold Rdiv; - rewrite Rinv_r. - + symmetry ; apply Rplus_opp_r. - + assumption. -Qed. - -Lemma derivable_pt_lim_comp : - forall f1 f2 (x l1 l2:R), - derivable_pt_lim f1 x l1 -> - derivable_pt_lim f2 (f1 x) l2 -> derivable_pt_lim (f2 o f1) x (l2 * l1). -Proof. - intros; assert (H1 := derivable_pt_lim_D_in f1 (fun y:R => l1) x). - elim H1; intros. - assert (H4 := H3 H). - assert (H5 := derivable_pt_lim_D_in f2 (fun y:R => l2) (f1 x)). - elim H5; intros. - assert (H8 := H7 H0). - clear H1 H2 H3 H5 H6 H7. - assert (H1 := derivable_pt_lim_D_in (f2 o f1)%F (fun y:R => l2 * l1) x). - elim H1; intros. - clear H1 H3; apply H2. - unfold comp; - cut - (D_in (fun x0:R => f2 (f1 x0)) (fun y:R => l2 * l1) - (Dgf no_cond no_cond f1) x -> - D_in (fun x0:R => f2 (f1 x0)) (fun y:R => l2 * l1) no_cond x). - - intro; apply H1. - rewrite Rmult_comm; - apply (Dcomp no_cond no_cond (fun y:R => l1) (fun y:R => l2) f1 f2 x); - assumption. - - unfold Dgf, D_in, no_cond; unfold limit1_in; - unfold limit_in; unfold dist; simpl; - unfold Rdist; intros. - elim (H1 eps H3); intros. - exists x0; intros; split. - + elim H5; intros; assumption. - + intros; elim H5; intros; apply H9; split. - * unfold D_x; split. - -- split; trivial. - -- elim H6; intros; unfold D_x in H10; elim H10; intros; assumption. - * elim H6; intros; assumption. -Qed. - -Lemma derivable_pt_lim_opp : - forall f (x l:R), derivable_pt_lim f x l -> derivable_pt_lim (- f) x (- l). -Proof. - intros f x l H. - apply uniqueness_step3. - unfold opp_fct, limit1_in, limit_in, dist; simpl; unfold Rdist. - apply uniqueness_step2 in H. - unfold limit1_in, limit_in, dist in H; simpl in H; unfold Rdist in H. - intros eps Heps; specialize (H eps Heps). - destruct H as [alp [Halp H]]; exists alp. - split; [assumption|]. - intros x0 Hx0; specialize(H x0 Hx0). - rewrite <- Rabs_Ropp in H. - match goal with H:Rabs(?a) replace b with a by (field; tauto) end. - assumption. -Qed. - -Lemma derivable_pt_lim_opp_fwd : - forall f (x l:R), derivable_pt_lim f x (- l) -> derivable_pt_lim (- f) x l. -Proof. - intros f x l H. - apply uniqueness_step3. - unfold opp_fct, limit1_in, limit_in, dist; simpl; unfold Rdist. - apply uniqueness_step2 in H. - unfold limit1_in, limit_in, dist in H; simpl in H; unfold Rdist in H. - intros eps Heps; specialize (H eps Heps). - destruct H as [alp [Halp H]]; exists alp. - split; [assumption|]. - intros x0 Hx0; specialize(H x0 Hx0). - rewrite <- Rabs_Ropp in H. - match goal with H:Rabs(?a) replace b with a by (field; tauto) end. - assumption. -Qed. - -Lemma derivable_pt_lim_opp_rev : - forall f (x l:R), derivable_pt_lim (- f) x (- l) -> derivable_pt_lim f x l. -Proof. - intros f x l H. - apply derivable_pt_lim_ext with (f := fun x => - - (f x)). - - intros; rewrite Ropp_involutive; reflexivity. - - apply derivable_pt_lim_opp_fwd; exact H. -Qed. - -Lemma derivable_pt_lim_mirr_fwd : - forall f (x l:R), derivable_pt_lim f (- x) (- l) -> derivable_pt_lim (mirr_fct f) x l. -Proof. - intros f x l H. - change (mirr_fct f) with (comp f (opp_fct id)). - replace l with ((-l) * -1) by ring. - apply derivable_pt_lim_comp; [| exact H]. - apply derivable_pt_lim_opp. - apply derivable_pt_lim_id. -Qed. - -Lemma derivable_pt_lim_mirr_rev : - forall f (x l:R), derivable_pt_lim (mirr_fct f) (- x) (- l) -> derivable_pt_lim f x l. -Proof. - intros f x l H. - apply derivable_pt_lim_ext with (f := fun x => (mirr_fct f (- x))). - - intros; unfold mirr_fct; rewrite Ropp_involutive; reflexivity. - - apply derivable_pt_lim_mirr_fwd; exact H. -Qed. - -Lemma derivable_pt_lim_plus : - forall f1 f2 (x l1 l2:R), - derivable_pt_lim f1 x l1 -> - derivable_pt_lim f2 x l2 -> derivable_pt_lim (f1 + f2) x (l1 + l2). - intros. - apply uniqueness_step3. - assert (H1 := uniqueness_step2 _ _ _ H). - assert (H2 := uniqueness_step2 _ _ _ H0). - unfold plus_fct. - cut - (forall h:R, - (f1 (x + h) + f2 (x + h) - (f1 x + f2 x)) / h = - (f1 (x + h) - f1 x) / h + (f2 (x + h) - f2 x) / h). - - intro. - generalize - (limit_plus (fun h':R => (f1 (x + h') - f1 x) / h') - (fun h':R => (f2 (x + h') - f2 x) / h') (fun h:R => h <> 0) l1 l2 0 H1 H2). - unfold limit1_in; unfold limit_in; unfold dist; - simpl; unfold Rdist; intros. - elim (H4 eps H5); intros. - exists x0. - elim H6; intros. - split. - + assumption. - + intros; rewrite H3; apply H8; assumption. - - intro; unfold Rdiv; ring. -Qed. - -Lemma derivable_pt_lim_minus : - forall f1 f2 (x l1 l2:R), - derivable_pt_lim f1 x l1 -> - derivable_pt_lim f2 x l2 -> derivable_pt_lim (f1 - f2) x (l1 - l2). -Proof. - intros. - apply uniqueness_step3. - assert (H1 := uniqueness_step2 _ _ _ H). - assert (H2 := uniqueness_step2 _ _ _ H0). - unfold minus_fct. - cut - (forall h:R, - (f1 (x + h) - f1 x) / h - (f2 (x + h) - f2 x) / h = - (f1 (x + h) - f2 (x + h) - (f1 x - f2 x)) / h). - - intro. - generalize - (limit_minus (fun h':R => (f1 (x + h') - f1 x) / h') - (fun h':R => (f2 (x + h') - f2 x) / h') (fun h:R => h <> 0) l1 l2 0 H1 H2). - unfold limit1_in; unfold limit_in; unfold dist; - simpl; unfold Rdist; intros. - elim (H4 eps H5); intros. - exists x0. - elim H6; intros. - split. - + assumption. - + intros; rewrite <- H3; apply H8; assumption. - - intro; unfold Rdiv; ring. -Qed. - -Lemma derivable_pt_lim_mult : - forall f1 f2 (x l1 l2:R), - derivable_pt_lim f1 x l1 -> - derivable_pt_lim f2 x l2 -> - derivable_pt_lim (f1 * f2) x (l1 * f2 x + f1 x * l2). -Proof. - intros. - assert (H1 := derivable_pt_lim_D_in f1 (fun y:R => l1) x). - elim H1; intros. - assert (H4 := H3 H). - assert (H5 := derivable_pt_lim_D_in f2 (fun y:R => l2) x). - elim H5; intros. - assert (H8 := H7 H0). - clear H1 H2 H3 H5 H6 H7. - assert - (H1 := - derivable_pt_lim_D_in (f1 * f2)%F (fun y:R => l1 * f2 x + f1 x * l2) x). - elim H1; intros. - clear H1 H3. - apply H2. - unfold mult_fct. - apply (Dmult no_cond (fun y:R => l1) (fun y:R => l2) f1 f2 x); assumption. -Qed. - -Lemma derivable_pt_lim_const : forall a x:R, derivable_pt_lim (fct_cte a) x 0. -Proof. - intros; unfold fct_cte, derivable_pt_lim. - intros; exists (mkposreal 1 Rlt_0_1); intros; unfold Rminus; - rewrite Rplus_opp_r; unfold Rdiv; rewrite Rmult_0_l; - rewrite Rplus_opp_r; rewrite Rabs_R0; assumption. -Qed. - -Lemma derivable_pt_lim_scal : - forall f (a x l:R), - derivable_pt_lim f x l -> derivable_pt_lim (mult_real_fct a f) x (a * l). -Proof. - intros. - assert (H0 := derivable_pt_lim_const a x). - replace (mult_real_fct a f) with (fct_cte a * f)%F. - - replace (a * l) with (0 * f x + a * l); [ idtac | ring ]. - apply (derivable_pt_lim_mult (fct_cte a) f x 0 l); assumption. - - unfold mult_real_fct, mult_fct, fct_cte; reflexivity. -Qed. - -Lemma derivable_pt_lim_div_scal : - forall f x l a, derivable_pt_lim f x l -> - derivable_pt_lim (fun y => f y / a) x (l / a). -intros f x l a df; - apply (derivable_pt_lim_ext (fun y => /a * f y)). -- intros z; rewrite Rmult_comm; reflexivity. -- unfold Rdiv; rewrite Rmult_comm; apply derivable_pt_lim_scal; assumption. -Qed. - -Lemma derivable_pt_lim_scal_right : - forall f x l a, derivable_pt_lim f x l -> - derivable_pt_lim (fun y => f y * a) x (l * a). -intros f x l a df; - apply (derivable_pt_lim_ext (fun y => a * f y)). -- intros z; rewrite Rmult_comm; reflexivity. -- unfold Rdiv; rewrite Rmult_comm; apply derivable_pt_lim_scal; assumption. -Qed. - -Lemma derivable_pt_lim_Rsqr : forall x:R, derivable_pt_lim Rsqr x (2 * x). -Proof. - intro; unfold derivable_pt_lim. - unfold Rsqr; intros eps Heps; exists (mkposreal eps Heps); - intros h H1 H2; replace (((x + h) * (x + h) - x * x) / h - 2 * x) with h. - - assumption. - - replace ((x + h) * (x + h) - x * x) with (2 * x * h + h * h); - [ idtac | ring ]. - unfold Rdiv; rewrite Rmult_plus_distr_r. - repeat rewrite Rmult_assoc. - repeat rewrite Rinv_r; [ idtac | assumption ]. - ring. -Qed. - -(** ** Rules for derivable_pt (derivability at a point) *) - -Lemma derivable_pt_id : forall x:R, derivable_pt id x. -Proof. - unfold derivable_pt; intro. - exists 1. - apply derivable_pt_lim_id. -Qed. - -Lemma derivable_pt_comp : - forall f1 f2 (x:R), - derivable_pt f1 x -> derivable_pt f2 (f1 x) -> derivable_pt (f2 o f1) x. -Proof. - unfold derivable_pt; intros f1 f2 x X X0. - elim X; intros. - elim X0; intros. - exists (x1 * x0). - apply derivable_pt_lim_comp; assumption. -Qed. - -Lemma derivable_pt_xeq: - forall (f : R -> R) (x1 x2 : R), x1=x2 -> derivable_pt f x1 -> derivable_pt f x2. -Proof. - intros f x1 x2 Heq H. - subst; assumption. -Qed. - -Lemma derivable_pt_opp : - forall (f : R -> R) (x:R), derivable_pt f x -> derivable_pt (- f) x. -Proof. - intros f x H. - unfold derivable_pt in H. - destruct H as [l H]; exists (-l). - apply derivable_pt_lim_opp; assumption. -Qed. - -Lemma derivable_pt_opp_rev: - forall (f : R -> R) (x : R), derivable_pt (- f) x -> derivable_pt f x. -Proof. - intros f x H. - unfold derivable_pt in H. - destruct H as [l H]; exists (-l). - apply derivable_pt_lim_opp_rev. - rewrite Ropp_involutive; assumption. -Qed. - -Lemma derivable_pt_mirr: - forall (f : R -> R) (x : R), derivable_pt f (-x) -> derivable_pt (mirr_fct f) x. -Proof. - intros f x H. - unfold derivable_pt in H. - destruct H as [l H]; exists (-l). - apply derivable_pt_lim_mirr_fwd. - rewrite Ropp_involutive; assumption. -Qed. - -Lemma derivable_pt_mirr_rev: - forall (f : R -> R) (x : R), derivable_pt (mirr_fct f) (- x) -> derivable_pt f x. -Proof. - intros f x H. - unfold derivable_pt in H. - destruct H as [l H]; exists (-l). - apply derivable_pt_lim_mirr_rev. - rewrite Ropp_involutive; assumption. -Qed. - -Lemma derivable_pt_mirr_prem: - forall (f : R -> R) (x : R), derivable_pt (mirr_fct f) x -> derivable_pt f (-x). -Proof. - intros f x H. - unfold derivable_pt in H. - destruct H as [l H]; exists (-l). - apply derivable_pt_lim_mirr_rev. - repeat rewrite Ropp_involutive; assumption. -Qed. - -Lemma derivable_pt_plus : - forall f1 f2 (x:R), - derivable_pt f1 x -> derivable_pt f2 x -> derivable_pt (f1 + f2) x. -Proof. - unfold derivable_pt; intros f1 f2 x X X0. - elim X; intros. - elim X0; intros. - exists (x0 + x1). - apply derivable_pt_lim_plus; assumption. -Qed. - -Lemma derivable_pt_minus : - forall f1 f2 (x:R), - derivable_pt f1 x -> derivable_pt f2 x -> derivable_pt (f1 - f2) x. -Proof. - unfold derivable_pt; intros f1 f2 x X X0. - elim X; intros. - elim X0; intros. - exists (x0 - x1). - apply derivable_pt_lim_minus; assumption. -Qed. - -Lemma derivable_pt_mult : - forall f1 f2 (x:R), - derivable_pt f1 x -> derivable_pt f2 x -> derivable_pt (f1 * f2) x. -Proof. - unfold derivable_pt; intros f1 f2 x X X0. - elim X; intros. - elim X0; intros. - exists (x0 * f2 x + f1 x * x1). - apply derivable_pt_lim_mult; assumption. -Qed. - -Lemma derivable_pt_const : forall a x:R, derivable_pt (fct_cte a) x. -Proof. - intros; unfold derivable_pt. - exists 0. - apply derivable_pt_lim_const. -Qed. - -Lemma derivable_pt_scal : - forall f (a x:R), derivable_pt f x -> derivable_pt (mult_real_fct a f) x. -Proof. - unfold derivable_pt; intros f1 a x X. - elim X; intros. - exists (a * x0). - apply derivable_pt_lim_scal; assumption. -Qed. - -Lemma derivable_pt_Rsqr : forall x:R, derivable_pt Rsqr x. -Proof. - unfold derivable_pt; intro; exists (2 * x). - apply derivable_pt_lim_Rsqr. -Qed. - -(** ** Rules for derivable (derivability on whole domain) *) - -Lemma derivable_id : derivable id. -Proof. - unfold derivable; intro; apply derivable_pt_id. -Qed. - -Lemma derivable_comp : - forall f1 f2, derivable f1 -> derivable f2 -> derivable (f2 o f1). -Proof. - unfold derivable; intros f1 f2 X X0 x. - apply (derivable_pt_comp _ _ x (X _) (X0 _)). -Qed. - -Lemma derivable_opp : forall f, derivable f -> derivable (- f). -Proof. - unfold derivable; intros f X x. - apply (derivable_pt_opp _ x (X _)). -Qed. - -Lemma derivable_mirr : forall f, derivable f -> derivable (mirr_fct f). -Proof. - unfold derivable; intros f X x. - apply (derivable_pt_mirr _ x (X _)). -Qed. - -Lemma derivable_plus : - forall f1 f2, derivable f1 -> derivable f2 -> derivable (f1 + f2). -Proof. - unfold derivable; intros f1 f2 X X0 x. - apply (derivable_pt_plus _ _ x (X _) (X0 _)). -Qed. - -Lemma derivable_minus : - forall f1 f2, derivable f1 -> derivable f2 -> derivable (f1 - f2). -Proof. - unfold derivable; intros f1 f2 X X0 x. - apply (derivable_pt_minus _ _ x (X _) (X0 _)). -Qed. - -Lemma derivable_mult : - forall f1 f2, derivable f1 -> derivable f2 -> derivable (f1 * f2). -Proof. - unfold derivable; intros f1 f2 X X0 x. - apply (derivable_pt_mult _ _ x (X _) (X0 _)). -Qed. - -Lemma derivable_const : forall a:R, derivable (fct_cte a). -Proof. - unfold derivable; intros. - apply derivable_pt_const. -Qed. - -Lemma derivable_scal : - forall f (a:R), derivable f -> derivable (mult_real_fct a f). -Proof. - unfold derivable; intros f a X x. - apply (derivable_pt_scal _ a x (X _)). -Qed. - -Lemma derivable_Rsqr : derivable Rsqr. -Proof. - unfold derivable; intro; apply derivable_pt_Rsqr. -Qed. - -(** ** Rules for derive_pt (derivative function on whole domain) *) - -Lemma derive_pt_id : forall x:R, derive_pt id x (derivable_pt_id _) = 1. -Proof. - intros. - apply derive_pt_eq_0. - apply derivable_pt_lim_id. -Qed. - -Lemma derive_pt_comp : - forall f1 f2 (x:R) (pr1:derivable_pt f1 x) (pr2:derivable_pt f2 (f1 x)), - derive_pt (f2 o f1) x (derivable_pt_comp _ _ _ pr1 pr2) = - derive_pt f2 (f1 x) pr2 * derive_pt f1 x pr1. -Proof. - intros. - assert (H := derivable_derive f1 x pr1). - assert (H0 := derivable_derive f2 (f1 x) pr2). - assert - (H1 := derivable_derive (f2 o f1)%F x (derivable_pt_comp _ _ _ pr1 pr2)). - elim H; clear H; intros l1 H. - elim H0; clear H0; intros l2 H0. - elim H1; clear H1; intros l H1. - rewrite H; rewrite H0; apply derive_pt_eq_0. - assert (H3 := proj2_sig pr1). - unfold derive_pt in H; rewrite H in H3. - assert (H4 := proj2_sig pr2). - unfold derive_pt in H0; rewrite H0 in H4. - apply derivable_pt_lim_comp; assumption. -Qed. - -Lemma derive_pt_opp : - forall f (x:R) (pr1:derivable_pt f x), - derive_pt (- f) x (derivable_pt_opp _ _ pr1) = - derive_pt f x pr1. -Proof. - intros. - apply derive_pt_eq_0. - apply derivable_pt_lim_opp_fwd. - rewrite Ropp_involutive. - apply (derive_pt_eq_1 _ _ _ pr1). - reflexivity. -Qed. - -Lemma derive_pt_opp_rev : - forall f (x:R) (pr1:derivable_pt (- f) x), - derive_pt (- f) x pr1 = - derive_pt f x (derivable_pt_opp_rev _ _ pr1). -Proof. - intros. - apply derive_pt_eq_0. - apply derivable_pt_lim_opp_fwd. - rewrite Ropp_involutive. - apply (derive_pt_eq_1 _ _ _ (derivable_pt_opp_rev _ _ pr1)). - reflexivity. -Qed. - -Lemma derive_pt_mirr : - forall f (x:R) (pr1:derivable_pt f (-x)), - derive_pt (mirr_fct f) x (derivable_pt_mirr _ _ pr1) = - derive_pt f (-x) pr1. -Proof. - intros. - apply derive_pt_eq_0. - apply derivable_pt_lim_mirr_fwd. - rewrite Ropp_involutive. - apply (derive_pt_eq_1 _ _ _ pr1). - reflexivity. -Qed. - -Lemma derive_pt_mirr_rev : - forall f (x:R) (pr1:derivable_pt (mirr_fct f) x), - derive_pt (mirr_fct f) x pr1 = - derive_pt f (-x) (derivable_pt_mirr_prem f x pr1). -Proof. - intros. - apply derive_pt_eq_0. - apply derivable_pt_lim_mirr_fwd. - rewrite Ropp_involutive. - apply (derive_pt_eq_1 _ _ _ (derivable_pt_mirr_prem f x pr1)). - reflexivity. -Qed. - -Lemma derive_pt_plus : - forall f1 f2 (x:R) (pr1:derivable_pt f1 x) (pr2:derivable_pt f2 x), - derive_pt (f1 + f2) x (derivable_pt_plus _ _ _ pr1 pr2) = - derive_pt f1 x pr1 + derive_pt f2 x pr2. -Proof. - intros. - assert (H := derivable_derive f1 x pr1). - assert (H0 := derivable_derive f2 x pr2). - assert - (H1 := derivable_derive (f1 + f2)%F x (derivable_pt_plus _ _ _ pr1 pr2)). - elim H; clear H; intros l1 H. - elim H0; clear H0; intros l2 H0. - elim H1; clear H1; intros l H1. - rewrite H; rewrite H0; apply derive_pt_eq_0. - assert (H3 := proj2_sig pr1). - unfold derive_pt in H; rewrite H in H3. - assert (H4 := proj2_sig pr2). - unfold derive_pt in H0; rewrite H0 in H4. - apply derivable_pt_lim_plus; assumption. -Qed. - -Lemma derive_pt_minus : - forall f1 f2 (x:R) (pr1:derivable_pt f1 x) (pr2:derivable_pt f2 x), - derive_pt (f1 - f2) x (derivable_pt_minus _ _ _ pr1 pr2) = - derive_pt f1 x pr1 - derive_pt f2 x pr2. -Proof. - intros. - assert (H := derivable_derive f1 x pr1). - assert (H0 := derivable_derive f2 x pr2). - assert - (H1 := derivable_derive (f1 - f2)%F x (derivable_pt_minus _ _ _ pr1 pr2)). - elim H; clear H; intros l1 H. - elim H0; clear H0; intros l2 H0. - elim H1; clear H1; intros l H1. - rewrite H; rewrite H0; apply derive_pt_eq_0. - assert (H3 := proj2_sig pr1). - unfold derive_pt in H; rewrite H in H3. - assert (H4 := proj2_sig pr2). - unfold derive_pt in H0; rewrite H0 in H4. - apply derivable_pt_lim_minus; assumption. -Qed. - -Lemma derive_pt_mult : - forall f1 f2 (x:R) (pr1:derivable_pt f1 x) (pr2:derivable_pt f2 x), - derive_pt (f1 * f2) x (derivable_pt_mult _ _ _ pr1 pr2) = - derive_pt f1 x pr1 * f2 x + f1 x * derive_pt f2 x pr2. -Proof. - intros. - assert (H := derivable_derive f1 x pr1). - assert (H0 := derivable_derive f2 x pr2). - assert - (H1 := derivable_derive (f1 * f2)%F x (derivable_pt_mult _ _ _ pr1 pr2)). - elim H; clear H; intros l1 H. - elim H0; clear H0; intros l2 H0. - elim H1; clear H1; intros l H1. - rewrite H; rewrite H0; apply derive_pt_eq_0. - assert (H3 := proj2_sig pr1). - unfold derive_pt in H; rewrite H in H3. - assert (H4 := proj2_sig pr2). - unfold derive_pt in H0; rewrite H0 in H4. - apply derivable_pt_lim_mult; assumption. -Qed. - -Lemma derive_pt_const : - forall a x:R, derive_pt (fct_cte a) x (derivable_pt_const a x) = 0. -Proof. - intros. - apply derive_pt_eq_0. - apply derivable_pt_lim_const. -Qed. - -Lemma derive_pt_scal : - forall f (a x:R) (pr:derivable_pt f x), - derive_pt (mult_real_fct a f) x (derivable_pt_scal _ _ _ pr) = - a * derive_pt f x pr. -Proof. - intros. - assert (H := derivable_derive f x pr). - assert - (H0 := derivable_derive (mult_real_fct a f) x (derivable_pt_scal _ _ _ pr)). - elim H; clear H; intros l1 H. - elim H0; clear H0; intros l2 H0. - rewrite H; apply derive_pt_eq_0. - assert (H3 := proj2_sig pr). - unfold derive_pt in H; rewrite H in H3. - apply derivable_pt_lim_scal; assumption. -Qed. - -Lemma derive_pt_Rsqr : - forall x:R, derive_pt Rsqr x (derivable_pt_Rsqr _) = 2 * x. -Proof. - intros. - apply derive_pt_eq_0. - apply derivable_pt_lim_Rsqr. -Qed. - -(** ** Definition and derivative of power function with natural number exponent *) - -Definition pow_fct (n:nat) (y:R) : R := y ^ n. - -Lemma derivable_pt_lim_pow_pos : - forall (x:R) (n:nat), - (0 < n)%nat -> derivable_pt_lim (fun y:R => y ^ n) x (INR n * x ^ pred n). -Proof. - intros. - induction n as [| n Hrecn]. - - elim (Nat.lt_irrefl _ H). - - cut (n = 0%nat \/ (0 < n)%nat). - + intro; elim H0; intro. - * rewrite H1; simpl. - replace (fun y:R => y * 1) with (id * fct_cte 1)%F by reflexivity. - replace (1 * 1) with (1 * fct_cte 1 x + id x * 0). - -- apply derivable_pt_lim_mult. - ++ apply derivable_pt_lim_id. - ++ apply derivable_pt_lim_const. - -- unfold fct_cte, id; ring. - * replace (fun y:R => y ^ S n) with (fun y:R => y * y ^ n) by reflexivity. - replace (pred (S n)) with n; [ idtac | reflexivity ]. - replace (fun y:R => y * y ^ n) with (id * (fun y:R => y ^ n))%F by reflexivity. - set (f := fun y:R => y ^ n). - replace (INR (S n) * x ^ n) with (1 * f x + id x * (INR n * x ^ pred n)). - -- apply derivable_pt_lim_mult. - { apply derivable_pt_lim_id. } - unfold f; apply Hrecn; assumption. - -- unfold f. - pattern n at 1 5; replace n with (S (pred n)). - { unfold id; rewrite S_INR; simpl. - ring. } - apply Nat.lt_succ_pred with 0%nat; assumption. - + inversion H. - * left; reflexivity. - * right. - apply Nat.lt_le_trans with 1%nat. - -- apply Nat.lt_0_succ. - -- assumption. -Qed. - -Lemma derivable_pt_lim_pow : - forall (x:R) (n:nat), - derivable_pt_lim (fun y:R => y ^ n) x (INR n * x ^ pred n). -Proof. - intros. - induction n as [| n Hrecn]. - - simpl. - rewrite Rmult_0_l. - replace (fun _:R => 1) with (fct_cte 1); - [ apply derivable_pt_lim_const | reflexivity ]. - - apply derivable_pt_lim_pow_pos. - apply Nat.lt_0_succ. -Qed. - -Lemma derivable_pt_pow : - forall (n:nat) (x:R), derivable_pt (fun y:R => y ^ n) x. -Proof. - intros; unfold derivable_pt. - exists (INR n * x ^ pred n). - apply derivable_pt_lim_pow. -Qed. - -Lemma derivable_pow : forall n:nat, derivable (fun y:R => y ^ n). -Proof. - intro; unfold derivable; intro; apply derivable_pt_pow. -Qed. - -Lemma derive_pt_pow : - forall (n:nat) (x:R), - derive_pt (fun y:R => y ^ n) x (derivable_pt_pow n x) = INR n * x ^ pred n. -Proof. - intros; apply derive_pt_eq_0. - apply derivable_pt_lim_pow. -Qed. - -(** ** Irrelevance of derivability proof for derivative *) - -Lemma pr_nu : - forall f (x:R) (pr1 pr2:derivable_pt f x), - derive_pt f x pr1 = derive_pt f x pr2. -Proof. - intros f x (x0,H0) (x1,H1). - apply (uniqueness_limite f x x0 x1 H0 H1). -Qed. - -(** In dependently typed environments it is sometimes hard to rewrite. - Having pr_nu for separate x with a proof that they are equal helps. *) - -Lemma pr_nu_xeq : - forall f (x1 x2:R) (pr1:derivable_pt f x1) (pr2:derivable_pt f x2), - x1 = x2 -> derive_pt f x1 pr1 = derive_pt f x2 pr2. -Proof. - intros f x1 x2 H1 H2 Heq. - subst. apply pr_nu. -Qed. - -(************************************************************) -(** * Local extremum's condition *) -(************************************************************) - -Theorem deriv_maximum : - forall f (a b c:R) (pr:derivable_pt f c), - a < c -> - c < b -> - (forall x:R, a < x -> x < b -> f x <= f c) -> derive_pt f c pr = 0. -Proof. - intros; case (Rtotal_order 0 (derive_pt f c pr)); intro. - { (* 0 < _ *) assert (H3 := derivable_derive f c pr). - elim H3; intros l H4; rewrite H4 in H2. - assert (H5 := derive_pt_eq_1 f c l pr H4). - cut (0 < l / 2); - [ intro - | unfold Rdiv; apply Rmult_lt_0_compat; - [ assumption | apply Rinv_0_lt_compat; prove_sup0 ] ]. - elim (H5 (l / 2) H6); intros delta H7. - cut (0 < (b - c) / 2). - 1:intro; cut (Rmin (delta / 2) ((b - c) / 2) <> 0). - 1:intro; cut (Rabs (Rmin (delta / 2) ((b - c) / 2)) < delta). - - intro. - assert (H11 := H7 (Rmin (delta / 2) ((b - c) / 2)) H9 H10). - cut (0 < Rmin (delta / 2) ((b - c) / 2)). - 1:intro; cut (a < c + Rmin (delta / 2) ((b - c) / 2)). - 1:intro; cut (c + Rmin (delta / 2) ((b - c) / 2) < b). - 1:intro; assert (H15 := H1 (c + Rmin (delta / 2) ((b - c) / 2)) H13 H14). - 1:cut ((f (c + Rmin (delta / 2) ((b - c) / 2)) - f c) - / Rmin (delta / 2) ((b - c) / 2) <= 0). - 1:intro; cut (- l < 0). - 1:intro; unfold Rminus in H11. - 1:cut ((f (c + Rmin (delta / 2) ((b + - c) / 2)) + - f c) - / Rmin (delta / 2) ((b + - c) / 2) + - l < 0). - 1:intro; cut (Rabs ((f (c + Rmin (delta / 2) ((b + - c) / 2)) + - f c) - / Rmin (delta / 2) ((b + - c) / 2) + - l) < l / 2). - + unfold Rabs; - case (Rcase_abs - ((f (c + Rmin (delta / 2) ((b + - c) / 2)) + - f c) / - Rmin (delta / 2) ((b + - c) / 2) + - l)) as [Hlt|Hge]. - * replace - (- ((f (c + Rmin (delta / 2) ((b + - c) / 2)) + - f c) - / Rmin (delta / 2) ((b + - c) / 2) + - l)) with - (l + - - ((f (c + Rmin (delta / 2) ((b + - c) / 2)) + - f c) - / Rmin (delta / 2) ((b + - c) / 2))). - -- intro; - generalize - (Rplus_lt_compat_l - (- l) - (l + - - ((f (c + Rmin (delta / 2) ((b + - c) / 2)) + - f c) - / Rmin (delta / 2) ((b + - c) / 2))) (l / 2) H19); - repeat rewrite <- Rplus_assoc; rewrite Rplus_opp_l; - rewrite Rplus_0_l; replace (- l + l / 2) with (- (l / 2)). - ++ intro; - generalize - (Ropp_lt_gt_contravar - (- ((f (c + Rmin (delta / 2) ((b + - c) / 2)) + - f c) - / Rmin (delta / 2) ((b + - c) / 2))) (- (l / 2)) H20); - repeat rewrite Ropp_involutive; intro; - generalize - (Rlt_trans 0 (l / 2) - ((f (c + Rmin (delta / 2) ((b + - c) / 2)) + - f c) - / Rmin (delta / 2) ((b + - c) / 2)) H6 H21); intro; - elim - (Rlt_irrefl - 0 - (Rlt_le_trans 0 ((f (c + Rmin (delta / 2) ((b + - c) / 2)) + - f c) - / Rmin (delta / 2) ((b + - c) / 2)) 0 H22 H16)). - ++ pattern l at 2; rewrite <-Rplus_half_diag. - ring. - -- ring. - * intro. - assert - (H20 := - Rge_le - ((f (c + Rmin (delta / 2) ((b + - c) / 2)) + - f c) - / Rmin (delta / 2) ((b + - c) / 2) + - l) 0 Hge). - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H20 H18)). - + assumption. - + rewrite <- Ropp_0; - replace - ((f (c + Rmin (delta / 2) ((b + - c) / 2)) + - f c) - / Rmin (delta / 2) ((b + - c) / 2) + - l) with - (- - (l + - - - ((f (c + Rmin (delta / 2) ((b + - c) / 2)) - f c) - / Rmin (delta / 2) ((b + - c) / 2)))). - * apply Ropp_gt_lt_contravar; - change - (0 < - l + - - - ((f (c + Rmin (delta / 2) ((b + - c) / 2)) - f c) - / Rmin (delta / 2) ((b + - c) / 2))); apply Rplus_lt_le_0_compat; - [ assumption - | rewrite <- Ropp_0; apply Ropp_ge_le_contravar; apply Rle_ge; assumption ]. - * unfold Rminus; ring. - + rewrite <- Ropp_0; apply Ropp_lt_gt_contravar; assumption. - + replace - ((f (c + Rmin (delta / 2) ((b - c) / 2)) - f c) / - Rmin (delta / 2) ((b - c) / 2)) with - (- - ((f c - f (c + Rmin (delta / 2) ((b - c) / 2))) / - Rmin (delta / 2) ((b - c) / 2))). - * rewrite <- Ropp_0; apply Ropp_ge_le_contravar; apply Rle_ge; - unfold Rdiv; apply Rmult_le_pos; - [ generalize - (Rplus_le_compat_r (- f (c + Rmin (delta * / 2) ((b - c) * / 2))) - (f (c + Rmin (delta * / 2) ((b - c) * / 2))) ( - f c) H15); rewrite Rplus_opp_r; intro; assumption - | left; apply Rinv_0_lt_compat; assumption ]. - * unfold Rdiv. - rewrite <- Ropp_mult_distr_l_reverse. - repeat rewrite <- (Rmult_comm (/ Rmin (delta * / 2) ((b - c) * / 2))). - apply Rmult_eq_reg_l with (Rmin (delta * / 2) ((b - c) * / 2)). - -- repeat rewrite <- Rmult_assoc. - rewrite Rinv_r. - ++ repeat rewrite Rmult_1_l. - ring. - ++ red; intro. - unfold Rdiv in H12; rewrite H16 in H12; elim (Rlt_irrefl 0 H12). - -- red; intro. - unfold Rdiv in H12; rewrite H16 in H12; elim (Rlt_irrefl 0 H12). - + assert (H14 := Rmin_r (delta / 2) ((b - c) / 2)). - assert - (H15 := - Rplus_le_compat_l c (Rmin (delta / 2) ((b - c) / 2)) ((b - c) / 2) H14). - apply Rle_lt_trans with (c + (b - c) / 2). - * assumption. - * apply Rmult_lt_reg_l with 2. - -- prove_sup0. - -- replace (2 * (c + (b - c) / 2)) with (c + b). - ++ replace (2 * b) with (b + b). - ** apply Rplus_lt_compat_r; assumption. - ** ring. - ++ unfold Rdiv; rewrite Rmult_plus_distr_l. - repeat rewrite (Rmult_comm 2). - rewrite Rmult_assoc; rewrite Rinv_l. - ** rewrite Rmult_1_r. - ring. - ** discrR. - + apply Rlt_trans with c. - * assumption. - * pattern c at 1; rewrite <- (Rplus_0_r c); apply Rplus_lt_compat_l; - assumption. - + cut (0 < delta / 2). - * intro; - apply - (Rmin_stable_in_posreal (mkposreal (delta / 2) H12) - (mkposreal ((b - c) / 2) H8)). - * unfold Rdiv; apply Rmult_lt_0_compat; - [ apply (cond_pos delta) | apply Rinv_0_lt_compat; prove_sup0 ]. - - unfold Rabs; case (Rcase_abs (Rmin (delta / 2) ((b - c) / 2))) as [Hlt|Hge]. - + cut (0 < delta / 2). - * intro. - generalize - (Rmin_stable_in_posreal (mkposreal (delta / 2) H10) - (mkposreal ((b - c) / 2) H8)); simpl; intro; - elim (Rlt_irrefl 0 (Rlt_trans 0 (Rmin (delta / 2) ((b - c) / 2)) 0 H11 Hlt)). - * unfold Rdiv; apply Rmult_lt_0_compat; - [ apply (cond_pos delta) | apply Rinv_0_lt_compat; prove_sup0 ]. - + apply Rle_lt_trans with (delta / 2). - * apply Rmin_l. - * unfold Rdiv; apply Rmult_lt_reg_l with 2. - -- prove_sup0. - -- rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc; rewrite Rinv_r. - ++ rewrite Rmult_1_l. - replace (2 * delta) with (delta + delta). - ** pattern delta at 2; rewrite <- (Rplus_0_r delta); - apply Rplus_lt_compat_l. - rewrite Rplus_0_r; apply (cond_pos delta). - ** apply Rplus_diag. - ++ discrR. - - cut (0 < delta / 2). - + intro; - generalize - (Rmin_stable_in_posreal (mkposreal (delta / 2) H9) - (mkposreal ((b - c) / 2) H8)); simpl; - intro; red; intro; rewrite H11 in H10; elim (Rlt_irrefl 0 H10). - + unfold Rdiv; apply Rmult_lt_0_compat; - [ apply (cond_pos delta) | apply Rinv_0_lt_compat; prove_sup0 ]. - - unfold Rdiv; apply Rmult_lt_0_compat. - + generalize (Rplus_lt_compat_r (- c) c b H0); rewrite Rplus_opp_r; intro; - assumption. - + apply Rinv_0_lt_compat; prove_sup0. - } - elim H2; intro. - { (* 0 = _ *) symmetry ; assumption. } - (* 0 > _ *) - generalize (derivable_derive f c pr); intro; elim H4; intros l H5. - rewrite H5 in H3; generalize (derive_pt_eq_1 f c l pr H5); intro; - cut (0 < - (l / 2)). - - intro; elim (H6 (- (l / 2)) H7); intros delta H9. - cut (0 < (c - a) / 2). - 1:intro; cut (Rmax (- (delta / 2)) ((a - c) / 2) < 0). - 1:intro; cut (Rmax (- (delta / 2)) ((a - c) / 2) <> 0). - 1:intro; cut (Rabs (Rmax (- (delta / 2)) ((a - c) / 2)) < delta). - 1:intro; generalize (H9 (Rmax (- (delta / 2)) ((a - c) / 2)) H11 H12); intro; - cut (a < c + Rmax (- (delta / 2)) ((a - c) / 2)). - 1:cut (c + Rmax (- (delta / 2)) ((a - c) / 2) < b). - 1:intros; generalize (H1 (c + Rmax (- (delta / 2)) ((a - c) / 2)) H15 H14); - intro; cut - (0 <= (f (c + Rmax (- (delta / 2)) ((a - c) / 2)) - f c) - / Rmax (- (delta / 2)) ((a - c) / 2)). - 1:intro; cut (0 < - l). - 1:intro; unfold Rminus in H13; - cut - (0 < (f (c + Rmax (- (delta / 2)) ((a + - c) / 2)) + - f c) - / Rmax (- (delta / 2)) ((a + - c) / 2) + - l). - 1:intro; - cut - (Rabs ((f (c + Rmax (- (delta / 2)) ((a + - c) / 2)) + - f c) - / Rmax (- (delta / 2)) ((a + - c) / 2) + - l) - < - (l / 2)). - + unfold Rabs; - case - (Rcase_abs - ((f (c + Rmax (- (delta / 2)) ((a + - c) / 2)) + - f c) - / Rmax (- (delta / 2)) ((a + - c) / 2) + - l)) as [Hlt|Hge]. - * elim - (Rlt_irrefl 0 - (Rlt_trans 0 - ((f (c + Rmax (- (delta / 2)) ((a + - c) / 2)) + - f c) - / Rmax (- (delta / 2)) ((a + - c) / 2) + - l) 0 H19 Hlt)). - * intros; - generalize - (Rplus_lt_compat_r l - ((f (c + Rmax (- (delta / 2)) ((a + - c) / 2)) + - f c) - / Rmax (- (delta / 2)) ((a + - c) / 2) + - l) ( - - (l / 2)) H20); repeat rewrite Rplus_assoc; rewrite Rplus_opp_l; - rewrite Rplus_0_r; replace (- (l / 2) + l) with (l / 2). - -- cut (l / 2 < 0). - ++ intros; - generalize - (Rlt_trans - ((f (c + Rmax (- (delta / 2)) ((a + - c) / 2)) + - f c) - / Rmax (- (delta / 2)) ((a + - c) / 2)) (l / 2) 0 H22 H21); - intro; - elim - (Rlt_irrefl 0 - (Rle_lt_trans 0 - ((f (c + Rmax (- (delta / 2)) ((a - c) / 2)) - f c) - / Rmax (- (delta / 2)) ((a - c) / 2)) 0 H17 H23)). - ++ rewrite <- (Ropp_involutive (l / 2)); rewrite <- Ropp_0; - apply Ropp_lt_gt_contravar; assumption. - -- pattern l at 3; rewrite <-Rplus_half_diag. - ring. - + assumption. - + apply Rplus_le_lt_0_compat; assumption. - + rewrite <- Ropp_0; apply Ropp_lt_gt_contravar; assumption. - + unfold Rdiv; - replace - ((f (c + Rmax (- (delta * / 2)) ((a - c) * / 2)) - f c) * - / Rmax (- (delta * / 2)) ((a - c) * / 2)) with - (- (f (c + Rmax (- (delta * / 2)) ((a - c) * / 2)) - f c) * - / - Rmax (- (delta * / 2)) ((a - c) * / 2)). - * apply Rmult_le_pos. - -- generalize - (Rplus_le_compat_l (- f (c + Rmax (- (delta * / 2)) ((a - c) * / 2))) - (f (c + Rmax (- (delta * / 2)) ((a - c) * / 2))) ( - f c) H16); rewrite Rplus_opp_l; - replace (- (f (c + Rmax (- (delta * / 2)) ((a - c) * / 2)) - f c)) with - (- f (c + Rmax (- (delta * / 2)) ((a - c) * / 2)) + f c). - ++ intro; assumption. - ++ ring. - -- left; apply Rinv_0_lt_compat; rewrite <- Ropp_0; apply Ropp_lt_gt_contravar; - assumption. - * unfold Rdiv. - rewrite Rinv_opp. - rewrite Rmult_opp_opp. - reflexivity. - + generalize (Rplus_lt_compat_l c (Rmax (- (delta / 2)) ((a - c) / 2)) 0 H10); - rewrite Rplus_0_r; intro; apply Rlt_trans with c; - assumption. - + generalize (RmaxLess2 (- (delta / 2)) ((a - c) / 2)); intro; - generalize - (Rplus_le_compat_l c ((a - c) / 2) (Rmax (- (delta / 2)) ((a - c) / 2)) H14); - intro; apply Rlt_le_trans with (c + (a - c) / 2). - * apply Rmult_lt_reg_l with 2. - -- prove_sup0. - -- replace (2 * (c + (a - c) / 2)) with (a + c). - ++ rewrite <-Rplus_diag. - apply Rplus_lt_compat_l; assumption. - ++ field; discrR. - * assumption. - + unfold Rabs; case (Rcase_abs (Rmax (- (delta / 2)) ((a - c) / 2))) as [Hlt|Hge]. - * generalize (RmaxLess1 (- (delta / 2)) ((a - c) / 2)); intro; - generalize - (Ropp_le_ge_contravar (- (delta / 2)) (Rmax (- (delta / 2)) ((a - c) / 2)) - H12); rewrite Ropp_involutive; intro; - generalize (Rge_le (delta / 2) (- Rmax (- (delta / 2)) ((a - c) / 2)) H13); - intro; apply Rle_lt_trans with (delta / 2). - -- assumption. - -- apply Rmult_lt_reg_l with 2. - ++ prove_sup0. - ++ unfold Rdiv; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc; - rewrite Rinv_r. - ** rewrite Rmult_1_l; rewrite <-Rplus_diag. - pattern delta at 2; rewrite <- (Rplus_0_r delta); - apply Rplus_lt_compat_l; rewrite Rplus_0_r; apply (cond_pos delta). - ** discrR. - * cut (- (delta / 2) < 0). - -- cut ((a - c) / 2 < 0). - ++ intros; - generalize - (Rmax_stable_in_negreal (mknegreal (- (delta / 2)) H13) - (mknegreal ((a - c) / 2) H12)); simpl; - intro; generalize (Rge_le (Rmax (- (delta / 2)) ((a - c) / 2)) 0 Hge); - intro; - elim - (Rlt_irrefl 0 - (Rle_lt_trans 0 (Rmax (- (delta / 2)) ((a - c) / 2)) 0 H15 H14)). - ++ rewrite <- Ropp_0; rewrite <- (Ropp_involutive ((a - c) / 2)); - apply Ropp_lt_gt_contravar; replace (- ((a - c) / 2)) with ((c - a) / 2). - ** assumption. - ** unfold Rdiv. - rewrite <- Ropp_mult_distr_l_reverse. - rewrite (Ropp_minus_distr a c). - reflexivity. - -- rewrite <- Ropp_0; apply Ropp_lt_gt_contravar; unfold Rdiv; - apply Rmult_lt_0_compat; - [ apply (cond_pos delta) - | assert (Hyp : 0 < 2); [ prove_sup0 | apply (Rinv_0_lt_compat 2 Hyp) ] ]. - + red; intro; rewrite H11 in H10; elim (Rlt_irrefl 0 H10). - + cut ((a - c) / 2 < 0). - * intro; cut (- (delta / 2) < 0). - -- intro; - apply - (Rmax_stable_in_negreal (mknegreal (- (delta / 2)) H11) - (mknegreal ((a - c) / 2) H10)). - -- rewrite <- Ropp_0; apply Ropp_lt_gt_contravar; unfold Rdiv; - apply Rmult_lt_0_compat; - [ apply (cond_pos delta) - | assert (Hyp : 0 < 2); [ prove_sup0 | apply (Rinv_0_lt_compat 2 Hyp) ] ]. - * rewrite <- Ropp_0; rewrite <- (Ropp_involutive ((a - c) / 2)); - apply Ropp_lt_gt_contravar; replace (- ((a - c) / 2)) with ((c - a) / 2). - -- assumption. - -- unfold Rdiv. - rewrite <- Ropp_mult_distr_l_reverse. - rewrite (Ropp_minus_distr a c). - reflexivity. - + unfold Rdiv; apply Rmult_lt_0_compat; - [ generalize (Rplus_lt_compat_r (- a) a c H); rewrite Rplus_opp_r; intro; - assumption - | assert (Hyp : 0 < 2); [ prove_sup0 | apply (Rinv_0_lt_compat 2 Hyp) ] ]. - - replace (- (l / 2)) with (- l / 2). - + unfold Rdiv; apply Rmult_lt_0_compat. - * rewrite <- Ropp_0; apply Ropp_lt_gt_contravar; assumption. - * assert (Hyp : 0 < 2); [ prove_sup0 | apply (Rinv_0_lt_compat 2 Hyp) ]. - + unfold Rdiv; apply Ropp_mult_distr_l_reverse. -Qed. - -Theorem deriv_minimum : - forall f (a b c:R) (pr:derivable_pt f c), - a < c -> - c < b -> - (forall x:R, a < x -> x < b -> f c <= f x) -> derive_pt f c pr = 0. -Proof. - intros. - rewrite <- (Ropp_involutive (derive_pt f c pr)). - apply Ropp_eq_0_compat. - rewrite <- (derive_pt_opp f c pr). - cut (forall x:R, a < x -> x < b -> (- f)%F x <= (- f)%F c). - - intro. - apply (deriv_maximum (- f)%F a b c (derivable_pt_opp _ _ pr) H H0 H2). - - intros; unfold opp_fct; apply Ropp_ge_le_contravar; apply Rle_ge. - apply (H1 x H2 H3). -Qed. - -Theorem deriv_constant2 : - forall f (a b c:R) (pr:derivable_pt f c), - a < c -> - c < b -> (forall x:R, a < x -> x < b -> f x = f c) -> derive_pt f c pr = 0. -Proof. - intros. - eapply deriv_maximum with a b; try assumption. - intros; right; apply (H1 x H2 H3). -Qed. - -(**********) -Lemma nonneg_derivative_0 : - forall f (pr:derivable f), - increasing f -> forall x:R, 0 <= derive_pt f x (pr x). -Proof. - intros; unfold increasing in H. - assert (H0 := derivable_derive f x (pr x)). - elim H0; intros l H1. - rewrite H1; case (Rtotal_order 0 l); intro. - - left; assumption. - - elim H2; intro. - + right; assumption. - + assert (H4 := derive_pt_eq_1 f x l (pr x) H1). - cut (0 < - (l / 2)). - 1:intro; elim (H4 (- (l / 2)) H5); intros delta H6. - 1:cut (delta / 2 <> 0 /\ 0 < delta / 2 /\ Rabs (delta / 2) < delta). - 1:intro; decompose [and] H7; intros; generalize (H6 (delta / 2) H8 H11); - cut (0 <= (f (x + delta / 2) - f x) / (delta / 2)). - 1:intro; cut (0 <= (f (x + delta / 2) - f x) / (delta / 2) - l). - * intro; unfold Rabs; - case (Rcase_abs ((f (x + delta / 2) - f x) / (delta / 2) - l)) as [Hlt|Hge]. - -- elim - (Rlt_irrefl 0 - (Rle_lt_trans 0 ((f (x + delta / 2) - f x) / (delta / 2) - l) 0 H12 Hlt)). - -- intros; - generalize - (Rplus_lt_compat_r l ((f (x + delta / 2) - f x) / (delta / 2) - l) - (- (l / 2)) H13); unfold Rminus; - replace (- (l / 2) + l) with (l / 2). - ++ rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r; intro; - generalize - (Rle_lt_trans 0 ((f (x + delta / 2) - f x) / (delta / 2)) (l / 2) H9 H14); - intro; cut (l / 2 < 0). - ** intro; elim (Rlt_irrefl 0 (Rlt_trans 0 (l / 2) 0 H15 H16)). - ** rewrite <- Ropp_0 in H5; - generalize (Ropp_lt_gt_contravar (-0) (- (l / 2)) H5); - repeat rewrite Ropp_involutive; intro; assumption. - ++ pattern l at 3; rewrite <-Rplus_half_diag. - ring. - * unfold Rminus; apply Rplus_le_le_0_compat. - -- unfold Rdiv; apply Rmult_le_pos. - ++ cut (x <= x + delta * / 2). - ** intro; generalize (H x (x + delta * / 2) H12); intro; - generalize (Rplus_le_compat_l (- f x) (f x) (f (x + delta * / 2)) H13); - rewrite Rplus_opp_l; rewrite Rplus_comm; intro; assumption. - ** pattern x at 1; rewrite <- (Rplus_0_r x); apply Rplus_le_compat_l; - left; assumption. - ++ left; apply Rinv_0_lt_compat; assumption. - -- left; rewrite <- Ropp_0; apply Ropp_lt_gt_contravar; assumption. - * unfold Rdiv; apply Rmult_le_pos. - -- cut (x <= x + delta * / 2). - ++ intro; generalize (H x (x + delta * / 2) H9); intro; - generalize (Rplus_le_compat_l (- f x) (f x) (f (x + delta * / 2)) H12); - rewrite Rplus_opp_l; rewrite Rplus_comm; intro; assumption. - ++ pattern x at 1; rewrite <- (Rplus_0_r x); apply Rplus_le_compat_l; - left; assumption. - -- left; apply Rinv_0_lt_compat; assumption. - * split. - -- unfold Rdiv; apply prod_neq_R0. - ++ generalize (cond_pos delta); intro; red; intro H9; rewrite H9 in H7; - elim (Rlt_irrefl 0 H7). - ++ apply Rinv_neq_0_compat; discrR. - -- split. - ++ unfold Rdiv; apply Rmult_lt_0_compat; - [ apply (cond_pos delta) | apply Rinv_0_lt_compat; prove_sup0 ]. - ++ replace (Rabs (delta / 2)) with (delta / 2). - ** unfold Rdiv; apply Rmult_lt_reg_l with 2. - { prove_sup0. } - rewrite (Rmult_comm 2). - rewrite Rmult_assoc; rewrite Rinv_l; [ idtac | discrR ]. - rewrite Rmult_1_r. - rewrite <-Rplus_diag. - pattern (pos delta) at 1; rewrite <- Rplus_0_r. - apply Rplus_lt_compat_l; apply (cond_pos delta). - ** symmetry ; apply Rabs_right. - left; change (0 < delta / 2); unfold Rdiv; - apply Rmult_lt_0_compat; - [ apply (cond_pos delta) | apply Rinv_0_lt_compat; prove_sup0 ]. - * unfold Rdiv; rewrite <- Ropp_mult_distr_l_reverse; - apply Rmult_lt_0_compat. - -- apply Rplus_lt_reg_l with l. - unfold Rminus; rewrite Rplus_opp_r; rewrite Rplus_0_r; assumption. - -- apply Rinv_0_lt_compat; prove_sup0. -Qed. diff --git a/stdlib/theories/Reals/Ranalysis2.v b/stdlib/theories/Reals/Ranalysis2.v deleted file mode 100644 index 9edda1d29a36..000000000000 --- a/stdlib/theories/Reals/Ranalysis2.v +++ /dev/null @@ -1,409 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* R), - h <> 0 -> - f2 x <> 0 -> - f2 (x + h) <> 0 -> - (f1 (x + h) / f2 (x + h) - f1 x / f2 x) / h - - (l1 * f2 x - l2 * f1 x) / Rsqr (f2 x) = - / f2 (x + h) * ((f1 (x + h) - f1 x) / h - l1) + - l1 / (f2 x * f2 (x + h)) * (f2 x - f2 (x + h)) - - f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) - f2 x) / h - l2) + - l2 * f1 x / (Rsqr (f2 x) * f2 (x + h)) * (f2 (x + h) - f2 x). -Proof. - intros; unfold Rdiv, Rminus, Rsqr. - repeat rewrite Rmult_plus_distr_r; repeat rewrite Rmult_plus_distr_l; - repeat rewrite Rinv_mult. - replace (l1 * f2 x * (/ f2 x * / f2 x)) with (l1 * / f2 x * (f2 x * / f2 x)); - [ idtac | ring ]. - replace (l1 * (/ f2 x * / f2 (x + h)) * f2 x) with - (l1 * / f2 (x + h) * (f2 x * / f2 x)); [ idtac | ring ]. - replace (l1 * (/ f2 x * / f2 (x + h)) * - f2 (x + h)) with - (- (l1 * / f2 x * (f2 (x + h) * / f2 (x + h)))); [ idtac | ring ]. - replace (f1 x * (/ f2 x * / f2 (x + h)) * (f2 (x + h) * / h)) with - (f1 x * / f2 x * / h * (f2 (x + h) * / f2 (x + h))); - [ idtac | ring ]. - replace (f1 x * (/ f2 x * / f2 (x + h)) * (- f2 x * / h)) with - (- (f1 x * / f2 (x + h) * / h * (f2 x * / f2 x))); - [ idtac | ring ]. - replace (l2 * f1 x * (/ f2 x * / f2 x * / f2 (x + h)) * f2 (x + h)) with - (l2 * f1 x * / f2 x * / f2 x * (f2 (x + h) * / f2 (x + h))); - [ idtac | ring ]. - replace (l2 * f1 x * (/ f2 x * / f2 x * / f2 (x + h)) * - f2 x) with - (- (l2 * f1 x * / f2 x * / f2 (x + h) * (f2 x * / f2 x))); - [ idtac | ring ]. - repeat rewrite Rinv_r; try assumption || ring. -Qed. - -(* begin hide *) -Notation Rmin_pos := Rmin_pos (only parsing). (* compat *) -(* end hide *) - -Lemma maj_term1 : - forall (x h eps l1 alp_f2:R) (eps_f2 alp_f1d:posreal) - (f1 f2:R -> R), - 0 < eps -> - f2 x <> 0 -> - f2 (x + h) <> 0 -> - (forall h:R, - h <> 0 -> - Rabs h < alp_f1d -> - Rabs ((f1 (x + h) - f1 x) / h - l1) < Rabs (eps * f2 x / 8)) -> - (forall a:R, - Rabs a < Rmin eps_f2 alp_f2 -> / Rabs (f2 (x + a)) < 2 / Rabs (f2 x)) -> - h <> 0 -> - Rabs h < alp_f1d -> - Rabs h < Rmin eps_f2 alp_f2 -> - Rabs (/ f2 (x + h) * ((f1 (x + h) - f1 x) / h - l1)) < eps / 4. -Proof. - intros. - assert (H7 := H3 h H6). - assert (H8 := H2 h H4 H5). - apply Rle_lt_trans with - (2 / Rabs (f2 x) * Rabs ((f1 (x + h) - f1 x) / h - l1)). - - rewrite Rabs_mult. - apply Rmult_le_compat_r. - + apply Rabs_pos. - + rewrite Rabs_inv; left; exact H7. - - apply Rlt_le_trans with (2 / Rabs (f2 x) * Rabs (eps * f2 x / 8)). - + apply Rmult_lt_compat_l. - * unfold Rdiv; apply Rmult_lt_0_compat; - [ prove_sup0 | apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption ]. - * exact H8. - + right; unfold Rdiv. - repeat rewrite Rabs_mult. - rewrite Rabs_inv. - rewrite (Rabs_pos_eq 8) by now apply IZR_le. - rewrite (Rabs_pos_eq eps). - * field. - now apply Rabs_no_R0. - * now apply Rlt_le. -Qed. - -Lemma maj_term2 : - forall (x h eps l1 alp_f2 alp_f2t2:R) (eps_f2:posreal) - (f2:R -> R), - 0 < eps -> - f2 x <> 0 -> - f2 (x + h) <> 0 -> - (forall a:R, - Rabs a < alp_f2t2 -> - Rabs (f2 (x + a) - f2 x) < Rabs (eps * Rsqr (f2 x) / (8 * l1))) -> - (forall a:R, - Rabs a < Rmin eps_f2 alp_f2 -> / Rabs (f2 (x + a)) < 2 / Rabs (f2 x)) -> - h <> 0 -> - Rabs h < alp_f2t2 -> - Rabs h < Rmin eps_f2 alp_f2 -> - l1 <> 0 -> Rabs (l1 / (f2 x * f2 (x + h)) * (f2 x - f2 (x + h))) < eps / 4. -Proof. - intros. - assert (H8 := H3 h H6). - assert (H9 := H2 h H5). - apply Rle_lt_trans with - (Rabs (l1 / (f2 x * f2 (x + h))) * Rabs (eps * Rsqr (f2 x) / (8 * l1))). - { rewrite Rabs_mult; apply Rmult_le_compat_l. - { apply Rabs_pos. } - rewrite <- (Rabs_Ropp (f2 x - f2 (x + h))); rewrite Ropp_minus_distr. - left; apply H9. } - apply Rlt_le_trans with - (Rabs (2 * (l1 / (f2 x * f2 x))) * Rabs (eps * Rsqr (f2 x) / (8 * l1))). - { apply Rmult_lt_compat_r. - { apply Rabs_pos_lt. - unfold Rdiv; unfold Rsqr; repeat apply prod_neq_R0; - try assumption || discrR. - { lra. } - apply Rinv_neq_0_compat; apply prod_neq_R0; try assumption || discrR. - } - unfold Rdiv. - repeat rewrite Rinv_mult. - repeat rewrite Rabs_mult. - replace (Rabs 2) with 2 by (symmetry; apply Rabs_right; left; prove_sup0). - rewrite (Rmult_comm 2). - replace (Rabs l1 * (Rabs (/ f2 x) * Rabs (/ f2 x)) * 2) with - (Rabs l1 * (Rabs (/ f2 x) * (Rabs (/ f2 x) * 2))) by ring. - repeat apply Rmult_lt_compat_l. - - apply Rabs_pos_lt; assumption. - - apply Rabs_pos_lt; apply Rinv_neq_0_compat; assumption. - - repeat rewrite Rabs_inv. - rewrite <- (Rmult_comm 2). - unfold Rdiv in H8; exact H8. - } - right. - unfold Rsqr, Rdiv. - rewrite 2!Rinv_mult. - repeat rewrite Rabs_mult. - repeat rewrite Rabs_inv. - replace (Rabs eps) with eps by (symmetry ; apply Rabs_right; left; assumption). - replace (Rabs 8) with 8 by (symmetry ; apply Rabs_right; left; prove_sup). - replace (Rabs 2) with 2 by (symmetry ; apply Rabs_right; left; prove_sup0). - replace 8 with (4 * 2); [ idtac | ring ]. - rewrite Rinv_mult. - replace - (2 * (Rabs l1 * (/ Rabs (f2 x) * / Rabs (f2 x))) * - (eps * (Rabs (f2 x) * Rabs (f2 x)) * (/ 4 * / 2 * / Rabs l1))) with - (eps * / 4 * (Rabs l1 * / Rabs l1) * (Rabs (f2 x) * / Rabs (f2 x)) * - (Rabs (f2 x) * / Rabs (f2 x)) * (2 * / 2)); [ idtac | ring ]. - repeat rewrite Rinv_r; try (apply Rabs_no_R0; assumption) || discrR. - ring. -Qed. - -Lemma maj_term3 : - forall (x h eps l2 alp_f2:R) (eps_f2 alp_f2d:posreal) - (f1 f2:R -> R), - 0 < eps -> - f2 x <> 0 -> - f2 (x + h) <> 0 -> - (forall h:R, - h <> 0 -> - Rabs h < alp_f2d -> - Rabs ((f2 (x + h) - f2 x) / h - l2) < - Rabs (Rsqr (f2 x) * eps / (8 * f1 x))) -> - (forall a:R, - Rabs a < Rmin eps_f2 alp_f2 -> / Rabs (f2 (x + a)) < 2 / Rabs (f2 x)) -> - h <> 0 -> - Rabs h < alp_f2d -> - Rabs h < Rmin eps_f2 alp_f2 -> - f1 x <> 0 -> - Rabs (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) - f2 x) / h - l2)) < - eps / 4. -Proof. - intros. - assert (H8 := H2 h H4 H5). - assert (H9 := H3 h H6). - apply Rle_lt_trans with - (Rabs (f1 x / (f2 x * f2 (x + h))) * Rabs (Rsqr (f2 x) * eps / (8 * f1 x))). - { rewrite Rabs_mult. - apply Rmult_le_compat_l. - { apply Rabs_pos. } - left; apply H8. } - apply Rlt_le_trans with - (Rabs (2 * (f1 x / (f2 x * f2 x))) * Rabs (Rsqr (f2 x) * eps / (8 * f1 x))). - - apply Rmult_lt_compat_r. - { apply Rabs_pos_lt. - unfold Rdiv; unfold Rsqr; repeat apply prod_neq_R0; - try assumption. - { lra. } - apply Rinv_neq_0_compat; apply prod_neq_R0; discrR || assumption. } - unfold Rdiv. - repeat rewrite Rinv_mult. - repeat rewrite Rabs_mult. - replace (Rabs 2) with 2 by (symmetry ; apply Rabs_right; left; prove_sup0). - rewrite (Rmult_comm 2). - replace (Rabs (f1 x) * (Rabs (/ f2 x) * Rabs (/ f2 x)) * 2) with - (Rabs (f1 x) * (Rabs (/ f2 x) * (Rabs (/ f2 x) * 2))) by ring. - repeat apply Rmult_lt_compat_l. - { apply Rabs_pos_lt; assumption. } - { apply Rabs_pos_lt; apply Rinv_neq_0_compat; assumption. } - repeat rewrite Rabs_inv. - rewrite <- (Rmult_comm 2). - unfold Rdiv in H9; exact H9. - - right. - unfold Rsqr, Rdiv. - rewrite 2!Rinv_mult. - repeat rewrite Rabs_mult. - repeat rewrite Rabs_inv. - replace (Rabs eps) with eps by (symmetry ; apply Rabs_right; left; assumption). - replace (Rabs 8) with 8 by (symmetry ; apply Rabs_right; left; prove_sup). - replace (Rabs 2) with 2 by (symmetry ; apply Rabs_right; left; prove_sup0). - replace 8 with (4 * 2); [ idtac | ring ]. - rewrite Rinv_mult. - replace - (2 * (Rabs (f1 x) * (/ Rabs (f2 x) * / Rabs (f2 x))) * - (Rabs (f2 x) * Rabs (f2 x) * eps * (/ 4 * / 2 * / Rabs (f1 x)))) with - (eps * / 4 * (Rabs (f2 x) * / Rabs (f2 x)) * (Rabs (f2 x) * / Rabs (f2 x)) * - (Rabs (f1 x) * / Rabs (f1 x)) * (2 * / 2)); [ idtac | ring ]. - repeat rewrite Rinv_r; try discrR || (apply Rabs_no_R0; assumption). - ring. -Qed. - -Lemma maj_term4 : - forall (x h eps l2 alp_f2 alp_f2c:R) (eps_f2:posreal) - (f1 f2:R -> R), - 0 < eps -> - f2 x <> 0 -> - f2 (x + h) <> 0 -> - (forall a:R, - Rabs a < alp_f2c -> - Rabs (f2 (x + a) - f2 x) < - Rabs (Rsqr (f2 x) * f2 x * eps / (8 * f1 x * l2))) -> - (forall a:R, - Rabs a < Rmin eps_f2 alp_f2 -> / Rabs (f2 (x + a)) < 2 / Rabs (f2 x)) -> - h <> 0 -> - Rabs h < alp_f2c -> - Rabs h < Rmin eps_f2 alp_f2 -> - f1 x <> 0 -> - l2 <> 0 -> - Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h)) * (f2 (x + h) - f2 x)) < - eps / 4. -Proof. - intros. - assert (H9 := H2 h H5). - assert (H10 := H3 h H6). - apply Rle_lt_trans with - (Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h))) * - Rabs (Rsqr (f2 x) * f2 x * eps / (8 * f1 x * l2))). - { rewrite Rabs_mult. - apply Rmult_le_compat_l. - - apply Rabs_pos. - - left; apply H9. } - apply Rlt_le_trans with - (Rabs (2 * l2 * (f1 x / (Rsqr (f2 x) * f2 x))) * - Rabs (Rsqr (f2 x) * f2 x * eps / (8 * f1 x * l2))). - { apply Rmult_lt_compat_r. - { apply Rabs_pos_lt. - unfold Rdiv; unfold Rsqr; repeat apply prod_neq_R0; - assumption || idtac. - { lra. } - apply Rinv_neq_0_compat; apply prod_neq_R0;lra. - } - unfold Rdiv. - repeat rewrite Rinv_mult. - repeat rewrite Rabs_mult. - replace (Rabs 2) with 2 by (symmetry ; apply Rabs_right; left; prove_sup0). - replace - (2 * Rabs l2 * (Rabs (f1 x) * (Rabs (/ Rsqr (f2 x)) * Rabs (/ f2 x)))) with - (Rabs l2 * (Rabs (f1 x) * (Rabs (/ Rsqr (f2 x)) * (Rabs (/ f2 x) * 2)))); - [ idtac | ring ]. - replace - (Rabs l2 * Rabs (f1 x) * (Rabs (/ Rsqr (f2 x)) * Rabs (/ f2 (x + h)))) with - (Rabs l2 * (Rabs (f1 x) * (Rabs (/ Rsqr (f2 x)) * Rabs (/ f2 (x + h))))); - [ idtac | ring ]. - repeat apply Rmult_lt_compat_l;try apply Rabs_pos_lt. - 1,2:assumption. - { apply Rinv_neq_0_compat; unfold Rsqr; - apply prod_neq_R0; assumption. } - repeat rewrite Rabs_inv. - rewrite <- (Rmult_comm 2). - unfold Rdiv in H10; exact H10. - } - right; unfold Rsqr, Rdiv. - rewrite 4!Rinv_mult. - repeat rewrite Rabs_mult. - repeat rewrite Rabs_inv. - replace (Rabs eps) with eps by (symmetry ; apply Rabs_right; left; assumption). - replace (Rabs 8) with 8 by (symmetry ; apply Rabs_right; left; prove_sup). - replace (Rabs 2) with 2 by (symmetry ; apply Rabs_right; left; prove_sup0). - replace 8 with (4 * 2); [ idtac | ring ]. - rewrite Rinv_mult. - replace - (2 * Rabs l2 * - (Rabs (f1 x) * (/ Rabs (f2 x) * / Rabs (f2 x) * / Rabs (f2 x))) * - (Rabs (f2 x) * Rabs (f2 x) * Rabs (f2 x) * eps * - (/ 4 * / 2 * / Rabs (f1 x) * / Rabs l2))) with - (eps * / 4 * (Rabs l2 * / Rabs l2) * (Rabs (f1 x) * / Rabs (f1 x)) * - (Rabs (f2 x) * / Rabs (f2 x)) * (Rabs (f2 x) * / Rabs (f2 x)) * - (Rabs (f2 x) * / Rabs (f2 x)) * (2 * / 2)); [ idtac | ring ]. - repeat rewrite Rinv_r; try discrR || (apply Rabs_no_R0; assumption). - ring. -Qed. - -Lemma D_x_no_cond : forall x a:R, a <> 0 -> D_x no_cond x (x + a). -Proof. - intros. - unfold D_x, no_cond. - split. - - trivial. - - apply Rminus_not_eq. - unfold Rminus. - rewrite Ropp_plus_distr. - rewrite <- Rplus_assoc. - rewrite Rplus_opp_r. - rewrite Rplus_0_l. - apply Ropp_neq_0_compat; assumption. -Qed. - -Lemma Rabs_4 : - forall a b c d:R, Rabs (a + b + c + d) <= Rabs a + Rabs b + Rabs c + Rabs d. -Proof. - intros. - apply Rle_trans with (Rabs (a + b) + Rabs (c + d)). - - replace (a + b + c + d) with (a + b + (c + d)); [ apply Rabs_triang | ring ]. - - apply Rle_trans with (Rabs a + Rabs b + Rabs (c + d)). - + apply Rplus_le_compat_r. - apply Rabs_triang. - + repeat rewrite Rplus_assoc; repeat apply Rplus_le_compat_l. - apply Rabs_triang. -Qed. - -Lemma Rlt_4 : - forall a b c d e f g h:R, - a < b -> c < d -> e < f -> g < h -> a + c + e + g < b + d + f + h. -Proof. - intros. repeat apply Rplus_lt_compat;assumption. -Qed. - -(* begin hide *) -Notation Rmin_2 := Rmin_glb_lt (only parsing). -(* end hide *) - -Lemma quadruple : forall x:R, 4 * x = x + x + x + x. -Proof. - intro; ring. -Qed. - -Lemma quadruple_var : forall x:R, x = x / 4 + x / 4 + x / 4 + x / 4. -Proof. - intros;field. -Qed. - -(**********) -Lemma continuous_neq_0 : - forall (f:R -> R) (x0:R), - continuity_pt f x0 -> - f x0 <> 0 -> - exists eps : posreal, (forall h:R, Rabs h < eps -> f (x0 + h) <> 0). -Proof. - intros; unfold continuity_pt in H; unfold continue_in in H; - unfold limit1_in in H; unfold limit_in in H; elim (H (Rabs (f x0 / 2))). - 2:{ change (0 < Rabs (f x0 / 2)). - apply Rabs_pos_lt; unfold Rdiv; apply prod_neq_R0;lra. } - intros; elim H1; intros. - exists (mkposreal x H2). - intros; assert (H5 := H3 (x0 + h)). - cut - (dist R_met (x0 + h) x0 < x -> - dist R_met (f (x0 + h)) (f x0) < Rabs (f x0 / 2)). - 2:{ assert (H6 := Req_dec x0 (x0 + h)); elim H6; intro. - - intro; rewrite <- H7. unfold R_met, dist; unfold Rdist; - unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0; - apply Rabs_pos_lt. - unfold Rdiv; apply prod_neq_R0; - [ assumption | apply Rinv_neq_0_compat; discrR ]. - - intro; apply H5. - split. - + unfold D_x, no_cond. - split; trivial || assumption. - + assumption. - } - unfold dist; simpl; unfold Rdist; - replace (x0 + h - x0) with h by ring. - intros; assert (H7 := H6 H4). - red; intro. - rewrite H8 in H7; unfold Rminus in H7; rewrite Rplus_0_l in H7; - rewrite Rabs_Ropp in H7; unfold Rdiv in H7; rewrite Rabs_mult in H7; - pattern (Rabs (f x0)) at 1 in H7; rewrite <- Rmult_1_r in H7. - assert (0 < Rabs (f x0)) by (apply (Rabs_pos_lt _ H0)). - assert (H10 := Rmult_lt_reg_l _ _ _ H9 H7). - assert (Rabs (/ 2) = / 2) by (apply Rabs_pos_eq;lra). - assert (Hyp : 0 < 2) by prove_sup0. - rewrite H11 in H10; assert (H12 := Rmult_lt_compat_l 2 _ _ Hyp H10); - rewrite Rmult_1_r in H12; rewrite Rinv_r in H12; - [ idtac | discrR ]. - now apply lt_IZR in H12. -Qed. diff --git a/stdlib/theories/Reals/Ranalysis3.v b/stdlib/theories/Reals/Ranalysis3.v deleted file mode 100644 index d81fc556c6b3..000000000000 --- a/stdlib/theories/Reals/Ranalysis3.v +++ /dev/null @@ -1,716 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* R) (x l1 l2:R), - derivable_pt_lim f1 x l1 -> - derivable_pt_lim f2 x l2 -> - f2 x <> 0 -> - derivable_pt_lim (f1 / f2) x ((l1 * f2 x - l2 * f1 x) / Rsqr (f2 x)). -Proof. - intros f1 f2 x l1 l2 H H0 H1. - cut (derivable_pt f2 x); - [ intro X | unfold derivable_pt; exists l2; exact H0 ]. - assert (H2 := continuous_neq_0 _ _ (derivable_continuous_pt _ _ X) H1). - elim H2; clear H2; intros eps_f2 H2. - unfold div_fct. - assert (H3 := derivable_continuous_pt _ _ X). - unfold continuity_pt in H3; unfold continue_in in H3; unfold limit1_in in H3; - unfold limit_in in H3; unfold dist in H3. - simpl in H3; unfold Rdist in H3. - elim (H3 (Rabs (f2 x) / 2)); - [ idtac - | unfold Rdiv; change (0 < Rabs (f2 x) * / 2); - apply Rmult_lt_0_compat; - [ apply Rabs_pos_lt; assumption | apply Rinv_0_lt_compat; prove_sup0 ] ]. - clear H3; intros alp_f2 H3. - assert - (H4:forall x0:R, - Rabs (x0 - x) < alp_f2 -> Rabs (f2 x0 - f2 x) < Rabs (f2 x) / 2). { - intros. - case (Req_dec x x0); intro. - + rewrite <- H5; unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0; - unfold Rdiv; apply Rmult_lt_0_compat; - [ apply Rabs_pos_lt; assumption | apply Rinv_0_lt_compat; prove_sup0 ]. - + elim H3; intros. - apply H7. - split. - * unfold D_x, no_cond; split. - -- trivial. - -- assumption. - * assumption. - } - assert (H5:forall a:R, Rabs (a - x) < alp_f2 -> Rabs (f2 x) / 2 < Rabs (f2 a)). { - intros. - assert (H6 := H4 a H5). - rewrite <- (Rabs_Ropp (f2 a - f2 x)) in H6. - rewrite Ropp_minus_distr in H6. - assert (H7 := Rle_lt_trans _ _ _ (Rabs_triang_inv _ _) H6). - apply Rplus_lt_reg_l with (- Rabs (f2 a) + Rabs (f2 x) / 2). - rewrite Rplus_assoc. - rewrite Rplus_half_diag. - do 2 rewrite (Rplus_comm (- Rabs (f2 a))). - rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r. - unfold Rminus in H7; assumption. - } - assert - (Maj:forall a:R, - Rabs a < Rmin eps_f2 alp_f2 -> / Rabs (f2 (x + a)) < 2 / Rabs (f2 x)). { - intros. - unfold Rdiv. - apply Rmult_lt_reg_l with (Rabs (f2 (x + a))). - - apply Rabs_pos_lt; apply H2. - apply Rlt_le_trans with (Rmin eps_f2 alp_f2). - + assumption. - + apply Rmin_l. - - rewrite Rinv_r. - + apply Rmult_lt_reg_l with (Rabs (f2 x)). - { apply Rabs_pos_lt; assumption. } - rewrite Rmult_1_r. - rewrite (Rmult_comm (Rabs (f2 x))). - repeat rewrite Rmult_assoc. - rewrite Rinv_l. - 2:{ apply Rabs_no_R0; assumption. } - rewrite Rmult_1_r. - apply Rmult_lt_reg_l with (/ 2). - { apply Rinv_0_lt_compat; prove_sup0. } - repeat rewrite (Rmult_comm (/ 2)). - repeat rewrite Rmult_assoc. - rewrite Rinv_r. - 2:{ discrR. } - rewrite Rmult_1_r. - unfold Rdiv in H5; apply H5. - replace (x + a - x) with a by ring. - assert (H7 := Rlt_le_trans _ _ _ H6 (Rmin_r _ _)); assumption. - + apply Rabs_no_R0; apply H2. - assert (H7 := Rlt_le_trans _ _ _ H6 (Rmin_l _ _)); assumption. - } - unfold derivable_pt_lim; intros. - elim (H (Rabs (eps * f2 x / 8))); - [ idtac - | unfold Rdiv; change (0 < Rabs (eps * f2 x * / 8)); - apply Rabs_pos_lt; repeat apply prod_neq_R0; - [ red; intro H7; rewrite H7 in H6; elim (Rlt_irrefl _ H6) - | assumption - | apply Rinv_neq_0_compat; discrR ] ]. - intros alp_f1d H7. - case (Req_dec (f1 x) 0); intro. - 1:case (Req_dec l1 0); intro. - 3:case (Req_dec l1 0); intro. - 3:case (Req_dec l2 0); intro. - 5:case (Req_dec l2 0); intro. -(***********************************) -(* First case *) -(* (f1 x)=0 l1 =0 *) -(***********************************) - - cut (0 < Rmin eps_f2 (Rmin alp_f2 alp_f1d)); - [ intro - | repeat apply Rmin_pos; - [ apply (cond_pos eps_f2) - | elim H3; intros; assumption - | apply (cond_pos alp_f1d) ] ]. - exists (mkposreal (Rmin eps_f2 (Rmin alp_f2 alp_f1d)) H10). - simpl; intros. - assert (H13 := Rlt_le_trans _ _ _ H12 (Rmin_r _ _)). - assert (H14 := Rlt_le_trans _ _ _ H12 (Rmin_l _ _)). - assert (H15 := Rlt_le_trans _ _ _ H13 (Rmin_r _ _)). - assert (H16 := Rlt_le_trans _ _ _ H13 (Rmin_l _ _)). - assert (H17 := H7 _ H11 H15). - rewrite formule; [ idtac | assumption | assumption | apply H2; apply H14 ]. - apply Rle_lt_trans with - (Rabs (/ f2 (x + h) * ((f1 (x + h) - f1 x) / h - l1)) + - Rabs (l1 / (f2 x * f2 (x + h)) * (f2 x - f2 (x + h))) + - Rabs (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) - f2 x) / h - l2)) + - Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h)) * (f2 (x + h) - f2 x))). - { unfold Rminus. - rewrite <- - (Rabs_Ropp (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) + - f2 x) / h + - l2))). - apply Rabs_4. } - repeat rewrite Rabs_mult. - replace eps with (eps / 4 + eps / 4 + eps / 4 + eps / 4) by field. - cut (Rabs (/ f2 (x + h)) * Rabs ((f1 (x + h) - f1 x) / h - l1) < eps / 4). - 2:{ rewrite <- Rabs_mult. - apply (maj_term1 x h eps l1 alp_f2 eps_f2 alp_f1d f1 f2); - try assumption || apply H2. - - apply H14. - - apply Rmin_2; assumption. } - cut (Rabs (l1 / (f2 x * f2 (x + h))) * Rabs (f2 x - f2 (x + h)) < eps / 4). - 2:{ rewrite H9. - unfold Rdiv; repeat rewrite Rmult_0_r || rewrite Rmult_0_l. - rewrite Rabs_R0; rewrite Rmult_0_l. - apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup ]. } - cut - (Rabs (f1 x / (f2 x * f2 (x + h))) * Rabs ((f2 (x + h) - f2 x) / h - l2) < - eps / 4). - 2:{ rewrite H8. - unfold Rdiv; repeat rewrite Rmult_0_r || rewrite Rmult_0_l. - rewrite Rabs_R0; rewrite Rmult_0_l. - apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup ]. } - cut - (Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h))) * Rabs (f2 (x + h) - f2 x) < - eps / 4). - 2:{ rewrite H8. - unfold Rdiv; repeat rewrite Rmult_0_r || rewrite Rmult_0_l. - rewrite Rabs_R0; rewrite Rmult_0_l. - apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup ]. } - intros. lra. -(***********************************) -(* Second case *) -(* (f1 x)=0 l1<>0 *) -(***********************************) -- assert (H10 := derivable_continuous_pt _ _ X). - unfold continuity_pt in H10. - unfold continue_in in H10. - unfold limit1_in in H10. - unfold limit_in in H10. - unfold dist in H10. - simpl in H10. - unfold Rdist in H10. - elim (H10 (Rabs (eps * Rsqr (f2 x) / (8 * l1)))). - 2:{ change (0 < Rabs (eps * Rsqr (f2 x) / (8 * l1))). - apply Rabs_pos_lt; unfold Rdiv, Rsqr; repeat rewrite Rmult_assoc; - repeat apply prod_neq_R0. - - lra. - - assumption. - - assumption. - - apply Rinv_neq_0_compat; apply prod_neq_R0; [discrR | assumption]. } - clear H10; intros alp_f2t2 H10. - assert - (H11:forall a:R, - Rabs a < alp_f2t2 -> - Rabs (f2 (x + a) - f2 x) < Rabs (eps * Rsqr (f2 x) / (8 * l1))). { - intros. - elim H10; intros. - case (Req_dec a 0); intro. - - rewrite H14; rewrite Rplus_0_r. - unfold Rminus; rewrite Rplus_opp_r. - rewrite Rabs_R0. - apply Rabs_pos_lt. - unfold Rdiv, Rsqr; repeat rewrite Rmult_assoc. - repeat apply prod_neq_R0; try assumption. - + now apply Rgt_not_eq. - + apply Rinv_neq_0_compat; apply prod_neq_R0; [discrR | assumption]. - - apply H13. - split. - + apply D_x_no_cond; assumption. - + replace (x + a - x) with a; [ assumption | ring ]. - } - assert (0 < Rmin (Rmin eps_f2 alp_f1d) (Rmin alp_f2 alp_f2t2)). { - repeat apply Rmin_pos. - - apply (cond_pos eps_f2). - - apply (cond_pos alp_f1d). - - elim H3; intros; assumption. - - elim H10; intros; assumption. - } - exists (mkposreal (Rmin (Rmin eps_f2 alp_f1d) (Rmin alp_f2 alp_f2t2)) H12). - simpl. - intros. - assert (H15 := Rlt_le_trans _ _ _ H14 (Rmin_r _ _)). - assert (H16 := Rlt_le_trans _ _ _ H14 (Rmin_l _ _)). - assert (H17 := Rlt_le_trans _ _ _ H15 (Rmin_l _ _)). - assert (H18 := Rlt_le_trans _ _ _ H15 (Rmin_r _ _)). - assert (H19 := Rlt_le_trans _ _ _ H16 (Rmin_l _ _)). - assert (H20 := Rlt_le_trans _ _ _ H16 (Rmin_r _ _)). - clear H14 H15 H16. - rewrite formule; try assumption. - 2:{ apply H2; assumption. } - apply Rle_lt_trans with - (Rabs (/ f2 (x + h) * ((f1 (x + h) - f1 x) / h - l1)) + - Rabs (l1 / (f2 x * f2 (x + h)) * (f2 x - f2 (x + h))) + - Rabs (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) - f2 x) / h - l2)) + - Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h)) * (f2 (x + h) - f2 x))). - { unfold Rminus. - rewrite <- - (Rabs_Ropp (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) + - f2 x) / h + - l2))). - apply Rabs_4. } - repeat rewrite Rabs_mult. - replace eps with (eps / 4 + eps / 4 + eps / 4 + eps / 4) by field. - cut (Rabs (/ f2 (x + h)) * Rabs ((f1 (x + h) - f1 x) / h - l1) < eps / 4). - 2:{ rewrite <- Rabs_mult. - apply (maj_term1 x h eps l1 alp_f2 eps_f2 alp_f1d f1 f2); try assumption. - - apply H2; assumption. - - apply Rmin_2; assumption. } - cut (Rabs (l1 / (f2 x * f2 (x + h))) * Rabs (f2 x - f2 (x + h)) < eps / 4). - 2:{ rewrite <- Rabs_mult. - apply (maj_term2 x h eps l1 alp_f2 alp_f2t2 eps_f2 f2); try assumption. - - apply H2; assumption. - - apply Rmin_2; assumption. } - cut - (Rabs (f1 x / (f2 x * f2 (x + h))) * Rabs ((f2 (x + h) - f2 x) / h - l2) < - eps / 4). - 2:{ rewrite H8. - unfold Rdiv; repeat rewrite Rmult_0_r || rewrite Rmult_0_l. - rewrite Rabs_R0; rewrite Rmult_0_l. - apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup ]. } - cut - (Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h))) * Rabs (f2 (x + h) - f2 x) < - eps / 4). - 2:{ rewrite H8. - unfold Rdiv; repeat rewrite Rmult_0_r || rewrite Rmult_0_l. - rewrite Rabs_R0; rewrite Rmult_0_l. - apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup ]. } - intros. lra. -(***********************************) -(* Third case *) -(* (f1 x)<>0 l1=0 l2=0 *) -(***********************************) -- elim (H0 (Rabs (Rsqr (f2 x) * eps / (8 * f1 x)))); - [ idtac - | apply Rabs_pos_lt; unfold Rdiv, Rsqr; repeat rewrite Rmult_assoc; - repeat apply prod_neq_R0 ; - [ assumption - | assumption - | now apply Rgt_not_eq - | apply Rinv_neq_0_compat; apply prod_neq_R0; discrR || assumption ] ]. - intros alp_f2d H12. - assert (0 < Rmin (Rmin eps_f2 alp_f2) (Rmin alp_f1d alp_f2d)). { - repeat apply Rmin_pos. - - apply (cond_pos eps_f2). - - elim H3; intros; assumption. - - apply (cond_pos alp_f1d). - - apply (cond_pos alp_f2d). - } - exists (mkposreal (Rmin (Rmin eps_f2 alp_f2) (Rmin alp_f1d alp_f2d)) H11). - simpl. - intros. - assert (H15 := Rlt_le_trans _ _ _ H14 (Rmin_l _ _)). - assert (H16 := Rlt_le_trans _ _ _ H14 (Rmin_r _ _)). - assert (H17 := Rlt_le_trans _ _ _ H15 (Rmin_l _ _)). - assert (H18 := Rlt_le_trans _ _ _ H15 (Rmin_r _ _)). - assert (H19 := Rlt_le_trans _ _ _ H16 (Rmin_l _ _)). - assert (H20 := Rlt_le_trans _ _ _ H16 (Rmin_r _ _)). - clear H15 H16. - rewrite formule; try assumption. - 2:{ apply H2; assumption. } - apply Rle_lt_trans with - (Rabs (/ f2 (x + h) * ((f1 (x + h) - f1 x) / h - l1)) + - Rabs (l1 / (f2 x * f2 (x + h)) * (f2 x - f2 (x + h))) + - Rabs (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) - f2 x) / h - l2)) + - Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h)) * (f2 (x + h) - f2 x))). - { unfold Rminus. - rewrite <- - (Rabs_Ropp (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) + - f2 x) / h + - l2))). - apply Rabs_4. } - repeat rewrite Rabs_mult. - replace eps with (eps / 4 + eps / 4 + eps / 4 + eps / 4) by field. - cut (Rabs (/ f2 (x + h)) * Rabs ((f1 (x + h) - f1 x) / h - l1) < eps / 4). - 2:{ rewrite <- Rabs_mult. - apply (maj_term1 x h eps l1 alp_f2 eps_f2 alp_f1d f1 f2); assumption || idtac. - - apply H2; assumption. - - apply Rmin_2; assumption. } - cut (Rabs (l1 / (f2 x * f2 (x + h))) * Rabs (f2 x - f2 (x + h)) < eps / 4). - 2:{ rewrite H9. - unfold Rdiv; repeat rewrite Rmult_0_r || rewrite Rmult_0_l. - rewrite Rabs_R0; rewrite Rmult_0_l. - apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup ]. } - cut - (Rabs (f1 x / (f2 x * f2 (x + h))) * Rabs ((f2 (x + h) - f2 x) / h - l2) < - eps / 4). - 2:{ rewrite <- Rabs_mult. - apply (maj_term3 x h eps l2 alp_f2 eps_f2 alp_f2d f1 f2); try assumption. - - apply H2; assumption. - - apply Rmin_2; assumption. } - cut - (Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h))) * Rabs (f2 (x + h) - f2 x) < - eps / 4). - 2:{ rewrite H10. - unfold Rdiv; repeat rewrite Rmult_0_r || rewrite Rmult_0_l. - rewrite Rabs_R0; rewrite Rmult_0_l. - apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup ]. } - intros. lra. -(***********************************) -(* Fourth case *) -(* (f1 x)<>0 l1=0 l2<>0 *) -(***********************************) -- elim (H0 (Rabs (Rsqr (f2 x) * eps / (8 * f1 x)))); - [ idtac - | apply Rabs_pos_lt; unfold Rsqr, Rdiv; - repeat apply prod_neq_R0 ; - [ assumption.. - | now apply Rgt_not_eq - | apply Rinv_neq_0_compat; apply prod_neq_R0; discrR || assumption ] ]. - intros alp_f2d H11. - assert (H12 := derivable_continuous_pt _ _ X). - unfold continuity_pt in H12. - unfold continue_in in H12. - unfold limit1_in in H12. - unfold limit_in in H12. - unfold dist in H12. - simpl in H12. - unfold Rdist in H12. - elim (H12 (Rabs (Rsqr (f2 x) * f2 x * eps / (8 * f1 x * l2)))). - 2:{ change (0 < Rabs (Rsqr (f2 x) * f2 x * eps / (8 * f1 x * l2))). - apply Rabs_pos_lt. - unfold Rsqr, Rdiv. - repeat rewrite Rinv_mult. - repeat apply prod_neq_R0; try assumption. - - lra. - - apply Rinv_neq_0_compat; discrR. - - apply Rinv_neq_0_compat; assumption. - - apply Rinv_neq_0_compat; assumption. } - intros alp_f2c H13. - assert (0 < Rmin (Rmin eps_f2 alp_f2) (Rmin alp_f1d (Rmin alp_f2d alp_f2c))). { - repeat apply Rmin_pos. - - apply (cond_pos eps_f2). - - elim H3; intros; assumption. - - apply (cond_pos alp_f1d). - - apply (cond_pos alp_f2d). - - elim H13; intros; assumption. - } - exists (mkposreal (Rmin (Rmin eps_f2 alp_f2) (Rmin alp_f1d (Rmin alp_f2d alp_f2c))) H14). - simpl; intros. - assert (H17 := Rlt_le_trans _ _ _ H16 (Rmin_l _ _)). - assert (H18 := Rlt_le_trans _ _ _ H16 (Rmin_r _ _)). - assert (H19 := Rlt_le_trans _ _ _ H18 (Rmin_r _ _)). - assert (H20 := Rlt_le_trans _ _ _ H19 (Rmin_l _ _)). - assert (H21 := Rlt_le_trans _ _ _ H19 (Rmin_r _ _)). - assert (H22 := Rlt_le_trans _ _ _ H18 (Rmin_l _ _)). - assert (H23 := Rlt_le_trans _ _ _ H17 (Rmin_l _ _)). - assert (H24 := Rlt_le_trans _ _ _ H17 (Rmin_r _ _)). - clear H16 H17 H18 H19. - assert - (forall a:R, - Rabs a < alp_f2c -> - Rabs (f2 (x + a) - f2 x) < - Rabs (Rsqr (f2 x) * f2 x * eps / (8 * f1 x * l2))). { - intros. - case (Req_dec a 0); intro. - - rewrite H17; rewrite Rplus_0_r. - unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0. - apply Rabs_pos_lt. - unfold Rdiv, Rsqr. - repeat rewrite Rinv_mult. - repeat apply prod_neq_R0; try assumption. - + red; intro H18; rewrite H18 in H6; elim (Rlt_irrefl _ H6). - + apply Rinv_neq_0_compat; discrR. - + apply Rinv_neq_0_compat; assumption. - + apply Rinv_neq_0_compat; assumption. - - discrR. - elim H13; intros. - apply H19. - split. - + apply D_x_no_cond; assumption. - + replace (x + a - x) with a; [ assumption | ring ]. - } - rewrite formule; try assumption. - 2:{ apply H2; assumption. } - apply Rle_lt_trans with - (Rabs (/ f2 (x + h) * ((f1 (x + h) - f1 x) / h - l1)) + - Rabs (l1 / (f2 x * f2 (x + h)) * (f2 x - f2 (x + h))) + - Rabs (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) - f2 x) / h - l2)) + - Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h)) * (f2 (x + h) - f2 x))). - { unfold Rminus. - rewrite <- (Rabs_Ropp (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) + - f2 x) / h + - l2))). - apply Rabs_4. } - repeat rewrite Rabs_mult. - replace eps with (eps / 4 + eps / 4 + eps / 4 + eps / 4) by field. - cut (Rabs (/ f2 (x + h)) * Rabs ((f1 (x + h) - f1 x) / h - l1) < eps / 4). - 2:{ rewrite <- Rabs_mult. - apply (maj_term1 x h eps l1 alp_f2 eps_f2 alp_f1d f1 f2); try assumption. - - apply H2; assumption. - - apply Rmin_2; assumption. } - cut (Rabs (l1 / (f2 x * f2 (x + h))) * Rabs (f2 x - f2 (x + h)) < eps / 4). - 2:{ rewrite H9. - unfold Rdiv; repeat rewrite Rmult_0_r || rewrite Rmult_0_l. - rewrite Rabs_R0; rewrite Rmult_0_l. - apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup ]. } - cut - (Rabs (f1 x / (f2 x * f2 (x + h))) * Rabs ((f2 (x + h) - f2 x) / h - l2) < - eps / 4). - 2:{ rewrite <- Rabs_mult. - apply (maj_term3 x h eps l2 alp_f2 eps_f2 alp_f2d f1 f2); try assumption. - - apply H2; assumption. - - apply Rmin_2; assumption. } - cut - (Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h))) * Rabs (f2 (x + h) - f2 x) < - eps / 4). - 2:{ rewrite <- Rabs_mult. - apply (maj_term4 x h eps l2 alp_f2 alp_f2c eps_f2 f1 f2); try assumption. - - apply H2; assumption. - - apply Rmin_2; assumption. } - intros. lra. -(***********************************) -(* Fifth case *) -(* (f1 x)<>0 l1<>0 l2=0 *) -(***********************************) -- assert (H11 := derivable_continuous_pt _ _ X). - unfold continuity_pt in H11. - unfold continue_in in H11. - unfold limit1_in in H11. - unfold limit_in in H11. - unfold dist in H11. - simpl in H11. - unfold Rdist in H11. - elim (H11 (Rabs (eps * Rsqr (f2 x) / (8 * l1)))). - 2:{ change (0 < Rabs (eps * Rsqr (f2 x) / (8 * l1))). - apply Rabs_pos_lt. - unfold Rdiv, Rsqr; rewrite Rinv_mult. - repeat apply prod_neq_R0;try apply Rinv_neq_0_compat; lra. } - clear H11; intros alp_f2t2 H11. - elim (H0 (Rabs (Rsqr (f2 x) * eps / (8 * f1 x)))). - 2:{ apply Rabs_pos_lt. - unfold Rdiv, Rsqr; rewrite Rinv_mult. - repeat apply prod_neq_R0; try apply Rinv_neq_0_compat; lra. } - intros alp_f2d H12. - assert (0 < Rmin (Rmin eps_f2 alp_f2) (Rmin alp_f1d (Rmin alp_f2d alp_f2t2))). { - repeat apply Rmin_pos. - - apply (cond_pos eps_f2). - - elim H3; intros; assumption. - - apply (cond_pos alp_f1d). - - apply (cond_pos alp_f2d). - - elim H11; intros; assumption. - } - exists (mkposreal (Rmin (Rmin eps_f2 alp_f2) (Rmin alp_f1d (Rmin alp_f2d alp_f2t2))) H13). - simpl. - intros. - assert - (forall a:R, - Rabs a < alp_f2t2 -> - Rabs (f2 (x + a) - f2 x) < Rabs (eps * Rsqr (f2 x) / (8 * l1))). { - intros. - case (Req_dec a 0); intro. - - rewrite H17; rewrite Rplus_0_r; unfold Rminus; rewrite Rplus_opp_r; - rewrite Rabs_R0. - apply Rabs_pos_lt. - unfold Rdiv; rewrite Rinv_mult. - unfold Rsqr. - repeat apply prod_neq_R0; try apply Rinv_neq_0_compat;lra. - - elim H11; intros. - apply H19. - split. - + apply D_x_no_cond; assumption. - + replace (x + a - x) with a; [ assumption | ring ]. - } - assert (H17 := Rlt_le_trans _ _ _ H15 (Rmin_l _ _)). - assert (H18 := Rlt_le_trans _ _ _ H15 (Rmin_r _ _)). - assert (H19 := Rlt_le_trans _ _ _ H17 (Rmin_r _ _)). - assert (H20 := Rlt_le_trans _ _ _ H17 (Rmin_l _ _)). - assert (H21 := Rlt_le_trans _ _ _ H18 (Rmin_r _ _)). - assert (H22 := Rlt_le_trans _ _ _ H18 (Rmin_l _ _)). - assert (H23 := Rlt_le_trans _ _ _ H21 (Rmin_l _ _)). - assert (H24 := Rlt_le_trans _ _ _ H21 (Rmin_r _ _)). - clear H15 H17 H18 H21. - rewrite formule; auto; try assumption. - apply Rle_lt_trans with - (Rabs (/ f2 (x + h) * ((f1 (x + h) - f1 x) / h - l1)) + - Rabs (l1 / (f2 x * f2 (x + h)) * (f2 x - f2 (x + h))) + - Rabs (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) - f2 x) / h - l2)) + - Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h)) * (f2 (x + h) - f2 x))). - { unfold Rminus. - rewrite <- (Rabs_Ropp (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) + - f2 x) / h + - l2))). - apply Rabs_4. } - repeat rewrite Rabs_mult. - replace eps with (eps / 4 + eps / 4 + eps / 4 + eps / 4) by field. - cut (Rabs (/ f2 (x + h)) * Rabs ((f1 (x + h) - f1 x) / h - l1) < eps / 4). - 2:{ rewrite <- Rabs_mult. - apply (maj_term1 x h eps l1 alp_f2 eps_f2 alp_f1d f1 f2); try assumption. - - apply H2; assumption. - - apply Rmin_2; assumption. } - cut (Rabs (l1 / (f2 x * f2 (x + h))) * Rabs (f2 x - f2 (x + h)) < eps / 4). - 2:{ rewrite <- Rabs_mult. - apply (maj_term2 x h eps l1 alp_f2 alp_f2t2 eps_f2 f2); try assumption. - - apply H2; assumption. - - apply Rmin_2; assumption. } - cut - (Rabs (f1 x / (f2 x * f2 (x + h))) * Rabs ((f2 (x + h) - f2 x) / h - l2) < - eps / 4). - 2:{ rewrite <- Rabs_mult. - apply (maj_term3 x h eps l2 alp_f2 eps_f2 alp_f2d f1 f2); try assumption. - - apply H2; assumption. - - apply Rmin_2; assumption. } - cut - (Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h))) * Rabs (f2 (x + h) - f2 x) < - eps / 4). - 2:{ rewrite H10. - unfold Rdiv; repeat rewrite Rmult_0_r || rewrite Rmult_0_l. - rewrite Rabs_R0; rewrite Rmult_0_l. - apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup ]. } - intros. lra. -(***********************************) -(* Sixth case *) -(* (f1 x)<>0 l1<>0 l2<>0 *) -(***********************************) -- elim (H0 (Rabs (Rsqr (f2 x) * eps / (8 * f1 x)))). - 2:{ apply Rabs_pos_lt. - unfold Rdiv, Rsqr; rewrite Rinv_mult. - repeat apply prod_neq_R0; try apply Rinv_neq_0_compat; lra. } - intros alp_f2d H11. - assert (H12 := derivable_continuous_pt _ _ X). - unfold continuity_pt in H12. - unfold continue_in in H12. - unfold limit1_in in H12. - unfold limit_in in H12. - unfold dist in H12. - simpl in H12. - unfold Rdist in H12. - elim (H12 (Rabs (Rsqr (f2 x) * f2 x * eps / (8 * f1 x * l2)))). - 2:{ change (0 < Rabs (Rsqr (f2 x) * f2 x * eps / (8 * f1 x * l2))); - apply Rabs_pos_lt. - unfold Rdiv, Rsqr; rewrite Rinv_mult. - repeat apply prod_neq_R0; try apply Rinv_neq_0_compat; lra. } - intros alp_f2c H13. - elim (H12 (Rabs (eps * Rsqr (f2 x) / (8 * l1)))). - 2:{ change (0 < Rabs (eps * Rsqr (f2 x) / (8 * l1))); apply Rabs_pos_lt. - unfold Rdiv, Rsqr; rewrite Rinv_mult. - repeat apply prod_neq_R0; try apply Rinv_neq_0_compat; lra. } - intros alp_f2t2 H14. - assert - (0 < - Rmin (Rmin (Rmin eps_f2 alp_f2) (Rmin alp_f1d alp_f2d)) - (Rmin alp_f2c alp_f2t2)). { - repeat apply Rmin_pos. - - apply (cond_pos eps_f2). - - elim H3; intros; assumption. - - apply (cond_pos alp_f1d). - - apply (cond_pos alp_f2d). - - elim H13; intros; assumption. - - elim H14; intros; assumption. - } - exists - (mkposreal - (Rmin (Rmin (Rmin eps_f2 alp_f2) (Rmin alp_f1d alp_f2d)) - (Rmin alp_f2c alp_f2t2)) H15). - simpl. - intros. - assert (H18 := Rlt_le_trans _ _ _ H17 (Rmin_l _ _)). - assert (H19 := Rlt_le_trans _ _ _ H17 (Rmin_r _ _)). - assert (H20 := Rlt_le_trans _ _ _ H18 (Rmin_l _ _)). - assert (H21 := Rlt_le_trans _ _ _ H18 (Rmin_r _ _)). - assert (H22 := Rlt_le_trans _ _ _ H19 (Rmin_l _ _)). - assert (H23 := Rlt_le_trans _ _ _ H19 (Rmin_r _ _)). - assert (H24 := Rlt_le_trans _ _ _ H20 (Rmin_l _ _)). - assert (H25 := Rlt_le_trans _ _ _ H20 (Rmin_r _ _)). - assert (H26 := Rlt_le_trans _ _ _ H21 (Rmin_l _ _)). - assert (H27 := Rlt_le_trans _ _ _ H21 (Rmin_r _ _)). - clear H17 H18 H19 H20 H21. - cut - (forall a:R, - Rabs a < alp_f2t2 -> - Rabs (f2 (x + a) - f2 x) < Rabs (eps * Rsqr (f2 x) / (8 * l1))). - 2:{ intros. - case (Req_dec a 0); intro. - - rewrite H18; rewrite Rplus_0_r; unfold Rminus; rewrite Rplus_opp_r; - rewrite Rabs_R0; apply Rabs_pos_lt. - unfold Rdiv, Rsqr; rewrite Rinv_mult. - repeat apply prod_neq_R0; try apply Rinv_neq_0_compat; lra. - - elim H14; intros. - apply H20. - split. - + unfold D_x, no_cond; split. - * trivial. - * symmetry; apply Rminus_not_eq. - replace (x + a - x) with a; [ assumption | ring ]. - + replace (x + a - x) with a; [ assumption | ring ]. } - cut - (forall a:R, - Rabs a < alp_f2c -> - Rabs (f2 (x + a) - f2 x) < - Rabs (Rsqr (f2 x) * f2 x * eps / (8 * f1 x * l2))). - 2:{ intros. - case (Req_dec a 0); intro. - - rewrite H18; rewrite Rplus_0_r; unfold Rminus; rewrite Rplus_opp_r; - rewrite Rabs_R0; apply Rabs_pos_lt. - unfold Rdiv, Rsqr; rewrite Rinv_mult. - repeat apply prod_neq_R0; try apply Rinv_neq_0_compat; lra. - - elim H13; intros. - apply H20. - split. - + apply D_x_no_cond; assumption. - + replace (x + a - x) with a; [ assumption | ring ]. } - intros. - rewrite formule; try assumption. 2:{ auto. } - apply Rle_lt_trans with - (Rabs (/ f2 (x + h) * ((f1 (x + h) - f1 x) / h - l1)) + - Rabs (l1 / (f2 x * f2 (x + h)) * (f2 x - f2 (x + h))) + - Rabs (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) - f2 x) / h - l2)) + - Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h)) * (f2 (x + h) - f2 x))). - { unfold Rminus. - rewrite <- (Rabs_Ropp (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) + - f2 x) / h + - l2))). - apply Rabs_4. } - repeat rewrite Rabs_mult. - replace eps with (eps / 4 + eps / 4 + eps / 4 + eps / 4) by field. - cut (Rabs (/ f2 (x + h)) * Rabs ((f1 (x + h) - f1 x) / h - l1) < eps / 4). - 2:{ rewrite <- Rabs_mult. - apply (maj_term1 x h eps l1 alp_f2 eps_f2 alp_f1d f1 f2); try assumption. - - apply H2; assumption. - - apply Rmin_2; assumption. } - cut (Rabs (l1 / (f2 x * f2 (x + h))) * Rabs (f2 x - f2 (x + h)) < eps / 4). - 2:{ rewrite <- Rabs_mult. - apply (maj_term2 x h eps l1 alp_f2 alp_f2t2 eps_f2 f2); try assumption. - - apply H2; assumption. - - apply Rmin_2; assumption. } - cut - (Rabs (f1 x / (f2 x * f2 (x + h))) * Rabs ((f2 (x + h) - f2 x) / h - l2) < - eps / 4). - 2:{ rewrite <- Rabs_mult. - apply (maj_term3 x h eps l2 alp_f2 eps_f2 alp_f2d f1 f2); try assumption. - - apply H2; assumption. - - apply Rmin_2; assumption. } - cut - (Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h))) * Rabs (f2 (x + h) - f2 x) < - eps / 4). - 2:{ rewrite <- Rabs_mult. - apply (maj_term4 x h eps l2 alp_f2 alp_f2c eps_f2 f1 f2); try assumption. - - apply H2; assumption. - - apply Rmin_2; assumption. } - intros. lra. -Qed. - -Lemma derivable_pt_div : - forall (f1 f2:R -> R) (x:R), - derivable_pt f1 x -> - derivable_pt f2 x -> f2 x <> 0 -> derivable_pt (f1 / f2) x. -Proof. - unfold derivable_pt. - intros f1 f2 x X X0 H. - elim X; intros. - elim X0; intros. - exists ((x0 * f2 x - x1 * f1 x) / Rsqr (f2 x)). - apply derivable_pt_lim_div; assumption. -Qed. - -Lemma derivable_div : - forall f1 f2:R -> R, - derivable f1 -> - derivable f2 -> (forall x:R, f2 x <> 0) -> derivable (f1 / f2). -Proof. - unfold derivable; intros f1 f2 X X0 H x. - apply (derivable_pt_div _ _ _ (X x) (X0 x) (H x)). -Qed. - -Lemma derive_pt_div : - forall (f1 f2:R -> R) (x:R) (pr1:derivable_pt f1 x) - (pr2:derivable_pt f2 x) (na:f2 x <> 0), - derive_pt (f1 / f2) x (derivable_pt_div _ _ _ pr1 pr2 na) = - (derive_pt f1 x pr1 * f2 x - derive_pt f2 x pr2 * f1 x) / Rsqr (f2 x). -Proof. - intros. - assert (H := derivable_derive f1 x pr1). - assert (H0 := derivable_derive f2 x pr2). - assert - (H1 := derivable_derive (f1 / f2)%F x (derivable_pt_div _ _ _ pr1 pr2 na)). - elim H; clear H; intros l1 H. - elim H0; clear H0; intros l2 H0. - elim H1; clear H1; intros l H1. - rewrite H; rewrite H0; apply derive_pt_eq_0. - assert (H3 := proj2_sig pr1). - unfold derive_pt in H; rewrite H in H3. - assert (H4 := proj2_sig pr2). - unfold derive_pt in H0; rewrite H0 in H4. - apply derivable_pt_lim_div; assumption. -Qed. diff --git a/stdlib/theories/Reals/Ranalysis4.v b/stdlib/theories/Reals/Ranalysis4.v deleted file mode 100644 index b63cfbddb889..000000000000 --- a/stdlib/theories/Reals/Ranalysis4.v +++ /dev/null @@ -1,394 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* R) (x:R), - f x <> 0 -> derivable_pt f x -> derivable_pt (/ f) x. -Proof. - intros f x H X; cut (derivable_pt (fct_cte 1 / f) x -> derivable_pt (/ f) x). - - intro X0; apply X0. - apply derivable_pt_div. - + apply derivable_pt_const. - + assumption. - + assumption. - - unfold div_fct, inv_fct, fct_cte; intros (x0,p); - unfold derivable_pt; exists x0; - unfold derivable_pt_abs; unfold derivable_pt_lim; - unfold derivable_pt_abs in p; unfold derivable_pt_lim in p; - intros; elim (p eps H0); intros; exists x1; intros; - unfold Rdiv in H1; unfold Rdiv; rewrite <- (Rmult_1_l (/ f x)); - rewrite <- (Rmult_1_l (/ f (x + h))). - apply H1; assumption. -Qed. - -(**********) -Lemma pr_nu_var : - forall (f g:R -> R) (x:R) (pr1:derivable_pt f x) (pr2:derivable_pt g x), - f = g -> derive_pt f x pr1 = derive_pt g x pr2. -Proof. - unfold derivable_pt, derive_pt; intros f g x (x0,p0) (x1,p1) ->. - apply uniqueness_limite with g x; assumption. -Qed. - -(**********) -Lemma pr_nu_var2 : - forall (f g:R -> R) (x:R) (pr1:derivable_pt f x) (pr2:derivable_pt g x), - (forall h:R, f h = g h) -> derive_pt f x pr1 = derive_pt g x pr2. -Proof. - unfold derivable_pt, derive_pt; intros f g x (x0,p0) (x1,p1) H. - assert (H0 := uniqueness_step2 _ _ _ p0). - assert (H1 := uniqueness_step2 _ _ _ p1). - cut (limit1_in (fun h:R => (f (x + h) - f x) / h) (fun h:R => h <> 0) x1 0). - - intro H2; assert (H3 := uniqueness_step1 _ _ _ _ H0 H2). - assumption. - - unfold limit1_in; unfold limit_in; unfold dist; - simpl; unfold Rdist; unfold limit1_in in H1; - unfold limit_in in H1; unfold dist in H1; simpl in H1; - unfold Rdist in H1. - intros; elim (H1 eps H2); intros. - elim H3; intros. - exists x2. - split. - + assumption. - + intros; do 2 rewrite H; apply H5; assumption. -Qed. - -(**********) -Lemma derivable_inv : - forall f:R -> R, (forall x:R, f x <> 0) -> derivable f -> derivable (/ f). -Proof. - intros f H X. - unfold derivable; intro x. - apply derivable_pt_inv. - - apply (H x). - - apply (X x). -Qed. - -Lemma derive_pt_inv : - forall (f:R -> R) (x:R) (pr:derivable_pt f x) (na:f x <> 0), - derive_pt (/ f) x (derivable_pt_inv f x na pr) = - - derive_pt f x pr / Rsqr (f x). -Proof. - intros; - replace (derive_pt (/ f) x (derivable_pt_inv f x na pr)) with - (derive_pt (fct_cte 1 / f) x - (derivable_pt_div (fct_cte 1) f x (derivable_pt_const 1 x) pr na)). - - rewrite derive_pt_div; rewrite derive_pt_const; unfold fct_cte; - rewrite Rmult_0_l; rewrite Rmult_1_r; unfold Rminus; - rewrite Rplus_0_l; reflexivity. - - apply pr_nu_var2. - intro; unfold div_fct, fct_cte, inv_fct. - unfold Rdiv; ring. -Qed. - -(** Rabsolu *) -Lemma Rabs_derive_1 : forall x:R, 0 < x -> derivable_pt_lim Rabs x 1. -Proof. - intros. - unfold derivable_pt_lim; intros. - exists (mkposreal x H); intros. - rewrite (Rabs_right x). - - rewrite (Rabs_right (x + h)). - + rewrite Rplus_comm. - unfold Rminus; rewrite Rplus_assoc; rewrite Rplus_opp_r. - rewrite Rplus_0_r; unfold Rdiv; rewrite Rinv_r. - * rewrite Rplus_opp_r; rewrite Rabs_R0; apply H0. - * apply H1. - + apply Rle_ge. - destruct (Rcase_abs h) as [Hlt|Hgt]. - * rewrite (Rabs_left h Hlt) in H2. - left; rewrite Rplus_comm; apply Rplus_lt_reg_l with (- h); rewrite Rplus_0_r; - rewrite <- Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_l; - apply H2. - * apply Rplus_le_le_0_compat. - -- left; apply H. - -- apply Rge_le; apply Hgt. - - left; apply H. -Qed. - -Lemma Rabs_derive_2 : forall x:R, x < 0 -> derivable_pt_lim Rabs x (-1). -Proof. - intros. - unfold derivable_pt_lim; intros. - cut (0 < - x). - - intro; exists (mkposreal (- x) H1); intros. - rewrite (Rabs_left x). - + rewrite (Rabs_left (x + h)). - * replace ((-(x + h) - - x) / h - -1) with 0 by now field. - rewrite Rabs_R0; apply H0. - * destruct (Rcase_abs h) as [Hlt|Hgt]. - -- apply Ropp_lt_cancel. - rewrite Ropp_0; rewrite Ropp_plus_distr; apply Rplus_lt_0_compat. - ++ apply H1. - ++ apply Ropp_0_gt_lt_contravar; apply Hlt. - -- rewrite (Rabs_right h Hgt) in H3. - apply Rplus_lt_reg_l with (- x); rewrite Rplus_0_r; rewrite <- Rplus_assoc; - rewrite Rplus_opp_l; rewrite Rplus_0_l; apply H3. - + apply H. - - apply Ropp_0_gt_lt_contravar; apply H. -Qed. - -(** Rabsolu is derivable for all x <> 0 *) -Lemma Rderivable_pt_abs : forall x:R, x <> 0 -> derivable_pt Rabs x. -Proof. - intros. - destruct (total_order_T x 0) as [[Hlt|Heq]|Hgt]. - - unfold derivable_pt; exists (-1). - apply (Rabs_derive_2 x Hlt). - - elim H; exact Heq. - - unfold derivable_pt; exists 1. - apply (Rabs_derive_1 x Hgt). -Qed. - -(** Rabsolu is continuous for all x *) -Lemma Rcontinuity_abs : continuity Rabs. -Proof. - unfold continuity; intro. - case (Req_dec x 0); intro. - - unfold continuity_pt; unfold continue_in; - unfold limit1_in; unfold limit_in; - simpl; unfold Rdist; intros; exists eps; - split. - + apply H0. - + intros; rewrite H; rewrite Rabs_R0; unfold Rminus; rewrite Ropp_0; - rewrite Rplus_0_r; rewrite Rabs_Rabsolu; elim H1; - intros; rewrite H in H3; unfold Rminus in H3; rewrite Ropp_0 in H3; - rewrite Rplus_0_r in H3; apply H3. - - apply derivable_continuous_pt; apply (Rderivable_pt_abs x H). -Qed. - -(** Finite sums : Sum a_k x^k *) -Lemma continuity_finite_sum : - forall (An:nat -> R) (N:nat), - continuity (fun y:R => sum_f_R0 (fun k:nat => An k * y ^ k) N). -Proof. - intros; unfold continuity; intro. - induction N as [| N HrecN]. - - simpl. - apply continuity_pt_const. - unfold constant; intros; reflexivity. - - replace (fun y:R => sum_f_R0 (fun k:nat => An k * y ^ k) (S N)) with - ((fun y:R => sum_f_R0 (fun k:nat => (An k * y ^ k)%R) N) + - (fun y:R => (An (S N) * y ^ S N)%R))%F. - + apply continuity_pt_plus. - * apply HrecN. - * replace (fun y:R => An (S N) * y ^ S N) with - (mult_real_fct (An (S N)) (fun y:R => y ^ S N)). - -- apply continuity_pt_scal. - apply derivable_continuous_pt. - apply derivable_pt_pow. - -- reflexivity. - + reflexivity. -Qed. - -Lemma derivable_pt_lim_fs : - forall (An:nat -> R) (x:R) (N:nat), - (0 < N)%nat -> - derivable_pt_lim (fun y:R => sum_f_R0 (fun k:nat => An k * y ^ k) N) x - (sum_f_R0 (fun k:nat => INR (S k) * An (S k) * x ^ k) (pred N)). -Proof. - intros; induction N as [| N HrecN]. - { elim (Nat.lt_irrefl _ H). } - assert (N = 0%nat \/ (0 < N)%nat) by nia. - elim H0; intro. - { rewrite H1. - simpl. - change (fun y:R => An 0%nat * 1 + An 1%nat * (y * 1)) with - (fct_cte (An 0%nat * 1) + mult_real_fct (An 1%nat) (id * fct_cte 1))%F. - replace (1 * An 1%nat * 1) with (0 + An 1%nat * (1 * fct_cte 1 x + id x * 0)) - by (unfold fct_cte, id; ring). - apply derivable_pt_lim_plus. - - apply derivable_pt_lim_const. - - apply derivable_pt_lim_scal. - apply derivable_pt_lim_mult. - + apply derivable_pt_lim_id. - + apply derivable_pt_lim_const. } - change (fun y:R => sum_f_R0 (fun k:nat => An k * y ^ k) (S N)) with - ((fun y:R => sum_f_R0 (fun k:nat => (An k * y ^ k)%R) N) + - (fun y:R => (An (S N) * y ^ S N)%R))%F. - replace (sum_f_R0 (fun k:nat => INR (S k) * An (S k) * x ^ k) (pred (S N))) - with - (sum_f_R0 (fun k:nat => INR (S k) * An (S k) * x ^ k) (pred N) + - An (S N) * (INR (S (pred (S N))) * x ^ pred (S N))). - 2:{ assert (pred (S N) = S (pred N)) by lia. - rewrite H2. - rewrite tech5. - apply Rplus_eq_compat_l. - rewrite <- H2. - change (pred (S N)) with N. - ring. } - apply derivable_pt_lim_plus. - { apply HrecN. assumption. } - change (fun y:R => An (S N) * y ^ S N) with - (mult_real_fct (An (S N)) (fun y:R => y ^ S N)). - apply derivable_pt_lim_scal. - apply derivable_pt_lim_pow. -Qed. - -Lemma derivable_pt_lim_finite_sum : - forall (An:nat -> R) (x:R) (N:nat), - derivable_pt_lim (fun y:R => sum_f_R0 (fun k:nat => An k * y ^ k) N) x - match N with - | O => 0 - | _ => sum_f_R0 (fun k:nat => INR (S k) * An (S k) * x ^ k) (pred N) - end. -Proof. - intros. - induction N as [| N HrecN]. - - simpl. - rewrite Rmult_1_r. - replace (fun _:R => An 0%nat) with (fct_cte (An 0%nat)); - [ apply derivable_pt_lim_const | reflexivity ]. - - apply derivable_pt_lim_fs; apply Nat.lt_0_succ. -Qed. - -Lemma derivable_pt_finite_sum : - forall (An:nat -> R) (N:nat) (x:R), - derivable_pt (fun y:R => sum_f_R0 (fun k:nat => An k * y ^ k) N) x. -Proof. - intros. - unfold derivable_pt. - assert (H := derivable_pt_lim_finite_sum An x N). - induction N as [| N HrecN]. - - exists 0; apply H. - - exists - (sum_f_R0 (fun k:nat => INR (S k) * An (S k) * x ^ k) (pred (S N))); - apply H. -Qed. - -Lemma derivable_finite_sum : - forall (An:nat -> R) (N:nat), - derivable (fun y:R => sum_f_R0 (fun k:nat => An k * y ^ k) N). -Proof. - intros; unfold derivable; intro; apply derivable_pt_finite_sum. -Qed. - -(** Regularity of hyperbolic functions *) -Lemma derivable_pt_lim_cosh : forall x:R, derivable_pt_lim cosh x (sinh x). -Proof. - intro. - unfold cosh, sinh; unfold Rdiv. - replace (fun x0:R => (exp x0 + exp (- x0)) * / 2) with - ((exp + comp exp (- id)) * fct_cte (/ 2))%F; [ idtac | reflexivity ]. - replace ((exp x - exp (- x)) * / 2) with - ((exp x + exp (- x) * -1) * fct_cte (/ 2) x + - (exp + comp exp (- id))%F x * 0). - - apply derivable_pt_lim_mult. - + apply derivable_pt_lim_plus. - * apply derivable_pt_lim_exp. - * apply derivable_pt_lim_comp. - -- apply derivable_pt_lim_opp. - apply derivable_pt_lim_id. - -- apply derivable_pt_lim_exp. - + apply derivable_pt_lim_const. - - unfold plus_fct, mult_real_fct, comp, opp_fct, id, fct_cte; ring. -Qed. - -Lemma derivable_pt_lim_sinh : forall x:R, derivable_pt_lim sinh x (cosh x). -Proof. - intro. - unfold cosh, sinh; unfold Rdiv. - replace (fun x0:R => (exp x0 - exp (- x0)) * / 2) with - ((exp - comp exp (- id)) * fct_cte (/ 2))%F; [ idtac | reflexivity ]. - replace ((exp x + exp (- x)) * / 2) with - ((exp x - exp (- x) * -1) * fct_cte (/ 2) x + - (exp - comp exp (- id))%F x * 0). - - apply derivable_pt_lim_mult. - + apply derivable_pt_lim_minus. - * apply derivable_pt_lim_exp. - * apply derivable_pt_lim_comp. - -- apply derivable_pt_lim_opp. - apply derivable_pt_lim_id. - -- apply derivable_pt_lim_exp. - + apply derivable_pt_lim_const. - - unfold plus_fct, mult_real_fct, comp, opp_fct, id, fct_cte; ring. -Qed. - -Lemma derivable_pt_exp : forall x:R, derivable_pt exp x. -Proof. - intro. - unfold derivable_pt. - exists (exp x). - apply derivable_pt_lim_exp. -Qed. - -Lemma derivable_pt_cosh : forall x:R, derivable_pt cosh x. -Proof. - intro. - unfold derivable_pt. - exists (sinh x). - apply derivable_pt_lim_cosh. -Qed. - -Lemma derivable_pt_sinh : forall x:R, derivable_pt sinh x. -Proof. - intro. - unfold derivable_pt. - exists (cosh x). - apply derivable_pt_lim_sinh. -Qed. - -Lemma derivable_exp : derivable exp. -Proof. - unfold derivable; apply derivable_pt_exp. -Qed. - -Lemma derivable_cosh : derivable cosh. -Proof. - unfold derivable; apply derivable_pt_cosh. -Qed. - -Lemma derivable_sinh : derivable sinh. -Proof. - unfold derivable; apply derivable_pt_sinh. -Qed. - -Lemma derive_pt_exp : - forall x:R, derive_pt exp x (derivable_pt_exp x) = exp x. -Proof. - intro; apply derive_pt_eq_0. - apply derivable_pt_lim_exp. -Qed. - -Lemma derive_pt_cosh : - forall x:R, derive_pt cosh x (derivable_pt_cosh x) = sinh x. -Proof. - intro; apply derive_pt_eq_0. - apply derivable_pt_lim_cosh. -Qed. - -Lemma derive_pt_sinh : - forall x:R, derive_pt sinh x (derivable_pt_sinh x) = cosh x. -Proof. - intro; apply derive_pt_eq_0. - apply derivable_pt_lim_sinh. -Qed. - -Lemma sinh_lt : forall x y, x < y -> sinh x < sinh y. -intros x y xy; destruct (MVT_cor2 sinh cosh x y xy) as [c [Pc _]]. -- intros; apply derivable_pt_lim_sinh. -- apply Rplus_lt_reg_l with (Ropp (sinh x)); rewrite Rplus_opp_l, Rplus_comm. - unfold Rminus at 1 in Pc; rewrite Pc; apply Rmult_lt_0_compat;[ | ]. - + unfold cosh; apply Rmult_lt_0_compat;[|apply Rinv_0_lt_compat, Rlt_0_2]. - now apply Rplus_lt_0_compat; apply exp_pos. - + now apply Rlt_0_minus; assumption. -Qed. diff --git a/stdlib/theories/Reals/Ranalysis5.v b/stdlib/theories/Reals/Ranalysis5.v deleted file mode 100644 index 4433d1ef25fe..000000000000 --- a/stdlib/theories/Reals/Ranalysis5.v +++ /dev/null @@ -1,1399 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* R, forall lb ub, - lb < ub -> - (forall x y, lb <= x -> x < y -> y <= ub -> f x < f y) -> - (forall x, f lb <= x -> x <= f ub -> (comp f g) x = id x) -> - (forall x , f lb <= x -> x <= f ub -> lb <= g x <= ub) -> - (forall x y, f lb <= x -> x < y -> y <= f ub -> g x < g y). -Proof. - intros f g lb ub lb_lt_ub f_incr f_eq_g g_ok x y lb_le_x x_lt_y y_le_ub. - assert (x_encad : f lb <= x <= f ub) by lra. - assert (y_encad : f lb <= y <= f ub) by lra. - assert (gx_encad := g_ok _ (proj1 x_encad) (proj2 x_encad)). - assert (gy_encad := g_ok _ (proj1 y_encad) (proj2 y_encad)). - case (Rlt_dec (g x) (g y)); [ easy |]. - intros Hfalse. - assert (Temp := Rnot_lt_le _ _ Hfalse). - enough (y <= x) by lra. - replace y with (id y) by easy. - replace x with (id x) by easy. - rewrite <- f_eq_g by easy. - rewrite <- f_eq_g by easy. - assert (f_incr2 : forall x y, lb <= x -> x <= y -> y < ub -> f x <= f y). { - intros m n lb_le_m m_le_n n_lt_ub. - case (m_le_n). - - intros; apply Rlt_le, f_incr, Rlt_le; assumption. - - intros Hyp; rewrite Hyp; apply Req_le; reflexivity. - } - apply f_incr2; intuition. - enough (g x <> ub) by lra. - intro Hf. - assert (Htemp : (comp f g) x = f ub). { - unfold comp; rewrite Hf; reflexivity. - } - rewrite f_eq_g in Htemp by easy. - unfold id in Htemp. - lra. -Qed. - -Lemma derivable_pt_id_interv : forall (lb ub x:R), - lb <= x <= ub -> - derivable_pt id x. -Proof. -intros. - reg. -Qed. - -Lemma pr_nu_var2_interv : forall (f g : R -> R) (lb ub x : R) (pr1 : derivable_pt f x) - (pr2 : derivable_pt g x), - lb < ub -> - lb < x < ub -> - (forall h : R, lb < h < ub -> f h = g h) -> derive_pt f x pr1 = derive_pt g x pr2. -Proof. - intros f g lb ub x Prf Prg lb_lt_ub x_encad local_eq. - assert (forall x l, lb < x < ub -> (derivable_pt_abs f x l <-> derivable_pt_abs g x l)). { - intros a l a_encad. - unfold derivable_pt_abs, derivable_pt_lim. - split. - { intros Hyp eps eps_pos. - elim (Hyp eps eps_pos) ; intros delta Hyp2. - assert (Pos_cond : Rmin delta (Rmin (ub - a) (a - lb)) > 0). - { clear-a lb ub a_encad delta. - apply Rmin_pos ; [exact ((cond_pos delta)) | apply Rmin_pos ] ; apply Rlt_0_minus ; intuition. } - exists (mkposreal (Rmin delta (Rmin (ub - a) (a - lb))) Pos_cond). - intros h h_neq h_encad. - replace (g (a + h) - g a) with (f (a + h) - f a). - { apply Hyp2 ; intuition. - apply Rlt_le_trans with (r2:=Rmin delta (Rmin (ub - a) (a - lb))). - { assumption. } apply Rmin_l. } - assert (local_eq2 : forall h : R, lb < h < ub -> - f h = - g h). - { intros ; apply Ropp_eq_compat ; intuition. } - rewrite local_eq ; unfold Rminus. { rewrite local_eq2. { reflexivity. } - assumption. } - assert (Sublemma2 : forall x y, Rabs x < Rabs y -> y > 0 -> x < y). - { intros m n Hyp_abs y_pos. apply Rlt_le_trans with (r2:=Rabs n). - { apply Rle_lt_trans with (r2:=Rabs m) ; [ | assumption] ; apply RRle_abs. } - apply Req_le ; apply Rabs_right ; apply Rgt_ge ; assumption. } - split. - { assert (Sublemma : forall x y z, -z < y - x -> x < y + z). - { intros ; lra. } - apply Sublemma. - apply Sublemma2. { rewrite Rabs_Ropp. - apply Rlt_le_trans with (r2:=a-lb) ; [| apply RRle_abs] ; - apply Rlt_le_trans with (r2:=Rmin (ub - a) (a - lb)) ; [| apply Rmin_r] ; - apply Rlt_le_trans with (r2:=Rmin delta (Rmin (ub - a) (a - lb))) ; [| apply Rmin_r] ; assumption. } - apply Rlt_le_trans with (r2:=Rmin (ub - a) (a - lb)) ; [| apply Rmin_r] ; - apply Rlt_le_trans with (r2:=Rmin delta (Rmin (ub - a) (a - lb))) ; [| apply Rmin_r] ; assumption. } - assert (Sublemma : forall x y z, y < z - x -> x + y < z). - { intros ; lra. } - apply Sublemma. - apply Sublemma2. - { apply Rlt_le_trans with (r2:=ub-a) ; [| apply RRle_abs] ; - apply Rlt_le_trans with (r2:=Rmin (ub - a) (a - lb)) ; [| apply Rmin_l] ; - apply Rlt_le_trans with (r2:=Rmin delta (Rmin (ub - a) (a - lb))) ; [| apply Rmin_r] ; assumption. } - apply Rlt_le_trans with (r2:=Rmin (ub - a) (a - lb)) ; [| apply Rmin_l] ; - apply Rlt_le_trans with (r2:=Rmin delta (Rmin (ub - a) (a - lb))) ; [| apply Rmin_r] ; assumption. } - intros Hyp eps eps_pos. - elim (Hyp eps eps_pos) ; intros delta Hyp2. - assert (Pos_cond : Rmin delta (Rmin (ub - a) (a - lb)) > 0). - { clear-a lb ub a_encad delta. - apply Rmin_pos ; [exact ((cond_pos delta)) | apply Rmin_pos ] ; apply Rlt_0_minus ; intuition. } - exists (mkposreal (Rmin delta (Rmin (ub - a) (a - lb))) Pos_cond). - intros h h_neq h_encad. - replace (f (a + h) - f a) with (g (a + h) - g a). - { apply Hyp2 ; intuition. - apply Rlt_le_trans with (r2:=Rmin delta (Rmin (ub - a) (a - lb))). - { assumption. } apply Rmin_l. } - assert (local_eq2 : forall h : R, lb < h < ub -> - f h = - g h). - { intros ; apply Ropp_eq_compat ; intuition. } - rewrite local_eq ; unfold Rminus. { rewrite local_eq2. { reflexivity. } - assumption. } - assert (Sublemma2 : forall x y, Rabs x < Rabs y -> y > 0 -> x < y). - { intros m n Hyp_abs y_pos. apply Rlt_le_trans with (r2:=Rabs n). - { apply Rle_lt_trans with (r2:=Rabs m) ; [ | assumption] ; apply RRle_abs. } - apply Req_le ; apply Rabs_right ; apply Rgt_ge ; assumption. } - split. - { assert (Sublemma : forall x y z, -z < y - x -> x < y + z). - { intros ; lra. } - apply Sublemma. - apply Sublemma2. { rewrite Rabs_Ropp. - apply Rlt_le_trans with (r2:=a-lb) ; [| apply RRle_abs] ; - apply Rlt_le_trans with (r2:=Rmin (ub - a) (a - lb)) ; [| apply Rmin_r] ; - apply Rlt_le_trans with (r2:=Rmin delta (Rmin (ub - a) (a - lb))) ; [| apply Rmin_r] ; assumption. } - apply Rlt_le_trans with (r2:=Rmin (ub - a) (a - lb)) ; [| apply Rmin_r] ; - apply Rlt_le_trans with (r2:=Rmin delta (Rmin (ub - a) (a - lb))) ; [| apply Rmin_r] ; assumption. } - assert (Sublemma : forall x y z, y < z - x -> x + y < z). - { intros ; lra. } - apply Sublemma. - apply Sublemma2. - { apply Rlt_le_trans with (r2:=ub-a) ; [| apply RRle_abs] ; - apply Rlt_le_trans with (r2:=Rmin (ub - a) (a - lb)) ; [| apply Rmin_l] ; - apply Rlt_le_trans with (r2:=Rmin delta (Rmin (ub - a) (a - lb))) ; [| apply Rmin_r] ; assumption. } - apply Rlt_le_trans with (r2:=Rmin (ub - a) (a - lb)) ; [| apply Rmin_l] ; - apply Rlt_le_trans with (r2:=Rmin delta (Rmin (ub - a) (a - lb))) ; [| apply Rmin_r] ; assumption. } - unfold derivable_pt in Prf. - unfold derivable_pt in Prg. - elim Prf; intros x0 p. - elim Prg; intros x1 p0. - assert (Temp := p); rewrite H in Temp. - { unfold derivable_pt_abs in p. - unfold derivable_pt_abs in p0. - simpl in |- *. - apply (uniqueness_limite g x x0 x1 Temp p0). } - assumption. -Qed. - - -(* begin hide *) -Lemma leftinv_is_rightinv : forall (f g:R->R), - (forall x y, x < y -> f x < f y) -> - (forall x, (comp f g) x = id x) -> - (forall x, (comp g f) x = id x). -Proof. - intros f g f_incr Hyp x. - assert(f_inj : forall x y, f x = f y -> x = y). - { intros a b fa_eq_fb. - pose proof (f_incr a b);pose proof (f_incr b a);lra. } - apply f_inj,Hyp. -Qed. -(* end hide *) - -Lemma leftinv_is_rightinv_interv : forall (f g:R->R) (lb ub:R), - (forall x y, lb <= x -> x < y -> y <= ub -> f x < f y) -> - (forall y, f lb <= y -> y <= f ub -> (comp f g) y = id y) -> - (forall x, f lb <= x -> x <= f ub -> lb <= g x <= ub) -> - forall x, - lb <= x <= ub -> - (comp g f) x = id x. -Proof. - intros f g lb ub f_incr_interv Hyp g_wf x x_encad. - assert(f_inj : forall x y, lb <= x <= ub -> lb <= y <= ub -> f x = f y -> x = y). - { intros a b a_encad b_encad fa_eq_fb. - case(total_order_T a b). - { intro s ; case s ; clear s. - { intro Hf. - assert (Hfalse := f_incr_interv a b (proj1 a_encad) Hf (proj2 b_encad)). - apply False_ind. apply (Rlt_not_eq (f a) (f b)) ; assumption. } - intuition. } - intro Hf. assert (Hfalse := f_incr_interv b a (proj1 b_encad) Hf (proj2 a_encad)). - apply False_ind. apply (Rlt_not_eq (f b) (f a)) ; [|symmetry] ; assumption. } - assert (f_incr_interv2 : forall x y, lb <= x -> x <= y -> y <= ub -> f x <= f y). - { intros m n cond1 cond2 cond3. - case cond2. - { intro cond. apply Rlt_le ; apply f_incr_interv ; assumption. } - intro cond ; right ; rewrite cond ; reflexivity. } - assert (Hyp2:forall x, lb <= x <= ub -> f (g (f x)) = f x). - { intros ; apply Hyp. { apply f_incr_interv2 ; intuition. } - apply f_incr_interv2 ; intuition. } - unfold comp ; unfold comp in Hyp. - apply f_inj. - { apply g_wf ; apply f_incr_interv2 ; intuition. } - { unfold id ; assumption. } - apply Hyp2 ; unfold id ; assumption. -Qed. - - -(** Intermediate Value Theorem on an Interval (Proof mainly taken from Reals.Rsqrt_def) and its corollary *) - -Lemma IVT_interv_prelim0 : forall (x y:R) (P:R->bool) (N:nat), - x < y -> - x <= Dichotomy_ub x y P N <= y /\ x <= Dichotomy_lb x y P N <= y. -Proof. - assert (Sublemma : forall x y lb ub, lb <= x <= ub /\ lb <= y <= ub -> lb <= (x+y) / 2 <= ub) by (intros;lra). - intros x y P N x_lt_y. - induction N. - { simpl ; intuition. } - simpl. - case (P ((Dichotomy_lb x y P N + Dichotomy_ub x y P N) / 2)). - { split. { apply Sublemma ; intuition. } - intuition. } - split. { intuition. } - apply Sublemma ; intuition. -Qed. - -Lemma IVT_interv_prelim1 : forall (x y x0:R) (D : R -> bool), - x < y -> - Un_cv (dicho_up x y D) x0 -> - x <= x0 <= y. -Proof. - intros x y x0 D x_lt_y bnd. - assert (Main : forall n, x <= dicho_up x y D n <= y). - { intro n. unfold dicho_up. - apply (proj1 (IVT_interv_prelim0 x y D n x_lt_y)). } - split. - - apply Rle_cv_lim with (Vn:=dicho_up x y D) (Un:=fun n => x). - + intro n ; exact (proj1 (Main n)). - + unfold Un_cv ; intros ; exists 0%nat ; intros ; unfold Rdist ; replace (x -x) with 0 by field ; rewrite Rabs_R0 ; assumption. - + assumption. - - apply Rle_cv_lim with (Un:=dicho_up x y D) (Vn:=fun n => y). - + intro n ; exact (proj2 (Main n)). - + assumption. - + unfold Un_cv ; intros ; exists 0%nat ; intros ; unfold Rdist ; replace (y -y) with 0 by field ; rewrite Rabs_R0 ; assumption. -Qed. - -Lemma IVT_interv : forall (f : R -> R) (x y : R), - (forall a, x <= a <= y -> continuity_pt f a) -> - x < y -> - f x < 0 -> - 0 < f y -> - {z : R | x <= z <= y /\ f z = 0}. -Proof. - intros. (* f x y f_cont_interv x_lt_y fx_neg fy_pos.*) - assert (x <= y) by (left;assumption). - generalize (dicho_lb_cv x y (fun z:R => cond_positivity (f z)) H3). - generalize (dicho_up_cv x y (fun z:R => cond_positivity (f z)) H3). - intros X X0. - elim X; intros x0 p. - elim X0; intros x1 p0. - assert (H4 := cv_dicho _ _ _ _ _ H3 p0 p). - rewrite H4 in p0. - exists x0. - split. - 1:split. - { apply Rle_trans with (dicho_lb x y (fun z:R => cond_positivity (f z)) 0). - { simpl in |- *. - right; reflexivity. } - apply growing_ineq. - { apply dicho_lb_growing; assumption. } - assumption. } - { apply Rle_trans with (dicho_up x y (fun z:R => cond_positivity (f z)) 0). - { apply decreasing_ineq. - { apply dicho_up_decreasing; assumption. } - assumption. } - right; reflexivity. } - set (Vn := fun n:nat => dicho_lb x y (fun z:R => cond_positivity (f z)) n). - set (Wn := fun n:nat => dicho_up x y (fun z:R => cond_positivity (f z)) n). - cut ((forall n:nat, f (Vn n) <= 0) -> f x0 <= 0). - { cut ((forall n:nat, 0 <= f (Wn n)) -> 0 <= f x0). - { intros. - cut (forall n:nat, f (Vn n) <= 0). - { cut (forall n:nat, 0 <= f (Wn n)). - { intros. - assert (H9 := H6 H8). - assert (H10 := H5 H7). - apply Rle_antisym; assumption. } - intro. - unfold Wn in |- *. - cut (forall z:R, cond_positivity z = true <-> 0 <= z). - { intro. - assert (H8 := dicho_up_car x y (fun z:R => cond_positivity (f z)) n). - elim (H7 (f (dicho_up x y (fun z:R => cond_positivity (f z)) n))); intros. - apply H9. - apply H8. - elim (H7 (f y)); intros. - apply H12. - left; assumption. } - intro. - unfold cond_positivity in |- *. - destruct (Rle_dec 0 z) as [|Hnotle]. - { split. - { intro; assumption. } - intro; reflexivity. } - split. - { intro feqt;discriminate feqt. } - intro. - elim Hnotle; assumption. } - unfold Vn in |- *. - cut (forall z:R, cond_positivity z = false <-> z < 0). - { intros. - assert (H8 := dicho_lb_car x y (fun z:R => cond_positivity (f z)) n). - left. - elim (H7 (f (dicho_lb x y (fun z:R => cond_positivity (f z)) n))); intros. - apply H9. - apply H8. - elim (H7 (f x)); intros. - apply H12. - assumption. } - intro. - unfold cond_positivity in |- *. - destruct (Rle_dec 0 z) as [Hle|]. - { split. - { intro feqt; discriminate feqt. } - intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ Hle H7)). } - split. - { intro; auto with real. } - intro; reflexivity. } - cut (Un_cv Wn x0). - { intros. - assert (Temp : x <= x0 <= y). - { apply IVT_interv_prelim1 with (D:=(fun z : R => cond_positivity (f z))) ; assumption. } - assert (H7 := continuity_seq f Wn x0 (H x0 Temp) H5). - destruct (total_order_T 0 (f x0)) as [[Hlt|<-]|Hgt]. - - left; assumption. - - right; reflexivity. - - unfold Un_cv in H7; unfold Rdist in H7. - cut (0 < - f x0). - { intro. - elim (H7 (- f x0) H8); intros. - cut (x2 >= x2)%nat; [ intro | unfold ge in |- *; apply le_n ]. - assert (H11 := H9 x2 H10). - rewrite Rabs_right in H11. - { pattern (- f x0) at 1 in H11; rewrite <- Rplus_0_r in H11. - unfold Rminus in H11; rewrite (Rplus_comm (f (Wn x2))) in H11. - assert (H12 := Rplus_lt_reg_l _ _ _ H11). - assert (H13 := H6 x2). - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H13 H12)). } - apply Rle_ge; left; unfold Rminus in |- *; apply Rplus_le_lt_0_compat. - { apply H6. } - exact H8. } - apply Ropp_0_gt_lt_contravar; assumption. } - unfold Wn in |- *; assumption. } - assert (Un_cv Vn x0) by (unfold Vn; assumption). - intros. - assert (Temp : x <= x0 <= y). - { apply IVT_interv_prelim1 with (D:=(fun z : R => cond_positivity (f z))) ; assumption. } - assert (H7 := continuity_seq f Vn x0 (H x0 Temp) H5). - destruct (total_order_T 0 (f x0)) as [[Hlt|Heq]|]. - - unfold Un_cv in H7; unfold Rdist in H7. - elim (H7 (f x0) Hlt); intros. - cut (x2 >= x2)%nat; [ intro | unfold ge; apply le_n ]. - assert (H10 := H8 x2 H9). - rewrite Rabs_left in H10. - { pattern (f x0) at 2 in H10; rewrite <- Rplus_0_r in H10. - rewrite Ropp_minus_distr in H10. - unfold Rminus in H10. - assert (H11 := Rplus_lt_reg_l _ _ _ H10). - assert (H12 := H6 x2). - cut (0 < f (Vn x2)). - { intro. - elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ H13 H12)). } - rewrite <- (Ropp_involutive (f (Vn x2))). - apply Ropp_0_gt_lt_contravar; assumption. } - apply Rplus_lt_reg_l with (f x0 - f (Vn x2)). - rewrite Rplus_0_r; replace (f x0 - f (Vn x2) + (f (Vn x2) - f x0)) with 0; - [ unfold Rminus in |- *; apply Rplus_lt_le_0_compat | ring ]. - { assumption. } - apply Ropp_0_ge_le_contravar; apply Rle_ge; apply H6. - - right; rewrite <- Heq; reflexivity. - - left; assumption. -Qed. - -(* begin hide *) -Ltac case_le H := - let t := type of H in - let h' := fresh in - match t with ?x <= ?y => case (total_order_T x y); - [intros h'; case h'; clear h' | - intros h'; clear -H h'; exfalso; lra ] end. -(* end hide *) - - -Lemma f_interv_is_interv : forall (f:R->R) (lb ub y:R), - lb < ub -> - f lb <= y <= f ub -> - (forall x, lb <= x <= ub -> continuity_pt f x) -> - {x | lb <= x <= ub /\ f x = y}. -Proof. - intros f lb ub y lb_lt_ub y_encad f_cont_interv. - case y_encad ; intro y_encad1. - case_le y_encad1 ; intros y_encad2 y_encad3 ; - case_le y_encad3. - - intro y_encad4. - clear y_encad y_encad1 y_encad3. - assert (Cont : forall a : R, lb <= a <= ub -> continuity_pt (fun x => f x - y) a). - { intros a a_encad. unfold continuity_pt, continue_in, limit1_in, limit_in ; simpl ; unfold Rdist. - intros eps eps_pos. elim (f_cont_interv a a_encad eps eps_pos). - intros alpha alpha_pos. destruct alpha_pos as (alpha_pos,Temp). - exists alpha. split. - { assumption. } intros x x_cond. - replace (f x - y - (f a - y)) with (f x - f a) by field. - exact (Temp x x_cond). } - assert (H1 : (fun x : R => f x - y) lb < 0). - { apply Rlt_minus. assumption. } - assert (H2 : 0 < (fun x : R => f x - y) ub). - { apply Rgt_minus ; assumption. } - destruct (IVT_interv (fun x => f x - y) lb ub Cont lb_lt_ub H1 H2) as (x,Hx). - exists x. - destruct Hx as (Hyp,Result). - intuition. - - intro H ; exists ub ; intuition. - - intro H ; exists lb ; intuition. - - intro H ; exists ub ; intuition. -Qed. - -(** ** The derivative of a reciprocal function *) - - -(** * Continuity of the reciprocal function *) - -Lemma continuity_pt_recip_prelim : forall (f g:R->R) (lb ub : R) (Pr1:lb < ub), - (forall x y, lb <= x -> x < y -> y <= ub -> f x < f y) -> - (forall x, lb <= x <= ub -> (comp g f) x = id x) -> - (forall a, lb <= a <= ub -> continuity_pt f a) -> - forall b, - f lb < b < f ub -> - continuity_pt g b. -Proof. - assert (Sublemma : forall x y z, Rmax x y < z <-> x < z /\ y < z). - { intros x y z. split. - { unfold Rmax. case (Rle_dec x y) ; intros Hyp Hyp2. - { split. { apply Rle_lt_trans with (r2:=y) ; assumption. } assumption. } - split. { assumption. } apply Rlt_trans with (r2:=x). - { assert (Temp : forall x y, ~ x <= y -> x > y). - { intros m n Hypmn. intuition. } - apply Temp ; clear Temp ; assumption. } - assumption. } - intros Hyp. - unfold Rmax. case (Rle_dec x y). - { intro ; exact (proj2 Hyp). } - intro ; exact (proj1 Hyp). } - assert (Sublemma2 : forall x y z, Rmin x y > z <-> x > z /\ y > z). - { intros x y z. split. - { unfold Rmin. case (Rle_dec x y) ; intros Hyp Hyp2. - { split. { assumption. } - apply Rlt_le_trans with (r2:=x) ; intuition. } - split. - { apply Rlt_trans with (r2:=y). { intuition. } - assert (Temp : forall x y, ~ x <= y -> x > y). - { intros m n Hypmn. intuition. } - apply Temp ; clear Temp ; assumption. } - assumption. } - intros Hyp. - unfold Rmin. case (Rle_dec x y). - { intro ; exact (proj1 Hyp). } - intro ; exact (proj2 Hyp). } - assert (Sublemma3 : forall x y, x <= y /\ x <> y -> x < y). - { intros m n Hyp. unfold Rle in Hyp. - destruct Hyp as (Hyp1,Hyp2). - case Hyp1. - { intuition. } - intro Hfalse ; apply False_ind ; apply Hyp2 ; exact Hfalse. } - intros f g lb ub lb_lt_ub f_incr_interv f_eq_g f_cont_interv b b_encad. - assert (f_incr_interv2 : forall x y, lb <= x -> x <= y -> y <= ub -> f x <= f y). - { intros m n cond1 cond2 cond3. - case cond2. - { intro cond. apply Rlt_le ; apply f_incr_interv ; assumption. } - intro cond ; right ; rewrite cond ; reflexivity. } - unfold continuity_pt, continue_in, limit1_in, limit_in ; intros eps eps_pos. - unfold dist ; simpl ; unfold Rdist. - assert (b_encad_e : f lb <= b <= f ub) by intuition. - elim (f_interv_is_interv f lb ub b lb_lt_ub b_encad_e f_cont_interv) ; intros x Temp. - destruct Temp as (x_encad,f_x_b). - assert (lb_lt_x : lb < x). - { assert (Temp : x <> lb). - { intro Hfalse. - assert (Temp' : b = f lb). - { rewrite <- f_x_b ; rewrite Hfalse ; reflexivity. } - assert (Temp'' : b <> f lb). - { apply Rgt_not_eq ; exact (proj1 b_encad). } - apply Temp'' ; exact Temp'. } - apply Sublemma3. - split. { exact (proj1 x_encad). } - assert (Temp2 : forall x y:R, x <> y <-> y <> x). - { intros m n. split ; intuition. } - rewrite Temp2 ; assumption. } - assert (x_lt_ub : x < ub). - { assert (Temp : x <> ub). - { intro Hfalse. - assert (Temp' : b = f ub). - { rewrite <- f_x_b ; rewrite Hfalse ; reflexivity. } - assert (Temp'' : b <> f ub). - { apply Rlt_not_eq ; exact (proj2 b_encad). } - apply Temp'' ; exact Temp'. } - apply Sublemma3. - split ; [exact (proj2 x_encad) | assumption]. } - pose (x1 := Rmax (x - eps) lb). - pose (x2 := Rmin (x + eps) ub). - assert (Hx1 : x1 = Rmax (x - eps) lb) by intuition. - assert (Hx2 : x2 = Rmin (x + eps) ub) by intuition. - assert (x1_encad : lb <= x1 <= ub). - { split. { apply RmaxLess2. } - apply Rlt_le. rewrite Hx1. rewrite Sublemma. - split. { apply Rlt_trans with (r2:=x) ; lra. } - assumption. } - assert (x2_encad : lb <= x2 <= ub). - { split. { apply Rlt_le ; rewrite Hx2 ; apply Rgt_lt ; rewrite Sublemma2. - split. { apply Rgt_trans with (r2:=x) ; lra. } - assumption. } - apply Rmin_r. } - assert (x_lt_x2 : x < x2). - { rewrite Hx2. - apply Rgt_lt. rewrite Sublemma2. - split ; lra. } - assert (x1_lt_x : x1 < x). - { rewrite Hx1. - rewrite Sublemma. - split ; lra. } - exists (Rmin (f x - f x1) (f x2 - f x)). - split. { apply Rmin_pos ; apply Rgt_minus. { apply f_incr_interv ; [apply RmaxLess2 | | ] ; lra. } - apply f_incr_interv ; intuition. } - intros y Temp. - destruct Temp as (_,y_cond). - rewrite <- f_x_b in y_cond. - assert (Temp : forall x y d1 d2, d1 > 0 -> d2 > 0 -> Rabs (y - x) < Rmin d1 d2 -> x - d1 <= y <= x + d2). - { intros. - split. { assert (H10 : forall x y z, x - y <= z -> x - z <= y). { intuition. lra. } - apply H10. apply Rle_trans with (r2:=Rabs (y0 - x0)). - { replace (Rabs (y0 - x0)) with (Rabs (x0 - y0)). { apply RRle_abs. } - rewrite <- Rabs_Ropp. unfold Rminus ; rewrite Ropp_plus_distr. rewrite Ropp_involutive. - intuition. } - apply Rle_trans with (r2:= Rmin d1 d2). { apply Rlt_le ; assumption. } - apply Rmin_l. } - assert (H10 : forall x y z, x - y <= z -> x <= y + z). { intuition. lra. } - apply H10. apply Rle_trans with (r2:=Rabs (y0 - x0)). { apply RRle_abs. } - apply Rle_trans with (r2:= Rmin d1 d2). { apply Rlt_le ; assumption. } - apply Rmin_r. } - assert (Temp' := Temp (f x) y (f x - f x1) (f x2 - f x)). - replace (f x - (f x - f x1)) with (f x1) in Temp' by field. - replace (f x + (f x2 - f x)) with (f x2) in Temp' by field. - assert (T : f x - f x1 > 0). - { apply Rgt_minus. apply f_incr_interv ; intuition. } - assert (T' : f x2 - f x > 0). - { apply Rgt_minus. apply f_incr_interv ; intuition. } - assert (Main := Temp' T T' y_cond). - clear Temp Temp' T T'. - assert (x1_lt_x2 : x1 < x2). - { apply Rlt_trans with (r2:=x) ; assumption. } - assert (f_cont_myinterv : forall a : R, x1 <= a <= x2 -> continuity_pt f a). - { intros ; apply f_cont_interv ; split. - { apply Rle_trans with (r2 := x1) ; intuition. } - apply Rle_trans with (r2 := x2) ; intuition. } - elim (f_interv_is_interv f x1 x2 y x1_lt_x2 Main f_cont_myinterv) ; intros x' Temp. - destruct Temp as (x'_encad,f_x'_y). - rewrite <- f_x_b ; rewrite <- f_x'_y. - unfold comp in f_eq_g. rewrite f_eq_g. - 2:{ split. { apply Rle_trans with (r2:=x1) ; intuition. } - apply Rle_trans with (r2:=x2) ; intuition. } - rewrite f_eq_g. - 2:assumption. - unfold id. - assert (x'_encad2 : x - eps <= x' <= x + eps). - { split. - { apply Rle_trans with (r2:=x1) ; [ apply RmaxLess1|] ; intuition. } - apply Rle_trans with (r2:=x2) ; [ | apply Rmin_l] ; intuition. } - assert (x1_lt_x' : x1 < x'). - { apply Sublemma3. - assert (x1_neq_x' : x1 <> x'). - { intro Hfalse. rewrite Hfalse, f_x'_y in y_cond. - assert (Hf : Rabs (y - f x) < f x - y). - { apply Rlt_le_trans with (r2:=Rmin (f x - y) (f x2 - f x)). { lra. } - apply Rmin_l. } - assert(Hfin : f x - y < f x - y). - { apply Rle_lt_trans with (r2:=Rabs (y - f x)). - { replace (Rabs (y - f x)) with (Rabs (f x - y)). { apply RRle_abs. } - rewrite <- Rabs_Ropp. replace (- (f x - y)) with (y - f x) by field ; reflexivity. } lra. } - apply (Rlt_irrefl (f x - y)) ; assumption. } - split ; intuition. } - assert (x'_lb : x - eps < x'). - { apply Sublemma3. - split. { intuition. } apply Rlt_not_eq. - apply Rle_lt_trans with (r2:=x1) ; [ apply RmaxLess1|] ; intuition. } - assert (x'_lt_x2 : x' < x2). - { apply Sublemma3. - assert (x1_neq_x' : x' <> x2). - { intro Hfalse. rewrite <- Hfalse, f_x'_y in y_cond. - assert (Hf : Rabs (y - f x) < y - f x). - { apply Rlt_le_trans with (r2:=Rmin (f x - f x1) (y - f x)). { lra. } - apply Rmin_r. } - assert(Hfin : y - f x < y - f x). - { apply Rle_lt_trans with (r2:=Rabs (y - f x)). { apply RRle_abs. } lra. } - apply (Rlt_irrefl (y - f x)) ; assumption. } - split ; intuition. } - assert (x'_ub : x' < x + eps). - { apply Sublemma3. - split. { intuition. } apply Rlt_not_eq. - apply Rlt_le_trans with (r2:=x2) ; [ |rewrite Hx2 ; apply Rmin_l] ; intuition. } - apply Rabs_def1 ; lra. -Qed. - -Lemma continuity_pt_recip_interv : forall (f g:R->R) (lb ub : R) (Pr1:lb < ub), - (forall x y, lb <= x -> x < y -> y <= ub -> f x < f y) -> - (forall x, f lb <= x -> x <= f ub -> (comp f g) x = id x) -> - (forall x, f lb <= x -> x <= f ub -> lb <= g x <= ub) -> - (forall a, lb <= a <= ub -> continuity_pt f a) -> - forall b, - f lb < b < f ub -> - continuity_pt g b. -Proof. -intros f g lb ub lb_lt_ub f_incr_interv f_eq_g g_wf. -assert (g_eq_f_prelim := leftinv_is_rightinv_interv f g lb ub f_incr_interv f_eq_g). -assert (g_eq_f : forall x, lb <= x <= ub -> (comp g f) x = id x). -{ intro x ; apply g_eq_f_prelim ; assumption. } -apply (continuity_pt_recip_prelim f g lb ub lb_lt_ub f_incr_interv g_eq_f). -Qed. - -(** * Derivability of the reciprocal function *) - -Lemma derivable_pt_lim_recip_interv : forall (f g:R->R) (lb ub x:R) - (Prf:forall a : R, g lb <= a <= g ub -> derivable_pt f a) (Prg : continuity_pt g x), - lb < ub -> - lb < x < ub -> - forall (Prg_incr:g lb <= g x <= g ub), - (forall x, lb <= x <= ub -> (comp f g) x = id x) -> - derive_pt f (g x) (Prf (g x) Prg_incr) <> 0 -> - derivable_pt_lim g x (1 / derive_pt f (g x) (Prf (g x) Prg_incr)). -Proof. - intros f g lb ub x Prf g_cont_pur lb_lt_ub x_encad Prg_incr f_eq_g df_neq. - assert (x_encad2 : lb <= x <= ub). - { split ; apply Rlt_le ; intuition. } - elim (Prf (g x)); simpl; intros l Hl. - unfold derivable_pt_lim. - intros eps eps_pos. - pose (y := g x). - assert (Hlinv := limit_inv). - assert (Hf_deriv : forall eps:R, - 0 < eps -> - exists delta : posreal, - (forall h:R, - h <> 0 -> Rabs h < delta -> Rabs ((f (g x + h) - f (g x)) / h - l) < eps)). - { intros eps0 eps0_pos. - red in Hl ; red in Hl. elim (Hl eps0 eps0_pos). - intros deltatemp Htemp. - exists deltatemp ; exact Htemp. } - elim (Hf_deriv eps eps_pos). - intros deltatemp Htemp. - red in Hlinv ; red in Hlinv ; unfold dist in Hlinv ; unfold Rdist in Hlinv. - assert (Hlinv' := Hlinv (fun h => (f (y+h) - f y)/h) (fun h => h <>0) l 0). - unfold limit1_in, limit_in, dist in Hlinv' ; simpl in Hlinv'. unfold Rdist in Hlinv'. - assert (Premisse : forall eps : R, - eps > 0 -> - exists alp : R, - alp > 0 /\ - (forall x : R, - (fun h => h <>0) x /\ Rabs (x - 0) < alp -> - Rabs ((f (y + x) - f y) / x - l) < eps)). - { intros eps0 eps0_pos. - elim (Hf_deriv eps0 eps0_pos). - intros deltatemp' Htemp'. - exists deltatemp'. - split. - { exact (cond_pos deltatemp'). } - intros htemp cond. - apply (Htemp' htemp). - { exact (proj1 cond). } - replace (htemp) with (htemp - 0). - { exact (proj2 cond). } - intuition. } - assert (Premisse2 : l <> 0). - { intro l_null. - rewrite l_null in Hl. - apply df_neq. - rewrite derive_pt_eq. - exact Hl. } - elim (Hlinv' Premisse Premisse2 eps eps_pos). - intros alpha cond. - assert (alpha_pos := proj1 cond) ; assert (inv_cont := proj2 cond) ; clear cond. - unfold derivable, derivable_pt, derivable_pt_abs, derivable_pt_lim in Prf. - elim (Hl eps eps_pos). - intros delta f_deriv. - assert (g_cont := g_cont_pur). - unfold continuity_pt, continue_in, limit1_in, limit_in in g_cont. - pose (mydelta := Rmin delta alpha). - assert (mydelta_pos : mydelta > 0). - { unfold mydelta, Rmin. - case (Rle_dec delta alpha). - { intro ; exact ((cond_pos delta)). } - intro ; exact alpha_pos. } - elim (g_cont mydelta mydelta_pos). - intros delta' new_g_cont. - assert(delta'_pos := proj1 (new_g_cont)). - clear g_cont ; assert (g_cont := proj2 (new_g_cont)) ; clear new_g_cont. - pose (mydelta'' := Rmin delta' (Rmin (x - lb) (ub - x))). - assert(mydelta''_pos : mydelta'' > 0). - { unfold mydelta''. - apply Rmin_pos ; [intuition | apply Rmin_pos] ; apply Rgt_minus ; intuition. } - pose (delta'' := mkposreal mydelta'' mydelta''_pos: posreal). - exists delta''. - intros h h_neq h_le_delta'. - assert (lb <= x +h <= ub). - { assert (Sublemma2 : forall x y, Rabs x < Rabs y -> y > 0 -> x < y). - { intros m n Hyp_abs y_pos. apply Rlt_le_trans with (r2:=Rabs n). - { apply Rle_lt_trans with (r2:=Rabs m) ; [ | assumption] ; apply RRle_abs. } - apply Req_le ; apply Rabs_right ; apply Rgt_ge ; assumption. } - split. - { assert (Sublemma : forall x y z, -z <= y - x -> x <= y + z). - { intros ; lra. } - apply Sublemma. - apply Rlt_le ; apply Sublemma2. - { rewrite Rabs_Ropp. - apply Rlt_le_trans with (r2:=x-lb) ; [| apply RRle_abs] ; - apply Rlt_le_trans with (r2:=Rmin (x - lb) (ub - x)) ; [| apply Rmin_l] ; - apply Rlt_le_trans with (r2:=Rmin delta' (Rmin (x - lb) (ub - x))). - { apply Rlt_le_trans with (r2:=delta''). { assumption. } intuition. } apply Rmin_r. } - apply Rgt_minus. intuition. } - assert (Sublemma : forall x y z, y <= z - x -> x + y <= z). - { intros ; lra. } - apply Sublemma. - apply Rlt_le ; apply Sublemma2. - { apply Rlt_le_trans with (r2:=ub-x) ; [| apply RRle_abs] ; - apply Rlt_le_trans with (r2:=Rmin (x - lb) (ub - x)) ; [| apply Rmin_r] ; - apply Rlt_le_trans with (r2:=Rmin delta' (Rmin (x - lb) (ub - x))) ; [| apply Rmin_r] ; assumption. } - apply Rlt_le_trans with (r2:=delta''). { assumption. } - apply Rle_trans with (r2:=Rmin delta' (Rmin (x - lb) (ub - x))). { intuition. } - apply Rle_trans with (r2:=Rmin (x - lb) (ub - x)). { apply Rmin_r. } apply Rmin_r. } - replace ((g (x + h) - g x) / h) with (1/ (h / (g (x + h) - g x))). - 2:{ field ; split. - { assumption. } - intro Hfalse ; apply h_neq. - apply (Rplus_0_r_uniq x). - assert (Hfin : (comp f g) (x+h) = (comp f g) x). - { apply Rminus_diag_uniq in Hfalse. - unfold comp. - rewrite Hfalse ; reflexivity. } - rewrite f_eq_g in Hfin. - { rewrite f_eq_g in Hfin. - { unfold id in Hfin. exact Hfin. } - assumption. } - assumption. } - assert (Hrewr : h = (comp f g ) (x+h) - (comp f g) x). - { rewrite f_eq_g. - { rewrite f_eq_g. - { unfold id ; rewrite Rplus_comm ; - unfold Rminus ; rewrite Rplus_assoc ; rewrite Rplus_opp_r ; intuition. } - assumption. } - assumption. } - rewrite Hrewr at 1. - unfold comp. - replace (g(x+h)) with (g x + (g (x+h) - g(x))) by field. - pose (h':=g (x+h) - g x). - replace (g (x+h) - g x) with h' by intuition. - replace (g x + h' - g x) with h' by field. - assert (h'_neq : h' <> 0). - { unfold h'. - intro Hfalse. - unfold Rminus in Hfalse ; apply Rminus_diag_uniq in Hfalse. - assert (Hfalse' : (comp f g) (x+h) = (comp f g) x). - { intros ; unfold comp ; rewrite Hfalse ; trivial. } - rewrite f_eq_g in Hfalse' ; rewrite f_eq_g in Hfalse'. - - unfold id in Hfalse'. - apply Rplus_0_r_uniq in Hfalse'. - apply h_neq ; exact Hfalse'. - - assumption. - - assumption. - - assumption. } - unfold Rdiv at 1 3; rewrite Rmult_1_l ; rewrite Rmult_1_l. - apply inv_cont. - split. - { exact h'_neq. } - rewrite Rminus_0_r. - unfold continuity_pt, continue_in, limit1_in, limit_in in g_cont_pur. - elim (g_cont_pur mydelta mydelta_pos). - intros delta3 cond3. - unfold dist in cond3 ; simpl in cond3 ; unfold Rdist in cond3. - unfold h'. - assert (mydelta_le_alpha : mydelta <= alpha). - { unfold mydelta, Rmin ; case (Rle_dec delta alpha). - { trivial. } - intro ; intuition. } - apply Rlt_le_trans with (r2:=mydelta). - 2:assumption. - unfold dist in g_cont ; simpl in g_cont ; unfold Rdist in g_cont ; apply g_cont. - split. - { unfold D_x ; simpl. - split. - { unfold no_cond ; trivial. } - intro Hfalse ; apply h_neq. - apply (Rplus_0_r_uniq x). - symmetry ; assumption. } - replace (x + h - x) with h by field. - apply Rlt_le_trans with (r2:=delta''). - { assumption ; unfold delta''. } intuition. - apply Rle_trans with (r2:=mydelta''). { apply Req_le. unfold delta''. intuition. } - apply Rmin_l. -Qed. - -Lemma derivable_pt_recip_interv_prelim0 : forall (f g : R -> R) (lb ub x : R) - (Prf : forall a : R, g lb <= a <= g ub -> derivable_pt f a), - continuity_pt g x -> - lb < ub -> - lb < x < ub -> - forall Prg_incr : g lb <= g x <= g ub, - (forall x0 : R, lb <= x0 <= ub -> comp f g x0 = id x0) -> - derive_pt f (g x) (Prf (g x) Prg_incr) <> 0 -> - derivable_pt g x. -Proof. -intros f g lb ub x Prf g_cont_pt lb_lt_ub x_encad Prg_incr f_eq_g Df_neq. -unfold derivable_pt, derivable_pt_abs. -exists (1 / derive_pt f (g x) (Prf (g x) Prg_incr)). -apply derivable_pt_lim_recip_interv ; assumption. -Qed. - -Lemma derivable_pt_recip_interv_prelim1 : forall (f g:R->R) (lb ub x : R), - lb < ub -> - f lb < x < f ub -> - (forall x : R, f lb <= x -> x <= f ub -> lb <= g x <= ub) -> - (forall a : R, lb <= a <= ub -> derivable_pt f a) -> - derivable_pt f (g x). -Proof. - intros f g lb ub x lb_lt_ub x_encad g_wf f_deriv. - apply f_deriv. - apply g_wf; lra. -Qed. - -Lemma derivable_pt_recip_interv_prelim1_decr : forall (f g:R->R) (lb ub x : R), - lb < ub -> - f ub < x < f lb -> - (forall x : R, f ub <= x -> x <= f lb -> lb <= g x <= ub) -> - (forall a : R, lb <= a <= ub -> derivable_pt f a) -> - derivable_pt f (g x). -Proof. - intros f g lb ub x lb_lt_ub x_encad g_wf f_deriv. - apply f_deriv. - apply g_wf; lra. -Qed. - -Lemma derivable_pt_recip_interv - (f g:R->R) (lb ub x : R) - (lb_lt_ub:lb < ub) (x_encad:f lb < x < f ub) - (f_eq_g:forall x : R, f lb <= x -> x <= f ub -> comp f g x = id x) - (g_wf:forall x : R, f lb <= x -> x <= f ub -> lb <= g x <= ub) - (f_incr:forall x y : R, lb <= x -> x < y -> y <= ub -> f x < f y) - (f_derivable:forall a : R, lb <= a <= ub -> derivable_pt f a) - : derive_pt f (g x) - (derivable_pt_recip_interv_prelim1 f g lb ub x lb_lt_ub - x_encad g_wf f_derivable) - <> 0 -> - derivable_pt g x. -Proof. - intros Df_neq. - assert(g_incr : g (f lb) < g x < g (f ub)). - { assert (Temp:= f_incr_implies_g_incr_interv f g lb ub lb_lt_ub f_incr f_eq_g g_wf). - split ; apply Temp ; intuition. - - exact (proj1 x_encad). - - apply Rlt_le ; exact (proj2 x_encad). - - apply Rlt_le ; exact (proj1 x_encad). - - exact (proj2 x_encad). } - assert(g_incr2 : g (f lb) <= g x <= g (f ub)). - { split ; apply Rlt_le ; intuition. } - assert (g_eq_f := leftinv_is_rightinv_interv f g lb ub f_incr f_eq_g g_wf). - unfold comp, id in g_eq_f. - assert (f_derivable2 : forall a : R, g (f lb) <= a <= g (f ub) -> derivable_pt f a). - { intros a a_encad ; apply f_derivable. - rewrite g_eq_f in a_encad ; rewrite g_eq_f in a_encad ; intuition. } - apply derivable_pt_recip_interv_prelim0 with - (f:=f) (lb:=f lb) (ub:=f ub) - (Prf:=f_derivable2) (Prg_incr:=g_incr2). - - apply continuity_pt_recip_interv with (f:=f) (lb:=lb) (ub:=ub) ; intuition. - + apply derivable_continuous_pt ; apply f_derivable ; intuition. - + exact (proj1 x_encad). - + exact (proj2 x_encad). - - apply f_incr ; intuition. - - assumption. - - intros x0 x0_encad ; apply f_eq_g ; intuition. - - rewrite pr_nu_var2_interv with - (g:=f) (lb:=lb) (ub:=ub) - (pr2:=derivable_pt_recip_interv_prelim1 f g lb ub x lb_lt_ub x_encad g_wf f_derivable); - [| |rewrite g_eq_f in g_incr ; rewrite g_eq_f in g_incr| ] ; intuition. -Qed. - -Lemma derivable_pt_recip_interv_decr (f g:R->R) (lb ub x : R) - (lb_lt_ub:lb < ub) - (x_encad:f ub < x < f lb) - (f_eq_g:forall x : R, f ub <= x -> x <= f lb -> comp f g x = id x) - (g_wf:forall x : R, f ub <= x -> x <= f lb -> lb <= g x <= ub) - (f_decr:forall x y : R, lb <= x -> x < y -> y <= ub -> f y < f x) - (f_derivable:forall a : R, lb <= a <= ub -> derivable_pt f a) - : derive_pt f (g x) - (derivable_pt_recip_interv_prelim1_decr f g lb ub x lb_lt_ub - x_encad g_wf f_derivable) - <> 0 -> - derivable_pt g x. -Proof. - intros. - apply derivable_pt_opp_rev. - unshelve eapply (derivable_pt_recip_interv (mirr_fct f) (opp_fct g) (-ub) (-lb) (x)). -- lra. -- unfold mirr_fct; repeat rewrite Ropp_involutive; lra. -- intros x0 H1 H2. - unfold mirr_fct in H1,H2; unfold opp_fct. - rewrite Ropp_involutive in H1,H2. - pose proof g_wf x0 as g_wfs; lra. -- intros x0 H1. - apply derivable_pt_mirr, f_derivable; lra. -- intros x0 H1 H2. - unfold mirr_fct in H1,H2 |-*; unfold opp_fct, comp. - rewrite Ropp_involutive in H1,H2 |-*. - apply f_eq_g; lra. -- intros x0 y0 H1 H2 H3. - unfold mirr_fct. - apply f_decr; lra. -- (* In order to rewrite with derive_pt_mirr the term must have the form - derive_pt (mirr_fct f) _ (derivable_pt_mirr ... - pr_nu is a sort of proof irrelevance lemma for derive_pt equalities *) - unshelve erewrite (pr_nu _ _ _). - + apply derivable_pt_mirr. - unfold opp_fct; rewrite Ropp_involutive. - apply f_derivable; apply g_wf; lra. - + rewrite derive_pt_mirr. - unfold opp_fct; rewrite Ropp_involutive. - match goal with H:context[derive_pt _ _ ?pr] |- _ => rewrite (pr_nu f (g x) _ pr) end. - apply Ropp_neq_0_compat. - assumption. -Qed. - -(****************************************************) -(** * Value of the derivative of the reciprocal function *) -(****************************************************) - -Lemma derive_pt_recip_interv_prelim0 (f g:R->R) (lb ub x:R) - (Prf:derivable_pt f (g x)) (Prg:derivable_pt g x) - : lb < ub -> - lb < x < ub -> - (forall x, lb < x < ub -> (comp f g) x = id x) -> - derive_pt f (g x) Prf <> 0 -> - derive_pt g x Prg = 1 / (derive_pt f (g x) Prf). -Proof. - intros lb_lt_ub x_encad local_recip Df_neq. - replace (derive_pt g x Prg) with - ((derive_pt g x Prg) * (derive_pt f (g x) Prf) * / (derive_pt f (g x) Prf)). - { unfold Rdiv. - rewrite (Rmult_comm _ (/ derive_pt f (g x) Prf)). - rewrite (Rmult_comm _ (/ derive_pt f (g x) Prf)). - apply Rmult_eq_compat_l. - rewrite Rmult_comm. - rewrite <- derive_pt_comp. - assert (x_encad2 : lb <= x <= ub) by intuition. - rewrite pr_nu_var2_interv with (g:=id) (pr2:= derivable_pt_id_interv lb ub x x_encad2) (lb:=lb) (ub:=ub) ; [reg| | |] ; assumption. } - rewrite Rmult_assoc, Rinv_r. - { intuition. } - assumption. -Qed. - -Lemma derive_pt_recip_interv_prelim1_0 : forall (f g:R->R) (lb ub x:R), - lb < ub -> - f lb < x < f ub -> - (forall x y : R, lb <= x -> x < y -> y <= ub -> f x < f y) -> - (forall x : R, f lb <= x -> x <= f ub -> lb <= g x <= ub) -> - (forall x, f lb <= x -> x <= f ub -> (comp f g) x = id x) -> - lb < g x < ub. -Proof. -intros f g lb ub x lb_lt_ub x_encad f_incr g_wf f_eq_g. - assert (Temp:= f_incr_implies_g_incr_interv f g lb ub lb_lt_ub f_incr f_eq_g g_wf). - assert (Left_inv := leftinv_is_rightinv_interv f g lb ub f_incr f_eq_g g_wf). - unfold comp, id in Left_inv. - split ; [rewrite <- Left_inv with (x:=lb) | rewrite <- Left_inv ];intuition. -Qed. - -Lemma derive_pt_recip_interv_prelim1_1 : forall (f g:R->R) (lb ub x:R), - lb < ub -> - f lb < x < f ub -> - (forall x y : R, lb <= x -> x < y -> y <= ub -> f x < f y) -> - (forall x : R, f lb <= x -> x <= f ub -> lb <= g x <= ub) -> - (forall x, f lb <= x -> x <= f ub -> (comp f g) x = id x) -> - lb <= g x <= ub. -Proof. -intros f g lb ub x lb_lt_ub x_encad f_incr g_wf f_eq_g. - assert (Temp := derive_pt_recip_interv_prelim1_0 f g lb ub x lb_lt_ub x_encad f_incr g_wf f_eq_g). - split ; apply Rlt_le ; intuition. -Qed. - -Lemma derive_pt_recip_interv_prelim1_1_decr : forall (f g:R->R) (lb ub x:R), - lb < ub -> - f ub < x < f lb -> - (forall x y : R, lb <= x -> x < y -> y <= ub -> f y < f x) -> - (forall x : R, f ub <= x -> x <= f lb -> lb <= g x <= ub) -> - (forall x, f ub <= x -> x <= f lb -> (comp f g) x = id x) -> - lb <= g x <= ub. -Proof. - intros f g lb ub x lb_lt_ub x_encad f_decr g_wf f_eq_g. - enough (-ub <= - g x <= - lb) by lra. - unshelve eapply (derive_pt_recip_interv_prelim1_1 (mirr_fct f) (opp_fct g) (-ub) (-lb) (x)). -- lra. -- unfold mirr_fct; repeat rewrite Ropp_involutive; lra. -- intros x0 y0 H1 H2 H3. - unfold mirr_fct. - apply f_decr; lra. -- intros x0 H1 H2. - unfold mirr_fct in H1,H2; unfold opp_fct. - rewrite Ropp_involutive in H1,H2. - pose proof g_wf x0 as g_wfs; lra. -- intros x0 H1 H2. - unfold mirr_fct in H1,H2 |-*; unfold opp_fct, comp. - rewrite Ropp_involutive in H1,H2 |-*. - apply f_eq_g; lra. -Qed. - -Lemma derive_pt_recip_interv : forall (f g:R->R) (lb ub x:R) - (lb_lt_ub:lb < ub) (x_encad:f lb < x < f ub) - (f_incr:forall x y : R, lb <= x -> x < y -> y <= ub -> f x < f y) - (g_wf:forall x : R, f lb <= x -> x <= f ub -> lb <= g x <= ub) - (Prf:forall a : R, lb <= a <= ub -> derivable_pt f a) - (f_eq_g:forall x, f lb <= x -> x <= f ub -> (comp f g) x = id x) - (Df_neq:derive_pt f (g x) (derivable_pt_recip_interv_prelim1 f g lb ub x - lb_lt_ub x_encad g_wf Prf) <> 0), - derive_pt g x (derivable_pt_recip_interv f g lb ub x lb_lt_ub x_encad f_eq_g - g_wf f_incr Prf Df_neq) - = - 1 / (derive_pt f (g x) (Prf (g x) (derive_pt_recip_interv_prelim1_1 f g lb ub x - lb_lt_ub x_encad f_incr g_wf f_eq_g))). -Proof. -intros. - assert(g_incr := (derive_pt_recip_interv_prelim1_1 f g lb ub x lb_lt_ub - x_encad f_incr g_wf f_eq_g)). - apply derive_pt_recip_interv_prelim0 with (lb:=f lb) (ub:=f ub) ; - [intuition |assumption | intuition |]. - intro Hfalse ; apply Df_neq. rewrite pr_nu_var2_interv with (g:=f) (lb:=lb) (ub:=ub) - (pr2:= (Prf (g x) (derive_pt_recip_interv_prelim1_1 f g lb ub x lb_lt_ub x_encad - f_incr g_wf f_eq_g))) ; - [intuition | intuition | | intuition]. - exact (derive_pt_recip_interv_prelim1_0 f g lb ub x lb_lt_ub x_encad f_incr g_wf f_eq_g). -Qed. - -Lemma derive_pt_recip_interv_decr : forall (f g:R->R) (lb ub x:R) - (lb_lt_ub:lb < ub) - (x_encad:f ub < x < f lb) - (f_decr:forall x y : R, lb <= x -> x < y -> y <= ub -> f y < f x) - (g_wf:forall x : R, f ub <= x -> x <= f lb -> lb <= g x <= ub) - (Prf:forall a : R, lb <= a <= ub -> derivable_pt f a) - (f_eq_g:forall x, f ub <= x -> x <= f lb -> (comp f g) x = id x) - (Df_neq:derive_pt f (g x) (derivable_pt_recip_interv_prelim1_decr f g lb ub x - lb_lt_ub x_encad g_wf Prf) <> 0), - derive_pt g x (derivable_pt_recip_interv_decr f g lb ub x lb_lt_ub x_encad f_eq_g - g_wf f_decr Prf Df_neq) - = - 1 / (derive_pt f (g x) (Prf (g x) (derive_pt_recip_interv_prelim1_1_decr f g lb ub x - lb_lt_ub x_encad f_decr g_wf f_eq_g))). -Proof. - (* This proof based on derive_pt_recip_interv looks fairly long compared to the direct proof above, - but the direct proof needs a lot of lengthy preparation lemmas e.g. derivable_pt_lim_recip_interv. *) - intros. - (* Note: here "unshelve epose" with proving the premises first does not work. - The more abstract form with the unbound evars has less issues with dependent rewriting. *) - epose proof (derive_pt_recip_interv (mirr_fct f) (opp_fct g) (-ub) (-lb) (x) _ _ _ _ _ _ _). - rewrite derive_pt_mirr_rev in H. - rewrite derive_pt_opp_rev in H. - unfold opp_fct in H. - match goal with - | H:context[derive_pt ?f ?x1 ?pr1] |- context[derive_pt ?f ?x2 ?pr2] => - rewrite (pr_nu_xeq f x1 x2 pr1 pr2 (Ropp_involutive x2)) in H - end. - match goal with - | H:context[derive_pt ?f ?x ?pr1] |- context[derive_pt ?f ?x ?pr2] => - rewrite (pr_nu f x pr1 pr2) in H - end. - apply Ropp_eq_compat in H; rewrite Ropp_involutive in H. - rewrite H; field. - pose proof Df_neq as Df_neq'. - match goal with - | H:context[derive_pt ?f ?x ?pr1] |- context[derive_pt ?f ?x ?pr2] => - rewrite (pr_nu f x pr1 pr2) in H - end. - assumption. - -Unshelve. -- abstract lra. -- unfold mirr_fct; repeat rewrite Ropp_involutive; abstract lra. -- intros x0 y0 H1 H2 H3. - unfold mirr_fct. - apply f_decr; abstract lra. -- intros x0 H1 H2. - unfold mirr_fct in H1,H2; unfold opp_fct. - rewrite Ropp_involutive in H1,H2. - pose proof g_wf x0 as g_wfs; abstract lra. -- intros x0 H1. - apply derivable_pt_mirr, Prf; abstract lra. -- intros x0 H1 H2. - unfold mirr_fct in H1,H2 |-*; unfold opp_fct, comp. - rewrite Ropp_involutive in H1,H2 |-*. - apply f_eq_g; abstract lra. -- unshelve erewrite (pr_nu _ _ _). - { apply derivable_pt_mirr. - unfold opp_fct; rewrite Ropp_involutive. - apply Prf; apply g_wf; abstract lra. } - rewrite derive_pt_mirr. - unfold opp_fct; rewrite Ropp_involutive. - apply Ropp_neq_0_compat. - erewrite (pr_nu _ _ _). - apply Df_neq. -Qed. - -(****************************************************) -(** * Existence of the derivative of a function which is the limit of a sequence of functions *) -(****************************************************) - -(* begin hide *) -Lemma ub_lt_2_pos : forall x ub lb, lb < x -> x < ub -> 0 < (ub-lb)/2. -Proof. -intros x ub lb lb_lt_x x_lt_ub. -lra. -Qed. - -Definition mkposreal_lb_ub (x lb ub:R) (lb_lt_x:lb R -> R) (f g:R->R) - (x:R) : forall c r, - Boule c r x -> - (forall y n, Boule c r y -> derivable_pt_lim (fn n) y (fn' n y)) -> - (forall y, Boule c r y -> Un_cv (fun n => fn n y) (f y)) -> - (CVU fn' g c r) -> - (forall y, Boule c r y -> continuity_pt g y) -> - derivable_pt_lim f x (g x). -Proof. - intros c' r xinb Dfn_eq_fn' fn_CV_f fn'_CVU_g g_cont eps eps_pos. - assert (eps_8_pos : 0 < eps / 8) by lra. - elim (g_cont x xinb _ eps_8_pos) ; clear g_cont ; - intros delta1 (delta1_pos, g_cont). - destruct (Ball_in_inter _ _ _ _ _ xinb - (Boule_center x (mkposreal _ delta1_pos))) - as [delta Pdelta]. - exists delta; intros h hpos hinbdelta. - assert (eps'_pos : 0 < (Rabs h) * eps / 4). - { unfold Rdiv ; rewrite Rmult_assoc ; apply Rmult_lt_0_compat. - { apply Rabs_pos_lt ; assumption. } - lra. } - destruct (fn_CV_f x xinb ((Rabs h) * eps / 4) eps'_pos) as [N2 fnx_CV_fx]. - assert (xhinbxdelta : Boule x delta (x + h)). - { clear -hinbdelta; apply Rabs_def2 in hinbdelta; unfold Boule; simpl. - destruct hinbdelta; apply Rabs_def1; lra. } - assert (t : Boule c' r (x + h)). - { apply Pdelta in xhinbxdelta; tauto. } - destruct (fn_CV_f (x+h) t ((Rabs h) * eps / 4) eps'_pos) as [N1 fnxh_CV_fxh]. - clear fn_CV_f t. - destruct (fn'_CVU_g (eps/8) eps_8_pos) as [N3 fn'c_CVU_gc]. - pose (N := ((N1 + N2) + N3)%nat). - assert (Main : Rabs ((f (x+h) - fn N (x+h)) - (f x - fn N x) + (fn N (x+h) - fn N x - h * (g x))) < (Rabs h)*eps). - 2:{ replace ((f (x + h) - f x) / h - g x) with ((/h) * ((f (x + h) - f x) - h * g x)) - by (field;assumption). - rewrite Rabs_mult ; rewrite Rabs_inv. - replace eps with (/ Rabs h * (Rabs h * eps)). - { apply Rmult_lt_compat_l. - { apply Rinv_0_lt_compat ; apply Rabs_pos_lt ; assumption. } - replace (f (x + h) - f x - h * g x) with - (f (x + h) - fn N (x + h) - (f x - fn N x) + (fn N (x + h) - fn N x - h * g x)) - by field. - assumption. } - field ; apply Rgt_not_eq ; apply Rabs_pos_lt ; assumption. } - apply Rle_lt_trans with (Rabs (f (x + h) - fn N (x + h) - (f x - fn N x)) + Rabs ((fn N (x + h) - fn N x - h * g x))). - { solve[apply Rabs_triang]. } - apply Rle_lt_trans with (Rabs (f (x + h) - fn N (x + h)) + Rabs (- (f x - fn N x)) + Rabs (fn N (x + h) - fn N x - h * g x)). - { solve[apply Rplus_le_compat_r ; apply Rabs_triang]. } - rewrite Rabs_Ropp. - case (Rlt_le_dec h 0) ; intro sgn_h. - { assert (pr1 : forall c : R, x + h < c < x -> derivable_pt (fn N) c). - { intros c c_encad ; unfold derivable_pt. - exists (fn' N c) ; apply Dfn_eq_fn'. - assert (t : Boule x delta c). - { apply Rabs_def2 in xhinbxdelta; destruct xhinbxdelta; destruct c_encad. - apply Rabs_def2 in xinb; apply Rabs_def1; lra. } - apply Pdelta in t; tauto. } - assert (pr2 : forall c : R, x + h < c < x -> derivable_pt id c). - { solve[intros; apply derivable_id]. } - assert (xh_x : x+h < x) by lra. - assert (pr3 : forall c : R, x + h <= c <= x -> continuity_pt (fn N) c). - { intros c c_encad ; apply derivable_continuous_pt. - exists (fn' N c) ; apply Dfn_eq_fn' ; intuition. - assert (t : Boule x delta c). - { apply Rabs_def2 in xhinbxdelta; destruct xhinbxdelta. - apply Rabs_def2 in xinb; apply Rabs_def1; lra. } - apply Pdelta in t; tauto. } - assert (pr4 : forall c : R, x + h <= c <= x -> continuity_pt id c). - { solve[intros; apply derivable_continuous ; apply derivable_id]. } - destruct (MVT (fn N) id (x+h) x pr1 pr2 xh_x pr3 pr4) as [c [P Hc]]. - assert (Hc' : h * derive_pt (fn N) c (pr1 c P) = (fn N (x+h) - fn N x)). - { apply Rmult_eq_reg_l with (-1). - { replace (-1 * (h * derive_pt (fn N) c (pr1 c P))) with (-h * derive_pt (fn N) c (pr1 c P)) by field. - replace (-1 * (fn N (x + h) - fn N x)) with (- (fn N (x + h) - fn N x)) by field. - replace (-h) with (id x - id (x + h)) by (unfold id; field). - rewrite <- Rmult_1_r ; replace 1 with (derive_pt id c (pr2 c P)) by reg. - replace (- (fn N (x + h) - fn N x)) with (fn N x - fn N (x + h)) by field. - assumption. } - now apply Rlt_not_eq, IZR_lt. } - rewrite <- Hc'; clear Hc Hc'. - replace (derive_pt (fn N) c (pr1 c P)) with (fn' N c). - 2:{ assert (H := pr1 c P) ; elim H ; clear H ; intros l Hl. - assert (Temp : l = fn' N c). - { assert (bc'rc : Boule c' r c). - { assert (t : Boule x delta c). - { clear - xhinbxdelta P. - destruct P; apply Rabs_def2 in xhinbxdelta; destruct xhinbxdelta. - apply Rabs_def1; lra. } - apply Pdelta in t; tauto. } - assert (Hl' := Dfn_eq_fn' c N bc'rc). - unfold derivable_pt_abs in Hl; clear -Hl Hl'. - apply uniqueness_limite with (f:= fn N) (x:=c) ; assumption. } - rewrite <- Temp. - assert (Hl' : derivable_pt (fn N) c). - { exists l ; apply Hl. } - rewrite pr_nu_var with (g:= fn N) (pr2:=Hl'). - { elim Hl' ; clear Hl' ; intros l' Hl'. - assert (Main : l = l'). - { apply uniqueness_limite with (f:= fn N) (x:=c) ; assumption. } - rewrite Main ; reflexivity. } - reflexivity. } - replace (h * fn' N c - h * g x) with (h * (fn' N c - g x)) by field. - rewrite Rabs_mult. - apply Rlt_trans with (Rabs h * eps / 4 + Rabs (f x - fn N x) + Rabs h * Rabs (fn' N c - g x)). - { apply Rplus_lt_compat_r ; apply Rplus_lt_compat_r ; unfold Rdist in fnxh_CV_fxh ; - rewrite Rabs_minus_sym ; apply fnxh_CV_fxh. - unfold N; lia. } - apply Rlt_trans with (Rabs h * eps / 4 + Rabs h * eps / 4 + Rabs h * Rabs (fn' N c - g x)). - { apply Rplus_lt_compat_r ; apply Rplus_lt_compat_l. - unfold Rdist in fnx_CV_fx ; rewrite Rabs_minus_sym ; apply fnx_CV_fx. - unfold N ; lia. } - replace (fn' N c - g x) with ((fn' N c - g c) + (g c - g x)) by field. - apply Rle_lt_trans with (Rabs h * eps / 4 + Rabs h * eps / 4 + - Rabs h * Rabs (fn' N c - g c) + Rabs h * Rabs (g c - g x)). - { rewrite Rplus_assoc ; rewrite Rplus_assoc ; rewrite Rplus_assoc ; - apply Rplus_le_compat_l ; apply Rplus_le_compat_l ; - rewrite <- Rmult_plus_distr_l ; apply Rmult_le_compat_l. - { solve[apply Rabs_pos]. } - solve[apply Rabs_triang]. } - apply Rlt_trans with (Rabs h * eps / 4 + Rabs h * eps / 4 + - Rabs h * (eps / 8) + Rabs h * Rabs (g c - g x)). - { apply Rplus_lt_compat_r; apply Rplus_lt_compat_l; apply Rmult_lt_compat_l. - { apply Rabs_pos_lt ; assumption. } - rewrite Rabs_minus_sym ; apply fn'c_CVU_gc. - { unfold N ; lia. } - assert (t : Boule x delta c). - { destruct P. - apply Rabs_def2 in xhinbxdelta; destruct xhinbxdelta. - apply Rabs_def2 in xinb; apply Rabs_def1; lra. } - apply Pdelta in t; tauto. } - apply Rlt_trans with (Rabs h * eps / 4 + Rabs h * eps / 4 + Rabs h * (eps / 8) + - Rabs h * (eps / 8)). - { rewrite Rplus_assoc ; rewrite Rplus_assoc ; rewrite Rplus_assoc ; rewrite Rplus_assoc ; - apply Rplus_lt_compat_l ; apply Rplus_lt_compat_l ; rewrite <- Rmult_plus_distr_l ; - rewrite <- Rmult_plus_distr_l ; apply Rmult_lt_compat_l. - { apply Rabs_pos_lt ; assumption. } - apply Rplus_lt_compat_l ; simpl in g_cont ; apply g_cont ; split ; [unfold D_x ; split |]. - - solve[unfold no_cond ; intuition]. - - apply Rgt_not_eq ; exact (proj2 P). - - apply Rlt_trans with (Rabs h). - { apply Rabs_def1. - { apply Rlt_trans with 0. - { destruct P; lra. } - apply Rabs_pos_lt ; assumption. } - rewrite <- Rabs_Ropp, Rabs_pos_eq, Ropp_involutive;[ | lra]. - destruct P; lra. } - clear -Pdelta xhinbxdelta. - apply Pdelta in xhinbxdelta; destruct xhinbxdelta as [_ P']. - apply Rabs_def2 in P'; simpl in P'; destruct P'; - apply Rabs_def1; lra. } - rewrite Rplus_assoc ; rewrite Rplus_assoc ; rewrite <- Rmult_plus_distr_l. - replace (Rabs h * eps / 4 + (Rabs h * eps / 4 + Rabs h * (eps / 8 + eps / 8))) with - (Rabs h * (eps / 4 + eps / 4 + eps / 8 + eps / 8)) by field. - apply Rmult_lt_compat_l. - { apply Rabs_pos_lt ; assumption. } - lra. } - assert (h_pos : h > 0). - { case sgn_h ; intro Hyp. - { assumption. } - apply False_ind ; apply hpos ; symmetry ; assumption. } - clear sgn_h. - assert (pr1 : forall c : R, x < c < x + h -> derivable_pt (fn N) c). - { intros c c_encad ; unfold derivable_pt. - exists (fn' N c) ; apply Dfn_eq_fn'. - assert (t : Boule x delta c). - { apply Rabs_def2 in xhinbxdelta; destruct xhinbxdelta; destruct c_encad. - apply Rabs_def2 in xinb; apply Rabs_def1; lra. } - apply Pdelta in t; tauto. } - assert (pr2 : forall c : R, x < c < x + h -> derivable_pt id c). - { solve[intros; apply derivable_id]. } - assert (xh_x : x < x + h) by lra. - assert (pr3 : forall c : R, x <= c <= x + h -> continuity_pt (fn N) c). - { intros c c_encad ; apply derivable_continuous_pt. - exists (fn' N c) ; apply Dfn_eq_fn' ; intuition. - assert (t : Boule x delta c). - { apply Rabs_def2 in xhinbxdelta; destruct xhinbxdelta. - apply Rabs_def2 in xinb; apply Rabs_def1; lra. } - apply Pdelta in t; tauto. } - assert (pr4 : forall c : R, x <= c <= x + h -> continuity_pt id c). - { solve[intros; apply derivable_continuous ; apply derivable_id]. } - destruct (MVT (fn N) id x (x+h) pr1 pr2 xh_x pr3 pr4) as [c [P Hc]]. - assert (Hc' : h * derive_pt (fn N) c (pr1 c P) = fn N (x+h) - fn N x). - { pattern h at 1; replace h with (id (x + h) - id x) by (unfold id; field). - rewrite <- Rmult_1_r ; replace 1 with (derive_pt id c (pr2 c P)) by reg. - assumption. } - rewrite <- Hc'; clear Hc Hc'. - replace (derive_pt (fn N) c (pr1 c P)) with (fn' N c). - { replace (h * fn' N c - h * g x) with (h * (fn' N c - g x)) by field. - rewrite Rabs_mult. - apply Rlt_trans with (Rabs h * eps / 4 + Rabs (f x - fn N x) + Rabs h * Rabs (fn' N c - g x)). - { apply Rplus_lt_compat_r ; apply Rplus_lt_compat_r ; unfold Rdist in fnxh_CV_fxh ; - rewrite Rabs_minus_sym ; apply fnxh_CV_fxh. - unfold N; lia. } - apply Rlt_trans with (Rabs h * eps / 4 + Rabs h * eps / 4 + Rabs h * Rabs (fn' N c - g x)). - { apply Rplus_lt_compat_r ; apply Rplus_lt_compat_l. - unfold Rdist in fnx_CV_fx ; rewrite Rabs_minus_sym ; apply fnx_CV_fx. - unfold N ; lia. } - replace (fn' N c - g x) with ((fn' N c - g c) + (g c - g x)) by field. - apply Rle_lt_trans with (Rabs h * eps / 4 + Rabs h * eps / 4 + - Rabs h * Rabs (fn' N c - g c) + Rabs h * Rabs (g c - g x)). - { rewrite Rplus_assoc ; rewrite Rplus_assoc ; rewrite Rplus_assoc ; - apply Rplus_le_compat_l ; apply Rplus_le_compat_l ; - rewrite <- Rmult_plus_distr_l ; apply Rmult_le_compat_l. - { solve[apply Rabs_pos]. } - solve[apply Rabs_triang]. } - apply Rlt_trans with (Rabs h * eps / 4 + Rabs h * eps / 4 + - Rabs h * (eps / 8) + Rabs h * Rabs (g c - g x)). - { apply Rplus_lt_compat_r; apply Rplus_lt_compat_l; apply Rmult_lt_compat_l. - { apply Rabs_pos_lt ; assumption. } - rewrite Rabs_minus_sym ; apply fn'c_CVU_gc. - { unfold N ; lia. } - assert (t : Boule x delta c). - { destruct P. - apply Rabs_def2 in xhinbxdelta; destruct xhinbxdelta. - apply Rabs_def2 in xinb; apply Rabs_def1; lra. } - apply Pdelta in t; tauto. } - apply Rlt_trans with (Rabs h * eps / 4 + Rabs h * eps / 4 + Rabs h * (eps / 8) + - Rabs h * (eps / 8)). - { rewrite Rplus_assoc ; rewrite Rplus_assoc ; rewrite Rplus_assoc ; rewrite Rplus_assoc ; - apply Rplus_lt_compat_l ; apply Rplus_lt_compat_l ; rewrite <- Rmult_plus_distr_l ; - rewrite <- Rmult_plus_distr_l ; apply Rmult_lt_compat_l. - { apply Rabs_pos_lt ; assumption. } - apply Rplus_lt_compat_l ; simpl in g_cont ; apply g_cont ; split ; [unfold D_x ; split |]. - - solve[unfold no_cond ; intuition]. - - apply Rlt_not_eq ; exact (proj1 P). - - apply Rlt_trans with (Rabs h). - { apply Rabs_def1. - { destruct P; rewrite Rabs_pos_eq;lra. } - apply Rle_lt_trans with 0. - { assert (t := Rabs_pos h); clear -t; lra. } - clear -P; destruct P; lra. } - clear -Pdelta xhinbxdelta. - apply Pdelta in xhinbxdelta; destruct xhinbxdelta as [_ P']. - apply Rabs_def2 in P'; simpl in P'; destruct P'; - apply Rabs_def1; lra. } - rewrite Rplus_assoc ; rewrite Rplus_assoc ; rewrite <- Rmult_plus_distr_l. - replace (Rabs h * eps / 4 + (Rabs h * eps / 4 + Rabs h * (eps / 8 + eps / 8))) with - (Rabs h * (eps / 4 + eps / 4 + eps / 8 + eps / 8)) by field. - apply Rmult_lt_compat_l. - { apply Rabs_pos_lt ; assumption. } - lra. } - assert (H := pr1 c P) ; elim H ; clear H ; intros l Hl. - assert (Temp : l = fn' N c). - { assert (bc'rc : Boule c' r c). - { assert (t : Boule x delta c). - { clear - xhinbxdelta P. - destruct P; apply Rabs_def2 in xhinbxdelta; destruct xhinbxdelta. - apply Rabs_def1; lra. } - apply Pdelta in t; tauto. } - assert (Hl' := Dfn_eq_fn' c N bc'rc). - unfold derivable_pt_abs in Hl; clear -Hl Hl'. - apply uniqueness_limite with (f:= fn N) (x:=c) ; assumption. } - rewrite <- Temp. - assert (Hl' : derivable_pt (fn N) c). - { exists l ; apply Hl. } - rewrite pr_nu_var with (g:= fn N) (pr2:=Hl'). - { elim Hl' ; clear Hl' ; intros l' Hl'. - assert (Main : l = l'). - { apply uniqueness_limite with (f:= fn N) (x:=c) ; assumption. } - rewrite Main ; reflexivity. } - reflexivity. -Qed. diff --git a/stdlib/theories/Reals/Ranalysis_reg.v b/stdlib/theories/Reals/Ranalysis_reg.v deleted file mode 100644 index 7e01efaebb66..000000000000 --- a/stdlib/theories/Reals/Ranalysis_reg.v +++ /dev/null @@ -1,813 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* - match goal with - | |- (derivable _) => intro_hyp_glob X1; intro_hyp_glob X2 - | |- (continuity _) => intro_hyp_glob X1; intro_hyp_glob X2 - | _ => idtac - end - | (?X1 - ?X2)%F => - match goal with - | |- (derivable _) => intro_hyp_glob X1; intro_hyp_glob X2 - | |- (continuity _) => intro_hyp_glob X1; intro_hyp_glob X2 - | _ => idtac - end - | (?X1 * ?X2)%F => - match goal with - | |- (derivable _) => intro_hyp_glob X1; intro_hyp_glob X2 - | |- (continuity _) => intro_hyp_glob X1; intro_hyp_glob X2 - | _ => idtac - end - | (?X1 / ?X2)%F => - let aux := constr:(X2) in - match goal with - | _:(forall x0:R, aux x0 <> 0) |- (derivable _) => - intro_hyp_glob X1; intro_hyp_glob X2 - | _:(forall x0:R, aux x0 <> 0) |- (continuity _) => - intro_hyp_glob X1; intro_hyp_glob X2 - | |- (derivable _) => - cut (forall x0:R, aux x0 <> 0); - [ intro; intro_hyp_glob X1; intro_hyp_glob X2 | try assumption ] - | |- (continuity _) => - cut (forall x0:R, aux x0 <> 0); - [ intro; intro_hyp_glob X1; intro_hyp_glob X2 | try assumption ] - | _ => idtac - end - | (comp ?X1 ?X2) => - match goal with - | |- (derivable _) => intro_hyp_glob X1; intro_hyp_glob X2 - | |- (continuity _) => intro_hyp_glob X1; intro_hyp_glob X2 - | _ => idtac - end - | (- ?X1)%F => - match goal with - | |- (derivable _) => intro_hyp_glob X1 - | |- (continuity _) => intro_hyp_glob X1 - | _ => idtac - end - | (/ ?X1)%F => - let aux := constr:(X1) in - match goal with - | _:(forall x0:R, aux x0 <> 0) |- (derivable _) => - intro_hyp_glob X1 - | _:(forall x0:R, aux x0 <> 0) |- (continuity _) => - intro_hyp_glob X1 - | |- (derivable _) => - cut (forall x0:R, aux x0 <> 0); - [ intro; intro_hyp_glob X1 | try assumption ] - | |- (continuity _) => - cut (forall x0:R, aux x0 <> 0); - [ intro; intro_hyp_glob X1 | try assumption ] - | _ => idtac - end - | cos => idtac - | sin => idtac - | cosh => idtac - | sinh => idtac - | exp => idtac - | Rsqr => idtac - | sqrt => idtac - | id => idtac - | (fct_cte _) => idtac - | (pow_fct _) => idtac - | Rabs => idtac - | ?X1 => - let p := constr:(X1) in - let HYPPD := fresh "HYPPD" in - match goal with - | _:(derivable p) |- _ => idtac - | |- (derivable p) => idtac - | |- (derivable _) => - cut (True -> derivable p); - [ intro HYPPD; cut (derivable p); - [ intro; clear HYPPD | apply HYPPD; clear HYPPD; trivial ] - | idtac ] - | _:(continuity p) |- _ => idtac - | |- (continuity p) => idtac - | |- (continuity _) => - cut (True -> continuity p); - [ intro HYPPD; cut (continuity p); - [ intro; clear HYPPD | apply HYPPD; clear HYPPD; trivial ] - | idtac ] - | _ => idtac - end - end. - -(**********) -Ltac intro_hyp_pt trm pt := - match constr:(trm) with - | (?X1 + ?X2)%F => - match goal with - | |- (derivable_pt _ _) => intro_hyp_pt X1 pt; intro_hyp_pt X2 pt - | |- (continuity_pt _ _) => intro_hyp_pt X1 pt; intro_hyp_pt X2 pt - | |- (derive_pt _ _ _ = _) => - intro_hyp_pt X1 pt; intro_hyp_pt X2 pt - | _ => idtac - end - | (?X1 - ?X2)%F => - match goal with - | |- (derivable_pt _ _) => intro_hyp_pt X1 pt; intro_hyp_pt X2 pt - | |- (continuity_pt _ _) => intro_hyp_pt X1 pt; intro_hyp_pt X2 pt - | |- (derive_pt _ _ _ = _) => - intro_hyp_pt X1 pt; intro_hyp_pt X2 pt - | _ => idtac - end - | (?X1 * ?X2)%F => - match goal with - | |- (derivable_pt _ _) => intro_hyp_pt X1 pt; intro_hyp_pt X2 pt - | |- (continuity_pt _ _) => intro_hyp_pt X1 pt; intro_hyp_pt X2 pt - | |- (derive_pt _ _ _ = _) => - intro_hyp_pt X1 pt; intro_hyp_pt X2 pt - | _ => idtac - end - | (?X1 / ?X2)%F => - let aux := constr:(X2) in - match goal with - | _:(aux pt <> 0) |- (derivable_pt _ _) => - intro_hyp_pt X1 pt; intro_hyp_pt X2 pt - | _:(aux pt <> 0) |- (continuity_pt _ _) => - intro_hyp_pt X1 pt; intro_hyp_pt X2 pt - | _:(aux pt <> 0) |- (derive_pt _ _ _ = _) => - intro_hyp_pt X1 pt; intro_hyp_pt X2 pt - | id:(forall x0:R, aux x0 <> 0) |- (derivable_pt _ _) => - generalize (id pt); intro; intro_hyp_pt X1 pt; intro_hyp_pt X2 pt - | id:(forall x0:R, aux x0 <> 0) |- (continuity_pt _ _) => - generalize (id pt); intro; intro_hyp_pt X1 pt; intro_hyp_pt X2 pt - | id:(forall x0:R, aux x0 <> 0) |- (derive_pt _ _ _ = _) => - generalize (id pt); intro; intro_hyp_pt X1 pt; intro_hyp_pt X2 pt - | |- (derivable_pt _ _) => - cut (aux pt <> 0); - [ intro; intro_hyp_pt X1 pt; intro_hyp_pt X2 pt | try assumption ] - | |- (continuity_pt _ _) => - cut (aux pt <> 0); - [ intro; intro_hyp_pt X1 pt; intro_hyp_pt X2 pt | try assumption ] - | |- (derive_pt _ _ _ = _) => - cut (aux pt <> 0); - [ intro; intro_hyp_pt X1 pt; intro_hyp_pt X2 pt | try assumption ] - | _ => idtac - end - | (comp ?X1 ?X2) => - match goal with - | |- (derivable_pt _ _) => - let pt_f1 := eval cbv beta in (X2 pt) in - (intro_hyp_pt X1 pt_f1; intro_hyp_pt X2 pt) - | |- (continuity_pt _ _) => - let pt_f1 := eval cbv beta in (X2 pt) in - (intro_hyp_pt X1 pt_f1; intro_hyp_pt X2 pt) - | |- (derive_pt _ _ _ = _) => - let pt_f1 := eval cbv beta in (X2 pt) in - (intro_hyp_pt X1 pt_f1; intro_hyp_pt X2 pt) - | _ => idtac - end - | (- ?X1)%F => - match goal with - | |- (derivable_pt _ _) => intro_hyp_pt X1 pt - | |- (continuity_pt _ _) => intro_hyp_pt X1 pt - | |- (derive_pt _ _ _ = _) => intro_hyp_pt X1 pt - | _ => idtac - end - | (/ ?X1)%F => - let aux := constr:(X1) in - match goal with - | _:(aux pt <> 0) |- (derivable_pt _ _) => - intro_hyp_pt X1 pt - | _:(aux pt <> 0) |- (continuity_pt _ _) => - intro_hyp_pt X1 pt - | _:(aux pt <> 0) |- (derive_pt _ _ _ = _) => - intro_hyp_pt X1 pt - | id:(forall x0:R, aux x0 <> 0) |- (derivable_pt _ _) => - generalize (id pt); intro; intro_hyp_pt X1 pt - | id:(forall x0:R, aux x0 <> 0) |- (continuity_pt _ _) => - generalize (id pt); intro; intro_hyp_pt X1 pt - | id:(forall x0:R, aux x0 <> 0) |- (derive_pt _ _ _ = _) => - generalize (id pt); intro; intro_hyp_pt X1 pt - | |- (derivable_pt _ _) => - cut (aux pt <> 0); [ intro; intro_hyp_pt X1 pt | try assumption ] - | |- (continuity_pt _ _) => - cut (aux pt <> 0); [ intro; intro_hyp_pt X1 pt | try assumption ] - | |- (derive_pt _ _ _ = _) => - cut (aux pt <> 0); [ intro; intro_hyp_pt X1 pt | try assumption ] - | _ => idtac - end - | cos => idtac - | sin => idtac - | cosh => idtac - | sinh => idtac - | exp => idtac - | Rsqr => idtac - | id => idtac - | (fct_cte _) => idtac - | (pow_fct _) => idtac - | sqrt => - match goal with - | |- (derivable_pt _ _) => cut (0 < pt); [ intro | try assumption ] - | |- (continuity_pt _ _) => - cut (0 <= pt); [ intro | try assumption ] - | |- (derive_pt _ _ _ = _) => - cut (0 < pt); [ intro | try assumption ] - | _ => idtac - end - | Rabs => - match goal with - | |- (derivable_pt _ _) => - cut (pt <> 0); [ intro | try assumption ] - | _ => idtac - end - | ?X1 => - let p := constr:(X1) in - let HYPPD := fresh "HYPPD" in - match goal with - | _:(derivable_pt p pt) |- _ => idtac - | |- (derivable_pt p pt) => idtac - | |- (derivable_pt _ _) => - cut (True -> derivable_pt p pt); - [ intro HYPPD; cut (derivable_pt p pt); - [ intro; clear HYPPD | apply HYPPD; clear HYPPD; trivial ] - | idtac ] - | _:(continuity_pt p pt) |- _ => idtac - | |- (continuity_pt p pt) => idtac - | |- (continuity_pt _ _) => - cut (True -> continuity_pt p pt); - [ intro HYPPD; cut (continuity_pt p pt); - [ intro; clear HYPPD | apply HYPPD; clear HYPPD; trivial ] - | idtac ] - | |- (derive_pt _ _ _ = _) => - cut (True -> derivable_pt p pt); - [ intro HYPPD; cut (derivable_pt p pt); - [ intro; clear HYPPD | apply HYPPD; clear HYPPD; trivial ] - | idtac ] - | _ => idtac - end - end. - -(**********) -Ltac is_diff_pt := - match goal with - | |- (derivable_pt Rsqr _) => - - (* fonctions de base *) - apply derivable_pt_Rsqr - | |- (derivable_pt id ?X1) => apply (derivable_pt_id X1) - | |- (derivable_pt (fct_cte _) _) => apply derivable_pt_const - | |- (derivable_pt sin _) => apply derivable_pt_sin - | |- (derivable_pt cos _) => apply derivable_pt_cos - | |- (derivable_pt sinh _) => apply derivable_pt_sinh - | |- (derivable_pt cosh _) => apply derivable_pt_cosh - | |- (derivable_pt exp _) => apply derivable_pt_exp - | |- (derivable_pt (pow_fct _) _) => - unfold pow_fct in |- *; apply derivable_pt_pow - | |- (derivable_pt sqrt ?X1) => - apply (derivable_pt_sqrt X1); - assumption || - unfold plus_fct, minus_fct, opp_fct, mult_fct, div_fct, inv_fct, - comp, id, fct_cte, pow_fct in |- * - | |- (derivable_pt Rabs ?X1) => - apply (Rderivable_pt_abs X1); - assumption || - unfold plus_fct, minus_fct, opp_fct, mult_fct, div_fct, inv_fct, - comp, id, fct_cte, pow_fct in |- * - (* regles de differentiabilite *) - (* PLUS *) - | |- (derivable_pt (?X1 + ?X2) ?X3) => - apply (derivable_pt_plus X1 X2 X3); is_diff_pt - (* MOINS *) - | |- (derivable_pt (?X1 - ?X2) ?X3) => - apply (derivable_pt_minus X1 X2 X3); is_diff_pt - (* OPPOSE *) - | |- (derivable_pt (- ?X1) ?X2) => - apply (derivable_pt_opp X1 X2); - is_diff_pt - (* MULTIPLICATION PAR UN SCALAIRE *) - | |- (derivable_pt (mult_real_fct ?X1 ?X2) ?X3) => - apply (derivable_pt_scal X2 X1 X3); is_diff_pt - (* MULTIPLICATION *) - | |- (derivable_pt (?X1 * ?X2) ?X3) => - apply (derivable_pt_mult X1 X2 X3); is_diff_pt - (* DIVISION *) - | |- (derivable_pt (?X1 / ?X2) ?X3) => - apply (derivable_pt_div X1 X2 X3); - [ is_diff_pt - | is_diff_pt - | try - assumption || - unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct, - comp, pow_fct, id, fct_cte in |- * ] - | |- (derivable_pt (/ ?X1) ?X2) => - - (* INVERSION *) - apply (derivable_pt_inv X1 X2); - [ assumption || - unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct, - comp, pow_fct, id, fct_cte in |- * - | is_diff_pt ] - | |- (derivable_pt (comp ?X1 ?X2) ?X3) => - - (* COMPOSITION *) - apply (derivable_pt_comp X2 X1 X3); is_diff_pt - | _:(derivable_pt ?X1 ?X2) |- (derivable_pt ?X1 ?X2) => - assumption - | _:(derivable ?X1) |- (derivable_pt ?X1 ?X2) => - let HypDDPT := fresh "HypDDPT" in - cut (derivable X1); [ intro HypDDPT; apply HypDDPT | assumption ] - | |- (True -> derivable_pt _ _) => - let HypTruE := fresh "HypTruE" in - intro HypTruE; clear HypTruE; is_diff_pt - | _ => - try - unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct, id, - fct_cte, comp, pow_fct in |- * - end. - -(**********) -Ltac is_diff_glob := - match goal with - | |- (derivable Rsqr) => - (* fonctions de base *) - apply derivable_Rsqr - | |- (derivable id) => apply derivable_id - | |- (derivable (fct_cte _)) => apply derivable_const - | |- (derivable sin) => apply derivable_sin - | |- (derivable cos) => apply derivable_cos - | |- (derivable cosh) => apply derivable_cosh - | |- (derivable sinh) => apply derivable_sinh - | |- (derivable exp) => apply derivable_exp - | |- (derivable (pow_fct _)) => - unfold pow_fct in |- *; - apply derivable_pow - (* regles de differentiabilite *) - (* PLUS *) - | |- (derivable (?X1 + ?X2)) => - apply (derivable_plus X1 X2); is_diff_glob - (* MOINS *) - | |- (derivable (?X1 - ?X2)) => - apply (derivable_minus X1 X2); is_diff_glob - (* OPPOSE *) - | |- (derivable (- ?X1)) => - apply (derivable_opp X1); - is_diff_glob - (* MULTIPLICATION PAR UN SCALAIRE *) - | |- (derivable (mult_real_fct ?X1 ?X2)) => - apply (derivable_scal X2 X1); is_diff_glob - (* MULTIPLICATION *) - | |- (derivable (?X1 * ?X2)) => - apply (derivable_mult X1 X2); is_diff_glob - (* DIVISION *) - | |- (derivable (?X1 / ?X2)) => - apply (derivable_div X1 X2); - [ is_diff_glob - | is_diff_glob - | try - assumption || - unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct, - id, fct_cte, comp, pow_fct in |- * ] - | |- (derivable (/ ?X1)) => - - (* INVERSION *) - apply (derivable_inv X1); - [ try - assumption || - unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct, - id, fct_cte, comp, pow_fct in |- * - | is_diff_glob ] - | |- (derivable (comp sqrt _)) => - - (* COMPOSITION *) - unfold derivable in |- *; intro; try is_diff_pt - | |- (derivable (comp Rabs _)) => - unfold derivable in |- *; intro; try is_diff_pt - | |- (derivable (comp ?X1 ?X2)) => - apply (derivable_comp X2 X1); is_diff_glob - | _:(derivable ?X1) |- (derivable ?X1) => assumption - | |- (True -> derivable _) => - let HypTruE := fresh "HypTruE" in - intro HypTruE; clear HypTruE; is_diff_glob - | _ => - try - unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct, id, - fct_cte, comp, pow_fct in |- * - end. - -(**********) -Ltac is_cont_pt := - match goal with - | |- (continuity_pt Rsqr _) => - - (* fonctions de base *) - apply derivable_continuous_pt; apply derivable_pt_Rsqr - | |- (continuity_pt id ?X1) => - apply derivable_continuous_pt; apply (derivable_pt_id X1) - | |- (continuity_pt (fct_cte _) _) => - apply derivable_continuous_pt; apply derivable_pt_const - | |- (continuity_pt sin _) => - apply derivable_continuous_pt; apply derivable_pt_sin - | |- (continuity_pt cos _) => - apply derivable_continuous_pt; apply derivable_pt_cos - | |- (continuity_pt sinh _) => - apply derivable_continuous_pt; apply derivable_pt_sinh - | |- (continuity_pt cosh _) => - apply derivable_continuous_pt; apply derivable_pt_cosh - | |- (continuity_pt exp _) => - apply derivable_continuous_pt; apply derivable_pt_exp - | |- (continuity_pt (pow_fct _) _) => - unfold pow_fct in |- *; apply derivable_continuous_pt; - apply derivable_pt_pow - | |- (continuity_pt sqrt ?X1) => - apply continuity_pt_sqrt; - assumption || - unfold plus_fct, minus_fct, opp_fct, mult_fct, div_fct, inv_fct, - comp, id, fct_cte, pow_fct in |- * - | |- (continuity_pt Rabs ?X1) => - apply (Rcontinuity_abs X1) - (* regles de differentiabilite *) - (* PLUS *) - | |- (continuity_pt (?X1 + ?X2) ?X3) => - apply (continuity_pt_plus X1 X2 X3); is_cont_pt - (* MOINS *) - | |- (continuity_pt (?X1 - ?X2) ?X3) => - apply (continuity_pt_minus X1 X2 X3); is_cont_pt - (* OPPOSE *) - | |- (continuity_pt (- ?X1) ?X2) => - apply (continuity_pt_opp X1 X2); - is_cont_pt - (* MULTIPLICATION PAR UN SCALAIRE *) - | |- (continuity_pt (mult_real_fct ?X1 ?X2) ?X3) => - apply (continuity_pt_scal X2 X1 X3); is_cont_pt - (* MULTIPLICATION *) - | |- (continuity_pt (?X1 * ?X2) ?X3) => - apply (continuity_pt_mult X1 X2 X3); is_cont_pt - (* DIVISION *) - | |- (continuity_pt (?X1 / ?X2) ?X3) => - apply (continuity_pt_div X1 X2 X3); - [ is_cont_pt - | is_cont_pt - | try - assumption || - unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct, - comp, id, fct_cte, pow_fct in |- * ] - | |- (continuity_pt (/ ?X1) ?X2) => - - (* INVERSION *) - apply (continuity_pt_inv X1 X2); - [ is_cont_pt - | assumption || - unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct, - comp, id, fct_cte, pow_fct in |- * ] - | |- (continuity_pt (comp ?X1 ?X2) ?X3) => - - (* COMPOSITION *) - apply (continuity_pt_comp X2 X1 X3); is_cont_pt - | _:(continuity_pt ?X1 ?X2) |- (continuity_pt ?X1 ?X2) => - assumption - | _:(continuity ?X1) |- (continuity_pt ?X1 ?X2) => - let HypDDPT := fresh "HypDDPT" in - cut (continuity X1); [ intro HypDDPT; apply HypDDPT | assumption ] - | _:(derivable_pt ?X1 ?X2) |- (continuity_pt ?X1 ?X2) => - apply derivable_continuous_pt; assumption - | _:(derivable ?X1) |- (continuity_pt ?X1 ?X2) => - let HypDDPT := fresh "HypDDPT" in - cut (continuity X1); - [ intro HypDDPT; apply HypDDPT - | apply derivable_continuous; assumption ] - | |- (True -> continuity_pt _ _) => - let HypTruE := fresh "HypTruE" in - intro HypTruE; clear HypTruE; is_cont_pt - | _ => - try - unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct, id, - fct_cte, comp, pow_fct in |- * - end. - -(**********) -Ltac is_cont_glob := - match goal with - | |- (continuity Rsqr) => - - (* fonctions de base *) - apply derivable_continuous; apply derivable_Rsqr - | |- (continuity id) => apply derivable_continuous; apply derivable_id - | |- (continuity (fct_cte _)) => - apply derivable_continuous; apply derivable_const - | |- (continuity sin) => apply derivable_continuous; apply derivable_sin - | |- (continuity cos) => apply derivable_continuous; apply derivable_cos - | |- (continuity exp) => apply derivable_continuous; apply derivable_exp - | |- (continuity (pow_fct _)) => - unfold pow_fct in |- *; apply derivable_continuous; apply derivable_pow - | |- (continuity sinh) => - apply derivable_continuous; apply derivable_sinh - | |- (continuity cosh) => - apply derivable_continuous; apply derivable_cosh - | |- (continuity Rabs) => - apply Rcontinuity_abs - (* regles de continuite *) - (* PLUS *) - | |- (continuity (?X1 + ?X2)) => - apply (continuity_plus X1 X2); - try is_cont_glob || assumption - (* MOINS *) - | |- (continuity (?X1 - ?X2)) => - apply (continuity_minus X1 X2); - try is_cont_glob || assumption - (* OPPOSE *) - | |- (continuity (- ?X1)) => - apply (continuity_opp X1); try is_cont_glob || assumption - (* INVERSE *) - | |- (continuity (/ ?X1)) => - apply (continuity_inv X1); - try is_cont_glob || assumption - (* MULTIPLICATION PAR UN SCALAIRE *) - | |- (continuity (mult_real_fct ?X1 ?X2)) => - apply (continuity_scal X2 X1); - try is_cont_glob || assumption - (* MULTIPLICATION *) - | |- (continuity (?X1 * ?X2)) => - apply (continuity_mult X1 X2); - try is_cont_glob || assumption - (* DIVISION *) - | |- (continuity (?X1 / ?X2)) => - apply (continuity_div X1 X2); - [ try is_cont_glob || assumption - | try is_cont_glob || assumption - | try - assumption || - unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct, - id, fct_cte, pow_fct in |- * ] - | |- (continuity (comp sqrt _)) => - - (* COMPOSITION *) - unfold continuity_pt in |- *; intro; try is_cont_pt - | |- (continuity (comp ?X1 ?X2)) => - apply (continuity_comp X2 X1); try is_cont_glob || assumption - | _:(continuity ?X1) |- (continuity ?X1) => assumption - | |- (True -> continuity _) => - let HypTruE := fresh "HypTruE" in - intro HypTruE; clear HypTruE; is_cont_glob - | _:(derivable ?X1) |- (continuity ?X1) => - apply derivable_continuous; assumption - | _ => - try - unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct, id, - fct_cte, comp, pow_fct in |- * - end. - -(**********) -Ltac rew_term trm := - match constr:(trm) with - | (?X1 + ?X2) => - let p1 := rew_term X1 with p2 := rew_term X2 in - match constr:(p1) with - | (fct_cte ?X3) => - match constr:(p2) with - | (fct_cte ?X4) => constr:(fct_cte (X3 + X4)) - | _ => constr:((p1 + p2)%F) - end - | _ => constr:((p1 + p2)%F) - end - | (?X1 - ?X2) => - let p1 := rew_term X1 with p2 := rew_term X2 in - match constr:(p1) with - | (fct_cte ?X3) => - match constr:(p2) with - | (fct_cte ?X4) => constr:(fct_cte (X3 - X4)) - | _ => constr:((p1 - p2)%F) - end - | _ => constr:((p1 - p2)%F) - end - | (?X1 / ?X2) => - let p1 := rew_term X1 with p2 := rew_term X2 in - match constr:(p1) with - | (fct_cte ?X3) => - match constr:(p2) with - | (fct_cte ?X4) => constr:(fct_cte (X3 / X4)) - | _ => constr:((p1 / p2)%F) - end - | _ => - match constr:(p2) with - | (fct_cte ?X4) => constr:((p1 * fct_cte (/ X4))%F) - | _ => constr:((p1 / p2)%F) - end - end - | (?X1 * / ?X2) => - let p1 := rew_term X1 with p2 := rew_term X2 in - match constr:(p1) with - | (fct_cte ?X3) => - match constr:(p2) with - | (fct_cte ?X4) => constr:(fct_cte (X3 / X4)) - | _ => constr:((p1 / p2)%F) - end - | _ => - match constr:(p2) with - | (fct_cte ?X4) => constr:((p1 * fct_cte (/ X4))%F) - | _ => constr:((p1 / p2)%F) - end - end - | (?X1 * ?X2) => - let p1 := rew_term X1 with p2 := rew_term X2 in - match constr:(p1) with - | (fct_cte ?X3) => - match constr:(p2) with - | (fct_cte ?X4) => constr:(fct_cte (X3 * X4)) - | _ => constr:((p1 * p2)%F) - end - | _ => constr:((p1 * p2)%F) - end - | (- ?X1) => - let p := rew_term X1 in - match constr:(p) with - | (fct_cte ?X2) => constr:(fct_cte (- X2)) - | _ => constr:((- p)%F) - end - | (/ ?X1) => - let p := rew_term X1 in - match constr:(p) with - | (fct_cte ?X2) => constr:(fct_cte (/ X2)) - | _ => constr:((/ p)%F) - end - | (?X1 AppVar) => constr:(X1) - | (?X1 ?X2) => - let p := rew_term X2 in - match constr:(p) with - | (fct_cte ?X3) => constr:(fct_cte (X1 X3)) - | _ => constr:(comp X1 p) - end - | AppVar => constr:(id) - | (AppVar ^ ?X1) => constr:(pow_fct X1) - | (?X1 ^ ?X2) => - let p := rew_term X1 in - match constr:(p) with - | (fct_cte ?X3) => constr:(fct_cte (pow_fct X2 X3)) - | _ => constr:(comp (pow_fct X2) p) - end - | ?X1 => constr:(fct_cte X1) - end. - -(**********) -Ltac deriv_proof trm pt := - match constr:(trm) with - | (?X1 + ?X2)%F => - let p1 := deriv_proof X1 pt with p2 := deriv_proof X2 pt in - constr:(derivable_pt_plus X1 X2 pt p1 p2) - | (?X1 - ?X2)%F => - let p1 := deriv_proof X1 pt with p2 := deriv_proof X2 pt in - constr:(derivable_pt_minus X1 X2 pt p1 p2) - | (?X1 * ?X2)%F => - let p1 := deriv_proof X1 pt with p2 := deriv_proof X2 pt in - constr:(derivable_pt_mult X1 X2 pt p1 p2) - | (?X1 / ?X2)%F => - match goal with - | id:(?X2 pt <> 0) |- _ => - let p1 := deriv_proof X1 pt with p2 := deriv_proof X2 pt in - constr:(derivable_pt_div X1 X2 pt p1 p2 id) - | _ => constr:(False) - end - | (/ ?X1)%F => - match goal with - | id:(?X1 pt <> 0) |- _ => - let p1 := deriv_proof X1 pt in - constr:(derivable_pt_inv X1 pt p1 id) - | _ => constr:(False) - end - | (comp ?X1 ?X2) => - let pt_f1 := eval cbv beta in (X2 pt) in - let p1 := deriv_proof X1 pt_f1 with p2 := deriv_proof X2 pt in - constr:(derivable_pt_comp X2 X1 pt p2 p1) - | (- ?X1)%F => - let p1 := deriv_proof X1 pt in - constr:(derivable_pt_opp X1 pt p1) - | sin => constr:(derivable_pt_sin pt) - | cos => constr:(derivable_pt_cos pt) - | sinh => constr:(derivable_pt_sinh pt) - | cosh => constr:(derivable_pt_cosh pt) - | exp => constr:(derivable_pt_exp pt) - | id => constr:(derivable_pt_id pt) - | Rsqr => constr:(derivable_pt_Rsqr pt) - | sqrt => - match goal with - | id:(0 < pt) |- _ => constr:(derivable_pt_sqrt pt id) - | _ => constr:(False) - end - | (fct_cte ?X1) => constr:(derivable_pt_const X1 pt) - | ?X1 => - let aux := constr:(X1) in - match goal with - | id:(derivable_pt aux pt) |- _ => constr:(id) - | id:(derivable aux) |- _ => constr:(id pt) - | _ => constr:(False) - end - end. - -(**********) -Ltac simplify_derive trm pt := - match constr:(trm) with - | (?X1 + ?X2)%F => - try rewrite derive_pt_plus; simplify_derive X1 pt; - simplify_derive X2 pt - | (?X1 - ?X2)%F => - try rewrite derive_pt_minus; simplify_derive X1 pt; - simplify_derive X2 pt - | (?X1 * ?X2)%F => - try rewrite derive_pt_mult; simplify_derive X1 pt; - simplify_derive X2 pt - | (?X1 / ?X2)%F => - try rewrite derive_pt_div; simplify_derive X1 pt; simplify_derive X2 pt - | (comp ?X1 ?X2) => - let pt_f1 := eval cbv beta in (X2 pt) in - (try rewrite derive_pt_comp; simplify_derive X1 pt_f1; - simplify_derive X2 pt) - | (- ?X1)%F => try rewrite derive_pt_opp; simplify_derive X1 pt - | (/ ?X1)%F => - try rewrite derive_pt_inv; simplify_derive X1 pt - | (fct_cte ?X1) => try rewrite derive_pt_const - | id => try rewrite derive_pt_id - | sin => try rewrite derive_pt_sin - | cos => try rewrite derive_pt_cos - | sinh => try rewrite derive_pt_sinh - | cosh => try rewrite derive_pt_cosh - | exp => try rewrite derive_pt_exp - | Rsqr => try rewrite derive_pt_Rsqr - | sqrt => try rewrite derive_pt_sqrt - | ?X1 => - let aux := constr:(X1) in - match goal with - | id:(derive_pt aux pt ?X2 = _),H:(derivable aux) |- _ => - try replace (derive_pt aux pt (H pt)) with (derive_pt aux pt X2); - [ rewrite id | apply pr_nu ] - | id:(derive_pt aux pt ?X2 = _),H:(derivable_pt aux pt) |- _ => - try replace (derive_pt aux pt H) with (derive_pt aux pt X2); - [ rewrite id | apply pr_nu ] - | _ => idtac - end - | _ => idtac - end. - -(**********) -Ltac reg := - match goal with - | |- (derivable_pt ?X1 ?X2) => - let trm := eval cbv beta in (X1 AppVar) in - let aux := rew_term trm in - (intro_hyp_pt aux X2; - try (change (derivable_pt aux X2) in |- *; is_diff_pt) || is_diff_pt) - | |- (derivable ?X1) => - let trm := eval cbv beta in (X1 AppVar) in - let aux := rew_term trm in - (intro_hyp_glob aux; - try (change (derivable aux) in |- *; is_diff_glob) || is_diff_glob) - | |- (continuity ?X1) => - let trm := eval cbv beta in (X1 AppVar) in - let aux := rew_term trm in - (intro_hyp_glob aux; - try (change (continuity aux) in |- *; is_cont_glob) || is_cont_glob) - | |- (continuity_pt ?X1 ?X2) => - let trm := eval cbv beta in (X1 AppVar) in - let aux := rew_term trm in - (intro_hyp_pt aux X2; - try (change (continuity_pt aux X2) in |- *; is_cont_pt) || is_cont_pt) - | |- (derive_pt ?X1 ?X2 ?X3 = ?X4) => - let trm := eval cbv beta in (X1 AppVar) in - let aux := rew_term trm in - intro_hyp_pt aux X2; - (let aux2 := deriv_proof aux X2 in - try - (replace (derive_pt X1 X2 X3) with (derive_pt aux X2 aux2); - [ simplify_derive aux X2; - try unfold plus_fct, minus_fct, mult_fct, div_fct, id, fct_cte, - inv_fct, opp_fct in |- *; ring || ring_simplify - | try apply pr_nu ]) || is_diff_pt) - end. diff --git a/stdlib/theories/Reals/Ratan.v b/stdlib/theories/Reals/Ratan.v deleted file mode 100644 index f03a91382643..000000000000 --- a/stdlib/theories/Reals/Ratan.v +++ /dev/null @@ -1,2143 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* 0 <= x <= 1. -Proof. -unfold Boule, posreal_half; simpl. -intros x b; apply Rabs_def2 in b; destruct b; split; lra. -Qed. - -Lemma Boule_lt : forall c r x, - Boule c r x -> Rabs x < Rabs c + r. -Proof. -unfold Boule; intros c r x h. -apply Rabs_def2 in h; destruct h; apply Rabs_def1; - (destruct (Rle_lt_dec 0 c);[rewrite Rabs_pos_eq; lra | - rewrite <- Rabs_Ropp, Rabs_pos_eq; lra]). -Qed. - -(* The following lemma does not belong here. *) -Lemma Un_cv_ext : forall un vn, - (forall n, un n = vn n) -> - forall l, Un_cv un l -> - Un_cv vn l. -Proof. -intros un vn quv l P eps ep; destruct (P eps ep) as [N Pn]; exists N. -intro n; rewrite <- quv; apply Pn. -Qed. - -(* The following two lemmas are general purposes about alternated series. - They do not belong here. *) -Lemma Alt_first_term_bound : forall f l N n, - Un_decreasing f -> Un_cv f 0 -> - Un_cv (sum_f_R0 (tg_alt f)) l -> - (N <= n)%nat -> - Rdist (sum_f_R0 (tg_alt f) n) l <= f N. -Proof. - intros f l. - assert (WLOG : - forall n P, (forall k, (0 < k)%nat -> P k) -> - ((forall k, (0 < k)%nat -> P k) -> P 0%nat) -> P n). - { clear. - intros [ | n] P Hs Ho;[solve[apply Ho, Hs] | apply Hs; auto with arith]. } - intros N; pattern N; apply WLOG; clear N. - 2:{ clear WLOG; intros Hyp [ | n] decr to0 cv _. - { generalize (alternated_series_ineq f l 0 decr to0 cv). - unfold Rdist, tg_alt; simpl; rewrite !Rmult_1_l, !Rmult_1_r. - assert (f 1%nat <= f 0%nat) by apply decr. - intros [A B]; rewrite Rabs_pos_eq; lra. } - apply Rle_trans with (f 1%nat). - { apply (Hyp 1%nat (le_n 1) (S n) decr to0 cv). - lia. } - solve[apply decr]. } - intros [ | N] Npos n decr to0 cv nN. - { lia. } - assert (decr' : Un_decreasing (fun i => f (S N + i)%nat)). - { intros k; replace (S N+S k)%nat with (S (S N+k)) by ring. - apply (decr (S N + k)%nat). } - assert (to' : Un_cv (fun i => f (S N + i)%nat) 0). - { intros eps ep; destruct (to0 eps ep) as [M PM]. - exists M; intros k kM; apply PM; lia. } - assert (cv' : Un_cv - (sum_f_R0 (tg_alt (fun i => ((-1) ^ S N * f(S N + i)%nat)))) - (l - sum_f_R0 (tg_alt f) N)). - { intros eps ep; destruct (cv eps ep) as [M PM]; exists M. - intros n' nM. - match goal with |- ?C => set (U := C) end. - assert (nM' : (n' + S N >= M)%nat) by lia. - generalize (PM _ nM'); unfold Rdist. - rewrite (tech2 (tg_alt f) N (n' + S N)). - 2:lia. - assert (t : forall a b c, (a + b) - c = b - (c - a)) by (intros; ring). - rewrite t; clear t; unfold U, Rdist; clear U. - replace (n' + S N - S N)%nat with n' by lia. - rewrite <- (sum_eq (tg_alt (fun i => (-1) ^ S N * f(S N + i)%nat))). - { tauto. } - intros i _; unfold tg_alt. - rewrite <- Rmult_assoc, <- pow_add, !(Nat.add_comm i); reflexivity. } - assert (cv'' : Un_cv (sum_f_R0 (tg_alt (fun i => f (S N + i)%nat))) - ((-1) ^ S N * (l - sum_f_R0 (tg_alt f) N))). - { apply (Un_cv_ext (fun n => (-1) ^ S N * - sum_f_R0 (tg_alt (fun i : nat => (-1) ^ S N * f (S N + i)%nat)) n)). - { intros n0; rewrite scal_sum; apply sum_eq; intros i _. - unfold tg_alt; ring_simplify; replace (((-1) ^ S N) ^ 2) with 1. - { ring. } - rewrite <- pow_mult, Nat.mul_comm, pow_mult; replace ((-1) ^2) with 1 by ring. - rewrite pow1; reflexivity. } - apply CV_mult. - { solve[intros eps ep; exists 0%nat; intros; rewrite Rdist_eq; auto]. } - assumption. } - destruct (even_odd_cor N) as [p [Neven | Nodd]]. - - rewrite Neven; destruct (alternated_series_ineq _ _ p decr to0 cv) as [B C]. - case (even_odd_cor n) as [p' [neven | nodd]]. - + rewrite neven. - destruct (alternated_series_ineq _ _ p' decr to0 cv) as [D E]. - unfold Rdist; rewrite Rabs_pos_eq;[ | lra]. - assert (dist : (p <= p')%nat) by lia. - assert (t := decreasing_prop _ _ _ (CV_ALT_step1 f decr) dist). - apply Rle_trans with (sum_f_R0 (tg_alt f) (2 * p) - l). - { unfold Rminus; apply Rplus_le_compat_r; exact t. } - match goal with - _ : ?a <= l, _ : l <= ?b |- _ => - replace (f (S (2 * p))) with (b - a) by - (rewrite tech5; unfold tg_alt; rewrite pow_1_odd; ring); lra - end. - + rewrite nodd; destruct (alternated_series_ineq _ _ p' decr to0 cv) as [D E]. - unfold Rdist; rewrite <- Rabs_Ropp, Rabs_pos_eq, Ropp_minus_distr; - [ | lra]. - assert (dist : (p <= p')%nat) by lia. - apply Rle_trans with (l - sum_f_R0 (tg_alt f) (S (2 * p))). - { unfold Rminus; apply Rplus_le_compat_l, Ropp_le_contravar. - solve[apply Rge_le, (growing_prop _ _ _ (CV_ALT_step0 f decr) dist)]. } - unfold Rminus; rewrite tech5, Ropp_plus_distr, <- Rplus_assoc. - unfold tg_alt at 2; rewrite pow_1_odd; lra. - - rewrite Nodd; destruct (alternated_series_ineq _ _ p decr to0 cv) as [B _]. - destruct (alternated_series_ineq _ _ (S p) decr to0 cv) as [_ C]. - assert (keep : (2 * S p = S (S ( 2 * p)))%nat) by ring. - case (even_odd_cor n) as [p' [neven | nodd]]. - + rewrite neven; - destruct (alternated_series_ineq _ _ p' decr to0 cv) as [D E]. - unfold Rdist; rewrite Rabs_pos_eq;[ | lra]. - assert (dist : (S p < S p')%nat) by lia. - apply Rle_trans with (sum_f_R0 (tg_alt f) (2 * S p) - l). - { unfold Rminus; apply Rplus_le_compat_r, - (decreasing_prop _ _ _ (CV_ALT_step1 f decr)). - lia. } - rewrite keep, tech5; unfold tg_alt at 2; rewrite <- keep, pow_1_even. - lra. - + rewrite nodd; destruct (alternated_series_ineq _ _ p' decr to0 cv) as [D E]. - unfold Rdist; rewrite <- Rabs_Ropp, Rabs_pos_eq;[ | lra]. - rewrite Ropp_minus_distr. - apply Rle_trans with (l - sum_f_R0 (tg_alt f) (S (2 * p))). - { unfold Rminus; apply Rplus_le_compat_l, Ropp_le_contravar, Rge_le, - (growing_prop _ _ _ (CV_ALT_step0 f decr)); lia. } - generalize C; rewrite keep, tech5; unfold tg_alt. - rewrite <- keep, pow_1_even. - lra. -Qed. - -Lemma Alt_CVU : forall (f : nat -> R -> R) g h c r, - (forall x, Boule c r x ->Un_decreasing (fun n => f n x)) -> - (forall x, Boule c r x -> Un_cv (fun n => f n x) 0) -> - (forall x, Boule c r x -> - Un_cv (sum_f_R0 (tg_alt (fun i => f i x))) (g x)) -> - (forall x n, Boule c r x -> f n x <= h n) -> - (Un_cv h 0) -> - CVU (fun N x => sum_f_R0 (tg_alt (fun i => f i x)) N) g c r. -Proof. - intros f g h c r decr to0 to_g bound bound0 eps ep. - assert (ep' : 0 f i y) (g y) n n); auto]. } - apply Rle_lt_trans with (h n). - { apply bound; assumption. } - clear - nN Pn. - generalize (Pn _ nN); unfold Rdist; rewrite Rminus_0_r; intros t. - apply Rabs_def2 in t; tauto. -Qed. - -(* The following lemmas are general purpose lemmas about squares. - They do not belong here *) - -Lemma pow2_ge_0 : forall x, 0 <= x^2. -Proof. - intros x; destruct (Rle_lt_dec 0 x). - - replace (x ^ 2) with (x * x) by field. - apply Rmult_le_pos; assumption. - - replace (x ^ 2) with ((-x) * (-x)) by field. - apply Rmult_le_pos; lra. -Qed. - -Lemma pow2_abs : forall x, Rabs x^2 = x^2. -Proof. - intros x; destruct (Rle_lt_dec 0 x). - - rewrite Rabs_pos_eq;[field | assumption]. - - rewrite <- Rabs_Ropp, Rabs_pos_eq;[field | lra]. -Qed. - -(** ** Properties of tangent *) - -(** *** Derivative of tangent *) - -Lemma derivable_pt_tan : forall x, -PI/2 < x < PI/2 -> - derivable_pt tan x. -Proof. -intros x xint. - unfold derivable_pt, tan. - apply derivable_pt_div ; [reg | reg | ]. - apply Rgt_not_eq. - unfold Rgt ; apply cos_gt_0; - [unfold Rdiv; rewrite <- Ropp_mult_distr_l_reverse; fold (-PI/2) |];tauto. -Qed. - -Lemma derive_pt_tan : forall x, - forall (Pr1: -PI/2 < x < PI/2), - derive_pt tan x (derivable_pt_tan x Pr1) = 1 + (tan x)^2. -Proof. -intros x pr. -assert (cos x <> 0). -{ apply Rgt_not_eq, cos_gt_0; rewrite <- ?Rdiv_opp_l; tauto. } -unfold tan; reg; unfold pow, Rsqr; field; assumption. -Qed. - -(** *** Proof that tangent is a bijection *) - -(* to be removed? *) - -Lemma derive_increasing_interv : forall (a b : R) (f : R -> R), - a < b -> - forall (pr:forall x, a < x < b -> derivable_pt f x), - (forall t:R, forall (t_encad : a < t < b), 0 < derive_pt f t (pr t t_encad)) -> - forall x y:R, a < x < b -> a < y < b -> x < y -> f x < f y. -Proof. -intros a b f a_lt_b pr Df_gt_0 x y x_encad y_encad x_lt_y. -assert (derivable_id_interv : forall c : R, x < c < y -> derivable_pt id c). -{ intros ; apply derivable_pt_id. } -assert (derivable_f_interv : forall c : R, x < c < y -> derivable_pt f c). -{ intros c c_encad. apply pr. split. - { apply Rlt_trans with (r2:=x) ; [exact (proj1 x_encad) | exact (proj1 c_encad)]. } - apply Rlt_trans with (r2:=y) ; [exact (proj2 c_encad) | exact (proj2 y_encad)]. } -assert (f_cont_interv : forall c : R, x <= c <= y -> continuity_pt f c). -{ intros c c_encad; apply derivable_continuous_pt ; apply pr. split. - { apply Rlt_le_trans with (r2:=x) ; [exact (proj1 x_encad) | exact (proj1 c_encad)]. } - apply Rle_lt_trans with (r2:=y) ; [ exact (proj2 c_encad) | exact (proj2 y_encad)]. } -assert (id_cont_interv : forall c : R, x <= c <= y -> continuity_pt id c). -{ intros ; apply derivable_continuous_pt ; apply derivable_pt_id. } -elim (MVT f id x y derivable_f_interv derivable_id_interv x_lt_y f_cont_interv id_cont_interv). -intros c Temp ; elim Temp ; clear Temp ; intros Pr eq. -replace (id y - id x) with (y - x) in eq by intuition. -replace (derive_pt id c (derivable_id_interv c Pr)) with 1 in eq. -2:{ symmetry ; rewrite derive_pt_eq ; apply derivable_pt_lim_id. } -apply Rminus_gt. -rewrite Rmult_1_r in eq. rewrite <- eq. -apply Rmult_gt_0_compat. -{ apply Rgt_minus ; assumption. } -assert (c_encad2 : a <= c < b). -{ split. - { apply Rlt_le ; apply Rlt_trans with (r2:=x) ; [exact (proj1 x_encad) | exact (proj1 Pr)]. } - apply Rle_lt_trans with (r2:=y) ; [apply Rlt_le ; exact (proj2 Pr) | exact (proj2 y_encad)]. } -assert (c_encad : a < c < b). -{ split. - { apply Rlt_trans with (r2:=x) ; [exact (proj1 x_encad) | exact (proj1 Pr)]. } - apply Rle_lt_trans with (r2:=y) ; [apply Rlt_le ; exact (proj2 Pr) | exact (proj2 y_encad)]. } -rewrite (pr_nu f c (derivable_f_interv c Pr) (pr c c_encad)). -apply (Df_gt_0 c c_encad). -Qed. - -(* begin hide *) -Lemma plus_Rsqr_gt_0 : forall x, 1 + x ^ 2 > 0. -Proof. -intro m. replace 0 with (0+0) by intuition. -apply Rplus_gt_ge_compat. { intuition. } -destruct (total_order_T m 0) as [[m_cond|H']|?]. -- replace 0 with (0*0) by intuition. - replace (m ^ 2) with ((-m)^2). - { apply Rle_ge ; apply Rmult_le_compat ; intuition ; - apply Rlt_le ; rewrite Rmult_1_r ; intuition. } - field. -- rewrite H' ; right ; field. -- left. intuition. -Qed. -(* end hide *) - -(* The following lemmas about PI should probably be in Rtrigo. *) - -Lemma PI2_lower_bound : forall x, 0 < x < 2 -> 0 < cos x -> x < PI/2. -Proof. -intros x [xp xlt2] cx. -destruct (Rtotal_order x (PI/2)) as [xltpi2 | [xeqpi2 | xgtpi2]]. -- assumption. -- now case (Rgt_not_eq _ _ cx); rewrite xeqpi2, cos_PI2. -- destruct (MVT_cor1 cos (PI/2) x derivable_cos xgtpi2) as - [c [Pc [cint1 cint2]]]. - revert Pc; rewrite cos_PI2, Rminus_0_r. - rewrite <- (pr_nu cos c (derivable_pt_cos c)), derive_pt_cos. - assert (0 < c < 2) by (split; assert (t := PI2_RGT_0); lra). - assert (0 < sin c) by now apply sin_pos_tech. - intros Pc. - case (Rlt_not_le _ _ cx). - rewrite <- (Rplus_0_l (cos x)), Pc, Ropp_mult_distr_l_reverse. - apply Rle_minus, Rmult_le_pos;[apply Rlt_le; assumption | lra ]. -Qed. - -Lemma PI2_3_2 : 3/2 < PI/2. -Proof. -apply PI2_lower_bound;[split; lra | ]. -destruct (pre_cos_bound (3/2) 1) as [t _]; [lra | lra | ]. -apply Rlt_le_trans with (2 := t); clear t. -unfold cos_approx; simpl; unfold cos_term. -rewrite !INR_IZR_INZ. -cbv -[IZR]. (* faster than simpl: 0.005s vs 0.2s *) -field_simplify. -apply Rdiv_lt_0_compat ; now apply IZR_lt. -Qed. - -Lemma PI2_1 : 1 < PI/2. -Proof. assert (t := PI2_3_2); lra. Qed. - -Lemma tan_increasing : forall x y, - -PI/2 < x -> x < y -> y < PI/2 -> - tan x < tan y. -Proof. -intros x y Z_le_x x_lt_y y_le_1. -assert (x_encad : -PI/2 < x < PI/2). -{ split ; [assumption | apply Rlt_trans with (r2:=y) ; assumption]. } -assert (y_encad : -PI/2 < y < PI/2). -{ split ; [apply Rlt_trans with (r2:=x) ; intuition | intuition ]. } -assert (local_derivable_pt_tan : forall x, -PI/2 < x < PI/2 -> - derivable_pt tan x). -{ intros ; apply derivable_pt_tan ; intuition. } -apply derive_increasing_interv with (a:=-PI/2) (b:=PI/2) (pr:=local_derivable_pt_tan) ; intuition. -{ lra. } -assert (Temp := pr_nu tan t (derivable_pt_tan t t_encad) (local_derivable_pt_tan t t_encad)) ; - rewrite <- Temp ; clear Temp. -assert (Temp := derive_pt_tan t t_encad) ; rewrite Temp ; clear Temp. -apply plus_Rsqr_gt_0. -Qed. - - -Lemma tan_inj : forall x y, - -PI/2 < x < PI/2 -> -PI/2 < y < PI/2 -> - tan x = tan y -> - x = y. -Proof. - intros a b a_encad b_encad fa_eq_fb. - destruct (total_order_T a b) as [[Hf|?]|Hf]. - - assert (Hfalse := tan_increasing a b (proj1 a_encad) Hf (proj2 b_encad)). - case (Rlt_not_eq (tan a) (tan b)) ; assumption. - - intuition. - - assert (Hfalse := tan_increasing b a (proj1 b_encad) Hf (proj2 a_encad)). - case (Rlt_not_eq (tan b) (tan a)) ; [|symmetry] ; assumption. -Qed. - -Notation tan_is_inj := tan_inj (only parsing). (* compat *) - -Lemma exists_atan_in_frame : forall lb ub y, - lb < ub -> -PI/2 < lb -> ub < PI/2 -> - tan lb < y < tan ub -> - {x | lb < x < ub /\ tan x = y}. -Proof. -intros lb ub y lb_lt_ub lb_cond ub_cond y_encad. -case y_encad ; intros y_encad1 y_encad2. -assert (f_cont : forall a : R, lb <= a <= ub -> continuity_pt tan a). -{ intros a a_encad. apply derivable_continuous_pt ; apply derivable_pt_tan. - split. - - apply Rlt_le_trans with (r2:=lb) ; intuition. - - apply Rle_lt_trans with (r2:=ub) ; intuition. } -assert (Cont : forall a : R, lb <= a <= ub -> continuity_pt (fun x => tan x - y) a). -{ intros a a_encad. unfold continuity_pt, continue_in, limit1_in, limit_in ; simpl ; unfold Rdist. - intros eps eps_pos. elim (f_cont a a_encad eps eps_pos). - intros alpha alpha_pos. destruct alpha_pos as (alpha_pos,Temp). - exists alpha. split. - { assumption. } - intros x x_cond. - replace (tan x - y - (tan a - y)) with (tan x - tan a) by field. - exact (Temp x x_cond). } -assert (H1 : (fun x => tan x - y) lb < 0). -{ apply Rlt_minus. assumption. } -assert (H2 : 0 < (fun x => tan x - y) ub). -{ apply Rgt_minus. assumption. } -destruct (IVT_interv (fun x => tan x - y) lb ub Cont lb_lt_ub H1 H2) as (x,Hx). -exists x. -destruct Hx as (Hyp,Result). -intuition. -- assert (Temp2 : x <> lb). - { intro Hfalse. rewrite Hfalse in Result. - assert (Temp2 : y <> tan lb) by (now apply Rgt_not_eq, Rlt_minus_0). - rewrite Result in H1. now apply (Rlt_irrefl 0). - } - now case H3; intros hyp; [assumption |]; rewrite hyp in Temp2. -- assert (Temp : x <> ub). - { intro Hfalse. rewrite Hfalse in Result. - assert (Temp2 : y <> tan ub). - { apply Rlt_not_eq ; assumption. } - clear - Temp2 Result. apply Temp2. - symmetry; intuition. } - case H4 ; intuition. -Qed. - -(*********************************************************) -(** * Definition of arctangent *) -(*********************************************************) - -(** ** Definition of arctangent as the reciprocal function of tangent and proof of this status *) - -Lemma tan_1_gt_1 : tan 1 > 1. -Proof. -assert (0 < cos 1) by (apply cos_gt_0; assert (t:=PI2_1); lra). -assert (t1 : cos 1 <= 1 - 1/2 + 1/24). -{ destruct (pre_cos_bound 1 0) as [_ t]; try lra; revert t. - unfold cos_approx, cos_term; simpl; intros t; apply Rle_trans with (1:=t). - clear t; apply Req_le; field. } -assert (t2 : 1 - 1/6 <= sin 1). -{ destruct (pre_sin_bound 1 0) as [t _]; try lra; revert t. - unfold sin_approx, sin_term; simpl; intros t; apply Rle_trans with (2:=t). - clear t; apply Req_le; field. } -pattern 1 at 2; replace 1 with - (cos 1 / cos 1) by (field; apply Rgt_not_eq; lra). -apply Rlt_gt; apply (Rmult_lt_compat_r (/ cos 1) (cos 1) (sin 1)). -{ apply Rinv_0_lt_compat; assumption. } -apply Rle_lt_trans with (1 := t1); apply Rlt_le_trans with (2 := t2). -lra. -Qed. - -Lemma sin_lt_x x : 0 < x -> sin x < x. -Proof. - intros. - pose proof PI2_1. - destruct (SIN_bound x), (Rle_or_lt x (PI / 2)); try lra. - pose (f x := x - sin x). - cut (f 0 < f x); [now unfold f; rewrite sin_0; lra|]. - eapply (MVT.derive_increasing_interv 0 (PI/2) (id - sin)%F); try lra. - intros t Ht. - rewrite derive_pt_minus, derive_pt_id, derive_pt_sin. - pose proof (COS_bound t). - pose proof cos_0. - pose proof (cos_inj 0 t). - lra. -Qed. - -Definition frame_tan y : {x | 0 < x < PI/2 /\ Rabs y < tan x}. -Proof. -destruct (total_order_T (Rabs y) 1) as [Hs|Hgt]. -{ assert (yle1 : Rabs y <= 1) by (destruct Hs; lra). - clear Hs; exists 1; split;[split; [exact Rlt_0_1 | exact PI2_1] | ]. - apply Rle_lt_trans with (1 := yle1); exact tan_1_gt_1. } -assert (0 < / (Rabs y + 1)). -{ apply Rinv_0_lt_compat; lra. } -set (u := /2 * / (Rabs y + 1)). -assert (0 < u). -{ apply Rmult_lt_0_compat; [lra | assumption]. } -assert (vlt1 : / (Rabs y + 1) < 1). -{ apply Rmult_lt_reg_r with (Rabs y + 1). - { assert (t := Rabs_pos y); lra. } - rewrite Rinv_l; [rewrite Rmult_1_l | apply Rgt_not_eq]; lra. } -assert (vlt2 : u < 1). -{ apply Rlt_trans with (/ (Rabs y + 1)). - { rewrite <-Rplus_half_diag. - assert (t : forall x, 0 < x -> x < x + x) by (clear; intros; lra). - unfold u; rewrite Rmult_comm; apply t. - unfold Rdiv; rewrite Rmult_comm; assumption. } - assumption. } -assert(int : 0 < PI / 2 - u < PI / 2). -{ split. - { assert (t := PI2_1); apply Rlt_0_minus, Rlt_trans with (2 := t); assumption. } - assert (dumb : forall x y, 0 < y -> x - y < x) by (clear; intros; lra). - apply dumb; clear dumb; assumption. } -exists (PI/2 - u). -assert (0 < sin u). -{ apply sin_gt_0;[ assumption | ]. - assert (t := PI2_Rlt_PI); assert (t' := PI2_1). - apply Rlt_trans with (2 := Rlt_trans _ _ _ t' t); assumption. } -split. -{ assumption. } -apply Rlt_trans with (/2 * / cos(PI / 2 - u)). -- rewrite cos_shift. - assert (sin u < u) by (apply sin_lt_x;assumption). - apply Rlt_trans with (Rabs y + 1);[lra | ]. - rewrite <- (Rinv_inv (Rabs y + 1)). - rewrite <- Rinv_mult. - apply Rinv_lt_contravar. - { apply Rmult_lt_0_compat. - { apply Rmult_lt_0_compat;[lra | assumption]. } - assumption. } - replace (/(Rabs y + 1)) with (2 * u). - { lra. } - unfold u; field; apply Rgt_not_eq; clear -Hgt; lra. -- unfold tan. - set (u' := PI / 2); unfold Rdiv; apply Rmult_lt_compat_r; unfold u'. - { apply Rinv_0_lt_compat. - rewrite cos_shift; assumption. } - assert (vlt3 : u < /4). - { replace (/4) with (/2 * /2) by field. - unfold u; apply Rmult_lt_compat_l;[lra | ]. - apply Rinv_lt_contravar;lra. } - assert (1 < PI / 2 - u) by (assert (t := PI2_3_2); lra). - apply Rlt_trans with (sin 1). - { assert (t' : 1 <= 4) by lra. - destruct (pre_sin_bound 1 0 (Rlt_le _ _ Rlt_0_1) t') as [t _]. - apply Rlt_le_trans with (2 := t); clear t. - simpl plus; replace (sin_approx 1 1) with (5/6);[lra | ]. - unfold sin_approx, sin_term; simpl; field. } - apply sin_increasing_1. - + assert (t := PI2_1); lra. - + apply Rlt_le, PI2_1. - + assert (t := PI2_1); lra. - + lra. - + assumption. -Qed. - -Lemma ub_opp : forall x, x < PI/2 -> -PI/2 < -x. -Proof. -intros x h; rewrite Rdiv_opp_l; apply Ropp_lt_contravar; assumption. -Qed. - -Lemma pos_opp_lt : forall x, 0 < x -> -x < x. -Proof. intros; lra. Qed. - -Lemma tech_opp_tan : forall x y, -tan x < y -> tan (-x) < y. -Proof. -intros; rewrite tan_neg; assumption. -Qed. - -Definition pre_atan (y : R) : {x : R | -PI/2 < x < PI/2 /\ tan x = y}. -Proof. -destruct (frame_tan y) as [ub [[ub0 ubpi2] Ptan_ub]]. -set (pr := (conj (tech_opp_tan _ _ (proj2 (Rabs_def2 _ _ Ptan_ub))) - (proj1 (Rabs_def2 _ _ Ptan_ub)))). -destruct (exists_atan_in_frame (-ub) ub y (pos_opp_lt _ ub0) (ub_opp _ ubpi2) - ubpi2 pr) as [v [[vl vu] vq]]. -exists v; clear pr. -split;[rewrite Rdiv_opp_l; split; lra | assumption]. -Qed. - -Definition atan x := let (v, _) := pre_atan x in v. - -Lemma atan_bound : forall x, - -PI/2 < atan x < PI/2. -Proof. -intros x; unfold atan; destruct (pre_atan x) as [v [int _]]; exact int. -Qed. - -Lemma tan_atan : forall x, - tan (atan x) = x. -Proof. -intros x; unfold atan; destruct (pre_atan x) as [v [_ q]]; exact q. -Qed. - -Notation atan_right_inv := tan_atan (only parsing). (* compat *) - -Lemma atan_opp : forall x, - atan (- x) = - atan x. -Proof. -intros x; generalize (atan_bound (-x)); rewrite Rdiv_opp_l;intros [a b]. -generalize (atan_bound x); rewrite Rdiv_opp_l; intros [c d]. -apply tan_inj; try rewrite Rdiv_opp_l; try split; try lra. -rewrite tan_neg, !tan_atan; reflexivity. -Qed. - -Lemma derivable_pt_atan : forall x, - derivable_pt atan x. -Proof. -intros x. -destruct (frame_tan x) as [ub [[ub0 ubpi] P]]. -assert (lb_lt_ub : -ub < ub) by apply pos_opp_lt, ub0. -assert (xint : tan(-ub) < x < tan ub). -{ assert (xint' : x < tan ub /\ -(tan ub) < x) by apply Rabs_def2, P. - rewrite tan_neg; tauto. } -assert (inv_p : forall x, tan(-ub) <= x -> x <= tan ub -> - comp tan atan x = id x). -{ intros; apply tan_atan. } -assert (int_tan : forall y, tan (- ub) <= y -> y <= tan ub -> - -ub <= atan y <= ub). -{ clear -ub0 ubpi; intros y lo up; split. - { destruct (Rle_lt_dec (-ub) (atan y)) as [h | abs]; auto. - assert (y < tan (-ub)). - { rewrite <- (tan_atan y); apply tan_increasing. - - destruct (atan_bound y); assumption. - - assumption. - - lra. } - lra. } - destruct (Rle_lt_dec (atan y) ub) as [h | abs]; auto. - assert (tan ub < y). - { rewrite <- (tan_atan y); apply tan_increasing. - - rewrite Rdiv_opp_l; lra. - - assumption. - - destruct (atan_bound y); assumption. } - lra. } -assert (incr : forall x y, -ub <= x -> x < y -> y <= ub -> tan x < tan y). -{ intros y z l yz u; apply tan_increasing. - - rewrite Rdiv_opp_l; lra. - - assumption. - - lra. } -assert (der : forall a, -ub <= a <= ub -> derivable_pt tan a). -{ intros a [la ua]; apply derivable_pt_tan. - rewrite Rdiv_opp_l; split; lra. } -assert (df_neq : derive_pt - tan (atan x) - (derivable_pt_recip_interv_prelim1 tan atan (- ub) ub x lb_lt_ub xint int_tan der) - <> 0). -{ rewrite <- (pr_nu tan (atan x) (derivable_pt_tan (atan x) (atan_bound x))). - rewrite derive_pt_tan. - solve[apply Rgt_not_eq, plus_Rsqr_gt_0]. } -apply (derivable_pt_recip_interv - tan atan (-ub) ub x - lb_lt_ub xint inv_p int_tan incr der). -exact df_neq. -Qed. - -Lemma atan_increasing : forall x y, - x < y -> atan x < atan y. -Proof. -intros x y d. -assert (t1 := atan_bound x). -assert (t2 := atan_bound y). -destruct (Rlt_le_dec (atan x) (atan y)) as [lt | bad]. -{ assumption. } -apply Rlt_not_le in d. -case d. -rewrite <- (tan_atan y), <- (tan_atan x). -destruct bad as [ylt | yx]. -{ apply Rlt_le, tan_increasing; try tauto. } -solve[rewrite yx; apply Rle_refl]. -Qed. - -Lemma atan_0 : atan 0 = 0. -Proof. -apply tan_inj; try (apply atan_bound). -{ assert (t := PI_RGT_0); rewrite Rdiv_opp_l; split; lra. } -rewrite tan_atan, tan_0. -reflexivity. -Qed. - -Lemma atan_eq0 : forall x, - atan x = 0 -> x = 0. -Proof. -intros x. -generalize (atan_increasing 0 x) (atan_increasing x 0). -rewrite atan_0. -lra. -Qed. - -Lemma atan_1 : atan 1 = PI/4. -Proof. -assert (ut := PI_RGT_0). -assert (-PI/2 < PI/4 < PI/2) by (rewrite Rdiv_opp_l; split; lra). -assert (t := atan_bound 1). -apply tan_inj; auto. -rewrite tan_PI4, tan_atan; reflexivity. -Qed. - -Lemma atan_tan : forall x, - (PI / 2) < x < PI / 2 -> - atan (tan x) = x. -Proof. -intros x xB. -apply tan_inj. -- now apply atan_bound. -- lra. -- now apply tan_atan. -Qed. - -Lemma atan_inv : forall x, (0 < x)%R -> - atan (/ x) = (PI / 2 - atan x)%R. -Proof. -intros x Hx. -apply tan_inj. -- apply atan_bound. -- split. - + apply Rlt_trans with R0. - * unfold Rdiv. - rewrite Ropp_mult_distr_l_reverse. - apply Ropp_lt_gt_0_contravar. - apply PI2_RGT_0. - * apply Rgt_minus. - apply atan_bound. - + apply Rplus_lt_reg_r with (atan x - PI / 2)%R. - ring_simplify. - rewrite <- atan_0. - now apply atan_increasing. -- rewrite tan_atan. - unfold tan. - rewrite sin_shift. - rewrite cos_shift. - rewrite <- Rinv_div. - apply f_equal, sym_eq, tan_atan. -Qed. - -(** ** Derivative of arctangent *) - -Lemma derive_pt_atan : forall x, - derive_pt atan x (derivable_pt_atan x) = 1 / (1 + xĀ²). -Proof. -intros x. -destruct (frame_tan x) as [ub [[ub0 ubpi] Pub]]. -assert (lb_lt_ub : -ub < ub) by apply pos_opp_lt, ub0. -assert (xint : tan(-ub) < x < tan ub). -{ assert (xint' : x < tan ub /\ -(tan ub) < x) by apply Rabs_def2, Pub. - rewrite tan_neg; tauto. } -assert (inv_p : forall x, tan(-ub) <= x -> x <= tan ub -> - comp tan atan x = id x). -{ intros; apply tan_atan. } -assert (int_tan : forall y, tan (- ub) <= y -> y <= tan ub -> - -ub <= atan y <= ub). -{ clear -ub0 ubpi; intros y lo up; split. - { destruct (Rle_lt_dec (-ub) (atan y)) as [h | abs]; auto. - assert (y < tan (-ub)). - { rewrite <- (tan_atan y); apply tan_increasing. - - destruct (atan_bound y); assumption. - - assumption. - - lra. } - lra. } - destruct (Rle_lt_dec (atan y) ub) as [h | abs]; auto. - assert (tan ub < y). - { rewrite <- (tan_atan y); apply tan_increasing. - - rewrite Rdiv_opp_l; lra. - - assumption. - - destruct (atan_bound y); assumption. } - lra. } -assert (incr : forall x y, -ub <= x -> x < y -> y <= ub -> tan x < tan y). -{ intros y z l yz u; apply tan_increasing. - - rewrite Rdiv_opp_l; lra. - - assumption. - - lra. } -assert (der : forall a, -ub <= a <= ub -> derivable_pt tan a). -{ intros a [la ua]; apply derivable_pt_tan. - rewrite Rdiv_opp_l; split; lra. } -assert (df_neq : derive_pt tan (atan x) - (derivable_pt_recip_interv_prelim1 - tan atan - (- ub) ub x lb_lt_ub xint int_tan der) <> 0). -{ rewrite <- (pr_nu tan (atan x) - (derivable_pt_tan (atan x) (atan_bound x))). - rewrite derive_pt_tan. - solve[apply Rgt_not_eq, plus_Rsqr_gt_0]. } -assert (t := derive_pt_recip_interv tan atan (-ub) ub x lb_lt_ub - xint incr int_tan der inv_p df_neq). -rewrite <- (pr_nu atan x (derivable_pt_recip_interv - tan atan (- ub) ub - x lb_lt_ub xint inv_p int_tan incr der df_neq)). -rewrite t. -assert (t' := atan_bound x). -rewrite <- (pr_nu tan (atan x) (derivable_pt_tan _ t')). -rewrite derive_pt_tan, tan_atan. -replace (Rsqr x) with (x ^ 2) by (unfold Rsqr; ring). -reflexivity. -Qed. - -Lemma derivable_pt_lim_atan : forall x, - derivable_pt_lim atan x (/ (1 + x^2)). -Proof. -intros x. -apply derive_pt_eq_1 with (derivable_pt_atan x). -replace (x ^ 2) with (x * x) by ring. -rewrite <- (Rmult_1_l (Rinv _)). -apply derive_pt_atan. -Qed. - -(** ** Definition of the arctangent function as the sum of the arctan power series *) - -(* Proof taken from Guillaume Melquiond's interval package for Coq *) - -Definition Ratan_seq x := fun n => (x ^ (2 * n + 1) / INR (2 * n + 1))%R. - -Lemma Ratan_seq_decreasing : forall x, (0 <= x <= 1)%R -> - Un_decreasing (Ratan_seq x). -Proof. -intros x Hx n. -unfold Ratan_seq, Rdiv. -apply Rmult_le_compat. -- apply pow_le. - exact (proj1 Hx). -- apply Rlt_le. - apply Rinv_0_lt_compat. - apply lt_INR_0. - lia. -- destruct (proj1 Hx) as [Hx1|Hx1]. - 1:destruct (proj2 Hx) as [Hx2|Hx2]. - + (* . 0 < x < 1 *) - rewrite <- (Rinv_inv x). - repeat rewrite (pow_inv (/ x)). - apply Rlt_le. - apply Rinv_lt_contravar. - { apply Rmult_lt_0_compat ; apply pow_lt ; auto with real. } - apply Rlt_pow. - { rewrite <- Rinv_1. - apply Rinv_lt_contravar. - { rewrite Rmult_1_r. - exact Hx1. } - exact Hx2. } - lia. - + (* . x = 1 *) - rewrite Hx2. - do 2 rewrite pow1. - apply Rle_refl. - + (* . x = 0 *) - rewrite <- Hx1. - do 2 (rewrite pow_i ; [ idtac | lia ]). - apply Rle_refl. -- apply Rlt_le. - apply Rinv_lt_contravar. - { apply Rmult_lt_0_compat ; apply lt_INR_0 ; lia. } - apply lt_INR. - lia. -Qed. - -Lemma Ratan_seq_converging : forall x, (0 <= x <= 1)%R -> - Un_cv (Ratan_seq x) 0. -Proof. -intros x Hx eps Heps. -destruct (archimed (/ eps)) as (HN,_). -assert (0 < up (/ eps))%Z. -{ apply lt_IZR. - apply Rlt_trans with (2 := HN). - apply Rinv_0_lt_compat. - exact Heps. } -case_eq (up (/ eps)) ; - intros ; rewrite H0 in H ; try discriminate H. -rewrite H0 in HN. -simpl in HN. -pose (N := Pos.to_nat p). -fold N in HN. -clear H H0. -exists N. -intros n Hn. -unfold Rdist. -rewrite Rminus_0_r. -unfold Ratan_seq. -rewrite Rabs_right. -2:{ apply Rle_ge. - unfold Rdiv. - apply Rmult_le_pos. - { apply pow_le. - exact (proj1 Hx). } - apply Rlt_le. - apply Rinv_0_lt_compat. - apply lt_INR_0. - lia. } -apply Rle_lt_trans with (1 ^ (2 * n + 1) / INR (2 * n + 1))%R. -{ unfold Rdiv. - apply Rmult_le_compat_r. - { apply Rlt_le. - apply Rinv_0_lt_compat. - apply lt_INR_0. - lia. } - apply pow_incr. - exact Hx. } -rewrite pow1. -apply Rle_lt_trans with (/ INR (2 * N + 1))%R. -{ unfold Rdiv. - rewrite Rmult_1_l. - apply Rinv_le_contravar. - { apply lt_INR_0. - lia. } - apply le_INR. - lia. } -rewrite <- (Rinv_inv eps). -apply Rinv_lt_contravar. -{ apply Rmult_lt_0_compat. - { auto with real. } - apply lt_INR_0. - lia. } -apply Rlt_trans with (INR N). -{ destruct (archimed (/ eps)) as (H,_). - assert (0 < up (/ eps))%Z. - { apply lt_IZR. - apply Rlt_trans with (2 := H). - apply Rinv_0_lt_compat. - exact Heps. } - unfold N. - rewrite INR_IZR_INZ, positive_nat_Z. - exact HN. } -apply lt_INR. -lia. -Qed. - -Definition ps_atan_exists_01 (x : R) (Hx:0 <= x <= 1) : - {l : R | Un_cv (fun N : nat => sum_f_R0 (tg_alt (Ratan_seq x)) N) l}. -Proof. -exact (alternated_series (Ratan_seq x) - (Ratan_seq_decreasing _ Hx) (Ratan_seq_converging _ Hx)). -Defined. - -Lemma Ratan_seq_opp : forall x n, - Ratan_seq (-x) n = -Ratan_seq x n. -Proof. -intros x n; unfold Ratan_seq. -rewrite !pow_add, !pow_mult, !pow_1. -unfold Rdiv; replace ((-x) ^ 2) with (x ^ 2) by ring; ring. -Qed. - -Lemma sum_Ratan_seq_opp : forall x n, - sum_f_R0 (tg_alt (Ratan_seq (- x))) n = - sum_f_R0 (tg_alt (Ratan_seq x)) n. -Proof. -intros x n; replace (-sum_f_R0 (tg_alt (Ratan_seq x)) n) with - (-1 * sum_f_R0 (tg_alt (Ratan_seq x)) n) by ring. -rewrite scal_sum; apply sum_eq; intros i _; unfold tg_alt. -rewrite Ratan_seq_opp; ring. -Qed. - -Definition ps_atan_exists_1 (x : R) (Hx : -1 <= x <= 1) : - {l : R | Un_cv (fun N : nat => sum_f_R0 (tg_alt (Ratan_seq x)) N) l}. -Proof. -destruct (Rle_lt_dec 0 x). -{ assert (pr : 0 <= x <= 1) by tauto. - exact (ps_atan_exists_01 x pr). } -assert (pr : 0 <= -x <= 1) by (destruct Hx; split; lra). -destruct (ps_atan_exists_01 _ pr) as [v Pv]. -exists (-v). -apply (Un_cv_ext (fun n => (- 1) * sum_f_R0 (tg_alt (Ratan_seq (- x))) n)). -{ intros n; rewrite sum_Ratan_seq_opp; ring. } -replace (-v) with (-1 * v) by ring. -apply CV_mult;[ | assumption]. -solve[intros; exists 0%nat; intros; rewrite Rdist_eq; auto]. -Qed. - -Definition in_int (x : R) : {-1 <= x <= 1}+{~ -1 <= x <= 1}. -Proof. -destruct (Rle_lt_dec x 1). -1:destruct (Rle_lt_dec (-1) x). -- left;split; auto. -- right;intros [a1 a2]; lra. -- right;intros [a1 a2]; lra. -Qed. - -Definition ps_atan (x : R) : R := - match in_int x with - left h => let (v, _) := ps_atan_exists_1 x h in v - | right h => atan x - end. - -(** ** Proof of the equivalence of the two definitions between -1 and 1 *) - -Lemma ps_atan0_0 : ps_atan 0 = 0. -Proof. -unfold ps_atan. -destruct (in_int 0) as [h1 | h2]. -{ destruct (ps_atan_exists_1 0 h1) as [v P]. - apply (UL_sequence _ _ _ P). - apply (Un_cv_ext (fun n => 0)). - { symmetry;apply sum_eq_R0. - intros i _; unfold tg_alt, Ratan_seq; rewrite Nat.add_comm; simpl. - unfold Rdiv; rewrite !Rmult_0_l, Rmult_0_r; reflexivity. } - intros eps ep; exists 0%nat; intros n _; unfold Rdist. - rewrite Rminus_0_r, Rabs_pos_eq; auto with real. } -case h2; split; lra. -Qed. - -Lemma ps_atan_exists_1_opp : forall x h h', - proj1_sig (ps_atan_exists_1 (-x) h) = -(proj1_sig (ps_atan_exists_1 x h')). -Proof. -intros x h h'; destruct (ps_atan_exists_1 (-x) h) as [v Pv]. -destruct (ps_atan_exists_1 x h') as [u Pu]; simpl. -assert (Pu' : Un_cv (fun N => (-1) * sum_f_R0 (tg_alt (Ratan_seq x)) N) (-1 * u)). -{ apply CV_mult;[ | assumption]. - intros eps ep; exists 0%nat; intros; rewrite Rdist_eq; assumption. } -assert (Pv' : Un_cv - (fun N : nat => -1 * sum_f_R0 (tg_alt (Ratan_seq x)) N) v). -{ apply Un_cv_ext with (2 := Pv); intros n; rewrite sum_Ratan_seq_opp; ring. } -replace (-u) with (-1 * u) by ring. -apply UL_sequence with (1:=Pv') (2:= Pu'). -Qed. - -Lemma ps_atan_opp : forall x, - ps_atan (-x) = -ps_atan x. -Proof. -intros x; unfold ps_atan. -destruct (in_int (- x)) as [inside | outside]. -{ destruct (in_int x) as [ins' | outs']. - { generalize (ps_atan_exists_1_opp x inside ins'). - intros h; exact h. } - destruct inside; case outs'; split; lra. } -destruct (in_int x) as [ins' | outs']. -{ destruct outside; case ins'; split; lra. } -apply atan_opp. -Qed. - -(** atan = ps_atan *) - -Lemma ps_atanSeq_continuity_pt_1 : forall (N : nat) (x : R), - 0 <= x -> x <= 1 -> - continuity_pt (fun x => sum_f_R0 (tg_alt (Ratan_seq x)) N) x. -Proof. - assert (Sublemma : forall (x:R) (N:nat), - sum_f_R0 (tg_alt (Ratan_seq x)) N - = x * (comp (fun x => sum_f_R0 (fun n => (fun i : nat => (-1) ^ i / INR (2 * i + 1)) n * x ^ n) N) - (fun x => x ^ 2) x)). -{ intros x N. - induction N. - { unfold tg_alt, Ratan_seq, comp ; simpl ; field. } - simpl sum_f_R0 at 1. - rewrite IHN. - replace (comp (fun x => sum_f_R0 (fun n : nat => (-1) ^ n / INR (2 * n + 1) * x ^ n) (S N)) (fun x => x ^ 2)) - with (comp (fun x => sum_f_R0 (fun n : nat => (-1) ^ n / INR (2 * n + 1) * x ^ n) N + (-1) ^ (S N) / INR (2 * (S N) + 1) * x ^ (S N)) (fun x => x ^ 2)) - by intuition. - unfold comp. - rewrite Rmult_plus_distr_l. - apply Rplus_eq_compat_l. - unfold tg_alt, Ratan_seq. - rewrite <- Rmult_assoc. - case (Req_dec x 0) ; intro Hyp. - { rewrite Hyp ; rewrite pow_i. - { rewrite Rmult_0_l ; rewrite Rmult_0_l. - unfold Rdiv ; rewrite Rmult_0_l ; rewrite Rmult_0_r ; reflexivity. } - intuition. } - replace (x * ((-1) ^ S N / INR (2 * S N + 1)) * (x ^ 2) ^ S N) with (x ^ (2 * S N + 1) * ((-1) ^ S N / INR (2 * S N + 1))). - { lra. } - rewrite Rmult_assoc. - replace (x * ((-1) ^ S N / INR (2 * S N + 1) * (x ^ 2) ^ S N)) with (((-1) ^ S N / INR (2 * S N + 1) * (x ^ 2) ^ S N) * x) by ring. - rewrite Rmult_assoc. - replace ((x ^ 2) ^ S N * x) with (x ^ (2 * S N + 1)). - { rewrite Rmult_comm at 1 ; reflexivity. } - rewrite <- pow_mult. - assert (Temp : forall x n, x ^ n * x = x ^ (n+1)). - { intros a n ; induction n. { rewrite pow_O. simpl ; intuition. } - simpl ; rewrite Rmult_assoc ; rewrite IHn ; intuition. } - rewrite Temp ; reflexivity. } -intros N x x_lb x_ub. -intros eps eps_pos. -assert (continuity_id : continuity id). -{ apply derivable_continuous ; exact derivable_id. } -assert (Temp := continuity_mult id - (comp - (fun x1 : R => sum_f_R0 (fun n : nat => (-1) ^ n / INR (2 * n + 1) * x1 ^ n) N) - (fun x1 : R => x1 ^ 2)) - continuity_id). -assert (Temp2 : continuity - (comp - (fun x1 : R => sum_f_R0 (fun n : nat => (-1) ^ n / INR (2 * n + 1) * x1 ^ n) N) - (fun x1 : R => x1 ^ 2))). -{ apply continuity_comp. - { reg. } - apply continuity_finite_sum. } -elim (Temp Temp2 x eps eps_pos) ; clear Temp Temp2 ; intros alpha T ; destruct T as (alpha_pos, T). -exists alpha ; split. -{ intuition. } -intros x0 x0_cond. -rewrite Sublemma ; rewrite Sublemma. -apply T. -intuition. -Qed. - -(** Definition of ps_atan's derivative *) - -Definition Datan_seq := fun (x : R) (n : nat) => x ^ (2*n). - -Lemma pow_lt_1_compat : forall x n, - 0 <= x < 1 -> (0 < n)%nat -> - 0 <= x ^ n < 1. -Proof. -intros x n hx; induction 1; simpl. -{ rewrite Rmult_1_r; tauto. } -split. -{ apply Rmult_le_pos; tauto. } -rewrite <- (Rmult_1_r 1); apply Rmult_le_0_lt_compat; intuition. -Qed. - -Lemma Datan_seq_Rabs : forall x n, - Datan_seq (Rabs x) n = Datan_seq x n. -Proof. -intros x n; unfold Datan_seq; rewrite !pow_mult, pow2_abs; reflexivity. -Qed. - -Lemma Datan_seq_pos : forall x n, 0 < x -> - 0 < Datan_seq x n. -Proof. -intros x n x_lb ; unfold Datan_seq ; induction n. -{ simpl ; intuition. } -replace (x ^ (2 * S n)) with ((x ^ 2) * (x ^ (2 * n))). -{ apply Rmult_gt_0_compat. - { replace (x^2) with (x*x) by field ; apply Rmult_gt_0_compat ; assumption. } - assumption. } -replace (2 * S n)%nat with (S (S (2 * n))) by lia. -simpl ; field. -Qed. - -Lemma Datan_sum_eq :forall x n, - sum_f_R0 (tg_alt (Datan_seq x)) n = (1 - (- x ^ 2) ^ S n)/(1 + x ^ 2). -Proof. -intros x n. -assert (dif : - x ^ 2 <> 1). -{ nra. } -replace (1 + x ^ 2) with (1 - - (x ^ 2)) by ring; rewrite <- (tech3 _ n dif). -apply sum_eq; unfold tg_alt, Datan_seq; intros i _. -rewrite pow_mult, <- Rpow_mult_distr. -f_equal. -ring. -Qed. - -Lemma Datan_seq_increasing : forall x y n, - (n > 0)%nat -> 0 <= x < y -> - Datan_seq x n < Datan_seq y n. -Proof. -intros x y n n_lb x_encad ; assert (x_pos : x >= 0) by intuition. -assert (y_pos : y > 0). { apply Rle_lt_trans with (r2:=x) ; intuition. } -induction n. { lia. } -clear -x_encad x_pos y_pos ; induction n ; unfold Datan_seq. -{ case x_pos ; clear x_pos ; intro x_pos. - { simpl ; apply Rmult_gt_0_lt_compat ; intuition. lra. } - rewrite x_pos ; rewrite pow_i. - { replace (y ^ (2*1)) with (y*y). - { apply Rmult_gt_0_compat ; assumption. } - simpl ; field. } - intuition. } -assert (Hrew : forall a, a^(2 * S (S n)) = (a ^ 2) * (a ^ (2 * S n))). -{ clear ; intro a ; replace (2 * S (S n))%nat with (S (S (2 * S n)))%nat by lia. - simpl ; field. } -case x_pos ; clear x_pos ; intro x_pos. -{ rewrite Hrew ; rewrite Hrew. - apply Rmult_gt_0_lt_compat ; intuition. - apply Rmult_gt_0_lt_compat ; intuition ; lra. } -rewrite x_pos. -rewrite pow_i. { intuition. } lia. -Qed. - -Lemma Datan_seq_decreasing : forall x, -1 < x -> x < 1 -> - Un_decreasing (Datan_seq x). -Proof. -intros x x_lb x_ub n. -unfold Datan_seq. -replace (2 * S n)%nat with (2 + 2 * n)%nat by ring. -rewrite <- (Rmult_1_l (x ^ (2 * n))). -rewrite pow_add. -apply Rmult_le_compat_r. -{ rewrite pow_mult; apply pow_le, pow2_ge_0. } -apply Rlt_le; rewrite <- pow2_abs. -assert (intabs : 0 <= Rabs x < 1). -{ split;[apply Rabs_pos | apply Rabs_def1]; tauto. } -apply (pow_lt_1_compat (Rabs x) 2) in intabs. -{ tauto. } -lia. -Qed. - -Lemma Datan_seq_CV_0 : forall x, -1 < x -> x < 1 -> - Un_cv (Datan_seq x) 0. -Proof. -intros x x_lb x_ub eps eps_pos. -assert (x_ub2 : Rabs (x^2) < 1). -{ rewrite Rabs_pos_eq;[ | apply pow2_ge_0]. - rewrite <- pow2_abs. - assert (H: 0 <= Rabs x < 1) - by (split;[apply Rabs_pos | apply Rabs_def1; auto]). - apply (pow_lt_1_compat _ 2) in H;[tauto | lia]. } -elim (pow_lt_1_zero (x^2) x_ub2 eps eps_pos) ; intros N HN ; exists N ; intros n Hn. -unfold Rdist, Datan_seq. -replace (x ^ (2 * n) - 0) with ((x ^ 2) ^ n). { apply HN ; assumption. } -rewrite pow_mult ; field. -Qed. - -Lemma Datan_lim : forall x, -1 < x -> x < 1 -> - Un_cv (fun N : nat => sum_f_R0 (tg_alt (Datan_seq x)) N) (/ (1 + x ^ 2)). -Proof. -intros x x_lb x_ub eps eps_pos. -assert (Tool0 : 0 <= x ^ 2) by apply pow2_ge_0. -assert (Tool1 : 0 < (1 + x ^ 2)). -{ solve[apply Rplus_lt_le_0_compat ; intuition]. } -assert (Tool2 : / (1 + x ^ 2) > 0). -{ apply Rinv_0_lt_compat ; tauto. } -assert (x_ub2' : 0<= Rabs (x^2) < 1). -{ rewrite Rabs_pos_eq, <- pow2_abs;[ | apply pow2_ge_0]. - apply pow_lt_1_compat;[split;[apply Rabs_pos | ] | lia]. - apply Rabs_def1; assumption. } -assert (x_ub2 : Rabs (x^2) < 1) by tauto. -assert (eps'_pos : ((1 + x^2)*eps) > 0). -{ apply Rmult_gt_0_compat ; assumption. } -elim (pow_lt_1_zero _ x_ub2 _ eps'_pos) ; intros N HN ; exists N. -intros n Hn. -assert (H1 : - x^2 <> 1). -{ apply Rlt_not_eq; apply Rle_lt_trans with (2 := Rlt_0_1). - assert (t := pow2_ge_0 x); lra. } -rewrite Datan_sum_eq. -unfold Rdist. -assert (tool : forall a b, a / b - /b = (-1 + a) /b). -{ intros a b; rewrite <- (Rmult_1_l (/b)); unfold Rdiv, Rminus. - rewrite <- Ropp_mult_distr_l_reverse, Rmult_plus_distr_r, Rplus_comm. - reflexivity. } -set (u := 1 + x ^ 2); rewrite tool; unfold Rminus; rewrite <- Rplus_assoc. -unfold Rdiv, u. -change (-1) with (-(1)). -rewrite Rplus_opp_l, Rplus_0_l, Ropp_mult_distr_l_reverse, Rabs_Ropp. -rewrite Rabs_mult; clear tool u. -assert (tool : forall k, Rabs ((-x ^ 2) ^ k) = Rabs ((x ^ 2) ^ k)). -{ clear -Tool0; induction k;[simpl; rewrite Rabs_R1;tauto | ]. - rewrite <- !(tech_pow_Rmult _ k), !Rabs_mult, Rabs_Ropp, IHk, Rabs_pos_eq. - { reflexivity. } - exact Tool0. } -rewrite tool, (Rabs_pos_eq (/ _)); clear tool;[ | apply Rlt_le; assumption]. -assert (tool : forall a b c, 0 < b -> a < b * c -> a * / b < c). -{ intros a b c bp h; replace c with (b * c * /b). - { apply Rmult_lt_compat_r. - { apply Rinv_0_lt_compat; assumption. } - assumption. } - field; apply Rgt_not_eq; exact bp. } -apply tool;[exact Tool1 | ]. -apply HN; lia. -Qed. - -Lemma Datan_CVU_prelim : forall c (r : posreal), Rabs c + r < 1 -> - CVU (fun N x => sum_f_R0 (tg_alt (Datan_seq x)) N) - (fun y : R => / (1 + y ^ 2)) c r. -Proof. -intros c r ub_ub eps eps_pos. -apply (Alt_CVU (fun x n => Datan_seq n x) - (fun x => /(1 + x ^ 2)) - (Datan_seq (Rabs c + r)) c r). -- intros x inb; apply Datan_seq_decreasing; - apply Boule_lt in inb; apply Rabs_def2 in inb; - destruct inb; lra. -- intros x inb; apply Datan_seq_CV_0; - apply Boule_lt in inb; apply Rabs_def2 in inb; - destruct inb; lra. -- intros x inb; apply (Datan_lim x); - apply Boule_lt in inb; apply Rabs_def2 in inb; - destruct inb; lra. -- intros x [ | n] inb. - { solve[unfold Datan_seq; apply Rle_refl]. } - rewrite <- (Datan_seq_Rabs x); apply Rlt_le, Datan_seq_increasing. - { lia. } - apply Boule_lt in inb; intuition. - solve[apply Rabs_pos]. -- apply Datan_seq_CV_0. - { apply Rlt_trans with 0;[lra | ]. - apply Rplus_le_lt_0_compat. - { solve[apply Rabs_pos]. } - destruct r; assumption. } - assumption. -- assumption. -Qed. - -Lemma Datan_is_datan : forall (N : nat) (x : R), - -1 <= x -> x < 1 -> - derivable_pt_lim (fun x => sum_f_R0 (tg_alt (Ratan_seq x)) N) x (sum_f_R0 (tg_alt (Datan_seq x)) N). -Proof. -assert (Tool : forall N, (-1) ^ (S (2 * N)) = - 1). -{ intro n ; induction n. - { simpl ; field. } - replace ((-1) ^ S (2 * S n)) with ((-1) ^ 2 * (-1) ^ S (2*n)). - { rewrite IHn ; field. } - rewrite <- pow_add. - replace (2 + S (2 * n))%nat with (S (2 * S n))%nat. - { reflexivity. } - lia. } -intros N x x_lb x_ub. -induction N. -{ unfold Datan_seq, Ratan_seq, tg_alt ; simpl. - intros eps eps_pos. - elim (derivable_pt_lim_id x eps eps_pos) ; intros delta Hdelta ; exists delta. - intros h hneq h_b. - replace (1 * ((x + h) * 1 / 1) - 1 * (x * 1 / 1)) with (id (x + h) - id x). - { rewrite Rmult_1_r. - apply Hdelta ; assumption. } - unfold id ; field ; assumption. } -intros eps eps_pos. -assert (eps_3_pos : (eps/3) > 0) by lra. -elim (IHN (eps/3) eps_3_pos) ; intros delta1 Hdelta1. -assert (Main : derivable_pt_lim (fun x =>tg_alt (Ratan_seq x) (S N)) x ((tg_alt (Datan_seq x)) (S N))). -{ clear -Tool ; intros eps' eps'_pos. - elim (derivable_pt_lim_pow x (2 * (S N) + 1) eps' eps'_pos) ; intros delta Hdelta ; exists delta. - intros h h_neq h_b ; unfold tg_alt, Ratan_seq, Datan_seq. - replace (((-1) ^ S N * ((x + h) ^ (2 * S N + 1) / INR (2 * S N + 1)) - - (-1) ^ S N * (x ^ (2 * S N + 1) / INR (2 * S N + 1))) / h - - (-1) ^ S N * x ^ (2 * S N)) - with (((-1)^(S N)) * ((((x + h) ^ (2 * S N + 1) / INR (2 * S N + 1)) - - (x ^ (2 * S N + 1) / INR (2 * S N + 1))) / h - x ^ (2 * S N))) - by (field ; split ; [apply Rgt_not_eq |] ; intuition). - rewrite Rabs_mult ; rewrite pow_1_abs ; rewrite Rmult_1_l. - replace (((x + h) ^ (2 * S N + 1) / INR (2 * S N + 1) - - x ^ (2 * S N + 1) / INR (2 * S N + 1)) / h - x ^ (2 * S N)) - with ((/INR (2* S N + 1)) * (((x + h) ^ (2 * S N + 1) - x ^ (2 * S N + 1)) / h - - INR (2 * S N + 1) * x ^ pred (2 * S N + 1))). - { rewrite Rabs_mult. - case (Req_dec (((x + h) ^ (2 * S N + 1) - x ^ (2 * S N + 1)) / h - - INR (2 * S N + 1) * x ^ pred (2 * S N + 1)) 0) ; intro Heq. - { rewrite Heq ; rewrite Rabs_R0 ; rewrite Rmult_0_r ; assumption. } - apply Rlt_trans with (r2:=Rabs - (((x + h) ^ (2 * S N + 1) - x ^ (2 * S N + 1)) / h - - INR (2 * S N + 1) * x ^ pred (2 * S N + 1))). - 2:{ apply Hdelta; assumption. } - rewrite <- Rmult_1_l ; apply Rmult_lt_compat_r. - { apply Rabs_pos_lt ; assumption. } - rewrite Rabs_right. - { replace 1 with (/1) by field. - apply Rinv_0_lt_contravar. { lra. } apply lt_1_INR; lia. } - apply Rgt_ge ; replace (INR (2 * S N + 1)) with (INR (2*S N) + 1) ; - [apply RiemannInt.RinvN_pos | ]. - replace (2 * S N + 1)%nat with (S (2 * S N))%nat by lia. - rewrite S_INR ; reflexivity. } - rewrite Rmult_minus_distr_l. - replace (/ INR (2 * S N + 1) * (INR (2 * S N + 1) * x ^ pred (2 * S N + 1))) with (x ^ (2 * S N)). - 2:{ clear ; replace (pred (2 * S N + 1)) with (2 * S N)%nat by lia. - field ; apply Rgt_not_eq ; intuition. } - unfold Rminus ; rewrite Rplus_comm. - replace (((x + h) ^ (2 * S N + 1) / INR (2 * S N + 1) + - - (x ^ (2 * S N + 1) / INR (2 * S N + 1))) / h + - x ^ (2 * S N)) - with (- x ^ (2 * S N) + (((x + h) ^ (2 * S N + 1) / INR (2 * S N + 1) + - - (x ^ (2 * S N + 1) / INR (2 * S N + 1))) / h)) - by intuition. - apply Rplus_eq_compat_l. field. - split ; [apply Rgt_not_eq|] ; intuition. } -elim (Main (eps/3) eps_3_pos) ; intros delta2 Hdelta2. -destruct delta1 as (delta1, delta1_pos) ; destruct delta2 as (delta2, delta2_pos). -pose (mydelta := Rmin delta1 delta2). -assert (mydelta_pos : mydelta > 0). -{ unfold mydelta ; rewrite Rmin_Rgt ; split ; assumption. } -pose (delta := mkposreal mydelta mydelta_pos) ; exists delta ; intros h h_neq h_b. -clear Main IHN. -unfold Rminus at 1. -apply Rle_lt_trans with (r2:=eps/3 + eps / 3). -{ assert (Temp : (sum_f_R0 (tg_alt (Ratan_seq (x + h))) (S N) - - sum_f_R0 (tg_alt (Ratan_seq x)) (S N)) / h + - - sum_f_R0 (tg_alt (Datan_seq x)) (S N) - = ((sum_f_R0 (tg_alt (Ratan_seq (x + h))) N - - sum_f_R0 (tg_alt (Ratan_seq x)) N) / h) + - (- sum_f_R0 (tg_alt (Datan_seq x)) N) + - ((tg_alt (Ratan_seq (x + h)) (S N) - tg_alt (Ratan_seq x) (S N)) - / h - tg_alt (Datan_seq x) (S N))). - { simpl ; field ; intuition. } - apply Rle_trans with (r2:= Rabs ((sum_f_R0 (tg_alt (Ratan_seq (x + h))) N - - sum_f_R0 (tg_alt (Ratan_seq x)) N) / h + - - sum_f_R0 (tg_alt (Datan_seq x)) N) + - Rabs ((tg_alt (Ratan_seq (x + h)) (S N) - tg_alt (Ratan_seq x) (S N)) - / h - tg_alt (Datan_seq x) (S N))). - { rewrite Temp ; clear Temp ; apply Rabs_triang. } - apply Rplus_le_compat ; apply Rlt_le ; [apply Hdelta1 | apply Hdelta2] ; - intuition ; apply Rlt_le_trans with (r2:=delta) ; intuition unfold delta, mydelta. - { apply Rmin_l. } - apply Rmin_r. } -lra. -Qed. - -Lemma Ratan_CVU' : - CVU (fun N x => sum_f_R0 (tg_alt (Ratan_seq x)) N) - ps_atan (/2) posreal_half. -Proof. -apply (Alt_CVU (fun i r => Ratan_seq r i) ps_atan PI_tg (/2) posreal_half); - lazy beta. -- now intros; apply Ratan_seq_decreasing, Boule_half_to_interval. -- now intros; apply Ratan_seq_converging, Boule_half_to_interval. -- intros x b; apply Boule_half_to_interval in b. - unfold ps_atan; destruct (in_int x) as [inside | outside]; - [ | destruct b; case outside; split; lra]. - destruct (ps_atan_exists_1 x inside) as [v Pv]. - apply Un_cv_ext with (2 := Pv);[reflexivity]. -- intros x n b; apply Boule_half_to_interval in b. - rewrite <- (Rmult_1_l (PI_tg n)); unfold Ratan_seq, PI_tg. - apply Rmult_le_compat_r. - { apply Rlt_le, Rinv_0_lt_compat, (lt_INR 0); lia. } - rewrite <- (pow1 (2 * n + 1)); apply pow_incr; assumption. -- exact PI_tg_cv. -Qed. - -Lemma Ratan_CVU : - CVU (fun N x => sum_f_R0 (tg_alt (Ratan_seq x)) N) - ps_atan 0 (mkposreal 1 Rlt_0_1). -Proof. -intros eps ep; destruct (Ratan_CVU' eps ep) as [N Pn]. -exists N; intros n x nN b_y. -case (Rtotal_order 0 x) as [xgt0 | [x0 | x0]]. -- assert (Boule (/2) posreal_half x). - { revert b_y; unfold Boule; simpl; intros b_y; apply Rabs_def2 in b_y. - destruct b_y; unfold Boule; simpl; apply Rabs_def1; lra. } - apply Pn; assumption. -- rewrite <- x0, ps_atan0_0. - rewrite <- (sum_eq (fun _ => 0)), sum_cte, Rmult_0_l, Rminus_0_r, Rabs_pos_eq. - + assumption. - + apply Rle_refl. - + intros i _; unfold tg_alt, Ratan_seq, Rdiv; rewrite Nat.add_comm; simpl. - solve[rewrite !Rmult_0_l, Rmult_0_r; auto]. -- replace (ps_atan x - sum_f_R0 (tg_alt (Ratan_seq x)) n) with - (-(ps_atan (-x) - sum_f_R0 (tg_alt (Ratan_seq (-x))) n)). - { rewrite Rabs_Ropp. - assert (Boule (/2) posreal_half (-x)). - { revert b_y; unfold Boule; simpl; intros b_y; apply Rabs_def2 in b_y. - destruct b_y; unfold Boule; simpl; apply Rabs_def1; lra. } - apply Pn; assumption. } - unfold Rminus; rewrite ps_atan_opp, Ropp_plus_distr, sum_Ratan_seq_opp. - rewrite !Ropp_involutive; reflexivity. -Qed. - -Lemma Alt_PI_tg : forall n, PI_tg n = Ratan_seq 1 n. -Proof. -intros n; unfold PI_tg, Ratan_seq, Rdiv; rewrite pow1, Rmult_1_l. -reflexivity. -Qed. - -Lemma Ratan_is_ps_atan : forall eps, eps > 0 -> - exists N, forall n, (n >= N)%nat -> forall x, -1 < x -> x < 1 -> - Rabs (sum_f_R0 (tg_alt (Ratan_seq x)) n - ps_atan x) < eps. -Proof. -intros eps ep. -destruct (Ratan_CVU _ ep) as [N1 PN1]. -exists N1; intros n nN x xm1 x1; rewrite <- Rabs_Ropp, Ropp_minus_distr. -apply PN1; [assumption | ]. -unfold Boule; simpl; rewrite Rminus_0_r; apply Rabs_def1; assumption. -Qed. - -Lemma Datan_continuity : continuity (fun x => /(1 + x^2)). -Proof. -apply continuity_inv. -{ apply continuity_plus. - { apply continuity_const ; unfold constant ; intuition. } - apply derivable_continuous ; apply derivable_pow. } -intro x ; apply Rgt_not_eq ; apply Rge_gt_trans with (1+0) ; [|lra] ; - apply Rplus_ge_compat_l. -replace (x^2) with (xĀ²). -{ apply Rle_ge ; apply Rle_0_sqr. } -unfold Rsqr ; field. -Qed. - -Lemma derivable_pt_lim_ps_atan : forall x, -1 < x < 1 -> - derivable_pt_lim ps_atan x ((fun y => /(1 + y ^ 2)) x). -Proof. -intros x x_encad. -destruct (boule_in_interval (-1) 1 x x_encad) as [c [r [Pcr1 [P1 P2]]]]. -change (/ (1 + x ^ 2)) with ((fun u => /(1 + u ^ 2)) x). -assert (t := derivable_pt_lim_CVU). -apply derivable_pt_lim_CVU with - (fn := (fun N x => sum_f_R0 (tg_alt (Ratan_seq x)) N)) - (fn' := (fun N x => sum_f_R0 (tg_alt (Datan_seq x)) N)) - (c := c) (r := r). -- assumption. -- intros y N inb; apply Rabs_def2 in inb; destruct inb. - apply Datan_is_datan. - { lra. } - lra. -- intros y inb; apply Rabs_def2 in inb; destruct inb. - assert (y_gt_0 : -1 < y) by lra. - assert (y_lt_1 : y < 1) by lra. - intros eps eps_pos ; elim (Ratan_is_ps_atan eps eps_pos). - intros N HN ; exists N; intros n n_lb ; apply HN ; tauto. -- apply Datan_CVU_prelim. - replace ((c - r + (c + r)) / 2) with c by field. - unfold mkposreal_lb_ub; simpl. - replace ((c + r - (c - r)) / 2) with (r :R) by field. - assert (Rabs c < 1 - r). - { unfold Boule in Pcr1; destruct r; simpl in *; apply Rabs_def1; - apply Rabs_def2 in Pcr1; destruct Pcr1; lra. } - lra. -- intros; apply Datan_continuity. -Qed. - -Lemma derivable_pt_ps_atan : forall x, -1 < x < 1 -> - derivable_pt ps_atan x. -Proof. -intros x x_encad. -exists (/(1 + x^2)) ; apply derivable_pt_lim_ps_atan; assumption. -Qed. - -Lemma ps_atan_continuity_pt_1 : forall eps : R, - eps > 0 -> - exists alp : R, alp > 0 /\ (forall x, x < 1 -> 0 < x -> Rdist x 1 < alp -> - dist R_met (ps_atan x) (Alt_PI/4) < eps). -Proof. -intros eps eps_pos. -assert (eps_3_pos : eps / 3 > 0) by lra. -elim (Ratan_is_ps_atan (eps / 3) eps_3_pos) ; intros N1 HN1. -unfold Alt_PI. -destruct exist_PI as [v Pv]; replace ((4 * v)/4) with v by field. -assert (Pv' : Un_cv (sum_f_R0 (tg_alt (Ratan_seq 1))) v). -{ apply Un_cv_ext with (2:= Pv). - intros; apply sum_eq; intros; unfold tg_alt; rewrite Alt_PI_tg; tauto. } -destruct (Pv' (eps / 3) eps_3_pos) as [N2 HN2]. -set (N := (N1 + N2)%nat). -assert (O_lb : 0 <= 1) by intuition ; assert (O_ub : 1 <= 1) by intuition ; - elim (ps_atanSeq_continuity_pt_1 N 1 O_lb O_ub (eps / 3) eps_3_pos) ; intros alpha Halpha ; - clear -HN1 HN2 Halpha eps_3_pos; destruct Halpha as (alpha_pos, Halpha). -exists alpha ; split;[assumption | ]. -intros x x_ub x_lb x_bounds. -simpl ; unfold Rdist. -replace (ps_atan x - v) with - ((ps_atan x - sum_f_R0 (tg_alt (Ratan_seq x)) N) - + (sum_f_R0 (tg_alt (Ratan_seq x)) N - sum_f_R0 (tg_alt (Ratan_seq 1)) N) - + (sum_f_R0 (tg_alt (Ratan_seq 1)) N - v)) - by ring. -apply Rle_lt_trans with - (r2:=Rabs (ps_atan x - sum_f_R0 (tg_alt (Ratan_seq x)) N) + - Rabs ((sum_f_R0 (tg_alt (Ratan_seq x)) N - sum_f_R0 (tg_alt (Ratan_seq 1)) N) + - (sum_f_R0 (tg_alt (Ratan_seq 1)) N - v))). -{ rewrite Rplus_assoc ; apply Rabs_triang. } -replace eps with (2 / 3 * eps + eps / 3) by field. -rewrite Rplus_comm. -apply Rplus_lt_compat. -{ apply Rle_lt_trans with - (r2 := Rabs (sum_f_R0 (tg_alt (Ratan_seq x)) N - sum_f_R0 (tg_alt (Ratan_seq 1)) N) + - Rabs (sum_f_R0 (tg_alt (Ratan_seq 1)) N - v)). - { apply Rabs_triang. } - apply Rlt_le_trans with (r2:= eps / 3 + eps / 3). - { apply Rplus_lt_compat. - { simpl in Halpha ; unfold Rdist in Halpha. - apply Halpha ; split. - { unfold D_x, no_cond ; split ; [ | apply Rgt_not_eq ] ; intuition. } - intuition. } - apply HN2; unfold N; lia. } - lra. } -rewrite <- Rabs_Ropp, Ropp_minus_distr; apply HN1. -- unfold N; lia. -- lra. -- assumption. -Qed. - -Lemma Datan_eq_DatanSeq_interv : forall x, -1 < x < 1 -> - forall (Pratan:derivable_pt ps_atan x) (Prmymeta:derivable_pt atan x), - derive_pt ps_atan x Pratan = derive_pt atan x Prmymeta. -Proof. -assert (freq : 0 < tan 1) by apply (Rlt_trans _ _ _ Rlt_0_1 tan_1_gt_1). -intros x x_encad Pratan Prmymeta. -rewrite pr_nu_var2_interv with - (g:=ps_atan) (lb:=-1) (ub:=tan 1) - (pr2 := derivable_pt_ps_atan x x_encad). -- rewrite pr_nu_var2_interv with (f:=atan) (g:=atan) (lb:=-1) (ub:= 1) (pr2:=derivable_pt_atan x). - + assert (Temp := derivable_pt_lim_ps_atan x x_encad). - assert (Hrew1 : derive_pt ps_atan x (derivable_pt_ps_atan x x_encad) = (/(1 + x^2))). - { apply derive_pt_eq_0 ; assumption. } - rewrite derive_pt_atan. - rewrite Hrew1. - replace (Rsqr x) with (x ^ 2) by (unfold Rsqr; ring). - unfold Rdiv; rewrite Rmult_1_l; reflexivity. - + lra. - + assumption. - + intros; reflexivity. -- lra. -- assert (t := tan_1_gt_1); split;destruct x_encad; lra. -- intros; reflexivity. -Qed. - -Lemma atan_eq_ps_atan : forall x, 0 < x < 1 -> - atan x = ps_atan x. -Proof. -intros x x_encad. -assert (pr1 : forall c : R, 0 < c < x -> derivable_pt (atan - ps_atan) c). -{ intros c c_encad. - apply derivable_pt_minus. - { exact (derivable_pt_atan c). } - apply derivable_pt_ps_atan. - destruct x_encad; destruct c_encad; split; lra. } -assert (pr2 : forall c : R, 0 < c < x -> derivable_pt id c). -{ intros ; apply derivable_pt_id; lra. } -assert (delta_cont : forall c : R, 0 <= c <= x -> continuity_pt (atan - ps_atan) c). -{ intros c [[c_encad1 | c_encad1 ] [c_encad2 | c_encad2]]; - apply continuity_pt_minus. - - apply derivable_continuous_pt ; apply derivable_pt_atan. - - apply derivable_continuous_pt ; apply derivable_pt_ps_atan. - split; destruct x_encad; lra. - - apply derivable_continuous_pt, derivable_pt_atan. - - apply derivable_continuous_pt, derivable_pt_ps_atan. - subst c; destruct x_encad; split; lra. - - apply derivable_continuous_pt, derivable_pt_atan. - - apply derivable_continuous_pt, derivable_pt_ps_atan. - subst c; split; lra. - - apply derivable_continuous_pt, derivable_pt_atan. - - apply derivable_continuous_pt, derivable_pt_ps_atan. - subst c; destruct x_encad; split; lra. } -assert (id_cont : forall c : R, 0 <= c <= x -> continuity_pt id c). -{ intros ; apply derivable_continuous ; apply derivable_id. } -assert (x_lb : 0 < x) by (destruct x_encad; lra). -elim (MVT (atan - ps_atan)%F id 0 x pr1 pr2 x_lb delta_cont id_cont) ; intros d Temp ; elim Temp ; intros d_encad Main. -clear - Main x_encad. -assert (Temp : forall (pr: derivable_pt (atan - ps_atan) d), derive_pt (atan - ps_atan) d pr = 0). -{ intro pr. - assert (d_encad3 : -1 < d < 1). - { destruct d_encad; destruct x_encad; split; lra. } - pose (pr3 := derivable_pt_minus atan ps_atan d (derivable_pt_atan d) (derivable_pt_ps_atan d d_encad3)). - rewrite <- pr_nu_var2_interv with (f:=(atan - ps_atan)%F) (g:=(atan - ps_atan)%F) (lb:=0) (ub:=x) (pr1:=pr3) (pr2:=pr). - - unfold pr3. rewrite derive_pt_minus. - rewrite Datan_eq_DatanSeq_interv with (Prmymeta := derivable_pt_atan d). - { intuition. } - assumption. - - destruct d_encad; lra. - - assumption. - - reflexivity. } -assert (iatan0 : atan 0 = 0). -{ apply tan_inj. - - apply atan_bound. - - rewrite Rdiv_opp_l; assert (t := PI2_RGT_0); split; lra. - - rewrite tan_0, tan_atan; reflexivity. } -generalize Main; rewrite Temp, Rmult_0_r. -replace ((atan - ps_atan)%F x) with (atan x - ps_atan x) by intuition. -replace ((atan - ps_atan)%F 0) with (atan 0 - ps_atan 0) by intuition. -rewrite iatan0, ps_atan0_0, !Rminus_0_r. -replace (derive_pt id d (pr2 d d_encad)) with 1. -{ rewrite Rmult_1_r. - solve[intros M; apply Rminus_diag_uniq; auto]. } -rewrite pr_nu_var with (g:=id) (pr2:=derivable_pt_id d). -{ symmetry ; apply derive_pt_id. } -tauto. -Qed. - -Theorem Alt_PI_eq : Alt_PI = PI. -Proof. -apply Rmult_eq_reg_r with (/4); fold (Alt_PI/4); fold (PI/4); - [ | apply Rgt_not_eq; lra]. -assert (0 < PI/6) by (apply PI6_RGT_0). -assert (t1:= PI2_1). -assert (t2 := PI_4). -assert (m := Alt_PI_RGT_0). -assert (-PI/2 < 1 < PI/2) by (rewrite Rdiv_opp_l; split; lra). -apply cond_eq; intros eps ep. -change (Rdist (Alt_PI/4) (PI/4) < eps). -assert (ca : continuity_pt atan 1). -{ apply derivable_continuous_pt, derivable_pt_atan. } -assert (Xe : exists eps', exists eps'', - eps' + eps'' <= eps /\ 0 < eps' /\ 0 < eps''). -{ exists (eps/2); exists (eps/2); repeat apply conj; lra. } -destruct Xe as [eps' [eps'' [eps_ineq [ep' ep'']]]]. -destruct (ps_atan_continuity_pt_1 _ ep') as [alpha [a0 Palpha]]. -destruct (ca _ ep'') as [beta [b0 Pbeta]]. -assert (Xa : exists a, 0 < a < 1 /\ Rdist a 1 < alpha /\ - Rdist a 1 < beta). -{ exists (Rmax (/2) (Rmax (1 - alpha /2) (1 - beta /2))). - assert (/2 <= Rmax (/2) (Rmax (1 - alpha /2) (1 - beta /2))) by apply Rmax_l. - assert (Rmax (1 - alpha /2) (1 - beta /2) <= - Rmax (/2) (Rmax (1 - alpha /2) (1 - beta /2))) by apply Rmax_r. - assert ((1 - alpha /2) <= Rmax (1 - alpha /2) (1 - beta /2)) by apply Rmax_l. - assert ((1 - beta /2) <= Rmax (1 - alpha /2) (1 - beta /2)) by apply Rmax_r. - assert (Rmax (1 - alpha /2) (1 - beta /2) < 1) - by (apply Rmax_lub_lt; lra). - split;[split;[ | apply Rmax_lub_lt]; lra | ]. - assert (0 <= 1 - Rmax (/ 2) (Rmax (1 - alpha / 2) (1 - beta / 2))). - { assert (Rmax (/2) (Rmax (1 - alpha / 2) - (1 - beta /2)) <= 1) by (apply Rmax_lub; lra). - lra. } - split; unfold Rdist; rewrite <-Rabs_Ropp, Ropp_minus_distr, - Rabs_pos_eq;lra. } -destruct Xa as [a [[Pa0 Pa1] [P1 P2]]]. -apply Rle_lt_trans with (1 := Rdist_tri _ _ (ps_atan a)). -apply Rlt_le_trans with (2 := eps_ineq). -apply Rplus_lt_compat. -{ rewrite Rdist_sym; apply Palpha; assumption. } -rewrite <- atan_eq_ps_atan. -{ rewrite <- atan_1; apply (Pbeta a); auto. - split; [ | exact P2]. - split;[exact I | apply Rgt_not_eq; assumption]. } -split; assumption. -Qed. - -Lemma PI_ineq : forall N : nat, - sum_f_R0 (tg_alt PI_tg) (S (2 * N)) <= PI/4 <= sum_f_R0 (tg_alt PI_tg) (2 * N). -Proof. -intros; rewrite <- Alt_PI_eq; apply Alt_PI_ineq. -Qed. - -(** ** Relation between arctangent and sine and cosine *) - -Lemma sin_atan: forall x, - sin (atan x) = x / sqrt (1 + xĀ²). -Proof. -intros x. -pose proof (atan_right_inv x) as Hatan. -remember (atan(x)) as Ī±. -rewrite <- Hatan. -apply sin_tan. -apply cos_gt_0. -1,2: pose proof atan_bound x; lra. -Qed. - -Lemma cos_atan: forall x, - cos (atan x) = 1 / sqrt(1 + xĀ²). -Proof. -intros x. -pose proof (atan_right_inv x) as Hatan. -remember (atan(x)) as Ī±. -rewrite <- Hatan. -apply cos_tan. -apply cos_gt_0. -1,2: pose proof atan_bound x; lra. -Qed. - -(*********************************************************) -(** * Definition of arcsine based on arctangent *) -(*********************************************************) - -(** asin is defined by cases so that it is defined in the full range from -1 .. 1 *) - -Definition asin x := - if Rle_dec x (-1) then - (PI / 2) else - if Rle_dec 1 x then PI / 2 else - atan (x / sqrt (1 - xĀ²)). - -(** ** Relation between arcsin and arctangent *) - -Lemma asin_atan : forall x, -1 < x < 1 -> - asin x = atan (x / sqrt (1 - xĀ²)). -Proof. -intros x. -unfold asin; repeat case Rle_dec; intros; lra. -Qed. - -(** ** arcsine of specific values *) - -Lemma asin_0 : asin 0 = 0. -Proof. -unfold asin; repeat case Rle_dec; intros; try lra. -replace (0/_) with 0. -- apply atan_0. -- field. - rewrite Rsqr_pow2; field_simplify (1 - 0^2). - rewrite sqrt_1; lra. -Qed. - -Lemma asin_1 : asin 1 = PI / 2. -Proof. -unfold asin; repeat case Rle_dec; lra. -Qed. - -Lemma asin_inv_sqrt2 : asin (/sqrt 2) = PI/4. -Proof. -rewrite asin_atan. -{ pose proof sqrt2_neq_0 as SH. - rewrite Rsqr_pow2, pow_inv, <- Rsqr_pow2, Rsqr_sqrt; try lra. - replace (1 - /2) with (/2) by lra. - rewrite sqrt_inv. - now rewrite <- atan_1; apply f_equal; field. } -split. -{ apply (Rlt_trans _ 0); try lra. - apply Rinv_0_lt_compat; apply sqrt_lt_R0; lra. } -replace 1 with (/ sqrt 1). -{ apply Rinv_0_lt_contravar. - { rewrite sqrt_1; lra. } - apply sqrt_lt_1; lra. } -rewrite sqrt_1; lra. -Qed. - -Lemma asin_opp : forall x, - asin (- x) = - asin x. -Proof. -intros x. -unfold asin; repeat case Rle_dec; intros; try lra. -rewrite <- Rsqr_neg. -rewrite Rdiv_opp_l. -rewrite atan_opp. -reflexivity. -Qed. - -(** ** Bounds of arcsine *) - -Lemma asin_bound : forall x, - - (PI/2) <= asin x <= PI/2. -Proof. -intros x. -pose proof PI_RGT_0. -unfold asin; repeat case Rle_dec; try lra. -intros Hx1 Hx2. -pose proof atan_bound (x / sqrt (1 - xĀ²)); lra. -Qed. - -Lemma asin_bound_lt : forall x, -1 < x < 1 -> - - (PI/2) < asin x < PI/2. -Proof. -intros x HxB. -pose proof PI_RGT_0. -unfold asin; repeat case Rle_dec; try lra. -intros Hx1 Hx2. -pose proof atan_bound (x / sqrt (1 - xĀ²)); lra. -Qed. - -(** ** arcsine is the left and right inverse of sine *) - -Lemma sin_asin : forall x, -1 <= x <= 1 -> - sin (asin x) = x. -Proof. -intros x. -unfold asin; repeat case Rle_dec. -- rewrite sin_antisym, sin_PI2; lra. -- rewrite sin_PI2; lra. -- intros Hx1 Hx2 Hx3. - pose proof Rsqr_bounds_lt 1 x ltac:(lra) as Hxsqr; rewrite Rsqr_1 in Hxsqr. - rewrite sin_atan. - unfold Rdiv at 1 2. - rewrite Rmult_assoc, <- Rinv_mult. - rewrite <- sqrt_mult_alt by lra. - rewrite Rsqr_div', Rsqr_sqrt by lra. - field_simplify ((1 - xĀ²) * (1 + xĀ² / (1 - xĀ²))). - { rewrite sqrt_1. - field. } - lra. -Qed. - -Lemma asin_sin : forall x, -(PI/2) <= x <= PI/2 -> - asin (sin x) = x. -Proof. -intros x HB. -apply sin_inj; auto. -{ apply asin_bound. } -apply sin_asin. -apply SIN_bound. -Qed. - -(** ** Relation between arcsin, cosine and tangent *) - -Lemma cos_asin : forall x, -1 <= x <= 1 -> - cos (asin x) = sqrt (1 - xĀ²). -Proof. - intros x Hxrange. - pose proof (sin_asin x) ltac:(lra) as Hasin. - remember (asin(x)) as Ī±. - rewrite <- Hasin. - apply cos_sin. - pose proof cos_ge_0 Ī±. - pose proof asin_bound x. - lra. -Qed. - -Lemma tan_asin : forall x, -1 <= x <= 1 -> - tan (asin x) = x / sqrt (1 - xĀ²). -Proof. - intros x Hxrange. - pose proof (sin_asin x) Hxrange as Hasin. - remember (asin(x)) as Ī±. - rewrite <- Hasin. - apply tan_sin. - pose proof cos_ge_0 Ī±. - pose proof asin_bound x. - lra. -Qed. - -(** ** Derivative of arcsine *) - -Lemma derivable_pt_asin : forall x, -1 < x < 1 -> - derivable_pt asin x. -Proof. - intros x H. - - eapply (derivable_pt_recip_interv sin asin (-PI/2) (PI/2)); [shelve ..|]. - - rewrite <- (pr_nu sin (asin x) (derivable_pt_sin (asin x))). - rewrite derive_pt_sin. - (* The asin bounds are needed later, so pose them before asin is unfolded *) - pose proof asin_bound_lt x ltac:(lra) as HxB3. - unfold asin in *. - destruct (Rle_dec x (-1)); destruct (Rle_dec 1 x); [lra .. |]. - apply Rgt_not_eq; apply cos_gt_0; lra. - - Unshelve. - - pose proof PI_RGT_0 as HPi; lra. - - rewrite Rdiv_opp_l,sin_antisym,sin_PI2; lra. - - clear x H; intros x Ha Hb. - rewrite Rdiv_opp_l; apply asin_bound. - - intros a Ha; reg. - - intros x0 Ha Hb. - unfold comp,id. - apply sin_asin. - rewrite Rdiv_opp_l,sin_antisym,sin_PI2 in Ha; rewrite sin_PI2 in Hb; lra. - - intros x1 x2 Ha Hb Hc. - apply sin_increasing_1; lra. -Qed. - -Lemma derive_pt_asin : forall (x : R) (Hxrange : -1 < x < 1), - derive_pt asin x (derivable_pt_asin x Hxrange) = 1 / sqrt (1 - xĀ²). -Proof. - intros x Hxrange. - - epose proof (derive_pt_recip_interv sin asin (-PI/2) (PI/2) x _ _ _ _ _ _ _) as Hd. - - rewrite <- (pr_nu sin (asin x) (derivable_pt_sin (asin x))) in Hd. - rewrite <- (pr_nu asin x (derivable_pt_asin x Hxrange)) in Hd. - rewrite derive_pt_sin in Hd. - rewrite cos_asin in Hd by lra. - assumption. - - Unshelve. - - pose proof PI_RGT_0. lra. - - rewrite Rdiv_opp_l,sin_antisym,sin_PI2; lra. - - intros x1 x2 Ha Hb Hc. - apply sin_increasing_1; lra. - - intros x0 Ha Hb. - pose proof asin_bound x0; lra. - - intros a Ha; reg. - - intros x0 Ha Hb. - unfold comp,id. - apply sin_asin. - rewrite Rdiv_opp_l,sin_antisym,sin_PI2 in Ha; rewrite sin_PI2 in Hb; lra. - - rewrite <- (pr_nu sin (asin x) (derivable_pt_sin (asin x))). - rewrite derive_pt_sin. - rewrite cos_asin by lra. - apply Rgt_not_eq. - apply sqrt_lt_R0. - pose proof Rsqr_bounds_lt 1 x ltac:(lra) as Hxsqrrange. - rewrite Rsqr_1 in Hxsqrrange; lra. -Qed. - -(*********************************************************) -(** * Definition of arccosine based on arctangent *) -(*********************************************************) - -(** acos is defined by cases so that it is defined in the full range from -1 .. 1 *) - -Definition acos x := - if Rle_dec x (-1) then PI else - if Rle_dec 1 x then 0 else - PI/2 - atan (x/sqrt(1 - xĀ²)). - -(** ** Relation between arccosine, arcsine and arctangent *) - -Lemma acos_atan : forall x, 0 < x -> - acos x = atan (sqrt (1 - xĀ²) / x). -Proof. - intros x. - unfold acos; repeat case Rle_dec; [lra | |]. - - intros Hx1 Hx2 Hx3. - pose proof Rsqr_bounds_le x 1 ltac:(lra)as Hxsqr. - rewrite Rsqr_1 in Hxsqr. - rewrite sqrt_neg_0 by lra. - replace (0/x) with 0 by (field;lra). - rewrite atan_0; reflexivity. - - intros Hx1 Hx2 Hx3. - pose proof atan_inv (sqrt (1 - xĀ²) / x) as Hatan. - pose proof Rsqr_bounds_lt 1 x ltac:(lra)as Hxsqr. - rewrite Rsqr_1 in Hxsqr. - replace (/ (sqrt (1 - xĀ²) / x)) with (x/sqrt (1 - xĀ²)) in Hatan. - + rewrite Hatan; [field|]. - apply Rdiv_lt_0_compat; [|assumption]. - apply sqrt_lt_R0; lra. - + field; split. - * lra. - * assert(sqrt (1 - xĀ²) >0) by (apply sqrt_lt_R0; lra); lra. -Qed. - -Lemma acos_asin : forall x, -1 <= x <= 1 -> - acos x = PI/2 - asin x. -Proof. - intros x. - unfold acos, asin; repeat case Rle_dec; lra. -Qed. - -Lemma asin_acos : forall x, -1 <= x <= 1 -> - asin x = PI/2 - acos x. -Proof. - intros x. - unfold acos, asin; repeat case Rle_dec; lra. -Qed. - -(** ** arccosine of specific values *) - -Lemma acos_0 : acos 0 = PI/2. -Proof. - unfold acos; repeat case Rle_dec; [lra..|]. - intros Hx1 Hx2. - replace (0/_) with 0. - { rewrite atan_0; field. } - field. - rewrite Rsqr_pow2; field_simplify (1 - 0^2). - rewrite sqrt_1; lra. -Qed. - -Lemma acos_1 : acos 1 = 0. -Proof. - unfold acos; repeat case Rle_dec; lra. -Qed. - -Lemma acos_opp : forall x, - acos (- x) = PI - acos x. -Proof. - intros x. - unfold acos; repeat case Rle_dec; try lra. - intros Hx1 Hx2 Hx3 Hx4. - rewrite <- Rsqr_neg, Rdiv_opp_l, atan_opp. - lra. -Qed. - -Lemma acos_inv_sqrt2 : acos (/sqrt 2) = PI/4. -Proof. - rewrite acos_asin. - { rewrite asin_inv_sqrt2. - lra. } - split. - { apply Rlt_le. - apply (Rlt_trans (-1) 0 (/ sqrt 2)); try lra. - apply Rinv_0_lt_compat. - apply Rlt_sqrt2_0. } - replace 1 with (/ sqrt 1). - { apply Rlt_le. - apply Rinv_0_lt_contravar. - { rewrite sqrt_1; lra. } - apply sqrt_lt_1; lra. } - rewrite sqrt_1; lra. -Qed. - -(** ** Bounds of arccosine *) - -Lemma acos_bound : forall x, - 0 <= acos x <= PI. -Proof. - intros x. - pose proof PI_RGT_0. - unfold acos; repeat case Rle_dec; try lra. - intros Hx1 Hx2. - pose proof atan_bound (x / sqrt (1 - xĀ²)); lra. -Qed. - -Lemma acos_bound_lt : forall x, -1 < x < 1 -> - 0 < acos x < PI. -Proof. - intros x xB. - pose proof PI_RGT_0. - unfold acos; repeat case Rle_dec; try lra. - intros Hx1 Hx2. - pose proof atan_bound (x / sqrt (1 - xĀ²)); lra. -Qed. - -(** ** arccosine is the left and right inverse of cosine *) - -Lemma cos_acos : forall x, -1 <= x <= 1 -> - cos (acos x) = x. -Proof. - intros x xB. - assert (H : x = -1 \/ -1 < x) by lra. - destruct H as [He|Hl]. - - rewrite He. - change (IZR (-1)) with (-(IZR 1)). - now rewrite acos_opp, acos_1, Rminus_0_r, cos_PI. - - assert (H : x = 1 \/ x < 1) by lra. - destruct H as [He1|Hl1]. - { now rewrite He1, acos_1, cos_0. } - rewrite acos_asin, cos_shift; try lra. - rewrite sin_asin; lra. -Qed. - -Lemma acos_cos : forall x, 0 <= x <= PI -> - acos (cos x) = x. -Proof. - intros x HB. - apply cos_inj; try lra. - { apply acos_bound. } - apply cos_acos. - apply COS_bound. -Qed. - -(** ** Relation between arccosine, sine and tangent *) - -Lemma sin_acos : forall x, -1 <= x <= 1 -> - sin (acos x) = sqrt (1 - xĀ²). -Proof. - intros x Hxrange. - pose proof (cos_acos x) ltac:(lra) as Hacos. - remember (acos(x)) as Ī±. - rewrite <- Hacos. - apply sin_cos. - pose proof sin_ge_0 Ī±. - pose proof acos_bound x. - lra. -Qed. - -Lemma tan_acos : forall x, -1 <= x <= 1 -> - tan (acos x) = sqrt (1 - xĀ²) / x. -Proof. - intros x Hxrange. - pose proof (cos_acos x) Hxrange as Hacos. - remember (acos(x)) as Ī±. - rewrite <- Hacos. - apply tan_cos. - pose proof sin_ge_0 Ī±. - pose proof acos_bound x. - lra. -Qed. - -(** ** Derivative of arccosine *) - -Lemma derivable_pt_acos : forall x, -1 < x < 1 -> - derivable_pt acos x. -Proof. - intros x H. - - eapply (derivable_pt_recip_interv_decr cos acos 0 PI); [shelve ..|]. - - rewrite <- (pr_nu cos (acos x) (derivable_pt_cos (acos x))). - rewrite derive_pt_cos. - (* The acos bounds are needed later, so pose them before acos is unfolded *) - pose proof acos_bound_lt x ltac:(lra) as Hbnd. - unfold acos in *. - destruct (Rle_dec x (-1)); destruct (Rle_dec 1 x); [lra..|]. - apply Rlt_not_eq, Ropp_lt_gt_0_contravar, Rlt_gt. - apply sin_gt_0; lra. - - Unshelve. - - pose proof PI_RGT_0 as HPi; lra. - - rewrite cos_0; rewrite cos_PI; lra. - - clear x H; intros x H1 H2. - apply acos_bound. - - intros a Ha; reg. - - intros x0 H1 H2. - unfold comp,id. - apply cos_acos. - rewrite cos_PI in H1; rewrite cos_0 in H2; lra. - - intros x1 x2 H1 H2 H3. - pose proof cos_decreasing_1 x1 x2; lra. -Qed. - -Lemma derive_pt_acos : forall (x : R) (Hxrange : -1 < x < 1), - derive_pt acos x (derivable_pt_acos x Hxrange) = -1 / sqrt (1 - xĀ²). -Proof. - intros x Hxrange. - - epose proof (derive_pt_recip_interv_decr cos acos 0 PI x _ _ _ _ _ _ _ ) as Hd. - - rewrite <- (pr_nu cos (acos x) (derivable_pt_cos (acos x))) in Hd. - rewrite <- (pr_nu acos x (derivable_pt_acos x Hxrange)) in Hd. - rewrite derive_pt_cos in Hd. - rewrite sin_acos in Hd by lra. - rewrite Hd; field. - apply Rgt_not_eq, Rlt_gt; rewrite <- sqrt_0. - pose proof Rsqr_bounds_lt 1 x ltac:(lra) as Hxb; rewrite Rsqr_1 in Hxb. - apply sqrt_lt_1; lra. - -Unshelve. - - pose proof PI_RGT_0; lra. - - rewrite cos_PI,cos_0; lra. - - intros x1 x2 Ha Hb Hc. - apply cos_decreasing_1; lra. - - intros x0 Ha Hb. - pose proof acos_bound x0; lra. - - intros a Ha; reg. - - intros x0 Ha Hb. - unfold comp,id. - apply cos_acos. - rewrite cos_PI in Ha; rewrite cos_0 in Hb; lra. - - rewrite <- (pr_nu cos (acos x) (derivable_pt_cos (acos x))). - rewrite derive_pt_cos. - rewrite sin_acos by lra. - apply Rlt_not_eq; rewrite <- Ropp_0; apply Ropp_lt_contravar; rewrite <- sqrt_0. - pose proof Rsqr_bounds_lt 1 x ltac:(lra) as Hxb; rewrite Rsqr_1 in Hxb. - apply sqrt_lt_1; lra. -Qed. - -Lemma sin_gt_x x : x < 0 -> x < sin x. -Proof. - intros. - pose proof (sin_lt_x (- x)). - pose proof (sin_neg x). - lra. -Qed. diff --git a/stdlib/theories/Reals/Raxioms.v b/stdlib/theories/Reals/Raxioms.v deleted file mode 100644 index 6f9bc76f1b4b..000000000000 --- a/stdlib/theories/Reals/Raxioms.v +++ /dev/null @@ -1,487 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* Rrepr x <= Rrepr y. -Proof. - split. - - intros [H|H] abs. - + rewrite RbaseSymbolsImpl.Rlt_def in H. - apply CRealLtEpsilon in H. - exact (CRealLt_asym (Rrepr x) (Rrepr y) H abs). - + destruct H. exact (CRealLt_asym (Rrepr x) (Rrepr x) abs abs). - - intros. destruct (total_order_T x y). - + destruct s. - * left. exact r. - * right. exact e. - + rewrite RbaseSymbolsImpl.Rlt_def in r. apply CRealLtEpsilon in r. contradiction. -Qed. - -Lemma Rrepr_appart : forall x y:R, - (x <> y)%R -> Rrepr x # Rrepr y. -Proof. - intros. destruct (total_order_T x y). - - destruct s. - + left. rewrite RbaseSymbolsImpl.Rlt_def in r. - apply CRealLtEpsilon. exact r. - + contradiction. - - right. rewrite RbaseSymbolsImpl.Rlt_def in r. - apply CRealLtEpsilon. exact r. -Qed. - -Lemma Rappart_repr : forall x y:R, - Rrepr x # Rrepr y -> (x <> y)%R. -Proof. - intros x y [H|H] abs. - - destruct abs. exact (CRealLt_asym (Rrepr x) (Rrepr x) H H). - - destruct abs. exact (CRealLt_asym (Rrepr x) (Rrepr x) H H). -Qed. - -Close Scope CReal_scope. - - -(**********) -Lemma Rplus_comm : forall r1 r2:R, r1 + r2 = r2 + r1. -Proof. - intros. apply Rquot1. do 2 rewrite Rrepr_plus. apply CReal_plus_comm. -Qed. -#[global] -Hint Resolve Rplus_comm: real. - -(**********) -Lemma Rplus_assoc : forall r1 r2 r3:R, r1 + r2 + r3 = r1 + (r2 + r3). -Proof. - intros. apply Rquot1. repeat rewrite Rrepr_plus. - apply CReal_plus_assoc. -Qed. -#[global] -Hint Resolve Rplus_assoc: real. - -(**********) -Lemma Rplus_opp_r : forall r:R, r + - r = 0. -Proof. - intros. apply Rquot1. rewrite Rrepr_plus, Rrepr_opp, Rrepr_0. - apply CReal_plus_opp_r. -Qed. -#[global] -Hint Resolve Rplus_opp_r: real. - -(**********) -Lemma Rplus_0_l : forall r:R, 0 + r = r. -Proof. - intros. apply Rquot1. rewrite Rrepr_plus, Rrepr_0. - apply CReal_plus_0_l. -Qed. -#[global] -Hint Resolve Rplus_0_l: real. - -(***********************************************************) -(** ** Multiplication *) -(***********************************************************) - -(**********) -Lemma Rmult_comm : forall r1 r2:R, r1 * r2 = r2 * r1. -Proof. - intros. apply Rquot1. do 2 rewrite Rrepr_mult. apply CReal_mult_comm. -Qed. -#[global] -Hint Resolve Rmult_comm: real. - -(**********) -Lemma Rmult_assoc : forall r1 r2 r3:R, r1 * r2 * r3 = r1 * (r2 * r3). -Proof. - intros. apply Rquot1. repeat rewrite Rrepr_mult. - apply CReal_mult_assoc. -Qed. -#[global] -Hint Resolve Rmult_assoc: real. - -(**********) -Lemma Rinv_l : forall r:R, r <> 0 -> / r * r = 1. -Proof. - intros. rewrite RinvImpl.Rinv_def; destruct (Req_appart_dec r R0). - - contradiction. - - apply Rquot1. rewrite Rrepr_mult, Rquot2, Rrepr_1. apply CReal_inv_l. -Qed. -#[global] -Hint Resolve Rinv_l: real. - -(**********) -Lemma Rmult_1_l : forall r:R, 1 * r = r. -Proof. - intros. apply Rquot1. rewrite Rrepr_mult, Rrepr_1. - apply CReal_mult_1_l. -Qed. -#[global] -Hint Resolve Rmult_1_l: real. - -(**********) -Lemma R1_neq_R0 : 1 <> 0. -Proof. - intro abs. - assert (CRealEq 1%CReal 0%CReal). - { transitivity (Rrepr 1). - - symmetry. - replace 1%R with (Rabst 1%CReal). - 2: unfold IZR,IPR; rewrite RbaseSymbolsImpl.R1_def; reflexivity. - rewrite Rquot2. reflexivity. - - transitivity (Rrepr 0). - + rewrite abs. reflexivity. - + replace 0%R with (Rabst 0%CReal). - 2: unfold IZR; rewrite RbaseSymbolsImpl.R0_def; reflexivity. - rewrite Rquot2. reflexivity. } - pose proof (CRealLt_morph 0%CReal 0%CReal (CRealEq_refl _) 1%CReal 0%CReal H). - apply (CRealLt_irrefl 0%CReal). apply H0. apply CRealLt_0_1. -Qed. -#[global] -Hint Resolve R1_neq_R0: real. - -(*********************************************************) -(** ** Distributivity *) -(*********************************************************) - -(**********) -Lemma - Rmult_plus_distr_l : forall r1 r2 r3:R, r1 * (r2 + r3) = r1 * r2 + r1 * r3. -Proof. - intros. apply Rquot1. - rewrite Rrepr_mult, Rrepr_plus, Rrepr_plus, Rrepr_mult, Rrepr_mult. - apply CReal_mult_plus_distr_l. -Qed. -#[global] -Hint Resolve Rmult_plus_distr_l: real. - -(*********************************************************) -(** * Order *) -(*********************************************************) - -(*********************************************************) -(** ** Lower *) -(*********************************************************) - -(**********) -Lemma Rlt_asym : forall r1 r2:R, r1 < r2 -> ~ r2 < r1. -Proof. - intros. intro abs. rewrite RbaseSymbolsImpl.Rlt_def in H, abs. - apply CRealLtEpsilon in H. apply CRealLtEpsilon in abs. - apply (CRealLt_asym (Rrepr r1) (Rrepr r2)); assumption. -Qed. - -(**********) -Lemma Rlt_trans : forall r1 r2 r3:R, r1 < r2 -> r2 < r3 -> r1 < r3. -Proof. - intros. rewrite RbaseSymbolsImpl.Rlt_def. rewrite RbaseSymbolsImpl.Rlt_def in H, H0. - apply CRealLtEpsilon in H. apply CRealLtEpsilon in H0. - apply CRealLtForget. - apply (CReal_lt_trans (Rrepr r1) (Rrepr r2) (Rrepr r3)); assumption. -Qed. - -(**********) -Lemma Rplus_lt_compat_l : forall r r1 r2:R, r1 < r2 -> r + r1 < r + r2. -Proof. - intros. rewrite RbaseSymbolsImpl.Rlt_def. rewrite RbaseSymbolsImpl.Rlt_def in H. - do 2 rewrite Rrepr_plus. apply CRealLtForget. - apply CReal_plus_lt_compat_l. apply CRealLtEpsilon. exact H. -Qed. - -(**********) -Lemma Rmult_lt_compat_l : forall r r1 r2:R, 0 < r -> r1 < r2 -> r * r1 < r * r2. -Proof. - intros. rewrite RbaseSymbolsImpl.Rlt_def. rewrite RbaseSymbolsImpl.Rlt_def in H. - do 2 rewrite Rrepr_mult. apply CRealLtForget. apply CReal_mult_lt_compat_l. - - rewrite <- (Rquot2 0%CReal). unfold IZR in H. - rewrite RbaseSymbolsImpl.R0_def in H. apply CRealLtEpsilon. exact H. - - rewrite RbaseSymbolsImpl.Rlt_def in H0. apply CRealLtEpsilon. exact H0. -Qed. - -#[global] -Hint Resolve Rlt_asym Rplus_lt_compat_l Rmult_lt_compat_l: real. - -(**********************************************************) -(** * Injection from N to R *) -(**********************************************************) - -(**********) -Fixpoint INR (n:nat) : R := - match n with - | O => 0 - | S O => 1 - | S n => INR n + 1 - end. -Arguments INR n%_nat. - -(**********************************************************) -(** * [R] Archimedean *) -(**********************************************************) - -Lemma Rrepr_INR : forall n : nat, - CRealEq (Rrepr (INR n)) (inject_Z (Z.of_nat n)). -Proof. - induction n. - - apply Rrepr_0. - - replace (Z.of_nat (S n)) with (Z.of_nat n + 1)%Z. - + simpl. destruct n. - * apply Rrepr_1. - * rewrite Rrepr_plus,inject_Z_plus, <- IHn, Rrepr_1. reflexivity. - + replace 1%Z with (Z.of_nat 1). - * rewrite <- (Nat2Z.inj_add n 1). - apply f_equal. rewrite Nat.add_comm. reflexivity. - * reflexivity. -Qed. - -Lemma Rrepr_IPR2 : forall n : positive, - CRealEq (Rrepr (IPR_2 n)) (inject_Z (Z.pos (n~0))). -Proof. - induction n. - - simpl. replace (Z.pos n~1~0) with ((Z.pos n~0 + 1) + (Z.pos n~0 + 1))%Z. - + rewrite RbaseSymbolsImpl.R1_def, Rrepr_mult, inject_Z_plus, inject_Z_plus. - rewrite Rrepr_plus, Rrepr_plus, <- IHn. - rewrite Rquot2, CReal_mult_plus_distr_r, CReal_mult_1_l. - rewrite (CReal_plus_comm 1%CReal). repeat rewrite CReal_plus_assoc. - apply CReal_plus_morph. - * reflexivity. - * reflexivity. - + repeat rewrite <- Pos2Z.inj_add. apply f_equal. - rewrite Pos.add_diag. apply f_equal. - rewrite Pos.add_1_r. reflexivity. - - simpl. replace (Z.pos n~0~0) with ((Z.pos n~0) + (Z.pos n~0))%Z. - + rewrite RbaseSymbolsImpl.R1_def, Rrepr_mult, inject_Z_plus. - rewrite Rrepr_plus, <- IHn. - rewrite Rquot2, CReal_mult_plus_distr_r, CReal_mult_1_l. reflexivity. - + rewrite <- Pos2Z.inj_add. apply f_equal. - rewrite Pos.add_diag. reflexivity. - - simpl. rewrite Rrepr_plus, RbaseSymbolsImpl.R1_def, Rquot2. - replace 2%Z with (1 + 1)%Z. - + rewrite inject_Z_plus. reflexivity. - + reflexivity. -Qed. - -Lemma Rrepr_IPR : forall n : positive, - CRealEq (Rrepr (IPR n)) (inject_Z (Z.pos n)). -Proof. - intro n. destruct n. - - unfold IPR. rewrite Rrepr_plus. - replace (n~1)%positive with (n~0 + 1)%positive. - + rewrite Pos2Z.inj_add, inject_Z_plus, <- Rrepr_IPR2, CReal_plus_comm. - rewrite RbaseSymbolsImpl.R1_def, Rquot2. reflexivity. - + rewrite Pos.add_1_r. reflexivity. - - apply Rrepr_IPR2. - - unfold IPR. rewrite RbaseSymbolsImpl.R1_def. apply Rquot2. -Qed. - -Lemma Rrepr_IZR : forall n : Z, - CRealEq (Rrepr (IZR n)) (inject_Z n). -Proof. - intros [|p|n]. - - unfold IZR. rewrite RbaseSymbolsImpl.R0_def. apply Rquot2. - - apply Rrepr_IPR. - - unfold IZR. rewrite Rrepr_opp, Rrepr_IPR. rewrite <- opp_inject_Z. - replace (- Z.pos n)%Z with (Z.neg n); reflexivity. -Qed. - -(**********) -Lemma archimed : forall r:R, IZR (up r) > r /\ IZR (up r) - r <= 1. -Proof. - intro r. unfold up. - destruct (CRealArchimedean (Rrepr r)) as [n nmaj], (total_order_T (IZR n - r) R1). - 1:destruct s. - - split. - + unfold Rgt. rewrite RbaseSymbolsImpl.Rlt_def. rewrite Rrepr_IZR. - apply CRealLtForget. apply nmaj. - + unfold Rle. left. exact r0. - - split. - + unfold Rgt. rewrite RbaseSymbolsImpl.Rlt_def. - rewrite Rrepr_IZR. apply CRealLtForget. apply nmaj. - + right. exact e. - - split. - + unfold Rgt, Z.pred. rewrite RbaseSymbolsImpl.Rlt_def. - rewrite Rrepr_IZR, inject_Z_plus. - rewrite RbaseSymbolsImpl.Rlt_def in r0. rewrite Rrepr_minus in r0. - rewrite <- (Rrepr_IZR n). - apply CRealLtForget. apply CRealLtEpsilon in r0. - unfold CReal_minus in r0. - apply (CReal_plus_lt_compat_l - (CReal_plus (Rrepr r) (CReal_opp (Rrepr R1)))) - in r0. - rewrite CReal_plus_assoc, - CReal_plus_opp_l, - CReal_plus_0_r, - RbaseSymbolsImpl.R1_def, Rquot2, - CReal_plus_comm, - CReal_plus_assoc, - <- (CReal_plus_assoc (CReal_opp (Rrepr r))), - CReal_plus_opp_l, - CReal_plus_0_l - in r0. - rewrite (opp_inject_Z 1). exact r0. - + destruct (total_order_T (IZR (Z.pred n) - r) 1). - * destruct s. - -- left. exact r1. - -- right. exact e. - * exfalso. destruct nmaj as [_ nmaj]. - pose proof Rrepr_IZR as iz. - rewrite <- iz in nmaj. - apply (Rlt_asym (IZR n) (r + 2)). - -- rewrite RbaseSymbolsImpl.Rlt_def. rewrite Rrepr_plus. rewrite (Rrepr_plus 1 1). - apply CRealLtForget. - apply (CReal_lt_le_trans _ _ _ nmaj). - unfold IZR, IPR. rewrite RbaseSymbolsImpl.R1_def, Rquot2. - rewrite <- (inject_Z_plus 1 1). apply CRealLe_refl. - -- clear nmaj. - unfold Z.pred in r1. rewrite RbaseSymbolsImpl.Rlt_def in r1. - rewrite Rrepr_minus, (Rrepr_IZR (n + -1)) in r1. - rewrite inject_Z_plus, <- (Rrepr_IZR n) in r1. - rewrite RbaseSymbolsImpl.Rlt_def, Rrepr_plus. - apply CRealLtEpsilon in r1. - apply (CReal_plus_lt_compat_l - (CReal_plus (Rrepr r) 1%CReal)) in r1. - apply CRealLtForget. - apply (CReal_le_lt_trans - _ (CReal_plus (CReal_plus (Rrepr r) (Rrepr 1)) 1%CReal)). - ++ rewrite (Rrepr_plus 1 1). unfold IZR, IPR. - rewrite RbaseSymbolsImpl.R1_def, (Rquot2 1%CReal), <- CReal_plus_assoc. - apply CRealLe_refl. - ++ rewrite <- (CReal_plus_comm (Rrepr 1)), - <- CReal_plus_assoc, - (CReal_plus_comm (Rrepr 1)) - in r1. - apply (CReal_lt_le_trans _ _ _ r1). - unfold CReal_minus. rewrite (opp_inject_Z 1). - rewrite (CReal_plus_comm (Rrepr (IZR n))), CReal_plus_assoc, - <- (CReal_plus_assoc 1), <- (CReal_plus_assoc 1), CReal_plus_opp_r. - rewrite CReal_plus_0_l, CReal_plus_comm, CReal_plus_assoc, - CReal_plus_opp_l, CReal_plus_0_r. - apply CRealLe_refl. -Qed. - -(**********************************************************) -(** * [R] Complete *) -(**********************************************************) - -(**********) -Definition is_upper_bound (E:R -> Prop) (m:R) := forall x:R, E x -> x <= m. - -(**********) -Definition bound (E:R -> Prop) := exists m : R, is_upper_bound E m. - -(**********) -Definition is_lub (E:R -> Prop) (m:R) := - is_upper_bound E m /\ (forall b:R, is_upper_bound E b -> m <= b). - -(**********) -Lemma completeness : - forall E:R -> Prop, - bound E -> (exists x : R, E x) -> { m:R | is_lub E m }. -Proof. - intros. pose (fun x:CReal => E (Rabst x)) as Er. - assert (forall x y : CReal, CRealEq x y -> Er x <-> Er y) - as Erproper. - { intros. unfold Er. replace (Rabst x) with (Rabst y). - - reflexivity. - - apply Rquot1. do 2 rewrite Rquot2. split; apply H1. } - assert (exists x : CReal, Er x) as Einhab. - { destruct H0. exists (Rrepr x). unfold Er. - replace (Rabst (Rrepr x)) with x. - - exact H0. - - apply Rquot1. rewrite Rquot2. reflexivity. } - assert (exists x : CReal, - (forall y:CReal, Er y -> CRealLe y x)) - as Ebound. - { destruct H. exists (Rrepr x). intros y Ey. rewrite <- (Rquot2 y). - apply Rrepr_le. apply H. exact Ey. } - 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. - unfold CRealLe. apply a. - unfold Er. replace (Rabst (Rrepr y)) with y. - + exact Ey. - + apply Rquot1. rewrite Rquot2. reflexivity. - - intros. destruct a. apply Rrepr_le. rewrite Rquot2. - unfold CRealLe. apply H3. intros y Ey. - intros. rewrite <- (Rquot2 y) in H4. - apply Rrepr_le in H4. - + exact H4. - + apply H1, Ey. -Qed. diff --git a/stdlib/theories/Reals/Rbase.v b/stdlib/theories/Reals/Rbase.v deleted file mode 100644 index e4f822a74d3c..000000000000 --- a/stdlib/theories/Reals/Rbase.v +++ /dev/null @@ -1,14 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* x - | right _ => y - end. - -(*********) -Lemma Rmin_case : forall r1 r2 (P:R -> Type), P r1 -> P r2 -> P (Rmin r1 r2). -Proof. - intros r1 r2 P H1 H2; unfold Rmin; case (Rle_dec r1 r2); auto. -Qed. - -(*********) -Lemma Rmin_case_strong : forall r1 r2 (P:R -> Type), - (r1 <= r2 -> P r1) -> (r2 <= r1 -> P r2) -> P (Rmin r1 r2). -Proof. - intros r1 r2 P H1 H2; unfold Rmin; destruct (Rle_dec r1 r2); auto with real. -Qed. - -(*********) -Lemma Rmin_Rgt_l : forall r1 r2 r, Rmin r1 r2 > r -> r1 > r /\ r2 > r. -Proof. - intros r1 r2 r; unfold Rmin; case (Rle_dec r1 r2) as [Hle|Hnle]; intros. - - split. - + assumption. - + unfold Rgt; exact (Rlt_le_trans r r1 r2 H Hle). - - split. - + generalize (Rnot_le_lt r1 r2 Hnle); intro; exact (Rgt_trans r1 r2 r H0 H). - + assumption. -Qed. - -(*********) -Lemma Rmin_Rgt_r : forall r1 r2 r, r1 > r /\ r2 > r -> Rmin r1 r2 > r. -Proof. - intros; unfold Rmin; case (Rle_dec r1 r2); elim H; clear H; intros; - assumption. -Qed. - -(*********) -Lemma Rmin_Rgt : forall r1 r2 r, Rmin r1 r2 > r <-> r1 > r /\ r2 > r. -Proof. - intros; split. - - exact (Rmin_Rgt_l r1 r2 r). - - exact (Rmin_Rgt_r r1 r2 r). -Qed. - -(*********) -Lemma Rmin_l : forall x y:R, Rmin x y <= x. -Proof. - intros; unfold Rmin; case (Rle_dec x y); intro H1; - [ right; reflexivity | auto with real ]. -Qed. - -(*********) -Lemma Rmin_r : forall x y:R, Rmin x y <= y. -Proof. - intros; unfold Rmin; case (Rle_dec x y); intro H1; - [ assumption | auto with real ]. -Qed. - -(*********) -Lemma Rmin_left : forall x y, x <= y -> Rmin x y = x. -Proof. - intros; apply Rmin_case_strong; auto using Rle_antisym. -Qed. - -(*********) -Lemma Rmin_right : forall x y, y <= x -> Rmin x y = y. -Proof. - intros; apply Rmin_case_strong; auto using Rle_antisym. -Qed. - -(*********) -Lemma Rle_min_compat_r : forall x y z, x <= y -> Rmin x z <= Rmin y z. -Proof. - intros; do 2 (apply Rmin_case_strong; intro); eauto using Rle_trans, Rle_refl. -Qed. - -(*********) -Lemma Rle_min_compat_l : forall x y z, x <= y -> Rmin z x <= Rmin z y. -Proof. - intros; do 2 (apply Rmin_case_strong; intro); eauto using Rle_trans, Rle_refl. -Qed. - -(*********) -Lemma Rmin_comm : forall x y:R, Rmin x y = Rmin y x. -Proof. - intros; unfold Rmin; case (Rle_dec x y); case (Rle_dec y x); intros; - try reflexivity || (apply Rle_antisym; assumption || auto with real). -Qed. - -(*********) -Lemma Rmin_stable_in_posreal : forall x y:posreal, 0 < Rmin x y. -Proof. - intros; apply Rmin_Rgt_r; split; [ apply (cond_pos x) | apply (cond_pos y) ]. -Qed. - -(*********) -Lemma Rmin_pos : forall x y:R, 0 < x -> 0 < y -> 0 < Rmin x y. -Proof. - intros; unfold Rmin. - case (Rle_dec x y); intro; assumption. -Qed. - -(*********) -Lemma Rmin_glb : forall x y z:R, z <= x -> z <= y -> z <= Rmin x y. -Proof. - intros; unfold Rmin; case (Rle_dec x y); intro; assumption. -Qed. - -(*********) -Lemma Rmin_glb_lt : forall x y z:R, z < x -> z < y -> z < Rmin x y. -Proof. - intros; unfold Rmin; case (Rle_dec x y); intro; assumption. -Qed. - -(*******************************) -(** * Rmax *) -(*******************************) - -(*********) -Definition Rmax (x y:R) : R := - match Rle_dec x y with - | left _ => y - | right _ => x - end. - -(*********) -Lemma Rmax_case : forall r1 r2 (P:R -> Type), P r1 -> P r2 -> P (Rmax r1 r2). -Proof. - intros r1 r2 P H1 H2; unfold Rmax; case (Rle_dec r1 r2); auto. -Qed. - -(*********) -Lemma Rmax_case_strong : forall r1 r2 (P:R -> Type), - (r2 <= r1 -> P r1) -> (r1 <= r2 -> P r2) -> P (Rmax r1 r2). -Proof. - intros r1 r2 P H1 H2; unfold Rmax; case (Rle_dec r1 r2); auto with real. -Qed. - -(*********) -Lemma Rmax_Rle : forall r1 r2 r, r <= Rmax r1 r2 <-> r <= r1 \/ r <= r2. -Proof. - intros; split. - - unfold Rmax; case (Rle_dec r1 r2); intros; auto. - - intro; unfold Rmax; case (Rle_dec r1 r2) as [|Hnle]; elim H; clear H; intros; - auto. - + apply (Rle_trans r r1 r2); auto. - + generalize (Rnot_le_lt r1 r2 Hnle); clear Hnle; intro; unfold Rgt in H0; - apply (Rlt_le r r1 (Rle_lt_trans r r2 r1 H H0)). -Qed. - -Lemma Rmax_comm : forall x y:R, Rmax x y = Rmax y x. -Proof. - intros p q; unfold Rmax; case (Rle_dec p q); case (Rle_dec q p); auto; - intros H1 H2; apply Rle_antisym; auto with real. -Qed. - -(* begin hide *) -Notation RmaxSym := Rmax_comm (only parsing). -(* end hide *) - -(*********) -Lemma Rmax_l : forall x y:R, x <= Rmax x y. -Proof. - intros; unfold Rmax; case (Rle_dec x y); intro H1; - [ assumption | auto with real ]. -Qed. - -(*********) -Lemma Rmax_r : forall x y:R, y <= Rmax x y. -Proof. - intros; unfold Rmax; case (Rle_dec x y); intro H1; - [ right; reflexivity | auto with real ]. -Qed. - -(* begin hide *) -Notation RmaxLess1 := Rmax_l (only parsing). -Notation RmaxLess2 := Rmax_r (only parsing). -(* end hide *) - -(*********) -Lemma Rmax_left : forall x y, y <= x -> Rmax x y = x. -Proof. - intros; apply Rmax_case_strong; auto using Rle_antisym. -Qed. - -(*********) -Lemma Rmax_right : forall x y, x <= y -> Rmax x y = y. -Proof. - intros; apply Rmax_case_strong; auto using Rle_antisym. -Qed. - -(*********) -Lemma Rle_max_compat_r : forall x y z, x <= y -> Rmax x z <= Rmax y z. -Proof. - intros; do 2 (apply Rmax_case_strong; intro); eauto using Rle_trans, Rle_refl. -Qed. - -(*********) -Lemma Rle_max_compat_l : forall x y z, x <= y -> Rmax z x <= Rmax z y. -Proof. - intros; do 2 (apply Rmax_case_strong; intro); eauto using Rle_trans, Rle_refl. -Qed. - -(*********) -Lemma RmaxRmult : - forall (p q:R) r, 0 <= r -> Rmax (r * p) (r * q) = r * Rmax p q. -Proof. - intros p q r H; unfold Rmax. - case (Rle_dec p q); case (Rle_dec (r * p) (r * q)); auto; intros H1 H2; auto. - - case H; intros E1. - + case H1; auto with real. - + rewrite <- E1; repeat rewrite Rmult_0_l; auto. - - case H; intros E1. - + case H2; auto with real. - apply Rmult_le_reg_l with (r := r); auto. - + rewrite <- E1; repeat rewrite Rmult_0_l; auto. -Qed. - -(*********) -Lemma Rmax_stable_in_negreal : forall x y:negreal, Rmax x y < 0. -Proof. - intros; unfold Rmax; case (Rle_dec x y); intro; - [ apply (cond_neg y) | apply (cond_neg x) ]. -Qed. - -(*********) -Lemma Rmax_lub : forall x y z:R, x <= z -> y <= z -> Rmax x y <= z. -Proof. - intros; unfold Rmax; case (Rle_dec x y); intro; assumption. -Qed. - -(*********) -Lemma Rmax_lub_lt : forall x y z:R, x < z -> y < z -> Rmax x y < z. -Proof. - intros; unfold Rmax; case (Rle_dec x y); intro; assumption. -Qed. - -Lemma Rmax_Rlt : forall x y z, - Rmax x y < z <-> x < z /\ y < z. -Proof. -intros x y z; split. -- unfold Rmax; case (Rle_dec x y). - + intros xy yz; split;[apply Rle_lt_trans with y|]; assumption. - + intros xz xy; split;[|apply Rlt_trans with x;[apply Rnot_le_gt|]];assumption. -- intros [h h']; apply Rmax_lub_lt; assumption. -Qed. - -(*********) -Lemma Rmax_neg : forall x y:R, x < 0 -> y < 0 -> Rmax x y < 0. -Proof. - intros; unfold Rmax. - case (Rle_dec x y); intro; assumption. -Qed. - -(*******************************) -(** * Rabsolu *) -(*******************************) - -(*********) -Lemma Rcase_abs : forall r, {r < 0} + {r >= 0}. -Proof. - intro; generalize (Rle_dec 0 r); intro X; elim X; intro H; clear X. - - right; apply (Rle_ge 0 r H). - - left; fold (0 > r); apply (Rnot_le_lt 0 r H). -Qed. - -(*********) -Definition Rabs r : R := - match Rcase_abs r with - | left _ => - r - | right _ => r - end. - -(*********) -Lemma Rabs_R0 : Rabs 0 = 0. -Proof. - unfold Rabs; case (Rcase_abs 0); auto; intro. - generalize (Rlt_irrefl 0); intro; exfalso; auto. -Qed. - -Lemma Rabs_R1 : Rabs 1 = 1. -Proof. -unfold Rabs; case (Rcase_abs 1); auto with real. -intros H; absurd (1 < 0); auto with real. -Qed. - -(*********) -Lemma Rabs_no_R0 : forall r, r <> 0 -> Rabs r <> 0. -Proof. - intros; unfold Rabs; case (Rcase_abs r); intro; auto. - apply Ropp_neq_0_compat; auto. -Qed. - -(*********) -Lemma Rabs_left : forall r, r < 0 -> Rabs r = - r. -Proof. - intros; unfold Rabs; case (Rcase_abs r); trivial; intro; - absurd (r >= 0). - - exact (Rlt_not_ge r 0 H). - - assumption. -Qed. - -(*********) -Lemma Rabs_right : forall r, r >= 0 -> Rabs r = r. -Proof. - intros; unfold Rabs; case (Rcase_abs r) as [Hlt|Hge]. - - absurd (r >= 0). - + exact (Rlt_not_ge r 0 Hlt). - + assumption. - - trivial. -Qed. - -Lemma Rabs_left1 : forall a:R, a <= 0 -> Rabs a = - a. -Proof. - intros a H; case H; intros H1. - - apply Rabs_left; auto. - - rewrite H1; simpl; rewrite Rabs_right; auto with real. -Qed. - -(*********) -Lemma Rabs_pos : forall x:R, 0 <= Rabs x. -Proof. - intros; unfold Rabs; case (Rcase_abs x) as [Hlt|Hge]. - - generalize (Ropp_lt_gt_contravar x 0 Hlt); intro; unfold Rgt in H; - rewrite Ropp_0 in H; left; assumption. - - apply Rge_le; assumption. -Qed. - -Lemma Rle_abs : forall x:R, x <= Rabs x. -Proof. - intro; unfold Rabs; case (Rcase_abs x); intros;auto with real. - apply Rminus_le; rewrite <- Rplus_0_r; - unfold Rminus; rewrite Ropp_involutive; auto with real. -Qed. - -Definition RRle_abs := Rle_abs. - -Lemma Rabs_le : forall a b, -b <= a <= b -> Rabs a <= b. -Proof. -intros a b; unfold Rabs; case Rcase_abs. -- intros _ [it _]; apply Ropp_le_cancel; rewrite Ropp_involutive; exact it. -- intros _ [_ it]; exact it. -Qed. - -(*********) -Lemma Rabs_pos_eq : forall x:R, 0 <= x -> Rabs x = x. -Proof. - intros; unfold Rabs; case (Rcase_abs x) as [Hlt|Hge]; - [ generalize (Rgt_not_le 0 x Hlt); intro; exfalso; auto | trivial ]. -Qed. - -(*********) -Lemma Rabs_Rabsolu : forall x:R, Rabs (Rabs x) = Rabs x. -Proof. - intro; apply (Rabs_pos_eq (Rabs x) (Rabs_pos x)). -Qed. - -(*********) -Lemma Rabs_pos_lt : forall x:R, x <> 0 -> 0 < Rabs x. -Proof. - intros; destruct (Rabs_pos x) as [|Heq]; auto. - apply Rabs_no_R0 in H; symmetry in Heq; contradiction. -Qed. - -(*********) -Lemma Rabs_minus_sym : forall x y:R, Rabs (x - y) = Rabs (y - x). -Proof. - intros; unfold Rabs; case (Rcase_abs (x - y)) as [Hlt|Hge]; - case (Rcase_abs (y - x)) as [Hlt'|Hge']. - - apply Rminus_lt, Rlt_asym in Hlt; apply Rminus_lt in Hlt'; contradiction. - - rewrite (Ropp_minus_distr x y); trivial. - - rewrite (Ropp_minus_distr y x); trivial. - - destruct Hge; destruct Hge'. - + apply Ropp_lt_gt_0_contravar in H; rewrite (Ropp_minus_distr x y) in H; - apply Rlt_asym in H0; contradiction. - + apply Rminus_diag_uniq in H0 as ->; trivial. - + apply Rminus_diag_uniq in H as ->; trivial. - + apply Rminus_diag_uniq in H0 as ->; trivial. -Qed. - -(*********) -Lemma Rabs_mult : forall x y:R, Rabs (x * y) = Rabs x * Rabs y. -Proof. - intros; unfold Rabs; case (Rcase_abs (x * y)) as [Hlt|Hge]; - case (Rcase_abs x) as [Hltx|Hgex]; - case (Rcase_abs y) as [Hlty|Hgey]; auto. - - apply Rmult_lt_gt_compat_neg_l with (r:=x), Rlt_asym in Hlty; trivial. - rewrite Rmult_0_r in Hlty; contradiction. - - rewrite (Ropp_mult_distr_l_reverse x y); trivial. - - rewrite (Rmult_comm x (- y)); rewrite (Ropp_mult_distr_l_reverse y x); - rewrite (Rmult_comm x y); trivial. - - destruct Hgex as [| ->], Hgey as [| ->]. - + apply Rmult_lt_compat_l with (r:=x), Rlt_asym in H0; trivial. - rewrite Rmult_0_r in H0; contradiction. - + rewrite Rmult_0_r in Hlt; contradiction (Rlt_irrefl 0). - + rewrite Rmult_0_l in Hlt; contradiction (Rlt_irrefl 0). - + rewrite Rmult_0_l in Hlt; contradiction (Rlt_irrefl 0). - - rewrite (Rmult_opp_opp x y); trivial. - - destruct Hge. - + destruct Hgey. - * apply Rmult_lt_compat_r with (r:=y), Rlt_asym in Hltx; trivial. - rewrite Rmult_0_l in Hltx; contradiction. - * rewrite H0, Rmult_0_r in H; contradiction (Rlt_irrefl 0). - + rewrite <- Ropp_mult_distr_l, H, Ropp_0; trivial. - - destruct Hge. - + destruct Hgex. - * apply Rmult_lt_compat_l with (r:=x), Rlt_asym in Hlty; trivial. - rewrite Rmult_0_r in Hlty; contradiction. - * rewrite H0, 2!Rmult_0_l; trivial. - + rewrite <- Ropp_mult_distr_r, H, Ropp_0; trivial. -Qed. - -(*********) -Lemma Rabs_inv r : Rabs (/ r) = / Rabs r. -Proof. - unfold Rabs; case (Rcase_abs r) as [Hlt|Hge]; - case (Rcase_abs (/ r)) as [Hlt'|Hge']; auto; - intros. - - apply eq_sym, Rinv_opp. - - rewrite Rinv_opp. - destruct Hge' as [| ->]. - + apply Rinv_lt_0_compat, Rlt_asym in Hlt; contradiction. - + rewrite Ropp_0; trivial. - - destruct Hge as [H0| ->]. - + apply Rinv_0_lt_compat, Rlt_asym in H0; contradiction. - + rewrite Rinv_0. - apply Ropp_0. -Qed. - -Lemma Rabs_Rinv_depr : forall r, r <> 0 -> Rabs (/ r) = / Rabs r. -Proof. - intros r Hr. - apply Rabs_inv. -Qed. - -#[deprecated(since="8.16",note="Use Rabs_inv.")] -Notation Rabs_Rinv := Rabs_Rinv_depr. - -Lemma Rabs_Ropp : forall x:R, Rabs (- x) = Rabs x. -Proof. - intro; replace (-x) with (-1 * x) by ring. - rewrite Rabs_mult. - replace (Rabs (-1)) with 1. - - apply Rmult_1_l. - - unfold Rabs; case (Rcase_abs (-1)). - + intro; ring. - + rewrite <- Ropp_0. - intro H0; apply Ropp_ge_cancel in H0. - elim (Rge_not_lt _ _ H0). - apply Rlt_0_1. -Qed. - -(*********) -Lemma Rabs_triang : forall a b:R, Rabs (a + b) <= Rabs a + Rabs b. -Proof. - intros a b; unfold Rabs; case (Rcase_abs (a + b)) as [Hlt|Hge]; - case (Rcase_abs a) as [Hlta|Hgea]; - case (Rcase_abs b) as [Hltb|Hgeb]. - - apply (Req_le (- (a + b)) (- a + - b)); rewrite (Ropp_plus_distr a b); - reflexivity. - - (**) - rewrite (Ropp_plus_distr a b); apply (Rplus_le_compat_l (- a) (- b) b); - unfold Rle; elim Hgeb; intro. - + left; unfold Rgt in H; generalize (Rplus_lt_compat_l (- b) 0 b H); intro; - elim (Rplus_ne (- b)); intros v w; rewrite v in H0; - clear v w; rewrite (Rplus_opp_l b) in H0; apply (Rlt_trans (- b) 0 b H0 H). - + right; rewrite H; apply Ropp_0. - - (**) - rewrite (Ropp_plus_distr a b); rewrite (Rplus_comm (- a) (- b)); - rewrite (Rplus_comm a (- b)); apply (Rplus_le_compat_l (- b) (- a) a); - unfold Rle; elim Hgea; intro. - + left; unfold Rgt in H; generalize (Rplus_lt_compat_l (- a) 0 a H); intro; - elim (Rplus_ne (- a)); intros v w; rewrite v in H0; - clear v w; rewrite (Rplus_opp_l a) in H0; apply (Rlt_trans (- a) 0 a H0 H). - + right; rewrite H; apply Ropp_0. - - (**) - exfalso; generalize (Rplus_ge_compat_l a b 0 Hgeb); intro; - elim (Rplus_ne a); intros v w; rewrite v in H; clear v w; - generalize (Rge_trans (a + b) a 0 H Hgea); intro; clear H; - unfold Rge in H0; elim H0; intro; clear H0. - + unfold Rgt in H; generalize (Rlt_asym (a + b) 0 Hlt); intro; auto. - + absurd (a + b = 0); auto. - apply (Rlt_dichotomy_converse (a + b) 0); left; assumption. - - (**) - exfalso; generalize (Rplus_lt_compat_l a b 0 Hltb); intro; - elim (Rplus_ne a); intros v w; rewrite v in H; clear v w; - generalize (Rlt_trans (a + b) a 0 H Hlta); intro; clear H; - destruct Hge. - + unfold Rgt in H; generalize (Rlt_trans (a + b) 0 (a + b) H0 H); intro; - apply (Rlt_irrefl (a + b)); assumption. - + rewrite H in H0; apply (Rlt_irrefl 0); assumption. - - (**) - rewrite (Rplus_comm a b); rewrite (Rplus_comm (- a) b); - apply (Rplus_le_compat_l b a (- a)); apply (Rminus_le a (- a)); - unfold Rminus; rewrite (Ropp_involutive a); - generalize (Rplus_lt_compat_l a a 0 Hlta); clear Hge Hgeb; - intro; elim (Rplus_ne a); intros v w; rewrite v in H; - clear v w; generalize (Rlt_trans (a + a) a 0 H Hlta); - intro; apply (Rlt_le (a + a) 0 H0). - - (**) - apply (Rplus_le_compat_l a b (- b)); apply (Rminus_le b (- b)); - unfold Rminus; rewrite (Ropp_involutive b); - generalize (Rplus_lt_compat_l b b 0 Hltb); clear Hge Hgea; - intro; elim (Rplus_ne b); intros v w; rewrite v in H; - clear v w; generalize (Rlt_trans (b + b) b 0 H Hltb); - intro; apply (Rlt_le (b + b) 0 H0). - - (**) - unfold Rle; right; reflexivity. -Qed. - -(*********) -Lemma Rabs_triang_inv : forall a b:R, Rabs a - Rabs b <= Rabs (a - b). -Proof. - intros; apply (Rplus_le_reg_l (Rabs b) (Rabs a - Rabs b) (Rabs (a - b))); - unfold Rminus; rewrite <- (Rplus_assoc (Rabs b) (Rabs a) (- Rabs b)); - rewrite (Rplus_comm (Rabs b) (Rabs a)); - rewrite (Rplus_assoc (Rabs a) (Rabs b) (- Rabs b)); - rewrite (Rplus_opp_r (Rabs b)); rewrite (proj1 (Rplus_ne (Rabs a))); - replace (Rabs a) with (Rabs (a + 0)). - - rewrite <- (Rplus_opp_r b); rewrite <- (Rplus_assoc a b (- b)); - rewrite (Rplus_comm a b); rewrite (Rplus_assoc b a (- b)). - exact (Rabs_triang b (a + - b)). - - rewrite (proj1 (Rplus_ne a)); trivial. -Qed. - -(* ||a|-|b||<=|a-b| *) -Lemma Rabs_triang_inv2 : forall a b:R, Rabs (Rabs a - Rabs b) <= Rabs (a - b). -Proof. - cut - (forall a b:R, Rabs b <= Rabs a -> Rabs (Rabs a - Rabs b) <= Rabs (a - b)). - - intros; destruct (Rtotal_order (Rabs a) (Rabs b)) as [Hlt| [Heq| Hgt]]. - + rewrite <- (Rabs_Ropp (Rabs a - Rabs b)); rewrite <- (Rabs_Ropp (a - b)); - do 2 rewrite Ropp_minus_distr. - apply H; left; assumption. - + rewrite Heq; unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0; - apply Rabs_pos. - + apply H; left; assumption. - - intros; replace (Rabs (Rabs a - Rabs b)) with (Rabs a - Rabs b). - + apply Rabs_triang_inv. - + rewrite (Rabs_right (Rabs a - Rabs b)); - [ reflexivity - | apply Rle_ge; apply Rplus_le_reg_l with (Rabs b); rewrite Rplus_0_r; - replace (Rabs b + (Rabs a - Rabs b)) with (Rabs a); - [ assumption | ring ] ]. -Qed. - -(*********) -Lemma Rabs_def1 : forall x a:R, x < a -> - a < x -> Rabs x < a. -Proof. - unfold Rabs; intros; case (Rcase_abs x); intro. - - generalize (Ropp_lt_gt_contravar (- a) x H0); unfold Rgt; - rewrite Ropp_involutive; intro; assumption. - - assumption. -Qed. - -(*********) -Lemma Rabs_def2 : forall x a:R, Rabs x < a -> x < a /\ - a < x. -Proof. - unfold Rabs; intro x; case (Rcase_abs x) as [Hlt|Hge]; intros. - - generalize (Ropp_gt_lt_0_contravar x Hlt); unfold Rgt; intro; - generalize (Rlt_trans 0 (- x) a H0 H); intro; split. - + apply (Rlt_trans x 0 a Hlt H1). - + generalize (Ropp_lt_gt_contravar (- x) a H); rewrite (Ropp_involutive x); - unfold Rgt; trivial. - - fold (a > x) in H; generalize (Rgt_ge_trans a x 0 H Hge); intro; - generalize (Ropp_lt_gt_0_contravar a H0); intro; fold (0 > - a); - generalize (Rge_gt_trans x 0 (- a) Hge H1); unfold Rgt; - intro; split; assumption. -Qed. - -Lemma RmaxAbs : - forall (p q:R) r, p <= q -> q <= r -> Rabs q <= Rmax (Rabs p) (Rabs r). -Proof. - intros p q r H' H'0; case (Rle_or_lt 0 p); intros H'1. - - repeat rewrite Rabs_right; auto with real. - + apply Rle_trans with r; auto with real. - apply RmaxLess2; auto. - + apply Rge_trans with p; auto with real; apply Rge_trans with q; - auto with real. - + apply Rge_trans with p; auto with real. - - rewrite (Rabs_left p); auto. - case (Rle_or_lt 0 q); intros H'2. - + repeat rewrite Rabs_right; auto with real. - * apply Rle_trans with r; auto. - apply RmaxLess2; auto. - * apply Rge_trans with q; auto with real. - + rewrite (Rabs_left q); auto. - case (Rle_or_lt 0 r); intros H'3. - * repeat rewrite Rabs_right; auto with real. - apply Rle_trans with (- p); auto with real. - apply RmaxLess1; auto. - * rewrite (Rabs_left r); auto. - apply Rle_trans with (- p); auto with real. - apply RmaxLess1; auto. -Qed. - -Lemma Rabs_Zabs : forall z:Z, Rabs (IZR z) = IZR (Z.abs z). -Proof. - intros z; case z; unfold Z.abs. - - apply Rabs_R0. - - now intros p0; apply Rabs_pos_eq, (IZR_le 0). - - unfold IZR at 1. - intros p0; rewrite Rabs_Ropp. - now apply Rabs_pos_eq, (IZR_le 0). -Qed. - -Lemma abs_IZR : forall z, IZR (Z.abs z) = Rabs (IZR z). -Proof. - intros. - now rewrite Rabs_Zabs. -Qed. - -Lemma Ropp_Rmax : forall x y, - Rmax x y = Rmin (-x) (-y). -intros x y; apply Rmax_case_strong. -- now intros w; rewrite Rmin_left;[ | apply Rge_le, Ropp_le_ge_contravar]. -- now intros w; rewrite Rmin_right; [ | apply Rge_le, Ropp_le_ge_contravar]. -Qed. - -Lemma Ropp_Rmin : forall x y, - Rmin x y = Rmax (-x) (-y). -intros x y; apply Rmin_case_strong. -- now intros w; rewrite Rmax_left;[ | apply Rge_le, Ropp_le_ge_contravar]. -- now intros w; rewrite Rmax_right; [ | apply Rge_le, Ropp_le_ge_contravar]. -Qed. - -Lemma Rmax_assoc : forall a b c, Rmax a (Rmax b c) = Rmax (Rmax a b) c. -Proof. -intros a b c. -unfold Rmax; destruct (Rle_dec b c); destruct (Rle_dec a b); - destruct (Rle_dec a c); destruct (Rle_dec b c); auto with real; - match goal with - | id : ~ ?x <= ?y, id2 : ?x <= ?z |- _ => - case id; apply Rle_trans with z; auto with real - | id : ~ ?x <= ?y, id2 : ~ ?z <= ?x |- _ => - case id; apply Rle_trans with z; auto with real - end. -Qed. - -Lemma Rminmax : forall a b, Rmin a b <= Rmax a b. -Proof. -intros a b; destruct (Rle_dec a b). -- rewrite Rmin_left, Rmax_right; assumption. -- now rewrite Rmin_right, Rmax_left; assumption || - apply Rlt_le, Rnot_le_gt. -Qed. - -Lemma Rmin_assoc : forall x y z, Rmin x (Rmin y z) = - Rmin (Rmin x y) z. -Proof. -intros a b c. -unfold Rmin; destruct (Rle_dec b c); destruct (Rle_dec a b); - destruct (Rle_dec a c); destruct (Rle_dec b c); auto with real; - match goal with - | id : ~ ?x <= ?y, id2 : ?x <= ?z |- _ => - case id; apply Rle_trans with z; auto with real - | id : ~ ?x <= ?y, id2 : ~ ?z <= ?x |- _ => - case id; apply Rle_trans with z; auto with real - end. -Qed. diff --git a/stdlib/theories/Reals/Rcomplete.v b/stdlib/theories/Reals/Rcomplete.v deleted file mode 100644 index ab2547f23034..000000000000 --- a/stdlib/theories/Reals/Rcomplete.v +++ /dev/null @@ -1,193 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* R, Cauchy_crit Un -> { l:R | Un_cv Un l } . -Proof. - intros. - set (Vn := sequence_minorant Un (cauchy_min Un H)). - set (Wn := sequence_majorant Un (cauchy_maj Un H)). - pose proof (maj_cv Un H) as (x,p). - fold Wn in p. - pose proof (min_cv Un H) as (x0,p0). - fold Vn in p0. - cut (x = x0). - - intros H2. - exists x. - rewrite <- H2 in p0. - unfold Un_cv. - intros. - unfold Un_cv in p; unfold Un_cv in p0. - cut (0 < eps / 3). - + intro H4. - elim (p (eps / 3) H4); intros. - elim (p0 (eps / 3) H4); intros. - exists (max x1 x2). - intros. - unfold Rdist. - apply Rle_lt_trans with (Rabs (Un n - Vn n) + Rabs (Vn n - x)). - { replace (Un n - x) with (Un n - Vn n + (Vn n - x)); - [ apply Rabs_triang | ring ]. } - apply Rle_lt_trans with (Rabs (Wn n - Vn n) + Rabs (Vn n - x)). - * do 2 rewrite <- (Rplus_comm (Rabs (Vn n - x))). - apply Rplus_le_compat_l. - repeat rewrite Rabs_right. - -- unfold Rminus; do 2 rewrite <- (Rplus_comm (- Vn n)); - apply Rplus_le_compat_l. - assert (H8 := Vn_Un_Wn_order Un (cauchy_maj Un H) (cauchy_min Un H)). - fold Vn Wn in H8. - elim (H8 n); intros. - assumption. - -- apply Rle_ge. - unfold Rminus; apply Rplus_le_reg_l with (Vn n). - rewrite Rplus_0_r. - replace (Vn n + (Wn n + - Vn n)) with (Wn n); [ idtac | ring ]. - assert (H8 := Vn_Un_Wn_order Un (cauchy_maj Un H) (cauchy_min Un H)). - fold Vn Wn in H8. - elim (H8 n); intros. - apply Rle_trans with (Un n); assumption. - -- apply Rle_ge. - unfold Rminus; apply Rplus_le_reg_l with (Vn n). - rewrite Rplus_0_r. - replace (Vn n + (Un n + - Vn n)) with (Un n); [ idtac | ring ]. - assert (H8 := Vn_Un_Wn_order Un (cauchy_maj Un H) (cauchy_min Un H)). - fold Vn Wn in H8. - elim (H8 n); intros. - assumption. - * apply Rle_lt_trans with (Rabs (Wn n - x) + Rabs (x - Vn n) + Rabs (Vn n - x)). - -- do 2 rewrite <- (Rplus_comm (Rabs (Vn n - x))). - apply Rplus_le_compat_l. - replace (Wn n - Vn n) with (Wn n - x + (x - Vn n)); - [ apply Rabs_triang | ring ]. - -- apply Rlt_le_trans with (eps / 3 + eps / 3 + eps / 3). - 1:repeat apply Rplus_lt_compat. - ++ unfold Rdist in H1. - apply H1. - unfold ge; apply Nat.le_trans with (max x1 x2). - ** apply Nat.le_max_l. - ** assumption. - ++ rewrite <- Rabs_Ropp. - replace (- (x - Vn n)) with (Vn n - x); [ idtac | ring ]. - unfold Rdist in H3. - apply H3. - unfold ge; apply Nat.le_trans with (max x1 x2). - ** apply Nat.le_max_r. - ** assumption. - ++ unfold Rdist in H3. - apply H3. - unfold ge; apply Nat.le_trans with (max x1 x2). - ** apply Nat.le_max_r. - ** assumption. - ++ right. - pattern eps at 4; replace eps with (3 * (eps / 3)). - ** ring. - ** unfold Rdiv; rewrite <- Rmult_assoc; apply Rmult_inv_r_id_m; discrR. - + unfold Rdiv; apply Rmult_lt_0_compat; - [ assumption | apply Rinv_0_lt_compat; prove_sup0 ]. - - apply cond_eq. - intros. - cut (0 < eps / 5). - + intro. - unfold Un_cv in p; unfold Un_cv in p0. - unfold Rdist in p; unfold Rdist in p0. - elim (p (eps / 5) H1); intros N1 H4. - elim (p0 (eps / 5) H1); intros N2 H5. - unfold Cauchy_crit in H. - unfold Rdist in H. - elim (H (eps / 5) H1); intros N3 H6. - set (N := max (max N1 N2) N3). - apply Rle_lt_trans with (Rabs (x - Wn N) + Rabs (Wn N - x0)). - { replace (x - x0) with (x - Wn N + (Wn N - x0)); [ apply Rabs_triang | ring ]. } - apply Rle_lt_trans with - (Rabs (x - Wn N) + Rabs (Wn N - Vn N) + Rabs (Vn N - x0)). - * rewrite Rplus_assoc. - apply Rplus_le_compat_l. - replace (Wn N - x0) with (Wn N - Vn N + (Vn N - x0)); - [ apply Rabs_triang | ring ]. - * replace eps with (eps / 5 + 3 * (eps / 5) + eps / 5). - -- repeat apply Rplus_lt_compat. - ++ rewrite <- Rabs_Ropp. - replace (- (x - Wn N)) with (Wn N - x); [ apply H4 | ring ]. - unfold ge, N. - apply Nat.le_trans with (max N1 N2); apply Nat.le_max_l. - ++ unfold Wn, Vn. - unfold sequence_majorant, sequence_minorant. - assert - (H7 := - approx_maj (fun k:nat => Un (N + k)%nat) (maj_ss Un N (cauchy_maj Un H))). - assert - (H8 := - approx_min (fun k:nat => Un (N + k)%nat) (min_ss Un N (cauchy_min Un H))). - assert - (H10 :Wn N = - majorant (fun k:nat => Un (N + k)%nat) (maj_ss Un N (cauchy_maj Un H))) by reflexivity. - assert - (H9:Vn N = - minorant (fun k:nat => Un (N + k)%nat) (min_ss Un N (cauchy_min Un H))) by reflexivity. - rewrite <- H9 in H8 |- *. - rewrite <- H10 in H7 |- *. - elim (H7 (eps / 5) H1); intros k2 H11. - elim (H8 (eps / 5) H1); intros k1 H12. - apply Rle_lt_trans with - (Rabs (Wn N - Un (N + k2)%nat) + Rabs (Un (N + k2)%nat - Vn N)). - { replace (Wn N - Vn N) with - (Wn N - Un (N + k2)%nat + (Un (N + k2)%nat - Vn N)); - [ apply Rabs_triang | ring ]. } - apply Rle_lt_trans with - (Rabs (Wn N - Un (N + k2)%nat) + Rabs (Un (N + k2)%nat - Un (N + k1)%nat) + - Rabs (Un (N + k1)%nat - Vn N)). - { rewrite Rplus_assoc. - apply Rplus_le_compat_l. - replace (Un (N + k2)%nat - Vn N) with - (Un (N + k2)%nat - Un (N + k1)%nat + (Un (N + k1)%nat - Vn N)); - [ apply Rabs_triang | ring ]. } - replace (3 * (eps / 5)) with (eps / 5 + eps / 5 + eps / 5); - [ repeat apply Rplus_lt_compat | ring ]. - ** assumption. - ** { apply H6. - - unfold ge. - apply Nat.le_trans with N. - + unfold N; apply Nat.le_max_r. - + apply Nat.le_add_r. - - unfold ge. - apply Nat.le_trans with N. - + unfold N; apply Nat.le_max_r. - + apply Nat.le_add_r. - } - ** rewrite <- Rabs_Ropp. - replace (- (Un (N + k1)%nat - Vn N)) with (Vn N - Un (N + k1)%nat); - [ assumption | ring ]. - ++ apply H5. - unfold ge; apply Nat.le_trans with (max N1 N2). - ** apply Nat.le_max_r. - ** unfold N; apply Nat.le_max_l. - -- pattern eps at 4; replace eps with (5 * (eps / 5)). - ++ ring. - ++ unfold Rdiv; rewrite <- Rmult_assoc; apply Rmult_inv_r_id_m. - discrR. - + unfold Rdiv; apply Rmult_lt_0_compat. - * assumption. - * apply Rinv_0_lt_compat. - prove_sup0. -Qed. diff --git a/stdlib/theories/Reals/Rdefinitions.v b/stdlib/theories/Reals/Rdefinitions.v deleted file mode 100644 index 4e349753047f..000000000000 --- a/stdlib/theories/Reals/Rdefinitions.v +++ /dev/null @@ -1,390 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* R. - Axiom Rrepr : R -> CReal. - Axiom Rquot1 : forall x y:R, CRealEq (Rrepr x) (Rrepr y) -> x = y. - Axiom Rquot2 : forall x:CReal, CRealEq (Rrepr (Rabst x)) x. - - Parameter R0 : R. - Parameter R1 : R. - Parameter Rplus : R -> R -> R. - Parameter Rmult : R -> R -> R. - Parameter Ropp : R -> R. - Parameter Rlt : R -> R -> Prop. - - Parameter R0_def : R0 = Rabst (inject_Q 0). - Parameter R1_def : R1 = Rabst (inject_Q 1). - Parameter Rplus_def : forall x y : R, - Rplus x y = Rabst (CReal_plus (Rrepr x) (Rrepr y)). - Parameter Rmult_def : forall x y : R, - Rmult x y = Rabst (CReal_mult (Rrepr x) (Rrepr y)). - Parameter Ropp_def : forall x : R, - Ropp x = Rabst (CReal_opp (Rrepr x)). - Parameter Rlt_def : forall x y : R, - Rlt x y = CRealLtProp (Rrepr x) (Rrepr y). -End RbaseSymbolsSig. - -Module RbaseSymbolsImpl : RbaseSymbolsSig. - Definition R := DReal. - Definition Rabst := DRealAbstr. - Definition Rrepr := DRealRepr. - Definition Rquot1 := DRealQuot1. - Definition Rquot2 := DRealQuot2. - Definition R0 : R := Rabst (inject_Q 0). - Definition R1 : R := Rabst (inject_Q 1). - Definition Rplus : R -> R -> R - := fun x y : R => Rabst (CReal_plus (Rrepr x) (Rrepr y)). - Definition Rmult : R -> R -> R - := fun x y : R => Rabst (CReal_mult (Rrepr x) (Rrepr y)). - Definition Ropp : R -> R - := fun x : R => Rabst (CReal_opp (Rrepr x)). - Definition Rlt : R -> R -> Prop - := fun x y : R => CRealLtProp (Rrepr x) (Rrepr y). - - Definition R0_def := eq_refl R0. - Definition R1_def := eq_refl R1. - Definition Rplus_def := fun x y => eq_refl (Rplus x y). - Definition Rmult_def := fun x y => eq_refl (Rmult x y). - Definition Ropp_def := fun x => eq_refl (Ropp x). - Definition Rlt_def := fun x y => eq_refl (Rlt x y). -End RbaseSymbolsImpl. -Export RbaseSymbolsImpl. - -(* Keep the same names as before *) -Notation R := RbaseSymbolsImpl.R (only parsing). -Notation R0 := RbaseSymbolsImpl.R0 (only parsing). -Notation R1 := RbaseSymbolsImpl.R1 (only parsing). -Notation Rplus := RbaseSymbolsImpl.Rplus (only parsing). -Notation Rmult := RbaseSymbolsImpl.Rmult (only parsing). -Notation Ropp := RbaseSymbolsImpl.Ropp (only parsing). -Notation Rlt := RbaseSymbolsImpl.Rlt (only parsing). - -(* Automatically open scope R_scope for arguments of type R *) -Bind Scope R_scope with R. - -Infix "+" := Rplus : R_scope. -Infix "*" := Rmult : R_scope. -Notation "- x" := (Ropp x) : R_scope. - -Infix "<" := Rlt : R_scope. - -(***********************************************************) - -(**********) -Definition Rgt (r1 r2:R) : Prop := r2 < r1. - -(**********) -Definition Rle (r1 r2:R) : Prop := r1 < r2 \/ r1 = r2. - -(**********) -Definition Rge (r1 r2:R) : Prop := Rgt r1 r2 \/ r1 = r2. - -(**********) -Definition Rminus (r1 r2:R) : R := r1 + - r2. - - -(**********) - -Infix "-" := Rminus : R_scope. - -Infix "<=" := Rle : R_scope. -Infix ">=" := Rge : R_scope. -Infix ">" := Rgt : R_scope. - -Notation "x <= y <= z" := (x <= y /\ y <= z) : R_scope. -Notation "x <= y < z" := (x <= y /\ y < z) : R_scope. -Notation "x < y < z" := (x < y /\ y < z) : R_scope. -Notation "x < y <= z" := (x < y /\ y <= z) : R_scope. - -(**********************************************************) -(** * Injection from [Z] to [R] *) -(**********************************************************) - -(* compact representation for 2*p *) -Fixpoint IPR_2 (p:positive) : R := - match p with - | xH => R1 + R1 - | xO p => (R1 + R1) * IPR_2 p - | xI p => (R1 + R1) * (R1 + IPR_2 p) - end. - -Definition IPR (p:positive) : R := - match p with - | xH => R1 - | xO p => IPR_2 p - | xI p => R1 + IPR_2 p - end. -Arguments IPR p%_positive : simpl never. - -(**********) -Definition IZR (z:Z) : R := - match z with - | Z0 => R0 - | Zpos n => IPR n - | Zneg n => - IPR n - end. -Arguments IZR z%_Z : simpl never. - -Lemma total_order_T : forall r1 r2:R, {Rlt r1 r2} + {r1 = r2} + {Rlt r2 r1}. -Proof. - intros. destruct (CRealLt_lpo_dec (Rrepr r1) (Rrepr r2) sig_forall_dec). - - left. left. rewrite RbaseSymbolsImpl.Rlt_def. - apply CRealLtForget. exact c. - - destruct (CRealLt_lpo_dec (Rrepr r2) (Rrepr r1) sig_forall_dec). - + right. rewrite RbaseSymbolsImpl.Rlt_def. apply CRealLtForget. exact c. - + left. right. apply Rquot1. split; assumption. -Qed. - -Lemma Req_appart_dec : forall x y : R, - { x = y } + { x < y \/ y < x }. -Proof. - intros. destruct (total_order_T x y). 1:destruct s. - - right. left. exact r. - - left. exact e. - - right. right. exact r. -Qed. - -Lemma Rrepr_appart_0 : forall x:R, - (x < R0 \/ R0 < x) -> CReal_appart (Rrepr x) (inject_Q 0). -Proof. - intros. apply CRealLtDisjunctEpsilon. destruct H. - - left. rewrite RbaseSymbolsImpl.Rlt_def, RbaseSymbolsImpl.R0_def, Rquot2 in H. - exact H. - - right. rewrite RbaseSymbolsImpl.Rlt_def, RbaseSymbolsImpl.R0_def, Rquot2 in H. - exact H. -Qed. - -Module Type RinvSig. - Parameter Rinv : R -> R. - Parameter Rinv_def : forall x : R, - Rinv x = match Req_appart_dec x R0 with - | left _ => R0 (* / 0 is undefined, we take 0 arbitrarily *) - | right r => Rabst ((CReal_inv (Rrepr x) (Rrepr_appart_0 x r))) - end. -End RinvSig. - -Module RinvImpl : RinvSig. - Definition Rinv : R -> R - := fun x => match Req_appart_dec x R0 with - | left _ => R0 (* / 0 is undefined, we take 0 arbitrarily *) - | right r => Rabst ((CReal_inv (Rrepr x) (Rrepr_appart_0 x r))) - end. - Definition Rinv_def := fun x => eq_refl (Rinv x). -End RinvImpl. -Notation Rinv := RinvImpl.Rinv (only parsing). - -Notation "/ x" := (Rinv x) : R_scope. - -(**********) -Definition Rdiv (r1 r2:R) : R := r1 * / r2. -Infix "/" := Rdiv : R_scope. - -(* First integer strictly above x *) -Definition up (x : R) : Z. -Proof. - destruct (CRealArchimedean (Rrepr x)) as [n nmaj], (total_order_T (IZR n - x) R1). - 1:destruct s. - - exact n. - - (* x = n-1 *) exact n. - - exact (Z.pred n). -Defined. - -(** Injection of rational numbers into real numbers. *) - -Definition Q2R (x : Q) : R := (IZR (Qnum x) * / IZR (QDen x))%R. - -(**********************************************************) -(** * Number notation for constants *) -(**********************************************************) - -Inductive IR := - | IRZ : IZ -> IR - | IRQ : Q -> IR - | IRmult : IR -> IR -> IR - | IRdiv : IR -> IR -> IR. - -Definition of_decimal (d : Decimal.decimal) : IR := - let '(i, f, e) := - match d with - | Decimal.Decimal i f => (i, f, Decimal.Pos Decimal.Nil) - | Decimal.DecimalExp i f e => (i, f, e) - end in - let zq := match f with - | Decimal.Nil => IRZ (IZ_of_Z (Z.of_int i)) - | _ => - let num := Z.of_int (Decimal.app_int i f) in - let den := Nat.iter (Decimal.nb_digits f) (Pos.mul 10) 1%positive in - IRQ (Qmake num den) end in - let e := Z.of_int e in - match e with - | Z0 => zq - | Zpos e => IRmult zq (IRZ (IZpow_pos 10 e)) - | Zneg e => IRdiv zq (IRZ (IZpow_pos 10 e)) - end. - -Definition of_hexadecimal (d : Hexadecimal.hexadecimal) : IR := - let '(i, f, e) := - match d with - | Hexadecimal.Hexadecimal i f => (i, f, Decimal.Pos Decimal.Nil) - | Hexadecimal.HexadecimalExp i f e => (i, f, e) - end in - let zq := match f with - | Hexadecimal.Nil => IRZ (IZ_of_Z (Z.of_hex_int i)) - | _ => - let num := Z.of_hex_int (Hexadecimal.app_int i f) in - let den := Nat.iter (Hexadecimal.nb_digits f) (Pos.mul 16) 1%positive in - IRQ (Qmake num den) end in - let e := Z.of_int e in - match e with - | Z0 => zq - | Zpos e => IRmult zq (IRZ (IZpow_pos 2 e)) - | Zneg e => IRdiv zq (IRZ (IZpow_pos 2 e)) - end. - -Definition of_number (n : Number.number) : IR := - match n with - | Number.Decimal d => of_decimal d - | Number.Hexadecimal h => of_hexadecimal h - end. - -Definition IQmake_to_decimal num den := - match den with - | 1%positive => None (* this should be encoded as IRZ *) - | _ => IQmake_to_decimal num den - end. - -Definition to_decimal (n : IR) : option Decimal.decimal := - match n with - | IRZ z => - match IZ_to_Z z with - | Some z => Some (Decimal.Decimal (Z.to_int z) Decimal.Nil) - | None => None - end - | IRQ (Qmake num den) => IQmake_to_decimal num den - | IRmult (IRZ z) (IRZ (IZpow_pos 10 e)) => - match IZ_to_Z z with - | Some z => - Some (Decimal.DecimalExp (Z.to_int z) Decimal.Nil (Pos.to_int e)) - | None => None - end - | IRmult (IRQ (Qmake num den)) (IRZ (IZpow_pos 10 e)) => - match IQmake_to_decimal num den with - | Some (Decimal.Decimal i f) => - Some (Decimal.DecimalExp i f (Pos.to_int e)) - | _ => None - end - | IRdiv (IRZ z) (IRZ (IZpow_pos 10 e)) => - match IZ_to_Z z with - | Some z => - Some (Decimal.DecimalExp (Z.to_int z) Decimal.Nil (Decimal.Neg (Pos.to_uint e))) - | None => None - end - | IRdiv (IRQ (Qmake num den)) (IRZ (IZpow_pos 10 e)) => - match IQmake_to_decimal num den with - | Some (Decimal.Decimal i f) => - Some (Decimal.DecimalExp i f (Decimal.Neg (Pos.to_uint e))) - | _ => None - end - | _ => None - end. - -Definition IQmake_to_hexadecimal num den := - match den with - | 1%positive => None (* this should be encoded as IRZ *) - | _ => IQmake_to_hexadecimal num den - end. - -Definition to_hexadecimal (n : IR) : option Hexadecimal.hexadecimal := - match n with - | IRZ z => - match IZ_to_Z z with - | Some z => Some (Hexadecimal.Hexadecimal (Z.to_hex_int z) Hexadecimal.Nil) - | None => None - end - | IRQ (Qmake num den) => IQmake_to_hexadecimal num den - | IRmult (IRZ z) (IRZ (IZpow_pos 2 e)) => - match IZ_to_Z z with - | Some z => - Some (Hexadecimal.HexadecimalExp (Z.to_hex_int z) Hexadecimal.Nil (Pos.to_int e)) - | None => None - end - | IRmult (IRQ (Qmake num den)) (IRZ (IZpow_pos 2 e)) => - match IQmake_to_hexadecimal num den with - | Some (Hexadecimal.Hexadecimal i f) => - Some (Hexadecimal.HexadecimalExp i f (Pos.to_int e)) - | _ => None - end - | IRdiv (IRZ z) (IRZ (IZpow_pos 2 e)) => - match IZ_to_Z z with - | Some z => - Some (Hexadecimal.HexadecimalExp (Z.to_hex_int z) Hexadecimal.Nil (Decimal.Neg (Pos.to_uint e))) - | None => None - end - | IRdiv (IRQ (Qmake num den)) (IRZ (IZpow_pos 2 e)) => - match IQmake_to_hexadecimal num den with - | Some (Hexadecimal.Hexadecimal i f) => - Some (Hexadecimal.HexadecimalExp i f (Decimal.Neg (Pos.to_uint e))) - | _ => None - end - | _ => None - end. - -Definition to_number q := - match to_decimal q with - | None => None - | Some q => Some (Number.Decimal q) - end. - -Definition to_hex_number q := - match to_hexadecimal q with - | None => None - | Some q => Some (Number.Hexadecimal q) - end. - -Number Notation R of_number to_hex_number (via IR - mapping [IZR => IRZ, Q2R => IRQ, Rmult => IRmult, Rdiv => IRdiv, - Z.pow_pos => IZpow_pos, Z0 => IZ0, Zpos => IZpos, Zneg => IZneg]) - : hex_R_scope. - -Number Notation R of_number to_number (via IR - mapping [IZR => IRZ, Q2R => IRQ, Rmult => IRmult, Rdiv => IRdiv, - Z.pow_pos => IZpow_pos, Z0 => IZ0, Zpos => IZpos, Zneg => IZneg]) - : R_scope. diff --git a/stdlib/theories/Reals/Rderiv.v b/stdlib/theories/Reals/Rderiv.v deleted file mode 100644 index 72af6a225424..000000000000 --- a/stdlib/theories/Reals/Rderiv.v +++ /dev/null @@ -1,434 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* Prop) (y x:R) : Prop := D x /\ y <> x. - -(*********) -Definition continue_in (f:R -> R) (D:R -> Prop) (x0:R) : Prop := - limit1_in f (D_x D x0) (f x0) x0. - -(*********) -Definition D_in (f d:R -> R) (D:R -> Prop) (x0:R) : Prop := - limit1_in (fun x:R => (f x - f x0) / (x - x0)) (D_x D x0) (d x0) x0. - -(*********) -Lemma cont_deriv : - forall (f d:R -> R) (D:R -> Prop) (x0:R), - D_in f d D x0 -> continue_in f D x0. -Proof. - unfold continue_in; unfold D_in; unfold limit1_in; - unfold limit_in; unfold Rdiv; simpl; - intros; elim (H eps H0); clear H; intros; elim H; - clear H; intros; elim (Req_dec (d x0) 0); intro. - - split with (Rmin 1 x); split. - + elim (Rmin_Rgt 1 x 0); intros a b; apply (b (conj Rlt_0_1 H)). - + intros; elim H3; clear H3; intros; - generalize (let (H1, H2) := Rmin_Rgt 1 x (Rdist x1 x0) in H1); - unfold Rgt; intro; elim (H5 H4); clear H5; - intros; generalize (H1 x1 (conj H3 H6)); clear H1; - intro; unfold D_x in H3; elim H3; intros. - rewrite H2 in H1; unfold Rdist; unfold Rdist in H1; - cut (Rabs (f x1 - f x0) < eps * Rabs (x1 - x0)). - * intro; unfold Rdist in H5; - generalize (Rmult_lt_compat_l eps (Rabs (x1 - x0)) 1 H0 H5); - rewrite Rmult_1_r; intro; apply Rlt_trans with (r2 := eps * Rabs (x1 - x0)); - assumption. - * rewrite (Rminus_0_r ((f x1 - f x0) * / (x1 - x0))) in H1; - rewrite Rabs_mult in H1; cut (x1 - x0 <> 0). - -- intro; rewrite (Rabs_inv (x1 - x0)) in H1; - generalize - (Rmult_lt_compat_l (Rabs (x1 - x0)) (Rabs (f x1 - f x0) * / Rabs (x1 - x0)) - eps (Rabs_pos_lt (x1 - x0) H9) H1); intro; rewrite Rmult_comm in H10; - rewrite Rmult_assoc in H10; rewrite Rinv_l in H10. - ++ rewrite Rmult_1_r in H10; rewrite Rmult_comm; assumption. - ++ apply Rabs_no_R0; auto. - -- apply Rminus_eq_contra; auto. - - (**) - split with (Rmin (Rmin (/ 2) x) (eps * / Rabs (2 * d x0))); split. - + cut (Rmin (/ 2) x > 0). - * cut (eps * / Rabs (2 * d x0) > 0). - -- intros; elim (Rmin_Rgt (Rmin (/ 2) x) (eps * / Rabs (2 * d x0)) 0); - intros a b; apply (b (conj H4 H3)). - -- apply Rmult_gt_0_compat; auto. - unfold Rgt; apply Rinv_0_lt_compat; apply Rabs_pos_lt; - apply Rmult_integral_contrapositive; split. - ++ discrR. - ++ assumption. - * elim (Rmin_Rgt (/ 2) x 0); intros a b; cut (0 < 2). - -- intro; generalize (Rinv_0_lt_compat 2 H3); intro; fold (/ 2 > 0) in H4; - apply (b (conj H4 H)). - -- lra. - + intros; elim H3; clear H3; intros; - generalize - (let (H1, H2) := - Rmin_Rgt (Rmin (/ 2) x) (eps * / Rabs (2 * d x0)) (Rdist x1 x0) in - H1); unfold Rgt; intro; elim (H5 H4); clear H5; - intros; generalize (let (H1, H2) := Rmin_Rgt (/ 2) x (Rdist x1 x0) in H1); - unfold Rgt; intro; elim (H7 H5); clear H7; - intros; clear H4 H5; generalize (H1 x1 (conj H3 H8)); - clear H1; intro; unfold D_x in H3; elim H3; intros; - generalize (not_eq_sym H5); clear H5; intro H5; - generalize (Rminus_eq_contra x1 x0 H5); intro; generalize H1; - pattern (d x0) at 1; - rewrite <- (let (H1, H2) := Rmult_ne (d x0) in H2); - rewrite <- (Rinv_l (x1 - x0) H9); unfold Rdist; - unfold Rminus at 1; rewrite (Rmult_comm (f x1 - f x0) (/ (x1 - x0))); - rewrite (Rmult_comm (/ (x1 - x0) * (x1 - x0)) (d x0)); - rewrite <- (Ropp_mult_distr_l_reverse (d x0) (/ (x1 - x0) * (x1 - x0))); - rewrite (Rmult_comm (- d x0) (/ (x1 - x0) * (x1 - x0))); - rewrite (Rmult_assoc (/ (x1 - x0)) (x1 - x0) (- d x0)); - rewrite <- - (Rmult_plus_distr_l (/ (x1 - x0)) (f x1 - f x0) ((x1 - x0) * - d x0)) - ; rewrite (Rabs_mult (/ (x1 - x0)) (f x1 - f x0 + (x1 - x0) * - d x0)); - clear H1; intro; - generalize - (Rmult_lt_compat_l (Rabs (x1 - x0)) - (Rabs (/ (x1 - x0)) * Rabs (f x1 - f x0 + (x1 - x0) * - d x0)) eps - (Rabs_pos_lt (x1 - x0) H9) H1); - rewrite <- - (Rmult_assoc (Rabs (x1 - x0)) (Rabs (/ (x1 - x0))) - (Rabs (f x1 - f x0 + (x1 - x0) * - d x0))); - rewrite (Rabs_inv (x1 - x0)); - rewrite (Rinv_r (Rabs (x1 - x0)) (Rabs_no_R0 (x1 - x0) H9)); - rewrite - (let (H1, H2) := Rmult_ne (Rabs (f x1 - f x0 + (x1 - x0) * - d x0)) in H2) - ; generalize (Rabs_triang_inv (f x1 - f x0) ((x1 - x0) * d x0)); - intro; rewrite (Rmult_comm (x1 - x0) (- d x0)); - rewrite (Ropp_mult_distr_l_reverse (d x0) (x1 - x0)); - fold (f x1 - f x0 - d x0 * (x1 - x0)); - rewrite (Rmult_comm (x1 - x0) (d x0)) in H10; clear H1; - intro; - generalize - (Rle_lt_trans (Rabs (f x1 - f x0) - Rabs (d x0 * (x1 - x0))) - (Rabs (f x1 - f x0 - d x0 * (x1 - x0))) (Rabs (x1 - x0) * eps) H10 H1); - clear H1; intro; - generalize - (Rplus_lt_compat_l (Rabs (d x0 * (x1 - x0))) - (Rabs (f x1 - f x0) - Rabs (d x0 * (x1 - x0))) ( - Rabs (x1 - x0) * eps) H1); unfold Rminus at 2; - rewrite (Rplus_comm (Rabs (f x1 - f x0)) (- Rabs (d x0 * (x1 - x0)))); - rewrite <- - (Rplus_assoc (Rabs (d x0 * (x1 - x0))) (- Rabs (d x0 * (x1 - x0))) - (Rabs (f x1 - f x0))); rewrite (Rplus_opp_r (Rabs (d x0 * (x1 - x0)))); - rewrite (let (H1, H2) := Rplus_ne (Rabs (f x1 - f x0)) in H2); - clear H1; intro; cut (Rabs (d x0 * (x1 - x0)) + Rabs (x1 - x0) * eps < eps). - * intro; - apply - (Rlt_trans (Rabs (f x1 - f x0)) - (Rabs (d x0 * (x1 - x0)) + Rabs (x1 - x0) * eps) eps H1 H11). - * clear H1 H5 H3 H10; generalize (Rabs_pos_lt (d x0) H2); intro; - unfold Rgt in H0; - generalize (Rmult_lt_compat_l eps (Rdist x1 x0) (/ 2) H0 H7); - clear H7; intro; - generalize - (Rmult_lt_compat_l (Rabs (d x0)) (Rdist x1 x0) ( - eps * / Rabs (2 * d x0)) H1 H6); clear H6; intro; - rewrite (Rmult_comm eps (Rdist x1 x0)) in H3; unfold Rdist in H3, H5; - rewrite <- (Rabs_mult (d x0) (x1 - x0)) in H5; - rewrite (Rabs_mult 2 (d x0)) in H5; cut (Rabs 2 <> 0). - -- intro; fold (Rabs (d x0) > 0) in H1; - rewrite - (Rinv_mult (Rabs 2) (Rabs (d x0))) - in H5; - rewrite (Rmult_comm (Rabs (d x0)) (eps * (/ Rabs 2 * / Rabs (d x0)))) in H5; - rewrite <- (Rmult_assoc eps (/ Rabs 2) (/ Rabs (d x0))) in H5; - rewrite (Rmult_assoc (eps * / Rabs 2) (/ Rabs (d x0)) (Rabs (d x0))) in H5; - rewrite - (Rinv_l (Rabs (d x0)) - (Rlt_dichotomy_converse (Rabs (d x0)) 0 (or_intror (Rabs (d x0) < 0) H1))) - in H5; rewrite (let (H1, H2) := Rmult_ne (eps * / Rabs 2) in H1) in H5; - cut (Rabs 2 = 2). - ++ intro; rewrite H7 in H5; - generalize - (Rplus_lt_compat (Rabs (d x0 * (x1 - x0))) (eps * / 2) - (Rabs (x1 - x0) * eps) (eps * / 2) H5 H3); intro; - rewrite eps2 in H10; assumption. - ++ unfold Rabs; destruct (Rcase_abs 2) as [Hlt|Hge]; auto. - cut (0 < 2). - ** intro H7; elim (Rlt_asym 0 2 H7 Hlt). - ** lra. - -- apply Rabs_no_R0. - discrR. -Qed. - -(*********) -Lemma Dconst : - forall (D:R -> Prop) (y x0:R), D_in (fun x:R => y) (fun x:R => 0) D x0. -Proof. - unfold D_in; intros; unfold limit1_in; - unfold limit_in; unfold Rdiv; intros; - simpl; split with eps; split; auto. - intros; rewrite (Rminus_diag_eq y y (eq_refl y)); rewrite Rmult_0_l; - unfold Rdist; rewrite (Rminus_diag_eq 0 0 (eq_refl 0)); - unfold Rabs; case (Rcase_abs 0); intro. - - absurd (0 < 0); auto. - red; intro; apply (Rlt_irrefl 0 H1). - - unfold Rgt in H0; assumption. -Qed. - -(*********) -Lemma Dx : - forall (D:R -> Prop) (x0:R), D_in (fun x:R => x) (fun x:R => 1) D x0. -Proof. - unfold D_in; unfold Rdiv; intros; unfold limit1_in; - unfold limit_in; intros; simpl; split with eps; - split; auto. - intros; elim H0; clear H0; intros; unfold D_x in H0; elim H0; intros; - rewrite (Rinv_r (x - x0) (Rminus_eq_contra x x0 (sym_not_eq H3))); - unfold Rdist; rewrite (Rminus_diag_eq 1 1 (refl_equal 1)); - unfold Rabs; case (Rcase_abs 0) as [Hlt|Hge]. - - absurd (0 < 0); auto. - red in |- *; intro; apply (Rlt_irrefl 0 Hlt). - - unfold Rgt in H; assumption. -Qed. - -(*********) -Lemma Dadd : - forall (D:R -> Prop) (df dg f g:R -> R) (x0:R), - D_in f df D x0 -> - D_in g dg D x0 -> - D_in (fun x:R => f x + g x) (fun x:R => df x + dg x) D x0. -Proof. - unfold D_in; intros; - generalize - (limit_plus (fun x:R => (f x - f x0) * / (x - x0)) - (fun x:R => (g x - g x0) * / (x - x0)) (D_x D x0) ( - df x0) (dg x0) x0 H H0); clear H H0; unfold limit1_in; - unfold limit_in; simpl; intros; elim (H eps H0); - clear H; intros; elim H; clear H; intros; split with x; - split; auto; intros; generalize (H1 x1 H2); clear H1; - intro; rewrite (Rmult_comm (f x1 - f x0) (/ (x1 - x0))) in H1; - rewrite (Rmult_comm (g x1 - g x0) (/ (x1 - x0))) in H1; - rewrite <- (Rmult_plus_distr_l (/ (x1 - x0)) (f x1 - f x0) (g x1 - g x0)) - in H1; - rewrite (Rmult_comm (/ (x1 - x0)) (f x1 - f x0 + (g x1 - g x0))) in H1; - cut (f x1 - f x0 + (g x1 - g x0) = f x1 + g x1 - (f x0 + g x0)). - - intro; rewrite H3 in H1; assumption. - - ring. -Qed. - -(*********) -Lemma Dmult : - forall (D:R -> Prop) (df dg f g:R -> R) (x0:R), - D_in f df D x0 -> - D_in g dg D x0 -> - D_in (fun x:R => f x * g x) (fun x:R => df x * g x + f x * dg x) D x0. -Proof. - intros; unfold D_in; generalize H H0; intros; unfold D_in in H, H0; - generalize (cont_deriv f df D x0 H1); unfold continue_in; - intro; - generalize - (limit_mul (fun x:R => (g x - g x0) * / (x - x0)) ( - fun x:R => f x) (D_x D x0) (dg x0) (f x0) x0 H0 H3); - intro; cut (limit1_in (fun x:R => g x0) (D_x D x0) (g x0) x0). - - intro; - generalize - (limit_mul (fun x:R => (f x - f x0) * / (x - x0)) ( - fun _:R => g x0) (D_x D x0) (df x0) (g x0) x0 H H5); - clear H H0 H1 H2 H3 H5; intro; - generalize - (limit_plus (fun x:R => (f x - f x0) * / (x - x0) * g x0) - (fun x:R => (g x - g x0) * / (x - x0) * f x) ( - D_x D x0) (df x0 * g x0) (dg x0 * f x0) x0 H H4); - clear H4 H; intro; unfold limit1_in in H; unfold limit_in in H; - simpl in H; unfold limit1_in; unfold limit_in; - simpl; intros; elim (H eps H0); clear H; intros; - elim H; clear H; intros; split with x; split; auto; - intros; generalize (H1 x1 H2); clear H1; intro; - rewrite (Rmult_comm (f x1 - f x0) (/ (x1 - x0))) in H1; - rewrite (Rmult_comm (g x1 - g x0) (/ (x1 - x0))) in H1; - rewrite (Rmult_assoc (/ (x1 - x0)) (f x1 - f x0) (g x0)) in H1; - rewrite (Rmult_assoc (/ (x1 - x0)) (g x1 - g x0) (f x1)) in H1; - rewrite <- - (Rmult_plus_distr_l (/ (x1 - x0)) ((f x1 - f x0) * g x0) - ((g x1 - g x0) * f x1)) in H1; - rewrite - (Rmult_comm (/ (x1 - x0)) ((f x1 - f x0) * g x0 + (g x1 - g x0) * f x1)) - in H1; rewrite (Rmult_comm (dg x0) (f x0)) in H1; - cut - ((f x1 - f x0) * g x0 + (g x1 - g x0) * f x1 = f x1 * g x1 - f x0 * g x0). - + intro; rewrite H3 in H1; assumption. - + ring. - - unfold limit1_in; unfold limit_in; simpl; intros; - split with eps; split; auto; intros; elim (Rdist_refl (g x0) (g x0)); - intros a b; rewrite (b (eq_refl (g x0))); unfold Rgt in H; - assumption. -Qed. - -(*********) -Lemma Dmult_const : - forall (D:R -> Prop) (f df:R -> R) (x0 a:R), - D_in f df D x0 -> D_in (fun x:R => a * f x) (fun x:R => a * df x) D x0. -Proof. - intros; - generalize (Dmult D (fun _:R => 0) df (fun _:R => a) f x0 (Dconst D a x0) H); - unfold D_in; intros; rewrite (Rmult_0_l (f x0)) in H0; - rewrite (let (H1, H2) := Rplus_ne (a * df x0) in H2) in H0; - assumption. -Qed. - -(*********) -Lemma Dopp : - forall (D:R -> Prop) (f df:R -> R) (x0:R), - D_in f df D x0 -> D_in (fun x:R => - f x) (fun x:R => - df x) D x0. -Proof. - intros; generalize (Dmult_const D f df x0 (-1) H); unfold D_in; - unfold limit1_in; unfold limit_in; - intros; generalize (H0 eps H1); clear H0; intro; elim H0; - clear H0; intros; elim H0; clear H0; simpl; - intros; split with x; split; auto. - intros; generalize (H2 x1 H3); clear H2; intro. - replace (- f x1 - - f x0) with (-1 * f x1 - -1 * f x0) by ring. - replace (- df x0) with (-1 * df x0) by ring. - exact H2. -Qed. - -(*********) -Lemma Dminus : - forall (D:R -> Prop) (df dg f g:R -> R) (x0:R), - D_in f df D x0 -> - D_in g dg D x0 -> - D_in (fun x:R => f x - g x) (fun x:R => df x - dg x) D x0. -Proof. - unfold Rminus; intros; generalize (Dopp D g dg x0 H0); intro; - apply (Dadd D df (fun x:R => - dg x) f (fun x:R => - g x) x0); - assumption. -Qed. - -(*********) -Lemma Dx_pow_n : - forall (n:nat) (D:R -> Prop) (x0:R), - D_in (fun x:R => x ^ n) (fun x:R => INR n * x ^ (n - 1)) D x0. -Proof. - simple induction n; intros. - - simpl; rewrite Rmult_0_l; apply Dconst. - - intros; cut (n0 = (S n0 - 1)%nat); - [ intro a; rewrite <- a; clear a | simpl; symmetry; apply Nat.sub_0_r ]. - generalize - (Dmult D (fun _:R => 1) (fun x:R => INR n0 * x ^ (n0 - 1)) ( - fun x:R => x) (fun x:R => x ^ n0) x0 (Dx D x0) ( - H D x0)); unfold D_in; unfold limit1_in; - unfold limit_in; simpl; intros; elim (H0 eps H1); - clear H0; intros; elim H0; clear H0; intros; split with x; - split; auto. - intros; generalize (H2 x1 H3); clear H2 H3; intro; - rewrite (let (H1, H2) := Rmult_ne (x0 ^ n0) in H2) in H2; - rewrite (tech_pow_Rmult x1 n0) in H2; rewrite (tech_pow_Rmult x0 n0) in H2; - rewrite (Rmult_comm (INR n0) (x0 ^ (n0 - 1))) in H2; - rewrite <- (Rmult_assoc x0 (x0 ^ (n0 - 1)) (INR n0)) in H2; - rewrite (tech_pow_Rmult x0 (n0 - 1)) in H2; elim (Peano_dec.eq_nat_dec n0 0) ; intros cond. - + rewrite cond in H2; rewrite cond; simpl in H2; simpl; - cut (1 + x0 * 1 * 0 = 1 * 1); - [ intro A; rewrite A in H2; assumption | ring ]. - + cut (n0 <> 0%nat -> S (n0 - 1) = n0); [ intro | lia ]; - rewrite (H3 cond) in H2; rewrite (Rmult_comm (x0 ^ n0) (INR n0)) in H2; - rewrite (tech_pow_Rplus x0 n0 n0) in H2; assumption. -Qed. - -(*********) -Lemma Dcomp : - forall (Df Dg:R -> Prop) (df dg f g:R -> R) (x0:R), - D_in f df Df x0 -> - D_in g dg Dg (f x0) -> - D_in (fun x:R => g (f x)) (fun x:R => df x * dg (f x)) (Dgf Df Dg f) x0. -Proof. - intros Df Dg df dg f g x0 H H0; generalize H H0; unfold D_in; - unfold Rdiv; intros; - generalize - (limit_comp f (fun x:R => (g x - g (f x0)) * / (x - f x0)) ( - D_x Df x0) (D_x Dg (f x0)) (f x0) (dg (f x0)) x0); - intro; generalize (cont_deriv f df Df x0 H); intro; - unfold continue_in in H4; generalize (H3 H4 H2); clear H3; - intro; - generalize - (limit_mul (fun x:R => (g (f x) - g (f x0)) * / (f x - f x0)) - (fun x:R => (f x - f x0) * / (x - x0)) - (Dgf (D_x Df x0) (D_x Dg (f x0)) f) (dg (f x0)) ( - df x0) x0 H3); intro; - cut - (limit1_in (fun x:R => (f x - f x0) * / (x - x0)) - (Dgf (D_x Df x0) (D_x Dg (f x0)) f) (df x0) x0). - - intro; generalize (H5 H6); clear H5; intro; - generalize - (limit_mul (fun x:R => (f x - f x0) * / (x - x0)) ( - fun x:R => dg (f x0)) (D_x Df x0) (df x0) (dg (f x0)) x0 H1 - (limit_free (fun x:R => dg (f x0)) (D_x Df x0) x0 x0)); - intro; unfold limit1_in; unfold limit_in; - simpl; unfold limit1_in in H5, H7; unfold limit_in in H5, H7; - simpl in H5, H7; intros; elim (H5 eps H8); elim (H7 eps H8); - clear H5 H7; intros; elim H5; elim H7; clear H5 H7; - intros; split with (Rmin x x1); split. - + elim (Rmin_Rgt x x1 0); intros a b; apply (b (conj H9 H5)); clear a b. - + intros; elim H11; clear H11; intros; elim (Rmin_Rgt x x1 (Rdist x2 x0)); - intros a b; clear b; unfold Rgt in a; elim (a H12); - clear H5 a; intros; unfold D_x, Dgf in H11, H7, H10; - clear H12; elim (Req_dec (f x2) (f x0)); intro. - * elim H11; clear H11; intros; elim H11; clear H11; intros; - generalize (H10 x2 (conj (conj H11 H14) H5)); intro; - rewrite (Rminus_diag_eq (f x2) (f x0) H12) in H16; - rewrite (Rmult_0_l (/ (x2 - x0))) in H16; - rewrite (Rmult_0_l (dg (f x0))) in H16; rewrite H12; - rewrite (Rminus_diag_eq (g (f x0)) (g (f x0)) (eq_refl (g (f x0)))); - rewrite (Rmult_0_l (/ (x2 - x0))); assumption. - * clear H10 H5; elim H11; clear H11; intros; elim H5; clear H5; intros; - cut - (((Df x2 /\ x0 <> x2) /\ Dg (f x2) /\ f x0 <> f x2) /\ Rdist x2 x0 < x1); - auto; intro; generalize (H7 x2 H14); intro; - generalize (Rminus_eq_contra (f x2) (f x0) H12); intro; - rewrite - (Rmult_assoc (g (f x2) - g (f x0)) (/ (f x2 - f x0)) - ((f x2 - f x0) * / (x2 - x0))) in H15; - rewrite <- (Rmult_assoc (/ (f x2 - f x0)) (f x2 - f x0) (/ (x2 - x0))) - in H15; rewrite (Rinv_l (f x2 - f x0) H16) in H15; - rewrite (let (H1, H2) := Rmult_ne (/ (x2 - x0)) in H2) in H15; - rewrite (Rmult_comm (df x0) (dg (f x0))); assumption. - - clear H5 H3 H4 H2; unfold limit1_in; unfold limit_in; - simpl; unfold limit1_in in H1; unfold limit_in in H1; - simpl in H1; intros; elim (H1 eps H2); clear H1; intros; - elim H1; clear H1; intros; split with x; split; auto; - intros; unfold D_x, Dgf in H4, H3; elim H4; clear H4; - intros; elim H4; clear H4; intros; exact (H3 x1 (conj H4 H5)). -Qed. - -(*********) -Lemma D_pow_n : - forall (n:nat) (D:R -> Prop) (x0:R) (expr dexpr:R -> R), - D_in expr dexpr D x0 -> - D_in (fun x:R => expr x ^ n) - (fun x:R => INR n * expr x ^ (n - 1) * dexpr x) ( - Dgf D D expr) x0. -Proof. - intros n D x0 expr dexpr H; - generalize - (Dcomp D D dexpr (fun x:R => INR n * x ^ (n - 1)) expr ( - fun x:R => x ^ n) x0 H (Dx_pow_n n D (expr x0))); - intro; unfold D_in; unfold limit1_in; - unfold limit_in; simpl; intros; unfold D_in in H0; - unfold limit1_in in H0; unfold limit_in in H0; simpl in H0; - elim (H0 eps H1); clear H0; intros; elim H0; clear H0; - intros; split with x; split; intros; auto. - cut - (dexpr x0 * (INR n * expr x0 ^ (n - 1)) = - INR n * expr x0 ^ (n - 1) * dexpr x0); - [ intro Rew; rewrite <- Rew; exact (H2 x1 H3) | ring ]. -Qed. diff --git a/stdlib/theories/Reals/Reals.v b/stdlib/theories/Reals/Reals.v deleted file mode 100644 index 8b532922d870..000000000000 --- a/stdlib/theories/Reals/Reals.v +++ /dev/null @@ -1,33 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* 0`` - - Sup: for goals like ``?1 0. -Proof. - intro; red; intro; apply (not_O_INR (fact n) (fact_neq_0 n)); - assumption. -Qed. - -(*********) -Lemma fact_simpl : forall n:nat, fact (S n) = (S n * fact n)%nat. -Proof. - intro; reflexivity. -Qed. - -(*********) -Lemma simpl_fact : - forall n:nat, / INR (fact (S n)) * / / INR (fact n) = / INR (S n). -Proof. - intro; rewrite (Rinv_inv (INR (fact n))); - unfold fact at 1; cbv beta iota; fold fact; - rewrite (mult_INR (S n) (fact n)); - rewrite (Rinv_mult (INR (S n)) (INR (fact n))). - rewrite (Rmult_assoc (/ INR (S n)) (/ INR (fact n)) (INR (fact n))); - rewrite (Rinv_l (INR (fact n)) (INR_fact_neq_0 n)); - apply (let (H1, H2) := Rmult_ne (/ INR (S n)) in H1). -Qed. - -(*******************************) -(** * Power *) -(*******************************) -(*********) - -Infix "^" := pow : R_scope. - -Lemma pow_O : forall x:R, x ^ 0 = 1. -Proof. - reflexivity. -Qed. - -Lemma pow_1 : forall x:R, x ^ 1 = x. -Proof. - simpl; auto with real. -Qed. - -Lemma pow_add : forall (x:R) (n m:nat), x ^ (n + m) = x ^ n * x ^ m. -Proof. - intros x n; elim n; simpl; auto with real. - intros n0 H' m; rewrite H'; auto with real. -Qed. - -Lemma Rpow_mult_distr : forall (x y:R) (n:nat), (x * y) ^ n = x^n * y^n. -Proof. -intros x y n ; induction n. -- field. -- simpl. - repeat (rewrite Rmult_assoc) ; apply Rmult_eq_compat_l. - rewrite IHn ; field. -Qed. - -Lemma pow_nonzero : forall (x:R) (n:nat), x <> 0 -> x ^ n <> 0. -Proof. - intro; simple induction n; simpl. - - intro; red; intro; apply R1_neq_R0; assumption. - - intros; red; intro; elim (Rmult_integral x (x ^ n0) H1). - + intro; auto. - + apply H; assumption. -Qed. - -#[global] -Hint Resolve pow_O pow_1 pow_add pow_nonzero: real. - -Lemma pow_RN_plus : - forall (x:R) (n m:nat), x <> 0 -> x ^ n = x ^ (n + m) * / x ^ m. -Proof. - intros x n m H. - apply (Rmult_eq_reg_r (x ^ m)); cycle 1. - { now apply pow_nonzero. } - rewrite Rmult_assoc, Rmult_inv_l, Rmult_1_r by (now apply pow_nonzero). - now rewrite pow_add. -Qed. - -Lemma pow_lt : forall (x:R) (n:nat), 0 < x -> 0 < x ^ n. -Proof. - intros x n; elim n; simpl; auto with real. - intros n0 H' H'0; replace 0 with (x * 0); auto with real. -Qed. -#[global] -Hint Resolve pow_lt: real. - -Lemma Rlt_pow_R1 : forall (x:R) (n:nat), 1 < x -> (0 < n)%nat -> 1 < x ^ n. -Proof. - intros x n; elim n; simpl; auto with real. - - intros H' H'0; exfalso. apply (Nat.lt_irrefl 0); assumption. - - intros n0; case n0. - + simpl; rewrite Rmult_1_r; auto. - + intros n1 H' H'0 H'1. - replace 1 with (1 * 1); auto with real. - apply Rlt_trans with (r2 := x * 1); auto with real. - apply Rmult_lt_compat_l; auto with real. - * apply Rlt_trans with (r2 := 1); auto with real. - * apply H'; auto with arith. -Qed. -#[global] -Hint Resolve Rlt_pow_R1: real. - -Lemma Rlt_pow : forall (x:R) (n m:nat), 1 < x -> (n < m)%nat -> x ^ n < x ^ m. -Proof. - intros x n m H' H'0; replace m with (m - n + n)%nat. - - rewrite pow_add. - pattern (x ^ n) at 1; replace (x ^ n) with (1 * x ^ n); - auto with real. - apply Rminus_lt. - repeat rewrite (fun y:R => Rmult_comm y (x ^ n)); - rewrite <- Rmult_minus_distr_l. - replace 0 with (x ^ n * 0); auto with real. - apply Rmult_lt_compat_l; auto with real. - + apply pow_lt; auto with real. - apply Rlt_trans with (r2 := 1); auto with real. - + apply Rlt_minus; auto with real. - apply Rlt_pow_R1; [ | apply lt_minus_O_lt ]; assumption. - - apply Nat.sub_add, Nat.lt_le_incl; assumption. -Qed. -#[global] -Hint Resolve Rlt_pow: real. - -(*********) -Lemma tech_pow_Rmult : forall (x:R) (n:nat), x * x ^ n = x ^ S n. -Proof. - simple induction n; simpl; trivial. -Qed. - -(*********) -Lemma tech_pow_Rplus : - forall (x:R) (a n:nat), x ^ a + INR n * x ^ a = INR (S n) * x ^ a. -Proof. - intros; pattern (x ^ a) at 1; - rewrite <- (let (H1, H2) := Rmult_ne (x ^ a) in H1); - rewrite (Rmult_comm (INR n) (x ^ a)); - rewrite <- (Rmult_plus_distr_l (x ^ a) 1 (INR n)); - rewrite (Rplus_comm 1 (INR n)); rewrite <- (S_INR n); - apply Rmult_comm. -Qed. - -Lemma poly : forall (n:nat) (x:R), 0 < x -> 1 + INR n * x <= (1 + x) ^ n. -Proof. - intros; elim n. - - simpl; cut (1 + 0 * x = 1). - + intro; rewrite H0; unfold Rle; right; reflexivity. - + ring. - - intros; unfold pow; fold pow; - apply - (Rle_trans (1 + INR (S n0) * x) ((1 + x) * (1 + INR n0 * x)) - ((1 + x) * (1 + x) ^ n0)). - + cut ((1 + x) * (1 + INR n0 * x) = 1 + INR (S n0) * x + INR n0 * (x * x)). - * intro; rewrite H1; pattern (1 + INR (S n0) * x) at 1; - rewrite <- (let (H1, H2) := Rplus_ne (1 + INR (S n0) * x) in H1); - apply Rplus_le_compat_l; elim n0; intros. - -- simpl; rewrite Rmult_0_l; unfold Rle; right; auto. - -- unfold Rle; left; generalize Rmult_gt_0_compat; unfold Rgt; - intro; fold (Rsqr x); - apply (H3 (INR (S n1)) (Rsqr x) (lt_INR_0 (S n1) (Nat.lt_0_succ n1))); - fold (x > 0) in H; - apply (Rlt_0_sqr x (Rlt_dichotomy_converse x 0 (or_intror (x < 0) H))). - * rewrite (S_INR n0); ring. - + unfold Rle in H0; elim H0; intro. - * unfold Rle; left; apply Rmult_lt_compat_l. - -- rewrite Rplus_comm; apply (Rplus_le_lt_0_compat _ _ (Rlt_le 0 x H)); - apply Rlt_0_1. - -- assumption. - * rewrite H1; unfold Rle; right; trivial. -Qed. - -Lemma Power_monotonic : - forall (x:R) (m n:nat), - Rabs x > 1 -> (m <= n)%nat -> Rabs (x ^ m) <= Rabs (x ^ n). -Proof. - intros x m n H; induction n as [| n Hrecn]; intros; inversion H0. - - unfold Rle; right; reflexivity. - - unfold Rle; right; reflexivity. - - apply (Rle_trans (Rabs (x ^ m)) (Rabs (x ^ n)) (Rabs (x ^ S n))). - + apply Hrecn; assumption. - + simpl; rewrite Rabs_mult. - pattern (Rabs (x ^ n)) at 1. - rewrite <- Rmult_1_r. - rewrite (Rmult_comm (Rabs x) (Rabs (x ^ n))). - apply Rmult_le_compat_l. - * apply Rabs_pos. - * unfold Rgt in H. - apply Rlt_le; assumption. -Qed. - -Lemma RPow_abs : forall (x:R) (n:nat), Rabs x ^ n = Rabs (x ^ n). -Proof. - intro; simple induction n; simpl. - - symmetry; apply Rabs_pos_eq; apply Rlt_le; apply Rlt_0_1. - - intros; rewrite H; symmetry; apply Rabs_mult. -Qed. - - -Lemma Pow_x_infinity : - forall x:R, - Rabs x > 1 -> - forall b:R, - exists N : nat, (forall n:nat, (n >= N)%nat -> Rabs (x ^ n) >= b). -Proof. - intros; elim (archimed (b * / (Rabs x - 1))); intros; clear H1; - cut (exists N : nat, INR N >= b * / (Rabs x - 1)). - - intro; elim H1; clear H1; intros; exists x0; intros; - apply (Rge_trans (Rabs (x ^ n)) (Rabs (x ^ x0)) b). - { apply Rle_ge; apply Power_monotonic; assumption. } - rewrite <- RPow_abs; assert (Rabs x = 1 + (Rabs x - 1)) by ring. - rewrite H3; - apply (Rge_trans ((1 + (Rabs x - 1)) ^ x0) (1 + INR x0 * (Rabs x - 1)) b). - + apply Rle_ge; apply poly; fold (Rabs x - 1 > 0); apply Rgt_minus; - assumption. - + apply (Rge_trans (1 + INR x0 * (Rabs x - 1)) (INR x0 * (Rabs x - 1)) b). - { apply Rle_ge; apply Rlt_le; rewrite (Rplus_comm 1 (INR x0 * (Rabs x - 1))); - pattern (INR x0 * (Rabs x - 1)) at 1; - rewrite <- (let (H1, H2) := Rplus_ne (INR x0 * (Rabs x - 1)) in H1); - apply Rplus_lt_compat_l; apply Rlt_0_1. } - cut (b = b * / (Rabs x - 1) * (Rabs x - 1)). - * intros; rewrite H4; apply Rmult_ge_compat_r. - { apply Rge_minus; unfold Rge; left; assumption. } - assumption. - * rewrite Rmult_assoc; rewrite Rinv_l. - { ring. } - apply Rlt_dichotomy_converse; right; apply Rgt_minus; assumption. - - assert ((0 <= up (b * / (Rabs x - 1)))%Z \/ (up (b * / (Rabs x - 1)) <= 0)%Z) - by apply Z.le_ge_cases. - elim H1; intro. - + elim (IZN (up (b * / (Rabs x - 1))) H2); intros; exists x0; - apply - (Rge_trans (INR x0) (IZR (up (b * / (Rabs x - 1)))) (b * / (Rabs x - 1))). - * rewrite INR_IZR_INZ; apply IZR_ge. Lia.lia. - * unfold Rge; left; assumption. - + exists 0%nat; - apply - (Rge_trans (INR 0) (IZR (up (b * / (Rabs x - 1)))) (b * / (Rabs x - 1))). - * rewrite INR_IZR_INZ; apply IZR_ge; simpl. Lia.lia. - * unfold Rge; left; assumption. -Qed. - -Lemma pow_ne_zero : forall n:nat, n <> 0%nat -> 0 ^ n = 0. -Proof. - simple induction n. - - simpl; auto. - intros; elim H; reflexivity. - - intros; simpl; apply Rmult_0_l. -Qed. - -Lemma pow_inv x n : (/ x)^n = / x^n. -Proof. -induction n as [|n IH] ; simpl. -- apply eq_sym, Rinv_1. -- rewrite Rinv_mult. - now apply f_equal. -Qed. - -Lemma Rinv_pow_depr : forall (x:R) (n:nat), x <> 0 -> / x ^ n = (/ x) ^ n. -Proof. -intros x n _. -apply eq_sym, pow_inv. -Qed. - -#[deprecated(since="8.16",note="Use pow_inv.")] -Notation Rinv_pow := Rinv_pow_depr. - -Lemma pow_lt_1_zero : - forall x:R, - Rabs x < 1 -> - forall y:R, - 0 < y -> - exists N : nat, (forall n:nat, (n >= N)%nat -> Rabs (x ^ n) < y). -Proof. - intros; elim (Req_dec x 0); intro. - - exists 1%nat; rewrite H1; intros n GE; rewrite pow_ne_zero. - + rewrite Rabs_R0; assumption. - + inversion GE; auto. - - assert (Rabs (/ x) > 1). { - rewrite <- (Rinv_inv 1). - rewrite Rabs_inv. - unfold Rgt; apply Rinv_lt_contravar. - - apply Rmult_lt_0_compat. - + apply Rabs_pos_lt. - assumption. - + rewrite Rinv_1; apply Rlt_0_1. - - rewrite Rinv_1; assumption. - } - elim (Pow_x_infinity (/ x) H2 (/ y + 1)); intros N. - exists N; intros; rewrite <- (Rinv_inv y). - rewrite <- (Rinv_inv (Rabs (x ^ n))). - apply Rinv_lt_contravar. - + apply Rmult_lt_0_compat. - * apply Rinv_0_lt_compat. - assumption. - * apply Rinv_0_lt_compat. - apply Rabs_pos_lt. - apply pow_nonzero. - assumption. - + rewrite <- Rabs_inv, <- pow_inv. - apply (Rlt_le_trans (/ y) (/ y + 1) (Rabs ((/ x) ^ n))). - * pattern (/ y) at 1. - rewrite <- (let (H1, H2) := Rplus_ne (/ y) in H1). - apply Rplus_lt_compat_l. - apply Rlt_0_1. - * apply Rge_le. - apply H3. - assumption. - -Qed. - -Lemma pow_R1 : forall (r:R) (n:nat), r ^ n = 1 -> Rabs r = 1 \/ n = 0%nat. -Proof. - intros r n H'. - case (Req_dec (Rabs r) 1); auto; intros H'1. - case (Rdichotomy _ _ H'1); intros H'2. - - generalize H'; case n; auto. - intros n0 H'0. - cut (r <> 0); [ intros Eq1 | idtac ]. - + assert (Eq2: Rabs r <> 0) by (apply Rabs_no_R0; auto). - absurd (Rabs (/ r) ^ 0 < Rabs (/ r) ^ S n0); auto. - * replace (Rabs (/ r) ^ S n0) with 1. - -- simpl; apply Rlt_irrefl; auto. - -- rewrite Rabs_inv, pow_inv. - rewrite RPow_abs; auto. - rewrite H'0; rewrite Rabs_right; auto with real rorders. - * apply Rlt_pow; auto with arith. - rewrite Rabs_inv. - apply Rmult_lt_reg_l with (r := Rabs r). - -- case (Rabs_pos r); auto. - intros H'3; case Eq2; auto. - -- rewrite Rmult_1_r; rewrite Rinv_r; auto with real. - + red; intro; absurd (r ^ S n0 = 1); auto. - simpl; rewrite H; rewrite Rmult_0_l; auto with real. - - generalize H'; case n; auto. - intros n0 H'0. - cut (r <> 0); [ intros Eq1 | auto with real ]. - + cut (Rabs r <> 0); [ intros Eq2 | apply Rabs_no_R0 ]; auto. - absurd (Rabs r ^ 0 < Rabs r ^ S n0); auto with real arith. - repeat rewrite RPow_abs; rewrite H'0; simpl; auto with real. - + red; intro; absurd (r ^ S n0 = 1); auto. - simpl; rewrite H; rewrite Rmult_0_l; auto with real. -Qed. - -Lemma pow_Rsqr : forall (x:R) (n:nat), x ^ (2 * n) = Rsqr x ^ n. -Proof. - intros; induction n as [| n Hrecn]. - - reflexivity. - - replace (2 * S n)%nat with (S (S (2 * n))). - + replace (x ^ S (S (2 * n))) with (x * x * x ^ (2 * n)). - * rewrite Hrecn; reflexivity. - * simpl; ring. - + ring. -Qed. - -Lemma pow_le : forall (a:R) (n:nat), 0 <= a -> 0 <= a ^ n. -Proof. - intros; induction n as [| n Hrecn]. - - simpl; left; apply Rlt_0_1. - - simpl; apply Rmult_le_pos; assumption. -Qed. - -(**********) -Lemma pow_1_even : forall n:nat, (-1) ^ (2 * n) = 1. -Proof. - intro; induction n as [| n Hrecn]. - - reflexivity. - - replace (2 * S n)%nat with (2 + 2 * n)%nat by ring. - rewrite pow_add; rewrite Hrecn; simpl; ring. -Qed. - -(**********) -Lemma pow_1_odd : forall n:nat, (-1) ^ S (2 * n) = -1. -Proof. - intro; replace (S (2 * n)) with (2 * n + 1)%nat by ring. - rewrite pow_add; rewrite pow_1_even; simpl; ring. -Qed. - -(**********) -Lemma pow_1_abs : forall n:nat, Rabs ((-1) ^ n) = 1. -Proof. - intro; induction n as [| n Hrecn]. - - simpl; apply Rabs_R1. - - replace (S n) with (n + 1)%nat; [ rewrite pow_add | ring ]. - rewrite Rabs_mult. - rewrite Hrecn; rewrite Rmult_1_l; simpl; rewrite Rmult_1_r. - change (-1) with (-(1)). - rewrite Rabs_Ropp; apply Rabs_R1. -Qed. - -Lemma pow_mult : forall (x:R) (n1 n2:nat), x ^ (n1 * n2) = (x ^ n1) ^ n2. -Proof. - intros; induction n2 as [| n2 Hrecn2]. - - simpl; replace (n1 * 0)%nat with 0%nat; [ reflexivity | ring ]. - - replace (n1 * S n2)%nat with (n1 * n2 + n1)%nat. - + replace (S n2) with (n2 + 1)%nat by ring. - do 2 rewrite pow_add. - rewrite Hrecn2. - simpl. - ring. - + ring. -Qed. - -Lemma pow_incr : forall (x y:R) (n:nat), 0 <= x <= y -> x ^ n <= y ^ n. -Proof. - intros. - induction n as [| n Hrecn]. - - right; reflexivity. - - simpl. - elim H; intros. - apply Rle_trans with (y * x ^ n). - + do 2 rewrite <- (Rmult_comm (x ^ n)). - apply Rmult_le_compat_l. - * apply pow_le; assumption. - * assumption. - + apply Rmult_le_compat_l. - * apply Rle_trans with x; assumption. - * apply Hrecn. -Qed. - -Lemma pow_R1_Rle : forall (x:R) (k:nat), 1 <= x -> 1 <= x ^ k. -Proof. - intros. - induction k as [| k Hreck]. - - right; reflexivity. - - simpl. - apply Rle_trans with (x * 1). - + rewrite Rmult_1_r; assumption. - + apply Rmult_le_compat_l. - * left; apply Rlt_le_trans with 1; [ apply Rlt_0_1 | assumption ]. - * exact Hreck. -Qed. - -Lemma Rle_pow : - forall (x:R) (m n:nat), 1 <= x -> (m <= n)%nat -> x ^ m <= x ^ n. -Proof. - intros. - replace n with (n - m + m)%nat. - - rewrite pow_add. - rewrite Rmult_comm. - pattern (x ^ m) at 1; rewrite <- Rmult_1_r. - apply Rmult_le_compat_l. - + apply pow_le; left; apply Rlt_le_trans with 1; [ apply Rlt_0_1 | assumption ]. - + apply pow_R1_Rle; assumption. - - apply Nat.sub_add; assumption. -Qed. - -Lemma pow1 : forall n:nat, 1 ^ n = 1. -Proof. - intro; induction n as [| n Hrecn]. - - reflexivity. - - simpl; rewrite Hrecn; rewrite Rmult_1_r; reflexivity. -Qed. - -Lemma pow_Rabs : forall (x:R) (n:nat), x ^ n <= Rabs x ^ n. -Proof. - intros; induction n as [| n Hrecn]. - - right; reflexivity. - - simpl; destruct (Rcase_abs x) as [Hlt|Hle]. - + apply Rle_trans with (Rabs (x * x ^ n)). - * apply RRle_abs. - * rewrite Rabs_mult. - apply Rmult_le_compat_l. - -- apply Rabs_pos. - -- right; symmetry; apply RPow_abs. - + pattern (Rabs x) at 1; rewrite (Rabs_right x Hle); - apply Rmult_le_compat_l. - * apply Rge_le; exact Hle. - * apply Hrecn. -Qed. - -Lemma pow_maj_Rabs : forall (x y:R) (n:nat), Rabs y <= x -> y ^ n <= x ^ n. -Proof. - intros; cut (0 <= x). - - intro; apply Rle_trans with (Rabs y ^ n). - + apply pow_Rabs. - + induction n as [| n Hrecn]. - * right; reflexivity. - * simpl; apply Rle_trans with (x * Rabs y ^ n). - -- do 2 rewrite <- (Rmult_comm (Rabs y ^ n)). - apply Rmult_le_compat_l. - ++ apply pow_le; apply Rabs_pos. - ++ assumption. - -- apply Rmult_le_compat_l. - ++ apply H0. - ++ apply Hrecn. - - apply Rle_trans with (Rabs y); [ apply Rabs_pos | exact H ]. -Qed. - -Lemma Rsqr_pow2 : forall x, Rsqr x = x ^ 2. -Proof. -intros; unfold Rsqr; simpl; rewrite Rmult_1_r; reflexivity. -Qed. - - -(*******************************) -(** * PowerRZ *) -(*******************************) -(*i Due to L.Thery i*) - -Section PowerRZ. - -Local Coercion Z_of_nat : nat >-> Z. - -(* the following section should probably be somewhere else, but not sure where *) -Section Z_compl. - -Local Open Scope Z_scope. - -(* Provides a way to reason directly on Z in terms of nats instead of positive *) -Inductive Z_spec (x : Z) : Z -> Type := -| ZintNull : x = 0 -> Z_spec x 0 -| ZintPos (n : nat) : x = n -> Z_spec x n -| ZintNeg (n : nat) : x = - n -> Z_spec x (- n). - -Lemma intP (x : Z) : Z_spec x x. -Proof. - destruct x as [|p|p]. - - now apply ZintNull. - - rewrite <-positive_nat_Z at 2. - apply ZintPos. - now rewrite positive_nat_Z. - - rewrite <-Pos2Z.opp_pos. - rewrite <-positive_nat_Z at 2. - apply ZintNeg. - now rewrite positive_nat_Z. -Qed. - -End Z_compl. - -Definition powerRZ (x:R) (n:Z) := - match n with - | Z0 => 1 - | Zpos p => x ^ Pos.to_nat p - | Zneg p => / x ^ Pos.to_nat p - end. - -Local Infix "^Z" := powerRZ (at level 30, right associativity) : R_scope. - -Lemma Zpower_NR0 : - forall (x:Z) (n:nat), (0 <= x)%Z -> (0 <= Zpower_nat x n)%Z. -Proof. - induction n; unfold Zpower_nat; simpl; auto with zarith. -Qed. - -Lemma powerRZ_O : forall x:R, x ^Z 0 = 1. -Proof. - reflexivity. -Qed. - -Lemma powerRZ_1 : forall x:R, x ^Z Z.succ 0 = x. -Proof. - simpl; auto with real. -Qed. - -Lemma powerRZ_NOR : forall (x:R) (z:Z), x <> 0 -> x ^Z z <> 0. -Proof. - destruct z; simpl; auto with real. -Qed. - -Lemma powerRZ_pos_sub (x:R) (n m:positive) : x <> 0 -> - x ^Z (Z.pos_sub n m) = x ^ Pos.to_nat n * / x ^ Pos.to_nat m. -Proof. - intro Hx. - rewrite Z.pos_sub_spec. - case Pos.compare_spec; intro H; simpl. - - subst; symmetry; auto with real. - - rewrite Pos2Nat.inj_sub by trivial. - rewrite Pos2Nat.inj_lt in H. - rewrite (pow_RN_plus x _ (Pos.to_nat n)) by auto with real. - rewrite Nat.sub_add; [ | apply Nat.lt_le_incl; assumption ]. - rewrite Rinv_mult, Rinv_inv; auto with real. - - rewrite Pos2Nat.inj_sub by trivial. - rewrite Pos2Nat.inj_lt in H. - rewrite (pow_RN_plus x _ (Pos.to_nat m)) by auto with real. - rewrite Nat.sub_add; [ reflexivity | apply Nat.lt_le_incl; assumption ]. -Qed. - -Lemma powerRZ_add : - forall (x:R) (n m:Z), x <> 0 -> x ^Z (n + m) = x ^Z n * x ^Z m. -Proof. - intros x [|n|n] [|m|m]; simpl; intros; auto with real. - - (* + + *) - rewrite Pos2Nat.inj_add; auto with real. - - (* + - *) - now apply powerRZ_pos_sub. - - (* - + *) - rewrite Rmult_comm. now apply powerRZ_pos_sub. - - (* - - *) - rewrite Pos2Nat.inj_add; auto with real. - rewrite pow_add; auto with real. - apply Rinv_mult. -Qed. -#[local] -Hint Resolve powerRZ_O powerRZ_1 powerRZ_NOR powerRZ_add: real. - -Lemma Zpower_nat_powerRZ : - forall n m:nat, IZR (Zpower_nat (Z.of_nat n) m) = INR n ^Z Z.of_nat m. -Proof. - intros n m; elim m; simpl; auto with real. - intros m1 H'; rewrite SuccNat2Pos.id_succ; simpl. - replace (Zpower_nat (Z.of_nat n) (S m1)) with - (Z.of_nat n * Zpower_nat (Z.of_nat n) m1)%Z. - - rewrite mult_IZR; auto with real. - repeat rewrite <- INR_IZR_INZ; simpl. - rewrite H'; simpl. - case m1; simpl; auto with real. - intros m2; rewrite SuccNat2Pos.id_succ; auto. - - unfold Zpower_nat; auto. -Qed. - -Lemma Zpower_pos_powerRZ : - forall n m, IZR (Z.pow_pos n m) = IZR n ^Z Zpos m. -Proof. - intros. - rewrite Zpower_pos_nat; simpl. - induction (Pos.to_nat m). - - easy. - - unfold Zpower_nat; simpl. - rewrite mult_IZR. - now rewrite <- IHn0. -Qed. - -Lemma powerRZ_lt : forall (x:R) (z:Z), 0 < x -> 0 < x ^Z z. -Proof. - intros x z; case z; simpl; auto with real. -Qed. -#[local] -Hint Resolve powerRZ_lt: real. - -Lemma powerRZ_le : forall (x:R) (z:Z), 0 < x -> 0 <= x ^Z z. -Proof. - intros x z H'; apply Rlt_le; auto with real. -Qed. -#[local] -Hint Resolve powerRZ_le: real. - -Lemma Zpower_nat_powerRZ_absolu : - forall n m:Z, (0 <= m)%Z -> IZR (Zpower_nat n (Z.abs_nat m)) = IZR n ^Z m. -Proof. - intros n m; case m; simpl; auto with zarith. - - intros p H'; elim (Pos.to_nat p); simpl; auto with zarith. - intros n0 H'0; rewrite <- H'0; simpl; auto with zarith. - rewrite <- mult_IZR; auto. - - intros p H'; absurd (0 <= Zneg p)%Z; auto with zarith. -Qed. - -Lemma powerRZ_R1 : forall n:Z, 1 ^Z n = 1. -Proof. - intros n; case n; simpl; auto. - - intros p; elim (Pos.to_nat p); simpl; auto; intros n0 H'; rewrite H'; - ring. - - intros p; elim (Pos.to_nat p); simpl. - + exact Rinv_1. - + intros n1 H'; rewrite Rinv_mult; try rewrite Rinv_1; try rewrite H'; - auto with real. -Qed. - -Local Open Scope Z_scope. - -Lemma pow_powerRZ (r : R) (n : nat) : - (r ^ n)%R = powerRZ r (Z_of_nat n). -Proof. - induction n; [easy|simpl]. - now rewrite SuccNat2Pos.id_succ. -Qed. - -Lemma powerRZ_ind (P : Z -> R -> R -> Prop) : - (forall x, P 0 x 1%R) -> - (forall x n, P (Z.of_nat n) x (x ^ n)%R) -> - (forall x n, P ((-(Z.of_nat n))%Z) x (Rinv (x ^ n))) -> - forall x (m : Z), P m x (powerRZ x m)%R. -Proof. - intros ? ? ? x m. - destruct (intP m) as [Hm|n Hm|n Hm]. - - easy. - - now rewrite <- pow_powerRZ. - - unfold powerRZ. - destruct n as [|n]; [ easy |]. - rewrite Nat2Z.inj_succ, <- Zpos_P_of_succ_nat, Pos2Z.opp_pos. - now rewrite <- Pos2Z.opp_pos, <- positive_nat_Z. -Qed. - -Lemma powerRZ_inv' x alpha : powerRZ (/ x) alpha = Rinv (powerRZ x alpha). -Proof. - destruct (intP alpha). - - now simpl; rewrite Rinv_1. - - now rewrite <-!pow_powerRZ, ?pow_inv, ?pow_powerRZ. - - unfold powerRZ. - destruct (- n). - + now rewrite Rinv_1. - + apply pow_inv. - + now rewrite pow_inv. -Qed. - -Lemma powerRZ_inv_depr x alpha : (x <> 0)%R -> powerRZ (/ x) alpha = Rinv (powerRZ x alpha). -Proof. - intros _. - apply powerRZ_inv'. -Qed. - -Lemma powerRZ_neg' x : forall alpha, powerRZ x (- alpha) = Rinv (powerRZ x alpha). -Proof. - intros [|n|n] ; simpl. - - apply eq_sym, Rinv_1. - - easy. - - now rewrite Rinv_inv. -Qed. - -Lemma powerRZ_neg_depr x : forall alpha, x <> R0 -> powerRZ x (- alpha) = powerRZ (/ x) alpha. -Proof. - intros alpha _. - rewrite powerRZ_neg'. - apply eq_sym, powerRZ_inv'. -Qed. - -Lemma powerRZ_mult m x y : (powerRZ (x*y) m = powerRZ x m * powerRZ y m)%R. -Proof. - destruct (intP m) as [ | | n Hm ]. - - now simpl; rewrite Rmult_1_l. - - now rewrite <- !pow_powerRZ, Rpow_mult_distr. - - rewrite !powerRZ_neg', <- Rinv_mult. - now rewrite <- !pow_powerRZ, Rpow_mult_distr. -Qed. - -Lemma powerRZ_mult_distr_depr : - forall m x y, ((0 <= m)%Z \/ (x * y <> 0)%R) -> - (powerRZ (x*y) m = powerRZ x m * powerRZ y m)%R. -Proof. - intros m x y _. - apply powerRZ_mult. -Qed. - -End PowerRZ. - -#[deprecated(since="8.16",note="Use powerRZ_inv'.")] -Notation powerRZ_inv := powerRZ_inv_depr. - -#[deprecated(since="8.16",note="Use powerRZ_neg' and powerRZ_inv'.")] -Notation powerRZ_neg := powerRZ_neg_depr. - -#[deprecated(since="8.16",note="Use powerRZ_mult.")] -Notation powerRZ_mult_distr := powerRZ_mult_distr_depr. - -Local Infix "^Z" := powerRZ (at level 30, right associativity) : R_scope. - -(*******************************) -(* For easy interface *) -(*******************************) -(* decimal_exp r z is defined as r 10^z *) - -Definition decimal_exp (r:R) (z:Z) : R := (r * 10 ^Z z). - - -(*******************************) -(** * Sum of n first naturals *) -(*******************************) -(*********) -Fixpoint sum_nat_f_O (f:nat -> nat) (n:nat) : nat := - match n with - | O => f 0%nat - | S n' => (sum_nat_f_O f n' + f (S n'))%nat - end. - -(*********) -Definition sum_nat_f (s n:nat) (f:nat -> nat) : nat := - sum_nat_f_O (fun x:nat => f (x + s)%nat) (n - s). - -(*********) -Definition sum_nat_O (n:nat) : nat := sum_nat_f_O (fun x:nat => x) n. - -(*********) -Definition sum_nat (s n:nat) : nat := sum_nat_f s n (fun x:nat => x). - -(*******************************) -(** * Sum *) -(*******************************) -(*********) -Fixpoint sum_f_R0 (f:nat -> R) (N:nat) : R := - match N with - | O => f 0%nat - | S i => sum_f_R0 f i + f (S i) - end. - -(*********) -Definition sum_f (s n:nat) (f:nat -> R) : R := - sum_f_R0 (fun x:nat => f (x + s)%nat) (n - s). - -Lemma GP_finite : - forall (x:R) (n:nat), - sum_f_R0 (fun n:nat => x ^ n) n * (x - 1) = x ^ (n + 1) - 1. -Proof. - intros; induction n as [| n Hrecn]; simpl. - - ring. - - rewrite Rmult_plus_distr_r; rewrite Hrecn; cut ((n + 1)%nat = S n). - + intro H; rewrite H; simpl; ring. - + apply Nat.add_1_r. -Qed. - -Lemma sum_f_R0_triangle : - forall (x:nat -> R) (n:nat), - Rabs (sum_f_R0 x n) <= sum_f_R0 (fun i:nat => Rabs (x i)) n. -Proof. - intro; simple induction n; simpl. - - unfold Rle; right; reflexivity. - - intro m; intro; - apply - (Rle_trans (Rabs (sum_f_R0 x m + x (S m))) - (Rabs (sum_f_R0 x m) + Rabs (x (S m))) - (sum_f_R0 (fun i:nat => Rabs (x i)) m + Rabs (x (S m)))). - + apply Rabs_triang. - + rewrite Rplus_comm; - rewrite (Rplus_comm (sum_f_R0 (fun i:nat => Rabs (x i)) m) (Rabs (x (S m)))); - apply Rplus_le_compat_l; assumption. -Qed. - -(*******************************) -(** * Distance in R *) -(*******************************) - -(*********) -Definition Rdist (x y:R) : R := Rabs (x - y). - -(*********) -Lemma Rdist_pos : forall x y:R, Rdist x y >= 0. -Proof. - intros; unfold Rdist; unfold Rabs; case (Rcase_abs (x - y)); - intro l. - - unfold Rge; left; apply (Ropp_gt_lt_0_contravar (x - y) l). - - trivial. -Qed. - -(*********) -Lemma Rdist_sym : forall x y:R, Rdist x y = Rdist y x. -Proof. - unfold Rdist; intros; split_Rabs; try ring. - - generalize (Ropp_gt_lt_0_contravar (y - x) Hlt0); intro; - rewrite (Ropp_minus_distr y x) in H; generalize (Rlt_asym (x - y) 0 Hlt); - intro; unfold Rgt in H; exfalso; auto. - - generalize (minus_Rge y x Hge0); intro; generalize (minus_Rge x y Hge); intro; - generalize (Rge_antisym x y H0 H); intro; rewrite H1; - ring. -Qed. - -(*********) -Lemma Rdist_refl : forall x y:R, Rdist x y = 0 <-> x = y. -Proof. - unfold Rdist; intros; split_Rabs; split; intros. - - rewrite (Ropp_minus_distr x y) in H; symmetry; - apply (Rminus_diag_uniq y x H). - - rewrite (Ropp_minus_distr x y); generalize (eq_sym H); intro; - apply (Rminus_diag_eq y x H0). - - apply (Rminus_diag_uniq x y H). - - apply (Rminus_diag_eq x y H). -Qed. - -Lemma Rdist_eq : forall x:R, Rdist x x = 0. -Proof. - unfold Rdist; intros; split_Rabs; intros; ring. -Qed. - -(***********) -Lemma Rdist_tri : forall x y z:R, Rdist x y <= Rdist x z + Rdist z y. -Proof. - intros; unfold Rdist; replace (x - y) with (x - z + (z - y)); - [ apply (Rabs_triang (x - z) (z - y)) | ring ]. -Qed. - -(*********) -Lemma Rdist_plus : - forall a b c d:R, Rdist (a + c) (b + d) <= Rdist a b + Rdist c d. -Proof. - intros; unfold Rdist; - replace (a + c - (b + d)) with (a - b + (c - d)). - - exact (Rabs_triang (a - b) (c - d)). - - ring. -Qed. - -Lemma Rdist_mult_l : forall a b c, - Rdist (a * b) (a * c) = Rabs a * Rdist b c. -Proof. -unfold Rdist. -intros a b c; rewrite <- Rmult_minus_distr_l, Rabs_mult; reflexivity. -Qed. - -Notation R_dist := Rdist (only parsing). -Notation R_dist_pos := Rdist_pos (only parsing). -Notation R_dist_sym := Rdist_sym (only parsing). -Notation R_dist_refl := Rdist_refl (only parsing). -Notation R_dist_eq := Rdist_eq (only parsing). -Notation R_dist_tri := Rdist_tri (only parsing). -Notation R_dist_plus := Rdist_plus (only parsing). -Notation R_dist_mult_l := Rdist_mult_l (only parsing). - -(*******************************) -(** * Infinite Sum *) -(*******************************) -(*********) -Definition infinite_sum (s:nat -> R) (l:R) : Prop := - forall eps:R, - eps > 0 -> - exists N : nat, - (forall n:nat, (n >= N)%nat -> Rdist (sum_f_R0 s n) l < eps). - -(** Compatibility with previous versions *) -Notation infinit_sum := infinite_sum (only parsing). diff --git a/stdlib/theories/Reals/Rgeom.v b/stdlib/theories/Reals/Rgeom.v deleted file mode 100644 index a961a98f32cc..000000000000 --- a/stdlib/theories/Reals/Rgeom.v +++ /dev/null @@ -1,202 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* - Rsqr b = Rsqr c + Rsqr a - 2 * (a * c * cos ac). -Proof. - unfold dist_euc; intros; repeat rewrite Rsqr_sqrt; - [ rewrite H; unfold Rsqr; ring - | apply Rplus_le_le_0_compat - | apply Rplus_le_le_0_compat - | apply Rplus_le_le_0_compat ]; apply Rle_0_sqr. -Qed. - -Lemma triangle : - forall x0 y0 x1 y1 x2 y2:R, - dist_euc x0 y0 x1 y1 <= dist_euc x0 y0 x2 y2 + dist_euc x2 y2 x1 y1. -Proof. - intros; unfold dist_euc; apply Rsqr_incr_0; - [ rewrite Rsqr_plus; repeat rewrite Rsqr_sqrt; - [ replace (Rsqr (x0 - x1)) with - (Rsqr (x0 - x2) + Rsqr (x2 - x1) + 2 * (x0 - x2) * (x2 - x1)); - [ replace (Rsqr (y0 - y1)) with - (Rsqr (y0 - y2) + Rsqr (y2 - y1) + 2 * (y0 - y2) * (y2 - y1)); - [ apply Rplus_le_reg_l with - (- Rsqr (x0 - x2) - Rsqr (x2 - x1) - Rsqr (y0 - y2) - - Rsqr (y2 - y1)); - replace - (- Rsqr (x0 - x2) - Rsqr (x2 - x1) - Rsqr (y0 - y2) - - Rsqr (y2 - y1) + - (Rsqr (x0 - x2) + Rsqr (x2 - x1) + 2 * (x0 - x2) * (x2 - x1) + - (Rsqr (y0 - y2) + Rsqr (y2 - y1) + 2 * (y0 - y2) * (y2 - y1)))) - with (2 * ((x0 - x2) * (x2 - x1) + (y0 - y2) * (y2 - y1))); - [ replace - (- Rsqr (x0 - x2) - Rsqr (x2 - x1) - Rsqr (y0 - y2) - - Rsqr (y2 - y1) + - (Rsqr (x0 - x2) + Rsqr (y0 - y2) + - (Rsqr (x2 - x1) + Rsqr (y2 - y1)) + - 2 * sqrt (Rsqr (x0 - x2) + Rsqr (y0 - y2)) * - sqrt (Rsqr (x2 - x1) + Rsqr (y2 - y1)))) with - (2 * - (sqrt (Rsqr (x0 - x2) + Rsqr (y0 - y2)) * - sqrt (Rsqr (x2 - x1) + Rsqr (y2 - y1)))); - [ apply Rmult_le_compat_l; - [ left; cut (0%nat <> 2%nat); - [ intros; generalize (lt_INR_0 2 (proj1 (Nat.neq_0_lt_0 2) (Nat.neq_sym 0 2 H))); - intro H0; assumption - | discriminate ] - | apply sqrt_cauchy ] - | ring ] - | ring ] - | ring_Rsqr ] - | ring_Rsqr ] - | apply Rplus_le_le_0_compat; apply Rle_0_sqr - | apply Rplus_le_le_0_compat; apply Rle_0_sqr - | apply Rplus_le_le_0_compat; apply Rle_0_sqr ] - | apply sqrt_positivity; apply Rplus_le_le_0_compat; apply Rle_0_sqr - | apply Rplus_le_le_0_compat; apply sqrt_positivity; - apply Rplus_le_le_0_compat; apply Rle_0_sqr ]. -Qed. - -(******************************************************************) -(** * Translation *) -(******************************************************************) - -Definition xt (x tx:R) : R := x + tx. -Definition yt (y ty:R) : R := y + ty. - -Lemma translation_0 : forall x y:R, xt x 0 = x /\ yt y 0 = y. -Proof. - intros x y; split; [ unfold xt | unfold yt ]; ring. -Qed. - -Lemma isometric_translation : - forall x1 x2 y1 y2 tx ty:R, - Rsqr (x1 - x2) + Rsqr (y1 - y2) = - Rsqr (xt x1 tx - xt x2 tx) + Rsqr (yt y1 ty - yt y2 ty). -Proof. - intros; unfold Rsqr, xt, yt; ring. -Qed. - -(******************************************************************) -(** * Rotation *) -(******************************************************************) - -Definition xr (x y theta:R) : R := x * cos theta + y * sin theta. -Definition yr (x y theta:R) : R := - x * sin theta + y * cos theta. - -Lemma rotation_0 : forall x y:R, xr x y 0 = x /\ yr x y 0 = y. -Proof. - intros x y; unfold xr, yr; split; rewrite cos_0; rewrite sin_0; ring. -Qed. - -Lemma rotation_PI2 : - forall x y:R, xr x y (PI / 2) = y /\ yr x y (PI / 2) = - x. -Proof. - intros x y; unfold xr, yr; split; rewrite cos_PI2; rewrite sin_PI2; - ring. -Qed. - -Lemma isometric_rotation_0 : - forall x1 y1 x2 y2 theta:R, - Rsqr (x1 - x2) + Rsqr (y1 - y2) = - Rsqr (xr x1 y1 theta - xr x2 y2 theta) + - Rsqr (yr x1 y1 theta - yr x2 y2 theta). -Proof. - intros; unfold xr, yr; - replace - (x1 * cos theta + y1 * sin theta - (x2 * cos theta + y2 * sin theta)) with - (cos theta * (x1 - x2) + sin theta * (y1 - y2)); - [ replace - (- x1 * sin theta + y1 * cos theta - (- x2 * sin theta + y2 * cos theta)) - with (cos theta * (y1 - y2) + sin theta * (x2 - x1)); - [ repeat rewrite Rsqr_plus; repeat rewrite Rsqr_mult; repeat rewrite cos2; - ring_simplify; replace (x2 - x1) with (- (x1 - x2)); - [ rewrite <- Rsqr_neg; ring | ring ] - | ring ] - | ring ]. -Qed. - -Lemma isometric_rotation : - forall x1 y1 x2 y2 theta:R, - dist_euc x1 y1 x2 y2 = - dist_euc (xr x1 y1 theta) (yr x1 y1 theta) (xr x2 y2 theta) - (yr x2 y2 theta). -Proof. - unfold dist_euc; intros; apply Rsqr_inj; - [ apply sqrt_positivity; apply Rplus_le_le_0_compat - | apply sqrt_positivity; apply Rplus_le_le_0_compat - | repeat rewrite Rsqr_sqrt; - [ apply isometric_rotation_0 - | apply Rplus_le_le_0_compat - | apply Rplus_le_le_0_compat ] ]; apply Rle_0_sqr. -Qed. - -(******************************************************************) -(** * Similarity *) -(******************************************************************) - -Lemma isometric_rot_trans : - forall x1 y1 x2 y2 tx ty theta:R, - Rsqr (x1 - x2) + Rsqr (y1 - y2) = - Rsqr (xr (xt x1 tx) (yt y1 ty) theta - xr (xt x2 tx) (yt y2 ty) theta) + - Rsqr (yr (xt x1 tx) (yt y1 ty) theta - yr (xt x2 tx) (yt y2 ty) theta). -Proof. - intros; rewrite <- isometric_rotation_0; apply isometric_translation. -Qed. - -Lemma isometric_trans_rot : - forall x1 y1 x2 y2 tx ty theta:R, - Rsqr (x1 - x2) + Rsqr (y1 - y2) = - Rsqr (xt (xr x1 y1 theta) tx - xt (xr x2 y2 theta) tx) + - Rsqr (yt (yr x1 y1 theta) ty - yt (yr x2 y2 theta) ty). -Proof. - intros; rewrite <- isometric_translation; apply isometric_rotation_0. -Qed. diff --git a/stdlib/theories/Reals/RiemannInt.v b/stdlib/theories/Reals/RiemannInt.v deleted file mode 100644 index 664fe59201ea..000000000000 --- a/stdlib/theories/Reals/RiemannInt.v +++ /dev/null @@ -1,3165 +0,0 @@ -(* -*- coding: utf-8 -*- *) -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* R) (a b:R) : Type := - forall eps:posreal, - { phi:StepFun a b & - { psi:StepFun a b | - (forall t:R, - Rmin a b <= t <= Rmax a b -> Rabs (f t - phi t) <= psi t) /\ - Rabs (RiemannInt_SF psi) < eps } }. - -Definition phi_sequence (un:nat -> posreal) (f:R -> R) - (a b:R) (pr:Riemann_integrable f a b) (n:nat) := - projT1 (pr (un n)). - -Lemma phi_sequence_prop : - forall (un:nat -> posreal) (f:R -> R) (a b:R) (pr:Riemann_integrable f a b) - (N:nat), - { psi:StepFun a b | - (forall t:R, - Rmin a b <= t <= Rmax a b -> - Rabs (f t - phi_sequence un pr N t) <= psi t) /\ - Rabs (RiemannInt_SF psi) < un N }. -Proof. - intros; apply (projT2 (pr (un N))). -Qed. - -Lemma RiemannInt_P1 : - forall (f:R -> R) (a b:R), - Riemann_integrable f a b -> Riemann_integrable f b a. -Proof. - unfold Riemann_integrable; intros; elim (X eps); clear X; intros. - elim p; clear p; intros x0 p; exists (mkStepFun (StepFun_P6 (pre x))); - exists (mkStepFun (StepFun_P6 (pre x0))); - elim p; clear p; intros; split. - - intros; apply (H t); elim H1; clear H1; intros; split; - [ apply Rle_trans with (Rmin b a); try assumption; right; - unfold Rmin - | apply Rle_trans with (Rmax b a); try assumption; right; - unfold Rmax ]; - (case (Rle_dec a b); case (Rle_dec b a); intros; - try reflexivity || apply Rle_antisym; - [ assumption | assumption | auto with real | auto with real ]). - - generalize H0; unfold RiemannInt_SF; case (Rle_dec a b); - case (Rle_dec b a); intros; - (replace - (Int_SF (subdivision_val (mkStepFun (StepFun_P6 (pre x0)))) - (subdivision (mkStepFun (StepFun_P6 (pre x0))))) with - (Int_SF (subdivision_val x0) (subdivision x0)); - [ idtac - | apply StepFun_P17 with (fe x0) a b; - [ apply StepFun_P1 - | apply StepFun_P2; - apply (StepFun_P1 (mkStepFun (StepFun_P6 (pre x0)))) ] ]). - + apply H1. - + rewrite Rabs_Ropp; apply H1. - + rewrite Rabs_Ropp in H1; apply H1. - + apply H1. -Qed. - -Lemma RiemannInt_P2 : - forall (f:R -> R) (a b:R) (un:nat -> posreal) (vn wn:nat -> StepFun a b), - Un_cv un 0 -> - a <= b -> - (forall n:nat, - (forall t:R, Rmin a b <= t <= Rmax a b -> Rabs (f t - vn n t) <= wn n t) /\ - Rabs (RiemannInt_SF (wn n)) < un n) -> - { l:R | Un_cv (fun N:nat => RiemannInt_SF (vn N)) l }. -Proof. - intros; apply R_complete; unfold Un_cv in H; unfold Cauchy_crit; - intros; assert (H3 : 0 < eps / 2) by lra. - elim (H _ H3); intros N0 H4; exists N0; intros; unfold Rdist; - unfold Rdist in H4; elim (H1 n); elim (H1 m); intros; - replace (RiemannInt_SF (vn n) - RiemannInt_SF (vn m)) with - (RiemannInt_SF (vn n) + -1 * RiemannInt_SF (vn m)); - [ idtac | ring ]; rewrite <- StepFun_P30; - apply Rle_lt_trans with - (RiemannInt_SF - (mkStepFun (StepFun_P32 (mkStepFun (StepFun_P28 (-1) (vn n) (vn m)))))). - { apply StepFun_P34; assumption. } - apply Rle_lt_trans with - (RiemannInt_SF (mkStepFun (StepFun_P28 1 (wn n) (wn m)))). - { apply StepFun_P37; try assumption. - intros; simpl; - apply Rle_trans with (Rabs (vn n x - f x) + Rabs (f x - vn m x)). - { replace (vn n x + -1 * vn m x) with (vn n x - f x + (f x - vn m x)); - [ apply Rabs_triang | ring ]. } - assert (H12 : Rmin a b = a). - { unfold Rmin; decide (Rle_dec a b) with H0; reflexivity. } - assert (H13 : Rmax a b = b). - { unfold Rmax; decide (Rle_dec a b) with H0; reflexivity. } - rewrite <- H12 in H11; rewrite <- H13 in H11 at 2; - rewrite Rmult_1_l; apply Rplus_le_compat. - { rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; apply H9. - elim H11; intros; split; left; assumption. } - apply H7. - elim H11; intros; split; left; assumption. } - rewrite StepFun_P30; rewrite Rmult_1_l; apply Rlt_trans with (un n + un m). - { apply Rle_lt_trans with - (Rabs (RiemannInt_SF (wn n)) + Rabs (RiemannInt_SF (wn m))). - { apply Rplus_le_compat; apply RRle_abs. } - apply Rplus_lt_compat; assumption. } - apply Rle_lt_trans with (Rabs (un n) + Rabs (un m)). - { apply Rplus_le_compat; apply RRle_abs. } - replace (pos (un n)) with (un n - 0); [ idtac | ring ]; - replace (pos (un m)) with (un m - 0); [ idtac | ring ]; - rewrite <-(Rplus_half_diag eps); apply Rplus_lt_compat; apply H4; - assumption. -Qed. - -Lemma RiemannInt_P3 : - forall (f:R -> R) (a b:R) (un:nat -> posreal) (vn wn:nat -> StepFun a b), - Un_cv un 0 -> - (forall n:nat, - (forall t:R, Rmin a b <= t <= Rmax a b -> Rabs (f t - vn n t) <= wn n t) /\ - Rabs (RiemannInt_SF (wn n)) < un n) -> - { l:R | Un_cv (fun N:nat => RiemannInt_SF (vn N)) l }. -Proof. - intros; destruct (Rle_dec a b) as [Hle|Hnle]. - { apply RiemannInt_P2 with f un wn; assumption. } - assert (H1 : b <= a); auto with real. - set (vn' := fun n:nat => mkStepFun (StepFun_P6 (pre (vn n)))); - set (wn' := fun n:nat => mkStepFun (StepFun_P6 (pre (wn n)))); - assert - (H2 : - forall n:nat, - (forall t:R, - Rmin b a <= t <= Rmax b a -> Rabs (f t - vn' n t) <= wn' n t) /\ - Rabs (RiemannInt_SF (wn' n)) < un n). - { intro; elim (H0 n); intros; split. - { intros t (H4,H5); apply (H2 t); split; - [ apply Rle_trans with (Rmin b a); try assumption; right; - unfold Rmin - | apply Rle_trans with (Rmax b a); try assumption; right; - unfold Rmax ]; - decide (Rle_dec a b) with Hnle; decide (Rle_dec b a) with H1; reflexivity. } - generalize H3; unfold RiemannInt_SF; destruct (Rle_dec a b) as [Hleab|Hnleab]; - destruct (Rle_dec b a) as [Hle'|Hnle']; unfold wn'; intros; - (replace - (Int_SF (subdivision_val (mkStepFun (StepFun_P6 (pre (wn n))))) - (subdivision (mkStepFun (StepFun_P6 (pre (wn n)))))) with - (Int_SF (subdivision_val (wn n)) (subdivision (wn n))); - [ idtac - | apply StepFun_P17 with (fe (wn n)) a b; - [ apply StepFun_P1 - | apply StepFun_P2; - apply (StepFun_P1 (mkStepFun (StepFun_P6 (pre (wn n))))) ] ]). - - apply H4. - - rewrite Rabs_Ropp; apply H4. - - rewrite Rabs_Ropp in H4; apply H4. - - apply H4. } - assert (H3 := RiemannInt_P2 _ _ _ _ H H1 H2); elim H3; intros x p; - exists (- x); unfold Un_cv; unfold Un_cv in p; - intros; elim (p _ H4); intros; exists x0; intros; - generalize (H5 _ H6); unfold Rdist, RiemannInt_SF; - destruct (Rle_dec b a) as [Hle'|Hnle']; destruct (Rle_dec a b) as [Hle''|Hnle'']; - intros. - 1,3,4: lra. - unfold vn' in H7; - replace (Int_SF (subdivision_val (vn n)) (subdivision (vn n))) with - (Int_SF (subdivision_val (mkStepFun (StepFun_P6 (pre (vn n))))) - (subdivision (mkStepFun (StepFun_P6 (pre (vn n)))))); - [ unfold Rminus; rewrite Ropp_involutive; rewrite <- Rabs_Ropp; - rewrite Ropp_plus_distr; rewrite Ropp_involutive; - apply H7 - | symmetry ; apply StepFun_P17 with (fe (vn n)) a b; - [ apply StepFun_P1 - | apply StepFun_P2; - apply (StepFun_P1 (mkStepFun (StepFun_P6 (pre (vn n))))) ] ]. -Qed. - -Lemma RiemannInt_exists : - forall (f:R -> R) (a b:R) (pr:Riemann_integrable f a b) - (un:nat -> posreal), - Un_cv un 0 -> - { l:R | Un_cv (fun N:nat => RiemannInt_SF (phi_sequence un pr N)) l }. -Proof. - intros f; intros; - apply RiemannInt_P3 with - f un (fun n:nat => proj1_sig (phi_sequence_prop un pr n)); - [ apply H | intro; apply (proj2_sig (phi_sequence_prop un pr n)) ]. -Qed. - -Lemma RiemannInt_P4 : - forall (f:R -> R) (a b l:R) (pr1 pr2:Riemann_integrable f a b) - (un vn:nat -> posreal), - Un_cv un 0 -> - Un_cv vn 0 -> - Un_cv (fun N:nat => RiemannInt_SF (phi_sequence un pr1 N)) l -> - Un_cv (fun N:nat => RiemannInt_SF (phi_sequence vn pr2 N)) l. -Proof. - unfold Un_cv; unfold Rdist; intros f; intros; - assert (H3 : 0 < eps / 3). - { unfold Rdiv; apply Rmult_lt_0_compat; - [ assumption | apply Rinv_0_lt_compat; prove_sup0 ]. } - elim (H _ H3); clear H; intros N0 H; elim (H0 _ H3); clear H0; intros N1 H0; - elim (H1 _ H3); clear H1; intros N2 H1; set (N := max (max N0 N1) N2); - exists N; intros; - apply Rle_lt_trans with - (Rabs - (RiemannInt_SF (phi_sequence vn pr2 n) - - RiemannInt_SF (phi_sequence un pr1 n)) + - Rabs (RiemannInt_SF (phi_sequence un pr1 n) - l)). - { replace (RiemannInt_SF (phi_sequence vn pr2 n) - l) with - (RiemannInt_SF (phi_sequence vn pr2 n) - - RiemannInt_SF (phi_sequence un pr1 n) + - (RiemannInt_SF (phi_sequence un pr1 n) - l)); [ apply Rabs_triang | ring ]. } - replace eps with (2 * (eps / 3) + eps / 3) by lra. - apply Rplus_lt_compat. - 2:{ apply H1; unfold ge; apply Nat.le_trans with N; try assumption; - unfold N; apply Nat.le_max_r. } - elim (phi_sequence_prop vn pr2 n); intros psi_vn H5; - elim (phi_sequence_prop un pr1 n); intros psi_un H6; - replace - (RiemannInt_SF (phi_sequence vn pr2 n) - - RiemannInt_SF (phi_sequence un pr1 n)) with - (RiemannInt_SF (phi_sequence vn pr2 n) + - -1 * RiemannInt_SF (phi_sequence un pr1 n)); [ idtac | ring ]; - rewrite <- StepFun_P30. - destruct (Rle_dec a b) as [Hle|Hnle]. - - apply Rle_lt_trans with - (RiemannInt_SF - (mkStepFun - (StepFun_P32 - (mkStepFun - (StepFun_P28 (-1) (phi_sequence vn pr2 n) - (phi_sequence un pr1 n)))))). - { apply StepFun_P34; assumption. } - apply Rle_lt_trans with - (RiemannInt_SF (mkStepFun (StepFun_P28 1 psi_un psi_vn))). - { apply StepFun_P37; try assumption; intros; simpl; rewrite Rmult_1_l; - apply Rle_trans with - (Rabs (phi_sequence vn pr2 n x - f x) + - Rabs (f x - phi_sequence un pr1 n x)). - { replace (phi_sequence vn pr2 n x + -1 * phi_sequence un pr1 n x) with - (phi_sequence vn pr2 n x - f x + (f x - phi_sequence un pr1 n x)); - [ apply Rabs_triang | ring ]. } - assert (H10 : Rmin a b = a). - { unfold Rmin; decide (Rle_dec a b) with Hle; reflexivity. } - assert (H11 : Rmax a b = b). - { unfold Rmax; decide (Rle_dec a b) with Hle; reflexivity. } - rewrite (Rplus_comm (psi_un x)); apply Rplus_le_compat. - { rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; destruct H5 as (H8,H9); apply H8. - rewrite H10; rewrite H11; elim H7; intros; split; left; assumption. } - elim H6; intros; apply H8. - rewrite H10; rewrite H11; elim H7; intros; split; left; assumption. } - rewrite StepFun_P30; rewrite Rmult_1_l; rewrite <-Rplus_diag; apply Rplus_lt_compat. - { apply Rlt_trans with (pos (un n)). - { elim H6; intros; apply Rle_lt_trans with (Rabs (RiemannInt_SF psi_un)). - { apply RRle_abs. } - assumption. } - replace (pos (un n)) with (Rabs (un n - 0)); - [ apply H; unfold ge; apply Nat.le_trans with N; try assumption; - unfold N; apply Nat.le_trans with (max N0 N1); - apply Nat.le_max_l - | unfold Rminus; rewrite Ropp_0; rewrite Rplus_0_r; apply Rabs_right; - apply Rle_ge; left; apply (cond_pos (un n)) ]. } - apply Rlt_trans with (pos (vn n)). - { elim H5; intros; apply Rle_lt_trans with (Rabs (RiemannInt_SF psi_vn)). - { apply RRle_abs; assumption. } - assumption. } - replace (pos (vn n)) with (Rabs (vn n - 0)); - [ apply H0; unfold ge; apply Nat.le_trans with N; try assumption; - unfold N; apply Nat.le_trans with (max N0 N1); - [ apply Nat.le_max_r | apply Nat.le_max_l ] - | unfold Rminus; rewrite Ropp_0; rewrite Rplus_0_r; apply Rabs_right; - apply Rle_ge; left; apply (cond_pos (vn n)) ]. - - rewrite StepFun_P39; rewrite Rabs_Ropp; - apply Rle_lt_trans with - (RiemannInt_SF - (mkStepFun - (StepFun_P32 - (mkStepFun - (StepFun_P6 - (pre - (mkStepFun - (StepFun_P28 (-1) (phi_sequence vn pr2 n) - (phi_sequence un pr1 n))))))))). - { apply StepFun_P34; try auto with real. } - apply Rle_lt_trans with - (RiemannInt_SF - (mkStepFun (StepFun_P6 (pre (mkStepFun (StepFun_P28 1 psi_vn psi_un)))))). - { apply StepFun_P37. - { auto with real. } - intros; simpl; rewrite Rmult_1_l; - apply Rle_trans with - (Rabs (phi_sequence vn pr2 n x - f x) + - Rabs (f x - phi_sequence un pr1 n x)). - { replace (phi_sequence vn pr2 n x + -1 * phi_sequence un pr1 n x) with - (phi_sequence vn pr2 n x - f x + (f x - phi_sequence un pr1 n x)); - [ apply Rabs_triang | ring ]. } - assert (H10 : Rmin a b = b). - { unfold Rmin; decide (Rle_dec a b) with Hnle; reflexivity. } - assert (H11 : Rmax a b = a). - { unfold Rmax; decide (Rle_dec a b) with Hnle; reflexivity. } - apply Rplus_le_compat. - { rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; elim H5; intros; apply H8. - rewrite H10; rewrite H11; elim H7; intros; split; left; assumption. } - elim H6; intros; apply H8. - rewrite H10; rewrite H11; elim H7; intros; split; left; assumption. } - rewrite <- - (Ropp_involutive - (RiemannInt_SF - (mkStepFun - (StepFun_P6 (pre (mkStepFun (StepFun_P28 1 psi_vn psi_un))))))) - ; rewrite <- StepFun_P39; rewrite StepFun_P30; rewrite Rmult_1_l; - rewrite <-Rplus_diag; rewrite Ropp_plus_distr; apply Rplus_lt_compat. - { apply Rlt_trans with (pos (vn n)). - { elim H5; intros; apply Rle_lt_trans with (Rabs (RiemannInt_SF psi_vn)). - { rewrite <- Rabs_Ropp; apply RRle_abs. } - assumption. } - replace (pos (vn n)) with (Rabs (vn n - 0)); - [ apply H0; unfold ge; apply Nat.le_trans with N; try assumption; - unfold N; apply Nat.le_trans with (max N0 N1); - [ apply Nat.le_max_r | apply Nat.le_max_l ] - | unfold Rdist; unfold Rminus; rewrite Ropp_0; - rewrite Rplus_0_r; apply Rabs_right; apply Rle_ge; - left; apply (cond_pos (vn n)) ]. } - apply Rlt_trans with (pos (un n)). - { elim H6; intros; apply Rle_lt_trans with (Rabs (RiemannInt_SF psi_un)). - { rewrite <- Rabs_Ropp; apply RRle_abs; assumption. } - assumption. } - replace (pos (un n)) with (Rabs (un n - 0)); - [ apply H; unfold ge; apply Nat.le_trans with N; try assumption; - unfold N; apply Nat.le_trans with (max N0 N1); - apply Nat.le_max_l - | unfold Rminus; rewrite Ropp_0; rewrite Rplus_0_r; apply Rabs_right; - apply Rle_ge; left; apply (cond_pos (un n)) ]. -Qed. - -Lemma RinvN_pos : forall n:nat, 0 < / (INR n + 1). -Proof. - intro; apply Rinv_0_lt_compat; apply Rplus_le_lt_0_compat; - [ apply pos_INR | apply Rlt_0_1 ]. -Qed. - -Definition RinvN (N:nat) : posreal := mkposreal _ (RinvN_pos N). - -Lemma RinvN_cv : Un_cv RinvN 0. -Proof. - unfold Un_cv; intros; assert (H0 := archimed (/ eps)); elim H0; - clear H0; intros; assert (H2 : (0 <= up (/ eps))%Z). - { apply le_IZR; left; apply Rlt_trans with (/ eps); - [ apply Rinv_0_lt_compat; assumption | assumption ]. } - elim (IZN _ H2); intros; exists x; intros; unfold Rdist; - simpl; unfold Rminus; rewrite Ropp_0; - rewrite Rplus_0_r; assert (H5 : 0 < INR n + 1). - { apply Rplus_le_lt_0_compat; [ apply pos_INR | apply Rlt_0_1 ]. } - rewrite Rabs_right; - [ idtac - | left; change (0 < / (INR n + 1)); apply Rinv_0_lt_compat; - assumption ]; apply Rle_lt_trans with (/ (INR x + 1)). - { apply Rinv_le_contravar. - { apply Rplus_le_lt_0_compat; [ apply pos_INR | apply Rlt_0_1 ]. } - apply Rplus_le_compat_r; apply le_INR; apply H4. } - rewrite <- (Rinv_inv eps). - apply Rinv_lt_contravar. - { apply Rmult_lt_0_compat. - { apply Rinv_0_lt_compat; assumption. } - apply Rplus_le_lt_0_compat; [ apply pos_INR | apply Rlt_0_1 ]. } - apply Rlt_trans with (INR x); - [ rewrite INR_IZR_INZ; rewrite <- H3; apply H0 - | pattern (INR x) at 1; rewrite <- Rplus_0_r; - apply Rplus_lt_compat_l; apply Rlt_0_1 ]. -Qed. - -Lemma Riemann_integrable_ext : - forall f g a b, - (forall x, Rmin a b <= x <= Rmax a b -> f x = g x) -> - Riemann_integrable f a b -> Riemann_integrable g a b. -intros f g a b fg rif eps; destruct (rif eps) as [phi [psi [P1 P2]]]. -exists phi; exists psi;split;[ | assumption ]. -intros t intt; rewrite <- fg;[ | assumption]. -apply P1; assumption. -Qed. -(**********) -Definition RiemannInt (f:R -> R) (a b:R) (pr:Riemann_integrable f a b) : R := - let (a,_) := RiemannInt_exists pr RinvN RinvN_cv in a. - -Lemma RiemannInt_P5 : - forall (f:R -> R) (a b:R) (pr1 pr2:Riemann_integrable f a b), - RiemannInt pr1 = RiemannInt pr2. -Proof. - intros; unfold RiemannInt; - case (RiemannInt_exists pr1 RinvN RinvN_cv) as (x,HUn); - case (RiemannInt_exists pr2 RinvN RinvN_cv) as (x0,HUn0); - eapply UL_sequence; - [ apply HUn - | apply RiemannInt_P4 with pr2 RinvN; apply RinvN_cv || assumption ]. -Qed. - -(***************************************) -(** CĀ°([a,b]) is included in L1([a,b]) *) -(***************************************) - -Lemma maxN : - forall (a b:R) (del:posreal), - a < b -> { n:nat | a + INR n * del < b /\ b <= a + INR (S n) * del }. -Proof. - intros; set (I := fun n:nat => a + INR n * del < b); - assert (H0 : exists n : nat, I n). - { exists 0%nat; unfold I; rewrite Rmult_0_l; rewrite Rplus_0_r; - assumption. } - cut (Nbound I). - { intro; assert (H2 := Nzorn H0 H1); elim H2; intros x p; exists x; elim p; intros; - split. - { apply H3. } - destruct (total_order_T (a + INR (S x) * del) b) as [[Hlt|Heq]|Hgt]. - { assert (H5 := H4 (S x) Hlt); elim (Nat.nle_succ_diag_l _ H5). } - { right; symmetry ; assumption. } - left; apply Hgt. } - assert (H1 : 0 <= (b - a) / del). - { unfold Rdiv; apply Rmult_le_pos; - [ apply Rge_le; apply Rge_minus; apply Rle_ge; left; apply H - | left; apply Rinv_0_lt_compat; apply (cond_pos del) ]. } - elim (archimed ((b - a) / del)); intros; - assert (H4 : (0 <= up ((b - a) / del))%Z). - { apply le_IZR; simpl; left; apply Rle_lt_trans with ((b - a) / del); - assumption. } - assert (H5 := IZN _ H4); elim H5; clear H5; intros N H5; - unfold Nbound; exists N; intros; unfold I in H6; - apply INR_le; rewrite H5 in H2; rewrite <- INR_IZR_INZ in H2; - left; apply Rle_lt_trans with ((b - a) / del); try assumption; - apply Rmult_le_reg_l with (pos del); - [ apply (cond_pos del) - | unfold Rdiv; rewrite <- (Rmult_comm (/ del)); - rewrite <- Rmult_assoc; rewrite Rinv_r; - [ rewrite Rmult_1_l; rewrite Rmult_comm; apply Rplus_le_reg_l with a; - replace (a + (b - a)) with b; [ left; assumption | ring ] - | assert (H7 := cond_pos del); red; intro; rewrite H8 in H7; - elim (Rlt_irrefl _ H7) ] ]. -Qed. - -Fixpoint SubEquiN (N:nat) (x y:R) (del:posreal) : list R := - match N with - | O => cons y nil - | S p => cons x (SubEquiN p (x + del) y del) - end. - -Definition max_N (a b:R) (del:posreal) (h:a < b) : nat := - let (N,_) := maxN del h in N. - -Definition SubEqui (a b:R) (del:posreal) (h:a < b) : list R := - SubEquiN (S (max_N del h)) a b del. - -Lemma Heine_cor1 : - forall (f:R -> R) (a b:R), - a < b -> - (forall x:R, a <= x <= b -> continuity_pt f x) -> - forall eps:posreal, - { delta:posreal | - delta <= b - a /\ - (forall x y:R, - a <= x <= b -> - a <= y <= b -> Rabs (x - y) < delta -> Rabs (f x - f y) < eps) }. -Proof. - intro f; intros; - set - (E := - fun l:R => - 0 < l <= b - a /\ - (forall x y:R, - a <= x <= b -> - a <= y <= b -> Rabs (x - y) < l -> Rabs (f x - f y) < eps)); - assert (H1 : bound E). - { unfold bound; exists (b - a); unfold is_upper_bound; intros; - unfold E in H1; elim H1; clear H1; intros H1 _; elim H1; - intros; assumption. } - assert (H2 : exists x : R, E x). - { assert (H2 := Heine f (fun x:R => a <= x <= b) (compact_P3 a b) H0 eps); - elim H2; intros; exists (Rmin x (b - a)); unfold E; - split; - [ split; - [ unfold Rmin; case (Rle_dec x (b - a)); intro; - [ apply (cond_pos x) | apply Rlt_0_minus; assumption ] - | apply Rmin_r ] - | intros; apply H3; try assumption; apply Rlt_le_trans with (Rmin x (b - a)); - [ assumption | apply Rmin_l ] ]. } - assert (H3 := completeness E H1 H2); elim H3; intros x p; cut (0 < x <= b - a). - { intro; elim H4; clear H4; intros; exists (mkposreal _ H4); split. - { apply H5. } - unfold is_lub in p; elim p; intros; unfold is_upper_bound in H6; - set (D := Rabs (x0 - y)). - assert (H11: ((exists y : R, D < y /\ E y) \/ (forall y : R, not (D < y /\ E y)) -> False) -> False). - { clear; intros H; apply H. - right; intros y0 H0; apply H. - left; now exists y0. } - apply Rnot_le_lt; intros H30. - apply H11; clear H11; intros H11. - revert H30; apply Rlt_not_le. - destruct H11 as [H11|H12]. - { elim H11; intros; elim H12; clear H12; intros; unfold E in H13; elim H13; - intros; apply H15; assumption. } - assert (H13 : is_upper_bound E D). - { unfold is_upper_bound; intros; assert (H14 := H12 x1); - apply Rnot_lt_le; contradict H14; now split. } - assert (H14 := H7 _ H13); elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H14 H10)). } - unfold is_lub in p; unfold is_upper_bound in p; elim p; clear p; intros; - split. - { elim H2; intros; assert (H7 := H4 _ H6); unfold E in H6; elim H6; clear H6; - intros H6 _; elim H6; intros; apply Rlt_le_trans with x0; - assumption. } - apply H5; intros; unfold E in H6; elim H6; clear H6; intros H6 _; elim H6; - intros; assumption. -Qed. - -Lemma Heine_cor2 : - forall (f:R -> R) (a b:R), - (forall x:R, a <= x <= b -> continuity_pt f x) -> - forall eps:posreal, - { delta:posreal | - forall x y:R, - a <= x <= b -> - a <= y <= b -> Rabs (x - y) < delta -> Rabs (f x - f y) < eps }. -Proof. - intro f; intros; destruct (total_order_T a b) as [[Hlt|Heq]|Hgt]. - - assert (H0 := Heine_cor1 Hlt H eps); elim H0; intros x p; exists x; - elim p; intros; apply H2; assumption. - - exists (mkposreal _ Rlt_0_1); intros; assert (H3 : x = y); - [ elim H0; elim H1; intros; rewrite Heq in H3, H5; - apply Rle_antisym; apply Rle_trans with b; assumption - | rewrite H3; unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0; - apply (cond_pos eps) ]. - - exists (mkposreal _ Rlt_0_1); intros; elim H0; intros; - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ (Rle_trans _ _ _ H3 H4) Hgt)). -Qed. - -Lemma SubEqui_P1 : - forall (a b:R) (del:posreal) (h:a < b), pos_Rl (SubEqui del h) 0 = a. -Proof. - intros; unfold SubEqui; case (maxN del h); intros; reflexivity. -Qed. - -Lemma SubEqui_P2 : - forall (a b:R) (del:posreal) (h:a < b), - pos_Rl (SubEqui del h) (pred (length (SubEqui del h))) = b. -Proof. - intros; unfold SubEqui; destruct (maxN del h)as (x,_). - cut - (forall (x:nat) (a:R) (del:posreal), - pos_Rl (SubEquiN (S x) a b del) - (pred (length (SubEquiN (S x) a b del))) = b); - [ intro; apply H - | simple induction x0; - [ intros; reflexivity - | intros; - change - (pos_Rl (SubEquiN (S n) (a0 + del0) b del0) - (pred (length (SubEquiN (S n) (a0 + del0) b del0))) = b) - ; apply H ] ]. -Qed. - -Lemma SubEqui_P3 : - forall (N:nat) (a b:R) (del:posreal), length (SubEquiN N a b del) = S N. -Proof. - simple induction N; intros; - [ reflexivity | simpl; rewrite H; reflexivity ]. -Qed. - -Lemma SubEqui_P4 : - forall (N:nat) (a b:R) (del:posreal) (i:nat), - (i < S N)%nat -> pos_Rl (SubEquiN (S N) a b del) i = a + INR i * del. -Proof. - simple induction N; - [ intros; inversion H; [ simpl; ring | elim (Nat.nle_succ_0 _ H1) ] - | intros; induction i as [| i Hreci]; - [ simpl; ring - | change - (pos_Rl (SubEquiN (S n) (a + del) b del) i = a + INR (S i) * del) - ; rewrite H; [ rewrite S_INR; ring | apply Nat.succ_lt_mono; apply H0 ] ] ]. -Qed. - -Lemma SubEqui_P5 : - forall (a b:R) (del:posreal) (h:a < b), - length (SubEqui del h) = S (S (max_N del h)). -Proof. - intros; unfold SubEqui; apply SubEqui_P3. -Qed. - -Lemma SubEqui_P6 : - forall (a b:R) (del:posreal) (h:a < b) (i:nat), - (i < S (max_N del h))%nat -> pos_Rl (SubEqui del h) i = a + INR i * del. -Proof. - intros; unfold SubEqui; apply SubEqui_P4; assumption. -Qed. - -Lemma SubEqui_P7 : - forall (a b:R) (del:posreal) (h:a < b), ordered_Rlist (SubEqui del h). -Proof. - intros; unfold ordered_Rlist; intros; rewrite SubEqui_P5 in H; - simpl in H; inversion H. - { rewrite (SubEqui_P6 del h (i:=(max_N del h))). - { replace (S (max_N del h)) with (pred (length (SubEqui del h))). - { rewrite SubEqui_P2; unfold max_N; case (maxN del h) as (?&?&?); left; - assumption. } - rewrite SubEqui_P5; reflexivity. } - apply Nat.lt_succ_diag_r. } - repeat rewrite SubEqui_P6. - 3: assumption. - 2: apply Nat.lt_succ_r; assumption. - apply Rplus_le_compat_l; rewrite S_INR; rewrite Rmult_plus_distr_r; - pattern (INR i * del) at 1; rewrite <- Rplus_0_r; - apply Rplus_le_compat_l; rewrite Rmult_1_l; left; - apply (cond_pos del). -Qed. - -Lemma SubEqui_P8 : - forall (a b:R) (del:posreal) (h:a < b) (i:nat), - (i < length (SubEqui del h))%nat -> a <= pos_Rl (SubEqui del h) i <= b. -Proof. - intros; split. - { pattern a at 1; rewrite <- (SubEqui_P1 del h); apply RList_P5. - { apply SubEqui_P7. } - elim (RList_P3 (SubEqui del h) (pos_Rl (SubEqui del h) i)); intros; apply H1; - exists i; split; [ reflexivity | assumption ]. } - pattern b at 2; rewrite <- (SubEqui_P2 del h); apply RList_P7; - [ apply SubEqui_P7 - | elim (RList_P3 (SubEqui del h) (pos_Rl (SubEqui del h) i)); intros; - apply H1; exists i; split; [ reflexivity | assumption ] ]. -Qed. - -Lemma SubEqui_P9 : - forall (a b:R) (del:posreal) (f:R -> R) (h:a < b), - { g:StepFun a b | - g b = f b /\ - (forall i:nat, - (i < pred (length (SubEqui del h)))%nat -> - constant_D_eq g - (co_interval (pos_Rl (SubEqui del h) i) - (pos_Rl (SubEqui del h) (S i))) - (f (pos_Rl (SubEqui del h) i))) }. -Proof. - intros; apply StepFun_P38; - [ apply SubEqui_P7 | apply SubEqui_P1 | apply SubEqui_P2 ]. -Qed. - -Lemma RiemannInt_P6 : - forall (f:R -> R) (a b:R), - a < b -> - (forall x:R, a <= x <= b -> continuity_pt f x) -> Riemann_integrable f a b. -Proof. - intros; unfold Riemann_integrable; intro; - assert (H1 : 0 < eps / (2 * (b - a))). - { unfold Rdiv; apply Rmult_lt_0_compat; - [ apply (cond_pos eps) - | apply Rinv_0_lt_compat; apply Rmult_lt_0_compat; - [ prove_sup0 | apply Rlt_0_minus; assumption ] ]. } - assert (H2 : Rmin a b = a). - { apply Rlt_le in H. - unfold Rmin; decide (Rle_dec a b) with H; reflexivity. } - assert (H3 : Rmax a b = b). - { apply Rlt_le in H. - unfold Rmax; decide (Rle_dec a b) with H; reflexivity. } - elim (Heine_cor2 H0 (mkposreal _ H1)); intros del H4; - elim (SubEqui_P9 del f H); intros phi [H5 H6]; split with phi; - split with (mkStepFun (StepFun_P4 a b (eps / (2 * (b - a))))); - split. - 2: rewrite StepFun_P18; unfold Rdiv; rewrite Rinv_mult. - 2: do 2 rewrite Rmult_assoc; rewrite Rinv_l. - 2: rewrite Rmult_1_r; rewrite Rabs_right. - 2: apply Rmult_lt_reg_l with 2. - 2: prove_sup0. - 2: rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc; - rewrite Rinv_r. - 2: rewrite Rmult_1_l; pattern (pos eps) at 1; rewrite <- Rplus_0_r; - rewrite <-Rplus_diag; apply Rplus_lt_compat_l; apply (cond_pos eps). - 2: discrR. - 2: apply Rle_ge; left; apply Rmult_lt_0_compat. - 2: apply (cond_pos eps). - 2: apply Rinv_0_lt_compat; prove_sup0. - 2: apply Rminus_eq_contra; red; intro; clear H6; rewrite H7 in H; - elim (Rlt_irrefl _ H). - intros; rewrite H2 in H7; rewrite H3 in H7; simpl; - unfold fct_cte; - cut - (forall t:R, - a <= t <= b -> - t = b \/ - (exists i : nat, - (i < pred (length (SubEqui del H)))%nat /\ - co_interval (pos_Rl (SubEqui del H) i) (pos_Rl (SubEqui del H) (S i)) - t)). - { intro; elim (H8 _ H7); intro. - { rewrite H9; rewrite H5; unfold Rminus; rewrite Rplus_opp_r; - rewrite Rabs_R0; left; assumption. } - elim H9; clear H9; intros I [H9 H10]; assert (H11 := H6 I H9 t H10); - rewrite H11; left; apply H4. - - assumption. - - apply SubEqui_P8; apply Nat.lt_trans with (pred (length (SubEqui del H))). - { assumption. } - apply Nat.lt_pred_l; red; intro; rewrite H12 in H9; - elim (Nat.nlt_0_r _ H9). - - unfold co_interval in H10; elim H10; clear H10; intros; rewrite Rabs_right. - { rewrite SubEqui_P5 in H9; simpl in H9; inversion H9. - { apply Rplus_lt_reg_l with (pos_Rl (SubEqui del H) (max_N del H)). - replace - (pos_Rl (SubEqui del H) (max_N del H) + - (t - pos_Rl (SubEqui del H) (max_N del H))) with t; - [ idtac | ring ]; apply Rlt_le_trans with b. - { rewrite H14 in H12; - assert (H13 : S (max_N del H) = pred (length (SubEqui del H))). - { rewrite SubEqui_P5; reflexivity. } - rewrite H13 in H12; rewrite SubEqui_P2 in H12; apply H12. } - rewrite SubEqui_P6. - 2: apply Nat.lt_succ_diag_r. - unfold max_N; destruct (maxN del H) as (?&?&H13); - replace (a + INR x * del + del) with (a + INR (S x) * del); - [ assumption | rewrite S_INR; ring ]. } - apply Rplus_lt_reg_l with (pos_Rl (SubEqui del H) I); - replace (pos_Rl (SubEqui del H) I + (t - pos_Rl (SubEqui del H) I)) with t; - [ idtac | ring ]; - replace (pos_Rl (SubEqui del H) I + del) with (pos_Rl (SubEqui del H) (S I)). - { assumption. } - repeat rewrite SubEqui_P6. - - rewrite S_INR; ring. - - assumption. - - apply Nat.lt_succ_r; assumption. } - apply Rge_minus; apply Rle_ge; assumption. } - intros; clear H0 H1 H4 phi H5 H6 t H7; case (Req_dec t0 b); intro. - { left; assumption. } - right; set (I := fun j:nat => a + INR j * del <= t0); - assert (H1 : exists n : nat, I n). - { exists 0%nat; unfold I; rewrite Rmult_0_l; rewrite Rplus_0_r; elim H8; - intros; assumption. } - assert (H4 : Nbound I). - { unfold Nbound; exists (S (max_N del H)); intros; unfold max_N; - destruct (maxN del H) as (?&_&H5); - apply INR_le; apply Rmult_le_reg_l with (pos del). - { apply (cond_pos del). } - apply Rplus_le_reg_l with a; do 2 rewrite (Rmult_comm del); - apply Rle_trans with t0; unfold I in H4; try assumption; - apply Rle_trans with b; try assumption; elim H8; intros; - assumption. } - elim (Nzorn H1 H4); intros N [H5 H6]; assert (H7 : (N < S (max_N del H))%nat). - { unfold max_N; case (maxN del H) as (?&?&?); apply INR_lt; - apply Rmult_lt_reg_l with (pos del). - { apply (cond_pos del). } - apply Rplus_lt_reg_l with a; do 2 rewrite (Rmult_comm del); - apply Rle_lt_trans with t0; unfold I in H5; try assumption; - apply Rlt_le_trans with b; try assumption; - elim H8; intros. - elim H11; intro. - { assumption. } - elim H0; assumption. } - exists N; split. - { rewrite SubEqui_P5; simpl; assumption. } - unfold co_interval; split. - { rewrite SubEqui_P6. - { apply H5. } - assumption. } - inversion H7. - { replace (S (max_N del H)) with (pred (length (SubEqui del H))). - { rewrite (SubEqui_P2 del H); elim H8; intros. - elim H11; intro. - { assumption. } - elim H0; assumption. } - rewrite SubEqui_P5; reflexivity. } - rewrite SubEqui_P6. - { destruct (Rle_dec (a + INR (S N) * del) t0) as [Hle|Hnle]. - { assert (H11 := H6 (S N) Hle); elim (Nat.nle_succ_diag_l _ H11). } - auto with real. } - apply Nat.lt_succ_r; assumption. -Qed. - -Lemma RiemannInt_P7 : forall (f:R -> R) (a:R), Riemann_integrable f a a. -Proof. - unfold Riemann_integrable; intro f; intros; - split with (mkStepFun (StepFun_P4 a a (f a))); - split with (mkStepFun (StepFun_P4 a a 0)); split. - - intros; simpl; unfold fct_cte; replace t with a. - + unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0; right; - reflexivity. - + generalize H; unfold Rmin, Rmax; decide (Rle_dec a a) with (Rle_refl a). - intros (?,?); apply Rle_antisym; assumption. - - rewrite StepFun_P18; rewrite Rmult_0_l; rewrite Rabs_R0; apply (cond_pos eps). -Qed. - -Lemma continuity_implies_RiemannInt : - forall (f:R -> R) (a b:R), - a <= b -> - (forall x:R, a <= x <= b -> continuity_pt f x) -> Riemann_integrable f a b. -Proof. - intros; destruct (total_order_T a b) as [[Hlt| -> ]|Hgt]; - [ apply RiemannInt_P6; assumption | apply RiemannInt_P7 - | elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H Hgt)) ]. -Qed. - -Lemma RiemannInt_P8 : - forall (f:R -> R) (a b:R) (pr1:Riemann_integrable f a b) - (pr2:Riemann_integrable f b a), RiemannInt pr1 = - RiemannInt pr2. -Proof. - intro f; intros; eapply UL_sequence. - { unfold RiemannInt; destruct (RiemannInt_exists pr1 RinvN RinvN_cv) as (?,HUn); - apply HUn. } - unfold RiemannInt; destruct (RiemannInt_exists pr2 RinvN RinvN_cv) as (?,HUn); - intros; - cut - (exists psi1 : nat -> StepFun a b, - (forall n:nat, - (forall t:R, - Rmin a b <= t /\ t <= Rmax a b -> - Rabs (f t - phi_sequence RinvN pr1 n t) <= psi1 n t) /\ - Rabs (RiemannInt_SF (psi1 n)) < RinvN n)). - 2:{ split with (fun n:nat => proj1_sig (phi_sequence_prop RinvN pr1 n)); intro; - apply (proj2_sig (phi_sequence_prop RinvN pr1 n)). } - cut - (exists psi2 : nat -> StepFun b a, - (forall n:nat, - (forall t:R, - Rmin a b <= t /\ t <= Rmax a b -> - Rabs (f t - phi_sequence RinvN pr2 n t) <= psi2 n t) /\ - Rabs (RiemannInt_SF (psi2 n)) < RinvN n)). - 2:{ split with (fun n:nat => proj1_sig (phi_sequence_prop RinvN pr2 n)); intro; - rewrite Rmin_comm; rewrite RmaxSym; - apply (proj2_sig (phi_sequence_prop RinvN pr2 n)). } - intros; elim H; clear H; intros psi2 H; elim H0; clear H0; intros psi1 H0; - assert (H1 := RinvN_cv); unfold Un_cv; intros; - assert (H3 : 0 < eps / 3). - { unfold Rdiv; apply Rmult_lt_0_compat; - [ assumption | apply Rinv_0_lt_compat; prove_sup0 ]. } - unfold Un_cv in H1; elim (H1 _ H3); clear H1; intros N0 H1; - unfold Rdist in H1; simpl in H1; - assert (H4 : forall n:nat, (n >= N0)%nat -> RinvN n < eps / 3). - { intros; assert (H5 := H1 _ H4); - replace (pos (RinvN n)) with (Rabs (/ (INR n + 1) - 0)); - [ assumption - | unfold Rminus; rewrite Ropp_0; rewrite Rplus_0_r; apply Rabs_right; - left; apply (cond_pos (RinvN n)) ]. } - clear H1; destruct (HUn _ H3) as (N1,H1); - exists (max N0 N1); intros; unfold Rdist; - apply Rle_lt_trans with - (Rabs - (RiemannInt_SF (phi_sequence RinvN pr1 n) + - RiemannInt_SF (phi_sequence RinvN pr2 n)) + - Rabs (RiemannInt_SF (phi_sequence RinvN pr2 n) - x)). - { rewrite <- (Rabs_Ropp (RiemannInt_SF (phi_sequence RinvN pr2 n) - x)); - replace (RiemannInt_SF (phi_sequence RinvN pr1 n) - - x) with - (RiemannInt_SF (phi_sequence RinvN pr1 n) + - RiemannInt_SF (phi_sequence RinvN pr2 n) + - - (RiemannInt_SF (phi_sequence RinvN pr2 n) - x)); - [ apply Rabs_triang | ring ]. } - replace eps with (2 * (eps / 3) + eps / 3) by lra. - apply Rplus_lt_compat. - 2:{ unfold Rdist in H1; apply H1; unfold ge; - apply Nat.le_trans with (max N0 N1); [ apply Nat.le_max_r | assumption ]. } - rewrite (StepFun_P39 (phi_sequence RinvN pr2 n)); - replace - (RiemannInt_SF (phi_sequence RinvN pr1 n) + - - RiemannInt_SF (mkStepFun (StepFun_P6 (pre (phi_sequence RinvN pr2 n))))) - with - (RiemannInt_SF (phi_sequence RinvN pr1 n) + - -1 * - RiemannInt_SF (mkStepFun (StepFun_P6 (pre (phi_sequence RinvN pr2 n))))); - [ idtac | ring ]; rewrite <- StepFun_P30. - destruct (Rle_dec a b) as [Hle|Hnle]. - { apply Rle_lt_trans with - (RiemannInt_SF - (mkStepFun - (StepFun_P32 - (mkStepFun - (StepFun_P28 (-1) (phi_sequence RinvN pr1 n) - (mkStepFun (StepFun_P6 (pre (phi_sequence RinvN pr2 n))))))))). - { apply StepFun_P34; assumption. } - apply Rle_lt_trans with - (RiemannInt_SF - (mkStepFun - (StepFun_P28 1 (psi1 n) (mkStepFun (StepFun_P6 (pre (psi2 n))))))). - { apply StepFun_P37; try assumption. - intros; simpl; rewrite Rmult_1_l; - apply Rle_trans with - (Rabs (phi_sequence RinvN pr1 n x0 - f x0) + - Rabs (f x0 - phi_sequence RinvN pr2 n x0)). - { replace (phi_sequence RinvN pr1 n x0 + -1 * phi_sequence RinvN pr2 n x0) with - (phi_sequence RinvN pr1 n x0 - f x0 + (f x0 - phi_sequence RinvN pr2 n x0)); - [ apply Rabs_triang | ring ]. } - assert (H7 : Rmin a b = a). - { unfold Rmin; decide (Rle_dec a b) with Hle; reflexivity. } - assert (H8 : Rmax a b = b). - { unfold Rmax; decide (Rle_dec a b) with Hle; reflexivity. } - apply Rplus_le_compat. - { elim (H0 n); intros; rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; apply H9; - rewrite H7; rewrite H8. - elim H6; intros; split; left; assumption. } - elim (H n); intros; apply H9; rewrite H7; rewrite H8. - elim H6; intros; split; left; assumption. } - rewrite StepFun_P30; rewrite Rmult_1_l; rewrite <-Rplus_diag; apply Rplus_lt_compat. - { elim (H0 n); intros; apply Rle_lt_trans with (Rabs (RiemannInt_SF (psi1 n))); - [ apply RRle_abs - | apply Rlt_trans with (pos (RinvN n)); - [ assumption - | apply H4; unfold ge; apply Nat.le_trans with (max N0 N1); - [ apply Nat.le_max_l | assumption ] ] ]. } - elim (H n); intros; - rewrite <- - (Ropp_involutive (RiemannInt_SF (mkStepFun (StepFun_P6 (pre (psi2 n)))))) - ; rewrite <- StepFun_P39; - apply Rle_lt_trans with (Rabs (RiemannInt_SF (psi2 n))); - [ rewrite <- Rabs_Ropp; apply RRle_abs - | apply Rlt_trans with (pos (RinvN n)); - [ assumption - | apply H4; unfold ge; apply Nat.le_trans with (max N0 N1); - [ apply Nat.le_max_l | assumption ] ] ]. } - assert (Hyp : b <= a). - { auto with real. } - rewrite StepFun_P39; rewrite Rabs_Ropp; - apply Rle_lt_trans with - (RiemannInt_SF - (mkStepFun - (StepFun_P32 - (mkStepFun - (StepFun_P6 - (StepFun_P28 (-1) (phi_sequence RinvN pr1 n) - (mkStepFun (StepFun_P6 (pre (phi_sequence RinvN pr2 n)))))))))). - { apply StepFun_P34; assumption. } - apply Rle_lt_trans with - (RiemannInt_SF - (mkStepFun - (StepFun_P28 1 (mkStepFun (StepFun_P6 (pre (psi1 n)))) (psi2 n)))). - { apply StepFun_P37; try assumption. - intros; simpl; rewrite Rmult_1_l; - apply Rle_trans with - (Rabs (phi_sequence RinvN pr1 n x0 - f x0) + - Rabs (f x0 - phi_sequence RinvN pr2 n x0)). - { replace (phi_sequence RinvN pr1 n x0 + -1 * phi_sequence RinvN pr2 n x0) with - (phi_sequence RinvN pr1 n x0 - f x0 + (f x0 - phi_sequence RinvN pr2 n x0)); - [ apply Rabs_triang | ring ]. } - assert (H7 : Rmin a b = b). - { unfold Rmin; decide (Rle_dec a b) with Hnle; reflexivity. } - assert (H8 : Rmax a b = a). - { unfold Rmax; decide (Rle_dec a b) with Hnle; reflexivity. } - apply Rplus_le_compat. - { elim (H0 n); intros; rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; apply H9; - rewrite H7; rewrite H8. - elim H6; intros; split; left; assumption. } - elim (H n); intros; apply H9; rewrite H7; rewrite H8; elim H6; intros; split; - left; assumption. } - rewrite StepFun_P30; rewrite Rmult_1_l; rewrite <-Rplus_diag; apply Rplus_lt_compat. - { elim (H0 n); intros; - rewrite <- - (Ropp_involutive (RiemannInt_SF (mkStepFun (StepFun_P6 (pre (psi1 n)))))) - ; rewrite <- StepFun_P39; - apply Rle_lt_trans with (Rabs (RiemannInt_SF (psi1 n))); - [ rewrite <- Rabs_Ropp; apply RRle_abs - | apply Rlt_trans with (pos (RinvN n)); - [ assumption - | apply H4; unfold ge; apply Nat.le_trans with (max N0 N1); - [ apply Nat.le_max_l | assumption ] ] ]. } - elim (H n); intros; apply Rle_lt_trans with (Rabs (RiemannInt_SF (psi2 n))); - [ apply RRle_abs - | apply Rlt_trans with (pos (RinvN n)); - [ assumption - | apply H4; unfold ge; apply Nat.le_trans with (max N0 N1); - [ apply Nat.le_max_l | assumption ] ] ]. -Qed. - -Lemma RiemannInt_P9 : - forall (f:R -> R) (a:R) (pr:Riemann_integrable f a a), RiemannInt pr = 0. -Proof. - intros; assert (H := RiemannInt_P8 pr pr); apply Rmult_eq_reg_l with 2; - [ rewrite Rmult_0_r; rewrite <-Rplus_diag; pattern (RiemannInt pr) at 2; - rewrite H; apply Rplus_opp_r - | discrR ]. -Qed. - -(* L1([a,b]) is a vectorial space *) -Lemma RiemannInt_P10 : - forall (f g:R -> R) (a b l:R), - Riemann_integrable f a b -> - Riemann_integrable g a b -> - Riemann_integrable (fun x:R => f x + l * g x) a b. -Proof. - unfold Riemann_integrable; intros f g; intros; destruct (Req_dec_T l 0) as [Heq|Hneq]. - { elim (X eps); intros x p; split with x; elim p; intros x0 p0; split with x0; elim p0; - intros; split; try assumption; rewrite Heq; intros; - rewrite Rmult_0_l; rewrite Rplus_0_r; apply H; assumption. } - assert (H : 0 < eps / 2). - { unfold Rdiv; apply Rmult_lt_0_compat; - [ apply (cond_pos eps) | apply Rinv_0_lt_compat; prove_sup0 ]. } - assert (H0 : 0 < eps / (2 * Rabs l)). - { unfold Rdiv; apply Rmult_lt_0_compat; - [ apply (cond_pos eps) - | apply Rinv_0_lt_compat; apply Rmult_lt_0_compat; - [ prove_sup0 | apply Rabs_pos_lt; assumption ] ]. } - elim (X (mkposreal _ H)); intros x p; elim (X0 (mkposreal _ H0)); intros x0 p0; - split with (mkStepFun (StepFun_P28 l x x0)); elim p0; - elim p; intros x1 p1 x2 p2. split with (mkStepFun (StepFun_P28 (Rabs l) x1 x2)); - elim p1; elim p2; clear p1 p2 p0 p X X0; intros; split. - { intros; simpl; - apply Rle_trans with (Rabs (f t - x t) + Rabs (l * (g t - x0 t))). - { replace (f t + l * g t - (x t + l * x0 t)) with - (f t - x t + l * (g t - x0 t)); [ apply Rabs_triang | ring ]. } - apply Rplus_le_compat; - [ apply H3; assumption - | rewrite Rabs_mult; apply Rmult_le_compat_l; - [ apply Rabs_pos | apply H1; assumption ] ]. } - rewrite StepFun_P30; - apply Rle_lt_trans with - (Rabs (RiemannInt_SF x1) + Rabs (Rabs l * RiemannInt_SF x2)). - { apply Rabs_triang. } - rewrite <-(Rplus_half_diag eps); apply Rplus_lt_compat. - { apply H4. } - rewrite Rabs_mult; rewrite Rabs_Rabsolu; apply Rmult_lt_reg_l with (/ Rabs l). - { apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption. } - rewrite <- Rmult_assoc; rewrite Rinv_l; - [ rewrite Rmult_1_l; - replace (/ Rabs l * (eps / 2)) with (eps / (2 * Rabs l)); - [ apply H2 - | unfold Rdiv; rewrite Rinv_mult; ring ] - | apply Rabs_no_R0; assumption ]. -Qed. - -Lemma RiemannInt_P11 : - forall (f:R -> R) (a b l:R) (un:nat -> posreal) - (phi1 phi2 psi1 psi2:nat -> StepFun a b), - Un_cv un 0 -> - (forall n:nat, - (forall t:R, - Rmin a b <= t <= Rmax a b -> Rabs (f t - phi1 n t) <= psi1 n t) /\ - Rabs (RiemannInt_SF (psi1 n)) < un n) -> - (forall n:nat, - (forall t:R, - Rmin a b <= t <= Rmax a b -> Rabs (f t - phi2 n t) <= psi2 n t) /\ - Rabs (RiemannInt_SF (psi2 n)) < un n) -> - Un_cv (fun N:nat => RiemannInt_SF (phi1 N)) l -> - Un_cv (fun N:nat => RiemannInt_SF (phi2 N)) l. -Proof. - unfold Un_cv; intro f; intros; intros. - case (Rle_dec a b); intro Hyp. - - assert (H4 : 0 < eps / 3) by lra. - elim (H _ H4); clear H; intros N0 H. - elim (H2 _ H4); clear H2; intros N1 H2. - set (N := max N0 N1); exists N; intros; unfold Rdist. - apply Rle_lt_trans with - (Rabs (RiemannInt_SF (phi2 n) - RiemannInt_SF (phi1 n)) + - Rabs (RiemannInt_SF (phi1 n) - l)). - { replace (RiemannInt_SF (phi2 n) - l) with - (RiemannInt_SF (phi2 n) - RiemannInt_SF (phi1 n) + - (RiemannInt_SF (phi1 n) - l)); [ apply Rabs_triang | ring ]. } - replace eps with (2 * (eps / 3) + eps / 3) by lra. - apply Rplus_lt_compat. - 2:{ unfold Rdist in H2; apply H2; unfold ge; apply Nat.le_trans with N; - try assumption; unfold N; apply Nat.le_max_r. } - replace (RiemannInt_SF (phi2 n) - RiemannInt_SF (phi1 n)) with - (RiemannInt_SF (phi2 n) + -1 * RiemannInt_SF (phi1 n)); - [ idtac | ring ]. - rewrite <- StepFun_P30. - apply Rle_lt_trans with - (RiemannInt_SF - (mkStepFun (StepFun_P32 (mkStepFun (StepFun_P28 (-1) (phi2 n) (phi1 n)))))). - { apply StepFun_P34; assumption. } - apply Rle_lt_trans with - (RiemannInt_SF (mkStepFun (StepFun_P28 1 (psi1 n) (psi2 n)))). - { apply StepFun_P37; try assumption; intros; simpl; rewrite Rmult_1_l. - apply Rle_trans with (Rabs (phi2 n x - f x) + Rabs (f x - phi1 n x)). - { replace (phi2 n x + -1 * phi1 n x) with (phi2 n x - f x + (f x - phi1 n x)); - [ apply Rabs_triang | ring ]. } - rewrite (Rplus_comm (psi1 n x)); apply Rplus_le_compat. - { rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; elim (H1 n); intros; apply H7. - assert (H10 : Rmin a b = a). - { unfold Rmin; decide (Rle_dec a b) with Hyp; reflexivity. } - assert (H11 : Rmax a b = b). - { unfold Rmax; decide (Rle_dec a b) with Hyp; reflexivity. } - rewrite H10; rewrite H11; elim H6; intros; split; left; assumption. } - elim (H0 n); intros; apply H7; assert (H10 : Rmin a b = a). - { unfold Rmin; decide (Rle_dec a b) with Hyp; reflexivity. } - assert (H11 : Rmax a b = b). - { unfold Rmax; decide (Rle_dec a b) with Hyp; reflexivity. } - rewrite H10; rewrite H11; elim H6; intros; split; left; assumption. } - rewrite StepFun_P30; rewrite Rmult_1_l; rewrite <-Rplus_diag; apply Rplus_lt_compat. - { apply Rlt_trans with (pos (un n)). - { elim (H0 n); intros; apply Rle_lt_trans with (Rabs (RiemannInt_SF (psi1 n))). - { apply RRle_abs. } - assumption. } - replace (pos (un n)) with (Rdist (un n) 0). - { apply H; unfold ge; apply Nat.le_trans with N; try assumption. - unfold N; apply Nat.le_max_l. } - unfold Rdist; unfold Rminus; rewrite Ropp_0; - rewrite Rplus_0_r; apply Rabs_right. - apply Rle_ge; left; apply (cond_pos (un n)). } - apply Rlt_trans with (pos (un n)). - { elim (H1 n); intros; apply Rle_lt_trans with (Rabs (RiemannInt_SF (psi2 n))). - { apply RRle_abs; assumption. } - assumption. } - replace (pos (un n)) with (Rdist (un n) 0). - { apply H; unfold ge; apply Nat.le_trans with N; try assumption; - unfold N; apply Nat.le_max_l. } - unfold Rdist; unfold Rminus; rewrite Ropp_0; - rewrite Rplus_0_r; apply Rabs_right; apply Rle_ge; - left; apply (cond_pos (un n)). - - assert (H4 : 0 < eps / 3) by lra. - elim (H _ H4); clear H; intros N0 H. - elim (H2 _ H4); clear H2; intros N1 H2. - set (N := max N0 N1); exists N; intros; unfold Rdist. - apply Rle_lt_trans with - (Rabs (RiemannInt_SF (phi2 n) - RiemannInt_SF (phi1 n)) + - Rabs (RiemannInt_SF (phi1 n) - l)). - { replace (RiemannInt_SF (phi2 n) - l) with - (RiemannInt_SF (phi2 n) - RiemannInt_SF (phi1 n) + - (RiemannInt_SF (phi1 n) - l)); [ apply Rabs_triang | ring ]. } - assert (Hyp_b : b <= a). - { auto with real. } - replace eps with (2 * (eps / 3) + eps / 3) by lra. - apply Rplus_lt_compat. - 2:{ unfold Rdist in H2; apply H2; unfold ge; apply Nat.le_trans with N; - try assumption; unfold N; apply Nat.le_max_r. } - replace (RiemannInt_SF (phi2 n) - RiemannInt_SF (phi1 n)) with - (RiemannInt_SF (phi2 n) + -1 * RiemannInt_SF (phi1 n)); - [ idtac | ring ]. - rewrite <- StepFun_P30. - rewrite StepFun_P39. - rewrite Rabs_Ropp. - apply Rle_lt_trans with - (RiemannInt_SF - (mkStepFun - (StepFun_P32 - (mkStepFun - (StepFun_P6 - (pre (mkStepFun (StepFun_P28 (-1) (phi2 n) (phi1 n))))))))). - { apply StepFun_P34; try assumption. } - apply Rle_lt_trans with - (RiemannInt_SF - (mkStepFun - (StepFun_P6 (pre (mkStepFun (StepFun_P28 1 (psi1 n) (psi2 n))))))). - { apply StepFun_P37; try assumption. - intros; simpl; rewrite Rmult_1_l. - apply Rle_trans with (Rabs (phi2 n x - f x) + Rabs (f x - phi1 n x)). - { replace (phi2 n x + -1 * phi1 n x) with (phi2 n x - f x + (f x - phi1 n x)); - [ apply Rabs_triang | ring ]. } - rewrite (Rplus_comm (psi1 n x)); apply Rplus_le_compat. - { rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; elim (H1 n); intros; apply H7. - assert (H10 : Rmin a b = b). - { unfold Rmin; case (Rle_dec a b); intro; - [ elim Hyp; assumption | reflexivity ]. } - assert (H11 : Rmax a b = a). - { unfold Rmax; case (Rle_dec a b); intro; - [ elim Hyp; assumption | reflexivity ]. } - rewrite H10; rewrite H11; elim H6; intros; split; left; assumption. } - elim (H0 n); intros; apply H7; assert (H10 : Rmin a b = b). - { unfold Rmin; case (Rle_dec a b); intro; - [ elim Hyp; assumption | reflexivity ]. } - assert (H11 : Rmax a b = a). - { unfold Rmax; case (Rle_dec a b); intro; - [ elim Hyp; assumption | reflexivity ]. } - rewrite H10; rewrite H11; elim H6; intros; split; left; assumption. } - rewrite <- (Ropp_involutive (RiemannInt_SF (mkStepFun - (StepFun_P6 (pre (mkStepFun (StepFun_P28 1 (psi1 n) (psi2 n)))))))). - rewrite <- StepFun_P39. - rewrite StepFun_P30. - rewrite Rmult_1_l; rewrite <-Rplus_diag. - rewrite Ropp_plus_distr; apply Rplus_lt_compat. - { apply Rlt_trans with (pos (un n)). - { elim (H0 n); intros; apply Rle_lt_trans with (Rabs (RiemannInt_SF (psi1 n))). - { rewrite <- Rabs_Ropp; apply RRle_abs. } - assumption. } - replace (pos (un n)) with (Rdist (un n) 0). - { apply H; unfold ge; apply Nat.le_trans with N; try assumption. - unfold N; apply Nat.le_max_l. } - unfold Rdist; unfold Rminus; rewrite Ropp_0; - rewrite Rplus_0_r; apply Rabs_right. - apply Rle_ge; left; apply (cond_pos (un n)). } - apply Rlt_trans with (pos (un n)). - { elim (H1 n); intros; apply Rle_lt_trans with (Rabs (RiemannInt_SF (psi2 n))). - { rewrite <- Rabs_Ropp; apply RRle_abs; assumption. } - assumption. } - replace (pos (un n)) with (Rdist (un n) 0). - { apply H; unfold ge; apply Nat.le_trans with N; try assumption; - unfold N; apply Nat.le_max_l. } - unfold Rdist; unfold Rminus; rewrite Ropp_0; - rewrite Rplus_0_r; apply Rabs_right; apply Rle_ge; - left; apply (cond_pos (un n)). -Qed. - -Lemma RiemannInt_P12 : - forall (f g:R -> R) (a b l:R) (pr1:Riemann_integrable f a b) - (pr2:Riemann_integrable g a b) - (pr3:Riemann_integrable (fun x:R => f x + l * g x) a b), - a <= b -> RiemannInt pr3 = RiemannInt pr1 + l * RiemannInt pr2. -Proof. - intro f; intros; case (Req_dec l 0); intro. - { pattern l at 2; rewrite H0; rewrite Rmult_0_l; rewrite Rplus_0_r; - unfold RiemannInt; destruct (RiemannInt_exists pr3 RinvN RinvN_cv) as (?,HUn_cv); - destruct (RiemannInt_exists pr1 RinvN RinvN_cv) as (?,HUn_cv0); intros. - eapply UL_sequence; - [ apply HUn_cv - | set (psi1 := fun n:nat => proj1_sig (phi_sequence_prop RinvN pr1 n)); - set (psi2 := fun n:nat => proj1_sig (phi_sequence_prop RinvN pr3 n)); - apply RiemannInt_P11 with f RinvN (phi_sequence RinvN pr1) psi1 psi2; - [ apply RinvN_cv - | intro; apply (proj2_sig (phi_sequence_prop RinvN pr1 n)) - | intro; - assert - (H1 : - (forall t:R, - Rmin a b <= t /\ t <= Rmax a b -> - Rabs (f t + l * g t - phi_sequence RinvN pr3 n t) <= psi2 n t) /\ - Rabs (RiemannInt_SF (psi2 n)) < RinvN n); - [ apply (proj2_sig (phi_sequence_prop RinvN pr3 n)) - | elim H1; intros; split; try assumption; intros; - replace (f t) with (f t + l * g t); - [ apply H2; assumption | rewrite H0; ring ] ] - | assumption ] ]. } - eapply UL_sequence. - { unfold RiemannInt; destruct (RiemannInt_exists pr3 RinvN RinvN_cv) as (?,HUn_cv); - intros; apply HUn_cv. } - unfold Un_cv; intros; unfold RiemannInt; - case (RiemannInt_exists pr1 RinvN RinvN_cv) as (x0,HUn_cv0); - case (RiemannInt_exists pr2 RinvN RinvN_cv) as (x,HUn_cv); unfold Un_cv; - intros; assert (H2 : 0 < eps / 5). - { unfold Rdiv; apply Rmult_lt_0_compat; - [ assumption | apply Rinv_0_lt_compat; prove_sup0 ]. } - elim (HUn_cv0 _ H2); clear HUn_cv0; intros N0 H3; assert (H4 := RinvN_cv); - unfold Un_cv in H4; elim (H4 _ H2); clear H4 H2; intros N1 H4; - assert (H5 : 0 < eps / (5 * Rabs l)). - { unfold Rdiv; apply Rmult_lt_0_compat; - [ assumption - | apply Rinv_0_lt_compat; apply Rmult_lt_0_compat; - [ prove_sup0 | apply Rabs_pos_lt; assumption ] ]. } - elim (HUn_cv _ H5); clear HUn_cv; intros N2 H6; assert (H7 := RinvN_cv); - unfold Un_cv in H7; elim (H7 _ H5); clear H7 H5; intros N3 H5; - unfold Rdist in H3, H4, H5, H6; set (N := max (max N0 N1) (max N2 N3)). - assert (H7 : forall n:nat, (n >= N1)%nat -> RinvN n < eps / 5). - { intros; replace (pos (RinvN n)) with (Rabs (RinvN n - 0)); - [ unfold RinvN; apply H4; assumption - | unfold Rminus; rewrite Ropp_0; rewrite Rplus_0_r; apply Rabs_right; - left; apply (cond_pos (RinvN n)) ]. } - clear H4; assert (H4 := H7); clear H7; - assert (H7 : forall n:nat, (n >= N3)%nat -> RinvN n < eps / (5 * Rabs l)). - { intros; replace (pos (RinvN n)) with (Rabs (RinvN n - 0)); - [ unfold RinvN; apply H5; assumption - | unfold Rminus; rewrite Ropp_0; rewrite Rplus_0_r; apply Rabs_right; - left; apply (cond_pos (RinvN n)) ]. } - clear H5; assert (H5 := H7); clear H7; exists N; intros; - unfold Rdist. - apply Rle_lt_trans with - (Rabs - (RiemannInt_SF (phi_sequence RinvN pr3 n) - - (RiemannInt_SF (phi_sequence RinvN pr1 n) + - l * RiemannInt_SF (phi_sequence RinvN pr2 n))) + - Rabs (RiemannInt_SF (phi_sequence RinvN pr1 n) - x0) + - Rabs l * Rabs (RiemannInt_SF (phi_sequence RinvN pr2 n) - x)). - { apply Rle_trans with - (Rabs - (RiemannInt_SF (phi_sequence RinvN pr3 n) - - (RiemannInt_SF (phi_sequence RinvN pr1 n) + - l * RiemannInt_SF (phi_sequence RinvN pr2 n))) + - Rabs - (RiemannInt_SF (phi_sequence RinvN pr1 n) - x0 + - l * (RiemannInt_SF (phi_sequence RinvN pr2 n) - x))). - { replace (RiemannInt_SF (phi_sequence RinvN pr3 n) - (x0 + l * x)) with - (RiemannInt_SF (phi_sequence RinvN pr3 n) - - (RiemannInt_SF (phi_sequence RinvN pr1 n) + - l * RiemannInt_SF (phi_sequence RinvN pr2 n)) + - (RiemannInt_SF (phi_sequence RinvN pr1 n) - x0 + - l * (RiemannInt_SF (phi_sequence RinvN pr2 n) - x))); - [ apply Rabs_triang | ring ]. } - rewrite Rplus_assoc; apply Rplus_le_compat_l; rewrite <- Rabs_mult; - replace - (RiemannInt_SF (phi_sequence RinvN pr1 n) - x0 + - l * (RiemannInt_SF (phi_sequence RinvN pr2 n) - x)) with - (RiemannInt_SF (phi_sequence RinvN pr1 n) - x0 + - l * (RiemannInt_SF (phi_sequence RinvN pr2 n) - x)); - [ apply Rabs_triang | ring ]. } - replace eps with (3 * (eps / 5) + eps / 5 + eps / 5) by lra. - apply Rplus_lt_compat. - 2:{ apply Rmult_lt_reg_l with (/ Rabs l). - { apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption. } - rewrite <- Rmult_assoc; rewrite Rinv_l. - 2:apply Rabs_no_R0; assumption. - rewrite Rmult_1_l; replace (/ Rabs l * (eps / 5)) with (eps / (5 * Rabs l)). - { apply H6; unfold ge; apply Nat.le_trans with (max N2 N3); - [ apply Nat.le_max_l - | apply Nat.le_trans with N; [ unfold N; apply Nat.le_max_r | assumption ] ]. } - unfold Rdiv; rewrite Rinv_mult; ring. } - apply Rplus_lt_compat. - 2:apply H3;Lia.lia. - assert - (H7 : - exists psi1 : nat -> StepFun a b, - (forall n:nat, - (forall t:R, - Rmin a b <= t /\ t <= Rmax a b -> - Rabs (f t - phi_sequence RinvN pr1 n t) <= psi1 n t) /\ - Rabs (RiemannInt_SF (psi1 n)) < RinvN n)). - { split with (fun n:nat => proj1_sig (phi_sequence_prop RinvN pr1 n)); intro; - apply (proj2_sig (phi_sequence_prop RinvN pr1 n0)). } - assert - (H8 : - exists psi2 : nat -> StepFun a b, - (forall n:nat, - (forall t:R, - Rmin a b <= t /\ t <= Rmax a b -> - Rabs (g t - phi_sequence RinvN pr2 n t) <= psi2 n t) /\ - Rabs (RiemannInt_SF (psi2 n)) < RinvN n)). - { split with (fun n:nat => proj1_sig (phi_sequence_prop RinvN pr2 n)); intro; - apply (proj2_sig (phi_sequence_prop RinvN pr2 n0)). } - assert - (H9 : - exists psi3 : nat -> StepFun a b, - (forall n:nat, - (forall t:R, - Rmin a b <= t /\ t <= Rmax a b -> - Rabs (f t + l * g t - phi_sequence RinvN pr3 n t) <= psi3 n t) /\ - Rabs (RiemannInt_SF (psi3 n)) < RinvN n)). - { split with (fun n:nat => proj1_sig (phi_sequence_prop RinvN pr3 n)); intro; - apply (proj2_sig (phi_sequence_prop RinvN pr3 n0)). } - elim H7; clear H7; intros psi1 H7; elim H8; clear H8; intros psi2 H8; elim H9; - clear H9; intros psi3 H9; - replace - (RiemannInt_SF (phi_sequence RinvN pr3 n) - - (RiemannInt_SF (phi_sequence RinvN pr1 n) + - l * RiemannInt_SF (phi_sequence RinvN pr2 n))) with - (RiemannInt_SF (phi_sequence RinvN pr3 n) + - -1 * - (RiemannInt_SF (phi_sequence RinvN pr1 n) + - l * RiemannInt_SF (phi_sequence RinvN pr2 n))); - [ idtac | ring ]; do 2 rewrite <- StepFun_P30; assert (H10 : Rmin a b = a). - { unfold Rmin; decide (Rle_dec a b) with H; reflexivity. } - assert (H11 : Rmax a b = b). - { unfold Rmax; decide (Rle_dec a b) with H; reflexivity. } - rewrite H10 in H7; rewrite H10 in H8; rewrite H10 in H9; rewrite H11 in H7; - rewrite H11 in H8; rewrite H11 in H9; - apply Rle_lt_trans with - (RiemannInt_SF - (mkStepFun - (StepFun_P32 - (mkStepFun - (StepFun_P28 (-1) (phi_sequence RinvN pr3 n) - (mkStepFun - (StepFun_P28 l (phi_sequence RinvN pr1 n) - (phi_sequence RinvN pr2 n)))))))). - { apply StepFun_P34; assumption. } - apply Rle_lt_trans with - (RiemannInt_SF - (mkStepFun - (StepFun_P28 1 (psi3 n) - (mkStepFun (StepFun_P28 (Rabs l) (psi1 n) (psi2 n)))))). - { apply StepFun_P37; try assumption. - intros; simpl; rewrite Rmult_1_l. - apply Rle_trans with - (Rabs (phi_sequence RinvN pr3 n x1 - (f x1 + l * g x1)) + - Rabs - (f x1 + l * g x1 + - -1 * (phi_sequence RinvN pr1 n x1 + l * phi_sequence RinvN pr2 n x1))). - { replace - (phi_sequence RinvN pr3 n x1 + - -1 * (phi_sequence RinvN pr1 n x1 + l * phi_sequence RinvN pr2 n x1)) with - (phi_sequence RinvN pr3 n x1 - (f x1 + l * g x1) + - (f x1 + l * g x1 + - -1 * (phi_sequence RinvN pr1 n x1 + l * phi_sequence RinvN pr2 n x1))); - [ apply Rabs_triang | ring ]. } - rewrite Rplus_assoc; apply Rplus_le_compat. - { elim (H9 n); intros; rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; - apply H13. - elim H12; intros; split; left; assumption. } - apply Rle_trans with - (Rabs (f x1 - phi_sequence RinvN pr1 n x1) + - Rabs l * Rabs (g x1 - phi_sequence RinvN pr2 n x1)). - { rewrite <- Rabs_mult; - replace - (f x1 + - (l * g x1 + - -1 * (phi_sequence RinvN pr1 n x1 + l * phi_sequence RinvN pr2 n x1))) - with - (f x1 - phi_sequence RinvN pr1 n x1 + - l * (g x1 - phi_sequence RinvN pr2 n x1)); [ apply Rabs_triang | ring ]. } - apply Rplus_le_compat. - { elim (H7 n); intros; apply H13. - elim H12; intros; split; left; assumption. } - apply Rmult_le_compat_l; - [ apply Rabs_pos - | elim (H8 n); intros; apply H13; elim H12; intros; split; left; assumption ]. } - do 2 rewrite StepFun_P30; rewrite Rmult_1_l; - replace (3 * (eps / 5)) with (eps / 5 + (eps / 5 + eps / 5)) by ring. - repeat apply Rplus_lt_compat. - - apply Rlt_trans with (pos (RinvN n)); - [ apply Rle_lt_trans with (Rabs (RiemannInt_SF (psi3 n))); - [ apply RRle_abs | elim (H9 n); intros; assumption ] - | apply H4; unfold ge; apply Nat.le_trans with N; - [ apply Nat.le_trans with (max N0 N1); - [ apply Nat.le_max_r | unfold N; apply Nat.le_max_l ] - | assumption ] ]. - - apply Rlt_trans with (pos (RinvN n)); - [ apply Rle_lt_trans with (Rabs (RiemannInt_SF (psi1 n))); - [ apply RRle_abs | elim (H7 n); intros; assumption ] - | apply H4; unfold ge; apply Nat.le_trans with N; - [ apply Nat.le_trans with (max N0 N1); - [ apply Nat.le_max_r | unfold N; apply Nat.le_max_l ] - | assumption ] ]. - - apply Rmult_lt_reg_l with (/ Rabs l). - { apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption. } - rewrite <- Rmult_assoc; rewrite Rinv_l. - { rewrite Rmult_1_l; replace (/ Rabs l * (eps / 5)) with (eps / (5 * Rabs l)). - { apply Rlt_trans with (pos (RinvN n)); - [ apply Rle_lt_trans with (Rabs (RiemannInt_SF (psi2 n))); - [ apply RRle_abs | elim (H8 n); intros; assumption ] - | apply H5; unfold ge; apply Nat.le_trans with N; - [ apply Nat.le_trans with (max N2 N3); - [ apply Nat.le_max_r | unfold N; apply Nat.le_max_r ] - | assumption ] ]. } - unfold Rdiv; rewrite Rinv_mult; ring. } - apply Rabs_no_R0; assumption. -Qed. - -Lemma RiemannInt_P13 : - forall (f g:R -> R) (a b l:R) (pr1:Riemann_integrable f a b) - (pr2:Riemann_integrable g a b) - (pr3:Riemann_integrable (fun x:R => f x + l * g x) a b), - RiemannInt pr3 = RiemannInt pr1 + l * RiemannInt pr2. -Proof. - intros; destruct (Rle_dec a b) as [Hle|Hnle]; - [ apply RiemannInt_P12; assumption - | assert (H : b <= a); - [ auto with real - | replace (RiemannInt pr3) with (- RiemannInt (RiemannInt_P1 pr3)); - [ idtac | symmetry ; apply RiemannInt_P8 ]; - replace (RiemannInt pr2) with (- RiemannInt (RiemannInt_P1 pr2)); - [ idtac | symmetry ; apply RiemannInt_P8 ]; - replace (RiemannInt pr1) with (- RiemannInt (RiemannInt_P1 pr1)); - [ idtac | symmetry ; apply RiemannInt_P8 ]; - rewrite - (RiemannInt_P12 (RiemannInt_P1 pr1) (RiemannInt_P1 pr2) - (RiemannInt_P1 pr3) H); ring ] ]. -Qed. - -Lemma RiemannInt_P14 : forall a b c:R, Riemann_integrable (fct_cte c) a b. -Proof. - unfold Riemann_integrable; intros; - split with (mkStepFun (StepFun_P4 a b c)); - split with (mkStepFun (StepFun_P4 a b 0)); split; - [ intros; simpl; unfold Rminus; rewrite Rplus_opp_r; - rewrite Rabs_R0; unfold fct_cte; right; - reflexivity - | rewrite StepFun_P18; rewrite Rmult_0_l; rewrite Rabs_R0; - apply (cond_pos eps) ]. -Qed. - -Lemma RiemannInt_P15 : - forall (a b c:R) (pr:Riemann_integrable (fct_cte c) a b), - RiemannInt pr = c * (b - a). -Proof. - intros; unfold RiemannInt; destruct (RiemannInt_exists pr RinvN RinvN_cv) as (?,HUn_cv); - intros; eapply UL_sequence. - { apply HUn_cv. } - set (phi1 := fun N:nat => phi_sequence RinvN pr N); - change (Un_cv (fun N:nat => RiemannInt_SF (phi1 N)) (c * (b - a))); - set (f := fct_cte c); - assert - (H1 : - exists psi1 : nat -> StepFun a b, - (forall n:nat, - (forall t:R, - Rmin a b <= t /\ t <= Rmax a b -> - Rabs (f t - phi_sequence RinvN pr n t) <= psi1 n t) /\ - Rabs (RiemannInt_SF (psi1 n)) < RinvN n)). - { split with (fun n:nat => proj1_sig (phi_sequence_prop RinvN pr n)); intro; - apply (proj2_sig (phi_sequence_prop RinvN pr n)). } - elim H1; clear H1; intros psi1 H1; - set (phi2 := fun n:nat => mkStepFun (StepFun_P4 a b c)); - set (psi2 := fun n:nat => mkStepFun (StepFun_P4 a b 0)); - apply RiemannInt_P11 with f RinvN phi2 psi2 psi1. - - apply RinvN_cv. - - intro; split. - { intros; unfold f; simpl; unfold Rminus; - rewrite Rplus_opp_r; rewrite Rabs_R0; unfold fct_cte; - right; reflexivity. } - unfold psi2; rewrite StepFun_P18; rewrite Rmult_0_l; rewrite Rabs_R0; - apply (cond_pos (RinvN n)). - - assumption. - - unfold Un_cv; intros; split with 0%nat; intros; unfold Rdist; - unfold phi2; rewrite StepFun_P18; unfold Rminus; - rewrite Rplus_opp_r; rewrite Rabs_R0; apply H. -Qed. - -Lemma RiemannInt_P16 : - forall (f:R -> R) (a b:R), - Riemann_integrable f a b -> Riemann_integrable (fun x:R => Rabs (f x)) a b. -Proof. - unfold Riemann_integrable; intro f; intros; elim (X eps); clear X; - intros phi [psi [H H0]]; split with (mkStepFun (StepFun_P32 phi)); - split with psi; split; try assumption; intros; simpl; - apply Rle_trans with (Rabs (f t - phi t)); - [ apply Rabs_triang_inv2 | apply H; assumption ]. -Qed. - -Lemma Rle_cv_lim : - forall (Un Vn:nat -> R) (l1 l2:R), - (forall n:nat, Un n <= Vn n) -> Un_cv Un l1 -> Un_cv Vn l2 -> l1 <= l2. -Proof. - intros; destruct (Rle_dec l1 l2) as [Hle|Hnle]. - { assumption. } - assert (H2 : l2 < l1). - { auto with real. } - assert (H3 : 0 < (l1 - l2) / 2). - { unfold Rdiv; apply Rmult_lt_0_compat; - [ apply Rlt_0_minus; assumption | apply Rinv_0_lt_compat; prove_sup0 ]. } - elim (H1 _ H3); elim (H0 _ H3); clear H0 H1; unfold Rdist; intros; - set (N := max x x0); cut (Vn N < Un N). - { intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ (H N) H4)). } - apply Rlt_trans with ((l1 + l2) / 2). - { apply Rplus_lt_reg_l with (- l2); - replace (- l2 + (l1 + l2) / 2) with ((l1 - l2) / 2). - { rewrite Rplus_comm; apply Rle_lt_trans with (Rabs (Vn N - l2)). - { apply RRle_abs. } - apply H1; unfold ge; unfold N; apply Nat.le_max_r. } - lra. } - apply Ropp_lt_cancel; apply Rplus_lt_reg_l with l1; - replace (l1 + - ((l1 + l2) / 2)) with ((l1 - l2) / 2). - { apply Rle_lt_trans with (Rabs (Un N - l1)). - { rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; apply RRle_abs. } - apply H0; unfold ge; unfold N; apply Nat.le_max_l. } - lra. -Qed. - -Lemma RiemannInt_P17 : - forall (f:R -> R) (a b:R) (pr1:Riemann_integrable f a b) - (pr2:Riemann_integrable (fun x:R => Rabs (f x)) a b), - a <= b -> Rabs (RiemannInt pr1) <= RiemannInt pr2. -Proof. - intro f; intros; unfold RiemannInt; - case (RiemannInt_exists pr1 RinvN RinvN_cv) as (x0,HUn_cv0); - case (RiemannInt_exists pr2 RinvN RinvN_cv) as (x,HUn_cv); - set (phi1 := phi_sequence RinvN pr1) in HUn_cv0; - set (phi2 := fun N:nat => mkStepFun (StepFun_P32 (phi1 N))); - apply Rle_cv_lim with - (fun N:nat => Rabs (RiemannInt_SF (phi1 N))) - (fun N:nat => RiemannInt_SF (phi2 N)). - { intro; unfold phi2; apply StepFun_P34; assumption. } - { apply (continuity_seq Rabs (fun N:nat => RiemannInt_SF (phi1 N)) x0); - try assumption. - apply Rcontinuity_abs. } - set (phi3 := phi_sequence RinvN pr2); - assert - (H0 : - exists psi3 : nat -> StepFun a b, - (forall n:nat, - (forall t:R, - Rmin a b <= t /\ t <= Rmax a b -> - Rabs (Rabs (f t) - phi3 n t) <= psi3 n t) /\ - Rabs (RiemannInt_SF (psi3 n)) < RinvN n)). - { split with (fun n:nat => proj1_sig (phi_sequence_prop RinvN pr2 n)); intro; - apply (proj2_sig (phi_sequence_prop RinvN pr2 n)). } - assert - (H1 : - exists psi2 : nat -> StepFun a b, - (forall n:nat, - (forall t:R, - Rmin a b <= t /\ t <= Rmax a b -> - Rabs (Rabs (f t) - phi2 n t) <= psi2 n t) /\ - Rabs (RiemannInt_SF (psi2 n)) < RinvN n)). - { assert - (H1 : - exists psi2 : nat -> StepFun a b, - (forall n:nat, - (forall t:R, - Rmin a b <= t /\ t <= Rmax a b -> Rabs (f t - phi1 n t) <= psi2 n t) /\ - Rabs (RiemannInt_SF (psi2 n)) < RinvN n)). - { split with (fun n:nat => proj1_sig (phi_sequence_prop RinvN pr1 n)); intro; - apply (proj2_sig (phi_sequence_prop RinvN pr1 n)). } - elim H1; clear H1; intros psi2 H1; split with psi2; intros; elim (H1 n); - clear H1; intros; split; try assumption. - intros; unfold phi2; simpl; - apply Rle_trans with (Rabs (f t - phi1 n t)). - { apply Rabs_triang_inv2. } - apply H1; assumption. } - elim H0; clear H0; intros psi3 H0; elim H1; clear H1; intros psi2 H1; - apply RiemannInt_P11 with (fun x:R => Rabs (f x)) RinvN phi3 psi3 psi2; - try assumption; apply RinvN_cv. -Qed. - -Lemma RiemannInt_P18 : - forall (f g:R -> R) (a b:R) (pr1:Riemann_integrable f a b) - (pr2:Riemann_integrable g a b), - a <= b -> - (forall x:R, a < x < b -> f x = g x) -> RiemannInt pr1 = RiemannInt pr2. -Proof. - intro f; intros; unfold RiemannInt; - case (RiemannInt_exists pr1 RinvN RinvN_cv) as (x0,HUn_cv0); - case (RiemannInt_exists pr2 RinvN RinvN_cv) as (x,HUn_cv); - eapply UL_sequence. - { apply HUn_cv0. } - set (phi1 := fun N:nat => phi_sequence RinvN pr1 N); - change (Un_cv (fun N:nat => RiemannInt_SF (phi1 N)) x); - assert - (H1 : - exists psi1 : nat -> StepFun a b, - (forall n:nat, - (forall t:R, - Rmin a b <= t /\ t <= Rmax a b -> - Rabs (f t - phi1 n t) <= psi1 n t) /\ - Rabs (RiemannInt_SF (psi1 n)) < RinvN n)). - { split with (fun n:nat => proj1_sig (phi_sequence_prop RinvN pr1 n)); intro; - apply (proj2_sig (phi_sequence_prop RinvN pr1 n)). } - elim H1; clear H1; intros psi1 H1; - set (phi2 := fun N:nat => phi_sequence RinvN pr2 N). - set - (phi2_aux := - fun (N:nat) (x:R) => - match Req_dec_T x a with - | left _ => f a - | right _ => - match Req_dec_T x b with - | left _ => f b - | right _ => phi2 N x - end - end). - cut (forall N:nat, IsStepFun (phi2_aux N) a b). - { intro; set (phi2_m := fun N:nat => mkStepFun (X N)). - assert - (H2 : - exists psi2 : nat -> StepFun a b, - (forall n:nat, - (forall t:R, - Rmin a b <= t /\ t <= Rmax a b -> Rabs (g t - phi2 n t) <= psi2 n t) /\ - Rabs (RiemannInt_SF (psi2 n)) < RinvN n)). - { split with (fun n:nat => proj1_sig (phi_sequence_prop RinvN pr2 n)); intro; - apply (proj2_sig (phi_sequence_prop RinvN pr2 n)). } - elim H2; clear H2; intros psi2 H2; - apply RiemannInt_P11 with f RinvN phi2_m psi2 psi1; - try assumption. - - apply RinvN_cv. - - intro; elim (H2 n); intros; split; try assumption. - intros; unfold phi2_m; simpl; unfold phi2_aux; - destruct (Req_dec_T t a) as [Heqa|Hneqa]; destruct (Req_dec_T t b) as [Heqb|Hneqb]. - + rewrite Heqa; unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0; - apply Rle_trans with (Rabs (g t - phi2 n t)). - { apply Rabs_pos. } - pattern a at 3; rewrite <- Heqa; apply H3; assumption. - + rewrite Heqa; unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0; - apply Rle_trans with (Rabs (g t - phi2 n t)). - { apply Rabs_pos. } - pattern a at 3; rewrite <- Heqa; apply H3; assumption. - + rewrite Heqb; unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0; - apply Rle_trans with (Rabs (g t - phi2 n t)). - { apply Rabs_pos. } - pattern b at 3; rewrite <- Heqb; apply H3; assumption. - + replace (f t) with (g t). - { apply H3; assumption. } - symmetry ; apply H0; elim H5; clear H5; intros. - assert (H7 : Rmin a b = a). - { unfold Rmin; destruct (Rle_dec a b) as [Heqab|Hneqab]; - [ reflexivity | elim Hneqab; assumption ]. } - assert (H8 : Rmax a b = b). - { unfold Rmax; destruct (Rle_dec a b) as [Heqab|Hneqab]; - [ reflexivity | elim Hneqab; assumption ]. } - rewrite H7 in H5; rewrite H8 in H6; split. - { elim H5; intro; [ assumption | elim Hneqa; symmetry ; assumption ]. } - elim H6; intro; [ assumption | elim Hneqb; assumption ]. - - cut (forall N:nat, RiemannInt_SF (phi2_m N) = RiemannInt_SF (phi2 N)). - { intro; unfold Un_cv; intros; elim (HUn_cv _ H4); intros; exists x1; intros; - rewrite (H3 n); apply H5; assumption. } - intro; apply Rle_antisym. - { apply StepFun_P37; try assumption. - intros; unfold phi2_m; simpl; unfold phi2_aux; - destruct (Req_dec_T x1 a) as [Heqa|Hneqa]; destruct (Req_dec_T x1 b) as [Heqb|Hneqb]. - + elim H3; intros; rewrite Heqa in H4; elim (Rlt_irrefl _ H4). - + elim H3; intros; rewrite Heqa in H4; elim (Rlt_irrefl _ H4). - + elim H3; intros; rewrite Heqb in H5; elim (Rlt_irrefl _ H5). - + right; reflexivity. } - apply StepFun_P37; try assumption. - intros; unfold phi2_m; simpl; unfold phi2_aux; - destruct (Req_dec_T x1 a) as [ -> |Hneqa]. - { elim H3; intros; elim (Rlt_irrefl _ H4). } - destruct (Req_dec_T x1 b) as [ -> |Hneqb]. - { elim H3; intros; elim (Rlt_irrefl _ H5). } - right; reflexivity. } - intro; assert (H2 := pre (phi2 N)); unfold IsStepFun in H2; - unfold is_subdivision in H2; elim H2; clear H2; intros l [lf H2]; - split with l; split with lf; unfold adapted_couple in H2; - decompose [and] H2; clear H2; unfold adapted_couple; - repeat split; try assumption. - intros; assert (H9 := H8 i H2); unfold constant_D_eq, open_interval in H9; - unfold constant_D_eq, open_interval; intros; - rewrite <- (H9 x1 H7); assert (H10 : a <= pos_Rl l i). - { replace a with (Rmin a b). - { rewrite <- H5; elim (RList_P6 l); intros; apply H10. - - assumption. - - apply Nat.le_0_l. - - apply Nat.lt_trans with (pred (length l)); [ assumption | apply Nat.lt_pred_l ]. - intro; rewrite H12 in H6; discriminate. } - unfold Rmin; decide (Rle_dec a b) with H; reflexivity. } - assert (H11 : pos_Rl l (S i) <= b). - { replace b with (Rmax a b). - { rewrite <- H4; elim (RList_P6 l); intros; apply H11. - - assumption. - - apply Nat.le_succ_l; assumption. - - apply Nat.lt_pred_l; intro; rewrite H13 in H6; discriminate. } - unfold Rmax; decide (Rle_dec a b) with H; reflexivity. } - elim H7; clear H7; intros; unfold phi2_aux; destruct (Req_dec_T x1 a) as [Heq|Hneq]; - destruct (Req_dec_T x1 b) as [Heq'|Hneq']. - - rewrite Heq' in H12; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H11 H12)). - - rewrite Heq in H7; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H10 H7)). - - rewrite Heq' in H12; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H11 H12)). - - reflexivity. -Qed. - -Lemma RiemannInt_P19 : - forall (f g:R -> R) (a b:R) (pr1:Riemann_integrable f a b) - (pr2:Riemann_integrable g a b), - a <= b -> - (forall x:R, a < x < b -> f x <= g x) -> RiemannInt pr1 <= RiemannInt pr2. -Proof. - intro f; intros; apply Rplus_le_reg_l with (- RiemannInt pr1); - rewrite Rplus_opp_l; rewrite Rplus_comm; - apply Rle_trans with (Rabs (RiemannInt (RiemannInt_P10 (-1) pr2 pr1))). - { apply Rabs_pos. } - replace (RiemannInt pr2 + - RiemannInt pr1) with - (RiemannInt (RiemannInt_P16 (RiemannInt_P10 (-1) pr2 pr1))). - { apply - (RiemannInt_P17 (RiemannInt_P10 (-1) pr2 pr1) - (RiemannInt_P16 (RiemannInt_P10 (-1) pr2 pr1))); - assumption. } - replace (RiemannInt pr2 + - RiemannInt pr1) with - (RiemannInt (RiemannInt_P10 (-1) pr2 pr1)). - { apply RiemannInt_P18; try assumption. - intros; apply Rabs_right. - apply Rle_ge; apply Rplus_le_reg_l with (f x); rewrite Rplus_0_r; - replace (f x + (g x + -1 * f x)) with (g x); [ apply H0; assumption | ring ]. } - rewrite (RiemannInt_P12 pr2 pr1 (RiemannInt_P10 (-1) pr2 pr1)); - [ ring | assumption ]. -Qed. - -Lemma FTC_P1 : - forall (f:R -> R) (a b:R), - a <= b -> - (forall x:R, a <= x <= b -> continuity_pt f x) -> - forall x:R, a <= x -> x <= b -> Riemann_integrable f a x. -Proof. - intros; apply continuity_implies_RiemannInt; - [ assumption - | intros; apply H0; elim H3; intros; split; - assumption || apply Rle_trans with x; assumption ]. -Qed. - -Definition primitive (f:R -> R) (a b:R) (h:a <= b) - (pr:forall x:R, a <= x -> x <= b -> Riemann_integrable f a x) - (x:R) : R := - match Rle_dec a x with - | left r => - match Rle_dec x b with - | left r0 => RiemannInt (pr x r r0) - | right _ => f b * (x - b) + RiemannInt (pr b h (Rle_refl b)) - end - | right _ => f a * (x - a) - end. - -Lemma RiemannInt_P20 : - forall (f:R -> R) (a b:R) (h:a <= b) - (pr:forall x:R, a <= x -> x <= b -> Riemann_integrable f a x) - (pr0:Riemann_integrable f a b), - RiemannInt pr0 = primitive h pr b - primitive h pr a. -Proof. - intros; replace (primitive h pr a) with 0. - { replace (RiemannInt pr0) with (primitive h pr b). - { ring. } - unfold primitive; destruct (Rle_dec a b) as [Hle|[]]; destruct (Rle_dec b b) as [Hle'|Hnle']; - [ apply RiemannInt_P5 - | destruct Hnle'; right; reflexivity - | assumption - | assumption]. } - symmetry ; unfold primitive; destruct (Rle_dec a a) as [Hle|[]]; - destruct (Rle_dec a b) as [Hle'|Hnle']; - [ apply RiemannInt_P9 - | elim Hnle'; assumption - | right; reflexivity - | right; reflexivity ]. -Qed. - -Lemma RiemannInt_P21 : - forall (f:R -> R) (a b c:R), - a <= b -> - b <= c -> - Riemann_integrable f a b -> - Riemann_integrable f b c -> Riemann_integrable f a c. -Proof. - unfold Riemann_integrable; intros f a b c Hyp1 Hyp2 X X0 eps. - assert (H : 0 < eps / 2). - { unfold Rdiv; apply Rmult_lt_0_compat; - [ apply (cond_pos eps) | apply Rinv_0_lt_compat; prove_sup0 ]. } - elim (X (mkposreal _ H)); clear X; intros phi1 [psi1 H1]; - elim (X0 (mkposreal _ H)); clear X0; intros phi2 [psi2 H2]. - set - (phi3 := - fun x:R => - match Rle_dec a x with - | left _ => - match Rle_dec x b with - | left _ => phi1 x - | right _ => phi2 x - end - | right _ => 0 - end). - set - (psi3 := - fun x:R => - match Rle_dec a x with - | left _ => - match Rle_dec x b with - | left _ => psi1 x - | right _ => psi2 x - end - | right _ => 0 - end). - cut (IsStepFun phi3 a c). - 1:intro; cut (IsStepFun psi3 a b). - 1:intro; cut (IsStepFun psi3 b c). - 1:intro; assert (IsStepFun psi3 a c) by (apply StepFun_P46 with b; assumption). - - split with (mkStepFun X); split with (mkStepFun X2); simpl; - split. - + intros; unfold phi3, psi3; case (Rle_dec t b) as [|Hnle]; case (Rle_dec a t) as [|Hnle']. - * elim H1; intros; apply H3. - replace (Rmin a b) with a. - { replace (Rmax a b) with b. - { split; assumption. } - unfold Rmax; decide (Rle_dec a b) with Hyp1; reflexivity. } - unfold Rmin; decide (Rle_dec a b) with Hyp1; reflexivity. - * elim Hnle'; replace a with (Rmin a c). - { elim H0; intros; assumption. } - unfold Rmin; case (Rle_dec a c) as [|[]]; - [ reflexivity | apply Rle_trans with b; assumption ]. - * elim H2; intros; apply H3. - replace (Rmax b c) with (Rmax a c). - { elim H0; intros; split; try assumption. - replace (Rmin b c) with b. - { auto with real. } - unfold Rmin; decide (Rle_dec b c) with Hyp2; reflexivity. } - unfold Rmax; decide (Rle_dec b c) with Hyp2; case (Rle_dec a c) as [|[]]; - [ reflexivity | apply Rle_trans with b; assumption ]. - * elim Hnle'; replace a with (Rmin a c). - { elim H0; intros; assumption. } - unfold Rmin; case (Rle_dec a c) as [|[]]; - [ reflexivity | apply Rle_trans with b; assumption ]. - + rewrite <- (StepFun_P43 X0 X1 X2). - apply Rle_lt_trans with - (Rabs (RiemannInt_SF (mkStepFun X0)) + Rabs (RiemannInt_SF (mkStepFun X1))). - { apply Rabs_triang. } - rewrite <-(Rplus_half_diag eps); - replace (RiemannInt_SF (mkStepFun X0)) with (RiemannInt_SF psi1). - { replace (RiemannInt_SF (mkStepFun X1)) with (RiemannInt_SF psi2). - { apply Rplus_lt_compat. - { elim H1; intros; assumption. } - elim H2; intros; assumption. } - apply Rle_antisym. - { apply StepFun_P37; try assumption. - simpl; intros; unfold psi3; elim H0; clear H0; intros; - destruct (Rle_dec a x) as [Hle|Hnle]; destruct (Rle_dec x b) as [Hle'|Hnle']; - [ elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ Hle' H0)) - | right; reflexivity - | elim Hnle; apply Rle_trans with b; [ assumption | left; assumption ] - | elim Hnle; apply Rle_trans with b; [ assumption | left; assumption ] ]. } - apply StepFun_P37; try assumption. - simpl; intros; unfold psi3; elim H0; clear H0; intros; - destruct (Rle_dec a x) as [Hle|Hnle]; destruct (Rle_dec x b) as [Hle'|Hnle']; - [ elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ Hle' H0)) - | right; reflexivity - | elim Hnle; apply Rle_trans with b; [ assumption | left; assumption ] - | elim Hnle; apply Rle_trans with b; [ assumption | left; assumption ] ]. } - apply Rle_antisym. - { apply StepFun_P37; try assumption. - simpl; intros; unfold psi3; elim H0; clear H0; intros; - destruct (Rle_dec a x) as [Hle|Hnle]; destruct (Rle_dec x b) as [Hle'|Hnle']; - [ right; reflexivity - | elim Hnle'; left; assumption - | elim Hnle; left; assumption - | elim Hnle; left; assumption ]. } - apply StepFun_P37; try assumption. - simpl; intros; unfold psi3; elim H0; clear H0; intros; - destruct (Rle_dec a x) as [Hle|Hnle]; destruct (Rle_dec x b) as [Hle'|Hnle']; - [ right; reflexivity - | elim Hnle'; left; assumption - | elim Hnle; left; assumption - | elim Hnle; left; assumption ]. - - assert (H3 := pre psi2); unfold IsStepFun in H3; unfold is_subdivision in H3; - elim H3; clear H3; intros l1 [lf1 H3]; split with l1; - split with lf1; unfold adapted_couple in H3; decompose [and] H3; - clear H3; unfold adapted_couple; repeat split; - try assumption. - intros; assert (H9 := H8 i H3); unfold constant_D_eq, open_interval; - unfold constant_D_eq, open_interval in H9; intros; - rewrite <- (H9 x H7); unfold psi3; assert (H10 : b < x). - { apply Rle_lt_trans with (pos_Rl l1 i). - { replace b with (Rmin b c). - { rewrite <- H5; elim (RList_P6 l1); intros; apply H10; try assumption. - { apply Nat.le_0_l. } - apply Nat.lt_trans with (pred (length l1)); try assumption; apply Nat.lt_pred_l; - red; intro; rewrite H12 in H6; discriminate. } - unfold Rmin; decide (Rle_dec b c) with Hyp2; - reflexivity. } - elim H7; intros; assumption. } - destruct (Rle_dec a x) as [Hle|Hnle]; destruct (Rle_dec x b) as [Hle'|Hnle']; - [ elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ Hle' H10)) - | reflexivity - | elim Hnle; apply Rle_trans with b; [ assumption | left; assumption ] - | elim Hnle; apply Rle_trans with b; [ assumption | left; assumption ] ]. - - assert (H3 := pre psi1); unfold IsStepFun in H3; unfold is_subdivision in H3; - elim H3; clear H3; intros l1 [lf1 H3]; split with l1; - split with lf1; unfold adapted_couple in H3; decompose [and] H3; - clear H3; unfold adapted_couple; repeat split; - try assumption. - intros; assert (H9 := H8 i H3); unfold constant_D_eq, open_interval; - unfold constant_D_eq, open_interval in H9; intros; - rewrite <- (H9 x H7); unfold psi3; assert (H10 : x <= b). - { apply Rle_trans with (pos_Rl l1 (S i)). - { elim H7; intros; left; assumption. } - replace b with (Rmax a b). - { rewrite <- H4; elim (RList_P6 l1); intros; apply H10; try assumption. - apply Nat.lt_pred_l; red; intro; rewrite H12 in H6; discriminate. } - unfold Rmax; decide (Rle_dec a b) with Hyp1; reflexivity. } - assert (H11 : a <= x). - { apply Rle_trans with (pos_Rl l1 i). - { replace a with (Rmin a b). - { rewrite <- H5; elim (RList_P6 l1); intros; apply H11; try assumption. - { apply Nat.le_0_l. } - apply Nat.lt_trans with (pred (length l1)); try assumption; apply Nat.lt_pred_l; - red; intro; rewrite H13 in H6; discriminate. } - unfold Rmin; decide (Rle_dec a b) with Hyp1; reflexivity. } - left; elim H7; intros; assumption. } - decide (Rle_dec a x) with H11; decide (Rle_dec x b) with H10; reflexivity. - - apply StepFun_P46 with b. - { assert (H3 := pre phi1); unfold IsStepFun in H3; unfold is_subdivision in H3; - elim H3; clear H3; intros l1 [lf1 H3]; split with l1; - split with lf1; unfold adapted_couple in H3; decompose [and] H3; - clear H3; unfold adapted_couple; repeat split; - try assumption. - intros; assert (H9 := H8 i H3); unfold constant_D_eq, open_interval; - unfold constant_D_eq, open_interval in H9; intros; - rewrite <- (H9 x H7); unfold psi3; assert (H10 : x <= b). - { apply Rle_trans with (pos_Rl l1 (S i)). - { elim H7; intros; left; assumption. } - replace b with (Rmax a b). - { rewrite <- H4; elim (RList_P6 l1); intros; apply H10; try assumption. - apply Nat.lt_pred_l; red; intro; rewrite H12 in H6; discriminate. } - unfold Rmax; decide (Rle_dec a b) with Hyp1; reflexivity. } - assert (H11 : a <= x). - { apply Rle_trans with (pos_Rl l1 i). - { replace a with (Rmin a b). - { rewrite <- H5; elim (RList_P6 l1); intros; apply H11; try assumption. - { apply Nat.le_0_l. } - apply Nat.lt_trans with (pred (length l1)); try assumption; apply Nat.lt_pred_l; - red; intro; rewrite H13 in H6; discriminate. } - unfold Rmin; decide (Rle_dec a b) with Hyp1; reflexivity. } - left; elim H7; intros; assumption. } - unfold phi3; decide (Rle_dec a x) with H11; decide (Rle_dec x b) with H10; - reflexivity || elim n; assumption. } - assert (H3 := pre phi2); unfold IsStepFun in H3; unfold is_subdivision in H3; - elim H3; clear H3; intros l1 [lf1 H3]; split with l1; - split with lf1; unfold adapted_couple in H3; decompose [and] H3; - clear H3; unfold adapted_couple; repeat split; - try assumption. - intros; assert (H9 := H8 i H3); unfold constant_D_eq, open_interval; - unfold constant_D_eq, open_interval in H9; intros; - rewrite <- (H9 x H7); unfold psi3; assert (H10 : b < x). - { apply Rle_lt_trans with (pos_Rl l1 i). - { replace b with (Rmin b c). - { rewrite <- H5; elim (RList_P6 l1); intros; apply H10; try assumption. - { apply Nat.le_0_l. } - apply Nat.lt_trans with (pred (length l1)); try assumption; apply Nat.lt_pred_l; - red; intro; rewrite H12 in H6; discriminate. } - unfold Rmin; decide (Rle_dec b c) with Hyp2; reflexivity. } - elim H7; intros; assumption. } - unfold phi3; destruct (Rle_dec a x) as [Hle|Hnle]; destruct (Rle_dec x b) as [Hle'|Hnle']; intros; - [ elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ Hle' H10)) - | reflexivity - | elim Hnle; apply Rle_trans with b; [ assumption | left; assumption ] - | elim Hnle; apply Rle_trans with b; [ assumption | left; assumption ] ]. -Qed. - -Lemma RiemannInt_P22 : - forall (f:R -> R) (a b c:R), - Riemann_integrable f a b -> a <= c <= b -> Riemann_integrable f a c. -Proof. - unfold Riemann_integrable; intros; elim (X eps); clear X; - intros phi [psi H0]; elim H; elim H0; clear H H0; - intros; assert (H3 : IsStepFun phi a c). - { apply StepFun_P44 with b. - { apply (pre phi). } - split; assumption. } - assert (H4 : IsStepFun psi a c). - { apply StepFun_P44 with b. - { apply (pre psi). } - split; assumption. } - split with (mkStepFun H3); split with (mkStepFun H4); split. - { simpl; intros; apply H. - replace (Rmin a b) with (Rmin a c) by (rewrite 2!Rmin_left; eauto using Rle_trans). - destruct H5; split; try assumption. - apply Rle_trans with (Rmax a c); try assumption. - apply Rle_max_compat_l; assumption. } - rewrite Rabs_right. - { assert (H5 : IsStepFun psi c b). - { apply StepFun_P46 with a. - { apply StepFun_P6; assumption. } - apply (pre psi). } - replace (RiemannInt_SF (mkStepFun H4)) with - (RiemannInt_SF psi - RiemannInt_SF (mkStepFun H5)). - { apply Rle_lt_trans with (RiemannInt_SF psi). - { unfold Rminus; pattern (RiemannInt_SF psi) at 2; - rewrite <- Rplus_0_r; apply Rplus_le_compat_l; rewrite <- Ropp_0; - apply Ropp_ge_le_contravar; apply Rle_ge; - replace 0 with (RiemannInt_SF (mkStepFun (StepFun_P4 c b 0))). - { apply StepFun_P37; try assumption. - intros; simpl; unfold fct_cte; - apply Rle_trans with (Rabs (f x - phi x)). - { apply Rabs_pos. } - apply H. - rewrite Rmin_left; eauto using Rle_trans. - rewrite Rmax_right; eauto using Rle_trans. - destruct H6; split; left. - { apply Rle_lt_trans with c; assumption. } - assumption. } - rewrite StepFun_P18; ring. } - apply Rle_lt_trans with (Rabs (RiemannInt_SF psi)). - { apply RRle_abs. } - assumption. } - assert (H6 : IsStepFun psi a b). - { apply (pre psi). } - replace (RiemannInt_SF psi) with (RiemannInt_SF (mkStepFun H6)). - { rewrite <- (StepFun_P43 H4 H5 H6); ring. } - unfold RiemannInt_SF; case (Rle_dec a b); intro. - { eapply StepFun_P17. - { apply StepFun_P1. } - simpl; apply StepFun_P1. } - apply Ropp_eq_compat; eapply StepFun_P17. - { apply StepFun_P1. } - simpl; apply StepFun_P1. } - apply Rle_ge. - replace 0 with (RiemannInt_SF (mkStepFun (StepFun_P4 a c 0))) by (rewrite StepFun_P18; ring). - apply StepFun_P37; try assumption. - intros; simpl; unfold fct_cte; - apply Rle_trans with (Rabs (f x - phi x)). - { apply Rabs_pos. } - apply H. - rewrite Rmin_left; eauto using Rle_trans. - rewrite Rmax_right; eauto using Rle_trans. - destruct H5; split; left. - { assumption. } - apply Rlt_le_trans with c; assumption. -Qed. - -Lemma RiemannInt_P23 : - forall (f:R -> R) (a b c:R), - Riemann_integrable f a b -> a <= c <= b -> Riemann_integrable f c b. -Proof. - unfold Riemann_integrable; intros; elim (X eps); clear X; - intros phi [psi H0]; elim H; elim H0; clear H H0; - intros; assert (H3 : IsStepFun phi c b). - { apply StepFun_P45 with a. - { apply (pre phi). } - split; assumption. } - assert (H4 : IsStepFun psi c b). - { apply StepFun_P45 with a. - { apply (pre psi). } - split; assumption. } - split with (mkStepFun H3); split with (mkStepFun H4); split. - { simpl; intros; apply H. - replace (Rmax a b) with (Rmax c b). - { elim H5; intros; split; try assumption. - apply Rle_trans with (Rmin c b); try assumption. - rewrite Rmin_left; eauto using Rle_trans. - rewrite Rmin_left; eauto using Rle_trans. } - rewrite Rmax_right; eauto using Rle_trans. - rewrite Rmax_right; eauto using Rle_trans. } - rewrite Rabs_right. - { assert (H5 : IsStepFun psi a c). - { apply StepFun_P46 with b. - { apply (pre psi). } - apply StepFun_P6; assumption. } - replace (RiemannInt_SF (mkStepFun H4)) with - (RiemannInt_SF psi - RiemannInt_SF (mkStepFun H5)). - { apply Rle_lt_trans with (RiemannInt_SF psi). - { unfold Rminus; pattern (RiemannInt_SF psi) at 2; - rewrite <- Rplus_0_r; apply Rplus_le_compat_l; rewrite <- Ropp_0; - apply Ropp_ge_le_contravar; apply Rle_ge; - replace 0 with (RiemannInt_SF (mkStepFun (StepFun_P4 a c 0))). - { apply StepFun_P37; try assumption. - intros; simpl; unfold fct_cte; - apply Rle_trans with (Rabs (f x - phi x)). - { apply Rabs_pos. } - apply H. - rewrite Rmin_left; eauto using Rle_trans. - rewrite Rmax_right; eauto using Rle_trans. - destruct H6; split; left. - { assumption. } - apply Rlt_le_trans with c; assumption. } - rewrite StepFun_P18; ring. } - apply Rle_lt_trans with (Rabs (RiemannInt_SF psi)). - { apply RRle_abs. } - assumption. } - assert (H6 : IsStepFun psi a b). - { apply (pre psi). } - replace (RiemannInt_SF psi) with (RiemannInt_SF (mkStepFun H6)). - { rewrite <- (StepFun_P43 H5 H4 H6); ring. } - unfold RiemannInt_SF; case (Rle_dec a b); intro. - { eapply StepFun_P17. - { apply StepFun_P1. } - simpl; apply StepFun_P1. } - apply Ropp_eq_compat; eapply StepFun_P17. - { apply StepFun_P1. } - simpl; apply StepFun_P1. } - apply Rle_ge; - replace 0 with (RiemannInt_SF (mkStepFun (StepFun_P4 c b 0))) by (rewrite StepFun_P18; ring). - apply StepFun_P37; try assumption. - intros; simpl; unfold fct_cte; - apply Rle_trans with (Rabs (f x - phi x)). - { apply Rabs_pos. } - apply H. - rewrite Rmin_left; eauto using Rle_trans. - rewrite Rmax_right; eauto using Rle_trans. - destruct H5; split; left. - { apply Rle_lt_trans with c; assumption. } - assumption. -Qed. - -Lemma RiemannInt_P24 : - forall (f:R -> R) (a b c:R), - Riemann_integrable f a b -> - Riemann_integrable f b c -> Riemann_integrable f a c. -Proof. - intros; case (Rle_dec a b); case (Rle_dec b c); intros. - - apply RiemannInt_P21 with b; assumption. - - case (Rle_dec a c); intro. - + apply RiemannInt_P22 with b; try assumption. - split; [ assumption | auto with real ]. - + apply RiemannInt_P1; apply RiemannInt_P22 with b. - * apply RiemannInt_P1; assumption. - * split; auto with real. - - case (Rle_dec a c); intro. - + apply RiemannInt_P23 with b; try assumption. - split; auto with real. - + apply RiemannInt_P1; apply RiemannInt_P23 with b. - * apply RiemannInt_P1; assumption. - * split; [ assumption | auto with real ]. - - apply RiemannInt_P1; apply RiemannInt_P21 with b; - auto with real || apply RiemannInt_P1; assumption. -Qed. - -Lemma RiemannInt_P25 : - forall (f:R -> R) (a b c:R) (pr1:Riemann_integrable f a b) - (pr2:Riemann_integrable f b c) (pr3:Riemann_integrable f a c), - a <= b -> b <= c -> RiemannInt pr1 + RiemannInt pr2 = RiemannInt pr3. -Proof. - intros f a b c pr1 pr2 pr3 Hyp1 Hyp2; unfold RiemannInt; - case (RiemannInt_exists pr1 RinvN RinvN_cv) as (x1,HUn_cv1); - case (RiemannInt_exists pr2 RinvN RinvN_cv) as (x0,HUn_cv0); - case (RiemannInt_exists pr3 RinvN RinvN_cv) as (x,HUn_cv); - symmetry ; eapply UL_sequence. - { apply HUn_cv. } - unfold Un_cv; intros; assert (H0 : 0 < eps / 3). - { unfold Rdiv; apply Rmult_lt_0_compat; - [ assumption | apply Rinv_0_lt_compat; prove_sup0 ]. } - destruct (HUn_cv1 _ H0) as (N1,H1); clear HUn_cv1; destruct (HUn_cv0 _ H0) as (N2,H2); clear HUn_cv0; - cut - (Un_cv - (fun n:nat => - RiemannInt_SF (phi_sequence RinvN pr3 n) - - (RiemannInt_SF (phi_sequence RinvN pr1 n) + - RiemannInt_SF (phi_sequence RinvN pr2 n))) 0). - { intro; elim (H3 _ H0); clear H3; intros N3 H3; - set (N0 := max (max N1 N2) N3); exists N0; intros; - unfold Rdist; - apply Rle_lt_trans with - (Rabs - (RiemannInt_SF (phi_sequence RinvN pr3 n) - - (RiemannInt_SF (phi_sequence RinvN pr1 n) + - RiemannInt_SF (phi_sequence RinvN pr2 n))) + - Rabs - (RiemannInt_SF (phi_sequence RinvN pr1 n) + - RiemannInt_SF (phi_sequence RinvN pr2 n) - (x1 + x0))). - { replace (RiemannInt_SF (phi_sequence RinvN pr3 n) - (x1 + x0)) with - (RiemannInt_SF (phi_sequence RinvN pr3 n) - - (RiemannInt_SF (phi_sequence RinvN pr1 n) + - RiemannInt_SF (phi_sequence RinvN pr2 n)) + - (RiemannInt_SF (phi_sequence RinvN pr1 n) + - RiemannInt_SF (phi_sequence RinvN pr2 n) - (x1 + x0))); - [ apply Rabs_triang | ring ]. } - replace eps with (eps / 3 + eps / 3 + eps / 3) by lra. - rewrite Rplus_assoc; apply Rplus_lt_compat. - { unfold Rdist in H3; cut (n >= N3)%nat. - { intro; assert (H6 := H3 _ H5); unfold Rminus in H6; rewrite Ropp_0 in H6; - rewrite Rplus_0_r in H6; apply H6. } - unfold ge; apply Nat.le_trans with N0; - [ unfold N0; apply Nat.le_max_r | assumption ]. } - apply Rle_lt_trans with - (Rabs (RiemannInt_SF (phi_sequence RinvN pr1 n) - x1) + - Rabs (RiemannInt_SF (phi_sequence RinvN pr2 n) - x0)). - { replace - (RiemannInt_SF (phi_sequence RinvN pr1 n) + - RiemannInt_SF (phi_sequence RinvN pr2 n) - (x1 + x0)) with - (RiemannInt_SF (phi_sequence RinvN pr1 n) - x1 + - (RiemannInt_SF (phi_sequence RinvN pr2 n) - x0)); - [ apply Rabs_triang | ring ]. } - apply Rplus_lt_compat. - { unfold Rdist in H1; apply H1. - unfold ge; apply Nat.le_trans with N0; - [ apply Nat.le_trans with (max N1 N2); - [ apply Nat.le_max_l | unfold N0; apply Nat.le_max_l ] - | assumption ]. } - unfold Rdist in H2; apply H2. - unfold ge; apply Nat.le_trans with N0; - [ apply Nat.le_trans with (max N1 N2); - [ apply Nat.le_max_r | unfold N0; apply Nat.le_max_l ] - | assumption ]. } - clear x HUn_cv x0 x1 eps H H0 N1 H1 N2 H2; - assert - (H1 : - exists psi1 : nat -> StepFun a b, - (forall n:nat, - (forall t:R, - Rmin a b <= t /\ t <= Rmax a b -> - Rabs (f t - phi_sequence RinvN pr1 n t) <= psi1 n t) /\ - Rabs (RiemannInt_SF (psi1 n)) < RinvN n)). - { split with (fun n:nat => proj1_sig (phi_sequence_prop RinvN pr1 n)); intro; - apply (proj2_sig (phi_sequence_prop RinvN pr1 n)). } - assert - (H2 : - exists psi2 : nat -> StepFun b c, - (forall n:nat, - (forall t:R, - Rmin b c <= t /\ t <= Rmax b c -> - Rabs (f t - phi_sequence RinvN pr2 n t) <= psi2 n t) /\ - Rabs (RiemannInt_SF (psi2 n)) < RinvN n)). - { split with (fun n:nat => proj1_sig (phi_sequence_prop RinvN pr2 n)); intro; - apply (proj2_sig (phi_sequence_prop RinvN pr2 n)). } - assert - (H3 : - exists psi3 : nat -> StepFun a c, - (forall n:nat, - (forall t:R, - Rmin a c <= t /\ t <= Rmax a c -> - Rabs (f t - phi_sequence RinvN pr3 n t) <= psi3 n t) /\ - Rabs (RiemannInt_SF (psi3 n)) < RinvN n)). - { split with (fun n:nat => proj1_sig (phi_sequence_prop RinvN pr3 n)); intro; - apply (proj2_sig (phi_sequence_prop RinvN pr3 n)). } - elim H1; clear H1; intros psi1 H1; elim H2; clear H2; intros psi2 H2; elim H3; - clear H3; intros psi3 H3; assert (H := RinvN_cv); - unfold Un_cv; intros; assert (H4 : 0 < eps / 3). - { unfold Rdiv; apply Rmult_lt_0_compat; - [ assumption | apply Rinv_0_lt_compat; prove_sup0 ]. } - elim (H _ H4); clear H; intros N0 H; - assert (H5 : forall n:nat, (n >= N0)%nat -> RinvN n < eps / 3). - { intros; - replace (pos (RinvN n)) with - (Rdist (mkposreal (/ (INR n + 1)) (RinvN_pos n)) 0). - { apply H; assumption. } - unfold Rdist; unfold Rminus; rewrite Ropp_0; - rewrite Rplus_0_r; apply Rabs_right; apply Rle_ge; - left; apply (cond_pos (RinvN n)). } - exists N0; intros; elim (H1 n); elim (H2 n); elim (H3 n); clear H1 H2 H3; - intros; unfold Rdist; unfold Rminus; - rewrite Ropp_0; rewrite Rplus_0_r; - set (phi1 := phi_sequence RinvN pr1 n) in H8 |- *; - set (phi2 := phi_sequence RinvN pr2 n) in H3 |- *; - set (phi3 := phi_sequence RinvN pr3 n) in H1 |- *; - assert (H10 : IsStepFun phi3 a b). - { apply StepFun_P44 with c. - { apply (pre phi3). } - split; assumption. } - assert (H11 : IsStepFun (psi3 n) a b). - { apply StepFun_P44 with c. - { apply (pre (psi3 n)). } - split; assumption. } - assert (H12 : IsStepFun phi3 b c). - { apply StepFun_P45 with a. - { apply (pre phi3). } - split; assumption. } - assert (H13 : IsStepFun (psi3 n) b c). - { apply StepFun_P45 with a. - { apply (pre (psi3 n)). } - split; assumption. } - replace (RiemannInt_SF phi3) with - (RiemannInt_SF (mkStepFun H10) + RiemannInt_SF (mkStepFun H12)). - { apply Rle_lt_trans with - (Rabs (RiemannInt_SF (mkStepFun H10) - RiemannInt_SF phi1) + - Rabs (RiemannInt_SF (mkStepFun H12) - RiemannInt_SF phi2)). - { replace - (RiemannInt_SF (mkStepFun H10) + RiemannInt_SF (mkStepFun H12) + - - (RiemannInt_SF phi1 + RiemannInt_SF phi2)) with - (RiemannInt_SF (mkStepFun H10) - RiemannInt_SF phi1 + - (RiemannInt_SF (mkStepFun H12) - RiemannInt_SF phi2)) by ring; - apply Rabs_triang. } - replace (RiemannInt_SF (mkStepFun H10) - RiemannInt_SF phi1) with - (RiemannInt_SF (mkStepFun (StepFun_P28 (-1) (mkStepFun H10) phi1))) - by (rewrite StepFun_P30; ring). - replace (RiemannInt_SF (mkStepFun H12) - RiemannInt_SF phi2) with - (RiemannInt_SF (mkStepFun (StepFun_P28 (-1) (mkStepFun H12) phi2))) - by (rewrite StepFun_P30; ring). - apply Rle_lt_trans with - (RiemannInt_SF - (mkStepFun - (StepFun_P32 (mkStepFun (StepFun_P28 (-1) (mkStepFun H10) phi1)))) + - RiemannInt_SF - (mkStepFun - (StepFun_P32 (mkStepFun (StepFun_P28 (-1) (mkStepFun H12) phi2))))). - { apply Rle_trans with - (Rabs (RiemannInt_SF (mkStepFun (StepFun_P28 (-1) (mkStepFun H10) phi1))) + - RiemannInt_SF - (mkStepFun - (StepFun_P32 (mkStepFun (StepFun_P28 (-1) (mkStepFun H12) phi2))))). - { apply Rplus_le_compat_l. - apply StepFun_P34; try assumption. } - do 2 - rewrite <- - (Rplus_comm - (RiemannInt_SF - (mkStepFun - (StepFun_P32 (mkStepFun (StepFun_P28 (-1) (mkStepFun H12) phi2)))))) - ; apply Rplus_le_compat_l; apply StepFun_P34; try assumption. } - apply Rle_lt_trans with - (RiemannInt_SF (mkStepFun (StepFun_P28 1 (mkStepFun H11) (psi1 n))) + - RiemannInt_SF (mkStepFun (StepFun_P28 1 (mkStepFun H13) (psi2 n)))). - { apply Rle_trans with - (RiemannInt_SF - (mkStepFun - (StepFun_P32 (mkStepFun (StepFun_P28 (-1) (mkStepFun H10) phi1)))) + - RiemannInt_SF (mkStepFun (StepFun_P28 1 (mkStepFun H13) (psi2 n)))). - { apply Rplus_le_compat_l; apply StepFun_P37; try assumption. - intros; simpl; rewrite Rmult_1_l; - apply Rle_trans with (Rabs (f x - phi3 x) + Rabs (f x - phi2 x)). - { rewrite <- (Rabs_Ropp (f x - phi3 x)); rewrite Ropp_minus_distr; - replace (phi3 x + -1 * phi2 x) with (phi3 x - f x + (f x - phi2 x)); - [ apply Rabs_triang | ring ]. } - apply Rplus_le_compat. - { apply H1. - elim H14; intros; split. - { rewrite Rmin_left; eauto using Rle_trans. - apply Rle_trans with b; try assumption. - left; assumption. } - rewrite Rmax_right; eauto using Rle_trans. - left; assumption. } - apply H3. - elim H14; intros; split. - { rewrite Rmin_left; eauto using Rle_trans. - left; assumption. } - rewrite Rmax_right; eauto using Rle_trans. - left; assumption. } - do 2 - rewrite <- - (Rplus_comm - (RiemannInt_SF (mkStepFun (StepFun_P28 1 (mkStepFun H13) (psi2 n))))) - ; apply Rplus_le_compat_l; apply StepFun_P37; try assumption. - intros; simpl; rewrite Rmult_1_l; - apply Rle_trans with (Rabs (f x - phi3 x) + Rabs (f x - phi1 x)). - { rewrite <- (Rabs_Ropp (f x - phi3 x)); rewrite Ropp_minus_distr; - replace (phi3 x + -1 * phi1 x) with (phi3 x - f x + (f x - phi1 x)); - [ apply Rabs_triang | ring ]. } - apply Rplus_le_compat. - { apply H1. - elim H14; intros; split. - { rewrite Rmin_left; eauto using Rle_trans. - left; assumption. } - rewrite Rmax_right; eauto using Rle_trans. - apply Rle_trans with b. - { left; assumption. } - assumption. } - apply H8. - elim H14; intros; split. - { rewrite Rmin_left; trivial. - left; assumption. } - rewrite Rmax_right; trivial. - left; assumption. } - do 2 rewrite StepFun_P30. - do 2 rewrite Rmult_1_l; - replace - (RiemannInt_SF (mkStepFun H11) + RiemannInt_SF (psi1 n) + - (RiemannInt_SF (mkStepFun H13) + RiemannInt_SF (psi2 n))) with - (RiemannInt_SF (psi3 n) + RiemannInt_SF (psi1 n) + RiemannInt_SF (psi2 n)). - { replace eps with (eps / 3 + eps / 3 + eps / 3) by lra. - repeat rewrite Rplus_assoc; apply Rplus_lt_compat. - { apply Rle_lt_trans with (Rabs (RiemannInt_SF (psi3 n))). - { apply RRle_abs. } - apply Rlt_trans with (pos (RinvN n)). - { assumption. } - apply H5; assumption. } - apply Rplus_lt_compat. - { apply Rle_lt_trans with (Rabs (RiemannInt_SF (psi1 n))). - { apply RRle_abs. } - apply Rlt_trans with (pos (RinvN n)). - { assumption. } - apply H5; assumption. } - apply Rle_lt_trans with (Rabs (RiemannInt_SF (psi2 n))). - { apply RRle_abs. } - apply Rlt_trans with (pos (RinvN n)). - { assumption. } - apply H5; assumption. } - replace (RiemannInt_SF (psi3 n)) with - (RiemannInt_SF (mkStepFun (pre (psi3 n)))). - { rewrite <- (StepFun_P43 H11 H13 (pre (psi3 n))); ring. } - reflexivity. } - apply (StepFun_P43 H10 H12 (pre phi3)). -Qed. - -Lemma RiemannInt_P26 : - forall (f:R -> R) (a b c:R) (pr1:Riemann_integrable f a b) - (pr2:Riemann_integrable f b c) (pr3:Riemann_integrable f a c), - RiemannInt pr1 + RiemannInt pr2 = RiemannInt pr3. -Proof. - intros; destruct (Rle_dec a b) as [Hle|Hnle]; destruct (Rle_dec b c) as [Hle'|Hnle']. - - apply RiemannInt_P25; assumption. - - destruct (Rle_dec a c) as [Hle''|Hnle'']. - { assert (H : c <= b). - { auto with real. } - rewrite <- (RiemannInt_P25 pr3 (RiemannInt_P1 pr2) pr1 Hle'' H); - rewrite (RiemannInt_P8 pr2 (RiemannInt_P1 pr2)); ring. } - assert (H : c <= a). - { auto with real. } - rewrite (RiemannInt_P8 pr2 (RiemannInt_P1 pr2)); - rewrite <- (RiemannInt_P25 (RiemannInt_P1 pr3) pr1 (RiemannInt_P1 pr2) H Hle); - rewrite (RiemannInt_P8 pr3 (RiemannInt_P1 pr3)); ring. - - assert (H : b <= a). - { auto with real. } - destruct (Rle_dec a c) as [Hle''|Hnle'']. - { rewrite <- (RiemannInt_P25 (RiemannInt_P1 pr1) pr3 pr2 H Hle''); - rewrite (RiemannInt_P8 pr1 (RiemannInt_P1 pr1)); ring. } - assert (H0 : c <= a). - { auto with real. } - rewrite (RiemannInt_P8 pr1 (RiemannInt_P1 pr1)); - rewrite <- (RiemannInt_P25 pr2 (RiemannInt_P1 pr3) (RiemannInt_P1 pr1) Hle' H0); - rewrite (RiemannInt_P8 pr3 (RiemannInt_P1 pr3)); ring. - - rewrite (RiemannInt_P8 pr1 (RiemannInt_P1 pr1)); - rewrite (RiemannInt_P8 pr2 (RiemannInt_P1 pr2)); - rewrite (RiemannInt_P8 pr3 (RiemannInt_P1 pr3)); - rewrite <- - (RiemannInt_P25 (RiemannInt_P1 pr2) (RiemannInt_P1 pr1) (RiemannInt_P1 pr3)) - ; [ ring | auto with real | auto with real ]. -Qed. - -Lemma RiemannInt_P27 : - forall (f:R -> R) (a b x:R) (h:a <= b) - (C0:forall x:R, a <= x <= b -> continuity_pt f x), - a < x < b -> derivable_pt_lim (primitive h (FTC_P1 h C0)) x (f x). -Proof. - intro f; intros; elim H; clear H; intros; assert (H1 : continuity_pt f x). - { apply C0; split; left; assumption. } - unfold derivable_pt_lim; intros; assert (Hyp : 0 < eps / 2). - { unfold Rdiv; apply Rmult_lt_0_compat; - [ assumption | apply Rinv_0_lt_compat; prove_sup0 ]. } - elim (H1 _ Hyp); unfold dist, D_x, no_cond; simpl; - unfold Rdist; intros; set (del := Rmin x0 (Rmin (b - x) (x - a))); - assert (H4 : 0 < del). - { unfold del; unfold Rmin; case (Rle_dec (b - x) (x - a)); - intro. - { destruct (Rle_dec x0 (b - x)) as [Hle|Hnle]; - [ elim H3; intros; assumption | apply Rlt_0_minus; assumption ]. } - destruct (Rle_dec x0 (x - a)) as [Hle'|Hnle']; - [ elim H3; intros; assumption | apply Rlt_0_minus; assumption ]. } - split with (mkposreal _ H4); intros; - assert (H7 : Riemann_integrable f x (x + h0)). - { destruct (Rle_dec x (x + h0)) as [Hle''|Hnle'']. - { apply continuity_implies_RiemannInt; try assumption. - intros; apply C0; elim H7; intros; split. - { apply Rle_trans with x; [ left; assumption | assumption ]. } - apply Rle_trans with (x + h0). - { assumption. } - left; apply Rlt_le_trans with (x + del). - { apply Rplus_lt_compat_l; apply Rle_lt_trans with (Rabs h0); - [ apply RRle_abs | apply H6 ]. } - unfold del; apply Rle_trans with (x + Rmin (b - x) (x - a)). - { apply Rplus_le_compat_l; apply Rmin_r. } - pattern b at 2; replace b with (x + (b - x)); - [ apply Rplus_le_compat_l; apply Rmin_l | ring ]. } - apply RiemannInt_P1; apply continuity_implies_RiemannInt; auto with real. - intros; apply C0; elim H7; intros; split. - { apply Rle_trans with (x + h0). - { left; apply Rle_lt_trans with (x - del). - { unfold del; apply Rle_trans with (x - Rmin (b - x) (x - a)). - { pattern a at 1; replace a with (x + (a - x)); [ idtac | ring ]. - unfold Rminus; apply Rplus_le_compat_l; apply Ropp_le_cancel. - rewrite Ropp_involutive; rewrite Ropp_plus_distr; rewrite Ropp_involutive; - rewrite (Rplus_comm x); apply Rmin_r. } - unfold Rminus; apply Rplus_le_compat_l; apply Ropp_le_cancel. - do 2 rewrite Ropp_involutive; apply Rmin_r. } - unfold Rminus; apply Rplus_lt_compat_l; apply Ropp_lt_cancel. - rewrite Ropp_involutive; apply Rle_lt_trans with (Rabs h0); - [ rewrite <- Rabs_Ropp; apply RRle_abs | apply H6 ]. } - assumption. } - apply Rle_trans with x; [ assumption | left; assumption ]. } - replace (primitive h (FTC_P1 h C0) (x + h0) - primitive h (FTC_P1 h C0) x) - with (RiemannInt H7). - 2:{ cut (a <= x + h0). - { cut (x + h0 <= b). - { intros; unfold primitive. - assert (H10: a <= x) by (left; assumption). - assert (H11: x <= b) by (left; assumption). - decide (Rle_dec a (x + h0)) with H9; decide (Rle_dec (x + h0) b) with H8; - decide (Rle_dec a x) with H10; decide (Rle_dec x b) with H11. - rewrite <- (RiemannInt_P26 (FTC_P1 h C0 H10 H11) H7 (FTC_P1 h C0 H9 H8)); ring. } - apply Rplus_le_reg_l with (- x); replace (- x + (x + h0)) with h0; - [ idtac | ring ]. - rewrite Rplus_comm; apply Rle_trans with (Rabs h0). - { apply RRle_abs. } - apply Rle_trans with del; - [ left; assumption - | unfold del; apply Rle_trans with (Rmin (b - x) (x - a)); - [ apply Rmin_r | apply Rmin_l ] ]. } - apply Ropp_le_cancel; apply Rplus_le_reg_l with x; - replace (x + - (x + h0)) with (- h0) by ring. - apply Rle_trans with (Rabs h0). - { rewrite <- Rabs_Ropp; apply RRle_abs. } - apply Rle_trans with del. - { left; assumption. } - unfold del; apply Rle_trans with (Rmin (b - x) (x - a)); - apply Rmin_r. } - replace (f x) with (RiemannInt (RiemannInt_P14 x (x + h0) (f x)) / h0). - 2:{ rewrite RiemannInt_P15; apply Rmult_eq_reg_l with h0; - [ unfold Rdiv; rewrite (Rmult_comm h0); repeat rewrite Rmult_assoc; - rewrite Rinv_l; [ ring | assumption ] - | assumption ]. } - replace - (RiemannInt H7 / h0 - RiemannInt (RiemannInt_P14 x (x + h0) (f x)) / h0) - with ((RiemannInt H7 - RiemannInt (RiemannInt_P14 x (x + h0) (f x))) / h0). - 2:{ unfold Rdiv, Rminus; rewrite Rmult_plus_distr_r; ring. } - replace (RiemannInt H7 - RiemannInt (RiemannInt_P14 x (x + h0) (f x))) with - (RiemannInt (RiemannInt_P10 (-1) H7 (RiemannInt_P14 x (x + h0) (f x)))). - 2:{ rewrite - (RiemannInt_P13 H7 (RiemannInt_P14 x (x + h0) (f x)) - (RiemannInt_P10 (-1) H7 (RiemannInt_P14 x (x + h0) (f x)))). - ring. } - unfold Rdiv; rewrite Rabs_mult; destruct (Rle_dec x (x + h0)) as [Hle|Hnle]. - - apply Rle_lt_trans with - (RiemannInt - (RiemannInt_P16 - (RiemannInt_P10 (-1) H7 (RiemannInt_P14 x (x + h0) (f x)))) * - Rabs (/ h0)). - { do 2 rewrite <- (Rmult_comm (Rabs (/ h0))); apply Rmult_le_compat_l. - { apply Rabs_pos. } - apply - (RiemannInt_P17 (RiemannInt_P10 (-1) H7 (RiemannInt_P14 x (x + h0) (f x))) - (RiemannInt_P16 - (RiemannInt_P10 (-1) H7 (RiemannInt_P14 x (x + h0) (f x))))); - assumption. } - apply Rle_lt_trans with - (RiemannInt (RiemannInt_P14 x (x + h0) (eps / 2)) * Rabs (/ h0)). - { do 2 rewrite <- (Rmult_comm (Rabs (/ h0))); apply Rmult_le_compat_l. - { apply Rabs_pos. } - apply RiemannInt_P19; try assumption. - intros; replace (f x1 + -1 * fct_cte (f x) x1) with (f x1 - f x). - { unfold fct_cte; destruct (Req_dec x x1) as [H9|H9]. - { rewrite H9; unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0; left; - assumption. } - elim H3; intros; left; apply H11. - repeat split. - { assumption. } - rewrite Rabs_right. - { apply Rplus_lt_reg_l with x; replace (x + (x1 - x)) with x1; [ idtac | ring ]. - apply Rlt_le_trans with (x + h0). - { elim H8; intros; assumption. } - apply Rplus_le_compat_l; apply Rle_trans with del. - { left; apply Rle_lt_trans with (Rabs h0); [ apply RRle_abs | assumption ]. } - unfold del; apply Rmin_l. } - apply Rge_minus; apply Rle_ge; left; elim H8; intros; assumption. } - unfold fct_cte; ring. } - rewrite RiemannInt_P15. - rewrite Rmult_assoc; replace ((x + h0 - x) * Rabs (/ h0)) with 1. - { rewrite Rmult_1_r; unfold Rdiv; apply Rmult_lt_reg_l with 2; - [ prove_sup0 - | rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc; - rewrite Rinv_r; - [ rewrite Rmult_1_l; pattern eps at 1; rewrite <- Rplus_0_r; - rewrite <-Rplus_diag; apply Rplus_lt_compat_l; assumption - | discrR ] ]. } - rewrite Rabs_right. - { replace (x + h0 - x) with h0; [ idtac | ring ]. - symmetry; apply Rinv_r. - assumption. } - apply Rle_ge; left; apply Rinv_0_lt_compat. - elim Hle; intro. - { apply Rplus_lt_reg_l with x; rewrite Rplus_0_r; assumption. } - elim H5; symmetry ; apply Rplus_eq_reg_l with x; rewrite Rplus_0_r; - assumption. - - apply Rle_lt_trans with - (RiemannInt - (RiemannInt_P16 - (RiemannInt_P1 - (RiemannInt_P10 (-1) H7 (RiemannInt_P14 x (x + h0) (f x))))) * - Rabs (/ h0)). - { do 2 rewrite <- (Rmult_comm (Rabs (/ h0))); apply Rmult_le_compat_l. - { apply Rabs_pos. } - replace - (RiemannInt (RiemannInt_P10 (-1) H7 (RiemannInt_P14 x (x + h0) (f x)))) with - (- - RiemannInt - (RiemannInt_P1 (RiemannInt_P10 (-1) H7 (RiemannInt_P14 x (x + h0) (f x))))). - { rewrite Rabs_Ropp; - apply - (RiemannInt_P17 - (RiemannInt_P1 - (RiemannInt_P10 (-1) H7 (RiemannInt_P14 x (x + h0) (f x)))) - (RiemannInt_P16 - (RiemannInt_P1 - (RiemannInt_P10 (-1) H7 (RiemannInt_P14 x (x + h0) (f x)))))); - auto with real. } - symmetry ; apply RiemannInt_P8. } - apply Rle_lt_trans with - (RiemannInt (RiemannInt_P14 (x + h0) x (eps / 2)) * Rabs (/ h0)). - { do 2 rewrite <- (Rmult_comm (Rabs (/ h0))); apply Rmult_le_compat_l. - { apply Rabs_pos. } - apply RiemannInt_P19. - { auto with real. } - intros; replace (f x1 + -1 * fct_cte (f x) x1) with (f x1 - f x). - { unfold fct_cte; case (Req_dec x x1); intro. - { rewrite H9; unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0; left; - assumption. } - elim H3; intros; left; apply H11. - repeat split. - { assumption. } - rewrite Rabs_left. - { apply Rplus_lt_reg_l with (x1 - x0); replace (x1 - x0 + x0) with x1 by ring. - replace (x1 - x0 + - (x1 - x)) with (x - x0) by ring. - apply Rle_lt_trans with (x + h0). - { unfold Rminus; apply Rplus_le_compat_l; apply Ropp_le_cancel. - rewrite Ropp_involutive; apply Rle_trans with (Rabs h0). - { rewrite <- Rabs_Ropp; apply RRle_abs. } - apply Rle_trans with del; - [ left; assumption | unfold del; apply Rmin_l ]. } - elim H8; intros; assumption. } - lra. } - unfold fct_cte; ring. } - rewrite RiemannInt_P15. - rewrite Rmult_assoc; replace ((x - (x + h0)) * Rabs (/ h0)) with 1. - { lra. } - rewrite Rabs_left. - { field. lra. } - apply Rinv_lt_0_compat. - assert (H8 : x + h0 < x). - { auto with real. } - apply Rplus_lt_reg_l with x; rewrite Rplus_0_r; assumption. -Qed. - -Lemma RiemannInt_P28 : - forall (f:R -> R) (a b x:R) (h:a <= b) - (C0:forall x:R, a <= x <= b -> continuity_pt f x), - a <= x <= b -> derivable_pt_lim (primitive h (FTC_P1 h C0)) x (f x). -Proof. - intro f; intros; elim h; intro. - 1:elim H; clear H; intros; elim H; intro. - - elim H1; intro. - { apply RiemannInt_P27; split; assumption. } - set - (f_b := fun x:R => f b * (x - b) + RiemannInt (FTC_P1 h C0 h (Rle_refl b))); - rewrite H3. - assert (H4 : derivable_pt_lim f_b b (f b)). - { unfold f_b; pattern (f b) at 2; replace (f b) with (f b + 0) by ring. - change - (derivable_pt_lim - ((fct_cte (f b) * (id - fct_cte b))%F + - fct_cte (RiemannInt (FTC_P1 h C0 h (Rle_refl b)))) b ( - f b + 0)). - apply derivable_pt_lim_plus. - { pattern (f b) at 2; - replace (f b) with (0 * (id - fct_cte b)%F b + fct_cte (f b) b * 1) - by (unfold fct_cte;ring). - apply derivable_pt_lim_mult. - { apply derivable_pt_lim_const. } - replace 1 with (1 - 0); [ idtac | ring ]. - apply derivable_pt_lim_minus. - { apply derivable_pt_lim_id. } - apply derivable_pt_lim_const. } - apply derivable_pt_lim_const. } - unfold derivable_pt_lim; intros; elim (H4 _ H5); intros; - assert (H7 : continuity_pt f b). - { apply C0; split; [ left; assumption | right; reflexivity ]. } - assert (H8 : 0 < eps / 2). - { unfold Rdiv; apply Rmult_lt_0_compat; - [ assumption | apply Rinv_0_lt_compat; prove_sup0 ]. } - elim (H7 _ H8); unfold D_x, no_cond, dist; simpl; - unfold Rdist; intros; set (del := Rmin x0 (Rmin x1 (b - a))); - assert (H10 : 0 < del). - { unfold del; unfold Rmin; case (Rle_dec x1 (b - a)); intros. - { destruct (Rle_dec x0 x1) as [Hle|Hnle]; - [ apply (cond_pos x0) | elim H9; intros; assumption ]. } - destruct (Rle_dec x0 (b - a)) as [Hle'|Hnle']; - [ apply (cond_pos x0) | apply Rlt_0_minus; assumption ]. } - split with (mkposreal _ H10); intros; destruct (Rcase_abs h0) as [Hle|Hnle]. - + assert (H14 : b + h0 < b). - { pattern b at 2; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l; - assumption. } - assert (H13 : Riemann_integrable f (b + h0) b). - { apply continuity_implies_RiemannInt. - { left; assumption. } - intros; apply C0; elim H13; intros; split; try assumption. - apply Rle_trans with (b + h0); try assumption. - apply Rplus_le_reg_l with (- a - h0). - replace (- a - h0 + a) with (- h0); [ idtac | ring ]. - replace (- a - h0 + (b + h0)) with (b - a); [ idtac | ring ]. - apply Rle_trans with del. - { apply Rle_trans with (Rabs h0). - { rewrite <- Rabs_Ropp; apply RRle_abs. } - left; assumption. } - unfold del; apply Rle_trans with (Rmin x1 (b - a)); apply Rmin_r. } - replace (primitive h (FTC_P1 h C0) (b + h0) - primitive h (FTC_P1 h C0) b) - with (- RiemannInt H13). - { replace (f b) with (- RiemannInt (RiemannInt_P14 (b + h0) b (f b)) / h0). - 2:{ rewrite RiemannInt_P15. - rewrite <- Ropp_mult_distr_l_reverse; apply Rmult_eq_reg_l with h0; - [ repeat rewrite (Rmult_comm h0); unfold Rdiv; - repeat rewrite Rmult_assoc; rewrite Rinv_l; - [ ring | assumption ] - | assumption ]. } - rewrite <- Rabs_Ropp; unfold Rminus; unfold Rdiv; - rewrite Ropp_mult_distr_l_reverse; rewrite Ropp_plus_distr; - repeat rewrite Ropp_involutive; - replace - (RiemannInt H13 * / h0 + - - RiemannInt (RiemannInt_P14 (b + h0) b (f b)) * / h0) with - ((RiemannInt H13 - RiemannInt (RiemannInt_P14 (b + h0) b (f b))) / h0). - 2:{ unfold Rdiv, Rminus; rewrite Rmult_plus_distr_r; ring. } - replace (RiemannInt H13 - RiemannInt (RiemannInt_P14 (b + h0) b (f b))) with - (RiemannInt (RiemannInt_P10 (-1) H13 (RiemannInt_P14 (b + h0) b (f b)))). - 2:{ rewrite - (RiemannInt_P13 H13 (RiemannInt_P14 (b + h0) b (f b)) - (RiemannInt_P10 (-1) H13 (RiemannInt_P14 (b + h0) b (f b)))) - ; ring. } - unfold Rdiv; rewrite Rabs_mult; - apply Rle_lt_trans with - (RiemannInt - (RiemannInt_P16 - (RiemannInt_P10 (-1) H13 (RiemannInt_P14 (b + h0) b (f b)))) * - Rabs (/ h0)). - { do 2 rewrite <- (Rmult_comm (Rabs (/ h0))); apply Rmult_le_compat_l. - { apply Rabs_pos. } - apply - (RiemannInt_P17 (RiemannInt_P10 (-1) H13 (RiemannInt_P14 (b + h0) b (f b))) - (RiemannInt_P16 - (RiemannInt_P10 (-1) H13 (RiemannInt_P14 (b + h0) b (f b))))); - left; assumption. } - apply Rle_lt_trans with - (RiemannInt (RiemannInt_P14 (b + h0) b (eps / 2)) * Rabs (/ h0)). - { do 2 rewrite <- (Rmult_comm (Rabs (/ h0))); apply Rmult_le_compat_l. - { apply Rabs_pos. } - apply RiemannInt_P19. - { left; assumption. } - intros; replace (f x2 + -1 * fct_cte (f b) x2) with (f x2 - f b) - by (unfold fct_cte; ring). - unfold fct_cte; case (Req_dec b x2); intro. - { rewrite H16; unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0; - left; assumption. } - elim H9; intros; left; apply H18. - repeat split. - { assumption. } - rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; rewrite Rabs_right. - 2:{ apply Rle_ge; left; apply Rlt_0_minus; elim H15; intros; assumption. } - apply Rplus_lt_reg_l with (x2 - x1); - replace (x2 - x1 + (b - x2)) with (b - x1); [ idtac | ring ]. - replace (x2 - x1 + x1) with x2; [ idtac | ring ]. - apply Rlt_le_trans with (b + h0). - 2: elim H15; intros; left; assumption. - unfold Rminus; apply Rplus_lt_compat_l; apply Ropp_lt_cancel; - rewrite Ropp_involutive; apply Rle_lt_trans with (Rabs h0). - { rewrite <- Rabs_Ropp; apply RRle_abs. } - apply Rlt_le_trans with del; - [ assumption - | unfold del; apply Rle_trans with (Rmin x1 (b - a)); - [ apply Rmin_r | apply Rmin_l ] ]. - } - - rewrite RiemannInt_P15. - rewrite Rmult_assoc; replace ((b - (b + h0)) * Rabs (/ h0)) with 1. - { lra. } - rewrite Rabs_left. - { apply Rmult_eq_reg_l with h0; - [ do 2 rewrite (Rmult_comm h0); rewrite Rmult_assoc; - rewrite Ropp_mult_distr_l_reverse; rewrite Rinv_l; - [ ring | assumption ] - | assumption ]. } - apply Rinv_lt_0_compat; assumption. } - cut (a <= b + h0). - { cut (b + h0 <= b). - 2:{ left; assumption. } - intros; unfold primitive; destruct (Rle_dec a (b + h0)) as [Hle'|Hnle']; - destruct (Rle_dec (b + h0) b) as [Hle''|[]]; destruct (Rle_dec a b) as [Hleab|[]]; destruct (Rle_dec b b) as [Hlebb|[]]; - assumption || (right; reflexivity) || (try (left; assumption)). - { rewrite <- (RiemannInt_P26 (FTC_P1 h C0 Hle' Hle'') H13 (FTC_P1 h C0 Hleab Hlebb)); ring. } - elim Hnle'; assumption. } - apply Rplus_le_reg_l with (- a - h0). - replace (- a - h0 + a) with (- h0); [ idtac | ring ]. - replace (- a - h0 + (b + h0)) with (b - a); [ idtac | ring ]. - apply Rle_trans with del. - { apply Rle_trans with (Rabs h0). - { rewrite <- Rabs_Ropp; apply RRle_abs. } - left; assumption. } - unfold del; apply Rle_trans with (Rmin x1 (b - a)); apply Rmin_r. - + cut (primitive h (FTC_P1 h C0) b = f_b b). - { intro; cut (primitive h (FTC_P1 h C0) (b + h0) = f_b (b + h0)). - { intro; rewrite H13; rewrite H14; apply H6. - { assumption. } - apply Rlt_le_trans with del; - [ assumption | unfold del; apply Rmin_l ]. } - assert (H14 : b < b + h0). - { pattern b at 1; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l. - assert (H14 := Rge_le _ _ Hnle); elim H14; intro. - { assumption. } - elim H11; symmetry ; assumption. } - unfold primitive; destruct (Rle_dec a (b + h0)) as [Hle|[]]; - destruct (Rle_dec (b + h0) b) as [Hle'|Hnle']; - [ elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ Hle' H14)) - | unfold f_b; reflexivity - | left; apply Rlt_trans with b; assumption - | left; apply Rlt_trans with b; assumption ]. } - unfold f_b; unfold Rminus; rewrite Rplus_opp_r; - rewrite Rmult_0_r; rewrite Rplus_0_l; unfold primitive; - destruct (Rle_dec a b) as [Hle'|Hnle']; destruct (Rle_dec b b) as [Hle''|[]]; - [ apply RiemannInt_P5 - | right; reflexivity - | elim Hnle'; left; assumption - | right; reflexivity ]. - - (*****) - set (f_a := fun x:R => f a * (x - a)); rewrite <- H2; - assert (H3 : derivable_pt_lim f_a a (f a)). - { unfold f_a; - change (derivable_pt_lim (fct_cte (f a) * (id - fct_cte a)%F) a (f a)) - ; pattern (f a) at 2; - replace (f a) with (0 * (id - fct_cte a)%F a + fct_cte (f a) a * 1). - { apply derivable_pt_lim_mult. - { apply derivable_pt_lim_const. } - replace 1 with (1 - 0); [ idtac | ring ]. - apply derivable_pt_lim_minus. - { apply derivable_pt_lim_id. } - apply derivable_pt_lim_const. } - unfold fct_cte; ring. } - unfold derivable_pt_lim; intros; elim (H3 _ H4); intros. - assert (H6 : continuity_pt f a). - { apply C0; split; [ right; reflexivity | left; assumption ]. } - assert (H7 : 0 < eps / 2). - { unfold Rdiv; apply Rmult_lt_0_compat; - [ assumption | apply Rinv_0_lt_compat; prove_sup0 ]. } - elim (H6 _ H7); unfold D_x, no_cond, dist; simpl; - unfold Rdist; intros. - set (del := Rmin x0 (Rmin x1 (b - a))). - assert (H9 : 0 < del). - { unfold del; unfold Rmin. - case (Rle_dec x1 (b - a)); intros. - { case (Rle_dec x0 x1); intro. - { apply (cond_pos x0). } - elim H8; intros; assumption. } - case (Rle_dec x0 (b - a)); intro. - { apply (cond_pos x0). } - apply Rlt_0_minus; assumption. } - split with (mkposreal _ H9). - intros; destruct (Rcase_abs h0) as [Hle|Hnle]. - + assert (H12 : a + h0 < a). - { pattern a at 2; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l; - assumption. } - unfold primitive. - destruct (Rle_dec a (a + h0)) as [Hle'|Hnle']; - destruct (Rle_dec (a + h0) b) as [Hle''|Hnle'']; - destruct (Rle_dec a a) as [Hleaa|[]]; - destruct (Rle_dec a b) as [Hleab|[]]; - try (left; assumption) || (right; reflexivity). - * elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ Hle' H12)). - * elim Hnle''; left; apply Rlt_trans with a; assumption. - * rewrite RiemannInt_P9; replace 0 with (f_a a). - { replace (f a * (a + h0 - a)) with (f_a (a + h0)). - { apply H5; try assumption. - apply Rlt_le_trans with del; - [ assumption | unfold del; apply Rmin_l ]. } - unfold f_a; ring. } - unfold f_a; ring. - * elim Hnle''; left; apply Rlt_trans with a; assumption. - + assert (H12 : a < a + h0). - { pattern a at 1; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l. - assert (H12 := Rge_le _ _ Hnle); elim H12; intro. - { assumption. } - elim H10; symmetry ; assumption. } - assert (H13 : Riemann_integrable f a (a + h0)). - { apply continuity_implies_RiemannInt. - { left; assumption. } - intros; apply C0; elim H13; intros; split; try assumption. - apply Rle_trans with (a + h0); try assumption. - apply Rplus_le_reg_l with (- b - h0). - replace (- b - h0 + b) with (- h0); [ idtac | ring ]. - replace (- b - h0 + (a + h0)) with (a - b); [ idtac | ring ]. - apply Ropp_le_cancel; rewrite Ropp_involutive; rewrite Ropp_minus_distr; - apply Rle_trans with del. - { apply Rle_trans with (Rabs h0); [ apply RRle_abs | left; assumption ]. } - unfold del; apply Rle_trans with (Rmin x1 (b - a)); apply Rmin_r. } - replace (primitive h (FTC_P1 h C0) (a + h0) - primitive h (FTC_P1 h C0) a) - with (RiemannInt H13). - { replace (f a) with (RiemannInt (RiemannInt_P14 a (a + h0) (f a)) / h0). - 2:{ rewrite RiemannInt_P15. - rewrite Rplus_comm; unfold Rminus; rewrite Rplus_assoc; - rewrite Rplus_opp_r; rewrite Rplus_0_r; unfold Rdiv; - rewrite Rmult_assoc; rewrite Rinv_r; [ ring | assumption ]. } - replace - (RiemannInt H13 / h0 - RiemannInt (RiemannInt_P14 a (a + h0) (f a)) / h0) - with ((RiemannInt H13 - RiemannInt (RiemannInt_P14 a (a + h0) (f a))) / h0). - 2:{ unfold Rdiv, Rminus; rewrite Rmult_plus_distr_r; ring. } - replace (RiemannInt H13 - RiemannInt (RiemannInt_P14 a (a + h0) (f a))) with - (RiemannInt (RiemannInt_P10 (-1) H13 (RiemannInt_P14 a (a + h0) (f a)))). - 2:{ rewrite - (RiemannInt_P13 H13 (RiemannInt_P14 a (a + h0) (f a)) - (RiemannInt_P10 (-1) H13 (RiemannInt_P14 a (a + h0) (f a)))) - ; ring. } - unfold Rdiv; rewrite Rabs_mult; - apply Rle_lt_trans with - (RiemannInt - (RiemannInt_P16 - (RiemannInt_P10 (-1) H13 (RiemannInt_P14 a (a + h0) (f a)))) * - Rabs (/ h0)). - { do 2 rewrite <- (Rmult_comm (Rabs (/ h0))); apply Rmult_le_compat_l. - { apply Rabs_pos. } - apply - (RiemannInt_P17 (RiemannInt_P10 (-1) H13 (RiemannInt_P14 a (a + h0) (f a))) - (RiemannInt_P16 - (RiemannInt_P10 (-1) H13 (RiemannInt_P14 a (a + h0) (f a))))); - left; assumption. } - apply Rle_lt_trans with - (RiemannInt (RiemannInt_P14 a (a + h0) (eps / 2)) * Rabs (/ h0)). - { do 2 rewrite <- (Rmult_comm (Rabs (/ h0))); apply Rmult_le_compat_l. - { apply Rabs_pos. } - apply RiemannInt_P19. - { left; assumption. } - intros; replace (f x2 + -1 * fct_cte (f a) x2) with (f x2 - f a). - 2:{ unfold fct_cte; ring. } unfold fct_cte; case (Req_dec a x2); intro. - { rewrite H15; unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0; - left; assumption. } - elim H8; intros; left; apply H17; repeat split. - { assumption. } - rewrite Rabs_right. - { apply Rplus_lt_reg_l with a; replace (a + (x2 - a)) with x2; [ idtac | ring ]. - apply Rlt_le_trans with (a + h0). - { elim H14; intros; assumption. } - apply Rplus_le_compat_l; left; apply Rle_lt_trans with (Rabs h0). - { apply RRle_abs. } - apply Rlt_le_trans with del; - [ assumption - | unfold del; apply Rle_trans with (Rmin x1 (b - a)); - [ apply Rmin_r | apply Rmin_l ] ]. } - apply Rle_ge; left; apply Rlt_0_minus; elim H14; intros; assumption. } - rewrite RiemannInt_P15. - rewrite Rmult_assoc; replace ((a + h0 - a) * Rabs (/ h0)) with 1. - { lra. } - rewrite Rabs_right. - { rewrite Rplus_comm; unfold Rminus; rewrite Rplus_assoc; - rewrite Rplus_opp_r; rewrite Rplus_0_r; rewrite Rinv_r; - [ reflexivity | assumption ]. } - apply Rle_ge; left; apply Rinv_0_lt_compat; assert (H14 := Rge_le _ _ Hnle); - elim H14; intro. - { assumption. } - elim H10; symmetry ; assumption. } - cut (a <= a + h0). - 2:left;assumption. - cut (a + h0 <= b). - { intros; unfold primitive. - decide (Rle_dec (a+h0) b) with H14. - decide (Rle_dec a a) with (Rle_refl a). - decide (Rle_dec a (a+h0)) with H15. - decide (Rle_dec a b) with h. - rewrite RiemannInt_P9; unfold Rminus; rewrite Ropp_0; - rewrite Rplus_0_r; apply RiemannInt_P5. } - apply Rplus_le_reg_l with (- a); replace (- a + (a + h0)) with h0; - [ idtac | ring ]. - rewrite Rplus_comm; apply Rle_trans with del; - [ apply Rle_trans with (Rabs h0); [ apply RRle_abs | left; assumption ] - | unfold del; apply Rle_trans with (Rmin x1 (b - a)); apply Rmin_r ]. - - (*****) - assert (H1 : x = a). - { rewrite <- H0 in H; elim H; intros; apply Rle_antisym; assumption. } - set (f_a := fun x:R => f a * (x - a)). - assert (H2 : derivable_pt_lim f_a a (f a)). - { unfold f_a; - change (derivable_pt_lim (fct_cte (f a) * (id - fct_cte a)%F) a (f a)) - ; pattern (f a) at 2; - replace (f a) with (0 * (id - fct_cte a)%F a + fct_cte (f a) a * 1). - { apply derivable_pt_lim_mult. - { apply derivable_pt_lim_const. } - replace 1 with (1 - 0); [ idtac | ring ]. - apply derivable_pt_lim_minus. - { apply derivable_pt_lim_id. } - apply derivable_pt_lim_const. } - unfold fct_cte; ring. } - set - (f_b := fun x:R => f b * (x - b) + RiemannInt (FTC_P1 h C0 h (Rle_refl b))). - assert (H3 : derivable_pt_lim f_b b (f b)). - { unfold f_b; pattern (f b) at 2; replace (f b) with (f b + 0). - { change - (derivable_pt_lim - ((fct_cte (f b) * (id - fct_cte b))%F + - fct_cte (RiemannInt (FTC_P1 h C0 h (Rle_refl b)))) b ( - f b + 0)). - apply derivable_pt_lim_plus. - { pattern (f b) at 2; - replace (f b) with (0 * (id - fct_cte b)%F b + fct_cte (f b) b * 1). - { apply derivable_pt_lim_mult. - { apply derivable_pt_lim_const. } - replace 1 with (1 - 0); [ idtac | ring ]. - apply derivable_pt_lim_minus. - { apply derivable_pt_lim_id. } - apply derivable_pt_lim_const. } - unfold fct_cte; ring. } - apply derivable_pt_lim_const. } - ring. } - unfold derivable_pt_lim; intros; elim (H2 _ H4); intros; - elim (H3 _ H4); intros; set (del := Rmin x0 x1). - assert (H7 : 0 < del). - { unfold del; unfold Rmin; destruct (Rle_dec x0 x1) as [Hle|Hnle]. - { apply (cond_pos x0). } - apply (cond_pos x1). } - split with (mkposreal _ H7); intros; destruct (Rcase_abs h0) as [Hle|Hnle]. - { assert (H10 : a + h0 < a). - { pattern a at 2; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l; - assumption. } - rewrite H1; unfold primitive. - apply (decide_left (Rle_dec a b) h); intro h'. - assert (H11:~ a<=a+h0) by auto using Rlt_not_le. - decide (Rle_dec a (a+h0)) with H11. - decide (Rle_dec a a) with (Rle_refl a). - rewrite RiemannInt_P9; replace 0 with (f_a a). - { replace (f a * (a + h0 - a)) with (f_a (a + h0)). - { apply H5; try assumption. - apply Rlt_le_trans with del; try assumption. - unfold del; apply Rmin_l. } - unfold f_a; ring. } - unfold f_a; ring. } - assert (H10 : a < a + h0). - { pattern a at 1; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l. - assert (H10 := Rge_le _ _ Hnle); elim H10; intro. - { assumption. } - elim H8; symmetry ; assumption. } - rewrite H0 in H1; rewrite H1; unfold primitive. - decide (Rle_dec a b) with h. - decide (Rle_dec b b) with (Rle_refl b). - assert (H12 : a<=b+h0) by (eauto using Rlt_le_trans with real). - decide (Rle_dec a (b+h0)) with H12. - rewrite H0 in H10. - assert (H13 : ~b+h0<=b) by (auto using Rlt_not_le). - decide (Rle_dec (b+h0) b) with H13. - replace (RiemannInt (FTC_P1 h C0 hbis H11)) with (f_b b). - { fold (f_b (b + h0)). - apply H6; try assumption. - apply Rlt_le_trans with del; try assumption. - unfold del; apply Rmin_r. } - unfold f_b; unfold Rminus; rewrite Rplus_opp_r; - rewrite Rmult_0_r; rewrite Rplus_0_l; apply RiemannInt_P5. - -Qed. - -Lemma RiemannInt_P29 : - forall (f:R -> R) a b (h:a <= b) - (C0:forall x:R, a <= x <= b -> continuity_pt f x), - antiderivative f (primitive h (FTC_P1 h C0)) a b. -Proof. - intro f; intros; unfold antiderivative; split; try assumption; intros; - assert (H0 := RiemannInt_P28 h C0 H); - assert (H1 : derivable_pt (primitive h (FTC_P1 h C0)) x); - [ unfold derivable_pt; split with (f x); apply H0 - | split with H1; symmetry ; apply derive_pt_eq_0; apply H0 ]. -Qed. - -Lemma RiemannInt_P30 : - forall (f:R -> R) (a b:R), - a <= b -> - (forall x:R, a <= x <= b -> continuity_pt f x) -> - { g:R -> R | antiderivative f g a b }. -Proof. - intros; split with (primitive H (FTC_P1 H H0)); apply RiemannInt_P29. -Qed. - -Record C1_fun : Type := mkC1 - {c1 :> R -> R; diff0 : derivable c1; cont1 : continuity (derive c1 diff0)}. - -Lemma RiemannInt_P31 : - forall (f:C1_fun) (a b:R), - a <= b -> antiderivative (derive f (diff0 f)) f a b. -Proof. - intro f; intros; unfold antiderivative; split; try assumption; intros; - split with (diff0 f x); reflexivity. -Qed. - -Lemma RiemannInt_P32 : - forall (f:C1_fun) (a b:R), Riemann_integrable (derive f (diff0 f)) a b. -Proof. - intro f; intros; destruct (Rle_dec a b) as [Hle|Hnle]; - [ apply continuity_implies_RiemannInt; try assumption; intros; - apply (cont1 f) - | assert (H : b <= a); - [ auto with real - | apply RiemannInt_P1; apply continuity_implies_RiemannInt; - try assumption; intros; apply (cont1 f) ] ]. -Qed. - -Lemma RiemannInt_P33 : - forall (f:C1_fun) (a b:R) (pr:Riemann_integrable (derive f (diff0 f)) a b), - a <= b -> RiemannInt pr = f b - f a. -Proof. - intro f; intros; - assert - (H0 : forall x:R, a <= x <= b -> continuity_pt (derive f (diff0 f)) x). - { intros; apply (cont1 f). } - rewrite (RiemannInt_P20 H (FTC_P1 H H0) pr); - assert (H1 := RiemannInt_P29 H H0); assert (H2 := RiemannInt_P31 f H); - elim (antiderivative_Ucte (derive f (diff0 f)) _ _ _ _ H1 H2); - intros C H3; repeat rewrite H3; - [ ring - | split; [ right; reflexivity | assumption ] - | split; [ assumption | right; reflexivity ] ]. -Qed. - -Lemma FTC_Riemann : - forall (f:C1_fun) (a b:R) (pr:Riemann_integrable (derive f (diff0 f)) a b), - RiemannInt pr = f b - f a. -Proof. - intro f; intros; destruct (Rle_dec a b) as [Hle|Hnle]; - [ apply RiemannInt_P33; assumption - | assert (H : b <= a); - [ auto with real - | assert (H0 := RiemannInt_P1 pr); rewrite (RiemannInt_P8 pr H0); - rewrite (RiemannInt_P33 _ H0 H); ring ] ]. -Qed. - -(* RiemannInt *) -Lemma RiemannInt_const_bound : - forall f a b l u (h : Riemann_integrable f a b), a <= b -> - (forall x, a < x < b -> l <= f x <= u) -> - l * (b - a) <= RiemannInt h <= u * (b - a). -intros f a b l u ri ab intf. -rewrite <- !(fun l => RiemannInt_P15 (RiemannInt_P14 a b l)). -split; apply RiemannInt_P19; try assumption; - intros x intx; unfold fct_cte; destruct (intf x intx); assumption. -Qed. - -Lemma Riemann_integrable_scal : - forall f a b k, - Riemann_integrable f a b -> - Riemann_integrable (fun x => k * f x) a b. -intros f a b k ri. -apply Riemann_integrable_ext with - (f := fun x => 0 + k * f x). - { intros; ring. } -apply (RiemannInt_P10 _ (RiemannInt_P14 _ _ 0) ri). -Qed. - -Arguments Riemann_integrable_scal [f a b] k _ eps. - -Lemma Riemann_integrable_Ropp : - forall f a b, Riemann_integrable f a b -> - Riemann_integrable (fun x => - f x) a b. -intros ff a b h. -apply Riemann_integrable_ext with (f := fun x => (-1) * ff x). -{ intros; ring. } -apply Riemann_integrable_scal; assumption. -Qed. - -Arguments Riemann_integrable_Ropp [f a b] _ eps. diff --git a/stdlib/theories/Reals/RiemannInt_SF.v b/stdlib/theories/Reals/RiemannInt_SF.v deleted file mode 100644 index d2aa2e963258..000000000000 --- a/stdlib/theories/Reals/RiemannInt_SF.v +++ /dev/null @@ -1,2396 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* Prop) : Prop := - exists n : nat, (forall i:nat, I i -> (i <= n)%nat). - -Lemma IZN_var : forall z:Z, (0 <= z)%Z -> {n : nat | z = Z.of_nat n}. -Proof. - intros; apply Z_of_nat_complete_inf; assumption. -Qed. - -Lemma Nzorn : - forall I:nat -> Prop, - (exists n : nat, I n) -> - Nbound I -> { n:nat | I n /\ (forall i:nat, I i -> (i <= n)%nat) }. -Proof. - intros I H H0; set (E := fun x:R => exists i : nat, I i /\ INR i = x); - assert (H1 : bound E). - { unfold Nbound in H0; elim H0; intros N H1; unfold bound; - exists (INR N); unfold is_upper_bound; intros; - unfold E in H2; elim H2; intros; elim H3; intros; - rewrite <- H5; apply le_INR; apply H1; assumption. } - assert (H2 : exists x : R, E x). - { elim H; intros; exists (INR x); unfold E; exists x; split; - [ assumption | reflexivity ]. } - destruct (completeness E H1 H2) as (x,(H4,H5)); unfold is_upper_bound in H4, H5; - assert (H6 : 0 <= x). - { destruct H2 as (x0,H6). remember H6 as H7. destruct H7 as (x1,(H8,H9)). - apply Rle_trans with x0; - [ rewrite <- H9; change (INR 0 <= INR x1); apply le_INR; - apply Nat.le_0_l - | apply H4; assumption ]. } - assert (H7 := archimed x); elim H7; clear H7; intros; - assert (H9 : x <= IZR (up x) - 1). - { apply H5; intros x0 H9. assert (H10 := H4 _ H9); unfold E in H9; elim H9; intros x1 (H12,<-). - apply Rplus_le_reg_l with 1; - replace (1 + (IZR (up x) - 1)) with (IZR (up x)); - [ idtac | ring ]; replace (1 + INR x1) with (INR (S x1)); - [ idtac | rewrite S_INR; ring ]. - assert (H14 : (0 <= up x)%Z). - { apply le_IZR; apply Rle_trans with x; [ apply H6 | left; assumption ]. } - destruct (IZN _ H14) as (x2,H15). - rewrite H15, <- INR_IZR_INZ; apply le_INR; apply Nat.le_succ_l. - apply INR_lt; apply Rle_lt_trans with x; - [ assumption | rewrite INR_IZR_INZ; rewrite <- H15; assumption ]. } - assert (H10 : x = IZR (up x) - 1). - { apply Rle_antisym; - [ assumption - | apply Rplus_le_reg_l with (- x + 1); - replace (- x + 1 + (IZR (up x) - 1)) with (IZR (up x) - x); - [ idtac | ring ]; replace (- x + 1 + x) with 1; - [ assumption | ring ] ]. } - assert (H11 : (0 <= up x)%Z). - { apply le_IZR; apply Rle_trans with x; [ apply H6 | left; assumption ]. } - assert (H12 := IZN_var H11); elim H12; clear H12; intros x0 H8; assert (H13 : E x). - 2:{ split with (pred x0); unfold E in H13; elim H13; intros; elim H12; intros; - rewrite H10 in H15; rewrite H8 in H15; rewrite <- INR_IZR_INZ in H15; - assert (H16 : INR x0 = INR x1 + 1). - { rewrite H15; ring. } - rewrite <- S_INR in H16; assert (H17 := INR_eq _ _ H16); rewrite H17; - simpl; split. - { assumption. } - intros; apply INR_le; rewrite H15; rewrite <- H15; elim H12; intros; - rewrite H20; apply H4; unfold E; exists i; - split; [ assumption | reflexivity ]. } - elim (classic (E x)); intro; try assumption. - cut (forall y:R, E y -> y <= x - 1). - { intro H13; assert (H14 := H5 _ H13); lra. } - intros y H13; assert (H14 := H4 _ H13); elim H14; intro H15; unfold E in H13; elim H13; - intros x1 H16; elim H16; intros H17 H18; apply Rplus_le_reg_l with 1. - 2:{ rewrite H15 in H13; elim H12; assumption. } - replace (1 + (x - 1)) with x; [ idtac | ring ]; rewrite <- H18; - replace (1 + INR x1) with (INR (S x1)); [ idtac | rewrite S_INR; ring ]. - cut (x = INR (pred x0)). - { intro H19; rewrite H19; apply le_INR; apply Nat.le_succ_l; apply INR_lt; rewrite H18; - rewrite <- H19; assumption. } - rewrite H10; rewrite H8; rewrite <- INR_IZR_INZ; - rewrite <- (minus_INR _ 1). - { apply f_equal; - case x0; [ reflexivity | intro; apply Nat.sub_0_r ]. } - induction x0 as [|x0 Hrecx0]. - { rewrite H8 in H3. rewrite <- INR_IZR_INZ in H3; simpl in H3. - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H6 H3)). } - apply le_n_S; apply Nat.le_0_l. -Qed. - -(*******************************************) -(** * Step functions *) -(*******************************************) - -Definition open_interval (a b x:R) : Prop := a < x < b. -Definition co_interval (a b x:R) : Prop := a <= x < b. - -Definition adapted_couple (f:R -> R) (a b:R) (l lf:list R) : Prop := - ordered_Rlist l /\ - pos_Rl l 0 = Rmin a b /\ - pos_Rl l (pred (length l)) = Rmax a b /\ - length l = S (length lf) /\ - (forall i:nat, - (i < pred (length l))%nat -> - constant_D_eq f (open_interval (pos_Rl l i) (pos_Rl l (S i))) - (pos_Rl lf i)). - -Definition adapted_couple_opt (f:R -> R) (a b:R) (l lf:list R) := - adapted_couple f a b l lf /\ - (forall i:nat, - (i < pred (length lf))%nat -> - pos_Rl lf i <> pos_Rl lf (S i) \/ f (pos_Rl l (S i)) <> pos_Rl lf i) /\ - (forall i:nat, (i < pred (length l))%nat -> pos_Rl l i <> pos_Rl l (S i)). - -Definition is_subdivision (f:R -> R) (a b:R) (l:list R) : Type := - { l0:list R & adapted_couple f a b l l0 }. - -Definition IsStepFun (f:R -> R) (a b:R) : Type := - { l:list R & is_subdivision f a b l }. - -(** ** Class of step functions *) -Record StepFun (a b:R) : Type := mkStepFun - {fe :> R -> R; pre : IsStepFun fe a b}. - -Definition subdivision (a b:R) (f:StepFun a b) : list R := projT1 (pre f). - -Definition subdivision_val (a b:R) (f:StepFun a b) : list R := - match projT2 (pre f) with - | existT _ a b => a - end. - -Fixpoint Int_SF (l k:list R) : R := - match l with - | nil => 0 - | cons a l' => - match k with - | nil => 0 - | cons x nil => 0 - | cons x (cons y k') => a * (y - x) + Int_SF l' (cons y k') - end - end. - -(** ** Integral of step functions *) -Definition RiemannInt_SF (a b:R) (f:StepFun a b) : R := - match Rle_dec a b with - | left _ => Int_SF (subdivision_val f) (subdivision f) - | right _ => - Int_SF (subdivision_val f) (subdivision f) - end. - -(************************************) -(** ** Properties of step functions *) -(************************************) - -Lemma StepFun_P1 : - forall (a b:R) (f:StepFun a b), - adapted_couple f a b (subdivision f) (subdivision_val f). -Proof. - intros a b f; unfold subdivision_val; case (projT2 (pre f)) as (x,H); - apply H. -Qed. - -Lemma StepFun_P2 : - forall (a b:R) (f:R -> R) (l lf:list R), - adapted_couple f a b l lf -> adapted_couple f b a l lf. -Proof. - unfold adapted_couple; intros; decompose [and] H; clear H; - repeat split; try assumption. - - rewrite H2; unfold Rmin; case (Rle_dec a b); intro; - case (Rle_dec b a); intro; try reflexivity. - + apply Rle_antisym; assumption. - + apply Rle_antisym; auto with real. - - rewrite H1; unfold Rmax; case (Rle_dec a b); intro; - case (Rle_dec b a); intro; try reflexivity. - + apply Rle_antisym; assumption. - + apply Rle_antisym; auto with real. -Qed. - -Lemma StepFun_P3 : - forall a b c:R, - a <= b -> - adapted_couple (fct_cte c) a b (cons a (cons b nil)) (cons c nil). -Proof. - intros; unfold adapted_couple; repeat split. - - unfold ordered_Rlist; intros; simpl in H0; inversion H0; - [ simpl; assumption | elim (Nat.nle_succ_0 _ H2) ]. - - simpl; unfold Rmin; decide (Rle_dec a b) with H; reflexivity. - - simpl; unfold Rmax; decide (Rle_dec a b) with H; reflexivity. - - unfold constant_D_eq, open_interval; intros; simpl in H0; - inversion H0; [ reflexivity | elim (Nat.nle_succ_0 _ H3) ]. -Qed. - -Lemma StepFun_P4 : forall a b c:R, IsStepFun (fct_cte c) a b. -Proof. - intros; unfold IsStepFun; destruct (Rle_dec a b) as [Hle|Hnle]. - - apply existT with (cons a (cons b nil)); unfold is_subdivision; - apply existT with (cons c nil); apply (StepFun_P3 c Hle). - - apply existT with (cons b (cons a nil)); unfold is_subdivision; - apply existT with (cons c nil); apply StepFun_P2; - apply StepFun_P3; auto with real. -Qed. - -Lemma StepFun_P5 : - forall (a b:R) (f:R -> R) (l:list R), - is_subdivision f a b l -> is_subdivision f b a l. -Proof. - destruct 1 as (x,(H0,(H1,(H2,(H3,H4))))); exists x; - repeat split; try assumption. - - rewrite H1; apply Rmin_comm. - - rewrite H2; apply Rmax_comm. -Qed. - -Lemma StepFun_P6 : - forall (f:R -> R) (a b:R), IsStepFun f a b -> IsStepFun f b a. -Proof. - unfold IsStepFun; intros; elim X; intros; apply existT with x; - apply StepFun_P5; assumption. -Qed. - -Lemma StepFun_P7 : - forall (a b r1 r2 r3:R) (f:R -> R) (l lf:list R), - a <= b -> - adapted_couple f a b (cons r1 (cons r2 l)) (cons r3 lf) -> - adapted_couple f r2 b (cons r2 l) lf. -Proof. - unfold adapted_couple; intros; decompose [and] H0; clear H0; - assert (H5 : Rmax a b = b). - { unfold Rmax; decide (Rle_dec a b) with H; reflexivity. } - assert (H7 : r2 <= b). - { rewrite H5 in H2; rewrite <- H2; apply RList_P7; - [ assumption | simpl; right; left; reflexivity ]. } - repeat split. - - apply RList_P4 with r1; assumption. - - rewrite H5 in H2; unfold Rmin; decide (Rle_dec r2 b) with H7; reflexivity. - - unfold Rmax; decide (Rle_dec r2 b) with H7. - rewrite H5 in H2; rewrite <- H2; reflexivity. - - simpl in H4; simpl; apply INR_eq; apply Rplus_eq_reg_l with 1; - do 2 rewrite (Rplus_comm 1); do 2 rewrite <- S_INR; - rewrite H4; reflexivity. - - intros; unfold constant_D_eq, open_interval; intros; - unfold constant_D_eq, open_interval in H6; - assert (H9 : (S i < pred (length (cons r1 (cons r2 l))))%nat). - + simpl; simpl in H0; apply -> Nat.succ_lt_mono; assumption. - + assert (H10 := H6 _ H9); apply H10; assumption. -Qed. - -Lemma StepFun_P8 : - forall (f:R -> R) (l1 lf1:list R) (a b:R), - adapted_couple f a b l1 lf1 -> a = b -> Int_SF lf1 l1 = 0. -Proof. - simple induction l1. - { intros; induction lf1 as [| r lf1 Hreclf1]; reflexivity. } - intros r r0. - induction r0 as [ | r1 r2 H0]. - - intros; induction lf1 as [| r1 lf1 Hreclf1]. - + reflexivity. - + unfold adapted_couple in H0; decompose [and] H0; clear H0; simpl in H5; - discriminate. - - intros H. - induction lf1 as [| r3 lf1 Hreclf1]; intros a b H1 H2. - + reflexivity. - + simpl; cut (r = r1). - * intros H3. - rewrite H3; rewrite (H lf1 r b). - -- ring. - -- rewrite H3; apply StepFun_P7 with a r r3; [ right; assumption | assumption ]. - -- clear H H0 Hreclf1; unfold adapted_couple in H1. - decompose [and] H1. - intros; simpl in H4; rewrite H4; unfold Rmin; - case (Rle_dec a b); intro; [ assumption | reflexivity ]. - - * unfold adapted_couple in H1; decompose [and] H1; intros; apply Rle_antisym. - -- apply (H3 0%nat); simpl; apply Nat.lt_0_succ. - -- simpl in H5; rewrite H2 in H5; rewrite H5; replace (Rmin b b) with (Rmax a b); - [ rewrite <- H4; apply RList_P7; - [ assumption | simpl; right; left; reflexivity ] - | unfold Rmin, Rmax; case (Rle_dec b b); case (Rle_dec a b); intros; - try assumption || reflexivity ]. -Qed. - -Lemma StepFun_P9 : - forall (a b:R) (f:R -> R) (l lf:list R), - adapted_couple f a b l lf -> a <> b -> (2 <= length l)%nat. -Proof. - intros; unfold adapted_couple in H; decompose [and] H; clear H; - induction l as [| r l Hrecl]. - - simpl in H4; discriminate. - - induction l as [| r0 l Hrecl0]; - [ simpl in H3; simpl in H2; generalize H3; generalize H2; - unfold Rmin, Rmax; case (Rle_dec a b); - intros; elim H0; rewrite <- H5; rewrite <- H7; - reflexivity - | simpl; do 2 apply le_n_S; apply Nat.le_0_l ]. -Qed. - -Lemma StepFun_P10 : - forall (f:R -> R) (l lf:list R) (a b:R), - a <= b -> - adapted_couple f a b l lf -> - exists l' : list R, - (exists lf' : list R, adapted_couple_opt f a b l' lf'). -Proof. - induction l as [ | r r0 H]. - { intros; unfold adapted_couple in H0; decompose [and] H0; simpl in H4; - discriminate. } - intros; case (Req_dec a b); intro. - { exists (cons a nil); exists nil; unfold adapted_couple_opt; - unfold adapted_couple; unfold ordered_Rlist; - repeat split; try (intros; simpl in H3; elim (Nat.nlt_0_r _ H3)). - 1,2:simpl; rewrite <- H2; unfold Rmin,Rmax; case (Rle_dec a a); intro; - reflexivity. } - elim (RList_P20 _ (StepFun_P9 H1 H2)); intros t1 [t2 [t3 H3]]; - induction lf as [| r1 lf Hreclf]. - { unfold adapted_couple in H1; decompose [and] H1; rewrite H3 in H7; - simpl in H7; discriminate. } - clear Hreclf; assert (H4 : adapted_couple f t2 b r0 lf). - { rewrite H3 in H1; assert (H4 := RList_P21 _ _ H3); simpl in H4; rewrite H4; - eapply StepFun_P7; [ apply H0 | apply H1 ]. } - assert (t2 <= b). { - rewrite H3 in H1; clear H4; unfold adapted_couple in H1; decompose [and] H1; - clear H1; clear H H7 H9; cut (Rmax a b = b); - [ intro; rewrite H in H5; rewrite <- H5; apply RList_P7; - [ assumption | simpl; right; left; reflexivity ] - | unfold Rmax; decide (Rle_dec a b) with H0; reflexivity ]. - } - assert (H6 := H _ _ _ H5 H4); case (Req_dec t1 t2); intro Hyp_eq. - { replace a with t2. - { apply H6. } - rewrite <- Hyp_eq; rewrite H3 in H1; unfold adapted_couple in H1; - decompose [and] H1; clear H1; simpl in H9; rewrite H9; - unfold Rmin; decide (Rle_dec a b) with H0; reflexivity. } - elim H6; clear H6; intros l' [lf' H6]; case (Req_dec t2 b); intro. - { exists (cons a (cons b nil)); exists (cons r1 nil); - unfold adapted_couple_opt; unfold adapted_couple; - repeat split. - - unfold ordered_Rlist; intros; simpl in H8; inversion H8; - [ simpl; assumption | elim (Nat.nle_succ_0 _ H10) ]. - - simpl; unfold Rmin; decide (Rle_dec a b) with H0; reflexivity. - - simpl; unfold Rmax; decide (Rle_dec a b) with H0; reflexivity. - - intros; simpl in H8; inversion H8. - + unfold constant_D_eq, open_interval; intros; simpl; - simpl in H9; rewrite H3 in H1; unfold adapted_couple in H1; - decompose [and] H1; apply (H16 0%nat). - * simpl; apply Nat.lt_0_succ. - * unfold open_interval; simpl; rewrite H7; simpl in H13; - rewrite H13; unfold Rmin; decide (Rle_dec a b) with H0; assumption. - + elim (Nat.nle_succ_0 _ H10). - - intros; simpl in H8; elim (Nat.nlt_0_r _ H8). - - intros; simpl in H8; inversion H8; - [ simpl; assumption | elim (Nat.nle_succ_0 _ H10) ]. } - assert (Hyp_min : Rmin t2 b = t2) by apply Rmin_left,H5. - unfold adapted_couple in H6; elim H6; clear H6; intros; - elim (RList_P20 _ (StepFun_P9 H6 H7)); intros s1 [s2 [s3 H9]]; - induction lf' as [| r2 lf' Hreclf']. - { unfold adapted_couple in H6; decompose [and] H6; rewrite H9 in H13; - simpl in H13; discriminate. } - clear Hreclf'; case (Req_dec r1 r2); intro. - 1:case (Req_dec (f t2) r1); intro. - - exists (cons t1 (cons s2 s3)); exists (cons r1 lf'); rewrite H3 in H1; - rewrite H9 in H6; unfold adapted_couple in H6, H1; - decompose [and] H1; decompose [and] H6; clear H1 H6; - unfold adapted_couple_opt; unfold adapted_couple; - repeat split. - + unfold ordered_Rlist; intros; simpl in H1; - induction i as [| i Hreci]. - { simpl; apply Rle_trans with s1. - { replace s1 with t2. - { apply (H12 0%nat). - simpl; apply Nat.lt_0_succ. } - simpl in H19; rewrite H19; symmetry ; apply Hyp_min. } - apply (H16 0%nat); simpl; apply Nat.lt_0_succ. } - change (pos_Rl (cons s2 s3) i <= pos_Rl (cons s2 s3) (S i)); - apply (H16 (S i)); simpl; assumption. - + simpl; simpl in H14; rewrite H14; reflexivity. - + simpl; simpl in H18; rewrite H18; unfold Rmax; - decide (Rle_dec a b) with H0; decide (Rle_dec t2 b) with H5; reflexivity. - + simpl; simpl in H20; apply H20. - + intros; simpl in H1; unfold constant_D_eq, open_interval; intros; - induction i as [| i Hreci]. - { simpl; simpl in H6; destruct (total_order_T x t2) as [[Hlt|Heq]|Hgt]. - - apply (H17 0%nat); - [ simpl; apply Nat.lt_0_succ - | unfold open_interval; simpl; elim H6; intros; split; - assumption ]. - - rewrite Heq; assumption. - - rewrite H10; apply (H22 0%nat); - [ simpl; apply Nat.lt_0_succ - | unfold open_interval; simpl; replace s1 with t2; - [ elim H6; intros; split; assumption - | simpl in H19; rewrite H19; rewrite Hyp_min; reflexivity ] ]. } - simpl; simpl in H6; apply (H22 (S i)); - [ simpl; assumption - | unfold open_interval; simpl; apply H6 ]. - + intros; simpl in H1; rewrite H10; - change - (pos_Rl (cons r2 lf') i <> pos_Rl (cons r2 lf') (S i) \/ - f (pos_Rl (cons s1 (cons s2 s3)) (S i)) <> pos_Rl (cons r2 lf') i) - ; rewrite <- H9; elim H8; intros; apply H6; - simpl; apply H1. - + intros; induction i as [| i Hreci]. - { simpl; red; intro; elim Hyp_eq; apply Rle_antisym. - - apply (H12 0%nat); simpl; apply Nat.lt_0_succ. - - rewrite <- Hyp_min; rewrite H6; simpl in H19; rewrite <- H19; - apply (H16 0%nat); simpl; apply Nat.lt_0_succ. } - elim H8; intros; rewrite H9 in H21; apply (H21 (S i)); simpl; - simpl in H1; apply H1. - - exists (cons t1 l'); exists (cons r1 (cons r2 lf')); rewrite H9 in H6; - rewrite H3 in H1; unfold adapted_couple in H1, H6; - decompose [and] H6; decompose [and] H1; clear H6 H1; - unfold adapted_couple_opt; unfold adapted_couple; - repeat split. - + rewrite H9; unfold ordered_Rlist; intros; simpl in H1; - induction i as [| i Hreci]. - { simpl; replace s1 with t2. - { apply (H16 0%nat); simpl; apply Nat.lt_0_succ. } - simpl in H14; rewrite H14; rewrite Hyp_min; reflexivity. } - change - (pos_Rl (cons s1 (cons s2 s3)) i <= pos_Rl (cons s1 (cons s2 s3)) (S i)) - ; apply (H12 i); simpl; apply Nat.succ_lt_mono; - assumption. - + simpl; simpl in H19; apply H19. - + rewrite H9; simpl; simpl in H13; rewrite H13; unfold Rmax; - decide (Rle_dec t2 b) with H5; decide (Rle_dec a b) with H0; reflexivity. - + rewrite H9; simpl; simpl in H15; rewrite H15; reflexivity. - + intros; simpl in H1; unfold constant_D_eq, open_interval; intros; - induction i as [| i Hreci]. - { simpl; rewrite H9 in H6; simpl in H6; apply (H22 0%nat). - { simpl; apply Nat.lt_0_succ. } - unfold open_interval; simpl. - replace t2 with s1. - { assumption. } - simpl in H14; rewrite H14; rewrite Hyp_min; reflexivity. } - change (f x = pos_Rl (cons r2 lf') i); clear Hreci; apply (H17 i). - { simpl; rewrite H9 in H1; simpl in H1; apply Nat.succ_lt_mono; apply H1. } - rewrite H9 in H6; unfold open_interval; apply H6. - + intros; simpl in H1; induction i as [| i Hreci]. - { simpl; rewrite H9; right; simpl; replace s1 with t2. - { assumption. } - simpl in H14; rewrite H14; rewrite Hyp_min; reflexivity. } - elim H8; intros; apply (H6 i). - simpl; apply Nat.succ_lt_mono; apply H1. - + intros; rewrite H9; induction i as [| i Hreci]. - { simpl; red; intro; elim Hyp_eq; apply Rle_antisym. - { apply (H16 0%nat); simpl; apply Nat.lt_0_succ. } - rewrite <- Hyp_min; rewrite H6; simpl in H14; rewrite <- H14; right; - reflexivity. } - elim H8; intros; rewrite <- H9; apply (H21 i); rewrite H9; rewrite H9 in H1; - simpl; simpl in H1; apply Nat.succ_lt_mono; apply H1. - - exists (cons t1 l'); exists (cons r1 (cons r2 lf')); rewrite H9 in H6; - rewrite H3 in H1; unfold adapted_couple in H1, H6; - decompose [and] H6; decompose [and] H1; clear H6 H1; - unfold adapted_couple_opt; unfold adapted_couple; - repeat split. - + rewrite H9; unfold ordered_Rlist; intros; simpl in H1; - induction i as [| i Hreci]. - { simpl; replace s1 with t2. - { apply (H15 0%nat); simpl; apply Nat.lt_0_succ. } - simpl in H13; rewrite H13; rewrite Hyp_min; reflexivity. } - change - (pos_Rl (cons s1 (cons s2 s3)) i <= pos_Rl (cons s1 (cons s2 s3)) (S i)) - ; apply (H11 i); simpl; apply Nat.succ_lt_mono; - assumption. - + simpl; simpl in H18; apply H18. - + rewrite H9; simpl; simpl in H12; rewrite H12; unfold Rmax; - decide (Rle_dec t2 b) with H5; decide (Rle_dec a b) with H0; reflexivity. - + rewrite H9; simpl; simpl in H14; rewrite H14; reflexivity. - + intros; simpl in H1; unfold constant_D_eq, open_interval; intros; - induction i as [| i Hreci]. - { simpl; rewrite H9 in H6; simpl in H6; apply (H21 0%nat). - { simpl; apply Nat.lt_0_succ. } - unfold open_interval; simpl; replace t2 with s1. - { assumption. } - simpl in H13; rewrite H13; rewrite Hyp_min; reflexivity. } - change (f x = pos_Rl (cons r2 lf') i); clear Hreci; apply (H16 i). - { simpl; rewrite H9 in H1; simpl in H1; apply Nat.succ_lt_mono; apply H1. } - rewrite H9 in H6; unfold open_interval; apply H6. - + intros; simpl in H1; induction i as [| i Hreci]. - { simpl; left; assumption. } - elim H8; intros; apply (H6 i). - simpl; apply Nat.succ_lt_mono; apply H1. - + intros; rewrite H9; induction i as [| i Hreci]. - { simpl; red; intro; elim Hyp_eq; apply Rle_antisym. - { apply (H15 0%nat); simpl; apply Nat.lt_0_succ. } - rewrite <- Hyp_min; rewrite H6; simpl in H13; rewrite <- H13; right; - reflexivity. } - elim H8; intros; rewrite <- H9; apply (H20 i); rewrite H9; rewrite H9 in H1; - simpl; simpl in H1; apply Nat.succ_lt_mono; apply H1. -Qed. - -Lemma StepFun_P11 : - forall (a b r r1 r3 s1 s2 r4:R) (r2 lf1 s3 lf2:list R) - (f:R -> R), - a < b -> - adapted_couple f a b (cons r (cons r1 r2)) (cons r3 lf1) -> - adapted_couple_opt f a b (cons s1 (cons s2 s3)) (cons r4 lf2) -> r1 <= s2. -Proof. - intros; unfold adapted_couple_opt in H1; elim H1; clear H1; intros; - unfold adapted_couple in H0, H1; decompose [and] H0; - decompose [and] H1; clear H0 H1; assert (H12 : r = s1). - { simpl in H10; simpl in H5; congruence. } - assert (H14 := H3 0%nat (Nat.lt_0_succ _)); simpl in H14; elim H14; intro. - 2:{ rewrite <- H0; rewrite H12; apply (H7 0%nat); simpl; apply Nat.lt_0_succ. } - assert (H15 := H7 0%nat (Nat.lt_0_succ _)); simpl in H15; elim H15; intro. - 2:{ elim H2; clear H2; intros; assert (H17 := H16 0%nat); simpl in H17; - elim (H17 (Nat.lt_0_succ _)); assumption. } - rewrite <- H12 in H1; destruct (Rle_dec r1 s2) as [Hle|Hnle]; try assumption. - assert (H16 : s2 < r1) by auto with real. - induction s3 as [| r0 s3 Hrecs3]. - { simpl in H9; rewrite H9 in H16; cut (r1 <= Rmax a b). - { intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H17 H16)). } - rewrite <- H4; apply RList_P7; - [ assumption | simpl; right; left; reflexivity ]. } - clear Hrecs3; induction lf2 as [| r5 lf2 Hreclf2]. - { simpl in H11; discriminate. } - clear Hreclf2; assert (H17 : r3 = r4). - { set (x := (r + s2) / 2); assert (H17 := H8 0%nat (Nat.lt_0_succ _)); - assert (H18 := H13 0%nat (Nat.lt_0_succ _)); - unfold constant_D_eq, open_interval in H17, H18; simpl in H17; - simpl in H18; rewrite <- (H17 x). - 1: apply H18;rewrite <- H12. - 1,2: unfold x; lra. } - assert (H18 : f s2 = r3). - { apply (H8 0%nat); - [ simpl; apply Nat.lt_0_succ - | unfold open_interval; simpl; split; assumption ]. } - assert (H19 : r3 = r5). - 2:{ elim H2; intros; assert (H22 := H20 0%nat); simpl in H22; - assert (H23 := H22 (Nat.lt_0_succ _)); elim H23; intro; - [ elim H24; rewrite <- H17; rewrite <- H19; reflexivity - | elim H24; rewrite <- H17; assumption ]. } - assert (H19 := H7 1%nat); simpl in H19; - assert (H20 := H19 (proj1 (Nat.succ_lt_mono _ _) (Nat.lt_0_succ _))); elim H20; - intro. - 2:{ elim H2; clear H2; intros; assert (H23 := H22 1%nat); simpl in H23; - assert (H24 := H23 (proj1 (Nat.succ_lt_mono _ _) (Nat.lt_0_succ _))); elim H24; - assumption. } - set (x := (s2 + Rmin r1 r0) / 2); assert (H22 := H8 0%nat); - assert (H23 := H13 1%nat); simpl in H22; simpl in H23; - rewrite <- (H22 (Nat.lt_0_succ _) x). - 1:apply (H23 (proj1 (Nat.succ_lt_mono _ _) (Nat.lt_0_succ _)) x). - 1,2:unfold open_interval; simpl; unfold x; - unfold Rmin;destruct (Rle_dec r1 r0);lra. -Qed. - -Lemma StepFun_P12 : - forall (a b:R) (f:R -> R) (l lf:list R), - adapted_couple_opt f a b l lf -> adapted_couple_opt f b a l lf. -Proof. - unfold adapted_couple_opt; unfold adapted_couple; intros; - decompose [and] H; clear H; repeat split; try assumption. - - rewrite H0; unfold Rmin; case (Rle_dec a b); intro; - case (Rle_dec b a); intro; try reflexivity. - + apply Rle_antisym; assumption. - + apply Rle_antisym; auto with real. - - rewrite H3; unfold Rmax; case (Rle_dec a b); intro; - case (Rle_dec b a); intro; try reflexivity. - + apply Rle_antisym; assumption. - + apply Rle_antisym; auto with real. -Qed. - -Lemma StepFun_P13 : - forall (a b r r1 r3 s1 s2 r4:R) (r2 lf1 s3 lf2:list R) - (f:R -> R), - a <> b -> - adapted_couple f a b (cons r (cons r1 r2)) (cons r3 lf1) -> - adapted_couple_opt f a b (cons s1 (cons s2 s3)) (cons r4 lf2) -> r1 <= s2. -Proof. - intros; destruct (total_order_T a b) as [[Hlt|Heq]|Hgt]. - - eapply StepFun_P11; [ apply Hlt | apply H0 | apply H1 ]. - - elim H; assumption. - - eapply StepFun_P11; - [ apply Hgt | apply StepFun_P2; apply H0 | apply StepFun_P12; apply H1 ]. -Qed. - -Lemma StepFun_P14 : - forall (f:R -> R) (l1 l2 lf1 lf2:list R) (a b:R), - a <= b -> - adapted_couple f a b l1 lf1 -> - adapted_couple_opt f a b l2 lf2 -> Int_SF lf1 l1 = Int_SF lf2 l2. -Proof. - induction l1 as [ | r r0 H0]. - { intros l2 lf1 lf2 a b Hyp H H0; unfold adapted_couple in H; decompose [and] H; - clear H H0 H2 H3 H1 H6; simpl in H4; discriminate. } - induction r0 as [|r1 r2 H]. - { intros; case (Req_dec a b); intro. - - unfold adapted_couple_opt in H2; elim H2; intros; rewrite (StepFun_P8 H4 H3); - rewrite (StepFun_P8 H1 H3); reflexivity. - - assert (H4 := StepFun_P9 H1 H3); simpl in H4; - elim (Nat.nle_succ_0 _ (le_S_n _ _ H4)). } - intros; clear H; unfold adapted_couple_opt in H3; elim H3; clear H3; intros; - case (Req_dec a b); intro. - { rewrite (StepFun_P8 H2 H4); rewrite (StepFun_P8 H H4); reflexivity. } - assert (Hyp_min : Rmin a b = a). - { unfold Rmin; decide (Rle_dec a b) with H1; reflexivity. } - assert (Hyp_max : Rmax a b = b). - { unfold Rmax; decide (Rle_dec a b) with H1; reflexivity. } - elim (RList_P20 _ (StepFun_P9 H H4)); intros s1 [s2 [s3 H5]]; rewrite H5 in H; - rewrite H5; induction lf1 as [| r3 lf1 Hreclf1]. - { unfold adapted_couple in H2; decompose [and] H2; - clear H H2 H4 H5 H3 H6 H8 H7 H11; simpl in H9; discriminate. } - clear Hreclf1; induction lf2 as [| r4 lf2 Hreclf2]. - { unfold adapted_couple in H; decompose [and] H; - clear H H2 H4 H5 H3 H6 H8 H7 H11; simpl in H9; discriminate. } - clear Hreclf2; assert (H6 : r = s1). - { unfold adapted_couple in H, H2; decompose [and] H; decompose [and] H2; - clear H H2; simpl in H13; simpl in H8; rewrite H13; - rewrite H8; reflexivity. } - assert (H7 : r3 = r4 \/ r = r1). { - case (Req_dec r r1); intro. - { right; assumption. } - left; assert (r1 <= s2). { - eapply StepFun_P13. - - apply H4. - - apply H2. - - unfold adapted_couple_opt; split. - + apply H. - + rewrite H5 in H3; apply H3. - } - unfold adapted_couple in H2, H; decompose [and] H; decompose [and] H2; - clear H H2; set (x := (r + r1) / 2); assert (H18 := H14 0%nat); - assert (H20 := H19 0%nat); unfold constant_D_eq, open_interval in H18, H20; - simpl in H18; simpl in H20; rewrite <- (H18 (Nat.lt_0_succ _) x). - { rewrite <- (H20 (Nat.lt_0_succ _) x). - { reflexivity. } - assert (H21 := H13 0%nat (Nat.lt_0_succ _)); simpl in H21; elim H21; intro; - [ idtac | elim H7; assumption ]; unfold x; - lra. } - rewrite <- H6; assert (H21 := H13 0%nat (Nat.lt_0_succ _)); simpl in H21; elim H21; - intro; [ idtac | elim H7; assumption ]; unfold x; - lra. } - assert (H8 : r1 <= s2). { - eapply StepFun_P13. - - apply H4. - - apply H2. - - unfold adapted_couple_opt; split. - + apply H. - + rewrite H5 in H3; apply H3. - } - elim H7; intro. - 2:{ simpl; rewrite H9; unfold Rminus; rewrite Rplus_opp_r; - rewrite Rmult_0_r; rewrite Rplus_0_l; - change - (Int_SF lf1 (cons r1 r2) = Int_SF (cons r4 lf2) (cons s1 (cons s2 s3))) - ; eapply H0. - - apply H1. - - assert (H10 : r = a). - + unfold adapted_couple in H2; decompose [and] H2; clear H2; simpl in H12; - rewrite H12; apply Hyp_min. - + rewrite <- H9; rewrite H10; apply StepFun_P7 with a r r3; - [ apply H1 - | pattern a at 2; rewrite <- H10; pattern r at 2; rewrite H9; - apply H2 ]. - - rewrite H5 in H3; unfold adapted_couple_opt; split; assumption. } - simpl; elim H8; intro. - { replace (r4 * (s2 - s1)) with (r3 * (r1 - r) + r3 * (s2 - r1)); - [ idtac | rewrite H9; rewrite H6; ring ]. - rewrite Rplus_assoc; apply Rplus_eq_compat_l; - change - (Int_SF lf1 (cons r1 r2) = Int_SF (cons r3 lf2) (cons r1 (cons s2 s3))) - ; apply H0 with r1 b. - { unfold adapted_couple in H2; decompose [and] H2; clear H2; - replace b with (Rmax a b); - rewrite <- H12; apply RList_P7; - [ assumption | simpl; right; left; reflexivity ]. } - { eapply StepFun_P7. - - apply H1. - - apply H2. } - unfold adapted_couple_opt; split. - { apply StepFun_P7 with a a r3. - { apply H1. } - unfold adapted_couple in H2, H; decompose [and] H2; decompose [and] H; - clear H H2; assert (H20 : r = a). - { simpl in H13; rewrite H13; apply Hyp_min. } - unfold adapted_couple; repeat split. - - unfold ordered_Rlist; intros; simpl in H; induction i as [| i Hreci]. - { simpl; rewrite <- H20; apply (H11 0%nat). - simpl; apply Nat.lt_0_succ. } - induction i as [| i Hreci0]. - { simpl; assumption. } - change (pos_Rl (cons s2 s3) i <= pos_Rl (cons s2 s3) (S i)); - apply (H15 (S i)); simpl; apply Nat.succ_lt_mono; assumption. - - simpl; symmetry ; apply Hyp_min. - - rewrite <- H17; reflexivity. - - simpl in H19; simpl; rewrite H19; reflexivity. - - intros; simpl in H; unfold constant_D_eq, open_interval; intros; - induction i as [| i Hreci]. - { simpl; apply (H16 0%nat). - { simpl; apply Nat.lt_0_succ. } - simpl in H2; rewrite <- H20 in H2; unfold open_interval; - simpl; apply H2. } - clear Hreci; induction i as [| i Hreci]. - { simpl; simpl in H2; rewrite H9; apply (H21 0%nat). - { simpl; apply Nat.lt_0_succ. } - unfold open_interval; simpl; elim H2; intros; split. - { apply Rle_lt_trans with r1; try assumption; rewrite <- H6; apply (H11 0%nat); - simpl; apply Nat.lt_0_succ. } - assumption. } - clear Hreci; simpl; apply (H21 (S i)). - { simpl; apply Nat.succ_lt_mono; assumption. } - unfold open_interval; apply H2. } - elim H3; clear H3; intros; split. - { rewrite H9; - change - (forall i:nat, - (i < pred (length (cons r4 lf2)))%nat -> - pos_Rl (cons r4 lf2) i <> pos_Rl (cons r4 lf2) (S i) \/ - f (pos_Rl (cons s1 (cons s2 s3)) (S i)) <> pos_Rl (cons r4 lf2) i) - ; rewrite <- H5; apply H3. } - rewrite H5 in H11; intros; simpl in H12; induction i as [| i Hreci]. - { simpl; red; intro; rewrite H13 in H10; - elim (Rlt_irrefl _ H10). } - clear Hreci; apply (H11 (S i)); simpl; apply H12. } - rewrite H9; rewrite H10; rewrite H6; apply Rplus_eq_compat_l; rewrite <- H10; - apply H0 with r1 b. - { unfold adapted_couple in H2; decompose [and] H2; clear H2; - replace b with (Rmax a b). - rewrite <- H12; apply RList_P7; - [ assumption | simpl; right; left; reflexivity ]. } - { eapply StepFun_P7. - - apply H1. - - apply H2. } - unfold adapted_couple_opt; split. - { apply StepFun_P7 with a a r3. - { apply H1. } - unfold adapted_couple in H2, H; decompose [and] H2; decompose [and] H; - clear H H2; assert (H20 : r = a). - { simpl in H13; rewrite H13; apply Hyp_min. } - unfold adapted_couple; repeat split. - - unfold ordered_Rlist; intros; simpl in H; induction i as [| i Hreci]. - { simpl; rewrite <- H20; apply (H11 0%nat); simpl; - apply Nat.lt_0_succ. } - rewrite H10; apply (H15 (S i)); simpl; assumption. - - simpl; symmetry ; apply Hyp_min. - - rewrite <- H17; rewrite H10; reflexivity. - - simpl in H19; simpl; apply H19. - - intros; simpl in H; unfold constant_D_eq, open_interval; intros; - induction i as [| i Hreci]. - { simpl; apply (H16 0%nat). - { simpl; apply Nat.lt_0_succ. } - simpl in H2; rewrite <- H20 in H2; unfold open_interval; - simpl; apply H2. } - clear Hreci; simpl; apply (H21 (S i)). - { simpl; assumption. } - rewrite <- H10; unfold open_interval; apply H2. } - elim H3; clear H3; intros; split. - - rewrite H5 in H3; intros; apply (H3 (S i)). - simpl; replace (length lf2) with (S (pred (length lf2))). - { apply -> Nat.succ_lt_mono; apply H12. } - apply Nat.lt_succ_pred with 0%nat; apply Nat.neq_0_lt_0; red; - intro; rewrite H13 in H12; elim (Nat.nlt_0_r _ H12). - - intros; simpl in H12; rewrite H10; rewrite H5 in H11; apply (H11 (S i)); - simpl; apply -> Nat.succ_lt_mono; apply H12. -Qed. - -Lemma StepFun_P15 : - forall (f:R -> R) (l1 l2 lf1 lf2:list R) (a b:R), - adapted_couple f a b l1 lf1 -> - adapted_couple_opt f a b l2 lf2 -> Int_SF lf1 l1 = Int_SF lf2 l2. -Proof. - intros; destruct (Rle_dec a b) as [Hle|Hnle]; - [ apply (StepFun_P14 Hle H H0) - | assert (H1 : b <= a); - [ auto with real - | eapply StepFun_P14; - [ apply H1 | apply StepFun_P2; apply H | apply StepFun_P12; apply H0 ] ] ]. -Qed. - -Lemma StepFun_P16 : - forall (f:R -> R) (l lf:list R) (a b:R), - adapted_couple f a b l lf -> - exists l' : list R, - (exists lf' : list R, adapted_couple_opt f a b l' lf'). -Proof. - intros; destruct (Rle_dec a b) as [Hle|Hnle]; - [ apply (StepFun_P10 Hle H) - | assert (H1 : b <= a); - [ auto with real - | assert (H2 := StepFun_P10 H1 (StepFun_P2 H)); elim H2; - intros l' [lf' H3]; exists l'; exists lf'; apply StepFun_P12; - assumption ] ]. -Qed. - -Lemma StepFun_P17 : - forall (f:R -> R) (l1 l2 lf1 lf2:list R) (a b:R), - adapted_couple f a b l1 lf1 -> - adapted_couple f a b l2 lf2 -> Int_SF lf1 l1 = Int_SF lf2 l2. -Proof. - intros; elim (StepFun_P16 H); intros l' [lf' H1]; rewrite (StepFun_P15 H H1); - rewrite (StepFun_P15 H0 H1); reflexivity. -Qed. - -Lemma StepFun_P18 : - forall a b c:R, RiemannInt_SF (mkStepFun (StepFun_P4 a b c)) = c * (b - a). -Proof. - intros; unfold RiemannInt_SF; case (Rle_dec a b); intro. - - replace - (Int_SF (subdivision_val (mkStepFun (StepFun_P4 a b c))) - (subdivision (mkStepFun (StepFun_P4 a b c)))) with - (Int_SF (cons c nil) (cons a (cons b nil))); - [ simpl; ring - | apply StepFun_P17 with (fct_cte c) a b; - [ apply StepFun_P3; assumption - | apply (StepFun_P1 (mkStepFun (StepFun_P4 a b c))) ] ]. - - replace - (Int_SF (subdivision_val (mkStepFun (StepFun_P4 a b c))) - (subdivision (mkStepFun (StepFun_P4 a b c)))) with - (Int_SF (cons c nil) (cons b (cons a nil))); - [ simpl; ring - | apply StepFun_P17 with (fct_cte c) a b; - [ apply StepFun_P2; apply StepFun_P3; auto with real - | apply (StepFun_P1 (mkStepFun (StepFun_P4 a b c))) ] ]. -Qed. - -Lemma StepFun_P19 : - forall (l1:list R) (f g:R -> R) (l:R), - Int_SF (FF l1 (fun x:R => f x + l * g x)) l1 = - Int_SF (FF l1 f) l1 + l * Int_SF (FF l1 g) l1. -Proof. - intros; induction l1 as [| r l1 Hrecl1]; - [ simpl; ring - | induction l1 as [| r0 l1 Hrecl0]; simpl; - [ ring | simpl in Hrecl1; rewrite Hrecl1; ring ] ]. -Qed. - -Lemma StepFun_P20 : - forall (l:list R) (f:R -> R), - (0 < length l)%nat -> length l = S (length (FF l f)). -Proof. - intros l f H; induction l; - [ elim (Nat.lt_irrefl _ H) - | simpl; rewrite RList_P18; rewrite RList_P14; reflexivity ]. -Qed. - -Lemma StepFun_P21 : - forall (a b:R) (f:R -> R) (l:list R), - is_subdivision f a b l -> adapted_couple f a b l (FF l f). -Proof. - intros * (x & H & H1 & H0 & H2 & H4). - repeat split; try assumption. - - apply StepFun_P20; rewrite H2; apply Nat.lt_0_succ. - - intros; assert (H5 := H4 _ H3); unfold constant_D_eq, open_interval in H5; - unfold constant_D_eq, open_interval; intros; - induction l as [| r l Hrecl]. - + discriminate. - + unfold FF; rewrite RList_P12. - * simpl; - change (f x0 = f (pos_Rl (mid_Rlist (cons r l) r) (S i))); - rewrite RList_P13; try assumption; rewrite (H5 x0 H6); - rewrite H5. - -- reflexivity. - -- lra. - * rewrite RList_P14; simpl in H3; apply H3. -Qed. - -Lemma StepFun_P22 : - forall (a b:R) (f g:R -> R) (lf lg:list R), - a <= b -> - is_subdivision f a b lf -> - is_subdivision g a b lg -> is_subdivision f a b (cons_ORlist lf lg). -Proof. - unfold is_subdivision; intros a b f g lf lg Hyp X X0; elim X; elim X0; - clear X X0; intros lg0 p lf0 p0; assert (Hyp_min : Rmin a b = a). - { unfold Rmin; decide (Rle_dec a b) with Hyp; reflexivity. } - assert (Hyp_max : Rmax a b = b). - { unfold Rmax; decide (Rle_dec a b) with Hyp; reflexivity. } - apply existT with (FF (cons_ORlist lf lg) f); unfold adapted_couple in p, p0; - decompose [and] p; decompose [and] p0; clear p p0; - rewrite Hyp_min in H6; rewrite Hyp_min in H1; rewrite Hyp_max in H0; - rewrite Hyp_max in H5; unfold adapted_couple; - repeat split. - - apply RList_P2; assumption. - - rewrite Hyp_min; symmetry ; apply Rle_antisym. - 2:{ induction lf as [| r lf Hreclf]. - { simpl; right; assumption. } - assert (H8 : In a (cons_ORlist (cons r lf) lg)). - { elim (RList_P9 (cons r lf) lg a); intros; apply H10; left; - elim (RList_P3 (cons r lf) a); intros; apply H12; - exists 0%nat; split; - [ symmetry ; assumption | simpl; apply Nat.lt_0_succ ]. } - apply RList_P5; [ apply RList_P2; assumption | assumption ]. } - induction lf as [| r lf Hreclf]. - { simpl; right; symmetry ; assumption. } - assert - (H10 : - In (pos_Rl (cons_ORlist (cons r lf) lg) 0) (cons_ORlist (cons r lf) lg)). - { elim - (RList_P3 (cons_ORlist (cons r lf) lg) - (pos_Rl (cons_ORlist (cons r lf) lg) 0)); intros _ H10; - apply H10; exists 0%nat; split; - [ reflexivity | rewrite RList_P11; simpl; apply Nat.lt_0_succ ]. } - elim (RList_P9 (cons r lf) lg (pos_Rl (cons_ORlist (cons r lf) lg) 0)); - intros H12 _; assert (H13 := H12 H10); elim H13; intro. - { elim (RList_P3 (cons r lf) (pos_Rl (cons_ORlist (cons r lf) lg) 0)); - intros H11 _; assert (H14 := H11 H8); elim H14; intros; - elim H15; clear H15; intros; rewrite H15; rewrite <- H6; - elim (RList_P6 (cons r lf)); intros; apply H17; - [ assumption | apply Nat.le_0_l | assumption ]. } - elim (RList_P3 lg (pos_Rl (cons_ORlist (cons r lf) lg) 0)); intros H11 _; - assert (H14 := H11 H8); elim H14; intros; elim H15; - clear H15; intros; rewrite H15; rewrite <- H1; elim (RList_P6 lg); - intros; apply H17; [ assumption | apply Nat.le_0_l | assumption ]. - - rewrite Hyp_max; apply Rle_antisym. - 2:{ induction lf as [| r lf Hreclf]. - { simpl; right; symmetry ; assumption. } - assert (H8 : In b (cons_ORlist (cons r lf) lg)). - { elim (RList_P9 (cons r lf) lg b); intros; apply H10; left; - elim (RList_P3 (cons r lf) b); intros; apply H12; - exists (pred (length (cons r lf))); split; - [ symmetry ; assumption | simpl; apply Nat.lt_succ_diag_r ]. } - apply RList_P7; [ apply RList_P2; assumption | assumption ]. } - induction lf as [| r lf Hreclf]. - { simpl; right; assumption. } - assert - (H8 : - In - (pos_Rl (cons_ORlist (cons r lf) lg) - (pred (length (cons_ORlist (cons r lf) lg)))) - (cons_ORlist (cons r lf) lg)). - { elim - (RList_P3 (cons_ORlist (cons r lf) lg) - (pos_Rl (cons_ORlist (cons r lf) lg) - (pred (length (cons_ORlist (cons r lf) lg))))); - intros _ H10; apply H10; - exists (pred (length (cons_ORlist (cons r lf) lg))); - split; [ reflexivity | rewrite RList_P11; simpl; apply Nat.lt_succ_diag_r ]. } - elim - (RList_P9 (cons r lf) lg - (pos_Rl (cons_ORlist (cons r lf) lg) - (pred (length (cons_ORlist (cons r lf) lg))))); - intros H10 _. - assert (H11 := H10 H8); elim H11; intro. - { elim - (RList_P3 (cons r lf) - (pos_Rl (cons_ORlist (cons r lf) lg) - (pred (length (cons_ORlist (cons r lf) lg))))); - intros H13 _; assert (H14 := H13 H12); elim H14; intros; - elim H15; clear H15; intros; rewrite H15; rewrite <- H5; - elim (RList_P6 (cons r lf)); intros; apply H17; - [ assumption - | simpl; simpl in H14; apply Nat.lt_succ_r; assumption - | simpl; apply Nat.lt_succ_diag_r ]. } - elim - (RList_P3 lg - (pos_Rl (cons_ORlist (cons r lf) lg) - (pred (length (cons_ORlist (cons r lf) lg))))); - intros H13 _; assert (H14 := H13 H12); elim H14; intros; - elim H15; clear H15; intros. - rewrite H15; assert (H17 : length lg = S (pred (length lg))). - { symmetry; apply Nat.lt_succ_pred with 0%nat. - apply Nat.neq_0_lt_0; red; intro; - rewrite H17 in H16; elim (Nat.nlt_0_r _ H16). } - rewrite <- H0; elim (RList_P6 lg); intros; apply H18; - [ assumption - | rewrite H17 in H16; apply Nat.lt_succ_r; assumption - | apply Nat.lt_pred_l; rewrite H17; intros Heq; discriminate ]. - - apply StepFun_P20; rewrite RList_P11; rewrite H2; rewrite H7; simpl; - apply Nat.lt_0_succ. - - intros; unfold constant_D_eq, open_interval; intros; - cut - (exists l : R, - constant_D_eq f - (open_interval (pos_Rl (cons_ORlist lf lg) i) - (pos_Rl (cons_ORlist lf lg) (S i))) l). - + intros; elim H11; clear H11; intros; assert (H12 := H11); - assert - (Hyp_cons : - exists r : R, (exists r0 : list R, cons_ORlist lf lg = cons r r0)). - { apply RList_P19; red; intro; rewrite H13 in H8; elim (Nat.nlt_0_r _ H8). } - elim Hyp_cons; clear Hyp_cons; intros r [r0 Hyp_cons]; rewrite Hyp_cons; - unfold FF; rewrite RList_P12. - 2:{ rewrite RList_P14; rewrite Hyp_cons in H8; simpl in H8; apply H8. } - change (f x = f (pos_Rl (mid_Rlist (cons r r0) r) (S i))); - rewrite <- Hyp_cons; rewrite RList_P13. - 2:{ apply H8. } - assert (H13 := RList_P2 _ _ H _ H8); elim H13; intro. - 2:{ elim H10; intros; rewrite H14 in H15; - elim (Rlt_irrefl _ (Rlt_trans _ _ _ H16 H15)). } - unfold constant_D_eq, open_interval in H11, H12; rewrite (H11 x H10); - assert - (H15 : - pos_Rl (cons_ORlist lf lg) i < - (pos_Rl (cons_ORlist lf lg) i + pos_Rl (cons_ORlist lf lg) (S i)) / 2 < - pos_Rl (cons_ORlist lf lg) (S i)) by lra. - rewrite (H11 _ H15); reflexivity. - + assert (H11 : a < b). { - apply Rle_lt_trans with (pos_Rl (cons_ORlist lf lg) i). - 2:apply Rlt_le_trans with (pos_Rl (cons_ORlist lf lg) (S i)). - - rewrite <- H6; rewrite <- (RList_P15 lf lg). - + elim (RList_P6 (cons_ORlist lf lg)); intros; apply H11. - * apply RList_P2; assumption. - * apply Nat.le_0_l. - * apply Nat.lt_trans with (pred (length (cons_ORlist lf lg))); - [ assumption - | apply Nat.lt_pred_l; apply Nat.neq_0_lt_0; apply Nat.neq_0_lt_0; red; intro; - rewrite H13 in H8; elim (Nat.nlt_0_r _ H8) ]. - + assumption. - + assumption. - + rewrite H1; assumption. - - elim H10; intros; apply Rlt_trans with x; assumption. - - rewrite <- H5; rewrite <- (RList_P16 lf lg); try assumption. - { elim (RList_P6 (cons_ORlist lf lg)); intros; apply H11. - - apply RList_P2; assumption. - - apply Nat.lt_succ_r; apply -> Nat.succ_lt_mono; assumption. - - apply Nat.lt_pred_l; red; intro; rewrite H13 in H8; - elim (Nat.nlt_0_r _ H8). } - rewrite H0; assumption. - } - set - (I := - fun j:nat => - pos_Rl lf j <= pos_Rl (cons_ORlist lf lg) i /\ (j < length lf)%nat); - assert (H12 : Nbound I). - { unfold Nbound; exists (length lf); intros; unfold I in H12; elim H12; - intros; apply Nat.lt_le_incl; assumption. } - assert (H13 : exists n : nat, I n). { - exists 0%nat; unfold I; split. - 2:{ apply Nat.neq_0_lt_0; red; intro; rewrite H13 in H5; - rewrite <- H6 in H11; rewrite <- H5 in H11; elim (Rlt_irrefl _ H11). } - apply Rle_trans with (pos_Rl (cons_ORlist lf lg) 0). - { right; symmetry . - apply RList_P15; try assumption; rewrite H1; assumption. } - elim (RList_P6 (cons_ORlist lf lg)); intros; apply H13. - - apply RList_P2; assumption. - - apply Nat.le_0_l. - - lia. - } - assert (H14 := Nzorn H13 H12); elim H14; clear H14; intros x0 H14; - exists (pos_Rl lf0 x0); unfold constant_D_eq, open_interval; - intros; assert (H16 := H9 x0); assert (H17 : (x0 < pred (length lf))%nat). - { elim H14; clear H14; intros; unfold I in H14; elim H14; clear H14; intros; - apply Nat.succ_lt_mono; replace (S (pred (length lf))) with (length lf). - { inversion H18. - 2: apply -> Nat.succ_lt_mono; assumption. - assert (x0 = pred (length lf)). { - rewrite <- H20; reflexivity. - } - rewrite H19 in H14; rewrite H5 in H14; - cut (pos_Rl (cons_ORlist lf lg) i < b). - - intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H14 H21)). - - apply Rlt_le_trans with (pos_Rl (cons_ORlist lf lg) (S i)). - { elim H10; intros; apply Rlt_trans with x; assumption. } - rewrite <- H5; - apply Rle_trans with - (pos_Rl (cons_ORlist lf lg) (pred (length (cons_ORlist lf lg)))). - + elim (RList_P6 (cons_ORlist lf lg)); intros; apply H21. - * apply RList_P2; assumption. - * apply Nat.lt_succ_r; apply -> Nat.succ_lt_mono; assumption. - * apply Nat.lt_pred_l; red; intro; rewrite H23 in H8; - elim (Nat.nlt_0_r _ H8). - + right; apply RList_P16; try assumption; rewrite H0; assumption. } - symmetry; apply Nat.lt_succ_pred with 0%nat; apply Nat.neq_0_lt_0; red; intro; - rewrite H19 in H18; elim (Nat.nlt_0_r _ H18). } - assert (H18 := H16 H17); unfold constant_D_eq, open_interval in H18; - rewrite (H18 x1). - { reflexivity. } - elim H15; clear H15; intros; elim H14; clear H14; intros; unfold I in H14; - elim H14; clear H14; intros; split. - { apply Rle_lt_trans with (pos_Rl (cons_ORlist lf lg) i); assumption. } - apply Rlt_le_trans with (pos_Rl (cons_ORlist lf lg) (S i)). - { assumption. } - assert (H22 : (S x0 < length lf)%nat) by lia. - elim (Rle_dec (pos_Rl lf (S x0)) (pos_Rl (cons_ORlist lf lg) i)); intro a0. - * assert (H23 : (S x0 <= x0)%nat). - { apply H20; unfold I; split; assumption. } - elim (Nat.nle_succ_diag_l _ H23). - * assert (H23 : pos_Rl (cons_ORlist lf lg) i < pos_Rl lf (S x0)) by auto with real. - clear a0; apply RList_P17; try assumption. - { apply RList_P2; assumption. } - elim (RList_P9 lf lg (pos_Rl lf (S x0))); intros; apply H25; left; - elim (RList_P3 lf (pos_Rl lf (S x0))); intros; apply H27; - exists (S x0); split; [ reflexivity | apply H22 ]. -Qed. - -Lemma StepFun_P23 : - forall (a b:R) (f g:R -> R) (lf lg:list R), - is_subdivision f a b lf -> - is_subdivision g a b lg -> is_subdivision f a b (cons_ORlist lf lg). -Proof. - intros; case (Rle_dec a b); intro; - [ apply StepFun_P22 with g; assumption - | apply StepFun_P5; apply StepFun_P22 with g; - [ auto with real - | apply StepFun_P5; assumption - | apply StepFun_P5; assumption ] ]. -Qed. - -Lemma StepFun_P24 : - forall (a b:R) (f g:R -> R) (lf lg:list R), - a <= b -> - is_subdivision f a b lf -> - is_subdivision g a b lg -> is_subdivision g a b (cons_ORlist lf lg). -Proof. - unfold is_subdivision; intros a b f g lf lg Hyp X X0; elim X; elim X0; - clear X X0; intros lg0 p lf0 p0; assert (Hyp_min : Rmin a b = a). - { unfold Rmin; decide (Rle_dec a b) with Hyp; reflexivity. } - assert (Hyp_max : Rmax a b = b). - { unfold Rmax; decide (Rle_dec a b) with Hyp; reflexivity. } - apply existT with (FF (cons_ORlist lf lg) g); unfold adapted_couple in p, p0; - decompose [and] p; decompose [and] p0; clear p p0; - rewrite Hyp_min in H1; rewrite Hyp_min in H6; rewrite Hyp_max in H0; - rewrite Hyp_max in H5; unfold adapted_couple; - repeat split. - - apply RList_P2; assumption. - - rewrite Hyp_min; symmetry ; apply Rle_antisym. - { induction lf as [| r lf Hreclf]. - { simpl; right; symmetry ; assumption. } - assert - (H10 : - In (pos_Rl (cons_ORlist (cons r lf) lg) 0) (cons_ORlist (cons r lf) lg)). - { elim - (RList_P3 (cons_ORlist (cons r lf) lg) - (pos_Rl (cons_ORlist (cons r lf) lg) 0)); intros _ H10; - apply H10; exists 0%nat; split; - [ reflexivity | rewrite RList_P11; simpl; apply Nat.lt_0_succ ]. } - elim (RList_P9 (cons r lf) lg (pos_Rl (cons_ORlist (cons r lf) lg) 0)); - intros H12 _; assert (H13 := H12 H10); elim H13; intro. - { elim (RList_P3 (cons r lf) (pos_Rl (cons_ORlist (cons r lf) lg) 0)); - intros H11 _; assert (H14 := H11 H8); elim H14; intros; - elim H15; clear H15; intros; rewrite H15; rewrite <- H6; - elim (RList_P6 (cons r lf)); intros; apply H17; - [ assumption | apply Nat.le_0_l | assumption ]. } - elim (RList_P3 lg (pos_Rl (cons_ORlist (cons r lf) lg) 0)); intros H11 _; - assert (H14 := H11 H8); elim H14; intros; elim H15; - clear H15; intros; rewrite H15; rewrite <- H1; elim (RList_P6 lg); - intros; apply H17; [ assumption | apply Nat.le_0_l | assumption ]. } - induction lf as [| r lf Hreclf]. - { simpl; right; assumption. } - assert (H8 : In a (cons_ORlist (cons r lf) lg)). - { elim (RList_P9 (cons r lf) lg a); intros; apply H10; left; - elim (RList_P3 (cons r lf) a); intros; apply H12; - exists 0%nat; split; - [ symmetry ; assumption | simpl; apply Nat.lt_0_succ ]. } - apply RList_P5; [ apply RList_P2; assumption | assumption ]. - - rewrite Hyp_max; apply Rle_antisym. - 2:{ induction lf as [| r lf Hreclf]. - { simpl; right; symmetry ; assumption. } - assert (H8 : In b (cons_ORlist (cons r lf) lg)). - { elim (RList_P9 (cons r lf) lg b); intros; apply H10; left; - elim (RList_P3 (cons r lf) b); intros; apply H12; - exists (pred (length (cons r lf))); split; - [ symmetry ; assumption | simpl; apply Nat.lt_succ_diag_r ]. } - apply RList_P7; [ apply RList_P2; assumption | assumption ]. } - induction lf as [| r lf Hreclf]. - { simpl; right; assumption. } - assert - (H8 : - In - (pos_Rl (cons_ORlist (cons r lf) lg) - (pred (length (cons_ORlist (cons r lf) lg)))) - (cons_ORlist (cons r lf) lg)). - { elim - (RList_P3 (cons_ORlist (cons r lf) lg) - (pos_Rl (cons_ORlist (cons r lf) lg) - (pred (length (cons_ORlist (cons r lf) lg))))); - intros _ H10; apply H10; - exists (pred (length (cons_ORlist (cons r lf) lg))); - split; [ reflexivity | rewrite RList_P11; simpl; apply Nat.lt_succ_diag_r ]. } - elim - (RList_P9 (cons r lf) lg - (pos_Rl (cons_ORlist (cons r lf) lg) - (pred (length (cons_ORlist (cons r lf) lg))))); - intros H10 _; assert (H11 := H10 H8); elim H11; intro. - { elim - (RList_P3 (cons r lf) - (pos_Rl (cons_ORlist (cons r lf) lg) - (pred (length (cons_ORlist (cons r lf) lg))))); - intros H13 _; assert (H14 := H13 H12); elim H14; intros; - elim H15; clear H15; intros; rewrite H15; rewrite <- H5; - elim (RList_P6 (cons r lf)); intros; apply H17; - [ assumption - | simpl; simpl in H14; apply Nat.lt_succ_r; assumption - | simpl; apply Nat.lt_succ_diag_r ]. } - elim - (RList_P3 lg - (pos_Rl (cons_ORlist (cons r lf) lg) - (pred (length (cons_ORlist (cons r lf) lg))))); - intros H13 _; assert (H14 := H13 H12); elim H14; intros; - elim H15; clear H15; intros; rewrite H15; - assert (H17 : length lg = S (pred (length lg))). - { symmetry; apply Nat.lt_succ_pred with 0%nat; apply Nat.neq_0_lt_0; red; intro; - rewrite H17 in H16; elim (Nat.nlt_0_r _ H16). } - rewrite <- H0; elim (RList_P6 lg); intros; apply H18; - [ assumption - | rewrite H17 in H16; apply Nat.lt_succ_r; assumption - | apply Nat.lt_pred_l; rewrite H17; intros Heq; discriminate ]. - - apply StepFun_P20; rewrite RList_P11; rewrite H7; rewrite H2; simpl; - apply Nat.lt_0_succ. - - unfold constant_D_eq, open_interval; intros; - cut - (exists l : R, - constant_D_eq g - (open_interval (pos_Rl (cons_ORlist lf lg) i) - (pos_Rl (cons_ORlist lf lg) (S i))) l). - { intros; elim H11; clear H11; intros; assert (H12 := H11); - assert - (Hyp_cons : - exists r : R, (exists r0 : list R, cons_ORlist lf lg = cons r r0)). - { apply RList_P19; red; intro; rewrite H13 in H8; elim (Nat.nlt_0_r _ H8). } - elim Hyp_cons; clear Hyp_cons; intros r [r0 Hyp_cons]; rewrite Hyp_cons; - unfold FF; rewrite RList_P12. - 2:{ rewrite RList_P14; rewrite Hyp_cons in H8; simpl in H8; apply H8. } - change (g x = g (pos_Rl (mid_Rlist (cons r r0) r) (S i))); - rewrite <- Hyp_cons; rewrite RList_P13. - 2:{ apply H8. } - assert (H13 := RList_P2 _ _ H _ H8); elim H13; intro. - 2:{ elim H10; intros; rewrite H14 in H15; - elim (Rlt_irrefl _ (Rlt_trans _ _ _ H16 H15)). } - unfold constant_D_eq, open_interval in H11, H12; rewrite (H11 x H10); - rewrite H11. - { reflexivity. } - lra. } - assert (H11 : a < b). - { apply Rle_lt_trans with (pos_Rl (cons_ORlist lf lg) i). - { rewrite <- H6; rewrite <- (RList_P15 lf lg); try assumption. - { elim (RList_P6 (cons_ORlist lf lg)); intros; apply H11. - { apply RList_P2; assumption. } - { apply Nat.le_0_l. } - apply Nat.lt_trans with (pred (length (cons_ORlist lf lg))); - [ assumption - | apply Nat.lt_pred_l; red; intro; - rewrite H13 in H8; elim (Nat.nlt_0_r _ H8) ]. } - rewrite H1; assumption. } - apply Rlt_le_trans with (pos_Rl (cons_ORlist lf lg) (S i)). - { elim H10; intros; apply Rlt_trans with x; assumption. } - rewrite <- H5; rewrite <- (RList_P16 lf lg); try assumption. - { elim (RList_P6 (cons_ORlist lf lg)); intros; apply H11. - { apply RList_P2; assumption. } - { apply Nat.lt_succ_r; apply -> Nat.succ_lt_mono; assumption. } - apply Nat.lt_pred_l; red; intro; rewrite H13 in H8; - elim (Nat.nlt_0_r _ H8). } - rewrite H0; assumption. } - set - (I := - fun j:nat => - pos_Rl lg j <= pos_Rl (cons_ORlist lf lg) i /\ (j < length lg)%nat); - assert (H12 : Nbound I). - { unfold Nbound; exists (length lg); intros; unfold I in H12; elim H12; - intros; apply Nat.lt_le_incl; assumption. } - assert (H13 : exists n : nat, I n). - { exists 0%nat; unfold I; split. - { apply Rle_trans with (pos_Rl (cons_ORlist lf lg) 0). - { right; symmetry ; rewrite H1; rewrite <- H6; apply RList_P15; - try assumption; rewrite H1; assumption. } - elim (RList_P6 (cons_ORlist lf lg)); intros; apply H13; - [ apply RList_P2; assumption - | apply Nat.le_0_l - | apply Nat.lt_trans with (pred (length (cons_ORlist lf lg))); - [ assumption - | apply Nat.lt_pred_l; red; intro; - rewrite H15 in H8; elim (Nat.nlt_0_r _ H8) ] ]. } - apply Nat.neq_0_lt_0; red; intro; rewrite H13 in H0; - rewrite <- H1 in H11; rewrite <- H0 in H11; elim (Rlt_irrefl _ H11). } - assert (H14 := Nzorn H13 H12); elim H14; clear H14; intros x0 H14; - exists (pos_Rl lg0 x0); unfold constant_D_eq, open_interval; - intros; assert (H16 := H4 x0); assert (H17 : (x0 < pred (length lg))%nat). - { elim H14; clear H14; intros; unfold I in H14; elim H14; clear H14; intros; - apply Nat.succ_lt_mono; replace (S (pred (length lg))) with (length lg). - { inversion H18. - 2: apply -> Nat.succ_lt_mono; assumption. - cut (x0 = pred (length lg)). - { intro; rewrite H19 in H14; rewrite H0 in H14; - cut (pos_Rl (cons_ORlist lf lg) i < b). - { intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H14 H21)). } - apply Rlt_le_trans with (pos_Rl (cons_ORlist lf lg) (S i)). - { elim H10; intros; apply Rlt_trans with x; assumption. } - rewrite <- H0; - apply Rle_trans with - (pos_Rl (cons_ORlist lf lg) (pred (length (cons_ORlist lf lg)))). - { elim (RList_P6 (cons_ORlist lf lg)); intros; apply H21. - { apply RList_P2; assumption. } - { apply Nat.lt_succ_r; apply -> Nat.succ_lt_mono; assumption. } - apply Nat.lt_pred_l; red; intro; rewrite H23 in H8; - elim (Nat.nlt_0_r _ H8). } - right; rewrite H0; rewrite <- H5; apply RList_P16; try assumption. - rewrite H0; assumption. } - rewrite <- H20; reflexivity. } - symmetry; apply Nat.lt_succ_pred with 0%nat; apply Nat.neq_0_lt_0; red; intro; - rewrite H19 in H18; elim (Nat.nlt_0_r _ H18). } - assert (H18 := H16 H17); unfold constant_D_eq, open_interval in H18; - rewrite (H18 x1). - { reflexivity. } - elim H15; clear H15; intros; elim H14; clear H14; intros; unfold I in H14; - elim H14; clear H14; intros; split. - { apply Rle_lt_trans with (pos_Rl (cons_ORlist lf lg) i); assumption. } - apply Rlt_le_trans with (pos_Rl (cons_ORlist lf lg) (S i)); try assumption. - assert (H22 : (S x0 < length lg)%nat). - { replace (length lg) with (S (pred (length lg))). - { apply -> Nat.succ_lt_mono; assumption. } - apply Nat.lt_succ_pred with 0%nat; apply Nat.neq_0_lt_0; red; - intro; rewrite H22 in H21; elim (Nat.nlt_0_r _ H21). } - elim (Rle_dec (pos_Rl lg (S x0)) (pos_Rl (cons_ORlist lf lg) i)); intro a0. - { assert (H23 : (S x0 <= x0)%nat); - [ apply H20; unfold I; split; assumption | elim (Nat.nle_succ_diag_l _ H23) ]. } - assert (H23 : pos_Rl (cons_ORlist lf lg) i < pos_Rl lg (S x0)) by auto with real. - clear a0; apply RList_P17; try assumption; - [ apply RList_P2; assumption - | elim (RList_P9 lf lg (pos_Rl lg (S x0))); intros; apply H25; right; - elim (RList_P3 lg (pos_Rl lg (S x0))); intros; - apply H27; exists (S x0); split; [ reflexivity | apply H22 ] ]. -Qed. - -Lemma StepFun_P25 : - forall (a b:R) (f g:R -> R) (lf lg:list R), - is_subdivision f a b lf -> - is_subdivision g a b lg -> is_subdivision g a b (cons_ORlist lf lg). -Proof. - intros a b f g lf lg H H0; case (Rle_dec a b); intro; - [ apply StepFun_P24 with f; assumption - | apply StepFun_P5; apply StepFun_P24 with f; - [ auto with real - | apply StepFun_P5; assumption - | apply StepFun_P5; assumption ] ]. -Qed. - -Lemma StepFun_P26 : - forall (a b l:R) (f g:R -> R) (l1:list R), - is_subdivision f a b l1 -> - is_subdivision g a b l1 -> - is_subdivision (fun x:R => f x + l * g x) a b l1. -Proof. - intros a b l f g l1 (x0,(H0,(H1,(H2,(H3,H4))))) - (x,(_,(_,(_,(_,H9))))). - exists (FF l1 (fun x:R => f x + l * g x)); repeat split. - 1,2,3:assumption. - - apply StepFun_P20; rewrite H3; auto with arith. - - intros i H8 x1 H10; unfold open_interval in H10, H9, H4; - rewrite (H9 _ H8 _ H10); rewrite (H4 _ H8 _ H10); - assert (H11 : l1 <> nil). - { red; intro H11; rewrite H11 in H8; elim (Nat.nlt_0_r _ H8). } - destruct (RList_P19 _ H11) as (r,(r0,H12)); - rewrite H12; unfold FF; - change - (pos_Rl x0 i + l * pos_Rl x i = - pos_Rl - (map (fun x2:R => f x2 + l * g x2) (mid_Rlist (cons r r0) r)) - (S i)); rewrite RList_P12. - { rewrite RList_P13. - { rewrite <- H12; rewrite (H9 _ H8); try rewrite (H4 _ H8); lra. } - rewrite <- H12; assumption. } - rewrite RList_P14; simpl; rewrite H12 in H8; simpl in H8; - apply -> Nat.succ_lt_mono; apply H8. -Qed. - -Lemma StepFun_P27 : - forall (a b l:R) (f g:R -> R) (lf lg:list R), - is_subdivision f a b lf -> - is_subdivision g a b lg -> - is_subdivision (fun x:R => f x + l * g x) a b (cons_ORlist lf lg). -Proof. - intros a b l f g lf lg H H0; apply StepFun_P26; - [ apply StepFun_P23 with g; assumption - | apply StepFun_P25 with f; assumption ]. -Qed. - -(** The set of step functions on [a,b] is a vectorial space *) -Lemma StepFun_P28 : - forall (a b l:R) (f g:StepFun a b), IsStepFun (fun x:R => f x + l * g x) a b. -Proof. - intros a b l f g; unfold IsStepFun; assert (H := pre f); - assert (H0 := pre g); unfold IsStepFun in H, H0; elim H; - elim H0; intros; apply existT with (cons_ORlist x0 x); - apply StepFun_P27; assumption. -Qed. - -Lemma StepFun_P29 : - forall (a b:R) (f:StepFun a b), is_subdivision f a b (subdivision f). -Proof. - intros a b f; unfold is_subdivision; - apply existT with (subdivision_val f); apply StepFun_P1. -Qed. - -Lemma StepFun_P30 : - forall (a b l:R) (f g:StepFun a b), - RiemannInt_SF (mkStepFun (StepFun_P28 l f g)) = - RiemannInt_SF f + l * RiemannInt_SF g. -Proof. - intros a b l f g; unfold RiemannInt_SF; case (Rle_dec a b); - (intro; - replace - (Int_SF (subdivision_val (mkStepFun (StepFun_P28 l f g))) - (subdivision (mkStepFun (StepFun_P28 l f g)))) with - (Int_SF - (FF (cons_ORlist (subdivision f) (subdivision g)) - (fun x:R => f x + l * g x)) - (cons_ORlist (subdivision f) (subdivision g))); - [ rewrite StepFun_P19; - replace - (Int_SF (FF (cons_ORlist (subdivision f) (subdivision g)) f) - (cons_ORlist (subdivision f) (subdivision g))) with - (Int_SF (subdivision_val f) (subdivision f)); - [ replace - (Int_SF (FF (cons_ORlist (subdivision f) (subdivision g)) g) - (cons_ORlist (subdivision f) (subdivision g))) with - (Int_SF (subdivision_val g) (subdivision g)); - [ ring - | apply StepFun_P17 with (fe g) a b; - [ apply StepFun_P1 - | apply StepFun_P21; apply StepFun_P25 with (fe f); - apply StepFun_P29 ] ] - | apply StepFun_P17 with (fe f) a b; - [ apply StepFun_P1 - | apply StepFun_P21; apply StepFun_P23 with (fe g); - apply StepFun_P29 ] ] - | apply StepFun_P17 with (fun x:R => f x + l * g x) a b; - [ apply StepFun_P21; apply StepFun_P27; apply StepFun_P29 - | apply (StepFun_P1 (mkStepFun (StepFun_P28 l f g))) ] ]). -Qed. - -Lemma StepFun_P31 : - forall (a b:R) (f:R -> R) (l lf:list R), - adapted_couple f a b l lf -> - adapted_couple (fun x:R => Rabs (f x)) a b l (map Rabs lf). -Proof. - unfold adapted_couple; intros; decompose [and] H; clear H; - repeat split; try assumption. - - symmetry ; rewrite H3; rewrite RList_P18; reflexivity. - - intros; unfold constant_D_eq, open_interval; - unfold constant_D_eq, open_interval in H5; intros; - rewrite (H5 _ H _ H4); rewrite RList_P12; - [ reflexivity | rewrite H3 in H; simpl in H; apply H ]. -Qed. - -Lemma StepFun_P32 : - forall (a b:R) (f:StepFun a b), IsStepFun (fun x:R => Rabs (f x)) a b. -Proof. - intros a b f; unfold IsStepFun; apply existT with (subdivision f); - unfold is_subdivision; - apply existT with (map Rabs (subdivision_val f)); - apply StepFun_P31; apply StepFun_P1. -Qed. - -Lemma StepFun_P33 : - forall l2 l1:list R, - ordered_Rlist l1 -> Rabs (Int_SF l2 l1) <= Int_SF (map Rabs l2) l1. -Proof. - induction l2 as [ | r r0 H]; intros. - - simpl; rewrite Rabs_R0; right; reflexivity. - - simpl; induction l1 as [| r1 l1 Hrecl1]. - + rewrite Rabs_R0; right; reflexivity. - + induction l1 as [| r2 l1 Hrecl0]. - * rewrite Rabs_R0; right; reflexivity. - * apply Rle_trans with (Rabs (r * (r2 - r1)) + Rabs (Int_SF r0 (cons r2 l1))). - -- apply Rabs_triang. - -- rewrite Rabs_mult; rewrite (Rabs_right (r2 - r1)); - [ apply Rplus_le_compat_l; apply H; apply RList_P4 with r1; assumption - | apply Rge_minus; apply Rle_ge; apply (H0 0%nat); simpl; - apply Nat.lt_0_succ ]. -Qed. - -Lemma StepFun_P34 : - forall (a b:R) (f:StepFun a b), - a <= b -> - Rabs (RiemannInt_SF f) <= RiemannInt_SF (mkStepFun (StepFun_P32 f)). -Proof. - intros; unfold RiemannInt_SF; decide (Rle_dec a b) with H. - replace - (Int_SF (subdivision_val (mkStepFun (StepFun_P32 f))) - (subdivision (mkStepFun (StepFun_P32 f)))) with - (Int_SF (map Rabs (subdivision_val f)) (subdivision f)). - - apply StepFun_P33; assert (H0 := StepFun_P29 f); unfold is_subdivision in H0; - elim H0; intros; unfold adapted_couple in p; decompose [and] p; - assumption. - - apply StepFun_P17 with (fun x:R => Rabs (f x)) a b; - [ apply StepFun_P31; apply StepFun_P1 - | apply (StepFun_P1 (mkStepFun (StepFun_P32 f))) ]. -Qed. - -Lemma StepFun_P35 : - forall (l:list R) (a b:R) (f g:R -> R), - ordered_Rlist l -> - pos_Rl l 0 = a -> - pos_Rl l (pred (length l)) = b -> - (forall x:R, a < x < b -> f x <= g x) -> - Int_SF (FF l f) l <= Int_SF (FF l g) l. -Proof. - induction l as [ | r r0 H]; intros. - { right; reflexivity. } - simpl; induction r0 as [| r0 r1 Hrecr0]. - { right; reflexivity. } - simpl; apply Rplus_le_compat. - 2:{ simpl in H; apply H with r0 b. - - apply RList_P4 with r; assumption. - - reflexivity. - - rewrite <- H2; reflexivity. - - intros; apply H3; elim H4; intros; split; try assumption. - apply Rle_lt_trans with r0; try assumption. - rewrite <- H1. - simpl; apply (H0 0%nat); simpl; apply Nat.lt_0_succ. } - case (Req_dec r r0); intro. - { rewrite H4; right; ring. } - do 2 rewrite <- (Rmult_comm (r0 - r)); apply Rmult_le_compat_l. - { apply Rge_le; apply Rge_minus; apply Rle_ge; apply (H0 0%nat); simpl; - apply Nat.lt_0_succ. } - apply H3; split. - { apply Rmult_lt_reg_l with 2. - { prove_sup0. } - unfold Rdiv; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc; - rewrite Rinv_r. - 2:discrR. - simpl in H1. - assert (H6 := H0 0%nat (Nat.lt_0_succ _)). - simpl in H6. - lra. } - apply Rmult_lt_reg_l with 2. - { prove_sup0. } - unfold Rdiv; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc; - rewrite Rinv_r. - 2:discrR. - rewrite Rmult_1_l; rewrite <-Rplus_diag; assert (H5 : r0 <= b). - { replace b with - (pos_Rl (cons r (cons r0 r1)) (pred (length (cons r (cons r0 r1))))). - replace r0 with (pos_Rl (cons r (cons r0 r1)) 1). - { elim (RList_P6 (cons r (cons r0 r1))); intros; apply H5. - { assumption. } - { simpl; lia. } - simpl; apply Nat.lt_succ_diag_r. } - reflexivity. } - apply Rle_lt_trans with (r + b). - { apply Rplus_le_compat_l; assumption. } - rewrite (Rplus_comm r); apply Rplus_lt_compat_l. - apply Rlt_le_trans with r0. - { assert (H6 := H0 0%nat (Nat.lt_0_succ _)). - simpl in H6. lra. } - assumption. -Qed. - -Lemma StepFun_P36 : - forall (a b:R) (f g:StepFun a b) (l:list R), - a <= b -> - is_subdivision f a b l -> - is_subdivision g a b l -> - (forall x:R, a < x < b -> f x <= g x) -> - RiemannInt_SF f <= RiemannInt_SF g. -Proof. - intros; unfold RiemannInt_SF; decide (Rle_dec a b) with H. - replace (Int_SF (subdivision_val f) (subdivision f)) with (Int_SF (FF l f) l). - - replace (Int_SF (subdivision_val g) (subdivision g)) with (Int_SF (FF l g) l). - + unfold is_subdivision in X; elim X; clear X; intros; - unfold adapted_couple in p; decompose [and] p; clear p; - assert (H5 : Rmin a b = a); - [ unfold Rmin; decide (Rle_dec a b) with H; reflexivity - | assert (H7 : Rmax a b = b); - [ unfold Rmax; decide (Rle_dec a b) with H; reflexivity - | rewrite H5 in H3; rewrite H7 in H2; eapply StepFun_P35 with a b; - assumption ] ]. - + apply StepFun_P17 with (fe g) a b; - [ apply StepFun_P21; assumption | apply StepFun_P1 ]. - - apply StepFun_P17 with (fe f) a b; - [ apply StepFun_P21; assumption | apply StepFun_P1 ]. -Qed. - -Lemma StepFun_P37 : - forall (a b:R) (f g:StepFun a b), - a <= b -> - (forall x:R, a < x < b -> f x <= g x) -> - RiemannInt_SF f <= RiemannInt_SF g. -Proof. - intros; eapply StepFun_P36; try assumption. - - eapply StepFun_P25; apply StepFun_P29. - - eapply StepFun_P23; apply StepFun_P29. -Qed. - -Lemma StepFun_P38 : - forall (l:list R) (a b:R) (f:R -> R), - ordered_Rlist l -> - pos_Rl l 0 = a -> - pos_Rl l (pred (length l)) = b -> - { g:StepFun a b | - g b = f b /\ - (forall i:nat, - (i < pred (length l))%nat -> - constant_D_eq g (co_interval (pos_Rl l i) (pos_Rl l (S i))) - (f (pos_Rl l i))) }. -Proof. - intros l a b f; generalize a; clear a; induction l as [|r l IHl]. - { intros a H H0 H1; simpl in H0; simpl in H1; - exists (mkStepFun (StepFun_P4 a b (f b))); split. - { reflexivity. } - intros; elim (Nat.nlt_0_r _ H2). } - intros; destruct l as [| r1 l]. - { simpl in H1; simpl in H0; exists (mkStepFun (StepFun_P4 a b (f b))); split. - { reflexivity. } - intros i H2; elim (Nat.nlt_0_r _ H2). } - intros; assert (H2 : ordered_Rlist (cons r1 l)). - { apply RList_P4 with r; assumption. } - assert (H3 : pos_Rl (cons r1 l) 0 = r1). - { reflexivity. } - assert (H4 : pos_Rl (cons r1 l) (pred (length (cons r1 l))) = b). - { rewrite <- H1; reflexivity. } - elim (IHl r1 H2 H3 H4); intros g [H5 H6]. - set - (g' := - fun x:R => match Rle_dec r1 x with - | left _ => g x - | right _ => f a - end). - assert (H7 : r1 <= b). - { rewrite <- H4; apply RList_P7; [ assumption | left; reflexivity ]. } - assert (H8 : IsStepFun g' a b). { - unfold IsStepFun; assert (H8 := pre g); unfold IsStepFun in H8; - elim H8; intros lg H9; unfold is_subdivision in H9; - elim H9; clear H9; intros lg2 H9; split with (cons a lg); - unfold is_subdivision; split with (cons (f a) lg2); - unfold adapted_couple in H9; decompose [and] H9; clear H9; - unfold adapted_couple; repeat split. - - unfold ordered_Rlist; intros; simpl in H9; - induction i as [| i Hreci]. - { simpl; rewrite H12; replace (Rmin r1 b) with r1. - { simpl in H0; rewrite <- H0; apply (H 0%nat); simpl; apply Nat.lt_0_succ. } - unfold Rmin; decide (Rle_dec r1 b) with H7; reflexivity. } - apply (H10 i); apply Nat.succ_lt_mono. - replace (S (pred (length lg))) with (length lg). - { apply H9. } - symmetry; apply Nat.lt_succ_pred with 0%nat; apply Nat.neq_0_lt_0; intro; rewrite H14 in H9; - elim (Nat.nlt_0_r _ H9). - - simpl; assert (H14 : a <= b). - { rewrite <- H1; simpl in H0; rewrite <- H0; apply RList_P7; - [ assumption | left; reflexivity ]. } - unfold Rmin; decide (Rle_dec a b) with H14; reflexivity. - - assert (H14 : a <= b). - { rewrite <- H1; simpl in H0; rewrite <- H0; apply RList_P7; - [ assumption | left; reflexivity ]. } - replace (Rmax a b) with (Rmax r1 b). - { rewrite <- H11; induction lg as [| r0 lg Hreclg]. - { simpl in H13; discriminate. } - reflexivity. } - unfold Rmax; decide (Rle_dec a b) with H14; decide (Rle_dec r1 b) with H7; - reflexivity. - - simpl; rewrite H13; reflexivity. - - intros; simpl in H9; induction i as [| i Hreci]. - { unfold constant_D_eq, open_interval; simpl; intros; - assert (H16 : Rmin r1 b = r1). - { unfold Rmin; decide (Rle_dec r1 b) with H7; reflexivity. } - rewrite H16 in H12; rewrite H12 in H14; elim H14; clear H14; intros _ H14; - unfold g'; case (Rle_dec r1 x); intro r3. - { elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r3 H14)). } - reflexivity. } - change - (constant_D_eq g' (open_interval (pos_Rl lg i) (pos_Rl lg (S i))) - (pos_Rl lg2 i)); clear Hreci; assert (H16 := H15 i); - assert (H17 : (i < pred (length lg))%nat). - { apply Nat.succ_lt_mono. - replace (S (pred (length lg))) with (length lg). - { assumption. } - symmetry; apply Nat.lt_succ_pred with 0%nat; apply Nat.neq_0_lt_0; red; intro; - rewrite H14 in H9; elim (Nat.nlt_0_r _ H9). } - assert (H18 := H16 H17); unfold constant_D_eq, open_interval in H18; - unfold constant_D_eq, open_interval; intros; - assert (H19 := H18 _ H14); rewrite <- H19; unfold g'; - case (Rle_dec r1 x) as [|[]]. - { reflexivity. } - replace r1 with (Rmin r1 b). - { rewrite <- H12; elim H14; clear H14; intros H14 _; left; - apply Rle_lt_trans with (pos_Rl lg i); try assumption. - apply RList_P5. - { assumption. } - elim (RList_P3 lg (pos_Rl lg i)); intros; apply H21; exists i; split. - { reflexivity. } - apply Nat.lt_trans with (pred (length lg)); try assumption. - apply Nat.lt_pred_l; red; intro; rewrite H22 in H17; - elim (Nat.nlt_0_r _ H17). } - unfold Rmin; decide (Rle_dec r1 b) with H7; reflexivity. - } - exists (mkStepFun H8); split. - { simpl; unfold g'; decide (Rle_dec r1 b) with H7; assumption. } - intros; simpl in H9; induction i as [| i Hreci]. - { unfold constant_D_eq, co_interval; simpl; intros; simpl in H0; - rewrite H0; elim H10; clear H10; intros; unfold g'; - case (Rle_dec r1 x); intro r3. - { elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r3 H11)). } - reflexivity. } - clear Hreci; - change - (constant_D_eq (mkStepFun H8) - (co_interval (pos_Rl (cons r1 l) i) (pos_Rl (cons r1 l) (S i))) - (f (pos_Rl (cons r1 l) i))); assert (H10 := H6 i); - assert (H11 : (i < pred (length (cons r1 l)))%nat). - { simpl; apply Nat.succ_lt_mono; assumption. } - assert (H12 := H10 H11); unfold constant_D_eq, co_interval in H12; - unfold constant_D_eq, co_interval; intros; - rewrite <- (H12 _ H13); simpl; unfold g'; - case (Rle_dec r1 x) as [|[]]. - { reflexivity. } - elim H13; clear H13; intros; - apply Rle_trans with (pos_Rl (cons r1 l) i); try assumption; - change (pos_Rl (cons r1 l) 0 <= pos_Rl (cons r1 l) i); - elim (RList_P6 (cons r1 l)); intros; apply H15; - [ assumption - | apply Nat.le_0_l - | simpl; apply Nat.lt_trans with (length l); - [ apply Nat.succ_lt_mono; assumption | apply Nat.lt_succ_diag_r ] ]. -Qed. - -Lemma StepFun_P39 : - forall (a b:R) (f:StepFun a b), - RiemannInt_SF f = - RiemannInt_SF (mkStepFun (StepFun_P6 (pre f))). -Proof. - intros; unfold RiemannInt_SF; case (Rle_dec a b); case (Rle_dec b a); - intros. - - assert (H : adapted_couple f a b (subdivision f) (subdivision_val f)); - [ apply StepFun_P1 - | assert - (H0 : - adapted_couple (mkStepFun (StepFun_P6 (pre f))) b a - (subdivision (mkStepFun (StepFun_P6 (pre f)))) - (subdivision_val (mkStepFun (StepFun_P6 (pre f))))); - [ apply StepFun_P1 - | assert (H1 : a = b); - [ apply Rle_antisym; assumption - | rewrite (StepFun_P8 H H1); assert (H2 : b = a); - [ symmetry ; apply H1 | rewrite (StepFun_P8 H0 H2); ring ] ] ] ]. - - rewrite Ropp_involutive; eapply StepFun_P17; - [ apply StepFun_P1 - | apply StepFun_P2; set (H := StepFun_P6 (pre f)); unfold IsStepFun in H; - elim H; intros; unfold is_subdivision; - elim p; intros; apply p0 ]. - - apply Ropp_eq_compat; eapply StepFun_P17; - [ apply StepFun_P1 - | apply StepFun_P2; set (H := StepFun_P6 (pre f)); unfold IsStepFun in H; - elim H; intros; unfold is_subdivision; - elim p; intros; apply p0 ]. - - assert (H : a < b); - [ auto with real - | assert (H0 : b < a); - [ auto with real | elim (Rlt_irrefl _ (Rlt_trans _ _ _ H H0)) ] ]. -Qed. - -Lemma StepFun_P40 : - forall (f:R -> R) (a b c:R) (l1 l2 lf1 lf2:list R), - a < b -> - b < c -> - adapted_couple f a b l1 lf1 -> - adapted_couple f b c l2 lf2 -> - adapted_couple f a c (app l1 l2) (FF (app l1 l2) f). -Proof. - intros f a b c l1 l2 lf1 lf2 H H0 H1 H2; unfold adapted_couple in H1, H2; - unfold adapted_couple; decompose [and] H1; - decompose [and] H2; clear H1 H2; repeat split. - - apply RList_P25; try assumption. - rewrite H10; rewrite H4; unfold Rmin, Rmax; case (Rle_dec a b) as [|[]]; - case (Rle_dec b c) as [|[]]; - (right; reflexivity) || (left; assumption). - - rewrite RList_P22. - { rewrite H5; unfold Rmin, Rmax; case (Rle_dec a c) as [|[]]; case (Rle_dec a b) as [|[]]; - [ reflexivity - | left; assumption - | apply Rle_trans with b; left; assumption - | left; assumption ]. } - red; intro; rewrite H1 in H6; discriminate. - - rewrite RList_P24. - { rewrite H9; unfold Rmin, Rmax; case (Rle_dec a c) as [|[]]; case (Rle_dec b c) as [|[]]; - [ reflexivity - | left; assumption - | apply Rle_trans with b; left; assumption - | left; assumption ]. } - red; intro; rewrite H1 in H11; discriminate. - - apply StepFun_P20. - rewrite length_app; apply Nat.neq_0_lt_0; red; intro. - assert (List.length l1 = 0)%nat as H12 by now destruct (List.length l1); inversion H1. - rewrite H12 in H6; discriminate. - - unfold constant_D_eq, open_interval; intros; - elim (Nat.le_gt_cases (S (S i)) (length l1)); intro. - + assert (H14 : pos_Rl (app l1 l2) i = pos_Rl l1 i). - { apply RList_P26; apply Nat.succ_lt_mono; apply Nat.lt_succ_r; apply Nat.succ_le_mono; - apply Nat.le_trans with (length l1); [ assumption | apply Nat.le_succ_diag_r ]. } - assert (H15 : pos_Rl (app l1 l2) (S i) = pos_Rl l1 (S i)). - { apply RList_P26; apply Nat.succ_lt_mono; apply Nat.lt_succ_r; assumption. } - rewrite H14 in H2; rewrite H15 in H2; assert (H16 : (2 <= length l1)%nat). - { apply Nat.le_trans with (S (S i)); - [ repeat apply -> Nat.succ_le_mono; apply Nat.le_0_l | assumption ]. } - elim (RList_P20 _ H16); intros r1 [r2 [r3 H17]]; rewrite H17; - change - (f x = pos_Rl (map f (mid_Rlist (app (cons r2 r3) l2) r1)) i) - ; rewrite RList_P12. - { induction i as [| i Hreci]. - { simpl; assert (H18 := H8 0%nat); - unfold constant_D_eq, open_interval in H18; - assert (H19 : (0 < pred (length l1))%nat). - { rewrite H17; simpl; apply Nat.lt_0_succ. } - assert (H20 := H18 H19); repeat rewrite H20. - { reflexivity. } - { assert (H21 : r1 <= r2). - { rewrite H17 in H3; apply (H3 0%nat). - simpl; apply Nat.lt_0_succ. } - elim H21; intro. - { split. - { rewrite H17; simpl; apply Rmult_lt_reg_l with 2; - [ prove_sup0 - | unfold Rdiv; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc; - rewrite Rinv_r; - [ rewrite Rmult_1_l; rewrite <-Rplus_diag; apply Rplus_lt_compat_l; assumption - | discrR ] ]. } - rewrite H17; simpl; apply Rmult_lt_reg_l with 2; - [ prove_sup0 - | unfold Rdiv; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc; - rewrite Rinv_r; - [ rewrite Rmult_1_l; rewrite (Rplus_comm r1); rewrite <-Rplus_diag; - apply Rplus_lt_compat_l; assumption - | discrR ] ]. } - elim H2; intros; rewrite H17 in H23; rewrite H17 in H24; simpl in H24; - simpl in H23; rewrite H22 in H23; - elim (Rlt_irrefl _ (Rlt_trans _ _ _ H23 H24)). } - assumption. } - clear Hreci; rewrite RList_P13. - { rewrite H17 in H14; rewrite H17 in H15; - change - (pos_Rl (app (cons r2 r3) l2) i = - pos_Rl (cons r1 (cons r2 r3)) (S i)) in H14; rewrite H14; - change - (pos_Rl (app (cons r2 r3) l2) (S i) = - pos_Rl (cons r1 (cons r2 r3)) (S (S i))) in H15; - rewrite H15; assert (H18 := H8 (S i)); - unfold constant_D_eq, open_interval in H18; - assert (H19 : (S i < pred (length l1))%nat). - { apply -> Nat.lt_succ_lt_pred; apply Nat.succ_lt_mono; apply Nat.lt_succ_r; assumption. } - assert (H20 := H18 H19); repeat rewrite H20. - { reflexivity. } - { rewrite <- H17; assert (H21 : pos_Rl l1 (S i) <= pos_Rl l1 (S (S i))). - { apply (H3 (S i)); lia. } - elim H21; intro. - { split. - { apply Rmult_lt_reg_l with 2; - [ prove_sup0 - | unfold Rdiv; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc; - rewrite Rinv_r; - [ rewrite Rmult_1_l; rewrite <-Rplus_diag; apply Rplus_lt_compat_l; assumption - | discrR ] ]. } - apply Rmult_lt_reg_l with 2; - [ prove_sup0 - | unfold Rdiv; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc; - rewrite Rinv_r; - [ rewrite Rmult_1_l; rewrite (Rplus_comm (pos_Rl l1 (S i))); - rewrite <-Rplus_diag; apply Rplus_lt_compat_l; assumption - | discrR ] ]. } - elim H2; intros; rewrite H22 in H23; - elim (Rlt_irrefl _ (Rlt_trans _ _ _ H23 H24)). } - assumption. } - simpl; rewrite H17 in H1; simpl in H1; apply Nat.succ_lt_mono; assumption. } - rewrite RList_P14; rewrite H17 in H1; simpl in H1; apply H1. - + inversion H12. - { assert (H16 : pos_Rl (app l1 l2) (S i) = b). - { rewrite RList_P29. - { rewrite H15; rewrite Nat.sub_diag; rewrite H10; unfold Rmin; - case (Rle_dec b c) as [|[]]; [ reflexivity | left; assumption ]. } - { rewrite H15; apply le_n. } - induction l1 as [| r l1 Hrecl1]. - { simpl in H15; discriminate. } - clear Hrecl1; simpl in H1; simpl; apply -> Nat.succ_lt_mono; assumption. } - assert (H17 : pos_Rl (app l1 l2) i = b). - { rewrite RList_P26. - { replace i with (pred (length l1)); - [ rewrite H4; unfold Rmax; case (Rle_dec a b) as [|[]]; - [ reflexivity | left; assumption ] - | rewrite H15; reflexivity ]. } - rewrite H15; apply Nat.lt_succ_diag_r. } - rewrite H16 in H2; rewrite H17 in H2; elim H2; intros; - elim (Rlt_irrefl _ (Rlt_trans _ _ _ H14 H18)). } - assert (H16 : pos_Rl (app l1 l2) i = pos_Rl l2 (i - length l1)). - { apply RList_P29. - { apply Nat.succ_le_mono; assumption. } - apply Nat.lt_le_trans with (pred (length (app l1 l2))); - [ assumption | apply Nat.le_pred_l ]. } - assert - (H17 : pos_Rl (app l1 l2) (S i) = pos_Rl l2 (S (i - length l1))). - { replace (S (i - length l1)) with (S i - length l1)%nat. - { apply RList_P29. - { apply le_S_n; apply Nat.le_trans with (S i); [ assumption | apply Nat.le_succ_diag_r ]. } - induction l1 as [| r l1 Hrecl1]. - { simpl in H6; discriminate. } - clear Hrecl1; simpl in H1; simpl; apply -> Nat.succ_lt_mono; assumption. } - apply Nat.sub_succ_l, Nat.succ_le_mono; assumption. } - assert (H18 : (2 <= length l1)%nat). - { clear f c l2 lf2 H0 H3 H8 H7 H10 H9 H11 H13 i H1 x H2 H12 m H14 H15 H16 H17; - induction l1 as [| r l1 Hrecl1]. - { discriminate. } - clear Hrecl1; induction l1 as [| r0 l1 Hrecl1]. - { simpl in H5; simpl in H4; assert (H0 : Rmin a b < Rmax a b). - { unfold Rmin, Rmax; case (Rle_dec a b) as [|[]]; - [ assumption | left; assumption ]. } - rewrite <- H5 in H0; rewrite <- H4 in H0; elim (Rlt_irrefl _ H0). } - clear Hrecl1; simpl; repeat apply -> Nat.succ_le_mono; apply Nat.le_0_l. } - elim (RList_P20 _ H18); intros r1 [r2 [r3 H19]]; rewrite H19; - change - (f x = pos_Rl (map f (mid_Rlist (app (cons r2 r3) l2) r1)) i) - ; rewrite RList_P12. - 2:{ rewrite RList_P14; rewrite H19 in H1; simpl in H1; simpl; apply H1. } - induction i as [| i Hreci]. - { assert (H20 := le_S_n _ _ H15); assert (H21 := Nat.le_trans _ _ _ H18 H20); - elim (Nat.nle_succ_0 _ H21). } - clear Hreci; rewrite RList_P13. - 2:{ simpl; rewrite H19 in H1; simpl in H1; apply Nat.succ_lt_mono; assumption. } - rewrite H19 in H16; rewrite H19 in H17; - change - (pos_Rl (app (cons r2 r3) l2) i = - pos_Rl l2 (S i - length (cons r1 (cons r2 r3)))) - in H16; rewrite H16; - change - (pos_Rl (app (cons r2 r3) l2) (S i) = - pos_Rl l2 (S (S i - length (cons r1 (cons r2 r3))))) - in H17; rewrite H17; assert (H20 := H13 (S i - length l1)%nat); - unfold constant_D_eq, open_interval in H20; - assert (H21 : (S i - length l1 < pred (length l2))%nat). - { apply Nat.lt_succ_lt_pred; rewrite <- Nat.sub_succ_l. - { apply Nat.add_lt_mono_l with (length l1); rewrite Nat.add_comm, Nat.sub_add. - { rewrite H19 in H1; simpl in H1; rewrite H19; simpl; - rewrite length_app in H1; apply -> Nat.succ_lt_mono; assumption. } - apply Nat.le_trans with (S i); [ apply Nat.succ_le_mono; assumption | apply Nat.le_succ_diag_r ]. } - apply Nat.succ_le_mono; assumption. } - assert (H22 := H20 H21); repeat rewrite H22. - { reflexivity. } - { rewrite <- H19; - assert - (H23 : pos_Rl l2 (S i - length l1) <= pos_Rl l2 (S (S i - length l1))). - { apply H7; apply Nat.lt_succ_lt_pred. - rewrite <- Nat.sub_succ_l. - { apply Nat.add_lt_mono_l with (length l1); rewrite Nat.add_comm, Nat.sub_add. - { rewrite H19 in H1; simpl in H1; rewrite H19; simpl; - rewrite length_app in H1; apply -> Nat.succ_lt_mono; assumption. } - apply Nat.le_trans with (S i); [ apply Nat.succ_le_mono; assumption | apply Nat.le_succ_diag_r ]. } - apply Nat.succ_le_mono; assumption. } - elim H23; intro. - { split. - { apply Rmult_lt_reg_l with 2; - [ prove_sup0 - | unfold Rdiv; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc; - rewrite Rinv_r; - [ rewrite Rmult_1_l; rewrite <-Rplus_diag; apply Rplus_lt_compat_l; assumption - | discrR ] ]. } - apply Rmult_lt_reg_l with 2; - [ prove_sup0 - | unfold Rdiv; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc; - rewrite Rinv_r; - [ rewrite Rmult_1_l; rewrite (Rplus_comm (pos_Rl l2 (S i - length l1))); - rewrite <-Rplus_diag; apply Rplus_lt_compat_l; assumption - | discrR ] ]. } - rewrite <- H19 in H16; rewrite <- H19 in H17; elim H2; intros; - rewrite H19 in H25; rewrite H19 in H26; simpl in H25; - simpl in H16; rewrite H16 in H25; simpl in H26; simpl in H17; - rewrite H17 in H26; simpl in H24; rewrite H24 in H25; - elim (Rlt_irrefl _ (Rlt_trans _ _ _ H25 H26)). } - assert (H23 : pos_Rl (app l1 l2) (S i) = pos_Rl l2 (S i - length l1)). - { rewrite H19; simpl; simpl in H16; apply H16. } - assert - (H24 : - pos_Rl (app l1 l2) (S (S i)) = pos_Rl l2 (S (S i - length l1))). - { rewrite H19; simpl; simpl in H17; apply H17. } - rewrite <- H23; rewrite <- H24; assumption. -Qed. - -Lemma StepFun_P41 : - forall (f:R -> R) (a b c:R), - a <= b -> b <= c -> IsStepFun f a b -> IsStepFun f b c -> IsStepFun f a c. -Proof. - intros f a b c H H0 (l1,(lf1,H1)) (l2,(lf2,H2)); - destruct (total_order_T a b) as [[Hltab|Hab]|Hgtab]. - - destruct (total_order_T b c) as [[Hltbc|Hbc]|Hgtbc]. - + exists (app l1 l2); exists (FF (app l1 l2) f); - apply StepFun_P40 with b lf1 lf2; assumption. - + exists l1; exists lf1; rewrite Hbc in H1; assumption. - + elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H0 Hgtbc)). - - exists l2; exists lf2; rewrite <- Hab in H2; assumption. - - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H Hgtab)). -Qed. - -Lemma StepFun_P42 : - forall (l1 l2:list R) (f:R -> R), - pos_Rl l1 (pred (length l1)) = pos_Rl l2 0 -> - Int_SF (FF (app l1 l2) f) (app l1 l2) = - Int_SF (FF l1 f) l1 + Int_SF (FF l2 f) l2. -Proof. - intros l1 l2 f; induction l1 as [| r l1 IHl1]; intros H; - [ simpl; ring - | destruct l1 as [| r0 r1]; - [ simpl in H; simpl; destruct l2 as [| r0 r1]; - [ simpl; ring | simpl; simpl in H; rewrite H; ring ] - | simpl; rewrite Rplus_assoc; apply Rplus_eq_compat_l; apply IHl1; - rewrite <- H; reflexivity ] ]. -Qed. - -Lemma StepFun_P43 : - forall (f:R -> R) (a b c:R) (pr1:IsStepFun f a b) - (pr2:IsStepFun f b c) (pr3:IsStepFun f a c), - RiemannInt_SF (mkStepFun pr1) + RiemannInt_SF (mkStepFun pr2) = - RiemannInt_SF (mkStepFun pr3). -Proof. - intros f; intros. - pose proof pr1 as (l1,(lf1,H1)). - pose proof pr2 as (l2,(lf2,H2)). - pose proof pr3 as (l3,(lf3,H3)). - replace (RiemannInt_SF (mkStepFun pr1)) with - match Rle_dec a b with - | left _ => Int_SF lf1 l1 - | right _ => - Int_SF lf1 l1 - end. - 1:replace (RiemannInt_SF (mkStepFun pr2)) with - match Rle_dec b c with - | left _ => Int_SF lf2 l2 - | right _ => - Int_SF lf2 l2 - end. - 1:replace (RiemannInt_SF (mkStepFun pr3)) with - match Rle_dec a c with - | left _ => Int_SF lf3 l3 - | right _ => - Int_SF lf3 l3 - end. - 2,3,4:unfold RiemannInt_SF; case (Rle_dec _ _); intro;[|apply Ropp_eq_compat]; - (eapply StepFun_P17;[|apply StepFun_P1]);assumption. - case (Rle_dec a b) as [Hle|Hnle]; case (Rle_dec b c) as [Hle'|Hnle']; case (Rle_dec a c) as [Hle''|Hnle'']. - - elim Hle; intro. - 1:elim Hle'; intro. - + replace (Int_SF lf3 l3) with - (Int_SF (FF (app l1 l2) f) (app l1 l2)). - 2:{ eapply StepFun_P17; [ apply (StepFun_P40 H H0 H1 H2) | apply H3 ]. } - replace (Int_SF lf1 l1) with (Int_SF (FF l1 f) l1). - { replace (Int_SF lf2 l2) with (Int_SF (FF l2 f) l2). - { symmetry ; apply StepFun_P42. - unfold adapted_couple in H1, H2; decompose [and] H1; decompose [and] H2; - clear H1 H2; rewrite H11; rewrite H5; unfold Rmax, Rmin; - decide (Rle_dec a b) with Hle; decide (Rle_dec b c) with Hle'; reflexivity. } - eapply StepFun_P17; - [ apply StepFun_P21; unfold is_subdivision; split with lf2; apply H2; - assumption - | assumption ]. } - eapply StepFun_P17; - [ apply StepFun_P21; unfold is_subdivision; split with lf1; apply H1 - | assumption ]. - + replace (Int_SF lf2 l2) with 0. - { rewrite Rplus_0_r; eapply StepFun_P17; - [ apply H1 | rewrite <- H0 in H3; apply H3 ]. } - symmetry ; eapply StepFun_P8; [ apply H2 | assumption ]. - + replace (Int_SF lf1 l1) with 0. - { rewrite Rplus_0_l; eapply StepFun_P17; - [ apply H2 | rewrite H in H3; apply H3 ]. } - symmetry ; eapply StepFun_P8; [ apply H1 | assumption ]. - - elim Hnle''; apply Rle_trans with b; assumption. - - apply Rplus_eq_reg_l with (Int_SF lf2 l2); - replace (Int_SF lf2 l2 + (Int_SF lf1 l1 + - Int_SF lf2 l2)) with - (Int_SF lf1 l1); [ idtac | ring ]. - assert (H : c < b). - { auto with real. } - elim Hle''; intro. - { rewrite Rplus_comm; - replace (Int_SF lf1 l1) with - (Int_SF (FF (app l3 l2) f) (app l3 l2)). - { replace (Int_SF lf3 l3) with (Int_SF (FF l3 f) l3). - { replace (Int_SF lf2 l2) with (Int_SF (FF l2 f) l2). - { apply StepFun_P42. - unfold adapted_couple in H2, H3; decompose [and] H2; decompose [and] H3; - clear H3 H2; rewrite H10; rewrite H6; unfold Rmax, Rmin. - decide (Rle_dec a c) with Hle''; decide (Rle_dec b c) with Hnle'; - reflexivity. } - eapply StepFun_P17; - [ apply StepFun_P21; unfold is_subdivision; split with lf2; apply H2 - | assumption ]. } - eapply StepFun_P17; - [ apply StepFun_P21; unfold is_subdivision; split with lf3; apply H3 - | assumption ]. } - eapply StepFun_P17; - [ apply (StepFun_P40 H0 H H3 (StepFun_P2 H2)) | apply H1 ]. } - replace (Int_SF lf3 l3) with 0. - { rewrite Rplus_0_r; eapply StepFun_P17; - [ apply H1 | apply StepFun_P2; rewrite <- H0 in H2; apply H2 ]. } - symmetry ; eapply StepFun_P8; [ apply H3 | assumption ]. - - replace (Int_SF lf2 l2) with (Int_SF lf3 l3 + Int_SF lf1 l1). - { ring. } - elim Hle; intro. - { replace (Int_SF lf2 l2) with - (Int_SF (FF (app l3 l1) f) (app l3 l1)). - { replace (Int_SF lf3 l3) with (Int_SF (FF l3 f) l3). - { replace (Int_SF lf1 l1) with (Int_SF (FF l1 f) l1). - { symmetry ; apply StepFun_P42. - unfold adapted_couple in H1, H3; decompose [and] H1; decompose [and] H3; - clear H3 H1; rewrite H9; rewrite H5; unfold Rmax, Rmin; - decide (Rle_dec a c) with Hnle''; decide (Rle_dec a b) with Hle; reflexivity. } - eapply StepFun_P17; - [ apply StepFun_P21; unfold is_subdivision; split with lf1; apply H1 - | assumption ]. } - eapply StepFun_P17; - [ apply StepFun_P21; unfold is_subdivision; split with lf3; apply H3 - | assumption ]. } - eapply StepFun_P17. - { assert (H0 : c < a). - { auto with real. } - apply (StepFun_P40 H0 H (StepFun_P2 H3) H1). } - apply StepFun_P2; apply H2. } - replace (Int_SF lf1 l1) with 0. - { rewrite Rplus_0_r; eapply StepFun_P17; - [ apply H3 | rewrite <- H in H2; apply H2 ]. } - symmetry ; eapply StepFun_P8; [ apply H1 | assumption ]. - - assert (H : b < a). - { auto with real. } - replace (Int_SF lf2 l2) with (Int_SF lf3 l3 + Int_SF lf1 l1). - { ring. } - rewrite Rplus_comm; elim Hle''; intro. - { replace (Int_SF lf2 l2) with - (Int_SF (FF (app l1 l3) f) (app l1 l3)). - { replace (Int_SF lf3 l3) with (Int_SF (FF l3 f) l3). - { replace (Int_SF lf1 l1) with (Int_SF (FF l1 f) l1). - { symmetry ; apply StepFun_P42. - unfold adapted_couple in H1, H3; decompose [and] H1; decompose [and] H3; - clear H3 H1; rewrite H11; rewrite H5; unfold Rmax, Rmin; - decide (Rle_dec a c) with Hle''; decide (Rle_dec a b) with Hnle; - reflexivity. } - eapply StepFun_P17; - [ apply StepFun_P21; unfold is_subdivision; split with lf1; apply H1 - | assumption ]. } - eapply StepFun_P17; - [ apply StepFun_P21; unfold is_subdivision; split with lf3; apply H3 - | assumption ]. } - eapply StepFun_P17. - { apply (StepFun_P40 H H0 (StepFun_P2 H1) H3). } - apply H2. } - replace (Int_SF lf3 l3) with 0. - { rewrite Rplus_0_r; eapply StepFun_P17; - [ apply H1 | rewrite <- H0 in H2; apply StepFun_P2; apply H2 ]. } - symmetry ; eapply StepFun_P8; [ apply H3 | assumption ]. - - assert (H : c < a). - { auto with real. } - replace (Int_SF lf1 l1) with (Int_SF lf2 l2 + Int_SF lf3 l3). - { ring. } - elim Hle'; intro. - { replace (Int_SF lf1 l1) with - (Int_SF (FF (app l2 l3) f) (app l2 l3)). - { replace (Int_SF lf3 l3) with (Int_SF (FF l3 f) l3). - { replace (Int_SF lf2 l2) with (Int_SF (FF l2 f) l2). - { symmetry ; apply StepFun_P42. - unfold adapted_couple in H2, H3; decompose [and] H2; decompose [and] H3; - clear H3 H2; rewrite H11; rewrite H5; unfold Rmax, Rmin; - decide (Rle_dec a c) with Hnle''; decide (Rle_dec b c) with Hle'; - reflexivity. } - eapply StepFun_P17; - [ apply StepFun_P21; unfold is_subdivision; split with lf2; apply H2 - | assumption ]. } - eapply StepFun_P17; - [ apply StepFun_P21; unfold is_subdivision; split with lf3; apply H3 - | assumption ]. } - eapply StepFun_P17. - { apply (StepFun_P40 H0 H H2 (StepFun_P2 H3)). } - apply StepFun_P2; apply H1. } - replace (Int_SF lf2 l2) with 0. - { rewrite Rplus_0_l; eapply StepFun_P17; - [ apply H3 | rewrite H0 in H1; apply H1 ]. } - symmetry; eapply StepFun_P8; [ apply H2 | assumption ]. - - elim Hnle'; apply Rle_trans with a; try assumption. - auto with real. - - assert (H : c < b). - { auto with real. } - assert (H0 : b < a). - { auto with real. } - replace (Int_SF lf3 l3) with (Int_SF lf2 l2 + Int_SF lf1 l1). - { ring. } - replace (Int_SF lf3 l3) with - (Int_SF (FF (app l2 l1) f) (app l2 l1)). - { replace (Int_SF lf1 l1) with (Int_SF (FF l1 f) l1). - { replace (Int_SF lf2 l2) with (Int_SF (FF l2 f) l2). - { symmetry ; apply StepFun_P42. - unfold adapted_couple in H2, H1; decompose [and] H2; decompose [and] H1; - clear H1 H2; rewrite H11; rewrite H5; unfold Rmax, Rmin; - decide (Rle_dec a b) with Hnle; decide (Rle_dec b c) with Hnle'; - reflexivity. } - eapply StepFun_P17; - [ apply StepFun_P21; unfold is_subdivision; split with lf2; apply H2 - | assumption ]. } - eapply StepFun_P17; - [ apply StepFun_P21; unfold is_subdivision; split with lf1; apply H1 - | assumption ]. } - eapply StepFun_P17. - { apply (StepFun_P40 H H0 (StepFun_P2 H2) (StepFun_P2 H1)). } - apply StepFun_P2; apply H3. -Qed. - -Lemma StepFun_P44 : - forall (f:R -> R) (a b c:R), - IsStepFun f a b -> a <= c <= b -> IsStepFun f a c. -Proof. - intros f; intros; assert (H0 : a <= b). - { elim H; intros; apply Rle_trans with c; assumption. } - elim H; clear H; intros; unfold IsStepFun in X; unfold is_subdivision in X; - elim X; clear X; intros l1 [lf1 H2]; - cut - (forall (l1 lf1:list R) (a b c:R) (f:R -> R), - adapted_couple f a b l1 lf1 -> - a <= c <= b -> - { l:list R & { l0:list R & adapted_couple f a c l l0 } }). - { intro X; unfold IsStepFun; unfold is_subdivision; eapply X. - { apply H2. } - split; assumption. } - clear f a b c H0 H H1 H2 l1 lf1; simple induction l1. - { intros; unfold adapted_couple in H; decompose [and] H; clear H; simpl in H4; - discriminate. } - intros r r0; elim r0. - { intros X lf1 a b c f H H0; assert (H1 : a = b). - { unfold adapted_couple in H; decompose [and] H; clear H; simpl in H3; - simpl in H2; assert (H7 : a <= b). - { elim H0; intros; apply Rle_trans with c; assumption. } - replace a with (Rmin a b). - { pattern b at 2; replace b with (Rmax a b). - { rewrite <- H2; rewrite H3; reflexivity. } - unfold Rmax; decide (Rle_dec a b) with H7; reflexivity. } - unfold Rmin; decide (Rle_dec a b) with H7; reflexivity. } - split with (cons r nil); split with lf1; assert (H2 : c = b). - { rewrite H1 in H0; elim H0; intros; apply Rle_antisym; assumption. } - rewrite H2; assumption. } - intros r1 r2 _ X0 lf1 a b c f H H0; induction lf1 as [| r3 lf1 Hreclf1]. - { unfold adapted_couple in H; decompose [and] H; clear H; simpl in H4; - discriminate. } - clear Hreclf1; assert (H1 : {c <= r1} + {r1 < c}). - { case (Rle_dec c r1); intro; [ left; assumption | right; auto with real ]. } - elim H1; intro a0. - { split with (cons r (cons c nil)); split with (cons r3 nil); - unfold adapted_couple in H; decompose [and] H; clear H; - assert (H6 : r = a). - { simpl in H4; rewrite H4; unfold Rmin; case (Rle_dec a b) as [|[]]; - [ reflexivity - | elim H0; intros; apply Rle_trans with c; assumption ]. } - elim H0; clear H0; intros; unfold adapted_couple; repeat split. - { rewrite H6; unfold ordered_Rlist; intros; simpl in H8; inversion H8; - [ simpl; assumption | elim (Nat.nle_succ_0 _ H10) ]. } - { simpl; unfold Rmin; decide (Rle_dec a c) with H; assumption. } - { simpl; unfold Rmax; decide (Rle_dec a c) with H; reflexivity. } - unfold constant_D_eq, open_interval; intros; simpl in H8; - inversion H8. - { simpl; assert (H10 := H7 0%nat); - assert (H12 : (0 < pred (length (cons r (cons r1 r2))))%nat). - { simpl; apply Nat.lt_0_succ. } - apply (H10 H12); unfold open_interval; simpl; - rewrite H11 in H9; simpl in H9; elim H9; clear H9; - intros; split; try assumption. - apply Rlt_le_trans with c; assumption. } - elim (Nat.nle_succ_0 _ H11). } - cut (adapted_couple f r1 b (cons r1 r2) lf1). - { cut (r1 <= c <= b). - { intros. - elim (X0 _ _ _ _ _ H3 H2); intros l1' [lf1' H4]; split with (cons r l1'); - split with (cons r3 lf1'); unfold adapted_couple in H, H4; - decompose [and] H; decompose [and] H4; clear H H4 X0; - assert (H14 : a <= b). - { elim H0; intros; apply Rle_trans with c; assumption. } - assert (H16 : r = a). - { simpl in H7; rewrite H7; unfold Rmin; decide (Rle_dec a b) with H14; - reflexivity. } - induction l1' as [| r4 l1' Hrecl1']. - { simpl in H13; discriminate. } - clear Hrecl1'; unfold adapted_couple; repeat split. - { unfold ordered_Rlist; intros; simpl in H; induction i as [| i Hreci]. - { simpl; replace r4 with r1. - { apply (H5 0%nat). - simpl; apply Nat.lt_0_succ. } - simpl in H12; rewrite H12; unfold Rmin; case (Rle_dec r1 c) as [|[]]; - [ reflexivity | left; assumption ]. } - apply (H9 i); simpl; apply Nat.succ_lt_mono; assumption. } - { simpl; unfold Rmin; case (Rle_dec a c) as [|[]]; - [ assumption | elim H0; intros; assumption ]. } - { replace (Rmax a c) with (Rmax r1 c). - { rewrite <- H11; reflexivity. } - unfold Rmax; case (Rle_dec a c) as [|[]]; case (Rle_dec r1 c) as [|[]]; - [ reflexivity - | left; assumption - | elim H0; intros; assumption - | left; assumption ]. } - { simpl; simpl in H13; rewrite H13; reflexivity. } - intros; simpl in H; unfold constant_D_eq, open_interval; intros; - induction i as [| i Hreci]. - { simpl; assert (H17 := H10 0%nat); - assert (H18 : (0 < pred (length (cons r (cons r1 r2))))%nat). - { simpl; apply Nat.lt_0_succ. } - apply (H17 H18); unfold open_interval; simpl; simpl in H4; - elim H4; clear H4; intros; split; try assumption; - replace r1 with r4. - { assumption. } - simpl in H12; rewrite H12; unfold Rmin; case (Rle_dec r1 c) as [|[]]; - [ reflexivity | left; assumption ]. } - clear Hreci; simpl; apply H15. - { simpl; apply Nat.succ_lt_mono; assumption. } - unfold open_interval; apply H4. } - split. - { left; assumption. } - elim H0; intros; assumption. } - eapply StepFun_P7; - [ elim H0; intros; apply Rle_trans with c; [ apply H2 | apply H3 ] - | apply H ]. -Qed. - -Lemma StepFun_P45 : - forall (f:R -> R) (a b c:R), - IsStepFun f a b -> a <= c <= b -> IsStepFun f c b. -Proof. - intros f; intros; assert (H0 : a <= b). - { elim H; intros; apply Rle_trans with c; assumption. } - elim H; clear H; intros; unfold IsStepFun in X; unfold is_subdivision in X; - elim X; clear X; intros l1 [lf1 H2]; - cut - (forall (l1 lf1:list R) (a b c:R) (f:R -> R), - adapted_couple f a b l1 lf1 -> - a <= c <= b -> - { l:list R & { l0:list R & adapted_couple f c b l l0 } }). - { intro X; unfold IsStepFun; unfold is_subdivision; eapply X; - [ apply H2 | split; assumption ]. } - clear f a b c H0 H H1 H2 l1 lf1; simple induction l1. - { intros; unfold adapted_couple in H; decompose [and] H; clear H; simpl in H4; - discriminate. } - intros r r0; elim r0. - { intros X lf1 a b c f H H0; assert (H1 : a = b). - { unfold adapted_couple in H; decompose [and] H; clear H; simpl in H3; - simpl in H2; assert (H7 : a <= b). - { elim H0; intros; apply Rle_trans with c; assumption. } - replace a with (Rmin a b). - { pattern b at 2; replace b with (Rmax a b). - { rewrite <- H2; rewrite H3; reflexivity. } - unfold Rmax; decide (Rle_dec a b) with H7; reflexivity. } - unfold Rmin; decide (Rle_dec a b) with H7; reflexivity. } - split with (cons r nil); split with lf1; assert (H2 : c = b). - { rewrite H1 in H0; elim H0; intros; apply Rle_antisym; assumption. } - rewrite <- H2 in H1; rewrite <- H1; assumption. } - intros r1 r2 _ X0 lf1 a b c f H H0; induction lf1 as [| r3 lf1 Hreclf1]. - { unfold adapted_couple in H; decompose [and] H; clear H; simpl in H4; - discriminate. } - clear Hreclf1; assert (H1 : {c <= r1} + {r1 < c}). - { case (Rle_dec c r1); intro; [ left; assumption | right; auto with real ]. } - elim H1; intro a0. - { split with (cons c (cons r1 r2)); split with (cons r3 lf1); - unfold adapted_couple in H; decompose [and] H; clear H; - unfold adapted_couple; repeat split. - - unfold ordered_Rlist; intros; simpl in H; induction i as [| i Hreci]. - { simpl; assumption. } - clear Hreci; apply (H2 (S i)); simpl; assumption. - - simpl; unfold Rmin; case (Rle_dec c b) as [|[]]; - [ reflexivity | elim H0; intros; assumption ]. - - replace (Rmax c b) with (Rmax a b). - { rewrite <- H3; reflexivity. } - unfold Rmax; case (Rle_dec c b) as [|[]]; case (Rle_dec a b) as [|[]]; - [ reflexivity - | elim H0; intros; apply Rle_trans with c; assumption - | elim H0; intros; assumption - | elim H0; intros; apply Rle_trans with c; assumption ]. - - simpl; simpl in H5; apply H5. - - intros; simpl in H; induction i as [| i Hreci]. - { unfold constant_D_eq, open_interval; intros; simpl; - apply (H7 0%nat). - { simpl; apply Nat.lt_0_succ. } - unfold open_interval; simpl; simpl in H6; elim H6; clear H6; - intros; split; try assumption; apply Rle_lt_trans with c; - try assumption; replace r with a. - { elim H0; intros; assumption. } - simpl in H4; rewrite H4; unfold Rmin; case (Rle_dec a b) as [|[]]; - [ reflexivity - | elim H0; intros; apply Rle_trans with c; assumption ]. } - clear Hreci; apply (H7 (S i)); simpl; assumption. } - cut (adapted_couple f r1 b (cons r1 r2) lf1). - { cut (r1 <= c <= b). - { intros; elim (X0 _ _ _ _ _ H3 H2); intros l1' [lf1' H4]; split with l1'; - split with lf1'; assumption. } - split; [ left; assumption | elim H0; intros; assumption ]. } - eapply StepFun_P7; - [ elim H0; intros; apply Rle_trans with c; [ apply H2 | apply H3 ] - | apply H ]. -Qed. - -Lemma StepFun_P46 : - forall (f:R -> R) (a b c:R), - IsStepFun f a b -> IsStepFun f b c -> IsStepFun f a c. -Proof. - intros f; intros; case (Rle_dec a b); case (Rle_dec b c); intros. - - apply StepFun_P41 with b; assumption. - - case (Rle_dec a c); intro. - + apply StepFun_P44 with b; try assumption. - split; [ assumption | auto with real ]. - + apply StepFun_P6; apply StepFun_P44 with b. - * apply StepFun_P6; assumption. - * split; auto with real. - - case (Rle_dec a c); intro. - + apply StepFun_P45 with b; try assumption. - split; auto with real. - + apply StepFun_P6; apply StepFun_P45 with b. - * apply StepFun_P6; assumption. - * split; [ assumption | auto with real ]. - - apply StepFun_P6; apply StepFun_P41 with b; - auto with real || apply StepFun_P6; assumption. -Qed. diff --git a/stdlib/theories/Reals/Rlimit.v b/stdlib/theories/Reals/Rlimit.v deleted file mode 100644 index 0f0f7e54a3f4..000000000000 --- a/stdlib/theories/Reals/Rlimit.v +++ /dev/null @@ -1,507 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* 0 -> eps * / 2 > 0. -Proof. - intros; lra. -Qed. - -(*********) -Lemma eps2 : forall eps:R, eps * / 2 + eps * / 2 = eps. -Proof. - intro esp. - apply Rplus_half_diag. -Qed. - -(*********) -Lemma eps4 : forall eps:R, eps * / (2 + 2) + eps * / (2 + 2) = eps * / 2. -Proof. - intro eps. - field. -Qed. - -(*********) -Lemma Rlt_eps2_eps : forall eps:R, eps > 0 -> eps * / 2 < eps. -Proof. - intros. - lra. -Qed. - -(*********) -Lemma Rlt_eps4_eps : forall eps:R, eps > 0 -> eps * / (2 + 2) < eps. -Proof. - intros. - lra. -Qed. - -(*********) -Lemma prop_eps : forall r:R, (forall eps:R, eps > 0 -> r < eps) -> r <= 0. -Proof. - intros; elim (Rtotal_order r 0); intro. - - apply Rlt_le; assumption. - - elim H0; intro. - + apply Req_le; assumption. - + clear H0; generalize (H r H1); intro; generalize (Rlt_irrefl r); intro; - exfalso; auto. -Qed. - -(*********) -Definition mul_factor (l l':R) := / (1 + (Rabs l + Rabs l')). - -(*********) -Lemma mul_factor_wd : forall l l':R, 1 + (Rabs l + Rabs l') <> 0. -Proof. - intros; rewrite (Rplus_comm 1 (Rabs l + Rabs l')); apply Rplus_le_lt_0_neq_0. - - cut (Rabs (l + l') <= Rabs l + Rabs l'). - + cut (0 <= Rabs (l + l')). - * exact (Rle_trans _ _ _). - * exact (Rabs_pos (l + l')). - + exact (Rabs_triang _ _). - - exact Rlt_0_1. -Qed. - -(*********) -Lemma mul_factor_gt : forall eps l l':R, eps > 0 -> eps * mul_factor l l' > 0. -Proof. - intros; unfold Rgt; rewrite <- (Rmult_0_r eps); - apply Rmult_lt_compat_l. - - assumption. - - unfold mul_factor; apply Rinv_0_lt_compat; - cut (1 <= 1 + (Rabs l + Rabs l')). - + cut (0 < 1). - * exact (Rlt_le_trans _ _ _). - * exact Rlt_0_1. - + replace (1 <= 1 + (Rabs l + Rabs l')) with (1 + 0 <= 1 + (Rabs l + Rabs l')). - * apply Rplus_le_compat_l. - cut (Rabs (l + l') <= Rabs l + Rabs l'). - -- cut (0 <= Rabs (l + l')). - ++ exact (Rle_trans _ _ _). - ++ exact (Rabs_pos _). - -- exact (Rabs_triang _ _). - * rewrite (proj1 (Rplus_ne 1)); trivial. -Qed. - -(*********) -Lemma mul_factor_gt_f : - forall eps l l':R, eps > 0 -> Rmin 1 (eps * mul_factor l l') > 0. - intros; apply Rmin_Rgt_r; split. - - exact Rlt_0_1. - - exact (mul_factor_gt eps l l' H). -Qed. - - -(*******************************) -(** * Metric space *) -(*******************************) - -(*********) -Record Metric_Space : Type := - {Base : Type; - dist : Base -> Base -> R; - dist_pos : forall x y:Base, dist x y >= 0; - dist_sym : forall x y:Base, dist x y = dist y x; - dist_refl : forall x y:Base, dist x y = 0 <-> x = y; - dist_tri : forall x y z:Base, dist x y <= dist x z + dist z y}. - -(*******************************) -(** ** Limit in Metric space *) -(*******************************) - -(*********) -Definition limit_in (X X':Metric_Space) (f:Base X -> Base X') - (D:Base X -> Prop) (x0:Base X) (l:Base X') := - forall eps:R, - eps > 0 -> - exists alp : R, - alp > 0 /\ - (forall x:Base X, D x /\ (dist X) x x0 < alp -> (dist X') (f x) l < eps). - -(*******************************) -(** ** R is a metric space *) -(*******************************) - -(*********) -Definition R_met : Metric_Space := - Build_Metric_Space R Rdist Rdist_pos Rdist_sym Rdist_refl Rdist_tri. - -Declare Equivalent Keys dist Rdist. - -(*******************************) -(** * Limit 1 arg *) -(*******************************) -(*********) -Definition Dgf (Df Dg:R -> Prop) (f:R -> R) (x:R) := Df x /\ Dg (f x). - -(*********) -Definition limit1_in (f:R -> R) (D:R -> Prop) (l x0:R) : Prop := - limit_in R_met R_met f D x0 l. - -(*********) -Lemma tech_limit : - forall (f:R -> R) (D:R -> Prop) (l x0:R), - D x0 -> limit1_in f D l x0 -> l = f x0. -Proof. - intros f D l x0 H H0. - case (Rabs_pos (f x0 - l)); intros H1. - - absurd ((@dist R_met) (f x0) l < (@dist R_met) (f x0) l). - + apply Rlt_irrefl. - + case (H0 ((@dist R_met) (f x0) l)); auto. - intros alpha1 [H2 H3]; apply H3; auto; split; auto. - case (dist_refl R_met x0 x0); intros Hr1 Hr2; rewrite Hr2; auto. - - case (dist_refl R_met (f x0) l); intros Hr1 Hr2; symmetry; auto. -Qed. - -(*********) -Lemma tech_limit_contr : - forall (f:R -> R) (D:R -> Prop) (l x0:R), - D x0 -> l <> f x0 -> ~ limit1_in f D l x0. -Proof. - intros; generalize (tech_limit f D l x0); tauto. -Qed. - -(*********) -Lemma lim_x : forall (D:R -> Prop) (x0:R), limit1_in (fun x:R => x) D x0 x0. -Proof. - unfold limit1_in; unfold limit_in; simpl; intros; - split with eps; split; auto; intros; elim H0; intros; - auto. -Qed. - -(*********) -Lemma limit_plus : - forall (f g:R -> R) (D:R -> Prop) (l l' x0:R), - limit1_in f D l x0 -> - limit1_in g D l' x0 -> limit1_in (fun x:R => f x + g x) D (l + l') x0. -Proof. - intros; unfold limit1_in; unfold limit_in; simpl; - intros; elim (H (eps * / 2) (eps2_Rgt_R0 eps H1)); - elim (H0 (eps * / 2) (eps2_Rgt_R0 eps H1)); simpl; - clear H H0; intros; elim H; elim H0; clear H H0; intros; - split with (Rmin x1 x); split. - - exact (Rmin_Rgt_r x1 x 0 (conj H H2)). - - intros; elim H4; clear H4; intros; - cut (Rdist (f x2) l + Rdist (g x2) l' < eps). - + cut (Rdist (f x2 + g x2) (l + l') <= Rdist (f x2) l + Rdist (g x2) l'). - * exact (Rle_lt_trans _ _ _). - * exact (Rdist_plus _ _ _ _). - + elim (Rmin_Rgt_l x1 x (Rdist x2 x0) H5); clear H5; intros. - generalize (H3 x2 (conj H4 H6)); generalize (H0 x2 (conj H4 H5)); intros; - replace eps with (eps * / 2 + eps * / 2). - * exact (Rplus_lt_compat _ _ _ _ H7 H8). - * exact (eps2 eps). -Qed. - -(*********) -Lemma limit_Ropp : - forall (f:R -> R) (D:R -> Prop) (l x0:R), - limit1_in f D l x0 -> limit1_in (fun x:R => - f x) D (- l) x0. -Proof. - unfold limit1_in; unfold limit_in; simpl; intros; - elim (H eps H0); clear H; intros; elim H; clear H; - intros; split with x; split; auto; intros; generalize (H1 x1 H2); - clear H1; intro; unfold Rdist; unfold Rminus; - rewrite (Ropp_involutive l); rewrite (Rplus_comm (- f x1) l); - fold (l - f x1); fold (Rdist l (f x1)); - rewrite Rdist_sym; assumption. -Qed. - -(*********) -Lemma limit_minus : - forall (f g:R -> R) (D:R -> Prop) (l l' x0:R), - limit1_in f D l x0 -> - limit1_in g D l' x0 -> limit1_in (fun x:R => f x - g x) D (l - l') x0. -Proof. - intros; unfold Rminus; generalize (limit_Ropp g D l' x0 H0); intro; - exact (limit_plus f (fun x:R => - g x) D l (- l') x0 H H1). -Qed. - -(*********) -Lemma limit_free : - forall (f:R -> R) (D:R -> Prop) (x x0:R), - limit1_in (fun h:R => f x) D (f x) x0. -Proof. - unfold limit1_in; unfold limit_in; simpl; intros; - split with eps; split; auto; intros; elim (Rdist_refl (f x) (f x)); - intros a b; rewrite (b (eq_refl (f x))); unfold Rgt in H; - assumption. -Qed. - -(*********) -Lemma limit_mul : - forall (f g:R -> R) (D:R -> Prop) (l l' x0:R), - limit1_in f D l x0 -> - limit1_in g D l' x0 -> limit1_in (fun x:R => f x * g x) D (l * l') x0. -Proof. - intros; unfold limit1_in; unfold limit_in; simpl; - intros; - elim (H (Rmin 1 (eps * mul_factor l l')) (mul_factor_gt_f eps l l' H1)); - elim (H0 (eps * mul_factor l l') (mul_factor_gt eps l l' H1)); - clear H H0; simpl; intros; elim H; elim H0; - clear H H0; intros; split with (Rmin x1 x); split. - { exact (Rmin_Rgt_r x1 x 0 (conj H H2)). } - intros; elim H4; clear H4; intros; unfold Rdist; - replace (f x2 * g x2 - l * l') with (f x2 * (g x2 - l') + l' * (f x2 - l)). - - cut (Rabs (f x2 * (g x2 - l')) + Rabs (l' * (f x2 - l)) < eps). - { cut - (Rabs (f x2 * (g x2 - l') + l' * (f x2 - l)) <= - Rabs (f x2 * (g x2 - l')) + Rabs (l' * (f x2 - l))). - - exact (Rle_lt_trans _ _ _). - - exact (Rabs_triang _ _). } - rewrite (Rabs_mult (f x2) (g x2 - l')); rewrite (Rabs_mult l' (f x2 - l)); - cut - ((1 + Rabs l) * (eps * mul_factor l l') + Rabs l' * (eps * mul_factor l l') <= - eps). - 1:cut - (Rabs (f x2) * Rabs (g x2 - l') + Rabs l' * Rabs (f x2 - l) < - (1 + Rabs l) * (eps * mul_factor l l') + Rabs l' * (eps * mul_factor l l')). - + exact (Rlt_le_trans _ _ _). - + elim (Rmin_Rgt_l x1 x (Rdist x2 x0) H5); clear H5; intros; - generalize (H0 x2 (conj H4 H5)); intro; generalize (Rmin_Rgt_l _ _ _ H7); - intro; elim H8; intros; clear H0 H8; apply Rplus_lt_le_compat. - * apply Rmult_ge_0_gt_0_lt_compat. - -- apply Rle_ge. - exact (Rabs_pos (g x2 - l')). - -- rewrite (Rplus_comm 1 (Rabs l)); unfold Rgt; - apply Rplus_le_lt_0_compat with (1 := (Rabs_pos l)); - exact Rlt_0_1. - -- unfold Rdist in H9; - apply (Rplus_lt_reg_l (- Rabs l) (Rabs (f x2)) (1 + Rabs l)). - rewrite <- (Rplus_assoc (- Rabs l) 1 (Rabs l)); - rewrite (Rplus_comm (- Rabs l) 1); - rewrite (Rplus_assoc 1 (- Rabs l) (Rabs l)); rewrite (Rplus_opp_l (Rabs l)); - rewrite (proj1 (Rplus_ne 1)); rewrite (Rplus_comm (- Rabs l) (Rabs (f x2))); - generalize H9; cut (Rabs (f x2) - Rabs l <= Rabs (f x2 - l)). - ++ exact (Rle_lt_trans _ _ _). - ++ exact (Rabs_triang_inv _ _). - -- generalize (H3 x2 (conj H4 H6)); trivial. - * apply Rmult_le_compat_l. - -- exact (Rabs_pos l'). - -- unfold Rle; left; assumption. - + rewrite (Rmult_comm (1 + Rabs l) (eps * mul_factor l l')); - rewrite (Rmult_comm (Rabs l') (eps * mul_factor l l')); - rewrite <- - (Rmult_plus_distr_l (eps * mul_factor l l') (1 + Rabs l) (Rabs l')) - ; rewrite (Rmult_assoc eps (mul_factor l l') (1 + Rabs l + Rabs l')); - rewrite (Rplus_assoc 1 (Rabs l) (Rabs l')); unfold mul_factor; - rewrite (Rinv_l (1 + (Rabs l + Rabs l')) (mul_factor_wd l l')); - rewrite (proj1 (Rmult_ne eps)); apply Req_le; trivial. - - ring. -Qed. - -(*********) -Definition adhDa (D:R -> Prop) (a:R) : Prop := - forall alp:R, alp > 0 -> exists x : R, D x /\ Rdist x a < alp. - -(*********) -Lemma single_limit : - forall (f:R -> R) (D:R -> Prop) (l l' x0:R), - adhDa D x0 -> limit1_in f D l x0 -> limit1_in f D l' x0 -> l = l'. -Proof. - unfold limit1_in; unfold limit_in; intros. - simpl in *. - cut (forall eps:R, eps > 0 -> dist R_met l l' < 2 * eps). - - clear H0 H1; unfold dist in |- *; unfold R_met; unfold Rdist in |- *; - unfold Rabs; case (Rcase_abs (l - l')) as [Hlt|Hge]; intros. - + cut (forall eps:R, eps > 0 -> - (l - l') < eps). - * intro; generalize (prop_eps (- (l - l')) H1); intro; - generalize (Ropp_gt_lt_0_contravar (l - l') Hlt); intro; - unfold Rgt in H3; generalize (Rgt_not_le (- (l - l')) 0 H3); - intro; exfalso; auto. - * intros; cut (eps * / 2 > 0). - -- intro; generalize (H0 (eps * / 2) H2); rewrite (Rmult_comm eps (/ 2)); - rewrite <- (Rmult_assoc 2 (/ 2) eps); rewrite (Rinv_r 2). - ++ elim (Rmult_ne eps); intros a b; rewrite b; clear a b; trivial. - ++ apply (Rlt_dichotomy_converse 2 0); right; generalize Rlt_0_1; intro; - unfold Rgt; generalize (Rplus_lt_compat_l 1 0 1 H3); - intro; elim (Rplus_ne 1); intros a b; rewrite a in H4; - clear a b; apply (Rlt_trans 0 1 2 H3 H4). - -- unfold Rgt; unfold Rgt in H1; rewrite (Rmult_comm eps (/ 2)); - rewrite <- (Rmult_0_r (/ 2)); apply (Rmult_lt_compat_l (/ 2) 0 eps); - auto. - apply (Rinv_0_lt_compat 2); cut (1 < 2). - ++ intro; apply (Rlt_trans 0 1 2 Rlt_0_1 H2). - ++ generalize (Rplus_lt_compat_l 1 0 1 Rlt_0_1); elim (Rplus_ne 1); intros a b; - rewrite a; clear a b; trivial. - + (**) - cut (forall eps:R, eps > 0 -> l - l' < eps). - * intro; generalize (prop_eps (l - l') H1); intro; elim (Rle_le_eq (l - l') 0); - intros a b; clear b; apply (Rminus_diag_uniq l l'); - apply a; split. - -- assumption. - -- apply (Rge_le (l - l') 0 Hge). - * intros; cut (eps * / 2 > 0). - -- intro; generalize (H0 (eps * / 2) H2); rewrite (Rmult_comm eps (/ 2)); - rewrite <- (Rmult_assoc 2 (/ 2) eps); rewrite (Rinv_r 2). - ++ elim (Rmult_ne eps); intros a b; rewrite b; clear a b; trivial. - ++ apply (Rlt_dichotomy_converse 2 0); right; generalize Rlt_0_1; intro; - unfold Rgt; generalize (Rplus_lt_compat_l 1 0 1 H3); - intro; elim (Rplus_ne 1); intros a b; rewrite a in H4; - clear a b; apply (Rlt_trans 0 1 2 H3 H4). - -- unfold Rgt; unfold Rgt in H1; rewrite (Rmult_comm eps (/ 2)); - rewrite <- (Rmult_0_r (/ 2)); apply (Rmult_lt_compat_l (/ 2) 0 eps); - auto. - apply (Rinv_0_lt_compat 2); cut (1 < 2). - ++ intro; apply (Rlt_trans 0 1 2 Rlt_0_1 H2). - ++ generalize (Rplus_lt_compat_l 1 0 1 Rlt_0_1); elim (Rplus_ne 1); intros a b; - rewrite a; clear a b; trivial. - - (**) - intros; unfold adhDa in H; elim (H0 eps H2); intros; elim (H1 eps H2); intros; - clear H0 H1; elim H3; elim H4; clear H3 H4; intros; - simpl; simpl in H1, H4; generalize (Rmin_Rgt x x1 0); - intro; elim H5; intros; clear H5; elim (H (Rmin x x1) (H7 (conj H3 H0))); - intros; elim H5; intros; clear H5 H H6 H7; - generalize (Rmin_Rgt x x1 (Rdist x2 x0)); intro; - elim H; intros; clear H H6; unfold Rgt in H5; elim (H5 H9); - intros; clear H5 H9; generalize (H1 x2 (conj H8 H6)); - generalize (H4 x2 (conj H8 H)); clear H8 H H6 H1 H4 H0 H3; - intros; - generalize - (Rplus_lt_compat (Rdist (f x2) l) eps (Rdist (f x2) l') eps H H0); - unfold Rdist; intros; rewrite (Rabs_minus_sym (f x2) l) in H1; - rewrite (Rmult_comm 2 eps); replace (eps *2) with (eps + eps) by ring; - generalize (Rdist_tri l l' (f x2)); unfold Rdist; - intros; - apply - (Rle_lt_trans (Rabs (l - l')) (Rabs (l - f x2) + Rabs (f x2 - l')) - (eps + eps) H3 H1). -Qed. - -(*********) -Lemma limit_comp : - forall (f g:R -> R) (Df Dg:R -> Prop) (l l' x0:R), - limit1_in f Df l x0 -> - limit1_in g Dg l' l -> limit1_in (fun x:R => g (f x)) (Dgf Df Dg f) l' x0. -Proof. - unfold limit1_in, limit_in, Dgf; simpl. - intros f g Df Dg l l' x0 Hf Hg eps eps_pos. - elim (Hg eps eps_pos). - intros alpg lg. - elim (Hf alpg). - 2: tauto. - intros alpf lf. - exists alpf. - intuition. -Qed. - -(*********) - -Lemma limit_inv : - forall (f:R -> R) (D:R -> Prop) (l x0:R), - limit1_in f D l x0 -> l <> 0 -> limit1_in (fun x:R => / f x) D (/ l) x0. -Proof. - unfold limit1_in; unfold limit_in; simpl; - unfold Rdist; intros; elim (H (Rabs l / 2)). - - intros delta1 H2; elim (H (eps * (Rsqr l / 2))). - + intros delta2 H3; elim H2; elim H3; intros; exists (Rmin delta1 delta2); - split. - { unfold Rmin; case (Rle_dec delta1 delta2); intro; assumption. } - intro; generalize (H5 x); clear H5; intro H5; generalize (H7 x); clear H7; - intro H7; intro H10; elim H10; intros; cut (D x /\ Rabs (x - x0) < delta1). - * cut (D x /\ Rabs (x - x0) < delta2). - -- intros; generalize (H5 H11); clear H5; intro H5; generalize (H7 H12); - clear H7; intro H7; generalize (Rabs_triang_inv l (f x)); - intro; rewrite Rabs_minus_sym in H7; - generalize - (Rle_lt_trans (Rabs l - Rabs (f x)) (Rabs (l - f x)) (Rabs l / 2) H13 H7); - intro; - generalize - (Rplus_lt_compat_l (Rabs (f x) - Rabs l / 2) (Rabs l - Rabs (f x)) - (Rabs l / 2) H14); - replace (Rabs (f x) - Rabs l / 2 + (Rabs l - Rabs (f x))) with (Rabs l / 2). - ++ unfold Rminus; rewrite Rplus_assoc; rewrite Rplus_opp_l; - rewrite Rplus_0_r; intro; cut (f x <> 0). - ** intro; replace (/ f x + - / l) with ((l - f x) * / (l * f x)). - { rewrite Rabs_mult; rewrite Rabs_inv. - cut (/ Rabs (l * f x) < 2 / Rsqr l). - - intro; rewrite Rabs_minus_sym in H5; cut (0 <= / Rabs (l * f x)). - + intro; - generalize - (Rmult_le_0_lt_compat (Rabs (l - f x)) (eps * (Rsqr l / 2)) - (/ Rabs (l * f x)) (2 / Rsqr l) (Rabs_pos (l - f x)) H18 H5 H17); - replace (eps * (Rsqr l / 2) * (2 / Rsqr l)) with eps. - * intro; assumption. - * unfold Rdiv; unfold Rsqr; rewrite Rinv_mult. - field. - exact H0. - + left; apply Rinv_0_lt_compat; apply Rabs_pos_lt; apply prod_neq_R0; - assumption. - - rewrite Rmult_comm; rewrite Rabs_mult; rewrite Rinv_mult. - rewrite (Rsqr_abs l); unfold Rsqr; unfold Rdiv; - rewrite Rinv_mult. - repeat rewrite <- Rmult_assoc; apply Rmult_lt_compat_r. - + apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption. - + apply Rmult_lt_reg_l with (Rabs (f x) * Rabs l * / 2). - * repeat apply Rmult_lt_0_compat. - -- apply Rabs_pos_lt; assumption. - -- apply Rabs_pos_lt; assumption. - -- apply Rinv_0_lt_compat; cut (0%nat <> 2%nat); - [ intro H17; generalize (lt_INR_0 2 (proj1 (Nat.neq_0_lt_0 2) (Nat.neq_sym 0 2 H17))); unfold INR; - intro H18; assumption - | discriminate ]. - * replace (Rabs (f x) * Rabs l * / 2 * / Rabs (f x)) with (Rabs l / 2). - -- replace (Rabs (f x) * Rabs l * / 2 * (2 * / Rabs l)) with (Rabs (f x)). - ++ assumption. - ++ field. - apply Rabs_no_R0. - assumption. - -- field. - apply Rabs_no_R0; assumption. - } - field. - now split. - ** red; intro; rewrite H16 in H15; rewrite Rabs_R0 in H15; - cut (0 < Rabs l / 2). - { intro; elim (Rlt_irrefl 0 (Rlt_trans 0 (Rabs l / 2) 0 H17 H15)). } - unfold Rdiv; apply Rmult_lt_0_compat. - { apply Rabs_pos_lt; assumption. } - apply Rinv_0_lt_compat; cut (0%nat <> 2%nat); - [ intro H17; generalize (lt_INR_0 2 (proj1 (Nat.neq_0_lt_0 2) (Nat.neq_sym 0 2 H17))); unfold INR; - intro; assumption - | discriminate ]. - ++ pattern (Rabs l) at 3; rewrite <-Rplus_half_diag. - ring. - -- split; - [ assumption - | apply Rlt_le_trans with (Rmin delta1 delta2); - [ assumption | apply Rmin_r ] ]. - * split; - [ assumption - | apply Rlt_le_trans with (Rmin delta1 delta2); - [ assumption | apply Rmin_l ] ]. - + change (0 < eps * (Rsqr l / 2)); unfold Rdiv; - repeat rewrite Rmult_assoc; apply Rmult_lt_0_compat. - * assumption. - * apply Rmult_lt_0_compat. - -- apply Rsqr_pos_lt; assumption. - -- apply Rinv_0_lt_compat; cut (0%nat <> 2%nat); - [ intro H3; generalize (lt_INR_0 2 (proj1 (Nat.neq_0_lt_0 2) (Nat.neq_sym 0 2 H3))); unfold INR; - intro; assumption - | discriminate ]. - - change (0 < Rabs l / 2); unfold Rdiv; apply Rmult_lt_0_compat; - [ apply Rabs_pos_lt; assumption - | apply Rinv_0_lt_compat; cut (0%nat <> 2%nat); - [ intro H3; generalize (lt_INR_0 2 (proj1 (Nat.neq_0_lt_0 2) (Nat.neq_sym 0 2 H3))); unfold INR; - intro; assumption - | discriminate ] ]. -Qed. diff --git a/stdlib/theories/Reals/Rlogic.v b/stdlib/theories/Reals/Rlogic.v deleted file mode 100644 index 94ec98a326c6..000000000000 --- a/stdlib/theories/Reals/Rlogic.v +++ /dev/null @@ -1,220 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* Prop. -Hypothesis HP : forall n, {P n} + {~P n}. - -Lemma sig_forall_dec : {n | ~P n} + {forall n, P n}. -Proof. -assert (Hi: (forall n, 0 < INR n + 1)%R). { - intros n. - apply Rplus_le_lt_0_compat with (1 := (pos_INR n)); apply Rlt_0_1. -} -set (u n := (if HP n then 0 else / (INR n + 1))%R). -assert (Bu: forall n, (u n <= 1)%R). { - intros n. - unfold u. - case HP ; intros _. - - apply Rle_0_1. - - rewrite <- S_INR, <- Rinv_1. - apply Rinv_le_contravar with (1 := Rlt_0_1). - apply (le_INR 1); apply -> Nat.succ_le_mono; apply Nat.le_0_l. -} -set (E y := exists n, y = u n). -destruct (completeness E) as [l [ub lub]]. -- exists R1. - intros y [n ->]. - apply Bu. -- exists (u O). - now exists O. -- assert (Hnp: forall n, not (P n) -> ((/ (INR n + 1) <= l)%R)). { - intros n Hp. - apply ub. - exists n. - unfold u. - now destruct (HP n). - } - destruct (Rle_lt_dec l 0) as [Hl|Hl]. - + right. - intros n. - destruct (HP n) as [H|H]. - * exact H. - * exfalso. - apply Rle_not_lt with (1 := Hl). - apply Rlt_le_trans with (/ (INR n + 1))%R. - -- now apply Rinv_0_lt_compat. - -- now apply Hnp. - + left. - set (N := Z.abs_nat (up (/l) - 2)). - assert (H1l: (1 <= /l)%R). { - rewrite <- Rinv_1. - apply Rinv_le_contravar with (1 := Hl). - apply lub. - now intros y [m ->]. - } - assert (HN: (INR N + 1 = IZR (up (/ l)) - 1)%R). { - unfold N. - rewrite INR_IZR_INZ. - rewrite inj_Zabs_nat. - replace (IZR (up (/ l)) - 1)%R with (IZR (up (/ l) - 2) + 1)%R. - - apply (f_equal (fun v => IZR v + 1)%R). - apply Z.abs_eq. - apply Zle_minus_le_0. - apply (Zlt_le_succ 1). - apply lt_IZR. - apply Rle_lt_trans with (1 := H1l). - apply archimed. - - rewrite minus_IZR. - simpl. - ring. - } - assert (Hl': (/ (INR (S N) + 1) < l)%R). { - rewrite <- (Rinv_inv l). - apply Rinv_0_lt_contravar. - { now apply Rinv_0_lt_compat. } - rewrite S_INR. - rewrite HN. - ring_simplify. - apply archimed. - } - exists N. - intros H. - apply Rle_not_lt with (2 := Hl'). - apply lub. - intros y [n ->]. - unfold u. - destruct (HP n) as [_|Hp]. - * apply Rlt_le. - now apply Rinv_0_lt_compat. - * apply Rinv_le_contravar. - -- apply Hi. - -- apply Rplus_le_compat_r. - apply le_INR. - destruct (Nat.le_gt_cases n N) as [Hn|Hn]. - 2: now apply Nat.le_succ_l. - exfalso. - destruct (proj1 (Nat.lt_eq_cases _ _) Hn) as [Hn'| ->]. - 2: now apply Hp. - apply Rlt_not_le with (2 := Hnp _ Hp). - rewrite <- (Rinv_inv l). - apply Rinv_0_lt_contravar. - ++ apply Rplus_le_lt_0_compat. - ** apply pos_INR. - ** apply Rlt_0_1. - ++ apply Rlt_le_trans with (INR N + 1)%R. - ** apply Rplus_lt_compat_r. - now apply lt_INR. - ** rewrite HN. - apply Rplus_le_reg_r with (-/l + 1)%R. - ring_simplify. - apply archimed. -Qed. - -End Arithmetical_dec. - -(** * Derivability of the Archimedean axiom *) - -(** This is a standard proof (it has been taken from PlanetMath). It is -formulated negatively so as to avoid the need for classical -logic. Using a proof of [{n | ~P n}+{forall n, P n}], we can in -principle also derive [up] and its specification. The proof above -cannot be used for that purpose, since it relies on the [archimed] axiom. *) - -Theorem not_not_archimedean : - forall r : R, ~ (forall n : nat, (INR n <= r)%R). -Proof. -intros r H. -set (E := fun r => exists n : nat, r = INR n). -assert (exists x : R, E x) by - (exists 0%R; simpl; red; exists 0%nat; reflexivity). -assert (bound E) by (exists r; intros x (m,H2); rewrite H2; apply H). -destruct (completeness E) as (M,(H3,H4)); try assumption. -set (M' := (M + -1)%R). -assert (H2 : ~ is_upper_bound E M'). { - intro H5. - assert (M <= M')%R by (apply H4; exact H5). - apply (Rlt_not_le M M'). { - unfold M'. - pattern M at 2. - rewrite <- Rplus_0_l. - pattern (0 + M)%R. - rewrite Rplus_comm. - rewrite <- (Rplus_opp_r 1). - apply Rplus_lt_compat_l. - rewrite Rplus_comm. - apply Rplus_pos_gt, Rlt_0_1. - } - assumption. -} -apply H2. -intros N (n,H7). -rewrite H7. -unfold M'. -assert (H5 : (INR (S n) <= M)%R) by (apply H3; exists (S n); reflexivity). -rewrite S_INR in H5. -assert (H6 : (INR n + 1 + -1 <= M + -1)%R). { - apply Rplus_le_compat_r. - assumption. -} -rewrite Rplus_assoc in H6. -rewrite Rplus_opp_r in H6. -rewrite (Rplus_comm (INR n) 0) in H6. -rewrite Rplus_0_l in H6. -assumption. -Qed. - -(** * Decidability of negated formulas *) - -Lemma sig_not_dec : forall P : Prop, {not (not P)} + {not P}. -Proof. -intros P. -set (E := fun x => x = R0 \/ (x = R1 /\ P)). -destruct (completeness E) as [x H]. -- exists R1. - intros x [->|[-> _]]. - + apply Rle_0_1. - + apply Rle_refl. -- exists R0. - now left. -- destruct (Rle_lt_dec 1 x) as [H'|H']. - + left. - intros HP. - elim Rle_not_lt with (1 := H'). - apply Rle_lt_trans with (2 := Rlt_0_1). - apply H. - intros y [->|[_ Hy]]. - * apply Rle_refl. - * now elim HP. - + right. - intros HP. - apply Rlt_not_le with (1 := H'). - apply H. - right. - now split. -Qed. diff --git a/stdlib/theories/Reals/Rminmax.v b/stdlib/theories/Reals/Rminmax.v deleted file mode 100644 index 8f5be32f3988..000000000000 --- a/stdlib/theories/Reals/Rminmax.v +++ /dev/null @@ -1,127 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* Rmax x y = x. -Proof. - unfold Rmax. intros. - destruct Rle_dec as [H'|H']; [| apply Rnot_le_lt in H' ]; - unfold Rle in *; intuition. -Qed. - -Lemma Rmax_r : forall x y, x<=y -> Rmax x y = y. -Proof. - unfold Rmax. intros. - destruct Rle_dec as [H'|H']; [| apply Rnot_le_lt in H' ]; - unfold Rle in *; intuition. -Qed. - -Lemma Rmin_l : forall x y, x<=y -> Rmin x y = x. -Proof. - unfold Rmin. intros. - destruct Rle_dec as [H'|H']; [| apply Rnot_le_lt in H' ]; - unfold Rle in *; intuition. -Qed. - -Lemma Rmin_r : forall x y, y<=x -> Rmin x y = y. -Proof. - unfold Rmin. intros. - destruct Rle_dec as [H'|H']; [| apply Rnot_le_lt in H' ]; - unfold Rle in *; intuition. -Qed. - -Module RHasMinMax <: HasMinMax R_as_OT. - Definition max := Rmax. - Definition min := Rmin. - Definition max_l := Rmax_l. - Definition max_r := Rmax_r. - Definition min_l := Rmin_l. - Definition min_r := Rmin_r. -End RHasMinMax. - -Module R. - -(** We obtain hence all the generic properties of max and min. *) - -Include UsualMinMaxProperties R_as_OT RHasMinMax. - -(** * Properties specific to the [R] domain *) - -(** Compatibilities (consequences of monotonicity) *) - -Lemma plus_max_distr_l : forall n m p, Rmax (p + n) (p + m) = p + Rmax n m. -Proof. - intros. apply max_monotone. - intros x y. apply Rplus_le_compat_l. -Qed. - -Lemma plus_max_distr_r : forall n m p, Rmax (n + p) (m + p) = Rmax n m + p. -Proof. - intros. rewrite (Rplus_comm n p), (Rplus_comm m p), (Rplus_comm _ p). - apply plus_max_distr_l. -Qed. - -Lemma plus_min_distr_l : forall n m p, Rmin (p + n) (p + m) = p + Rmin n m. -Proof. - intros. apply min_monotone. - intros x y. apply Rplus_le_compat_l. -Qed. - -Lemma plus_min_distr_r : forall n m p, Rmin (n + p) (m + p) = Rmin n m + p. -Proof. - intros. rewrite (Rplus_comm n p), (Rplus_comm m p), (Rplus_comm _ p). - apply plus_min_distr_l. -Qed. - -(** Anti-monotonicity swaps the role of [min] and [max] *) - -Lemma opp_max_distr : forall n m : R, -(Rmax n m) = Rmin (- n) (- m). -Proof. - intros. symmetry. apply min_max_antimonotone. - do 3 red. intros; apply Rge_le. apply Ropp_le_ge_contravar; auto. -Qed. - -Lemma opp_min_distr : forall n m : R, - (Rmin n m) = Rmax (- n) (- m). -Proof. - intros. symmetry. apply max_min_antimonotone. - do 3 red. intros; apply Rge_le. apply Ropp_le_ge_contravar; auto. -Qed. - -Lemma minus_max_distr_l : forall n m p, Rmax (p - n) (p - m) = p - Rmin n m. -Proof. - unfold Rminus. intros. rewrite opp_min_distr. apply plus_max_distr_l. -Qed. - -Lemma minus_max_distr_r : forall n m p, Rmax (n - p) (m - p) = Rmax n m - p. -Proof. - unfold Rminus. intros. apply plus_max_distr_r. -Qed. - -Lemma minus_min_distr_l : forall n m p, Rmin (p - n) (p - m) = p - Rmax n m. -Proof. - unfold Rminus. intros. rewrite opp_max_distr. apply plus_min_distr_l. -Qed. - -Lemma minus_min_distr_r : forall n m p, Rmin (n - p) (m - p) = Rmin n m - p. -Proof. - unfold Rminus. intros. apply plus_min_distr_r. -Qed. - -End R. diff --git a/stdlib/theories/Reals/Rpow_def.v b/stdlib/theories/Reals/Rpow_def.v deleted file mode 100644 index 9081c4ef4732..000000000000 --- a/stdlib/theories/Reals/Rpow_def.v +++ /dev/null @@ -1,17 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* 1 - | S n => Rmult r (pow r n) - end. diff --git a/stdlib/theories/Reals/Rpower.v b/stdlib/theories/Reals/Rpower.v deleted file mode 100644 index 5ac329b54891..000000000000 --- a/stdlib/theories/Reals/Rpower.v +++ /dev/null @@ -1,879 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* R->R; main properties *) -(************************************************************) - -Require Import Rbase. -Require Import Rfunctions. -Require Import SeqSeries. -Require Import Rtrigo1. -Require Import Ranalysis1. -Require Import Exp_prop. -Require Import Rsqrt_def. -Require Import R_sqrt. -Require Import Sqrt_reg. -Require Import MVT. -Require Import Ranalysis4. -Require Import Lra. -Require Import Arith.Factorial. -Local Open Scope R_scope. - -Definition P_Rmin_stt (P:R -> Prop) x y := Rmin_case x y P. -#[deprecated(since="8.16", note="Use Rmin_case instead.")] -Notation P_Rmin := P_Rmin_stt. - -Lemma exp_le_3 : exp 1 <= 3. -Proof. - assert (exp_1 : exp 1 <> 0). { - assert (H0 := exp_pos 1); red; intro; rewrite H in H0; - elim (Rlt_irrefl _ H0). - } - apply Rmult_le_reg_l with (/ exp 1). - { apply Rinv_0_lt_compat; apply exp_pos. } - rewrite Rinv_l. - 2:assumption. - apply Rmult_le_reg_l with (/ 3). - { lra. } - rewrite Rmult_1_r; rewrite <- (Rmult_comm 3); rewrite <- Rmult_assoc; - rewrite Rinv_l. - 2:lra. - rewrite Rmult_1_l; replace (/ exp 1) with (exp (-1)). - 2:{ apply Rmult_eq_reg_l with (exp 1). - 2:assumption. - rewrite <- exp_plus; rewrite Rplus_opp_r; rewrite exp_0; - rewrite Rinv_r;trivial. } - unfold exp; case (exist_exp (-1)) as (?,e); simpl in |- *; - unfold exp_in in e; - assert (H := alternated_series_ineq (fun i:nat => / INR (fact i)) x 1). - cut - (sum_f_R0 (tg_alt (fun i:nat => / INR (fact i))) (S (2 * 1)) <= x <= - sum_f_R0 (tg_alt (fun i:nat => / INR (fact i))) (2 * 1)). - { intro; elim H0; clear H0; intros H0 _; simpl in H0; unfold tg_alt in H0; - simpl in H0. - replace (/ 3) with - (1 * / 1 + -1 * 1 * / 1 + -1 * (-1 * 1) * / 2 + - -1 * (-1 * (-1 * 1)) * / (2 + 1 + 1 + 1 + 1)) by field. - apply H0. } - apply H. - - unfold Un_decreasing; intros; - apply Rmult_le_reg_l with (INR (fact n)). - { apply INR_fact_lt_0. } - apply Rmult_le_reg_l with (INR (fact (S n))). - { apply INR_fact_lt_0. } - rewrite Rinv_r. - 2:{ apply INR_fact_neq_0. } - rewrite Rmult_1_r; rewrite Rmult_comm; rewrite Rmult_assoc; - rewrite Rinv_l. - 2:{ apply INR_fact_neq_0. } - rewrite Rmult_1_r; apply le_INR; apply fact_le; apply Nat.le_succ_diag_r. - - assert (H0 := cv_speed_pow_fact 1); unfold Un_cv; unfold Un_cv in H0; - intros; elim (H0 _ H1); intros; exists x0; intros; - unfold Rdist in H2; unfold Rdist; - replace (/ INR (fact n)) with (1 ^ n / INR (fact n));auto. - unfold Rdiv; rewrite pow1; rewrite Rmult_1_l; reflexivity. - - unfold infinite_sum in e; unfold Un_cv, tg_alt; intros; elim (e _ H0); - intros; exists x0; intros; - replace (sum_f_R0 (fun i:nat => (-1) ^ i * / INR (fact i)) n) with - (sum_f_R0 (fun i:nat => / INR (fact i) * (-1) ^ i) n);auto. - apply sum_eq; intros; apply Rmult_comm. -Qed. - -(******************************************************************) -(** * Properties of Exp *) -(******************************************************************) - -Lemma exp_neq_0 : forall x:R, exp x <> 0. -Proof. - intro x. - exact (not_eq_sym (Rlt_not_eq 0 (exp x) (exp_pos x))). -Qed. - -Theorem exp_increasing : forall x y:R, x < y -> exp x < exp y. -Proof. - intros x y H. - assert (H0 : derivable exp). - - apply derivable_exp. - - assert (H1 := positive_derivative _ H0). - unfold strict_increasing in H1. - apply H1. - + intro. - replace (derive_pt exp x0 (H0 x0)) with (exp x0). - * apply exp_pos. - * symmetry ; apply derive_pt_eq_0. - apply (derivable_pt_lim_exp x0). - + apply H. -Qed. - -Theorem exp_lt_inv : forall x y:R, exp x < exp y -> x < y. -Proof. - intros x y H; case (Rtotal_order x y); [ intros H1 | intros [H1| H1] ]. - - assumption. - - rewrite H1 in H; elim (Rlt_irrefl _ H). - - assert (H2 := exp_increasing _ _ H1). - elim (Rlt_irrefl _ (Rlt_trans _ _ _ H H2)). -Qed. - -Lemma exp_ineq1 : forall x : R, x <> 0 -> 1 + x < exp x. -Proof. - assert (Hd : forall c : R, - derivable_pt_lim (fun x : R => exp x - (x + 1)) c (exp c - 1)). { - intros. - apply derivable_pt_lim_minus; [apply derivable_pt_lim_exp | ]. - replace (1) with (1 + 0) at 1 by lra. - apply derivable_pt_lim_plus; - [apply derivable_pt_lim_id | apply derivable_pt_lim_const]. - } - intros x xdz; destruct (Rtotal_order x 0) as [xlz|[xez|xgz]]. - - destruct (MVT_cor2 _ _ x 0 xlz (fun c _ => Hd c)) as [c [HH1 HH2]]. - rewrite exp_0 in HH1. - assert (H1 : 0 < x * exp c - x); [| lra]. - assert (H2 : x * exp 0 < x * exp c); [| rewrite exp_0 in H2; lra]. - apply Rmult_lt_gt_compat_neg_l; auto. - now apply exp_increasing. - - now case xdz. - - destruct (MVT_cor2 _ _ 0 x xgz (fun c _ => Hd c)) as [c [HH1 HH2]]. - rewrite exp_0 in HH1. - assert (H1 : 0 < x * exp c - x); [| lra]. - assert (H2 : x * exp 0 < x * exp c); [| rewrite exp_0 in H2; lra]. - apply Rmult_lt_compat_l; auto. - now apply exp_increasing. -Qed. - -Lemma exp_ineq1_le (x : R) : 1 + x <= exp x. -Proof. - destruct (Req_dec x 0) as [xeq|?]. - - rewrite xeq, exp_0; lra. - - left. - now apply exp_ineq1. -Qed. - -Lemma ln_exists1 : forall y:R, 1 <= y -> { z:R | y = exp z }. -Proof. - intros; set (f := fun x:R => exp x - y). - assert (H0 : 0 < y) by (apply Rlt_le_trans with 1; auto with real). - cut (f 0 <= 0); [intro H1|]. - - cut (continuity f); [intro H2|]. - + cut (0 <= f y); [intro H3|]. - * cut (f 0 * f y <= 0); [intro H4|]. - -- pose proof (IVT_cor f 0 y H2 (Rlt_le _ _ H0) H4) as (t,(_,H7)); - exists t; unfold f in H7; symmetry; apply Rminus_diag_uniq; exact H7. - -- pattern 0 at 2; rewrite <- (Rmult_0_r (f y)); - rewrite (Rmult_comm (f 0)); apply Rmult_le_compat_l; - assumption. - * unfold f; apply Rplus_le_reg_l with y; left; - apply Rlt_trans with (1 + y). - -- rewrite <- (Rplus_comm y); apply Rplus_lt_compat_l; apply Rlt_0_1. - -- replace (y + (exp y - y)) with (exp y); [ apply (exp_ineq1 y); lra | ring ]. - + unfold f; change (continuity (exp - fct_cte y)); - apply continuity_minus; - [ apply derivable_continuous; apply derivable_exp - | apply derivable_continuous; apply derivable_const ]. - - unfold f; rewrite exp_0; apply Rplus_le_reg_l with y; - rewrite Rplus_0_r; replace (y + (1 - y)) with 1; [ apply H | ring ]. -Qed. - -(**********) -Lemma ln_exists : forall y:R, 0 < y -> { z:R | y = exp z }. -Proof. - intros; destruct (Rle_dec 1 y) as [Hle|Hnle]. - - apply (ln_exists1 _ Hle). - - assert (H0 : 1 <= / y). - + apply Rmult_le_reg_l with y. - * apply H. - * rewrite Rinv_r. - -- rewrite Rmult_1_r; left; apply (Rnot_le_lt _ _ Hnle). - -- red; intro; rewrite H0 in H; elim (Rlt_irrefl _ H). - + destruct (ln_exists1 _ H0) as (x,p); exists (- x); - apply Rmult_eq_reg_l with (exp x / y). - * unfold Rdiv; rewrite Rmult_assoc; rewrite Rinv_l. - -- rewrite Rmult_1_r; rewrite <- (Rmult_comm (/ y)); rewrite Rmult_assoc; - rewrite <- exp_plus; rewrite Rplus_opp_r; rewrite exp_0; - rewrite Rmult_1_r; symmetry ; apply p. - -- red; intro H3; rewrite H3 in H; elim (Rlt_irrefl _ H). - * unfold Rdiv; apply prod_neq_R0. - -- assert (H3 := exp_pos x); red; intro H4; rewrite H4 in H3; - elim (Rlt_irrefl _ H3). - -- apply Rinv_neq_0_compat; red; intro H3; rewrite H3 in H; - elim (Rlt_irrefl _ H). -Qed. - -(* Definition of log R+* -> R *) -Definition Rln (y:posreal) : R := - let (a,_) := ln_exists (pos y) (cond_pos y) in a. - -(* Extension on R *) -Definition ln (x:R) : R := - match Rlt_dec 0 x with - | left a => Rln (mkposreal x a) - | right a => 0 - end. - -Definition Rlog x y := (ln y)/(ln x). - -Lemma exp_ln : forall x:R, 0 < x -> exp (ln x) = x. -Proof. - intros; unfold ln; decide (Rlt_dec 0 x) with H. - unfold Rln; - case (ln_exists (mkposreal x H) (cond_pos (mkposreal x H))) as (?,Hex). - symmetry; apply Hex. -Qed. - -Theorem exp_inv : forall x y:R, exp x = exp y -> x = y. -Proof. - intros x y H; case (Rtotal_order x y); [ intros H1 | intros [H1| H1] ]; auto; - assert (H2 := exp_increasing _ _ H1); rewrite H in H2; - elim (Rlt_irrefl _ H2). -Qed. - -Theorem exp_Ropp : forall x:R, exp (- x) = / exp x. -Proof. - intros x; assert (H : exp x <> 0). - - assert (H := exp_pos x); red; intro; rewrite H0 in H; - elim (Rlt_irrefl _ H). - - apply Rmult_eq_reg_l with (r := exp x). - + rewrite <- exp_plus; rewrite Rplus_opp_r; rewrite exp_0. - symmetry; apply Rinv_r. - apply H. - + apply H. -Qed. - -(******************************************************************) -(** * Properties of Ln *) -(******************************************************************) - -Theorem ln_increasing : forall x y:R, 0 < x -> x < y -> ln x < ln y. -Proof. - intros x y H H0; apply exp_lt_inv. - repeat rewrite exp_ln. - - apply H0. - - apply Rlt_trans with x; assumption. - - apply H. -Qed. - -Theorem ln_exp : forall x:R, ln (exp x) = x. -Proof. - intros x; apply exp_inv. - apply exp_ln. - apply exp_pos. -Qed. - -Theorem ln_1 : ln 1 = 0. -Proof. - rewrite <- exp_0; rewrite ln_exp; reflexivity. -Qed. - -Theorem ln_lt_inv : forall x y:R, 0 < x -> 0 < y -> ln x < ln y -> x < y. -Proof. - intros x y H H0 H1; rewrite <- (exp_ln x); try rewrite <- (exp_ln y). - - apply exp_increasing; apply H1. - - assumption. - - assumption. -Qed. - -Theorem ln_inv : forall x y:R, 0 < x -> 0 < y -> ln x = ln y -> x = y. -Proof. - intros x y H H0 H'0; case (Rtotal_order x y); [ intros H1 | intros [H1| H1] ]; - auto. - - assert (H2 := ln_increasing _ _ H H1); rewrite H'0 in H2; - elim (Rlt_irrefl _ H2). - - assert (H2 := ln_increasing _ _ H0 H1); rewrite H'0 in H2; - elim (Rlt_irrefl _ H2). -Qed. - -Lemma ln_neq_0 : forall x:R, x <> 1 -> 0 < x -> ln x <> 0. -Proof. - intros x Hneq_x_1 Hlt_0_x. - rewrite <- ln_1. - intro H. - assert (x = 1) as H0. - + exact (ln_inv x 1 Hlt_0_x (ltac:(lra) : 0 < 1) H). - + contradiction. -Qed. - -Theorem ln_mult : forall x y:R, 0 < x -> 0 < y -> ln (x * y) = ln x + ln y. -Proof. - intros x y H H0; apply exp_inv. - rewrite exp_plus. - repeat rewrite exp_ln. - - reflexivity. - - assumption. - - assumption. - - apply Rmult_lt_0_compat; assumption. -Qed. - -Lemma ln_pow : forall (x : R), 0 < x -> forall (n : nat), ln (x^n) = (INR n)*(ln x). -Proof. - intros x Hx. - induction n as [|m Hm]. - + simpl. - rewrite ln_1. - exact (eq_sym (Rmult_0_l (ln x))). - + unfold pow. - fold pow. - rewrite (ln_mult x (x^m) Hx (pow_lt x m Hx)). - rewrite Hm. - rewrite <- (Rmult_1_l (ln x)) at 1. - rewrite <- (Rmult_plus_distr_r 1 (INR m) (ln x)). - rewrite (Rplus_comm 1 (INR m)). - destruct m as [|m]; simpl. - - lra. - - reflexivity. -Qed. - -Theorem ln_Rinv : forall x:R, 0 < x -> ln (/ x) = - ln x. -Proof. - intros x H; apply exp_inv; repeat rewrite exp_ln || rewrite exp_Ropp. - - reflexivity. - - assumption. - - apply Rinv_0_lt_compat; assumption. -Qed. - -Theorem ln_continue : - forall y:R, 0 < y -> continue_in ln (fun x:R => 0 < x) y. -Proof. - intros y H. - unfold continue_in, limit1_in, limit_in; intros eps Heps. - assert (H1:1 < exp eps). { - rewrite <- exp_0. - apply exp_increasing; apply Heps. - } - assert (H2:exp (- eps) < 1). { - apply Rmult_lt_reg_l with (exp eps). - - apply exp_pos. - - rewrite <- exp_plus; rewrite Rmult_1_r; rewrite Rplus_opp_r; rewrite exp_0; - apply H1. - } - exists (Rmin (y * (exp eps - 1)) (y * (1 - exp (- eps)))); split. - { red; apply Rmin_case; nra. } - unfold dist, R_met, Rdist; simpl. - intros x [[H3 H4] H5]. - assert (Hxyy:y * (x * / y) = x). { - field. lra. - } - replace (ln x - ln y) with (ln (x * / y)). - 2:{ rewrite ln_mult;try apply Rinv_0_lt_compat; try assumption. - rewrite ln_Rinv;try assumption. - ring. } - pose proof (Rinv_0_lt_compat y) as Hinvy. - case (Rtotal_order x y); [ intros Hxy | intros [Hxy| Hxy] ]. - - rewrite Rabs_left. - 2:{ rewrite <- ln_1. - apply ln_increasing;nra. } - apply Ropp_lt_cancel; rewrite Ropp_involutive. - apply exp_lt_inv. - rewrite exp_ln. - 2:nra. - apply Rmult_lt_reg_l with (r := y). - { apply H. } - rewrite Hxyy. - apply Ropp_lt_cancel. - apply Rplus_lt_reg_l with (r := y). - replace (y + - (y * exp (- eps))) with (y * (1 - exp (- eps))); - [ idtac | ring ]. - replace (y + - x) with (Rabs (x - y)). - 2:{ rewrite Rabs_left; [ ring | idtac ]. - lra. } - apply Rlt_le_trans with (1 := H5); apply Rmin_r. - - rewrite Hxy; rewrite Rinv_r. - 2:lra. - rewrite ln_1; rewrite Rabs_R0; apply Heps. - - rewrite Rabs_right. - 2:{ rewrite <- ln_1. - apply Rgt_ge; red; apply ln_increasing;nra. } - apply exp_lt_inv. - rewrite exp_ln. - 2:nra. - apply Rmult_lt_reg_l with (r := y). - { apply H. } - rewrite Hxyy. - apply Rplus_lt_reg_l with (r := - y). - replace (- y + y * exp eps) with (y * (exp eps - 1)); [ idtac | ring ]. - replace (- y + x) with (Rabs (x - y)). - 2:{ rewrite Rabs_right; [ ring | idtac ]. lra. } - apply Rlt_le_trans with (1 := H5); apply Rmin_l. -Qed. - -(******************************************************************) -(** * Definition of Rpower *) -(******************************************************************) - -Definition Rpower (x y:R) := exp (y * ln x). - -(******************************************************************) -(** * Properties of Rpower *) -(******************************************************************) - -(** Note: [Rpower] is prolongated to [1] on negative real numbers and - it thus does not extend integer power. The next two lemmas, which - hold for integer power, accidentally hold on negative real numbers - as a side effect of the default value taken on negative real - numbers. Contrastingly, the lemmas that do not hold for the - integer power of a negative number are stated for [Rpower] on the - positive numbers only (even if they accidentally hold due to the - default value of [Rpower] on the negative side, as it is the case - for [Rpower_O]). *) - -Theorem Rpower_plus : forall x y z:R, Rpower z (x + y) = Rpower z x * Rpower z y. -Proof. - intros x y z; unfold Rpower. - rewrite Rmult_plus_distr_r; rewrite exp_plus; auto. -Qed. - -Theorem Rpower_mult : forall x y z:R, Rpower (Rpower x y) z = Rpower x (y * z). -Proof. - intros x y z; unfold Rpower. - rewrite ln_exp. - replace (z * (y * ln x)) with (y * z * ln x). - - reflexivity. - - ring. -Qed. - -Theorem Rpower_O : forall x:R, 0 < x -> Rpower x 0 = 1. -Proof. - intros x _; unfold Rpower. - rewrite Rmult_0_l; apply exp_0. -Qed. - -Theorem Rpower_1 : forall x:R, 0 < x -> Rpower x 1 = x. -Proof. - intros x H; unfold Rpower. - rewrite Rmult_1_l; apply exp_ln; apply H. -Qed. - -Theorem Rpower_pow : forall (n:nat) (x:R), 0 < x -> Rpower x (INR n) = x ^ n. -Proof. - intros n; elim n; simpl; auto; fold INR. - - intros x H; apply Rpower_O; auto. - - intros n1; case n1. - + intros H x H0; simpl; rewrite Rmult_1_r; apply Rpower_1; auto. - + intros n0 H x H0; rewrite Rpower_plus; rewrite H; try rewrite Rpower_1; - try apply Rmult_comm || assumption. -Qed. - -Lemma Rpower_nonzero : forall (x : R) (n : nat), 0 < x -> Rpower x (INR n) <> 0. -Proof. - intros x n H. - rewrite (Rpower_pow n x H). - exact (pow_nonzero x n (not_eq_sym (Rlt_not_eq 0 x H))). -Qed. - -Theorem Rpower_lt : - forall x y z:R, 1 < x -> y < z -> Rpower x y < Rpower x z. -Proof. - intros x y z H H1. - unfold Rpower. - apply exp_increasing. - apply Rmult_lt_compat_r. - - rewrite <- ln_1; apply ln_increasing. - + apply Rlt_0_1. - + apply H. - - apply H1. -Qed. - -Lemma Rpower_Rlog : forall x y:R, x <> 1 -> 0 < x -> 0 < y -> Rpower x (Rlog x y) = y. -Proof. - intros x y H_neq_x_1 H_lt_0_x H_lt_0_y. - unfold Rpower. - unfold Rlog. - unfold Rdiv. - rewrite (Rmult_assoc (ln y) (/ln x) (ln x)). - rewrite (Rinv_l (ln x) (ln_neq_0 x H_neq_x_1 H_lt_0_x)). - rewrite (Rmult_1_r (ln y)). - exact (exp_ln y H_lt_0_y). -Qed. - -Theorem Rpower_sqrt : forall x:R, 0 < x -> Rpower x (/ 2) = sqrt x. -Proof. - intros x H. - apply ln_inv. - - unfold Rpower; apply exp_pos. - - apply sqrt_lt_R0; apply H. - - apply Rmult_eq_reg_l with (INR 2). - + apply exp_inv. - fold Rpower. - cut (Rpower (Rpower x (/ INR 2)) (INR 2) = Rpower (sqrt x) (INR 2)). - * unfold Rpower; auto. - * rewrite Rpower_mult. - rewrite Rinv_l. - -- change 1 with (INR 1). - repeat rewrite Rpower_pow; simpl. - ++ pattern x at 1; rewrite <- (sqrt_sqrt x (Rlt_le _ _ H)). - ring. - ++ apply sqrt_lt_R0; apply H. - ++ apply H. - -- apply not_O_INR; discriminate. - + apply not_O_INR; discriminate. -Qed. - -Theorem Rpower_Ropp : forall x y:R, Rpower x (- y) = / (Rpower x y). -Proof. - unfold Rpower. - intros x y; rewrite Ropp_mult_distr_l_reverse. - apply exp_Ropp. -Qed. - -Lemma powerRZ_Rpower x z : (0 < x)%R -> powerRZ x z = Rpower x (IZR z). -Proof. - intros Hx. - destruct (intP z). - - now rewrite Rpower_O. - - rewrite <- pow_powerRZ, <- Rpower_pow by assumption. - now rewrite INR_IZR_INZ. - - rewrite opp_IZR, Rpower_Ropp. - rewrite powerRZ_neg'. - now rewrite <- pow_powerRZ, <- INR_IZR_INZ, Rpower_pow. -Qed. - -Theorem Rle_Rpower : - forall e n m:R, 1 <= e -> n <= m -> Rpower e n <= Rpower e m. -Proof. - intros e n m [H | H]; intros H1. - - case H1. - + intros H2; left; apply Rpower_lt; assumption. - + intros H2; rewrite H2; right; reflexivity. - - now rewrite <- H; unfold Rpower; rewrite ln_1, !Rmult_0_r; apply Rle_refl. -Qed. - -Lemma ln_Rpower : forall x y:R, ln (Rpower x y) = y * ln x. -Proof. - intros x y. - unfold Rpower. - rewrite (ln_exp (y * ln x)). - reflexivity. -Qed. - -Lemma Rlog_pow : forall (x : R) (n : nat), x <> 1 -> 0 < x -> Rlog x (x^n) = INR n. -Proof. - intros x n H_neq_x_1 H_lt_0_x. - rewrite <- (Rpower_pow n x H_lt_0_x). - unfold Rpower. - unfold Rlog. - rewrite (ln_exp (INR n * ln x)). - unfold Rdiv. - rewrite (Rmult_assoc (INR n) (ln x) (/ln x)). - rewrite (Rinv_r (ln x) (ln_neq_0 x H_neq_x_1 H_lt_0_x)). - exact (Rmult_1_r (INR n)). -Qed. - -Theorem ln_lt_2 : / 2 < ln 2. -Proof. - apply Rmult_lt_reg_l with (r := 2). - - prove_sup0. - - rewrite Rinv_r. - + apply exp_lt_inv. - apply Rle_lt_trans with (1 := exp_le_3). - change (3 < Rpower 2 (1 + 1)). - repeat rewrite Rpower_plus; repeat rewrite Rpower_1. - * now apply (IZR_lt 3 4). - * prove_sup0. - + discrR. -Qed. - -(*****************************************) -(** * Differentiability of Ln and Rpower *) -(*****************************************) - -Theorem limit1_ext : - forall (f g:R -> R) (D:R -> Prop) (l x:R), - (forall x:R, D x -> f x = g x) -> limit1_in f D l x -> limit1_in g D l x. -Proof. - intros f g D l x H; unfold limit1_in, limit_in. - intros H0 eps H1; case (H0 eps); auto. - intros x0 [H2 H3]; exists x0; split; auto. - intros x1 [H4 H5]; rewrite <- H; auto. -Qed. - -Theorem limit1_imp : - forall (f:R -> R) (D D1:R -> Prop) (l x:R), - (forall x:R, D1 x -> D x) -> limit1_in f D l x -> limit1_in f D1 l x. -Proof. - intros f D D1 l x H; unfold limit1_in, limit_in. - intros H0 eps H1; case (H0 eps H1); auto. - intros alpha [H2 H3]; exists alpha; split; auto. - intros d [H4 H5]; apply H3; split; auto. -Qed. - -Theorem Rinv_Rdiv_depr : forall x y:R, x <> 0 -> y <> 0 -> / (x / y) = y / x. -Proof. - intros x y _ _. - apply Rinv_div. -Qed. - -#[deprecated(since="8.16",note="Use Rinv_div.")] -Notation Rinv_Rdiv := Rinv_Rdiv_depr. - -Theorem Dln : forall y:R, 0 < y -> D_in ln Rinv (fun x:R => 0 < x) y. -Proof. - intros y Hy; unfold D_in. - apply limit1_ext with - (f := fun x:R => / ((exp (ln x) - exp (ln y)) / (ln x - ln y))). - { intros x [HD1 HD2]; repeat rewrite exp_ln. - 2,3:assumption. - unfold Rdiv; rewrite Rinv_mult. - rewrite Rinv_inv. - apply Rmult_comm. } - apply limit_inv with - (f := fun x:R => (exp (ln x) - exp (ln y)) / (ln x - ln y)). - 2:lra. - apply limit1_imp with - (f := fun x:R => (fun x:R => (exp x - exp (ln y)) / (x - ln y)) (ln x)) - (D := Dgf (D_x (fun x:R => 0 < x) y) (D_x (fun x:R => True) (ln y)) ln). - { intros x [H1 H2]; split. - - split; auto. - - split; auto. - red; intros H3; case H2; apply ln_inv; auto. } - apply limit_comp with - (l := ln y) (g := fun x:R => (exp x - exp (ln y)) / (x - ln y)) (f := ln). - { apply ln_continue; auto. } - assert (H0 := derivable_pt_lim_exp (ln y)); unfold derivable_pt_lim in H0; - unfold limit1_in; unfold limit_in; - simpl; unfold Rdist; intros; elim (H0 _ H); - intros; exists (pos x); split. - { apply (cond_pos x). } - intros; pattern y at 3; rewrite <- exp_ln. - 2:assumption. - pattern x0 at 1; replace x0 with (ln y + (x0 - ln y)); - [ idtac | ring ]. - apply H1. - { elim H2; intros H3 _; unfold D_x in H3; elim H3; clear H3; intros _ H3; - apply Rminus_eq_contra; apply (not_eq_sym (A:=R)); - apply H3. } - elim H2; clear H2; intros _ H2; apply H2. -Qed. - -Lemma derivable_pt_lim_ln : forall x:R, 0 < x -> derivable_pt_lim ln x (/ x). -Proof. - intros; assert (H0 := Dln x H); unfold D_in in H0; unfold limit1_in in H0; - unfold limit_in in H0; simpl in H0; unfold Rdist in H0; - unfold derivable_pt_lim; intros; elim (H0 _ H1); - intros; elim H2; clear H2; intros; set (alp := Rmin x0 (x / 2)); - assert (H4 : 0 < alp). - { unfold alp; unfold Rmin; case (Rle_dec x0 (x / 2)); intro;unfold Rdiv;lra. } - exists (mkposreal _ H4); intros; pattern h at 2; - replace h with (x + h - x); [ idtac | ring ]. - apply H3; split. - 2:{ replace (x + h - x) with h by ring. - apply Rlt_le_trans with alp; - [ apply H6 | unfold alp; apply Rmin_l ]. } - unfold D_x; split. - 2:lra. - pose proof (Rmin_r _ _ : alp <= _) as H7. - unfold Rdiv in H7. - unfold Rabs in H6. simpl in H6. - destruct (Rcase_abs h) as [Hlt|Hgt];lra. -Qed. - -Theorem D_in_imp : - forall (f g:R -> R) (D D1:R -> Prop) (x:R), - (forall x:R, D1 x -> D x) -> D_in f g D x -> D_in f g D1 x. -Proof. - intros f g D D1 x H; unfold D_in. - intros H0; apply limit1_imp with (D := D_x D x); auto. - intros x1 [H1 H2]; split; auto. -Qed. - -Theorem D_in_ext : - forall (f g h:R -> R) (D:R -> Prop) (x:R), - f x = g x -> D_in h f D x -> D_in h g D x. -Proof. - intros f g h D x H; unfold D_in. - rewrite H; auto. -Qed. - -Theorem Dpower : - forall y z:R, - 0 < y -> - D_in (fun x:R => Rpower x z) (fun x:R => z * Rpower x (z - 1)) ( - fun x:R => 0 < x) y. -Proof. - intros y z H; - apply D_in_imp with (D := Dgf (fun x:R => 0 < x) (fun x:R => True) ln). - { intros x H0; repeat split. - assumption. } - apply D_in_ext with (f := fun x:R => / x * (z * exp (z * ln x))). - { unfold Rminus; rewrite Rpower_plus; rewrite Rpower_Ropp; - rewrite (Rpower_1 _ H); unfold Rpower; ring. } - apply Dcomp with - (f := ln) - (g := fun x:R => exp (z * x)) - (df := Rinv) - (dg := fun x:R => z * exp (z * x)). - { apply (Dln _ H). } - apply D_in_imp with - (D := Dgf (fun x:R => True) (fun x:R => True) (fun x:R => z * x)). - { intros x H1; repeat split; auto. } - apply - (Dcomp (fun _:R => True) (fun _:R => True) (fun x => z) exp - (fun x:R => z * x) exp); simpl. - - apply D_in_ext with (f := fun x:R => z * 1). - { apply Rmult_1_r. } - apply (Dmult_const (fun x => True) (fun x => x) (fun x => 1)); apply Dx. - - assert (H0 := derivable_pt_lim_D_in exp exp (z * ln y)); elim H0; clear H0; - intros _ H0; apply H0; apply derivable_pt_lim_exp. -Qed. - -Theorem derivable_pt_lim_power : - forall x y:R, - 0 < x -> derivable_pt_lim (fun x => Rpower x y) x (y * Rpower x (y - 1)). -Proof. - intros x y H. - unfold Rminus; rewrite Rpower_plus. - rewrite Rpower_Ropp. - rewrite Rpower_1; auto. - rewrite <- Rmult_assoc. - unfold Rpower. - apply derivable_pt_lim_comp with (f1 := ln) (f2 := fun x => exp (y * x)). - - apply derivable_pt_lim_ln; assumption. - - rewrite (Rmult_comm y). - apply derivable_pt_lim_comp with (f1 := fun x => y * x) (f2 := exp). - + pattern y at 2; replace y with (0 * ln x + y * 1). - * apply derivable_pt_lim_mult with (f1 := fun x:R => y) (f2 := fun x:R => x). - -- apply derivable_pt_lim_const with (a := y). - -- apply derivable_pt_lim_id. - * ring. - + apply derivable_pt_lim_exp. -Qed. - -(* added later. *) - -Lemma Rpower_mult_distr : - forall x y z, 0 < x -> 0 < y -> - Rpower x z * Rpower y z = Rpower (x * y) z. -intros x y z x0 y0; unfold Rpower. -rewrite <- exp_plus, ln_mult, Rmult_plus_distr_l; auto. -Qed. - -Lemma Rlt_Rpower_l a b c: 0 < c -> 0 < a < b -> Rpower a c < Rpower b c. -Proof. -intros c0 [a0 ab]; apply exp_increasing. -now apply Rmult_lt_compat_l; auto; apply ln_increasing; lra. -Qed. - -Lemma Rle_Rpower_l a b c: 0 <= c -> 0 < a <= b -> Rpower a c <= Rpower b c. -Proof. -intros [c0 | c0]; - [ | intros; rewrite <- c0, !Rpower_O; [apply Rle_refl | |] ]. -- intros [a0 [ab|ab]]. - + now apply Rlt_le, Rlt_Rpower_l;[ | split]; lra. - + rewrite ab; apply Rle_refl. -- apply Rlt_le_trans with a; tauto. -- tauto. -Qed. - -(* arcsinh function *) - -Definition arcsinh x := ln (x + sqrt (x ^ 2 + 1)). - -Lemma arcsinh_sinh : forall x, arcsinh (sinh x) = x. -intros x; unfold sinh, arcsinh. -assert (Rminus_eq_0 : forall r, r - r = 0) by (intros; ring). -rewrite <- exp_0, <- (Rminus_eq_0 x); unfold Rminus. -rewrite exp_plus. -match goal with |- context[sqrt ?a] => - replace a with (((exp x + exp(-x))/2)^2) by field -end. -rewrite sqrt_pow2; - [|apply Rlt_le, Rmult_lt_0_compat;[apply Rplus_lt_0_compat; apply exp_pos | - apply Rinv_0_lt_compat, Rlt_0_2]]. -match goal with |- context[ln ?a] => replace a with (exp x) by field end. -rewrite ln_exp; reflexivity. -Qed. - -Lemma sinh_arcsinh x : sinh (arcsinh x) = x. -unfold sinh, arcsinh. -assert (cmp : 0 < x + sqrt (x ^ 2 + 1)). { - destruct (Rle_dec x 0). - - replace (x ^ 2) with ((-x) ^ 2) by ring. - assert (sqrt ((- x) ^ 2) < sqrt ((-x)^2+1)). { - apply sqrt_lt_1_alt. - split;[apply pow_le | ]; lra. - } - pattern x at 1; replace x with (- (sqrt ((- x) ^ 2))). - + assert (t:= sqrt_pos ((-x)^2)); lra. - + simpl; rewrite Rmult_1_r, sqrt_square, Ropp_involutive;[reflexivity | lra]. - - apply Rplus_lt_le_0_compat;[apply Rnot_le_gt; assumption | apply sqrt_pos]. -} -rewrite exp_ln;[ | assumption]. -rewrite exp_Ropp, exp_ln;[ | assumption]. -assert (Rmult_minus_distr_r : - forall x y z, (x - y) * z = x * z - y * z) by (intros; ring). -apply Rminus_diag_uniq; unfold Rdiv; rewrite Rmult_minus_distr_r. -assert (t: forall x y z, x - z = y -> x - y - z = 0);[ | apply t; clear t]. -- intros a b c H; rewrite <- H; ring. -- apply Rmult_eq_reg_l with (2 * (x + sqrt (x ^ 2 + 1)));[ | - apply Rgt_not_eq, Rmult_lt_0_compat;[apply Rlt_0_2 | assumption]]. - field_simplify;[rewrite pow2_sqrt;[field | ] | apply Rgt_not_eq; lra]. - apply Rplus_le_le_0_compat;[simpl; rewrite Rmult_1_r; apply (Rle_0_sqr x)|apply Rlt_le, Rlt_0_1]. -Qed. - -Lemma derivable_pt_lim_arcsinh : - forall x, derivable_pt_lim arcsinh x (/sqrt (x ^ 2 + 1)). -intros x; unfold arcsinh. -assert (0 < x + sqrt (x ^ 2 + 1)). { - destruct (Rle_dec x 0); - [ | assert (0 < x) by (apply Rnot_le_gt; assumption); - apply Rplus_lt_le_0_compat; auto; apply sqrt_pos]. - replace (x ^ 2) with ((-x) ^ 2) by ring. - assert (sqrt ((- x) ^ 2) < sqrt ((-x)^2+1)). { - apply sqrt_lt_1_alt. - split;[apply pow_le|]; lra. - } - pattern x at 1; replace x with (- (sqrt ((- x) ^ 2))). - - assert (t:= sqrt_pos ((-x)^2)); lra. - - simpl; rewrite Rmult_1_r, sqrt_square, Ropp_involutive; auto; lra. -} -assert (0 < x ^ 2 + 1). { - apply Rplus_le_lt_0_compat;[simpl; rewrite Rmult_1_r; apply Rle_0_sqr|lra]. -} -replace (/sqrt (x ^ 2 + 1)) with - (/(x + sqrt (x ^ 2 + 1)) * - (1 + (/(2 * sqrt (x ^ 2 + 1)) * (INR 2 * x ^ 1 + 0)))). -2:{ replace (INR 2 * x ^ 1 + 0) with (2 * x) by (simpl; ring). - replace (1 + / (2 * sqrt (x ^ 2 + 1)) * (2 * x)) with - (((sqrt (x ^ 2 + 1) + x))/sqrt (x ^ 2 + 1)); - [ | field; apply Rgt_not_eq, sqrt_lt_R0; assumption]. - apply Rmult_eq_reg_l with (x + sqrt (x ^ 2 + 1)); - [ | apply Rgt_not_eq; assumption]. - field. - split;apply Rgt_not_eq; auto; apply sqrt_lt_R0; assumption. } -apply (derivable_pt_lim_comp (fun x => x + sqrt (x ^ 2 + 1)) ln). -+ apply (derivable_pt_lim_plus). - * apply derivable_pt_lim_id. - * apply (derivable_pt_lim_comp (fun x => x ^ 2 + 1) sqrt x). - -- apply derivable_pt_lim_plus. - ++ apply derivable_pt_lim_pow. - ++ apply derivable_pt_lim_const. - -- apply derivable_pt_lim_sqrt; assumption. -+ apply derivable_pt_lim_ln; assumption. -Qed. - -Lemma arcsinh_lt : forall x y, x < y -> arcsinh x < arcsinh y. -intros x y xy. -case (Rle_dec (arcsinh y) (arcsinh x));[ | apply Rnot_le_lt ]. -intros abs; case (Rlt_not_le _ _ xy). -rewrite <- (sinh_arcsinh y), <- (sinh_arcsinh x). -destruct abs as [lt | q];[| rewrite q; lra]. -apply Rlt_le, sinh_lt; assumption. -Qed. - -Lemma arcsinh_le : forall x y, x <= y -> arcsinh x <= arcsinh y. -intros x y [xy | xqy]. -- apply Rlt_le, arcsinh_lt; assumption. -- rewrite xqy; apply Rle_refl. -Qed. - -Lemma arcsinh_0 : arcsinh 0 = 0. - unfold arcsinh; rewrite pow_ne_zero, !Rplus_0_l, sqrt_1, ln_1; - [reflexivity | discriminate]. -Qed. diff --git a/stdlib/theories/Reals/Rprod.v b/stdlib/theories/Reals/Rprod.v deleted file mode 100644 index f9698fdbfb0d..000000000000 --- a/stdlib/theories/Reals/Rprod.v +++ /dev/null @@ -1,196 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* R) (N:nat) : R := - match N with - | O => f O - | S p => prod_f_R0 f p * f (S p) - end. - -Notation prod_f_SO := (fun An N => prod_f_R0 (fun n => An (S n)) N). - -(**********) -Lemma prod_SO_split : - forall (An:nat -> R) (n k:nat), - (k < n)%nat -> - prod_f_R0 An n = - prod_f_R0 An k * prod_f_R0 (fun l:nat => An (k +1+l)%nat) (n - k -1). -Proof. - intros; induction n as [| n Hrecn]. - - absurd (k < 0)%nat; lia. - - cut (k = n \/ (k < n)%nat);[intro; elim H0; intro|lia]. - + replace (S n - k - 1)%nat with O; [rewrite H1; simpl|lia]. - replace (n+1+0)%nat with (S n); ring. - + replace (S n - k-1)%nat with (S (n - k-1));[idtac|lia]. - simpl; replace (k + S (n - k))%nat with (S n). - * replace (k + 1 + S (n - k - 1))%nat with (S n). - -- rewrite Hrecn; [ ring | assumption ]. - -- lia. - * lia. -Qed. - -(**********) -Lemma prod_SO_pos : - forall (An:nat -> R) (N:nat), - (forall n:nat, (n <= N)%nat -> 0 <= An n) -> 0 <= prod_f_R0 An N. -Proof. - intros; induction N as [| N HrecN]. - - simpl; apply H; trivial. - - simpl; apply Rmult_le_pos. - + apply HrecN; intros; apply H; apply Nat.le_trans with N; - [ assumption | apply Nat.le_succ_diag_r ]. - + apply H; apply Nat.le_refl. -Qed. - -(**********) -Lemma prod_SO_Rle : - forall (An Bn:nat -> R) (N:nat), - (forall n:nat, (n <= N)%nat -> 0 <= An n <= Bn n) -> - prod_f_R0 An N <= prod_f_R0 Bn N. -Proof. - intros; induction N as [| N HrecN]. - - elim H with O; trivial. - - simpl; apply Rle_trans with (prod_f_R0 An N * Bn (S N)). - + apply Rmult_le_compat_l. - * apply prod_SO_pos; intros; elim (H n (Nat.le_trans _ _ _ H0 (Nat.le_succ_diag_r N))); intros; - assumption. - * elim (H (S N) (le_n (S N))); intros; assumption. - + do 2 rewrite <- (Rmult_comm (Bn (S N))); apply Rmult_le_compat_l. - * elim (H (S N) (le_n (S N))); intros. - apply Rle_trans with (An (S N)); assumption. - * apply HrecN; intros; elim (H n (Nat.le_trans _ _ _ H0 (Nat.le_succ_diag_r N))); intros; - split; assumption. -Qed. - -(** Application to factorial *) -Lemma fact_prodSO : - forall n:nat, INR (fact n) = prod_f_R0 (fun k:nat => - (match (eq_nat_dec k 0) with - | left _ => 1%R - | right _ => INR k - end)) n. -Proof. - intro; induction n as [| n Hrecn]. - - reflexivity. - - simpl; rewrite <- Hrecn. - case n; auto with real. - intros; repeat rewrite plus_INR;rewrite mult_INR;ring. -Qed. - -Lemma le_n_2n : forall n:nat, (n <= 2 * n)%nat. -Proof. - simple induction n. - - replace (2 * 0)%nat with 0%nat; [ apply le_n | ring ]. - - intros; replace (2 * S n0)%nat with (S (S (2 * n0))). - + apply le_n_S; apply le_S; assumption. - + replace (S (S (2 * n0))) with (2 * n0 + 2)%nat; [ idtac | ring ]. - replace (S n0) with (n0 + 1)%nat; [ idtac | ring ]. - ring. -Qed. - -(** We prove that (N!)^2<=(2N-k)!*k! forall k in [|O;2N|] *) -Lemma RfactN_fact2N_factk : - forall N k:nat, - (k <= 2 * N)%nat -> - Rsqr (INR (fact N)) <= INR (fact (2 * N - k)) * INR (fact k). -Proof. - assert (forall (n:nat), 0 <= (if eq_nat_dec n 0 then 1 else INR n)). { - intros; case (eq_nat_dec n 0); auto with real. - } - assert (forall (n:nat), (0 < n)%nat -> - (if eq_nat_dec n 0 then 1 else INR n) = INR n). { - intros n; case (eq_nat_dec n 0); auto with real. - intros; absurd (0 < n)%nat; lia. - } - intros; unfold Rsqr; repeat rewrite fact_prodSO. - assert (H2:(k=N)%nat \/ (k < N)%nat \/ (N < k)%nat) by lia. - elim H2; intro H3. - { rewrite H3; replace (2*N-N)%nat with N by lia;right; ring. } - case H3; intro; clear H2 H3. - + rewrite (prod_SO_split (fun l:nat => if eq_nat_dec l 0 then 1 else INR l) (2 * N - k) N). - 2:{ lia. } - rewrite Rmult_assoc; apply Rmult_le_compat_l. - { apply prod_SO_pos; intros; auto. } - replace (2 * N - k - N-1)%nat with (N - k-1)%nat by lia. - rewrite Rmult_comm; - rewrite (prod_SO_split (fun l:nat => if eq_nat_dec l 0 then 1 else INR l) N k). - 2:{ lia. } - apply Rmult_le_compat_l. - * apply prod_SO_pos; intros; auto. - * apply prod_SO_Rle; intros; split; auto. - rewrite H0. - -- rewrite H0. - ++ apply le_INR; lia. - ++ lia. - -- lia. - + rewrite <- (Rmult_comm (prod_f_R0 (fun l:nat => - if eq_nat_dec l 0 then 1 else INR l) k)); - rewrite (prod_SO_split (fun l:nat => if eq_nat_dec l 0 then 1 else INR l) k N). - 2:{ lia. } - rewrite Rmult_assoc; apply Rmult_le_compat_l. - { apply prod_SO_pos; intros; auto. } - rewrite Rmult_comm; - rewrite (prod_SO_split (fun l:nat => if eq_nat_dec l 0 then 1 else INR l) N (2 * N - k)). - 2:{ lia. } - apply Rmult_le_compat_l. - { apply prod_SO_pos; intros; auto. } - replace (N - (2 * N - k)-1)%nat with (k - N-1)%nat. - 2:{ lia. } - apply prod_SO_Rle; intros; split; auto. - rewrite H0. - 2:{ lia. } - rewrite H0. - 2:{ lia. } - apply le_INR; lia. -Qed. - - -(**********) -Lemma INR_fact_lt_0 : forall n:nat, 0 < INR (fact n). -Proof. - intro; apply lt_INR_0; apply Nat.neq_0_lt_0; red; intro; - elim (fact_neq_0 n); assumption. -Qed. - -(** We have the following inequality : (C 2N k) <= (C 2N N) forall k in [|O;2N|] *) -Lemma C_maj : forall N k:nat, (k <= 2 * N)%nat -> C (2 * N) k <= C (2 * N) N. -Proof. - intros; unfold C; unfold Rdiv; apply Rmult_le_compat_l. - { apply pos_INR. } - replace (2 * N - N)%nat with N. - - apply Rmult_le_reg_l with (INR (fact N) * INR (fact N)). - { apply Rmult_lt_0_compat; apply INR_fact_lt_0. } - rewrite Rinv_r. - + rewrite Rmult_comm; - apply Rmult_le_reg_l with (INR (fact k) * INR (fact (2 * N - k))). - { apply Rmult_lt_0_compat; apply INR_fact_lt_0. } - rewrite Rmult_1_r; rewrite <- mult_INR; rewrite <- Rmult_assoc; - rewrite Rinv_r. - * rewrite Rmult_1_l; rewrite mult_INR; rewrite (Rmult_comm (INR (fact k))); - replace (INR (fact N) * INR (fact N)) with (Rsqr (INR (fact N))). - -- apply RfactN_fact2N_factk. - assumption. - -- reflexivity. - * rewrite mult_INR; apply prod_neq_R0; apply INR_fact_neq_0. - + apply prod_neq_R0; apply INR_fact_neq_0. - - lia. -Qed. diff --git a/stdlib/theories/Reals/Rregisternames.v b/stdlib/theories/Reals/Rregisternames.v deleted file mode 100644 index 9ba1150fa69e..000000000000 --- a/stdlib/theories/Reals/Rregisternames.v +++ /dev/null @@ -1,34 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* R. - -(*********) - Fixpoint Rmax_N (N:nat) : R := - match N with - | O => Un 0 - | S n => Rmax (Un (S n)) (Rmax_N n) - end. - -(*********) - Definition EUn r : Prop := exists i : nat, r = Un i. - -(*********) - Definition Un_cv (l:R) : Prop := - forall eps:R, - eps > 0 -> - exists N : nat, (forall n:nat, (n >= N)%nat -> Rdist (Un n) l < eps). - -(*********) - Definition Cauchy_crit : Prop := - forall eps:R, - eps > 0 -> - exists N : nat, - (forall n m:nat, - (n >= N)%nat -> (m >= N)%nat -> Rdist (Un n) (Un m) < eps). - -(*********) - Definition Un_growing : Prop := forall n:nat, Un n <= Un (S n). - -(*********) - Lemma EUn_noempty : exists r : R, EUn r. - Proof. - unfold EUn; split with (Un 0); split with 0%nat; trivial. - Qed. - -(*********) - Lemma Un_in_EUn : forall n:nat, EUn (Un n). - Proof. - intro; unfold EUn; split with n; trivial. - Qed. - -(*********) - Lemma Un_bound_imp : - forall x:R, (forall n:nat, Un n <= x) -> is_upper_bound EUn x. - Proof. - intros; unfold is_upper_bound; intros; unfold EUn in H0; elim H0; - clear H0; intros; generalize (H x1); intro; rewrite <- H0 in H1; - trivial. - Qed. - -(*********) - Lemma growing_prop : - forall n m:nat, Un_growing -> (n >= m)%nat -> Un n >= Un m. - Proof. - intros * Hgrowing Hle. - induction Hle as [|p]. - - apply Rge_refl. - - apply Rge_trans with (Un p). - + apply Rle_ge, Hgrowing. - + apply IHHle. - Qed. - -(*********) - Lemma Un_cv_crit_lub : Un_growing -> forall l, is_lub EUn l -> Un_cv l. - Proof. - intros Hug l H eps Heps. - - cut (exists N, Un N > l - eps). { - intros (N, H3). - exists N. - intros n H4. - unfold Rdist. - rewrite Rabs_left1, Ropp_minus_distr. - - apply Rplus_lt_reg_l with (Un n - eps). - apply Rlt_le_trans with (Un N). - + now replace (Un n - eps + (l - Un n)) with (l - eps) by ring. - + replace (Un n - eps + eps) with (Un n) by ring. - apply Rge_le. - now apply growing_prop. - - apply Rle_minus. - apply (proj1 H). - now exists n. - } - assert (Hi2pn: forall n, 0 < (/ 2)^n). { - clear. intros n. - apply pow_lt. - apply Rinv_0_lt_compat. - now apply (IZR_lt 0 2). - } - - pose (test := fun n => match Rle_lt_dec (Un n) (l - eps) with left _ => false | right _ => true end). - pose (sum := let fix aux n := match n with S n' => aux n' + - if test n' then (/ 2)^n else 0 | O => 0 end in aux). - - assert (Hsum': forall m n, sum m <= sum (m + n)%nat <= sum m + (/2)^m - (/2)^(m + n)). { - clearbody test. - clear -Hi2pn. - intros m. - induction n. - - rewrite<- plus_n_O. - ring_simplify (sum m + (/ 2) ^ m - (/ 2) ^ m). - split ; apply Rle_refl. - - rewrite <- plus_n_Sm. - simpl. - split. - + apply Rle_trans with (sum (m + n)%nat + 0). - * rewrite Rplus_0_r. - apply IHn. - * apply Rplus_le_compat_l. - case (test (m + n)%nat). - -- apply Rlt_le. - exact (Hi2pn (S (m + n))). - -- apply Rle_refl. - + apply Rle_trans with (sum (m + n)%nat + / 2 * (/ 2) ^ (m + n)). - * apply Rplus_le_compat_l. - case (test (m + n)%nat). - -- apply Rle_refl. - -- apply Rlt_le. - exact (Hi2pn (S (m + n))). - * apply Rplus_le_reg_r with (-(/ 2 * (/ 2) ^ (m + n))). - rewrite Rplus_assoc, Rplus_opp_r, Rplus_0_r. - apply Rle_trans with (1 := proj2 IHn). - apply Req_le. - field. - } - - assert (Hsum: forall n, 0 <= sum n <= 1 - (/2)^n). { - intros N. - generalize (Hsum' O N). - simpl. - now rewrite Rplus_0_l. - } - - destruct (completeness (fun x : R => exists n : nat, x = sum n)) as (m, (Hm1, Hm2)). - - exists 1. - intros x (n, H1). - rewrite H1. - apply Rle_trans with (1 := proj2 (Hsum n)). - apply Rlt_le. - apply Rplus_lt_reg_l with ((/2)^n - 1). - now ring_simplify. - - exists 0. now exists O. - - - destruct (Rle_or_lt m 0) as [[Hm|Hm]|Hm]. - + elim Rlt_not_le with (1 := Hm). - apply Hm1. - now exists O. - - + assert (Hs0: forall n, sum n = 0). { - intros n. - specialize (Hm1 (sum n) (ex_intro _ _ (eq_refl _))). - apply Rle_antisym with (2 := proj1 (Hsum n)). - now rewrite <- Hm. - } - - assert (Hub: forall n, Un n <= l - eps). { - intros n. - generalize (eq_refl (sum (S n))). - simpl sum at 1. - rewrite 2!Hs0, Rplus_0_l. - unfold test. - destruct Rle_lt_dec. - - easy. - - intros H'. - elim Rgt_not_eq with (2 := H'). - exact (Hi2pn (S n)). - } - - clear -Heps H Hub. - destruct H as (_, H). - refine (False_ind _ (Rle_not_lt _ _ (H (l - eps) _) _)). - * intros x (n, H1). - now rewrite H1. - * apply Rplus_lt_reg_l with (eps - l). - now ring_simplify. - - + assert (Rabs (/2) < 1). { - rewrite Rabs_pos_eq. - - rewrite <- Rinv_1. - apply Rinv_lt_contravar. - + rewrite Rmult_1_l. - now apply (IZR_lt 0 2). - + now apply (IZR_lt 1 2). - - apply Rlt_le. - apply Rinv_0_lt_compat. - now apply (IZR_lt 0 2). - } - destruct (pow_lt_1_zero (/2) H0 m Hm) as [N H4]. - exists N. - apply Rnot_le_lt. - intros H5. - apply Rlt_not_le with (1 := H4 _ (Nat.le_refl _)). - rewrite Rabs_pos_eq. 2: now apply Rlt_le. - apply Hm2. - intros x (n, H6). - rewrite H6. clear x H6. - - assert (Hs: sum N = 0). { - clear H4. - induction N. - - easy. - - simpl. - assert (H6: Un N <= l - eps). - + apply Rle_trans with (2 := H5). - apply Rge_le. - apply growing_prop ; try easy. - apply Nat.le_succ_diag_r. - + rewrite (IHN H6), Rplus_0_l. - unfold test. - destruct Rle_lt_dec as [Hle|Hlt]. - * apply eq_refl. - * now elim Rlt_not_le with (1 := Hlt). - } - - destruct (Nat.le_gt_cases N n) as [Hn|Hn]. - - * rewrite <- (Nat.sub_add _ _ Hn), Nat.add_comm. - apply Rle_trans with (1 := proj2 (Hsum' N (n - N)%nat)). - rewrite Hs, Rplus_0_l. - set (k := (N + (n - N))%nat). - apply Rlt_le. - apply Rplus_lt_reg_l with ((/2)^k - (/2)^N). - now ring_simplify. - * apply Rle_trans with (sum N). - -- rewrite <- (Nat.sub_add _ _ Hn), Nat.add_comm. - simpl Nat.add; rewrite <- Nat.add_succ_r. - exact (proj1 (Hsum' _ _)). - -- rewrite Hs. - now apply Rlt_le. - Qed. - -(*********) - Lemma Un_cv_crit : Un_growing -> bound EUn -> exists l : R, Un_cv l. - Proof. - intros Hug Heub. - exists (proj1_sig (completeness EUn Heub EUn_noempty)). - destruct (completeness EUn Heub EUn_noempty) as (l, H). - now apply Un_cv_crit_lub. - Qed. - -(*********) - Lemma finite_greater : - forall N:nat, exists M : R, (forall n:nat, (n <= N)%nat -> Un n <= M). - Proof. - intro; induction N as [| N HrecN]. - - split with (Un 0); intros. rewrite (proj1 (Nat.le_0_r n) H); - apply (Req_le (Un 0) (Un 0) (eq_refl (Un 0))). - - elim HrecN; clear HrecN; intros; split with (Rmax (Un (S N)) x); intros; - elim (Rmax_Rle (Un (S N)) x (Un n)); intros; clear H1; - inversion H0. - + rewrite <- H1; rewrite <- H1 in H2; - apply - (H2 (or_introl (Un n <= x) (Req_le (Un n) (Un n) (eq_refl (Un n))))). - + apply (H2 (or_intror (Un n <= Un (S N)) (H n H3))). - Qed. - -(*********) - Lemma cauchy_bound : Cauchy_crit -> bound EUn. - Proof. - unfold Cauchy_crit, bound; intros; unfold is_upper_bound; - unfold Rgt in H; elim (H 1 Rlt_0_1); clear H; intros; - generalize (H x); intro; generalize (le_dec x); intro; - elim (finite_greater x); intros; split with (Rmax x0 (Un x + 1)); - clear H; intros; unfold EUn in H; elim H; clear H; - intros; elim (H1 x2); clear H1; intro y. - - unfold ge in H0; generalize (H0 x2 (le_n x) y); clear H0; intro; - rewrite <- H in H0; unfold Rdist in H0; elim (Rabs_def2 (Un x - x1) 1 H0); - clear H0; intros; elim (Rmax_Rle x0 (Un x + 1) x1); - intros; apply H4; clear H3 H4; right; clear H H0 y; - apply (Rlt_le x1 (Un x + 1)); generalize (Rlt_minus (-1) (Un x - x1) H1); - clear H1; intro; apply (Rminus_lt x1 (Un x + 1)); - cut (-1 - (Un x - x1) = x1 - (Un x + 1)); - [ intro; rewrite H0 in H; assumption | ring ]. - - generalize (H2 x2 y); clear H2 H0; intro; rewrite <- H in H0; - elim (Rmax_Rle x0 (Un x + 1) x1); intros; clear H1; - apply H2; left; assumption. - Qed. - -End sequence. - -(*****************************************************************) -(** * Definition of Power Series and properties *) -(* *) -(*****************************************************************) - -Section Isequence. - -(*********) - Variable An : nat -> R. - -(*********) - Definition Pser (x l:R) : Prop := infinite_sum (fun n:nat => An n * x ^ n) l. - -End Isequence. - -Lemma GP_infinite : - forall x:R, Rabs x < 1 -> Pser (fun n:nat => 1) x (/ (1 - x)). -Proof. - intros; unfold Pser; unfold infinite_sum; intros; - elim (Req_dec x 0). - - intros; exists 0%nat; intros; rewrite H1; rewrite Rminus_0_r; rewrite Rinv_1; - cut (sum_f_R0 (fun n0:nat => 1 * 0 ^ n0) n = 1). - + intros; rewrite H3; rewrite Rdist_eq; auto. - + elim n; simpl. - * ring. - * intros; rewrite H3; ring. - - intro; cut (0 < eps * (Rabs (1 - x) * Rabs (/ x))). - + intro; elim (pow_lt_1_zero x H (eps * (Rabs (1 - x) * Rabs (/ x))) H2); - intro N; intros; exists N; intros; - cut - (sum_f_R0 (fun n0:nat => 1 * x ^ n0) n = sum_f_R0 (fun n0:nat => x ^ n0) n). - * intros; rewrite H5; - apply - (Rmult_lt_reg_l (Rabs (1 - x)) - (Rdist (sum_f_R0 (fun n0:nat => x ^ n0) n) (/ (1 - x))) eps). - -- apply Rabs_pos_lt. - apply Rminus_eq_contra. - apply Rlt_dichotomy_converse. - right; unfold Rgt. - apply (Rle_lt_trans x (Rabs x) 1). - ++ apply RRle_abs. - ++ assumption. - -- unfold Rdist; rewrite <- Rabs_mult. - rewrite Rmult_minus_distr_l. - cut - ((1 - x) * sum_f_R0 (fun n0:nat => x ^ n0) n = - - (sum_f_R0 (fun n0:nat => x ^ n0) n * (x - 1))). - ++ intro; rewrite H6. - rewrite GP_finite. - rewrite Rinv_r. - ** assert (- (x ^ (n + 1) - 1) - 1 = - x ^ (n + 1)) by ring. - rewrite H7. - rewrite Rabs_Ropp; replace (n + 1)%nat with (S n) by ring. - simpl; rewrite Rabs_mult; - apply - (Rlt_le_trans (Rabs x * Rabs (x ^ n)) - (Rabs x * (eps * (Rabs (1 - x) * Rabs (/ x)))) - (Rabs (1 - x) * eps)). - { apply Rmult_lt_compat_l. - - apply Rabs_pos_lt. assumption. - - auto. } - replace - (Rabs x * (eps * (Rabs (1 - x) * Rabs (/ x)))) - with (Rabs x * Rabs (/ x) * (eps * Rabs (1 - x))) by ring. - rewrite <- Rabs_mult; rewrite Rinv_r. 2:assumption. - rewrite Rabs_R1. - replace (1 * (eps * Rabs (1 - x))) with (Rabs (1 - x) * eps) by ring. - unfold Rle; right; reflexivity. - ** apply Rminus_eq_contra. - apply Rlt_dichotomy_converse. - right; unfold Rgt. - apply (Rle_lt_trans x (Rabs x) 1). - { apply RRle_abs. } - assumption. - ++ ring. - * elim n; simpl. - -- ring. - -- intros; rewrite H5. - ring. - + apply Rmult_lt_0_compat. - * auto. - * apply Rmult_lt_0_compat. - -- apply Rabs_pos_lt. - apply Rminus_eq_contra. - apply Rlt_dichotomy_converse. - right; unfold Rgt. - apply (Rle_lt_trans x (Rabs x) 1). - ++ apply RRle_abs. - ++ assumption. - -- apply Rabs_pos_lt. - apply Rinv_neq_0_compat. - assumption. -Qed. - -(* Convergence is preserved after shifting the indices. *) -Lemma CV_shift : - forall f k l, Un_cv (fun n => f (n + k)%nat) l -> Un_cv f l. -intros f' k l cvfk eps ep; destruct (cvfk eps ep) as [N Pn]. -exists (N + k)%nat; intros n nN; assert (tmp: (n = (n - k) + k)%nat). -- rewrite Nat.sub_add;[ | apply Nat.le_trans with (N + k)%nat]; auto with arith. -- rewrite tmp; apply Pn; apply Nat.le_add_le_sub_r; assumption. -Qed. - -Lemma CV_shift' : - forall f k l, Un_cv f l -> Un_cv (fun n => f (n + k)%nat) l. -intros f' k l cvf eps ep; destruct (cvf eps ep) as [N Pn]. -exists N; intros n nN; apply Pn; auto with arith. -Qed. - -(* Growing property is preserved after shifting the indices (one way only) *) - -Lemma Un_growing_shift : - forall k un, Un_growing un -> Un_growing (fun n => un (n + k)%nat). -Proof. -intros k un P n; apply P. -Qed. diff --git a/stdlib/theories/Reals/Rsigma.v b/stdlib/theories/Reals/Rsigma.v deleted file mode 100644 index 389ec6fce339..000000000000 --- a/stdlib/theories/Reals/Rsigma.v +++ /dev/null @@ -1,129 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* R. - - Definition sigma (low high:nat) : R := - sum_f_R0 (fun k:nat => f (low + k)) (high - low). - - Theorem sigma_split : - forall low high k:nat, - (low <= k)%nat -> - (k < high)%nat -> sigma low high = sigma low k + sigma (S k) high. - Proof. - intros; induction k as [| k Hreck]. - - cut (low = 0%nat). - + intro; rewrite H1; unfold sigma; rewrite Nat.sub_diag, Nat.sub_0_r; - simpl; replace (high - 1)%nat with (pred high). - * apply (decomp_sum (fun k:nat => f k)). - assumption. - * symmetry; apply Nat.sub_1_r. - + inversion H; reflexivity. - - cut ((low <= k)%nat \/ low = S k). - + intro; elim H1; intro. - * replace (sigma low (S k)) with (sigma low k + f (S k)). - -- rewrite Rplus_assoc; - replace (f (S k) + sigma (S (S k)) high) with (sigma (S k) high). - ++ apply Hreck. - ** assumption. - ** apply Nat.lt_trans with (S k); [ apply Nat.lt_succ_diag_r | assumption ]. - ++ unfold sigma; replace (high - S (S k))%nat with (pred (high - S k)). - ** pattern (S k) at 3; replace (S k) with (S k + 0)%nat; - [ idtac | ring ]. - replace (sum_f_R0 (fun k0:nat => f (S (S k) + k0)) (pred (high - S k))) with - (sum_f_R0 (fun k0:nat => f (S k + S k0)) (pred (high - S k))). - { apply (decomp_sum (fun i:nat => f (S k + i))). - apply lt_minus_O_lt; assumption. } - apply sum_eq; intros. replace (S k + S i)%nat with (S (S k) + i)%nat by ring. - reflexivity. - ** replace (high - S (S k))%nat with (high - S k - 1)%nat by lia. - symmetry; apply Nat.sub_1_r. - -- unfold sigma; replace (S k - low)%nat with (S (k - low)) by lia. - pattern (S k) at 1; replace (S k) with (low + S (k - low))%nat by lia. - symmetry ; apply (tech5 (fun i:nat => f (low + i))). - * rewrite <- H2; unfold sigma; rewrite Nat.sub_diag; simpl; - replace (high - S low)%nat with (pred (high - low)) by lia. - replace (sum_f_R0 (fun k0:nat => f (S (low + k0))) (pred (high - low))) with - (sum_f_R0 (fun k0:nat => f (low + S k0)) (pred (high - low))). - -- apply (decomp_sum (fun k0:nat => f (low + k0))). - apply lt_minus_O_lt. - apply Nat.le_lt_trans with (S k); [ rewrite H2; apply Nat.le_refl | assumption ]. - -- apply sum_eq; intros; replace (S (low + i)) with (low + S i)%nat by ring. - reflexivity. - + inversion H; [ right; reflexivity | left; assumption ]. - Qed. - - Theorem sigma_diff : - forall low high k:nat, - (low <= k)%nat -> - (k < high)%nat -> sigma low high - sigma low k = sigma (S k) high. - Proof. - intros low high k H1 H2; symmetry ; rewrite (sigma_split H1 H2); ring. - Qed. - - Theorem sigma_diff_neg : - forall low high k:nat, - (low <= k)%nat -> - (k < high)%nat -> sigma low k - sigma low high = - sigma (S k) high. - Proof. - intros low high k H1 H2; rewrite (sigma_split H1 H2); ring. - Qed. - - Theorem sigma_first : - forall low high:nat, - (low < high)%nat -> sigma low high = f low + sigma (S low) high. - Proof. - intros low high H1; generalize (proj2 (Nat.le_succ_l low high) H1); intro H2; - generalize (Nat.lt_le_incl low high H1); intro H3; - replace (f low) with (sigma low low). - - apply sigma_split. - + apply le_n. - + assumption. - - unfold sigma; rewrite Nat.sub_diag. - simpl. - replace (low + 0)%nat with low; [ reflexivity | ring ]. - Qed. - - Theorem sigma_last : - forall low high:nat, - (low < high)%nat -> sigma low high = f high + sigma low (pred high). - Proof. - intros low high H1; generalize (proj2 (Nat.le_succ_l low high) H1); intro H2; - generalize (Nat.lt_le_incl low high H1); intro H3; - replace (f high) with (sigma high high). - - rewrite Rplus_comm; cut (high = S (pred high)). - + intro; pattern high at 3; rewrite H. - apply sigma_split. - * apply le_S_n; rewrite <- H; apply Nat.le_succ_l; assumption. - * apply Nat.lt_pred_l, Nat.neq_0_lt_0; apply Nat.le_lt_trans with low; [ apply Nat.le_0_l | assumption ]. - + symmetry; apply Nat.lt_succ_pred with 0%nat; apply Nat.le_lt_trans with low; - [ apply Nat.le_0_l | assumption ]. - - unfold sigma; rewrite Nat.sub_diag; simpl; - replace (high + 0)%nat with high; [ reflexivity | ring ]. - Qed. - - Theorem sigma_eq_arg : forall low:nat, sigma low low = f low. - Proof. - intro; unfold sigma; rewrite Nat.sub_diag. - simpl; replace (low + 0)%nat with low; [ reflexivity | ring ]. - Qed. - -End Sigma. diff --git a/stdlib/theories/Reals/Rsqrt_def.v b/stdlib/theories/Reals/Rsqrt_def.v deleted file mode 100644 index 9a89511c65d4..000000000000 --- a/stdlib/theories/Reals/Rsqrt_def.v +++ /dev/null @@ -1,738 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* bool) (N:nat) {struct N} : R := - match N with - | O => x - | S n => - let down := Dichotomy_lb x y P n in - let up := Dichotomy_ub x y P n in - let z := (down + up) / 2 in if P z then down else z - end - - with Dichotomy_ub (x y:R) (P:R -> bool) (N:nat) {struct N} : R := - match N with - | O => y - | S n => - let down := Dichotomy_lb x y P n in - let up := Dichotomy_ub x y P n in - let z := (down + up) / 2 in if P z then z else up - end. - -Definition dicho_lb (x y:R) (P:R -> bool) (N:nat) : R := Dichotomy_lb x y P N. -Definition dicho_up (x y:R) (P:R -> bool) (N:nat) : R := Dichotomy_ub x y P N. - -(**********) -Lemma dicho_comp : - forall (x y:R) (P:R -> bool) (n:nat), - x <= y -> dicho_lb x y P n <= dicho_up x y P n. -Proof. - intros. - induction n as [| n Hrecn]. - - simpl; assumption. - - simpl. - case (P ((Dichotomy_lb x y P n + Dichotomy_ub x y P n) / 2)). - + unfold Rdiv; apply Rmult_le_reg_l with 2. - * prove_sup0. - * pattern 2 at 1; rewrite Rmult_comm. - rewrite Rmult_assoc; rewrite Rinv_l; [ idtac | discrR ]. - rewrite Rmult_1_r. - rewrite <-Rplus_diag. - apply Rplus_le_compat_l. - assumption. - + unfold Rdiv; apply Rmult_le_reg_l with 2. - * prove_sup0. - * rewrite Rmult_comm. - rewrite Rmult_assoc; rewrite Rinv_l; [ idtac | discrR ]. - rewrite Rmult_1_r. - rewrite <-Rplus_diag. - rewrite <- (Rplus_comm (Dichotomy_ub x y P n)). - apply Rplus_le_compat_l. - assumption. -Qed. - -Lemma dicho_lb_growing : - forall (x y:R) (P:R -> bool), x <= y -> Un_growing (dicho_lb x y P). -Proof. - intros. - unfold Un_growing. - intro. - simpl. - case (P ((Dichotomy_lb x y P n + Dichotomy_ub x y P n) / 2)). - - right; reflexivity. - - unfold Rdiv; apply Rmult_le_reg_l with 2. - + prove_sup0. - + pattern 2 at 1; rewrite Rmult_comm. - rewrite Rmult_assoc; rewrite Rinv_l; [ idtac | discrR ]. - rewrite Rmult_1_r. - rewrite <-Rplus_diag. - apply Rplus_le_compat_l. - replace (Dichotomy_ub x y P n) with (dicho_up x y P n); - [ apply dicho_comp; assumption | reflexivity ]. -Qed. - -Lemma dicho_up_decreasing : - forall (x y:R) (P:R -> bool), x <= y -> Un_decreasing (dicho_up x y P). -Proof. - intros. - unfold Un_decreasing. - intro. - simpl. - case (P ((Dichotomy_lb x y P n + Dichotomy_ub x y P n) / 2)). - - unfold Rdiv; apply Rmult_le_reg_l with 2. - + prove_sup0. - + rewrite Rmult_comm. - rewrite Rmult_assoc; rewrite Rinv_l; [ idtac | discrR ]. - rewrite Rmult_1_r. - rewrite <-Rplus_diag. - replace (Dichotomy_ub x y P n) with (dicho_up x y P n); - [ idtac | reflexivity ]. - replace (Dichotomy_lb x y P n) with (dicho_lb x y P n); - [ idtac | reflexivity ]. - rewrite <- (Rplus_comm (dicho_up x y P n)). - apply Rplus_le_compat_l. - apply dicho_comp; assumption. - - right; reflexivity. -Qed. - -Lemma dicho_lb_maj_y : - forall (x y:R) (P:R -> bool), x <= y -> forall n:nat, dicho_lb x y P n <= y. -Proof. - intros. - induction n as [| n Hrecn]. - - simpl; assumption. - - simpl. - case (P ((Dichotomy_lb x y P n + Dichotomy_ub x y P n) / 2)). - + assumption. - + unfold Rdiv; apply Rmult_le_reg_l with 2. - * prove_sup0. - * rewrite Rmult_comm. - rewrite Rmult_assoc; rewrite Rinv_l; [ rewrite Rmult_1_r | discrR ]. - rewrite <-Rplus_diag; apply Rplus_le_compat. - -- assumption. - -- pattern y at 2; replace y with (Dichotomy_ub x y P 0); - [ idtac | reflexivity ]. - apply decreasing_prop. - ++ assert (H0 := dicho_up_decreasing x y P H). - assumption. - ++ apply Nat.le_0_l. -Qed. - -Lemma dicho_lb_maj : - forall (x y:R) (P:R -> bool), x <= y -> has_ub (dicho_lb x y P). -Proof. - intros. - cut (forall n:nat, dicho_lb x y P n <= y). - - intro. - unfold has_ub. - unfold bound. - exists y. - unfold is_upper_bound. - intros. - elim H1; intros. - rewrite H2; apply H0. - - apply dicho_lb_maj_y; assumption. -Qed. - -Lemma dicho_up_min_x : - forall (x y:R) (P:R -> bool), x <= y -> forall n:nat, x <= dicho_up x y P n. -Proof. - intros. - induction n as [| n Hrecn]. - - simpl; assumption. - - simpl. - case (P ((Dichotomy_lb x y P n + Dichotomy_ub x y P n) / 2)). - + unfold Rdiv; apply Rmult_le_reg_l with 2. - * prove_sup0. - * pattern 2 at 1; rewrite Rmult_comm. - rewrite Rmult_assoc; rewrite Rinv_l; [ rewrite Rmult_1_r | discrR ]. - rewrite <-Rplus_diag; apply Rplus_le_compat. - -- pattern x at 1; replace x with (Dichotomy_lb x y P 0); - [ idtac | reflexivity ]. - apply tech9. - ++ assert (H0 := dicho_lb_growing x y P H). - assumption. - ++ apply Nat.le_0_l. - -- assumption. - + assumption. -Qed. - -Lemma dicho_up_min : - forall (x y:R) (P:R -> bool), x <= y -> has_lb (dicho_up x y P). -Proof. - intros. - cut (forall n:nat, x <= dicho_up x y P n). - - intro. - unfold has_lb. - unfold bound. - exists (- x). - unfold is_upper_bound. - intros. - elim H1; intros. - rewrite H2. - unfold opp_seq. - apply Ropp_le_contravar. - apply H0. - - apply dicho_up_min_x; assumption. -Qed. - -Lemma dicho_lb_cv : - forall (x y:R) (P:R -> bool), - x <= y -> { l:R | Un_cv (dicho_lb x y P) l }. -Proof. - intros. - apply growing_cv. - - apply dicho_lb_growing; assumption. - - apply dicho_lb_maj; assumption. -Qed. - -Lemma dicho_up_cv : - forall (x y:R) (P:R -> bool), - x <= y -> { l:R | Un_cv (dicho_up x y P) l }. -Proof. - intros. - apply decreasing_cv. - - apply dicho_up_decreasing; assumption. - - apply dicho_up_min; assumption. -Qed. - -Lemma dicho_lb_dicho_up : - forall (x y:R) (P:R -> bool) (n:nat), - x <= y -> dicho_up x y P n - dicho_lb x y P n = (y - x) / 2 ^ n. -Proof. - intros. - induction n as [| n Hrecn]. - - simpl. - unfold Rdiv; rewrite Rinv_1; ring. - - simpl. - case (P ((Dichotomy_lb x y P n + Dichotomy_ub x y P n) / 2)). - + unfold Rdiv. - replace - ((Dichotomy_lb x y P n + Dichotomy_ub x y P n) * / 2 - Dichotomy_lb x y P n) - with ((dicho_up x y P n - dicho_lb x y P n) / 2). - * unfold Rdiv; rewrite Hrecn. - unfold Rdiv. - field. - apply pow_nonzero; discrR. - * pattern (Dichotomy_lb x y P n) at 2; - rewrite <-(Rplus_half_diag (Dichotomy_lb x y P n)); - unfold dicho_up, dicho_lb, Rminus, Rdiv; ring. - + replace - (Dichotomy_ub x y P n - (Dichotomy_lb x y P n + Dichotomy_ub x y P n) / 2) - with ((dicho_up x y P n - dicho_lb x y P n) / 2). - * unfold Rdiv; rewrite Hrecn. - field. - apply pow_nonzero; discrR. - * pattern (Dichotomy_ub x y P n) at 1; - rewrite <-(Rplus_half_diag (Dichotomy_ub x y P n)); - unfold dicho_up, dicho_lb, Rminus, Rdiv; ring. -Qed. - -Definition pow_2_n (n:nat) := 2 ^ n. - -Lemma pow_2_n_neq_R0 : forall n:nat, pow_2_n n <> 0. -Proof. - intro. - unfold pow_2_n. - apply pow_nonzero. - discrR. -Qed. - -Lemma pow_2_n_growing : Un_growing pow_2_n. -Proof. - unfold Un_growing. - intro. - replace (S n) with (n + 1)%nat; - [ unfold pow_2_n; rewrite pow_add | ring ]. - pattern (2 ^ n) at 1; rewrite <- Rmult_1_r. - apply Rmult_le_compat_l. - - left; apply pow_lt; prove_sup0. - - simpl. - rewrite Rmult_1_r. - pattern 1 at 1; rewrite <- Rplus_0_r; apply Rplus_le_compat_l; left; - apply Rlt_0_1. -Qed. - -Lemma pow_2_n_infty : cv_infty pow_2_n. -Proof. - assert (forall N:nat, INR N <= 2 ^ N). { - simple induction N. - - simpl. - left; apply Rlt_0_1. - - intros. - pattern (S n) at 2; replace (S n) with (n + 1)%nat; [ idtac | ring ]. - rewrite S_INR; rewrite pow_add. - simpl. - rewrite Rmult_1_r. - apply Rle_trans with (2 ^ n). - + rewrite <- (Rplus_comm 1). - rewrite <- (Rmult_1_r (INR n)). - apply (poly n 1). - apply Rlt_0_1. - + pattern (2 ^ n) at 1; rewrite <- Rplus_0_r. - rewrite <- (Rmult_comm 2). - rewrite <-Rplus_diag. - apply Rplus_le_compat_l. - left; apply pow_lt; prove_sup0. - } - intros. - unfold cv_infty. - intro. - destruct (total_order_T 0 M) as [[Hlt|<-]|Hgt]. - 2:{ exists 0%nat; intros. - unfold pow_2_n; apply pow_lt; prove_sup0. } - 2:{ exists 0%nat; intros. - apply Rlt_trans with 0. - - assumption. - - unfold pow_2_n; apply pow_lt; prove_sup0. } - set (N := up M). - assert (0 <= N)%Z. { - apply le_IZR. - unfold N. - assert (H0 := archimed M); elim H0; intros. - left; apply Rlt_trans with M; assumption. - } - elim (IZN N H0); intros N0 H1. - exists N0. - intros. - apply Rlt_le_trans with (INR N0). - { rewrite INR_IZR_INZ. - rewrite <- H1. - unfold N. - assert (H3 := archimed M). - elim H3; intros; assumption. } - apply Rle_trans with (pow_2_n N0). - { unfold pow_2_n; apply H. } - apply Rge_le. - apply growing_prop. - 2:assumption. - apply pow_2_n_growing. -Qed. - -Lemma cv_dicho : - forall (x y l1 l2:R) (P:R -> bool), - x <= y -> - Un_cv (dicho_lb x y P) l1 -> Un_cv (dicho_up x y P) l2 -> l1 = l2. -Proof. - intros. - assert (H2 := CV_minus _ _ _ _ H0 H1). - cut (Un_cv (fun i:nat => dicho_lb x y P i - dicho_up x y P i) 0). - { intro. - assert (H4 := UL_sequence _ _ _ H2 H3). - apply Rminus_diag_uniq; assumption. } - unfold Un_cv; unfold Rdist. - intros. - assert (H4 := cv_infty_cv_0 pow_2_n pow_2_n_infty). - destruct (total_order_T x y) as [[ Hlt | -> ]|Hgt]. - 2:{ exists 0%nat; intros. - replace (dicho_lb y y P n - dicho_up y y P n - 0) with - (dicho_lb y y P n - dicho_up y y P n); [ idtac | ring ]. - rewrite <- Rabs_Ropp. - rewrite Ropp_minus_distr. - rewrite dicho_lb_dicho_up. - - unfold Rminus, Rdiv; rewrite Rplus_opp_r; rewrite Rmult_0_l; - rewrite Rabs_R0; assumption. - - assumption. } - 2:{ elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H Hgt)). } - unfold Un_cv in H4; unfold Rdist in H4. - assert (Hyp:0 < y - x) by lra. - assert (0 < eps / (y - x)). { - unfold Rdiv; apply Rmult_lt_0_compat; - [ assumption | apply Rinv_0_lt_compat; assumption ]. - } - elim (H4 (eps / (y - x)) H5); intros N H6. - exists N; intros. - replace (dicho_lb x y P n - dicho_up x y P n - 0) with - (dicho_lb x y P n - dicho_up x y P n); [ idtac | ring ]. - rewrite <- Rabs_Ropp. - rewrite Ropp_minus_distr. - rewrite dicho_lb_dicho_up. - 2:lra. - unfold Rdiv; rewrite Rabs_mult. - rewrite (Rabs_right (y - x)). - 2:lra. - apply Rmult_lt_reg_l with (/ (y - x)). - { apply Rinv_0_lt_compat; assumption. } - rewrite <- Rmult_assoc; rewrite Rinv_l. - 2:lra. - rewrite Rmult_1_l. - replace (/ 2 ^ n) with (/ 2 ^ n - 0); - [ unfold pow_2_n, Rdiv in H6; rewrite <- (Rmult_comm eps); apply H6; - assumption - | ring ]. -Qed. - -Definition cond_positivity (x:R) : bool := - match Rle_dec 0 x with - | left _ => true - | right _ => false - end. - -(** Sequential characterisation of continuity *) -Lemma continuity_seq : - forall (f:R -> R) (Un:nat -> R) (l:R), - continuity_pt f l -> Un_cv Un l -> Un_cv (fun i:nat => f (Un i)) (f l). -Proof. - unfold continuity_pt, Un_cv; unfold continue_in. - unfold limit1_in. - unfold limit_in. - unfold dist. - simpl. - unfold Rdist. - intros. - elim (H eps H1); intros alp H2. - elim H2; intros. - elim (H0 alp H3); intros N H5. - exists N; intros. - case (Req_dec (Un n) l); intro. - - rewrite H7; unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0; - assumption. - - apply H4. - split. - + unfold D_x, no_cond. - split. - * trivial. - * apply (not_eq_sym (A:=R)); assumption. - + apply H5; assumption. -Qed. - -Lemma dicho_lb_car : - forall (x y:R) (P:R -> bool) (n:nat), - P x = false -> P (dicho_lb x y P n) = false. -Proof. - intros. - induction n as [| n Hrecn]. - - assumption. - - simpl. - destruct - (sumbool_of_bool (P ((Dichotomy_lb x y P n + Dichotomy_ub x y P n) / 2))) as [Heq|Heq]. - + rewrite Heq. - unfold dicho_lb in Hrecn; assumption. - + rewrite Heq. - assumption. -Qed. - -Lemma dicho_up_car : - forall (x y:R) (P:R -> bool) (n:nat), - P y = true -> P (dicho_up x y P n) = true. -Proof. - intros. - induction n as [| n Hrecn]. - - assumption. - - simpl. - destruct - (sumbool_of_bool (P ((Dichotomy_lb x y P n + Dichotomy_ub x y P n) / 2))) as [Heq|Heq]. - + rewrite Heq. - unfold dicho_lb in Hrecn; assumption. - + rewrite Heq. - assumption. -Qed. - -(* A general purpose corollary. *) -Lemma cv_pow_half : forall a, Un_cv (fun n => a/2^n) 0. -intros a; unfold Rdiv; replace 0 with (a * 0) by ring. -apply CV_mult. -- intros eps ep; exists 0%nat; rewrite Rdist_eq; intros n _; assumption. -- exact (cv_infty_cv_0 pow_2_n pow_2_n_infty). -Qed. - -(** Intermediate Value Theorem *) -Lemma IVT : - forall (f:R -> R) (x y:R), - continuity f -> - x < y -> f x < 0 -> 0 < f y -> { z:R | x <= z <= y /\ f z = 0 }. -Proof. - intros. - assert (x <= y) by (left; assumption). - destruct (dicho_lb_cv x y (fun z:R => cond_positivity (f z)) H3) as (x1,p0). - destruct (dicho_up_cv x y (fun z:R => cond_positivity (f z)) H3) as (x0,p). - assert (H4 := cv_dicho _ _ _ _ _ H3 p0 p). - rewrite H4 in p0. - exists x0. - split;[split|]. - - apply Rle_trans with (dicho_lb x y (fun z:R => cond_positivity (f z)) 0). - { simpl. right; reflexivity. } - apply growing_ineq. - { apply dicho_lb_growing; assumption. } - assumption. - - apply Rle_trans with (dicho_up x y (fun z:R => cond_positivity (f z)) 0). - { apply decreasing_ineq. - { apply dicho_up_decreasing; assumption. } - assumption. } - right; reflexivity. - - set (Vn := fun n:nat => dicho_lb x y (fun z:R => cond_positivity (f z)) n). - set (Wn := fun n:nat => dicho_up x y (fun z:R => cond_positivity (f z)) n). - cut ((forall n:nat, f (Vn n) <= 0) -> f x0 <= 0). - 1:cut ((forall n:nat, 0 <= f (Wn n)) -> 0 <= f x0). - + intros. - cut (forall n:nat, f (Vn n) <= 0). - 1:cut (forall n:nat, 0 <= f (Wn n)). - { intros. - assert (H9 := H6 H8). - assert (H10 := H5 H7). - apply Rle_antisym; assumption. } - * intro. - unfold Wn. - cut (forall z:R, cond_positivity z = true <-> 0 <= z). - 2:{ intro. - unfold cond_positivity. - case (Rle_dec 0 z) as [Hle|Hnle]. - - split. - + intro; assumption. - + intro; reflexivity. - - split. - + intro feqt;discriminate feqt. - + intro. contradiction. } - intro. - assert (H8 := dicho_up_car x y (fun z:R => cond_positivity (f z)) n). - elim (H7 (f (dicho_up x y (fun z:R => cond_positivity (f z)) n))); intros. - apply H9. - apply H8. - elim (H7 (f y)); intros. - apply H12. - left; assumption. - * unfold Vn. - cut (forall z:R, cond_positivity z = false <-> z < 0). - 2:{ intro. - unfold cond_positivity. - case (Rle_dec 0 z) as [Hle|Hnle]. - - split. - + intro feqt; discriminate feqt. - + intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ Hle H7)). - - split. - + intro; auto with real. - + intro; reflexivity. } - intros. - assert (H8 := dicho_lb_car x y (fun z:R => cond_positivity (f z)) n). - left. - elim (H7 (f (dicho_lb x y (fun z:R => cond_positivity (f z)) n))); intros. - apply H9. - apply H8. - elim (H7 (f x)); intros. - apply H12. - assumption. - + assert (Un_cv Wn x0) by (unfold Wn; assumption). - intros. - assert (H7 := continuity_seq f Wn x0 (H x0) H5). - destruct (total_order_T 0 (f x0)) as [[Hlt|<-]|Hgt]. - { left; assumption. } - { right; reflexivity. } - unfold Un_cv in H7; unfold Rdist in H7. - assert (0 < - f x0) by (apply Ropp_0_gt_lt_contravar; assumption). - elim (H7 (- f x0) H8); intros. - cut (x2 >= x2)%nat; [ intro | unfold ge; apply le_n ]. - assert (H11 := H9 x2 H10). - rewrite Rabs_right in H11. - 2:{ apply Rle_ge; left; unfold Rminus; apply Rplus_le_lt_0_compat. - - apply H6. - - exact H8. } - pattern (- f x0) at 1 in H11; rewrite <- Rplus_0_r in H11. - unfold Rminus in H11; rewrite (Rplus_comm (f (Wn x2))) in H11. - assert (H12 := Rplus_lt_reg_l _ _ _ H11). - assert (H13 := H6 x2). - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H13 H12)). - + assert (Un_cv Vn x0) by (unfold Vn; assumption). - intros. - assert (H7 := continuity_seq f Vn x0 (H x0) H5). - destruct (total_order_T 0 (f x0)) as [[Hlt|<-]|Hgt]. - 2:{ right; reflexivity. } - 2:{ left; assumption. } - unfold Un_cv in H7; unfold Rdist in H7. - elim (H7 (f x0) Hlt); intros. - cut (x2 >= x2)%nat; [ intro | unfold ge; apply le_n ]. - assert (H10 := H8 x2 H9). - rewrite Rabs_left in H10. - 2:{ apply Rplus_lt_reg_l with (f x0 - f (Vn x2)). - rewrite Rplus_0_r; replace (f x0 - f (Vn x2) + (f (Vn x2) - f x0)) with 0; - [ unfold Rminus; apply Rplus_lt_le_0_compat | ring ]. - - assumption. - - apply Ropp_0_ge_le_contravar; apply Rle_ge; apply H6. } - pattern (f x0) at 2 in H10; rewrite <- Rplus_0_r in H10. - rewrite Ropp_minus_distr in H10. - unfold Rminus in H10. - assert (H11 := Rplus_lt_reg_l _ _ _ H10). - assert (H12 := H6 x2). - cut (0 < f (Vn x2)). - * intro. - elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ H13 H12)). - * rewrite <- (Ropp_involutive (f (Vn x2))). - apply Ropp_0_gt_lt_contravar; assumption. -Qed. - -Lemma IVT_cor : - forall (f:R -> R) (x y:R), - continuity f -> - x <= y -> f x * f y <= 0 -> { z:R | x <= z <= y /\ f z = 0 }. -Proof. - intros. - destruct (total_order_T 0 (f x)) as [[Hltx|Heqx]|Hgtx]. - 2:{ exists x. - split. - - split; [ right; reflexivity | assumption ]. - - symmetry ; assumption. } - 1,2:destruct (total_order_T 0 (f y)) as [[Hlty|Heqy]|Hgty]. - - cut (0 < f x * f y); - [ intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H1 H2)) - | apply Rmult_lt_0_compat; assumption ]. - - exists y. - split. - + split; [ assumption | right; reflexivity ]. - + symmetry ; exact Heqy. - - cut (x < y). - + intro. - assert (H3 := IVT (- f)%F x y (continuity_opp f H) H2). - cut ((- f)%F x < 0). - * cut (0 < (- f)%F y). - -- intros. - destruct (H3 H5 H4) as (x0,[]). - exists x0. - split. - ++ assumption. - ++ unfold opp_fct in H7. - rewrite <- (Ropp_involutive (f x0)). - apply Ropp_eq_0_compat; assumption. - -- unfold opp_fct; apply Ropp_0_gt_lt_contravar; assumption. - * unfold opp_fct. - apply Rplus_lt_reg_l with (f x); rewrite Rplus_opp_r; rewrite Rplus_0_r; - assumption. - + inversion H0. - * assumption. - * rewrite H2 in Hltx. - elim (Rlt_irrefl _ (Rlt_trans _ _ _ Hgty Hltx)). - - cut (x < y). - + intro. - apply IVT; assumption. - + inversion H0. - * assumption. - * rewrite H2 in Hgtx. - elim (Rlt_irrefl _ (Rlt_trans _ _ _ Hlty Hgtx)). - - exists y. - split. - + split; [ assumption | right; reflexivity ]. - + symmetry ; assumption. - - cut (0 < f x * f y). - + intro. - elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ H2 H1)). - + rewrite <- Rmult_opp_opp; apply Rmult_lt_0_compat; - apply Ropp_0_gt_lt_contravar; assumption. -Qed. - -(** We can now define the square root function as the reciprocal - transformation of the square function *) -Lemma Rsqrt_exists : - forall y:R, 0 <= y -> { z:R | 0 <= z /\ y = Rsqr z }. -Proof. - intros. - set (f := fun x:R => Rsqr x - y). - assert (f 0 <= 0). { - unfold f; rewrite Rsqr_0. - unfold Rminus; rewrite Rplus_0_l. - apply Rge_le. - apply Ropp_0_le_ge_contravar; assumption. - } - assert (continuity f). { - replace f with (Rsqr - fct_cte y)%F by reflexivity. - apply continuity_minus;apply derivable_continuous. - - apply derivable_Rsqr. - - apply derivable_const. - } - destruct (total_order_T y 1) as [[Hlt| -> ]|Hgt]. - - assert (0 <= f 1). { - unfold f. - rewrite Rsqr_1. - apply Rplus_le_reg_l with y. - rewrite Rplus_0_r; rewrite Rplus_comm; unfold Rminus; - rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r; - left; assumption. - } - assert (f 0 * f 1 <= 0). { - rewrite Rmult_comm; pattern 0 at 2; rewrite <- (Rmult_0_r (f 1)). - apply Rmult_le_compat_l; assumption. - } - assert (X := IVT_cor f 0 1 H1 (Rlt_le _ _ Rlt_0_1) H3). - elim X; intros t H4. - exists t. - elim H4; intros. - split. - + elim H5; intros; assumption. - + unfold f in H6. - symmetry; apply Rminus_diag_uniq; exact H6. - - exists 1. - split. - + left; apply Rlt_0_1. - + symmetry; apply Rsqr_1. - - assert (0 <= f y). { - unfold f. - apply Rplus_le_reg_l with y. - rewrite Rplus_0_r; rewrite Rplus_comm; unfold Rminus; - rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r. - pattern y at 1; rewrite <- Rmult_1_r. - unfold Rsqr; apply Rmult_le_compat_l. - - assumption. - - left; exact Hgt. - } - assert (f 0 * f y <= 0). { - rewrite Rmult_comm; pattern 0 at 2; rewrite <- (Rmult_0_r (f y)). - apply Rmult_le_compat_l; assumption. - } - assert (X := IVT_cor f 0 y H1 H H3). - elim X; intros t H4. - exists t. - elim H4; intros. - split. - + elim H5; intros; assumption. - + unfold f in H6. - symmetry; apply Rminus_diag_uniq; exact H6. -Qed. - -(* Definition of the square root: R+->R *) -Definition Rsqrt (y:nonnegreal) : R := - let (a,_) := Rsqrt_exists (nonneg y) (cond_nonneg y) in a. - -(**********) -Lemma Rsqrt_positivity : forall x:nonnegreal, 0 <= Rsqrt x. -Proof. - intro. - destruct (Rsqrt_exists (nonneg x) (cond_nonneg x)) as (x0 & H1 & H2). - cut (x0 = Rsqrt x). - - intros. - rewrite <- H; assumption. - - unfold Rsqrt. - case (Rsqrt_exists x (cond_nonneg x)) as (?,[]). - apply Rsqr_inj. - + assumption. - + assumption. - + rewrite <- H0, <- H2; reflexivity. -Qed. - -(**********) -Lemma Rsqrt_Rsqrt : forall x:nonnegreal, Rsqrt x * Rsqrt x = x. -Proof. - intros. - destruct (Rsqrt_exists (nonneg x) (cond_nonneg x)) as (x0 & H1 & H2). - cut (x0 = Rsqrt x). - - intros. - rewrite <- H. - rewrite H2; reflexivity. - - unfold Rsqrt. - case (Rsqrt_exists x (cond_nonneg x)) as (x1 & ? & ?). - apply Rsqr_inj. - + assumption. - + assumption. - + rewrite <- H0, <- H2; reflexivity. -Qed. diff --git a/stdlib/theories/Reals/Rtopology.v b/stdlib/theories/Reals/Rtopology.v deleted file mode 100644 index 361b94529adb..000000000000 --- a/stdlib/theories/Reals/Rtopology.v +++ /dev/null @@ -1,1866 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* Prop) : Prop := forall x:R, D1 x -> D2 x. -Definition disc (x:R) (delta:posreal) (y:R) : Prop := Rabs (y - x) < delta. -Definition neighbourhood (V:R -> Prop) (x:R) : Prop := - exists delta : posreal, included (disc x delta) V. -Definition open_set (D:R -> Prop) : Prop := - forall x:R, D x -> neighbourhood D x. -Definition complementary (D:R -> Prop) (c:R) : Prop := ~ D c. -Definition closed_set (D:R -> Prop) : Prop := open_set (complementary D). -Definition intersection_domain (D1 D2:R -> Prop) (c:R) : Prop := D1 c /\ D2 c. -Definition union_domain (D1 D2:R -> Prop) (c:R) : Prop := D1 c \/ D2 c. -Definition interior (D:R -> Prop) (x:R) : Prop := neighbourhood D x. - -Lemma interior_P1 : forall D:R -> Prop, included (interior D) D. -Proof. - intros; unfold included; unfold interior; intros; - unfold neighbourhood in H; elim H; intros; unfold included in H0; - apply H0; unfold disc; unfold Rminus; - rewrite Rplus_opp_r; rewrite Rabs_R0; apply (cond_pos x0). -Qed. - -Lemma interior_P2 : forall D:R -> Prop, open_set D -> included D (interior D). -Proof. - intros; unfold open_set in H; unfold included; intros; - assert (H1 := H _ H0); unfold interior; apply H1. -Qed. - -Definition point_adherent (D:R -> Prop) (x:R) : Prop := - forall V:R -> Prop, - neighbourhood V x -> exists y : R, intersection_domain V D y. -Definition adherence (D:R -> Prop) (x:R) : Prop := point_adherent D x. - -Lemma adherence_P1 : forall D:R -> Prop, included D (adherence D). -Proof. - intro; unfold included; intros; unfold adherence; - unfold point_adherent; intros; exists x; - unfold intersection_domain; split. - - unfold neighbourhood in H0; elim H0; intros; unfold included in H1; apply H1; - unfold disc; unfold Rminus; rewrite Rplus_opp_r; - rewrite Rabs_R0; apply (cond_pos x0). - - apply H. -Qed. - -Lemma included_trans : - forall D1 D2 D3:R -> Prop, - included D1 D2 -> included D2 D3 -> included D1 D3. -Proof. - unfold included; intros; apply H0; apply H; apply H1. -Qed. - -Lemma interior_P3 : forall D:R -> Prop, open_set (interior D). -Proof. - intro; unfold open_set, interior; unfold neighbourhood; - intros; elim H; intros. - exists x0; unfold included; intros. - set (del := x0 - Rabs (x - x1)). - cut (0 < del). - - intro; exists (mkposreal del H2); intros. - cut (included (disc x1 (mkposreal del H2)) (disc x x0)). - + intro; assert (H5 := included_trans _ _ _ H4 H0). - apply H5; apply H3. - + unfold included; unfold disc; intros. - apply Rle_lt_trans with (Rabs (x3 - x1) + Rabs (x1 - x)). - * replace (x3 - x) with (x3 - x1 + (x1 - x)); [ apply Rabs_triang | ring ]. - * replace (pos x0) with (del + Rabs (x1 - x)). - -- do 2 rewrite <- (Rplus_comm (Rabs (x1 - x))); apply Rplus_lt_compat_l; - apply H4. - -- unfold del; rewrite <- (Rabs_Ropp (x - x1)); rewrite Ropp_minus_distr; - ring. - - unfold del; apply Rplus_lt_reg_l with (Rabs (x - x1)); - rewrite Rplus_0_r; - replace (Rabs (x - x1) + (x0 - Rabs (x - x1))) with (pos x0); - [ idtac | ring ]. - unfold disc in H1; rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; apply H1. -Qed. - -Lemma complementary_P1 : - forall D:R -> Prop, - ~ (exists y : R, intersection_domain D (complementary D) y). -Proof. - intro; red; intro; elim H; intros; - unfold intersection_domain, complementary in H0; elim H0; - intros; elim H2; assumption. -Qed. - -Lemma adherence_P2 : - forall D:R -> Prop, closed_set D -> included (adherence D) D. -Proof. - unfold closed_set; unfold open_set, complementary; intros; - unfold included, adherence; intros; assert (H1 := classic (D x)); - elim H1; intro. - - assumption. - - assert (H3 := H _ H2); assert (H4 := H0 _ H3); elim H4; intros; - unfold intersection_domain in H5; elim H5; intros; - elim H6; assumption. -Qed. - -Lemma adherence_P3 : forall D:R -> Prop, closed_set (adherence D). -Proof. - intro; unfold closed_set, adherence; - unfold open_set, complementary, point_adherent; - intros; - set - (P := - fun V:R -> Prop => - neighbourhood V x -> exists y : R, intersection_domain V D y); - assert (H0 := not_all_ex_not _ P H); elim H0; intros V0 H1; - unfold P in H1; assert (H2 := imply_to_and _ _ H1); - unfold neighbourhood; elim H2; intros; unfold neighbourhood in H3; - elim H3; intros; exists x0; unfold included; - intros; red; intro. - assert (H8 := H7 V0); - cut (exists delta : posreal, (forall x:R, disc x1 delta x -> V0 x)). - - intro; assert (H10 := H8 H9); elim H4; assumption. - - cut (0 < x0 - Rabs (x - x1)). - + intro; set (del := mkposreal _ H9); exists del; intros; - unfold included in H5; apply H5; unfold disc; - apply Rle_lt_trans with (Rabs (x2 - x1) + Rabs (x1 - x)). - * replace (x2 - x) with (x2 - x1 + (x1 - x)); [ apply Rabs_triang | ring ]. - * replace (pos x0) with (del + Rabs (x1 - x)). - -- do 2 rewrite <- (Rplus_comm (Rabs (x1 - x))); apply Rplus_lt_compat_l; - apply H10. - -- unfold del; simpl; rewrite <- (Rabs_Ropp (x - x1)); - rewrite Ropp_minus_distr; ring. - + apply Rplus_lt_reg_l with (Rabs (x - x1)); rewrite Rplus_0_r; - replace (Rabs (x - x1) + (x0 - Rabs (x - x1))) with (pos x0); - [ rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; apply H6 | ring ]. -Qed. - -Definition eq_Dom (D1 D2:R -> Prop) : Prop := - included D1 D2 /\ included D2 D1. - -Infix "=_D" := eq_Dom (at level 70, no associativity). - -Lemma open_set_P1 : forall D:R -> Prop, open_set D <-> D =_D interior D. -Proof. - intro; split. - - intro; unfold eq_Dom; split. - + apply interior_P2; assumption. - + apply interior_P1. - - intro; unfold eq_Dom in H; elim H; clear H; intros; unfold open_set; - intros; unfold included, interior in H; unfold included in H0; - apply (H _ H1). -Qed. - -Lemma closed_set_P1 : forall D:R -> Prop, closed_set D <-> D =_D adherence D. -Proof. - intro; split. - - intro; unfold eq_Dom; split. - + apply adherence_P1. - + apply adherence_P2; assumption. - - unfold eq_Dom; unfold included; intros; - assert (H0 := adherence_P3 D); unfold closed_set in H0; - unfold closed_set; unfold open_set; - unfold open_set in H0; intros; assert (H2 : complementary (adherence D) x). - + unfold complementary; unfold complementary in H1; red; intro; - elim H; clear H; intros _ H; elim H1; apply (H _ H2). - + assert (H3 := H0 _ H2); unfold neighbourhood; - unfold neighbourhood in H3; elim H3; intros; exists x0; - unfold included; unfold included in H4; intros; - assert (H6 := H4 _ H5); unfold complementary in H6; - unfold complementary; red; intro; - elim H; clear H; intros H _; elim H6; apply (H _ H7). -Qed. - -Lemma neighbourhood_P1 : - forall (D1 D2:R -> Prop) (x:R), - included D1 D2 -> neighbourhood D1 x -> neighbourhood D2 x. -Proof. - unfold included, neighbourhood; intros; elim H0; intros; exists x0; - intros; unfold included; unfold included in H1; - intros; apply (H _ (H1 _ H2)). -Qed. - -Lemma open_set_P2 : - forall D1 D2:R -> Prop, - open_set D1 -> open_set D2 -> open_set (union_domain D1 D2). -Proof. - unfold open_set; intros; unfold union_domain in H1; elim H1; intro. - - apply neighbourhood_P1 with D1. - + unfold included, union_domain; tauto. - + apply H; assumption. - - apply neighbourhood_P1 with D2. - + unfold included, union_domain; tauto. - + apply H0; assumption. -Qed. - -Lemma open_set_P3 : - forall D1 D2:R -> Prop, - open_set D1 -> open_set D2 -> open_set (intersection_domain D1 D2). -Proof. - unfold open_set; intros; unfold intersection_domain in H1; elim H1; - intros. - assert (H4 := H _ H2); assert (H5 := H0 _ H3); - unfold intersection_domain; unfold neighbourhood in H4, H5; - elim H4; clear H; intros del1 H; elim H5; clear H0; - intros del2 H0; cut (0 < Rmin del1 del2). - - intro; set (del := mkposreal _ H6). - exists del; unfold included; intros; unfold included in H, H0; - unfold disc in H, H0, H7. - split. - + apply H; apply Rlt_le_trans with (pos del). - * apply H7. - * unfold del; simpl; apply Rmin_l. - + apply H0; apply Rlt_le_trans with (pos del). - * apply H7. - * unfold del; simpl; apply Rmin_r. - - unfold Rmin; case (Rle_dec del1 del2); intro. - + apply (cond_pos del1). - + apply (cond_pos del2). -Qed. - -Lemma open_set_P4 : open_set (fun x:R => False). -Proof. - unfold open_set; intros; elim H. -Qed. - -Lemma open_set_P5 : open_set (fun x:R => True). -Proof. - unfold open_set; intros; unfold neighbourhood. - exists (mkposreal 1 Rlt_0_1); unfold included; intros; trivial. -Qed. - -Lemma disc_P1 : forall (x:R) (del:posreal), open_set (disc x del). -Proof. - intros; assert (H := open_set_P1 (disc x del)). - elim H; intros; apply H1. - unfold eq_Dom; split. - - unfold included, interior, disc; intros; - cut (0 < del - Rabs (x - x0)). - + intro; set (del2 := mkposreal _ H3). - exists del2; unfold included; intros. - apply Rle_lt_trans with (Rabs (x1 - x0) + Rabs (x0 - x)). - * replace (x1 - x) with (x1 - x0 + (x0 - x)); [ apply Rabs_triang | ring ]. - * replace (pos del) with (del2 + Rabs (x0 - x)). - -- do 2 rewrite <- (Rplus_comm (Rabs (x0 - x))); apply Rplus_lt_compat_l. - apply H4. - -- unfold del2; simpl; rewrite <- (Rabs_Ropp (x - x0)); - rewrite Ropp_minus_distr; ring. - + apply Rplus_lt_reg_l with (Rabs (x - x0)); rewrite Rplus_0_r; - replace (Rabs (x - x0) + (del - Rabs (x - x0))) with (pos del); - [ rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; apply H2 | ring ]. - - apply interior_P1. -Qed. - -Lemma continuity_P1 : - forall (f:R -> R) (x:R), - continuity_pt f x <-> - (forall W:R -> Prop, - neighbourhood W (f x) -> - exists V : R -> Prop, - neighbourhood V x /\ (forall y:R, V y -> W (f y))). -Proof. - intros; split. - - intros; unfold neighbourhood in H0. - elim H0; intros del1 H1. - unfold continuity_pt in H; unfold continue_in in H; unfold limit1_in in H; - unfold limit_in in H; simpl in H; unfold Rdist in H. - assert (H2 := H del1 (cond_pos del1)). - elim H2; intros del2 H3. - elim H3; intros. - exists (disc x (mkposreal del2 H4)). - intros; unfold included in H1; split. - + unfold neighbourhood, disc. - exists (mkposreal del2 H4). - unfold included; intros; assumption. - + intros; apply H1; unfold disc; case (Req_dec y x); intro. - * rewrite H7; unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0; - apply (cond_pos del1). - * apply H5; split. - -- unfold D_x, no_cond; split. - ++ trivial. - ++ apply (not_eq_sym (A:=R)); apply H7. - -- unfold disc in H6; apply H6. - - intros; unfold continuity_pt; unfold continue_in; - unfold limit1_in; unfold limit_in; - intros. - assert (H1 := H (disc (f x) (mkposreal eps H0))). - cut (neighbourhood (disc (f x) (mkposreal eps H0)) (f x)). - + intro; assert (H3 := H1 H2). - elim H3; intros D H4; elim H4; intros; unfold neighbourhood in H5; elim H5; - intros del1 H7. - exists (pos del1); split. - * apply (cond_pos del1). - * intros; elim H8; intros; simpl in H10; unfold Rdist in H10; simpl; - unfold Rdist; apply (H6 _ (H7 _ H10)). - + unfold neighbourhood, disc; exists (mkposreal eps H0); - unfold included; intros; assumption. -Qed. - -Definition image_rec (f:R -> R) (D:R -> Prop) (x:R) : Prop := D (f x). - -(**********) -Lemma continuity_P2 : - forall (f:R -> R) (D:R -> Prop), - continuity f -> open_set D -> open_set (image_rec f D). -Proof. - intros; unfold open_set in H0; unfold open_set; intros; - assert (H2 := continuity_P1 f x); elim H2; intros H3 _; - assert (H4 := H3 (H x)); unfold neighbourhood, image_rec; - unfold image_rec in H1; assert (H5 := H4 D (H0 (f x) H1)); - elim H5; intros V0 H6; elim H6; intros; unfold neighbourhood in H7; - elim H7; intros del H9; exists del; unfold included in H9; - unfold included; intros; apply (H8 _ (H9 _ H10)). -Qed. - -(**********) -Lemma continuity_P3 : - forall f:R -> R, - continuity f <-> - (forall D:R -> Prop, open_set D -> open_set (image_rec f D)). -Proof. - intros; split. - - intros; apply continuity_P2; assumption. - - intros; unfold continuity; unfold continuity_pt; - unfold continue_in; unfold limit1_in; - unfold limit_in; simpl; unfold Rdist; - intros; cut (open_set (disc (f x) (mkposreal _ H0))). - + intro; assert (H2 := H _ H1). - unfold open_set, image_rec in H2; cut (disc (f x) (mkposreal _ H0) (f x)). - * intro; assert (H4 := H2 _ H3). - unfold neighbourhood in H4; elim H4; intros del H5. - exists (pos del); split. - -- apply (cond_pos del). - -- intros; unfold included in H5; apply H5; elim H6; intros; apply H8. - * unfold disc; unfold Rminus; rewrite Rplus_opp_r; - rewrite Rabs_R0; apply H0. - + apply disc_P1. -Qed. - -(**********) -Theorem Rsepare : - forall x y:R, - x <> y -> - exists V : R -> Prop, - (exists W : R -> Prop, - neighbourhood V x /\ - neighbourhood W y /\ ~ (exists y : R, intersection_domain V W y)). -Proof. - intros x y Hsep; set (D := Rabs (x - y)). - cut (0 < D / 2). - - intro; exists (disc x (mkposreal _ H)). - exists (disc y (mkposreal _ H)); split. - + unfold neighbourhood; exists (mkposreal _ H); unfold included; - tauto. - + split. - * unfold neighbourhood; exists (mkposreal _ H); unfold included; - tauto. - * red; intro; elim H0; intros; unfold intersection_domain in H1; - elim H1; intros. - cut (D < D). - -- intro; elim (Rlt_irrefl _ H4). - -- change (Rabs (x - y) < D); - apply Rle_lt_trans with (Rabs (x - x0) + Rabs (x0 - y)). - ++ replace (x - y) with (x - x0 + (x0 - y)); [ apply Rabs_triang | ring ]. - ++ rewrite <-(Rplus_half_diag D); apply Rplus_lt_compat. - ** rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; apply H2. - ** apply H3. - - unfold Rdiv; apply Rmult_lt_0_compat. - + unfold D; apply Rabs_pos_lt; apply (Rminus_eq_contra _ _ Hsep). - + apply Rinv_0_lt_compat; prove_sup0. -Qed. - -Record family : Type := mkfamily - {ind : R -> Prop; - f :> R -> R -> Prop; - cond_fam : forall x:R, (exists y : R, f x y) -> ind x}. - -Definition family_open_set (f:family) : Prop := forall x:R, open_set (f x). - -Definition domain_finite (D:R -> Prop) : Prop := - exists l : list R, (forall x:R, D x <-> In x l). - -Definition family_finite (f:family) : Prop := domain_finite (ind f). - -Definition covering (D:R -> Prop) (f:family) : Prop := - forall x:R, D x -> exists y : R, f y x. - -Definition covering_open_set (D:R -> Prop) (f:family) : Prop := - covering D f /\ family_open_set f. - -Definition covering_finite (D:R -> Prop) (f:family) : Prop := - covering D f /\ family_finite f. - -Lemma restriction_family : - forall (f:family) (D:R -> Prop) (x:R), - (exists y : R, (fun z1 z2:R => f z1 z2 /\ D z1) x y) -> - intersection_domain (ind f) D x. -Proof. - intros; elim H; intros; unfold intersection_domain; elim H0; intros; - split. - - apply (cond_fam f0); exists x0; assumption. - - assumption. -Qed. - -Definition subfamily (f:family) (D:R -> Prop) : family := - mkfamily (intersection_domain (ind f) D) (fun x y:R => f x y /\ D x) - (restriction_family f D). - -Definition compact (X:R -> Prop) : Prop := - forall f:family, - covering_open_set X f -> - exists D : R -> Prop, covering_finite X (subfamily f D). - -(**********) -Lemma family_P1 : - forall (f:family) (D:R -> Prop), - family_open_set f -> family_open_set (subfamily f D). -Proof. - unfold family_open_set; intros; unfold subfamily; - simpl; assert (H0 := classic (D x)). - elim H0; intro. - - cut (open_set (f0 x) -> open_set (fun y:R => f0 x y /\ D x)). - + intro; apply H2; apply H. - + unfold open_set; unfold neighbourhood; intros; elim H3; - intros; assert (H6 := H2 _ H4); elim H6; intros; exists x1; - unfold included; intros; split. - * apply (H7 _ H8). - * assumption. - - cut (open_set (fun y:R => False) -> open_set (fun y:R => f0 x y /\ D x)). - + intro; apply H2; apply open_set_P4. - + unfold open_set; unfold neighbourhood; intros; elim H3; - intros; elim H1; assumption. -Qed. - -Definition bounded (D:R -> Prop) : Prop := - exists m : R, (exists M : R, (forall x:R, D x -> m <= x <= M)). - -Lemma open_set_P6 : - forall D1 D2:R -> Prop, open_set D1 -> D1 =_D D2 -> open_set D2. -Proof. - unfold open_set; unfold neighbourhood; intros. - unfold eq_Dom in H0; elim H0; intros. - assert (H4 := H _ (H3 _ H1)). - elim H4; intros. - exists x0; apply included_trans with D1; assumption. -Qed. - -(**********) -Lemma compact_P1 : forall X:R -> Prop, compact X -> bounded X. -Proof. - intros; unfold compact in H; set (D := fun x:R => True); - set (g := fun x y:R => Rabs y < x); - cut (forall x:R, (exists y : _, g x y) -> True); - [ intro | intro; trivial ]. - set (f0 := mkfamily D g H0); assert (H1 := H f0); - cut (covering_open_set X f0). - - intro; assert (H3 := H1 H2); elim H3; intros D' H4; - unfold covering_finite in H4; elim H4; intros; unfold family_finite in H6; - unfold domain_finite in H6; elim H6; intros l H7; - unfold bounded; set (r := MaxRlist l). - exists (- r); exists r; intros. - unfold covering in H5; assert (H9 := H5 _ H8); elim H9; intros; - unfold subfamily in H10; simpl in H10; elim H10; intros; - assert (H13 := H7 x0); simpl in H13; cut (intersection_domain D D' x0). - + elim H13; clear H13; intros. - assert (H16 := H13 H15); unfold g in H11; split. - * cut (x0 <= r). - -- intro; cut (Rabs x < r). - ++ intro; assert (H19 := Rabs_def2 x r H18); elim H19; intros; left; assumption. - ++ apply Rlt_le_trans with x0; assumption. - -- apply (MaxRlist_P1 l x0 H16). - * cut (x0 <= r). - -- intro; apply Rle_trans with (Rabs x). - ++ apply RRle_abs. - ++ apply Rle_trans with x0. - ** left; apply H11. - ** assumption. - -- apply (MaxRlist_P1 l x0 H16). - + unfold intersection_domain, D; tauto. - - unfold covering_open_set; split. - + unfold covering; intros; simpl; exists (Rabs x + 1); - unfold g; pattern (Rabs x) at 1; rewrite <- Rplus_0_r; - apply Rplus_lt_compat_l; apply Rlt_0_1. - + unfold family_open_set; intro; case (Rtotal_order 0 x); intro. - * apply open_set_P6 with (disc 0 (mkposreal _ H2)). - -- apply disc_P1. - -- unfold eq_Dom; unfold f0; simpl; - unfold g, disc; split. - ++ unfold included; intros; unfold Rminus in H3; rewrite Ropp_0 in H3; - rewrite Rplus_0_r in H3; apply H3. - ++ unfold included; intros; unfold Rminus; rewrite Ropp_0; - rewrite Rplus_0_r; apply H3. - * apply open_set_P6 with (fun x:R => False). - -- apply open_set_P4. - -- unfold eq_Dom; split. - ++ unfold included; intros; elim H3. - ++ unfold included, f0; simpl; unfold g; intros; elim H2; - intro; - [ rewrite <- H4 in H3; assert (H5 := Rabs_pos x0); - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H5 H3)) - | assert (H6 := Rabs_pos x0); assert (H7 := Rlt_trans _ _ _ H3 H4); - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H6 H7)) ]. -Qed. - -(**********) -Lemma compact_P2 : forall X:R -> Prop, compact X -> closed_set X. -Proof. - intros; assert (H0 := closed_set_P1 X); elim H0; clear H0; intros _ H0; - apply H0; clear H0. - unfold eq_Dom; split. - { apply adherence_P1. } - unfold included; unfold adherence; - unfold point_adherent; intros; unfold compact in H; - assert (H1 := classic (X x)); elim H1; clear H1; intro. - { assumption. } - cut (forall y:R, X y -> 0 < Rabs (y - x) / 2). - 1:intro; set (D := X); - set (g := fun y z:R => Rabs (y - z) < Rabs (y - x) / 2 /\ D y); - cut (forall x:R, (exists y : _, g x y) -> D x). - 1:intro; set (f0 := mkfamily D g H3); assert (H4 := H f0); - cut (covering_open_set X f0). - 1:intro; assert (H6 := H4 H5); elim H6; clear H6; intros D' H6. - 1:unfold covering_finite in H6; decompose [and] H6; - unfold covering, subfamily in H7; simpl in H7; - unfold family_finite, subfamily in H8; simpl in H8; - unfold domain_finite in H8; elim H8; clear H8; intros l H8; - set (alp := MinRlist (AbsList l x)); cut (0 < alp). - 1:intro; assert (H10 := H0 (disc x (mkposreal _ H9))); - cut (neighbourhood (disc x (mkposreal alp H9)) x). - 1:intro; assert (H12 := H10 H11); elim H12; clear H12; intros y H12; - unfold intersection_domain in H12; elim H12; clear H12; - intros; assert (H14 := H7 _ H13); elim H14; clear H14; - intros y0 H14; elim H14; clear H14; intros; unfold g in H14; - elim H14; clear H14; intros; unfold disc in H12; simpl in H12; - cut (alp <= Rabs (y0 - x) / 2). - 1:intro; assert (H18 := Rlt_le_trans _ _ _ H12 H17); - cut (Rabs (y0 - x) < Rabs (y0 - x)). - - intro; elim (Rlt_irrefl _ H19). - - apply Rle_lt_trans with (Rabs (y0 - y) + Rabs (y - x)). - + replace (y0 - x) with (y0 - y + (y - x)); [ apply Rabs_triang | ring ]. - + rewrite <-(Rplus_half_diag (Rabs (y0 - x))); apply Rplus_lt_compat; assumption. - - apply (MinRlist_P1 (AbsList l x) (Rabs (y0 - x) / 2)); apply AbsList_P1; - elim (H8 y0); clear H8; intros; apply H8; unfold intersection_domain; - split; assumption. - - assert (H11 := disc_P1 x (mkposreal alp H9)); unfold open_set in H11; - apply H11. - unfold disc; unfold Rminus; rewrite Rplus_opp_r; - rewrite Rabs_R0; apply H9. - - unfold alp; apply MinRlist_P2; intros; - assert (H10 := AbsList_P2 _ _ _ H9); elim H10; clear H10; - intros z H10; elim H10; clear H10; intros; rewrite H11; - apply H2; elim (H8 z); clear H8; intros; assert (H13 := H12 H10); - unfold intersection_domain, D in H13; elim H13; clear H13; - intros; assumption. - - unfold covering_open_set; split. - + unfold covering; intros; exists x0; simpl; unfold g; - split. - * unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0; - unfold Rminus in H2; apply (H2 _ H5). - * apply H5. - + unfold family_open_set; intro; simpl; unfold g; - elim (classic (D x0)); intro. - * apply open_set_P6 with (disc x0 (mkposreal _ (H2 _ H5))). - -- apply disc_P1. - -- unfold eq_Dom; split. - ++ unfold included, disc; simpl; intros; split. - ** rewrite <- (Rabs_Ropp (x0 - x1)); rewrite Ropp_minus_distr; apply H6. - ** apply H5. - ++ unfold included, disc; simpl; intros; elim H6; intros; - rewrite <- (Rabs_Ropp (x1 - x0)); rewrite Ropp_minus_distr; - apply H7. - * apply open_set_P6 with (fun z:R => False). - -- apply open_set_P4. - -- unfold eq_Dom; split. - ++ unfold included; intros; elim H6. - ++ unfold included; intros; elim H6; intros; elim H5; assumption. - - intros; elim H3; intros; unfold g in H4; elim H4; clear H4; intros _ H4; - apply H4. - - intros; unfold Rdiv; apply Rmult_lt_0_compat. - + apply Rabs_pos_lt; apply Rminus_eq_contra; red; intro; - rewrite H3 in H2; elim H1; apply H2. - + apply Rinv_0_lt_compat; prove_sup0. -Qed. - -(**********) -Lemma compact_EMP : compact (fun _:R => False). -Proof. - unfold compact; intros; exists (fun x:R => False); - unfold covering_finite; split. - - unfold covering; intros; elim H0. - - unfold family_finite; unfold domain_finite; exists nil; intro. - split. - + simpl; unfold intersection_domain; intros; elim H0. - elim H0; clear H0; intros _ H0; elim H0. - + simpl; intro; elim H0. -Qed. - -Lemma compact_eqDom : - forall X1 X2:R -> Prop, compact X1 -> X1 =_D X2 -> compact X2. -Proof. - unfold compact; intros; unfold eq_Dom in H0; elim H0; clear H0; - unfold included; intros; assert (H3 : covering_open_set X1 f0). - - unfold covering_open_set; unfold covering_open_set in H1; elim H1; - clear H1; intros; split. - + unfold covering in H1; unfold covering; intros; - apply (H1 _ (H0 _ H4)). - + apply H3. - - elim (H _ H3); intros D H4; exists D; unfold covering_finite; - unfold covering_finite in H4; elim H4; intros; split. - + unfold covering in H5; unfold covering; intros; - apply (H5 _ (H2 _ H7)). - + apply H6. -Qed. - -(** Borel-Lebesgue's lemma *) -Lemma compact_P3 : forall a b:R, compact (fun c:R => a <= c <= b). -Proof. - intros a b; destruct (Rle_dec a b) as [Hle|Hnle]. - - unfold compact; intros f0 (H,H5); - set - (A := - fun x:R => - a <= x <= b /\ - (exists D : R -> Prop, - covering_finite (fun c:R => a <= c <= x) (subfamily f0 D))). - cut (A a); [intro H0|]. - 1:cut (bound A); [intro H1|]. - 1:cut (exists a0 : R, A a0); [intro H2|]. - 1:pose proof (completeness A H1 H2) as (m,H3); unfold is_lub in H3. - 1:cut (a <= m <= b); [intro H4|]. - 1:unfold covering in H; pose proof (H m H4) as (y0,H6). - 1:unfold family_open_set in H5; pose proof (H5 y0 m H6) as (eps,H8). - 1:cut (exists x : R, A x /\ m - eps < x <= m); - [intros (x,((H9 & Dx & H12 & H13),(Hltx,_)))|]. - + destruct (Req_dec m b) as [->|H11]. - * set (Db := fun x:R => Dx x \/ x = y0); exists Db; - unfold covering_finite; split. - -- unfold covering; intros x0 (H14,H18); - unfold covering in H12; destruct (Rle_dec x0 x) as [Hle'|Hnle']. - ++ cut (a <= x0 <= x); [intro H15|]. - ** pose proof (H12 x0 H15) as (x1 & H16 & H17); exists x1; - simpl; unfold Db; split; [ apply H16 | left; apply H17 ]. - ** split; assumption. - ++ exists y0; simpl; split. - ** apply H8; unfold disc; - rewrite <- Rabs_Ropp, Ropp_minus_distr, Rabs_right. - { apply Rlt_trans with (b - x). - - unfold Rminus; apply Rplus_lt_compat_l, Ropp_lt_gt_contravar; - auto with real. - - apply Rplus_lt_reg_l with (x - eps); - replace (x - eps + (b - x)) with (b - eps); - [ replace (x - eps + eps) with x; [ apply Hltx | ring ] | ring ]. } - apply Rge_minus, Rle_ge, H18. - ** unfold Db; right; reflexivity. - -- unfold family_finite, domain_finite. - intros; unfold family_finite in H13; unfold domain_finite in H13; - destruct H13 as (l,H13); exists (cons y0 l); - intro; split. - ++ intro H14; simpl in H14; unfold intersection_domain in H14; - specialize H13 with x0; destruct H13 as (H13,H15); - destruct (Req_dec x0 y0) as [H16|H16]. - ** simpl; left. symmetry; apply H16. - ** simpl; right; apply H13. - simpl; unfold intersection_domain; unfold Db in H14; - decompose [and or] H14. - { split; assumption. } - elim H16; assumption. - ++ intro H14; simpl in H14; destruct H14 as [H15|H15]; simpl; - unfold intersection_domain. - ** split. - { apply (cond_fam f0); rewrite <- H15; exists b; apply H6. } - unfold Db; right; symmetry; assumption. - ** simpl; unfold intersection_domain; elim (H13 x0). - intros _ H16; assert (H17 := H16 H15); simpl in H17; - unfold intersection_domain in H17; split. - { elim H17; intros; assumption. } - unfold Db; left; elim H17; intros; assumption. - * set (m' := Rmin (m + eps / 2) b). - cut (A m'); [intro H7|]. - -- destruct H3 as (H14,H15); unfold is_upper_bound in H14. - assert (H16 := H14 m' H7). - cut (m < m'); [intro H17|]. - ++ elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H16 H17))... - ++ unfold m', Rmin; destruct (Rle_dec (m + eps / 2) b) as [Hle'|Hnle']. - ** pattern m at 1; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l; - unfold Rdiv; apply Rmult_lt_0_compat; - [ apply (cond_pos eps) | apply Rinv_0_lt_compat; prove_sup0 ]. - ** destruct H4 as (_,[]). - { assumption. } - elim H11; assumption. - -- unfold A; split;[split|]. - ++ apply Rle_trans with m. - { elim H4; intros; assumption. } - unfold m'; unfold Rmin; case (Rle_dec (m + eps / 2) b); intro. - { pattern m at 1; rewrite <- Rplus_0_r; apply Rplus_le_compat_l; left; - unfold Rdiv; apply Rmult_lt_0_compat; - [ apply (cond_pos eps) | apply Rinv_0_lt_compat; prove_sup0 ]. } - destruct H4. - assumption. - ++ unfold m'; apply Rmin_r. - ++ set (Db := fun x:R => Dx x \/ x = y0); exists Db; - unfold covering_finite; split. - ** unfold covering; intros x0 (H14,H18); - unfold covering in H12; destruct (Rle_dec x0 x) as [Hle'|Hnle']. - { cut (a <= x0 <= x); [intro H15|]. - - pose proof (H12 x0 H15) as (x1 & H16 & H17); exists x1; - simpl; unfold Db; split; [ apply H16 | left; apply H17 ]. - - split; assumption. } - exists y0; simpl; split. - { apply H8; unfold disc, Rabs; destruct (Rcase_abs (x0 - m)) as [Hlt|Hge]. - - rewrite Ropp_minus_distr; apply Rlt_trans with (m - x). - + unfold Rminus; apply Rplus_lt_compat_l; apply Ropp_lt_gt_contravar; - auto with real. - + apply Rplus_lt_reg_l with (x - eps); - replace (x - eps + (m - x)) with (m - eps) by ring. - replace (x - eps + eps) with x by ring. - assumption. - - apply Rle_lt_trans with (m' - m). - + unfold Rminus; do 2 rewrite <- (Rplus_comm (- m)); - apply Rplus_le_compat_l; elim H14; intros; assumption. - + apply Rplus_lt_reg_l with m; replace (m + (m' - m)) with m' by ring. - apply Rle_lt_trans with (m + eps / 2). - { unfold m'; apply Rmin_l. } - apply Rplus_lt_compat_l; apply Rmult_lt_reg_l with 2. - { prove_sup0. } - unfold Rdiv; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc; - rewrite Rinv_r. - { rewrite Rmult_1_l; pattern (pos eps) at 1; rewrite <- Rplus_0_r; - rewrite <-Rplus_diag; apply Rplus_lt_compat_l; apply (cond_pos eps). } - discrR. - } - unfold Db; right; reflexivity. - ** { unfold family_finite, domain_finite; - unfold family_finite, domain_finite in H13; - destruct H13 as (l,H13); exists (cons y0 l); - intro; split. - - intro H14; simpl in H14; unfold intersection_domain in H14; - specialize (H13 x0); destruct H13 as (H13,H15); - destruct (Req_dec x0 y0) as [Heq|Hneq]. - { simpl; left; symmetry; apply Heq. } - simpl; right; apply H13; simpl; - unfold intersection_domain; unfold Db in H14; - decompose [and or] H14. - { split; assumption. } - elim Hneq; assumption. - - intros [H15|H15]. - + split. - * apply (cond_fam f0); rewrite <- H15; exists m; apply H6. - * unfold Db; right; symmetry; assumption. - + elim (H13 x0); intros _ H16. - assert (H17 := H16 H15). - simpl in H17. - unfold intersection_domain in H17. - split. - * elim H17; intros; assumption. - * unfold Db; left; elim H17; intros; assumption. - } - + elim (classic (exists x : R, A x /\ m - eps < x <= m)); intro H9. - { assumption. } - elim H3; intros H10 H11; cut (is_upper_bound A (m - eps)). - * intro H12; assert (H13 := H11 _ H12); cut (m - eps < m). - { intro H14; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H13 H14)). } - pattern m at 2; rewrite <- Rplus_0_r; unfold Rminus; - apply Rplus_lt_compat_l; apply Ropp_lt_cancel; rewrite Ropp_involutive; - rewrite Ropp_0; apply (cond_pos eps). - * set (P := fun n:R => A n /\ m - eps < n <= m); - assert (H12 := not_ex_all_not _ P H9); unfold P in H12; - unfold is_upper_bound; intros x H13; - assert (H14 := not_and_or _ _ (H12 x)); elim H14; - intro H15. - { elim H15; apply H13. } - destruct (not_and_or _ _ H15) as [H16|H16]. - -- destruct (Rle_dec x (m - eps)) as [H17|H17]. - { assumption. } - elim H16; auto with real. - -- unfold is_upper_bound in H10; assert (H17 := H10 x H13); elim H16; apply H17. - + elim H3; clear H3; intros. - unfold is_upper_bound in H3. - split. - * apply (H3 _ H0). - * clear H5. - apply (H4 b); unfold is_upper_bound; intros x H5; unfold A in H5; elim H5; - clear H5; intros H5 _; elim H5; clear H5; intros _ H5; - apply H5. - + exists a; apply H0. - + unfold bound; exists b; unfold is_upper_bound; intros; - unfold A in H1; elim H1; clear H1; intros H1 _; elim H1; - clear H1; intros _ H1; apply H1. - + unfold A; split. - { split; [ right; reflexivity | apply Hle ]. } - unfold covering in H; cut (a <= a <= b). - * intro H1; elim (H _ H1); intros y0 H2; set (D' := fun x:R => x = y0); exists D'; - unfold covering_finite; split. - -- unfold covering; simpl; intros x H3; cut (x = a). - ++ intro H4; exists y0; split. - ** rewrite H4; apply H2. - ** unfold D'; reflexivity. - ++ elim H3; intros; apply Rle_antisym; assumption. - -- unfold family_finite; unfold domain_finite; - exists (cons y0 nil); intro; split. - ++ simpl; unfold intersection_domain; intros (H3,H4). - unfold D' in H4; left; symmetry; apply H4. - ++ simpl; unfold intersection_domain; intros [H4|[]]. - split; [ rewrite <- H4; apply (cond_fam f0); exists a; apply H2 | - symmetry; apply H4 ]. - * split; [ right; reflexivity | apply Hle ]. - - apply compact_eqDom with (fun c:R => False). - + apply compact_EMP. - + unfold eq_Dom; split. - * unfold included; intros; elim H. - * unfold included; intros; elim H; clear H; intros; - assert (H1 := Rle_trans _ _ _ H H0); elim Hnle; apply H1. -Qed. - -Lemma compact_P4 : - forall X F:R -> Prop, compact X -> closed_set F -> included F X -> compact F. -Proof. - unfold compact; intros; elim (classic (exists z : R, F z)); - intro Hyp_F_NE. - - set (D := ind f0); set (g := f f0); unfold closed_set in H0. - set (g' := fun x y:R => f0 x y \/ complementary F y /\ D x). - set (D' := D). - cut (forall x:R, (exists y : R, g' x y) -> D' x). - 1:intro; set (f' := mkfamily D' g' H3); cut (covering_open_set X f'). - + intro; elim (H _ H4); intros DX H5; exists DX. - unfold covering_finite; unfold covering_finite in H5; elim H5; - clear H5; intros. - split. - * unfold covering; unfold covering in H5; intros. - elim (H5 _ (H1 _ H7)); intros y0 H8; exists y0; simpl in H8; simpl; - elim H8; clear H8; intros. - split. - -- unfold g' in H8; elim H8; intro. - ++ apply H10. - ++ elim H10; intros H11 _; unfold complementary in H11; elim H11; apply H7. - -- apply H9. - * unfold family_finite; unfold domain_finite; - unfold family_finite in H6; unfold domain_finite in H6; - elim H6; clear H6; intros l H6; exists l; intro; assert (H7 := H6 x); - elim H7; clear H7; intros. - split. - -- intro; apply H7; simpl; unfold intersection_domain; - simpl in H9; unfold intersection_domain in H9; unfold D'; - apply H9. - -- intro; assert (H10 := H8 H9); simpl in H10; unfold intersection_domain in H10; - simpl; unfold intersection_domain; - unfold D' in H10; apply H10. - + unfold covering_open_set; unfold covering_open_set in H2; elim H2; - clear H2; intros. - split. - * unfold covering; unfold covering in H2; intros. - elim (classic (F x)); intro. - -- elim (H2 _ H6); intros y0 H7; exists y0; simpl; unfold g'; - left; assumption. - -- cut (exists z : R, D z). - ++ intro; elim H7; clear H7; intros x0 H7; exists x0; simpl; - unfold g'; right. - split. - ** unfold complementary; apply H6. - ** apply H7. - ++ elim Hyp_F_NE; intros z0 H7. - assert (H8 := H2 _ H7). - elim H8; clear H8; intros t H8; exists t; apply (cond_fam f0); exists z0; - apply H8. - * unfold family_open_set; intro; simpl; unfold g'; - elim (classic (D x)); intro. - -- apply open_set_P6 with (union_domain (f0 x) (complementary F)). - ++ apply open_set_P2. - ** unfold family_open_set in H4; apply H4. - ** apply H0. - ++ unfold eq_Dom; split. - ** unfold included, union_domain, complementary; intros. - elim H6; intro; [ left; apply H7 | right; split; assumption ]. - ** unfold included, union_domain, complementary; intros. - elim H6; intro; [ left; apply H7 | right; elim H7; intros; apply H8 ]. - -- apply open_set_P6 with (f0 x). - ++ unfold family_open_set in H4; apply H4. - ++ unfold eq_Dom; split. - ** unfold included, complementary; intros; left; apply H6. - ** unfold included, complementary; intros. - elim H6; intro. - { apply H7. } - elim H7; intros _ H8; elim H5; apply H8. - + intros; elim H3; intros y0 H4; unfold g' in H4; elim H4; intro. - * apply (cond_fam f0); exists y0; apply H5. - * elim H5; clear H5; intros _ H5; apply H5. - - (* Cas ou F est l'ensemble vide *) - cut (compact F). - + intro; apply (H3 f0 H2). - + apply compact_eqDom with (fun _:R => False). - * apply compact_EMP. - * unfold eq_Dom; split. - -- unfold included; intros; elim H3. - -- assert (H3 := not_ex_all_not _ _ Hyp_F_NE); unfold included; intros; - elim (H3 x); apply H4. -Qed. - -(**********) -Lemma compact_P5 : forall X:R -> Prop, closed_set X -> bounded X -> compact X. -Proof. - intros; unfold bounded in H0. - elim H0; clear H0; intros m H0. - elim H0; clear H0; intros M H0. - assert (H1 := compact_P3 m M). - apply (compact_P4 (fun c:R => m <= c <= M) X H1 H H0). -Qed. - -(**********) -Lemma compact_carac : - forall X:R -> Prop, compact X <-> closed_set X /\ bounded X. -Proof. - intro; split. - - intro; split; [ apply (compact_P2 _ H) | apply (compact_P1 _ H) ]. - - intro; elim H; clear H; intros; apply (compact_P5 _ H H0). -Qed. - -Definition image_dir (f:R -> R) (D:R -> Prop) (x:R) : Prop := - exists y : R, x = f y /\ D y. - -(**********) -Lemma continuity_compact : - forall (f:R -> R) (X:R -> Prop), - (forall x:R, continuity_pt f x) -> compact X -> compact (image_dir f X). -Proof. - unfold compact; intros; unfold covering_open_set in H1. - elim H1; clear H1; intros. - set (D := ind f1). - set (g := fun x y:R => image_rec f0 (f1 x) y). - cut (forall x:R, (exists y : R, g x y) -> D x). - 1:intro; set (f' := mkfamily D g H3). - 1:cut (covering_open_set X f'). - - intro; elim (H0 f' H4); intros D' H5; exists D'. - unfold covering_finite in H5; elim H5; clear H5; intros; - unfold covering_finite; split. - + unfold covering, image_dir; simpl; unfold covering in H5; - intros; elim H7; intros y H8; elim H8; intros; assert (H11 := H5 _ H10); - simpl in H11; elim H11; intros z H12; exists z; unfold g in H12; - unfold image_rec in H12; rewrite H9; apply H12. - + unfold family_finite in H6; unfold domain_finite in H6; - unfold family_finite; unfold domain_finite; - elim H6; intros l H7; exists l; intro; elim (H7 x); - intros; split; intro. - * apply H8; simpl in H10; simpl; apply H10. - * apply (H9 H10). - - unfold covering_open_set; split. - + unfold covering; intros; simpl; unfold covering in H1; - unfold image_dir in H1; unfold g; unfold image_rec; - apply H1. - exists x; split; [ reflexivity | apply H4 ]. - + unfold family_open_set; unfold family_open_set in H2; intro; - simpl; unfold g; - cut ((fun y:R => image_rec f0 (f1 x) y) = image_rec f0 (f1 x)). - * intro; rewrite H4. - apply (continuity_P2 f0 (f1 x) H (H2 x)). - * reflexivity. - - intros; apply (cond_fam f1); unfold g in H3; unfold image_rec in H3; elim H3; - intros; exists (f0 x0); apply H4. -Qed. - -Lemma prolongement_C0 : - forall (f:R -> R) (a b:R), - a <= b -> - (forall c:R, a <= c <= b -> continuity_pt f c) -> - exists g : R -> R, - continuity g /\ (forall c:R, a <= c <= b -> g c = f c). -Proof. - intros; elim H; intro. - - set - (h := - fun x:R => - match Rle_dec x a with - | left _ => f0 a - | right _ => - match Rle_dec x b with - | left _ => f0 x - | right _ => f0 b - end - end). - assert (H2 : 0 < b - a). { - apply Rlt_0_minus; assumption. - } - exists h; split. - + unfold continuity; intro; case (Rtotal_order x a); intro. - * unfold continuity_pt; unfold continue_in; - unfold limit1_in; unfold limit_in; - simpl; unfold Rdist; intros; exists (a - x); - split. - -- change (0 < a - x); apply Rlt_0_minus; assumption. - -- intros; elim H5; clear H5; intros _ H5; unfold h. - case (Rle_dec x a) as [|[]]. - ++ case (Rle_dec x0 a) as [|[]]. - ** unfold Rminus; rewrite Rplus_opp_r, Rabs_R0; assumption. - ** left; apply Rplus_lt_reg_l with (- x); - do 2 rewrite (Rplus_comm (- x)); apply Rle_lt_trans with (Rabs (x0 - x)). - { apply RRle_abs. } - assumption. - ++ left; assumption. - * elim H3; intro. - -- assert (H5 : a <= a <= b). { - split; [ right; reflexivity | left; assumption ]. - } - assert (H6 := H0 _ H5); unfold continuity_pt in H6; unfold continue_in in H6; - unfold limit1_in in H6; unfold limit_in in H6; simpl in H6; - unfold Rdist in H6; unfold continuity_pt; - unfold continue_in; unfold limit1_in; - unfold limit_in; simpl; unfold Rdist; - intros; elim (H6 _ H7); intros; exists (Rmin x0 (b - a)); - split. - ++ unfold Rmin; case (Rle_dec x0 (b - a)); intro. - ** elim H8; intros; assumption. - ** change (0 < b - a); apply Rlt_0_minus; assumption. - ++ intros; elim H9; clear H9; intros _ H9; cut (x1 < b). - ** intro; unfold h; case (Rle_dec x a) as [|[]]. - { case (Rle_dec x1 a) as [Hlta|Hnlea]. - - unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0; assumption. - - case (Rle_dec x1 b) as [Hleb|[]]. - + elim H8; intros; apply H12; split. - * unfold D_x, no_cond; split. - -- trivial. - -- red; intro; elim Hnlea; right; symmetry ; assumption. - * apply Rlt_le_trans with (Rmin x0 (b - a)). - -- rewrite H4 in H9; apply H9. - -- apply Rmin_l. - + left; assumption. - } - right; assumption. - ** apply Rplus_lt_reg_l with (- a); do 2 rewrite (Rplus_comm (- a)); - rewrite H4 in H9; apply Rle_lt_trans with (Rabs (x1 - a)). - { apply RRle_abs. } - apply Rlt_le_trans with (Rmin x0 (b - a)). - { assumption. } - apply Rmin_r. - -- case (Rtotal_order x b); intro. - ++ assert (H6 : a <= x <= b). { - split; left; assumption. - } - assert (H7 := H0 _ H6); unfold continuity_pt in H7; unfold continue_in in H7; - unfold limit1_in in H7; unfold limit_in in H7; simpl in H7; - unfold Rdist in H7; unfold continuity_pt; - unfold continue_in; unfold limit1_in; - unfold limit_in; simpl; unfold Rdist; - intros; elim (H7 _ H8); intros; elim H9; clear H9; - intros. - assert (H11 : 0 < x - a). - { apply Rlt_0_minus; assumption. } - assert (H12 : 0 < b - x). - { apply Rlt_0_minus; assumption. } - exists (Rmin x0 (Rmin (x - a) (b - x))); split. - ** unfold Rmin; case (Rle_dec (x - a) (b - x)) as [Hle|Hnle]. - { case (Rle_dec x0 (x - a)) as [Hlea|Hnlea]; assumption. } - case (Rle_dec x0 (b - x)) as [Hleb|Hnleb]; assumption. - ** intros x1 (H13,H14); cut (a < x1 < b). - { intro; elim H15; clear H15; intros; unfold h; case (Rle_dec x a) as [Hle|Hnle]. - - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ Hle H4)). - - case (Rle_dec x b) as [|[]]. - + case (Rle_dec x1 a) as [Hle0|]. - * elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ Hle0 H15)). - * case (Rle_dec x1 b) as [|[]]. - -- apply H10; split. - ++ assumption. - ++ apply Rlt_le_trans with (Rmin x0 (Rmin (x - a) (b - x))). - ** assumption. - ** apply Rmin_l. - -- left; assumption. - + left; assumption. - } - split. - { apply Ropp_lt_cancel; apply Rplus_lt_reg_l with x; - apply Rle_lt_trans with (Rabs (x1 - x)). - - rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; apply RRle_abs. - - apply Rlt_le_trans with (Rmin x0 (Rmin (x - a) (b - x))). - + assumption. - + apply Rle_trans with (Rmin (x - a) (b - x)). - * apply Rmin_r. - * apply Rmin_l. - } - apply Rplus_lt_reg_l with (- x); do 2 rewrite (Rplus_comm (- x)); - apply Rle_lt_trans with (Rabs (x1 - x)). - { apply RRle_abs. } - apply Rlt_le_trans with (Rmin x0 (Rmin (x - a) (b - x))). - { assumption. } - apply Rle_trans with (Rmin (x - a) (b - x)); apply Rmin_r. - ++ elim H5; intro. - ** assert (H7 : a <= b <= b). { - split; [ left; assumption | right; reflexivity ]. - } - assert (H8 := H0 _ H7); unfold continuity_pt in H8; unfold continue_in in H8; - unfold limit1_in in H8; unfold limit_in in H8; simpl in H8; - unfold Rdist in H8; unfold continuity_pt; - unfold continue_in; unfold limit1_in; - unfold limit_in; simpl; unfold Rdist; - intros; elim (H8 _ H9); intros; exists (Rmin x0 (b - a)); - split. - { unfold Rmin; case (Rle_dec x0 (b - a)); intro. - - elim H10; intros; assumption. - - change (0 < b - a); apply Rlt_0_minus; assumption. - } - intros; elim H11; clear H11; intros _ H11; cut (a < x1). - { intro; unfold h; case (Rle_dec x a) as [Hlea|Hnlea]. - - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ Hlea H4)). - - case (Rle_dec x1 a) as [Hlea'|Hnlea']. - + elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ Hlea' H12)). - + case (Rle_dec x b) as [Hleb|Hnleb]. - * case (Rle_dec x1 b) as [Hleb'|Hnleb']. - -- rewrite H6; elim H10; intros; destruct Hleb'. - ++ apply H14; split. - ** unfold D_x, no_cond; split. - { trivial. } - red; intro; rewrite <- H16 in H15; elim (Rlt_irrefl _ H15). - ** rewrite H6 in H11; apply Rlt_le_trans with (Rmin x0 (b - a)). - { apply H11. } - apply Rmin_l. - ++ rewrite H15; unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0; - assumption. - -- rewrite H6; unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0; - assumption. - * elim Hnleb; right; assumption. - } - rewrite H6 in H11; apply Ropp_lt_cancel; apply Rplus_lt_reg_l with b; - apply Rle_lt_trans with (Rabs (x1 - b)). - { rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; apply RRle_abs. } - apply Rlt_le_trans with (Rmin x0 (b - a)). - { assumption. } - apply Rmin_r. - ** unfold continuity_pt; unfold continue_in; - unfold limit1_in; unfold limit_in; - simpl; unfold Rdist; intros; exists (x - b); - split. - { change (0 < x - b); apply Rlt_0_minus; assumption. } - intros; elim H8; clear H8; intros. - assert (H10 : b < x0). { - apply Ropp_lt_cancel; apply Rplus_lt_reg_l with x; - apply Rle_lt_trans with (Rabs (x0 - x)). - - rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; apply RRle_abs. - - assumption. - } - unfold h; case (Rle_dec x a) as [Hle|Hnle]. - { elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ Hle H4)). } - case (Rle_dec x b) as [Hleb|Hnleb]. - { elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ Hleb H6)). } - case (Rle_dec x0 a) as [Hlea'|Hnlea']. - { elim (Rlt_irrefl _ (Rlt_trans _ _ _ H1 (Rlt_le_trans _ _ _ H10 Hlea'))). } - case (Rle_dec x0 b) as [Hleb'|Hnleb']. - { elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ Hleb' H10)). } - unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0; assumption. - + intros; elim H3; intros; unfold h; case (Rle_dec c a) as [[|]|]. - * elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H4 H6)). - * rewrite H6; reflexivity. - * case (Rle_dec c b) as [|[]]. - -- reflexivity. - -- assumption. - - exists (fun _:R => f0 a); split. - + apply derivable_continuous; apply (derivable_const (f0 a)). - + intros; elim H2; intros; rewrite H1 in H3; cut (b = c). - * intro; rewrite <- H5; rewrite H1; reflexivity. - * apply Rle_antisym; assumption. -Qed. - -(**********) -Lemma continuity_ab_maj : - forall (f:R -> R) (a b:R), - a <= b -> - (forall c:R, a <= c <= b -> continuity_pt f c) -> - exists Mx : R, (forall c:R, a <= c <= b -> f c <= f Mx) /\ a <= Mx <= b. -Proof. - intros; - cut - (exists g : R -> R, - continuity g /\ (forall c:R, a <= c <= b -> g c = f0 c)). - - intro HypProl. - elim HypProl; intros g Hcont_eq. - elim Hcont_eq; clear Hcont_eq; intros Hcont Heq. - assert (H1 := compact_P3 a b). - assert (H2 := continuity_compact g (fun c:R => a <= c <= b) Hcont H1). - assert (H3 := compact_P2 _ H2). - assert (H4 := compact_P1 _ H2). - cut (bound (image_dir g (fun c:R => a <= c <= b))). - 1:cut (exists x : R, image_dir g (fun c:R => a <= c <= b) x). - + intros; assert (H7 := completeness _ H6 H5). - elim H7; clear H7; intros M H7; cut (image_dir g (fun c:R => a <= c <= b) M). - * intro; unfold image_dir in H8; elim H8; clear H8; intros Mxx H8; elim H8; - clear H8; intros; exists Mxx; split. - -- intros; rewrite <- (Heq c H10); rewrite <- (Heq Mxx H9); intros; - rewrite <- H8; unfold is_lub in H7; elim H7; clear H7; - intros H7 _; unfold is_upper_bound in H7; apply H7; - unfold image_dir; exists c; split; [ reflexivity | apply H10 ]. - -- apply H9. - * elim (classic (image_dir g (fun c:R => a <= c <= b) M)); intro. - -- assumption. - -- cut - (exists eps : posreal, - (forall y:R, - ~ - intersection_domain (disc M eps) - (image_dir g (fun c:R => a <= c <= b)) y)). - { intro; elim H9; clear H9; intros eps H9; unfold is_lub in H7; elim H7; - clear H7; intros; - cut (is_upper_bound (image_dir g (fun c:R => a <= c <= b)) (M - eps)). - - intro; assert (H12 := H10 _ H11); cut (M - eps < M). - + intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H12 H13)). - + pattern M at 2; rewrite <- Rplus_0_r; unfold Rminus; - apply Rplus_lt_compat_l; apply Ropp_lt_cancel; rewrite Ropp_0; - rewrite Ropp_involutive; apply (cond_pos eps). - - unfold is_upper_bound, image_dir; intros; cut (x <= M). - + intro; destruct (Rle_dec x (M - eps)) as [H13|]. - * apply H13. - * elim (H9 x); unfold intersection_domain, disc, image_dir; split. - -- rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; rewrite Rabs_right. - ++ apply Rplus_lt_reg_l with (x - eps); - replace (x - eps + (M - x)) with (M - eps) by ring. - replace (x - eps + eps) with x by ring. - auto with real. - ++ apply Rge_minus; apply Rle_ge; apply H12. - -- apply H11. - + apply H7; apply H11. - } - cut - (exists V : R -> Prop, - neighbourhood V M /\ - (forall y:R, - ~ intersection_domain V (image_dir g (fun c:R => a <= c <= b)) y)). - { intro; elim H9; intros V H10; elim H10; clear H10; intros. - unfold neighbourhood in H10; elim H10; intros del H12; exists del; intros; - red; intro; elim (H11 y). - unfold intersection_domain; unfold intersection_domain in H13; - elim H13; clear H13; intros; split. - - apply (H12 _ H13). - - apply H14. } - cut (~ point_adherent (image_dir g (fun c:R => a <= c <= b)) M). - { intro; unfold point_adherent in H9. - assert - (H10 := - not_all_ex_not - _ - (fun V:R -> Prop => - neighbourhood V M -> - exists y : R, - intersection_domain V (image_dir g (fun c:R => a <= c <= b)) y) H9). - elim H10; intros V0 H11; exists V0; assert (H12 := imply_to_and _ _ H11); - elim H12; clear H12; intros. - split. - - apply H12. - - apply (not_ex_all_not _ _ H13). - } - red; intro; cut (adherence (image_dir g (fun c:R => a <= c <= b)) M). - ++ intro; elim (closed_set_P1 (image_dir g (fun c:R => a <= c <= b))); - intros H11 _; assert (H12 := H11 H3). - elim H8. - unfold eq_Dom in H12; elim H12; clear H12; intros. - apply (H13 _ H10). - ++ apply H9. - + exists (g a); unfold image_dir; exists a; split. - * reflexivity. - * split; [ right; reflexivity | apply H ]. - + unfold bound; unfold bounded in H4; elim H4; clear H4; intros m H4; - elim H4; clear H4; intros M H4; exists M; unfold is_upper_bound; - intros; elim (H4 _ H5); intros _ H6; apply H6. - - apply prolongement_C0; assumption. -Qed. - -(**********) -Lemma continuity_ab_min : - forall (f:R -> R) (a b:R), - a <= b -> - (forall c:R, a <= c <= b -> continuity_pt f c) -> - exists mx : R, (forall c:R, a <= c <= b -> f mx <= f c) /\ a <= mx <= b. -Proof. - intros. - cut (forall c:R, a <= c <= b -> continuity_pt (- f0) c). - - intro; assert (H2 := continuity_ab_maj (- f0)%F a b H H1); elim H2; - intros x0 H3; exists x0; intros; split. - + intros; rewrite <- (Ropp_involutive (f0 x0)); - rewrite <- (Ropp_involutive (f0 c)); apply Ropp_le_contravar; - elim H3; intros; unfold opp_fct in H5; apply H5; apply H4. - + elim H3; intros; assumption. - - intros. - assert (H2 := H0 _ H1). - apply (continuity_pt_opp _ _ H2). -Qed. - - -(********************************************************) -(** * Proof of Bolzano-Weierstrass theorem *) -(********************************************************) - -Definition ValAdh (un:nat -> R) (x:R) : Prop := - forall (V:R -> Prop) (N:nat), - neighbourhood V x -> exists p : nat, (N <= p)%nat /\ V (un p). - -Definition intersection_family (f:family) (x:R) : Prop := - forall y:R, ind f y -> f y x. - -Lemma ValAdh_un_exists : - forall (un:nat -> R) (D:=fun x:R => exists n : nat, x = INR n) - (f:= - fun x:R => - adherence - (fun y:R => (exists p : nat, y = un p /\ x <= INR p) /\ D x)) - (x:R), (exists y : R, f x y) -> D x. -Proof. - intros; elim H; intros; unfold f in H0; unfold adherence in H0; - unfold point_adherent in H0; - assert (H1 : neighbourhood (disc x0 (mkposreal _ Rlt_0_1)) x0). - - unfold neighbourhood, disc; exists (mkposreal _ Rlt_0_1); - unfold included; trivial. - - elim (H0 _ H1); intros; unfold intersection_domain in H2; elim H2; intros; - elim H4; intros; apply H6. -Qed. - -Definition ValAdh_un (un:nat -> R) : R -> Prop := - let D := fun x:R => exists n : nat, x = INR n in - let f := - fun x:R => - adherence - (fun y:R => (exists p : nat, y = un p /\ x <= INR p) /\ D x) in - intersection_family (mkfamily D f (ValAdh_un_exists un)). - -Lemma ValAdh_un_prop : - forall (un:nat -> R) (x:R), ValAdh un x <-> ValAdh_un un x. -Proof. - intros; split; intro. - - unfold ValAdh in H; unfold ValAdh_un; - unfold intersection_family; simpl; - intros; elim H0; intros N H1; unfold adherence; - unfold point_adherent; intros; elim (H V N H2); - intros; exists (un x0); unfold intersection_domain; - elim H3; clear H3; intros; split. - + assumption. - + split. - * exists x0; split; [ reflexivity | rewrite H1; apply (le_INR _ _ H3) ]. - * exists N; assumption. - - unfold ValAdh; intros; unfold ValAdh_un in H; - unfold intersection_family in H; simpl in H; - assert - (H1 : - adherence - (fun y0:R => - (exists p : nat, y0 = un p /\ INR N <= INR p) /\ - (exists n : nat, INR N = INR n)) x). - + apply H; exists N; reflexivity. - + unfold adherence in H1; unfold point_adherent in H1; assert (H2 := H1 _ H0); - elim H2; intros; unfold intersection_domain in H3; - elim H3; clear H3; intros; elim H4; clear H4; intros; - elim H4; clear H4; intros; elim H4; clear H4; intros; - exists x1; split. - * apply (INR_le _ _ H6). - * rewrite H4 in H3; apply H3. -Qed. - -Lemma adherence_P4 : - forall F G:R -> Prop, included F G -> included (adherence F) (adherence G). -Proof. - unfold adherence, included; unfold point_adherent; intros; - elim (H0 _ H1); unfold intersection_domain; - intros; elim H2; clear H2; intros; exists x0; split; - [ assumption | apply (H _ H3) ]. -Qed. - -Definition family_closed_set (f:family) : Prop := - forall x:R, closed_set (f x). - -Definition intersection_vide_in (D:R -> Prop) (f:family) : Prop := - forall x:R, - (ind f x -> included (f x) D) /\ - ~ (exists y : R, intersection_family f y). - -Definition intersection_vide_finite_in (D:R -> Prop) - (f:family) : Prop := intersection_vide_in D f /\ family_finite f. - -(**********) -Lemma compact_P6 : - forall X:R -> Prop, - compact X -> - (exists z : R, X z) -> - forall g:family, - family_closed_set g -> - intersection_vide_in X g -> - exists D : R -> Prop, intersection_vide_finite_in X (subfamily g D). -Proof. - intros X H Hyp g H0 H1. - set (D' := ind g). - set (f' := fun x y:R => complementary (g x) y /\ D' x). - assert (H2 : forall x:R, (exists y : R, f' x y) -> D' x). { - intros; elim H2; intros; unfold f' in H3; elim H3; intros; assumption. - } - set (f0 := mkfamily D' f' H2). - unfold compact in H; assert (H3 : covering_open_set X f0). - - unfold covering_open_set; split. - + unfold covering; intros; unfold intersection_vide_in in H1; - elim (H1 x); intros; unfold intersection_family in H5; - assert - (H6 := not_ex_all_not _ (fun y:R => forall y0:R, ind g y0 -> g y0 y) H5 x); - assert (H7 := not_all_ex_not _ (fun y0:R => ind g y0 -> g y0 x) H6); - elim H7; intros; exists x0; elim (imply_to_and _ _ H8); - intros; unfold f0; simpl; unfold f'; - split; [ apply H10 | apply H9 ]. - + unfold family_open_set; intro; elim (classic (D' x)); intro. - * apply open_set_P6 with (complementary (g x)). - -- unfold family_closed_set in H0; unfold closed_set in H0; apply H0. - -- unfold f0; simpl; unfold f'; unfold eq_Dom; - split. - ++ unfold included; intros; split; [ apply H4 | apply H3 ]. - ++ unfold included; intros; elim H4; intros; assumption. - * apply open_set_P6 with (fun _:R => False). - -- apply open_set_P4. - -- unfold eq_Dom; unfold included; split; intros; - [ elim H4 - | simpl in H4; unfold f' in H4; elim H4; intros; elim H3; assumption ]. - - elim (H _ H3); intros SF H4; exists SF; - unfold intersection_vide_finite_in; split. - + unfold intersection_vide_in; simpl; intros; split. - * intros; unfold included; intros; unfold intersection_vide_in in H1; - elim (H1 x); intros; elim H6; intros; apply H7. - -- unfold intersection_domain in H5; elim H5; intros; assumption. - -- assumption. - * elim (classic (exists y : R, intersection_domain (ind g) SF y)); intro Hyp'. - -- red; intro; elim H5; intros; unfold intersection_family in H6; - simpl in H6. - cut (X x0). - ++ intro; unfold covering_finite in H4; elim H4; clear H4; intros H4 _; - unfold covering in H4; elim (H4 x0 H7); intros; simpl in H8; - unfold intersection_domain in H6; cut (ind g x1 /\ SF x1). - ** intro; assert (H10 := H6 x1 H9); elim H10; clear H10; intros H10 _; elim H8; - clear H8; intros H8 _; unfold f' in H8; unfold complementary in H8; - elim H8; clear H8; intros H8 _; elim H8; assumption. - ** split. - { apply (cond_fam f0). - exists x0; elim H8; intros; assumption. } - elim H8; intros; assumption. - ++ unfold intersection_vide_in in H1; elim Hyp'; intros; assert (H8 := H6 _ H7); - elim H8; intros; cut (ind g x1). - ** intro; elim (H1 x1); intros; apply H12. - { apply H11. } - apply H9. - ** apply (cond_fam g); exists x0; assumption. - -- unfold covering_finite in H4; elim H4; clear H4; intros H4 _; - cut (exists z : R, X z). - ++ intro; elim H5; clear H5; intros; unfold covering in H4; elim (H4 x0 H5); - intros; simpl in H6; elim Hyp'; exists x1; elim H6; - intros; unfold intersection_domain; split. - ** apply (cond_fam f0); exists x0; apply H7. - ** apply H8. - ++ apply Hyp. - + unfold covering_finite in H4; elim H4; clear H4; intros; - unfold family_finite in H5; unfold domain_finite in H5; - unfold family_finite; unfold domain_finite; - elim H5; clear H5; intros l H5; exists l; intro; elim (H5 x); - intros; split; intro; - [ apply H6; simpl; simpl in H8; apply H8 | apply (H7 H8) ]. -Qed. - -Theorem Bolzano_Weierstrass : - forall (un:nat -> R) (X:R -> Prop), - compact X -> (forall n:nat, X (un n)) -> exists l : R, ValAdh un l. -Proof. - intros; cut (exists l : R, ValAdh_un un l). - - intro; elim H1; intros; exists x; elim (ValAdh_un_prop un x); intros; - apply (H4 H2). - - assert (H1 : exists z : R, X z). { - exists (un 0%nat); apply H0. - } - set (D := fun x:R => exists n : nat, x = INR n). - set - (g := - fun x:R => - adherence (fun y:R => (exists p : nat, y = un p /\ x <= INR p) /\ D x)). - assert (H2 : forall x:R, (exists y : R, g x y) -> D x). { - intros; elim H2; intros; unfold g in H3; unfold adherence in H3; - unfold point_adherent in H3. - assert (H4 : neighbourhood (disc x0 (mkposreal _ Rlt_0_1)) x0). { - unfold neighbourhood; exists (mkposreal _ Rlt_0_1); - unfold included; trivial. - } - elim (H3 _ H4); intros; unfold intersection_domain in H5; decompose [and] H5; - assumption. - } - set (f0 := mkfamily D g H2). - assert (H3 := compact_P6 X H H1 f0). - elim (classic (exists l : R, ValAdh_un un l)); intro. - + assumption. - + cut (family_closed_set f0). - 1:intro; cut (intersection_vide_in X f0). - * intro; assert (H7 := H3 H5 H6). - elim H7; intros SF H8; unfold intersection_vide_finite_in in H8; elim H8; - clear H8; intros; unfold intersection_vide_in in H8; - elim (H8 0); intros _ H10; elim H10; unfold family_finite in H9; - unfold domain_finite in H9; elim H9; clear H9; intros l H9; - set (r := MaxRlist l); cut (D r). - -- intro; unfold D in H11; elim H11; intros; exists (un x); - unfold intersection_family; simpl; - unfold intersection_domain; intros; split. - ++ unfold g; apply adherence_P1; split. - ** exists x; split; - [ reflexivity - | rewrite <- H12; unfold r; apply MaxRlist_P1; elim (H9 y); intros; - apply H14; simpl; apply H13 ]. - ** elim H13; intros; assumption. - ++ elim H13; intros; assumption. - -- elim (H9 r); intros. - simpl in H12; unfold intersection_domain in H12; cut (In r l). - ++ intro; elim (H12 H13); intros; assumption. - ++ unfold r; apply MaxRlist_P2; - cut (exists z : R, intersection_domain (ind f0) SF z). - ** intro; elim H13; intros; elim (H9 x); intros; simpl in H15; - assert (H17 := H15 H14); exists x; apply H17. - ** elim (classic (exists z : R, intersection_domain (ind f0) SF z)); intro. - { assumption. } - elim (H8 0); intros _ H14; elim H1; intros; - assert - (H16 := - not_ex_all_not _ (fun y:R => intersection_family (subfamily f0 SF) y) H14); - assert - (H17 := - not_ex_all_not _ (fun z:R => intersection_domain (ind f0) SF z) H13); - assert (H18 := H16 x); unfold intersection_family in H18; - simpl in H18; - assert - (H19 := - not_all_ex_not _ (fun y:R => intersection_domain D SF y -> g y x /\ SF y) - H18); elim H19; intros; assert (H21 := imply_to_and _ _ H20); - elim (H17 x0); elim H21; intros; assumption. - * unfold intersection_vide_in; intros; split. - -- intro; simpl in H6; unfold f0; simpl; unfold g; - apply included_trans with (adherence X). - ++ apply adherence_P4. - unfold included; intros; elim H7; intros; elim H8; intros; elim H10; - intros; rewrite H11; apply H0. - ++ apply adherence_P2; apply compact_P2; assumption. - -- apply H4. - * unfold family_closed_set; unfold f0; simpl; - unfold g; intro; apply adherence_P3. -Qed. - -(********************************************************) -(** * Proof of Heine's theorem *) -(********************************************************) - -Definition uniform_continuity (f:R -> R) (X:R -> Prop) : Prop := - forall eps:posreal, - exists delta : posreal, - (forall x y:R, - X x -> X y -> Rabs (x - y) < delta -> Rabs (f x - f y) < eps). - -Lemma is_lub_u : - forall (E:R -> Prop) (x y:R), is_lub E x -> is_lub E y -> x = y. -Proof. - unfold is_lub; intros; elim H; elim H0; intros; apply Rle_antisym; - [ apply (H4 _ H1) | apply (H2 _ H3) ]. -Qed. - -Lemma domain_P1 : - forall X:R -> Prop, - ~ (exists y : R, X y) \/ - (exists y : R, X y /\ (forall x:R, X x -> x = y)) \/ - (exists x : R, (exists y : R, X x /\ X y /\ x <> y)). -Proof. - intro; elim (classic (exists y : R, X y)); intro. - - right; elim H; intros; elim (classic (exists y : R, X y /\ y <> x)); intro. - + right; elim H1; intros; elim H2; intros; exists x; exists x0; intros. - split; - [ assumption - | split; [ assumption | apply (not_eq_sym (A:=R)); assumption ] ]. - + left; exists x; split. - * assumption. - * intros; case (Req_dec x0 x); intro. - -- assumption. - -- elim H1; exists x0; split; assumption. - - left; assumption. -Qed. - -Theorem Heine : - forall (f:R -> R) (X:R -> Prop), - compact X -> - (forall x:R, X x -> continuity_pt f x) -> uniform_continuity f X. -Proof. - intros f0 X H0 H; elim (domain_P1 X); intro Hyp. - - (* X is empty *) - unfold uniform_continuity; intros; exists (mkposreal _ Rlt_0_1); - intros; elim Hyp; exists x; assumption. - - elim Hyp; clear Hyp; intro Hyp. - + (* X has only one element *) - unfold uniform_continuity; intros; exists (mkposreal _ Rlt_0_1); - intros; elim Hyp; clear Hyp; intros; elim H4; clear H4; - intros; assert (H6 := H5 _ H1); assert (H7 := H5 _ H2); - rewrite H6; rewrite H7; unfold Rminus; rewrite Rplus_opp_r; - rewrite Rabs_R0; apply (cond_pos eps). - + (* X has at least two distinct elements *) - assert - (X_enc : - exists m : R, (exists M : R, (forall x:R, X x -> m <= x <= M) /\ m < M)). - * assert (H1 := compact_P1 X H0); unfold bounded in H1; elim H1; intros; - elim H2; intros; exists x; exists x0; split. - -- apply H3. - -- elim Hyp; intros; elim H4; intros; decompose [and] H5; - assert (H10 := H3 _ H6); assert (H11 := H3 _ H8); - elim H10; intros; elim H11; intros; - destruct (total_order_T x x0) as [[|H15]|H15]. - ++ assumption. - ++ rewrite H15 in H13, H7; elim H9; apply Rle_antisym; - apply Rle_trans with x0; assumption. - ++ elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ (Rle_trans _ _ _ H13 H14) H15)). - * elim X_enc; clear X_enc; intros m X_enc; elim X_enc; clear X_enc; - intros M X_enc; elim X_enc; clear X_enc Hyp; intros X_enc Hyp; - unfold uniform_continuity; intro; - assert (H1 : forall t:posreal, 0 < t / 2). - -- intro; unfold Rdiv; apply Rmult_lt_0_compat; - [ apply (cond_pos t) | apply Rinv_0_lt_compat; prove_sup0 ]. - -- set - (g := - fun x y:R => - X x /\ - (exists del : posreal, - (forall z:R, Rabs (z - x) < del -> Rabs (f0 z - f0 x) < eps / 2) /\ - is_lub - (fun zeta:R => - 0 < zeta <= M - m /\ - (forall z:R, Rabs (z - x) < zeta -> Rabs (f0 z - f0 x) < eps / 2)) - del /\ disc x (mkposreal (del / 2) (H1 del)) y)). - assert (H2 : forall x:R, (exists y : R, g x y) -> X x). { - intros; elim H2; intros; unfold g in H3; elim H3; clear H3; intros H3 _; - apply H3. - } - set (f' := mkfamily X g H2); unfold compact in H0; - assert (H3 : covering_open_set X f'). - ++ unfold covering_open_set; split. - ** unfold covering; intros; exists x; simpl; unfold g; - split. - { assumption. } - assert (H4 := H _ H3); unfold continuity_pt in H4; unfold continue_in in H4; - unfold limit1_in in H4; unfold limit_in in H4; simpl in H4; - unfold Rdist in H4; elim (H4 (eps / 2) (H1 eps)); - intros; - set - (E := - fun zeta:R => - 0 < zeta <= M - m /\ - (forall z:R, Rabs (z - x) < zeta -> Rabs (f0 z - f0 x) < eps / 2)); - assert (H6 : bound E). - { unfold bound; exists (M - m); unfold is_upper_bound; - unfold E; intros; elim H6; clear H6; intros H6 _; - elim H6; clear H6; intros _ H6; apply H6. - } - assert (H7 : exists x : R, E x). - { elim H5; clear H5; intros; exists (Rmin x0 (M - m)); unfold E; intros; - split;[ split|]. - - unfold Rmin; case (Rle_dec x0 (M - m)); intro. - + apply H5. - + apply Rlt_0_minus; apply Hyp. - - apply Rmin_r. - - intros; case (Req_dec x z); intro. - + rewrite H9; unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0; - apply (H1 eps). - + apply H7; split. - * unfold D_x, no_cond; split; [ trivial | assumption ]. - * apply Rlt_le_trans with (Rmin x0 (M - m)); [ apply H8 | apply Rmin_l ]. - } - destruct (completeness _ H6 H7) as (x1,p). - { cut (0 < x1 <= M - m). - - intros (H8,H9); exists (mkposreal _ H8); split. - + intros; cut (exists alp : R, Rabs (z - x) < alp <= x1 /\ E alp). - * intros; elim H11; intros; elim H12; clear H12; intros; unfold E in H13; - elim H13; intros; apply H15. - elim H12; intros; assumption. - * elim (classic (exists alp : R, Rabs (z - x) < alp <= x1 /\ E alp)); intro. - -- assumption. - -- assert - (H12 := - not_ex_all_not _ (fun alp:R => Rabs (z - x) < alp <= x1 /\ E alp) H11); - unfold is_lub in p; elim p; intros; cut (is_upper_bound E (Rabs (z - x))). - ++ intro; assert (H16 := H14 _ H15); - elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ H10 H16)). - ++ unfold is_upper_bound; intros; unfold is_upper_bound in H13; - assert (H16 := H13 _ H15); case (Rle_dec x2 (Rabs (z - x))); - intro. - ** assumption. - ** elim (H12 x2); split; [ split; [ auto with real | assumption ] | assumption ]. - + split. - * apply p. - * unfold disc; unfold Rminus; rewrite Rplus_opp_r; - rewrite Rabs_R0; simpl; unfold Rdiv; - apply Rmult_lt_0_compat; [ apply H8 | apply Rinv_0_lt_compat; prove_sup0 ]. - - elim H7; intros; unfold E in H8; elim H8; intros H9 _; elim H9; intros H10 _; - unfold is_lub in p; elim p; intros; unfold is_upper_bound in H12; - unfold is_upper_bound in H11; split. - + apply Rlt_le_trans with x2; [ assumption | apply (H11 _ H8) ]. - + apply H12; intros; unfold E in H13; elim H13; intros; elim H14; intros; - assumption. - } - ** { unfold family_open_set; intro; simpl; elim (classic (X x)); - intro. - - unfold g; unfold open_set; intros; elim H4; clear H4; - intros _ H4; elim H4; clear H4; intros; elim H4; clear H4; - intros; unfold neighbourhood; case (Req_dec x x0); - intro. - + exists (mkposreal _ (H1 x1)); rewrite <- H6; unfold included; intros; - split. - * assumption. - * exists x1; split. - -- apply H4. - -- split. - ++ elim H5; intros; apply H8. - ++ apply H7. - + set (d := x1 / 2 - Rabs (x0 - x)); assert (H7 : 0 < d). - * unfold d; apply Rlt_0_minus; elim H5; clear H5; intros; - unfold disc in H7; apply H7. - * exists (mkposreal _ H7); unfold included; intros; split. - { assumption. } - exists x1; split. - { apply H4. } - elim H5; intros; split. - { assumption. } - unfold disc in H8; simpl in H8; unfold disc; simpl; - unfold disc in H10; simpl in H10; - apply Rle_lt_trans with (Rabs (x2 - x0) + Rabs (x0 - x)). - { replace (x2 - x) with (x2 - x0 + (x0 - x)); [ apply Rabs_triang | ring ]. } - replace (x1 / 2) with (d + Rabs (x0 - x)); [ idtac | unfold d; ring ]. - do 2 rewrite <- (Rplus_comm (Rabs (x0 - x))); apply Rplus_lt_compat_l; - apply H8. - - apply open_set_P6 with (fun _:R => False). - + apply open_set_P4. - + unfold eq_Dom; unfold included; intros; split. - * intros; elim H4. - * intros; unfold g in H4; elim H4; clear H4; intros H4 _; elim H3; apply H4. - } - ++ elim (H0 _ H3); intros DF H4; unfold covering_finite in H4; elim H4; clear H4; - intros; unfold family_finite in H5; unfold domain_finite in H5; - unfold covering in H4; simpl in H4; simpl in H5; elim H5; - clear H5; intros l H5; unfold intersection_domain in H5; - cut - (forall x:R, - In x l -> - exists del : R, - 0 < del /\ - (forall z:R, Rabs (z - x) < del -> Rabs (f0 z - f0 x) < eps / 2) /\ - included (g x) (fun z:R => Rabs (z - x) < del / 2)). - ** { intros; - assert - (H7 := - Rlist_P1 l - (fun x del:R => - 0 < del /\ - (forall z:R, Rabs (z - x) < del -> Rabs (f0 z - f0 x) < eps / 2) /\ - included (g x) (fun z:R => Rabs (z - x) < del / 2)) H6); - elim H7; clear H7; intros l' H7; elim H7; clear H7; - intros; set (D := MinRlist l'); cut (0 < D / 2). - - intro; exists (mkposreal _ H9); intros; assert (H13 := H4 _ H10); elim H13; - clear H13; intros xi H13; assert (H14 : In xi l). - + unfold g in H13; decompose [and] H13; elim (H5 xi); intros; apply H14; split; - assumption. - + elim (pos_Rl_P2 l xi); intros H15 _; elim (H15 H14); intros i H16; elim H16; - intros; apply Rle_lt_trans with (Rabs (f0 x - f0 xi) + Rabs (f0 xi - f0 y)). - * replace (f0 x - f0 y) with (f0 x - f0 xi + (f0 xi - f0 y)); - [ apply Rabs_triang | ring ]. - * rewrite <-(Rplus_half_diag eps); apply Rplus_lt_compat. - -- assert (H19 := H8 i H17); elim H19; clear H19; intros; rewrite <- H18 in H20; - elim H20; clear H20; intros; apply H20; unfold included in H21; - apply Rlt_trans with (pos_Rl l' i / 2). - ++ apply H21. - elim H13; clear H13; intros; assumption. - ++ unfold Rdiv; apply Rmult_lt_reg_l with 2. - { prove_sup0. } - rewrite Rmult_comm; rewrite Rmult_assoc; rewrite Rinv_l. - { rewrite Rmult_1_r; pattern (pos_Rl l' i) at 1; rewrite <- Rplus_0_r; - rewrite <-Rplus_diag; apply Rplus_lt_compat_l; apply H19. } - discrR. - -- assert (H19 := H8 i H17); elim H19; clear H19; intros; rewrite <- H18 in H20; - elim H20; clear H20; intros; rewrite <- Rabs_Ropp; - rewrite Ropp_minus_distr; apply H20; unfold included in H21; - elim H13; intros; assert (H24 := H21 x H22); - apply Rle_lt_trans with (Rabs (y - x) + Rabs (x - xi)). - ++ replace (y - xi) with (y - x + (x - xi)); [ apply Rabs_triang | ring ]. - ++ rewrite <-(Rplus_half_diag (pos_Rl l' i)); apply Rplus_lt_compat. - ** apply Rlt_le_trans with (D / 2). - { rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; apply H12. } - unfold Rdiv; do 2 rewrite <- (Rmult_comm (/ 2)); - apply Rmult_le_compat_l. - { left; apply Rinv_0_lt_compat; prove_sup0. } - unfold D; apply MinRlist_P1; elim (pos_Rl_P2 l' (pos_Rl l' i)); - intros; apply H26; exists i; split; - [ rewrite <- H7; assumption | reflexivity ]. - ** assumption. - - unfold Rdiv; apply Rmult_lt_0_compat; - [ unfold D; apply MinRlist_P2; intros; elim (pos_Rl_P2 l' y); intros; - elim (H10 H9); intros; elim H12; intros; rewrite H14; - rewrite <- H7 in H13; elim (H8 x H13); intros; - apply H15 - | apply Rinv_0_lt_compat; prove_sup0 ]. - } - ** { intros; elim (H5 x); intros; elim (H8 H6); intros; - set - (E := - fun zeta:R => - 0 < zeta <= M - m /\ - (forall z:R, Rabs (z - x) < zeta -> Rabs (f0 z - f0 x) < eps / 2)); - assert (H11 : bound E). - - unfold bound; exists (M - m); unfold is_upper_bound; - unfold E; intros; elim H11; clear H11; intros H11 _; - elim H11; clear H11; intros _ H11; apply H11. - - assert (H12 : exists x : R, E x). { - assert (H13 := H _ H9); unfold continuity_pt in H13; - unfold continue_in in H13; unfold limit1_in in H13; - unfold limit_in in H13; simpl in H13; unfold Rdist in H13; - elim (H13 _ (H1 eps)); intros; elim H12; clear H12; - intros; exists (Rmin x0 (M - m)); unfold E; - intros; split. - - split; - [ unfold Rmin; case (Rle_dec x0 (M - m)); intro; - [ apply H12 | apply Rlt_0_minus; apply Hyp ] - | apply Rmin_r ]. - - intros; case (Req_dec x z); intro. - + rewrite H16; unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0; - apply (H1 eps). - + apply H14; split; - [ unfold D_x, no_cond; split; [ trivial | assumption ] - | apply Rlt_le_trans with (Rmin x0 (M - m)); - [ apply H15 | apply Rmin_l ] ]. - } - destruct (completeness _ H11 H12) as (x0,p). - cut (0 < x0 <= M - m). - + intro; elim H13; clear H13; intros; exists x0; split. - * assumption. - * split. - -- intros; cut (exists alp : R, Rabs (z - x) < alp <= x0 /\ E alp). - ++ intros; elim H16; intros; elim H17; clear H17; intros; unfold E in H18; - elim H18; intros; apply H20; elim H17; intros; assumption. - ++ elim (classic (exists alp : R, Rabs (z - x) < alp <= x0 /\ E alp)); intro. - { assumption. } - assert - (H17 := - not_ex_all_not _ (fun alp:R => Rabs (z - x) < alp <= x0 /\ E alp) H16); - unfold is_lub in p; elim p; intros; cut (is_upper_bound E (Rabs (z - x))). - ** intro; assert (H21 := H19 _ H20); - elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ H15 H21)). - ** unfold is_upper_bound; intros; unfold is_upper_bound in H18; - assert (H21 := H18 _ H20); case (Rle_dec x1 (Rabs (z - x))); - intro. - { assumption. } - elim (H17 x1); split. - { split; [ auto with real | assumption ]. } - assumption. - -- unfold included, g; intros; elim H15; intros; elim H17; intros; - decompose [and] H18; cut (x0 = x2). - ++ intro; rewrite H20; apply H22. - ++ unfold E in p; eapply is_lub_u. - ** apply p. - ** apply H21. - + elim H12; intros; unfold E in H13; elim H13; intros H14 _; elim H14; - intros H15 _; unfold is_lub in p; elim p; intros; - unfold is_upper_bound in H16; unfold is_upper_bound in H17; - split. - * apply Rlt_le_trans with x1; [ assumption | apply (H16 _ H13) ]. - * apply H17; intros; unfold E in H18; elim H18; intros; elim H19; intros; - assumption. - } -Qed. diff --git a/stdlib/theories/Reals/Rtrigo.v b/stdlib/theories/Reals/Rtrigo.v deleted file mode 100644 index 72468b1c1fa4..000000000000 --- a/stdlib/theories/Reals/Rtrigo.v +++ /dev/null @@ -1,27 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* R -> R, - fn = (fun (N:nat) (x:R) => (-1) ^ N / INR (fact (2 * N)) * x ^ (2 * N)) -> - CVN_R fn. -Proof. - unfold CVN_R in |- *; intros. - assert (hyp_r:(r:R) <> 0). { - assert (H0 := cond_pos r); lra. - } - unfold CVN_r in |- *. - exists (fun n:nat => / INR (fact (2 * n)) * r ^ (2 * n)). - cut - { l:R | - Un_cv - (fun n:nat => - sum_f_R0 (fun k:nat => Rabs (/ INR (fact (2 * k)) * r ^ (2 * k))) - n) l }. - { intros (x,p). - exists x. - split. - - apply p. - - intros; rewrite H; unfold Rdiv in |- *; do 2 rewrite Rabs_mult. - rewrite pow_1_abs; rewrite Rmult_1_l. - assert (0 < / INR (fact (2 * n))). { - apply Rinv_0_lt_compat; apply INR_fact_lt_0. - } - rewrite (Rabs_right _ (Rle_ge _ _ (Rlt_le _ _ H1))). - apply Rmult_le_compat_l. - { left; apply H1. } - rewrite <- RPow_abs; apply pow_maj_Rabs. - rewrite Rabs_Rabsolu. - unfold Boule in H0; rewrite Rminus_0_r in H0. - left; apply H0. } - apply Alembert_C2. - { intro; apply Rabs_no_R0. - apply prod_neq_R0. - - apply Rinv_neq_0_compat. - apply INR_fact_neq_0. - - apply pow_nonzero; assumption. } - assert (H0 := Alembert_cos). - unfold cos_n in H0; unfold Un_cv in H0; unfold Un_cv in |- *; intros. - assert (0 < eps / Rsqr r). { - unfold Rdiv in |- *; apply Rmult_lt_0_compat. - - apply H1. - - apply Rinv_0_lt_compat; apply Rsqr_pos_lt; assumption. - } - elim (H0 _ H2); intros N0 H3. - exists N0; intros. - unfold Rdist in |- *; assert (H5 := H3 _ H4). - unfold Rdist in H5; - replace - (Rabs - (Rabs (/ INR (fact (2 * S n)) * r ^ (2 * S n)) / - Rabs (/ INR (fact (2 * n)) * r ^ (2 * n)))) with - (Rsqr r * - Rabs ((-1) ^ S n / INR (fact (2 * S n)) / ((-1) ^ n / INR (fact (2 * n))))). - { apply Rmult_lt_reg_l with (/ Rsqr r). - { apply Rinv_0_lt_compat; apply Rsqr_pos_lt; assumption. } - pattern (/ Rsqr r) at 1 in |- *; replace (/ Rsqr r) with (Rabs (/ Rsqr r)). - 2:{ rewrite Rabs_inv. - rewrite Rabs_right. - - reflexivity. - - apply Rle_ge; apply Rle_0_sqr. } - rewrite <- Rabs_mult; rewrite Rmult_minus_distr_l; rewrite Rmult_0_r; - rewrite <- Rmult_assoc; rewrite Rinv_l. - 2:{ unfold Rsqr in |- *; apply prod_neq_R0; assumption. } - rewrite Rmult_1_l; rewrite <- (Rmult_comm eps); apply H5. } - rewrite (Rmult_comm (Rsqr r)); unfold Rdiv in |- *; repeat rewrite Rabs_mult; - rewrite Rabs_Rabsolu; rewrite pow_1_abs; rewrite Rmult_1_l; - repeat rewrite Rmult_assoc; apply Rmult_eq_compat_l. - rewrite Rabs_inv. - rewrite Rabs_mult; rewrite (pow_1_abs n); rewrite Rmult_1_l; - rewrite <- Rabs_inv. - rewrite Rinv_inv. - rewrite Rinv_mult. - rewrite Rabs_inv. - rewrite Rinv_inv. - rewrite (Rmult_comm (Rabs (Rabs (r ^ (2 * S n))))); rewrite Rabs_mult; - rewrite Rabs_Rabsolu; rewrite Rmult_assoc; apply Rmult_eq_compat_l. - rewrite Rabs_inv. - do 2 rewrite Rabs_Rabsolu; repeat rewrite Rabs_right. - 2,3:apply Rle_ge; apply pow_le; left; apply (cond_pos r). - replace (r ^ (2 * S n)) with (r ^ (2 * n) * r * r). - 2:{ replace (2 * S n)%nat with (S (S (2 * n))) by ring. - simpl; ring. } - repeat rewrite <- Rmult_assoc; rewrite Rinv_l. - 2:{ apply pow_nonzero; assumption. } - unfold Rsqr; ring. -Qed. - -(**********) -Lemma continuity_cos : continuity cos. -Proof. - set (fn := fun (N:nat) (x:R) => (-1) ^ N / INR (fact (2 * N)) * x ^ (2 * N)). - cut (CVN_R fn). - 1:intro; cut (forall x:R, { l:R | Un_cv (fun N:nat => SP fn N x) l }). - 1:intro cv; cut (forall n:nat, continuity (fn n)). - 1:intro; cut (forall x:R, cos x = SFL fn cv x). - 1:intro; cut (continuity (SFL fn cv) -> continuity cos). - - intro; apply H1. - apply SFL_continuity; assumption. - - unfold continuity in |- *; unfold continuity_pt in |- *; - unfold continue_in in |- *; unfold limit1_in in |- *; - unfold limit_in in |- *; simpl in |- *; unfold Rdist in |- *; - intros. - elim (H1 x _ H2); intros. - exists x0; intros. - elim H3; intros. - split. - + apply H4. - + intros; rewrite (H0 x); rewrite (H0 x1); apply H5; apply H6. - - intro; unfold cos, SFL in |- *. - case (cv x) as (x1,HUn); case (exist_cos (Rsqr x)) as (x0,Hcos); intros. - symmetry; eapply UL_sequence. - + apply HUn. - + unfold cos_in, infinite_sum in Hcos; unfold Un_cv in |- *; intros. - elim (Hcos _ H0); intros N0 H1. - exists N0; intros. - unfold Rdist in H1; unfold Rdist, SP in |- *. - replace (sum_f_R0 (fun k:nat => fn k x) n) with - (sum_f_R0 (fun i:nat => cos_n i * Rsqr x ^ i) n). - * apply H1; assumption. - * apply sum_eq; intros. - unfold cos_n, fn in |- *; apply Rmult_eq_compat_l. - unfold Rsqr in |- *; rewrite pow_sqr; reflexivity. - - intro; unfold fn in |- *; - replace (fun x:R => (-1) ^ n / INR (fact (2 * n)) * x ^ (2 * n)) with - (fct_cte ((-1) ^ n / INR (fact (2 * n))) * pow_fct (2 * n))%F; - [ idtac | reflexivity ]. - apply continuity_mult. - + apply derivable_continuous; apply derivable_const. - + apply derivable_continuous; apply (derivable_pow (2 * n)). - - apply CVN_R_CVS; apply X. - - apply CVN_R_cos; unfold fn in |- *; reflexivity. -Qed. - -Lemma sin_gt_cos_7_8 : sin (7 / 8) > cos (7 / 8). -Proof. -assert (lo1 : 0 <= 7/8) by lra. -assert (up1 : 7/8 <= 4) by lra. -assert (lo : -2 <= 7/8) by lra. -assert (up : 7/8 <= 2) by lra. -destruct (pre_sin_bound _ 0 lo1 up1) as [lower _ ]. -destruct (pre_cos_bound _ 0 lo up) as [_ upper]. -apply Rle_lt_trans with (1 := upper). -apply Rlt_le_trans with (2 := lower). -unfold cos_approx, sin_approx. -simpl sum_f_R0. -unfold cos_term, sin_term; simpl fact; rewrite !INR_IZR_INZ. -simpl plus; simpl mult; simpl Z_of_nat. -field_simplify. -match goal with - |- IZR ?a / ?b < ?c / ?d => - apply Rmult_lt_reg_r with d;[apply (IZR_lt 0); reflexivity | - unfold Rdiv at 2; rewrite Rmult_assoc, Rinv_l, Rmult_1_r, Rmult_comm; - [ |apply not_eq_sym, Rlt_not_eq, (IZR_lt 0); reflexivity ]]; - apply Rmult_lt_reg_r with b;[apply (IZR_lt 0); reflexivity | ] -end. -unfold Rdiv; rewrite !Rmult_assoc, Rinv_l, Rmult_1_r; - [ | apply not_eq_sym, Rlt_not_eq, (IZR_lt 0); reflexivity]. -rewrite <- !mult_IZR. -apply IZR_lt; reflexivity. -Qed. - -Definition PI_2_aux : {z | 7/8 <= z <= 7/4 /\ -cos z = 0}. -assert (cc : continuity (fun r =>- cos r)). { - apply continuity_opp, continuity_cos. -} -assert (cvp : 0 < cos (7/8)). { - assert (int78 : -2 <= 7/8 <= 2) by (split; lra). - destruct int78 as [lower upper]. - case (pre_cos_bound _ 0 lower upper). - unfold cos_approx; simpl sum_f_R0; unfold cos_term. - intros cl _; apply Rlt_le_trans with (2 := cl); simpl. - lra. -} -assert (cun : cos (7/4) < 0). { - replace (7/4) with (7/8 + 7/8) by field. - rewrite cos_plus. - apply Rlt_minus; apply Rsqr_incrst_1. - - exact sin_gt_cos_7_8. - - apply Rlt_le; assumption. - - apply Rlt_le; apply Rlt_trans with (1 := cvp); exact sin_gt_cos_7_8. -} -apply IVT; auto; lra. -Qed. - -Definition PI2 := proj1_sig PI_2_aux. - -Definition PI := 2 * PI2. - -Lemma cos_pi2 : cos PI2 = 0. -unfold PI2; case PI_2_aux; simpl. -intros x [_ q]; rewrite <- (Ropp_involutive (cos x)), q; apply Ropp_0. -Qed. - -Lemma pi2_int : 7/8 <= PI2 <= 7/4. -unfold PI2; case PI_2_aux; simpl; tauto. -Qed. - -(**********) -Lemma cos_minus : forall x y:R, cos (x - y) = cos x * cos y + sin x * sin y. -Proof. - intros; unfold Rminus in |- *; rewrite cos_plus. - rewrite <- cos_sym; rewrite sin_antisym; ring. -Qed. - -(**********) -Lemma sin2_cos2 : forall x:R, Rsqr (sin x) + Rsqr (cos x) = 1. -Proof. - intro; unfold Rsqr in |- *; rewrite Rplus_comm; rewrite <- (cos_minus x x); - unfold Rminus in |- *; rewrite Rplus_opp_r; apply cos_0. -Qed. - -Lemma cos2 : forall x:R, Rsqr (cos x) = 1 - Rsqr (sin x). -Proof. - intros x; rewrite <- (sin2_cos2 x); ring. -Qed. - -Lemma sin2 : forall x:R, Rsqr (sin x) = 1 - Rsqr (cos x). -Proof. - intro x; generalize (cos2 x); intro H1; rewrite H1. - unfold Rminus in |- *; rewrite Ropp_plus_distr; rewrite <- Rplus_assoc; - rewrite Rplus_opp_r; rewrite Rplus_0_l; symmetry in |- *; - apply Ropp_involutive. -Qed. - -(**********) -Lemma cos_PI2 : cos (PI / 2) = 0. -Proof. - unfold PI; generalize cos_pi2; replace ((2 * PI2)/2) with PI2 by field; tauto. -Qed. - -Lemma sin_pos_tech : forall x, 0 < x < 2 -> 0 < sin x. -intros x [int1 int2]. -assert (lo : 0 <= x) by (apply Rlt_le; assumption). -assert (up : x <= 4) by (apply Rlt_le, Rlt_trans with (1:=int2); lra). -destruct (pre_sin_bound _ 0 lo up) as [t _]; clear lo up. -apply Rlt_le_trans with (2:= t); clear t. -unfold sin_approx; simpl sum_f_R0; unfold sin_term; simpl. -match goal with |- _ < ?a => - replace a with (x * (1 - x^2/6)) by (simpl; field) -end. -assert (t' : x ^ 2 <= 4). { - replace 4 with (2 ^ 2) by field. - apply (pow_incr x 2); split; apply Rlt_le; assumption. -} -apply Rmult_lt_0_compat;[assumption | lra ]. -Qed. - -Lemma sin_PI2 : sin (PI / 2) = 1. -replace (PI / 2) with PI2 by (unfold PI; field). -assert (int' : 0 < PI2 < 2). { - destruct pi2_int; split; lra. -} -assert (lo2 := sin_pos_tech PI2 int'). -assert (t2 : Rabs (sin PI2) = 1). { - rewrite <- Rabs_R1; apply Rsqr_eq_abs_0. - rewrite Rsqr_1, sin2, cos_pi2, Rsqr_0, Rminus_0_r; reflexivity. -} -revert t2; rewrite Rabs_pos_eq;[| apply Rlt_le]; tauto. -Qed. - -Lemma PI_RGT_0 : PI > 0. -Proof. unfold PI; destruct pi2_int; lra. Qed. - -Lemma PI_4 : PI <= 4. -Proof. unfold PI; destruct pi2_int; lra. Qed. - -(**********) -Lemma PI_neq0 : PI <> 0. -Proof. - red in |- *; intro; assert (H0 := PI_RGT_0); rewrite H in H0; - elim (Rlt_irrefl _ H0). -Qed. - - -(**********) -Lemma cos_PI : cos PI = -1. -Proof. - replace PI with (PI / 2 + PI / 2). - - rewrite cos_plus. - rewrite sin_PI2; rewrite cos_PI2. - ring. - - apply Rplus_half_diag. -Qed. - -Lemma sin_PI : sin PI = 0. -Proof. - assert (H := sin2_cos2 PI). - rewrite cos_PI in H. - change (-1) with (-(1)) in H. - rewrite <- Rsqr_neg in H. - rewrite Rsqr_1 in H. - cut (Rsqr (sin PI) = 0). - - intro; apply (Rsqr_eq_0 _ H0). - - apply Rplus_eq_reg_l with 1. - rewrite Rplus_0_r; rewrite Rplus_comm; exact H. -Qed. - -Lemma sin_bound : forall (a : R) (n : nat), 0 <= a -> a <= PI -> - sin_approx a (2 * n + 1) <= sin a <= sin_approx a (2 * (n + 1)). -Proof. -intros a n a0 api; apply pre_sin_bound. -- assumption. -- apply Rle_trans with (1:= api) (2 := PI_4). -Qed. - -Lemma cos_bound : forall (a : R) (n : nat), - PI / 2 <= a -> a <= PI / 2 -> - cos_approx a (2 * n + 1) <= cos a <= cos_approx a (2 * (n + 1)). -Proof. -intros a n lower upper; apply pre_cos_bound. -- apply Rle_trans with (2 := lower). - apply Rmult_le_reg_r with 2; [lra |]. - replace ((-PI/2) * 2) with (-PI) by field. - assert (t := PI_4); lra. -- apply Rle_trans with (1 := upper). - apply Rmult_le_reg_r with 2; [lra | ]. - replace ((PI/2) * 2) with PI by field. - generalize PI_4; intros; lra. -Qed. -(**********) -Lemma neg_cos : forall x:R, cos (x + PI) = - cos x. -Proof. - intro x; rewrite cos_plus; rewrite sin_PI; rewrite cos_PI; ring. -Qed. - -(**********) -Lemma sin_cos : forall x:R, sin x = - cos (PI / 2 + x). -Proof. - intro x; rewrite cos_plus; rewrite sin_PI2; rewrite cos_PI2; ring. -Qed. - -(**********) -Lemma sin_plus : forall x y:R, sin (x + y) = sin x * cos y + cos x * sin y. -Proof. - intros. - rewrite (sin_cos (x + y)). - replace (PI / 2 + (x + y)) with (PI / 2 + x + y); [ rewrite cos_plus | ring ]. - rewrite (sin_cos (PI / 2 + x)). - replace (PI / 2 + (PI / 2 + x)) with (x + PI). - - rewrite neg_cos. - replace (cos (PI / 2 + x)) with (- sin x). - + ring. - + rewrite sin_cos; rewrite Ropp_involutive; reflexivity. - - pattern PI at 1 in |- *; rewrite <-(Rplus_half_diag PI); ring. -Qed. - -Lemma sin_minus : forall x y:R, sin (x - y) = sin x * cos y - cos x * sin y. -Proof. - intros; unfold Rminus in |- *; rewrite sin_plus. - rewrite <- cos_sym; rewrite sin_antisym; ring. -Qed. - -(**********) -Definition tan (x:R) : R := sin x / cos x. - -Lemma tan_plus : - forall x y:R, - cos x <> 0 -> - cos y <> 0 -> - cos (x + y) <> 0 -> - 1 - tan x * tan y <> 0 -> - tan (x + y) = (tan x + tan y) / (1 - tan x * tan y). -Proof. - intros; unfold tan in |- *; rewrite sin_plus; rewrite cos_plus; - unfold Rdiv in |- *; - replace (cos x * cos y - sin x * sin y) with - (cos x * cos y * (1 - sin x * / cos x * (sin y * / cos y))). - - rewrite Rinv_mult. - repeat rewrite <- Rmult_assoc; - replace ((sin x * cos y + cos x * sin y) * / (cos x * cos y)) with - (sin x * / cos x + sin y * / cos y). - + reflexivity. - + rewrite Rmult_plus_distr_r; rewrite Rinv_mult. - repeat rewrite Rmult_assoc; repeat rewrite (Rmult_comm (sin x)); - repeat rewrite <- Rmult_assoc. - repeat rewrite Rmult_inv_r_id_m; [ reflexivity | assumption | assumption ]. - - unfold Rminus in |- *; rewrite Rmult_plus_distr_l; rewrite Rmult_1_r; - apply Rplus_eq_compat_l; repeat rewrite Rmult_assoc; - rewrite (Rmult_comm (sin x)); rewrite (Rmult_comm (cos y)); - rewrite <- Ropp_mult_distr_r_reverse; repeat rewrite <- Rmult_assoc; - rewrite Rinv_r. - + rewrite Rmult_1_l; rewrite (Rmult_comm (sin x)); - rewrite <- Ropp_mult_distr_r_reverse; repeat rewrite Rmult_assoc; - apply Rmult_eq_compat_l; rewrite (Rmult_comm (/ cos y)); - rewrite Rmult_assoc; rewrite Rinv_r. - * apply Rmult_1_r. - * assumption. - + assumption. -Qed. - -(*******************************************************) -(** * Some properties of cos, sin and tan *) -(*******************************************************) - -Lemma sin_2a : forall x:R, sin (2 * x) = 2 * sin x * cos x. -Proof. - intro x; rewrite <-Rplus_diag; rewrite sin_plus. - rewrite <- (Rmult_comm (sin x)); symmetry in |- *; rewrite Rmult_assoc; - symmetry; apply Rplus_diag. -Qed. - -Lemma cos_2a : forall x:R, cos (2 * x) = cos x * cos x - sin x * sin x. -Proof. - intro x; rewrite <-Rplus_diag; apply cos_plus. -Qed. - -Lemma cos_2a_cos : forall x:R, cos (2 * x) = 2 * cos x * cos x - 1. -Proof. - intro x; rewrite <-Rplus_diag; unfold Rminus in |- *; rewrite Rmult_assoc; - rewrite cos_plus; generalize (sin2_cos2 x); rewrite <-Rplus_diag; - intro H1; rewrite <- H1; ring_Rsqr. -Qed. - -Lemma cos_2a_sin : forall x:R, cos (2 * x) = 1 - 2 * sin x * sin x. -Proof. - intro x; rewrite Rmult_assoc; unfold Rminus in |- *; repeat rewrite <-Rplus_diag. - generalize (sin2_cos2 x); intro H1; rewrite <- H1; rewrite cos_plus; - ring_Rsqr. -Qed. - -Lemma tan_2a : - forall x:R, - cos x <> 0 -> - cos (2 * x) <> 0 -> - 1 - tan x * tan x <> 0 -> tan (2 * x) = 2 * tan x / (1 - tan x * tan x). -Proof. - repeat rewrite <-Rplus_diag; intros; repeat rewrite <-Rplus_diag; rewrite <-Rplus_diag in H0; - apply tan_plus; assumption. -Qed. - -Lemma sin_neg : forall x:R, sin (- x) = - sin x. -Proof. - apply sin_antisym. -Qed. - -Lemma cos_neg : forall x:R, cos (- x) = cos x. -Proof. - intro; symmetry in |- *; apply cos_sym. -Qed. - -Lemma tan_0 : tan 0 = 0. -Proof. - unfold tan in |- *; rewrite sin_0; rewrite cos_0. - unfold Rdiv in |- *; apply Rmult_0_l. -Qed. - -Lemma tan_neg : forall x:R, tan (- x) = - tan x. -Proof. - intros x; unfold tan in |- *; rewrite sin_neg; rewrite cos_neg; - unfold Rdiv in |- *. - apply Ropp_mult_distr_l_reverse. -Qed. - -Lemma tan_minus : - forall x y:R, - cos x <> 0 -> - cos y <> 0 -> - cos (x - y) <> 0 -> - 1 + tan x * tan y <> 0 -> - tan (x - y) = (tan x - tan y) / (1 + tan x * tan y). -Proof. - intros; unfold Rminus in |- *; rewrite tan_plus. - - rewrite tan_neg; unfold Rminus in |- *; rewrite <- Ropp_mult_distr_l_reverse; - rewrite Rmult_opp_opp; reflexivity. - - assumption. - - rewrite cos_neg; assumption. - - assumption. - - rewrite tan_neg; unfold Rminus in |- *; rewrite <- Ropp_mult_distr_l_reverse; - rewrite Rmult_opp_opp; assumption. -Qed. - -Lemma cos_3PI2 : cos (3 * (PI / 2)) = 0. -Proof. - replace (3 * (PI / 2)) with (PI + PI / 2). - - rewrite cos_plus; rewrite sin_PI; rewrite cos_PI2; ring. - - pattern PI at 1 in |- *; rewrite <-(Rplus_half_diag PI). - ring. -Qed. - -Lemma sin_2PI : sin (2 * PI) = 0. -Proof. - rewrite sin_2a; rewrite sin_PI; ring. -Qed. - -Lemma cos_2PI : cos (2 * PI) = 1. -Proof. - rewrite cos_2a; rewrite sin_PI; rewrite cos_PI; ring. -Qed. - -Lemma neg_sin : forall x:R, sin (x + PI) = - sin x. -Proof. - intro x; rewrite sin_plus; rewrite sin_PI; rewrite cos_PI; ring. -Qed. - -Lemma sin_PI_x : forall x:R, sin (PI - x) = sin x. -Proof. - intro x; rewrite sin_minus; rewrite sin_PI; rewrite cos_PI. - ring. -Qed. - -Lemma sin_period : forall (x:R) (k:nat), sin (x + 2 * INR k * PI) = sin x. -Proof. - intros x k; induction k as [| k Hreck]. - - simpl in |- *; ring_simplify (x + 2 * 0 * PI). - trivial. - - - replace (x + 2 * INR (S k) * PI) with (x + 2 * INR k * PI + 2 * PI). - + rewrite sin_plus in |- *; rewrite sin_2PI in |- *; rewrite cos_2PI in |- *. - ring_simplify; trivial. - + rewrite S_INR in |- *; ring. -Qed. - -Lemma cos_period : forall (x:R) (k:nat), cos (x + 2 * INR k * PI) = cos x. -Proof. - intros x k; induction k as [| k Hreck]. - - simpl in |- *; ring_simplify (x + 2 * 0 * PI). - trivial. - - - replace (x + 2 * INR (S k) * PI) with (x + 2 * INR k * PI + 2 * PI). - + rewrite cos_plus in |- *; rewrite sin_2PI in |- *; rewrite cos_2PI in |- *. - ring_simplify; trivial. - + rewrite S_INR in |- *; ring. -Qed. - -Lemma sin_shift : forall x:R, sin (PI / 2 - x) = cos x. -Proof. - intro x; rewrite sin_minus; rewrite sin_PI2; rewrite cos_PI2; ring. -Qed. - -Lemma cos_shift : forall x:R, cos (PI / 2 - x) = sin x. -Proof. - intro x; rewrite cos_minus; rewrite sin_PI2; rewrite cos_PI2; ring. -Qed. - -Lemma cos_sin : forall x:R, cos x = sin (PI / 2 + x). -Proof. - intro x; rewrite sin_plus; rewrite sin_PI2; rewrite cos_PI2; ring. -Qed. - -Lemma PI2_RGT_0 : 0 < PI / 2. -Proof. - unfold Rdiv in |- *; apply Rmult_lt_0_compat; - [ apply PI_RGT_0 | apply Rinv_0_lt_compat; prove_sup ]. -Qed. - -Lemma SIN_bound : forall x:R, -1 <= sin x <= 1. -Proof. - intro; destruct (Rle_dec (-1) (sin x)) as [Hle|Hnle]. - - destruct (Rle_dec (sin x) 1) as [Hle'|Hnle']. - + split; assumption. - + cut (1 < sin x). - * intro; - generalize - (Rsqr_incrst_1 1 (sin x) H (Rlt_le 0 1 Rlt_0_1) - (Rlt_le 0 (sin x) (Rlt_trans 0 1 (sin x) Rlt_0_1 H))); - rewrite Rsqr_1; intro; rewrite sin2 in H0; unfold Rminus in H0. - generalize (Rplus_lt_compat_l (-1) 1 (1 + - Rsqr (cos x)) H0); - repeat rewrite <- Rplus_assoc; change (-1) with (-(1)); rewrite Rplus_opp_l; - rewrite Rplus_0_l; intro; rewrite <- Ropp_0 in H1; - generalize (Ropp_lt_gt_contravar (-0) (- Rsqr (cos x)) H1); - repeat rewrite Ropp_involutive; intro; generalize (Rle_0_sqr (cos x)); - intro; elim (Rlt_irrefl 0 (Rle_lt_trans 0 (Rsqr (cos x)) 0 H3 H2)). - * auto with real. - - cut (sin x < -1). - + intro; generalize (Ropp_lt_gt_contravar (sin x) (-1) H); - change (-1) with (-(1)); - rewrite Ropp_involutive; clear H; intro; - generalize - (Rsqr_incrst_1 1 (- sin x) H (Rlt_le 0 1 Rlt_0_1) - (Rlt_le 0 (- sin x) (Rlt_trans 0 1 (- sin x) Rlt_0_1 H))); - rewrite Rsqr_1; intro; rewrite <- Rsqr_neg in H0; - rewrite sin2 in H0; unfold Rminus in H0; - generalize (Rplus_lt_compat_l (-1) 1 (1 + - Rsqr (cos x)) H0); - rewrite <- Rplus_assoc; change (-1) with (-(1)); rewrite Rplus_opp_l; - rewrite Rplus_0_l; intro; rewrite <- Ropp_0 in H1; - generalize (Ropp_lt_gt_contravar (-0) (- Rsqr (cos x)) H1); - repeat rewrite Ropp_involutive; intro; generalize (Rle_0_sqr (cos x)); - intro; elim (Rlt_irrefl 0 (Rle_lt_trans 0 (Rsqr (cos x)) 0 H3 H2)). - + auto with real. -Qed. - -Lemma COS_bound : forall x:R, -1 <= cos x <= 1. -Proof. - intro; rewrite <- sin_shift; apply SIN_bound. -Qed. - -Lemma cos_sin_0 : forall x:R, ~ (cos x = 0 /\ sin x = 0). -Proof. - intro; red in |- *; intro; elim H; intros; generalize (sin2_cos2 x); intro; - rewrite H0 in H2; rewrite H1 in H2; repeat rewrite Rsqr_0 in H2; - rewrite Rplus_0_r in H2; generalize Rlt_0_1; intro; - rewrite <- H2 in H3; elim (Rlt_irrefl 0 H3). -Qed. - -Lemma cos_sin_0_var : forall x:R, cos x <> 0 \/ sin x <> 0. -Proof. - intros x. - destruct (Req_dec (cos x) 0). 2: now left. - right. intros H'. - apply (cos_sin_0 x). - now split. -Qed. - -(*****************************************************************) -(** * Using series definitions of cos and sin *) -(*****************************************************************) - -Definition sin_lb (a:R) : R := sin_approx a 3. -Definition sin_ub (a:R) : R := sin_approx a 4. -Definition cos_lb (a:R) : R := cos_approx a 3. -Definition cos_ub (a:R) : R := cos_approx a 4. - -Lemma sin_lb_gt_0 : forall a:R, 0 < a -> a <= PI / 2 -> 0 < sin_lb a. -Proof. - intros. - unfold sin_lb in |- *; unfold sin_approx in |- *; unfold sin_term in |- *. - set (Un := fun i:nat => a ^ (2 * i + 1) / INR (fact (2 * i + 1))). - replace - (sum_f_R0 - (fun i:nat => (-1) ^ i * (a ^ (2 * i + 1) / INR (fact (2 * i + 1)))) 3) - with (sum_f_R0 (fun i:nat => (-1) ^ i * Un i) 3); - [ idtac | apply sum_eq; intros; unfold Un in |- *; reflexivity ]. - cut (forall n:nat, Un (S n) < Un n). - { intro; simpl in |- *. - repeat rewrite Rmult_1_l; repeat rewrite Rmult_1_r; - replace (-1 * Un 1%nat) with (- Un 1%nat); [ idtac | ring ]; - replace (-1 * -1 * Un 2%nat) with (Un 2%nat); [ idtac | ring ]; - replace (-1 * (-1 * -1) * Un 3%nat) with (- Un 3%nat); - [ idtac | ring ]; - replace (Un 0%nat + - Un 1%nat + Un 2%nat + - Un 3%nat) with - (Un 0%nat - Un 1%nat + (Un 2%nat - Un 3%nat)); [ idtac | ring ]. - apply Rplus_lt_0_compat. - - unfold Rminus in |- *; apply Rplus_lt_reg_l with (Un 1%nat); - rewrite Rplus_0_r; rewrite (Rplus_comm (Un 1%nat)); - rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r; - apply H1. - - unfold Rminus in |- *; apply Rplus_lt_reg_l with (Un 3%nat); - rewrite Rplus_0_r; rewrite (Rplus_comm (Un 3%nat)); - rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r; - apply H1. } - intro; unfold Un in |- *. - assert ((2 * S n + 1)%nat = (2 * n + 1 + 2)%nat) by ring. - rewrite H1. - rewrite pow_add; unfold Rdiv in |- *; rewrite Rmult_assoc; - apply Rmult_lt_compat_l. - { apply pow_lt; assumption. } - rewrite <- H1; apply Rmult_lt_reg_l with (INR (fact (2 * n + 1))). - { apply INR_fact_lt_0. } - rewrite Rinv_r. - 2:{ apply INR_fact_neq_0. } - apply Rmult_lt_reg_l with (INR (fact (2 * S n + 1))). - { apply INR_fact_lt_0. } - rewrite (Rmult_comm (INR (fact (2 * S n + 1)))); repeat rewrite Rmult_assoc; - rewrite Rinv_l. - 2:{ apply INR_fact_neq_0. } - do 2 rewrite Rmult_1_r; apply Rle_lt_trans with (INR (fact (2 * n + 1)) * 4). - { apply Rmult_le_compat_l. - { apply pos_INR. } - simpl in |- *; rewrite Rmult_1_r; change 4 with (Rsqr 2); - apply Rsqr_incr_1;[|lra|lra]. - apply Rle_trans with (PI / 2); - [ assumption - | unfold Rdiv in |- *; apply Rmult_le_reg_l with 2; - [ prove_sup0 - | rewrite <- Rmult_assoc; rewrite Rmult_inv_r_id_m; - [ apply PI_4 | discrR ] ] ]. } - rewrite H1; replace (2 * n + 1 + 2)%nat with (S (S (2 * n + 1))) by ring. - do 2 rewrite fact_simpl; do 2 rewrite mult_INR. - repeat rewrite <- Rmult_assoc. - rewrite <- (Rmult_comm (INR (fact (2 * n + 1)))). - apply Rmult_lt_compat_l. - { apply INR_fact_lt_0. } - do 2 rewrite S_INR; rewrite plus_INR; rewrite mult_INR; set (x := INR n); - unfold INR in |- *. - pose proof (pos_INR _ : 0 <= x). - nra. -Qed. - -Lemma SIN : forall a:R, 0 <= a -> a <= PI -> sin_lb a <= sin a <= sin_ub a. -Proof. - intros; unfold sin_lb, sin_ub in |- *; apply (sin_bound a 1 H H0). -Qed. - -Lemma COS : - forall a:R, - PI / 2 <= a -> a <= PI / 2 -> cos_lb a <= cos a <= cos_ub a. -Proof. - intros; unfold cos_lb, cos_ub in |- *; apply (cos_bound a 1 H H0). -Qed. - -(**********) -Lemma _PI2_RLT_0 : - (PI / 2) < 0. -Proof. - assert (H := PI_RGT_0). - lra. -Qed. - -Lemma PI4_RLT_PI2 : PI / 4 < PI / 2. -Proof. - assert (H := PI_RGT_0). - lra. -Qed. - -Lemma PI2_Rlt_PI : PI / 2 < PI. -Proof. - assert (H := PI_RGT_0). - lra. -Qed. - -(***************************************************) -(** * Increasing and decreasing of [cos] and [sin] *) -(***************************************************) -Theorem sin_gt_0 : forall x:R, 0 < x -> x < PI -> 0 < sin x. -Proof. - intros; elim (SIN x (Rlt_le 0 x H) (Rlt_le x PI H0)); intros H1 _; - case (Rtotal_order x (PI / 2)); intro H2. - - apply Rlt_le_trans with (sin_lb x). - + apply sin_lb_gt_0; [ assumption | left; assumption ]. - + assumption. - - elim H2; intro H3. - + rewrite H3; rewrite sin_PI2; apply Rlt_0_1. - + rewrite <- sin_PI_x; generalize (Ropp_gt_lt_contravar x (PI / 2) H3); - intro H4; generalize (Rplus_lt_compat_l PI (- x) (- (PI / 2)) H4). - replace (PI + - (PI / 2)) with (PI / 2) by field. - intro H5; generalize (Ropp_lt_gt_contravar x PI H0); intro H6; - change (- PI < - x) in H6; generalize (Rplus_lt_compat_l PI (- PI) (- x) H6). - rewrite Rplus_opp_r. - intro H7; - elim - (SIN (PI - x) (Rlt_le 0 (PI - x) H7) - (Rlt_le (PI - x) PI (Rlt_trans (PI - x) (PI / 2) PI H5 PI2_Rlt_PI))); - intros H8 _; - generalize (sin_lb_gt_0 (PI - x) H7 (Rlt_le (PI - x) (PI / 2) H5)); - intro H9; apply (Rlt_le_trans 0 (sin_lb (PI - x)) (sin (PI - x)) H9 H8). -Qed. - -Theorem cos_gt_0 : forall x:R, - (PI / 2) < x -> x < PI / 2 -> 0 < cos x. -Proof. - intros; rewrite cos_sin; - generalize (Rplus_lt_compat_l (PI / 2) (- (PI / 2)) x H). - rewrite Rplus_opp_r; intro H1; - generalize (Rplus_lt_compat_l (PI / 2) x (PI / 2) H0); - rewrite Rplus_half_diag; intro H2; apply (sin_gt_0 (PI / 2 + x) H1 H2). -Qed. - -Lemma sin_ge_0 : forall x:R, 0 <= x -> x <= PI -> 0 <= sin x. -Proof. - intros x H1 H2; elim H1; intro H3; - [ elim H2; intro H4; - [ left; apply (sin_gt_0 x H3 H4) - | rewrite H4; right; symmetry in |- *; apply sin_PI ] - | rewrite <- H3; right; symmetry in |- *; apply sin_0 ]. -Qed. - -Lemma cos_ge_0 : forall x:R, - (PI / 2) <= x -> x <= PI / 2 -> 0 <= cos x. -Proof. - intros x H1 H2; elim H1; intro H3; - [ elim H2; intro H4; - [ left; apply (cos_gt_0 x H3 H4) - | rewrite H4; right; symmetry in |- *; apply cos_PI2 ] - | rewrite <- H3; rewrite cos_neg; right; symmetry in |- *; apply cos_PI2 ]. -Qed. - -Lemma sin_le_0 : forall x:R, PI <= x -> x <= 2 * PI -> sin x <= 0. -Proof. - intros x H1 H2; apply Rge_le; rewrite <- Ropp_0; - rewrite <- (Ropp_involutive (sin x)); apply Ropp_le_ge_contravar; - rewrite <- neg_sin; replace (x + PI) with (x - PI + 2 * INR 1 * PI); - [ rewrite (sin_period (x - PI) 1); apply sin_ge_0; - [ replace (x - PI) with (x + - PI); - [ rewrite Rplus_comm; replace 0 with (- PI + PI); - [ apply Rplus_le_compat_l; assumption | ring ] - | ring ] - | replace (x - PI) with (x + - PI); rewrite Rplus_comm; - [ pattern PI at 2 in |- *; replace PI with (- PI + 2 * PI); - [ apply Rplus_le_compat_l; assumption | ring ] - | ring ] ] - | unfold INR in |- *; ring ]. -Qed. - -Lemma cos_le_0 : forall x:R, PI / 2 <= x -> x <= 3 * (PI / 2) -> cos x <= 0. -Proof. - intros x H1 H2; apply Rge_le; rewrite <- Ropp_0; - rewrite <- (Ropp_involutive (cos x)); apply Ropp_le_ge_contravar; - rewrite <- neg_cos; replace (x + PI) with (x - PI + 2 * INR 1 * PI). - - rewrite cos_period; apply cos_ge_0. - + replace (- (PI / 2)) with (- PI + PI / 2) by field. - unfold Rminus in |- *; rewrite (Rplus_comm x); apply Rplus_le_compat_l; - assumption. - + unfold Rminus in |- *; rewrite Rplus_comm; - replace (PI / 2) with (- PI + 3 * (PI / 2)) by field. - apply Rplus_le_compat_l; assumption. - - unfold INR in |- *; ring. -Qed. - -Lemma sin_lt_0 : forall x:R, PI < x -> x < 2 * PI -> sin x < 0. -Proof. - intros x H1 H2; rewrite <- Ropp_0; rewrite <- (Ropp_involutive (sin x)); - apply Ropp_lt_gt_contravar; rewrite <- neg_sin; - replace (x + PI) with (x - PI + 2 * INR 1 * PI); - [ rewrite (sin_period (x - PI) 1); apply sin_gt_0; - [ replace (x - PI) with (x + - PI); - [ rewrite Rplus_comm; replace 0 with (- PI + PI); - [ apply Rplus_lt_compat_l; assumption | ring ] - | ring ] - | replace (x - PI) with (x + - PI); rewrite Rplus_comm; - [ pattern PI at 2 in |- *; replace PI with (- PI + 2 * PI); - [ apply Rplus_lt_compat_l; assumption | ring ] - | ring ] ] - | unfold INR in |- *; ring ]. -Qed. - -Lemma sin_lt_0_var : forall x:R, - PI < x -> x < 0 -> sin x < 0. -Proof. - intros; generalize (Rplus_lt_compat_l (2 * PI) (- PI) x H); - replace (2 * PI + - PI) with PI; - [ intro H1; rewrite Rplus_comm in H1; - generalize (Rplus_lt_compat_l (2 * PI) x 0 H0); - intro H2; rewrite (Rplus_comm (2 * PI)) in H2; - rewrite <- (Rplus_comm 0) in H2; rewrite Rplus_0_l in H2; - rewrite <- (sin_period x 1); unfold INR in |- *; - replace (2 * 1 * PI) with (2 * PI); - [ apply (sin_lt_0 (x + 2 * PI) H1 H2) | ring ] - | ring ]. -Qed. - -Lemma cos_lt_0 : forall x:R, PI / 2 < x -> x < 3 * (PI / 2) -> cos x < 0. -Proof. - intros x H1 H2; rewrite <- Ropp_0; rewrite <- (Ropp_involutive (cos x)); - apply Ropp_lt_gt_contravar; rewrite <- neg_cos; - replace (x + PI) with (x - PI + 2 * INR 1 * PI). - - rewrite cos_period; apply cos_gt_0. - + replace (- (PI / 2)) with (- PI + PI / 2) by field. - unfold Rminus in |- *; rewrite (Rplus_comm x); apply Rplus_lt_compat_l; - assumption. - + unfold Rminus in |- *; rewrite Rplus_comm; - replace (PI / 2) with (- PI + 3 * (PI / 2)) by field. - apply Rplus_lt_compat_l; assumption. - - unfold INR in |- *; ring. -Qed. - -Lemma tan_gt_0 : forall x:R, 0 < x -> x < PI / 2 -> 0 < tan x. -Proof. - intros x H1 H2; unfold tan in |- *; generalize _PI2_RLT_0; - generalize (Rlt_trans 0 x (PI / 2) H1 H2); intros; - generalize (Rlt_trans (- (PI / 2)) 0 x H0 H1); intro H5; - generalize (Rlt_trans x (PI / 2) PI H2 PI2_Rlt_PI); - intro H7; unfold Rdiv in |- *; apply Rmult_lt_0_compat. - - apply sin_gt_0; assumption. - - apply Rinv_0_lt_compat; apply cos_gt_0; assumption. -Qed. - -Lemma tan_lt_0 : forall x:R, - (PI / 2) < x -> x < 0 -> tan x < 0. -Proof. - intros x H1 H2; unfold tan in |- *; - generalize (cos_gt_0 x H1 (Rlt_trans x 0 (PI / 2) H2 PI2_RGT_0)); - intro H3; rewrite <- Ropp_0; - replace (sin x / cos x) with (- (- sin x / cos x)). - - rewrite <- sin_neg; apply Ropp_gt_lt_contravar; - change (0 < sin (- x) / cos x) in |- *; unfold Rdiv in |- *; - apply Rmult_lt_0_compat. - + apply sin_gt_0. - * rewrite <- Ropp_0; apply Ropp_gt_lt_contravar; assumption. - * apply Rlt_trans with (PI / 2). - -- rewrite <- (Ropp_involutive (PI / 2)); apply Ropp_gt_lt_contravar; assumption. - -- apply PI2_Rlt_PI. - + apply Rinv_0_lt_compat; assumption. - - unfold Rdiv in |- *; ring. -Qed. - -Lemma cos_ge_0_3PI2 : - forall x:R, 3 * (PI / 2) <= x -> x <= 2 * PI -> 0 <= cos x. -Proof. - intros; rewrite <- cos_neg; rewrite <- (cos_period (- x) 1); - unfold INR in |- *; replace (- x + 2 * 1 * PI) with (2 * PI - x) by ring. - generalize (Ropp_le_ge_contravar x (2 * PI) H0); intro H1; - generalize (Rge_le (- x) (- (2 * PI)) H1); clear H1; - intro H1; generalize (Rplus_le_compat_l (2 * PI) (- (2 * PI)) (- x) H1). - rewrite Rplus_opp_r. - intro H2; generalize (Ropp_le_ge_contravar (3 * (PI / 2)) x H); intro H3; - generalize (Rge_le (- (3 * (PI / 2))) (- x) H3); clear H3; - intro H3; - generalize (Rplus_le_compat_l (2 * PI) (- x) (- (3 * (PI / 2))) H3). - replace (2 * PI + - (3 * (PI / 2))) with (PI / 2) by field. - intro H4; - apply - (cos_ge_0 (2 * PI - x) - (Rlt_le (- (PI / 2)) (2 * PI - x) - (Rlt_le_trans (- (PI / 2)) 0 (2 * PI - x) _PI2_RLT_0 H2)) H4). -Qed. - -Lemma form1 : - forall p q:R, cos p + cos q = 2 * cos ((p - q) / 2) * cos ((p + q) / 2). -Proof. - intros p q; pattern p at 1 in |- *; - replace p with ((p - q) / 2 + (p + q) / 2) by field. - rewrite <- (cos_neg q); replace (- q) with ((p - q) / 2 - (p + q) / 2) by field. - rewrite cos_plus; rewrite cos_minus; ring. -Qed. - -Lemma form2 : - forall p q:R, cos p - cos q = -2 * sin ((p - q) / 2) * sin ((p + q) / 2). -Proof. - intros p q; pattern p at 1 in |- *; - replace p with ((p - q) / 2 + (p + q) / 2) by field. - rewrite <- (cos_neg q); replace (- q) with ((p - q) / 2 - (p + q) / 2) by field. - rewrite cos_plus; rewrite cos_minus; ring. -Qed. - -Lemma form3 : - forall p q:R, sin p + sin q = 2 * cos ((p - q) / 2) * sin ((p + q) / 2). -Proof. - intros p q; pattern p at 1 in |- *; - replace p with ((p - q) / 2 + (p + q) / 2). - - pattern q at 3 in |- *; replace q with ((p + q) / 2 - (p - q) / 2). - + rewrite sin_plus; rewrite sin_minus; ring. - + pattern q at 3 in |- *; rewrite <-Rplus_half_diag; unfold Rdiv in |- *; ring. - - pattern p at 3 in |- *; rewrite <-Rplus_half_diag; unfold Rdiv in |- *; ring. -Qed. - -Lemma form4 : - forall p q:R, sin p - sin q = 2 * cos ((p + q) / 2) * sin ((p - q) / 2). -Proof. - intros p q; pattern p at 1 in |- *; - replace p with ((p - q) / 2 + (p + q) / 2) by field. - pattern q at 3 in |- *; replace q with ((p + q) / 2 - (p - q) / 2) by field. - rewrite sin_plus; rewrite sin_minus; ring. - -Qed. - -Lemma sin_increasing_0 : - forall x y:R, - - (PI / 2) <= x -> - x <= PI / 2 -> - (PI / 2) <= y -> y <= PI / 2 -> sin x < sin y -> x < y. -Proof. - intros; cut (sin ((x - y) / 2) < 0). - - intro H4; case (Rtotal_order ((x - y) / 2) 0); intro H5. - { unfold Rdiv in H5;lra. } - elim H5; intro H6. - { rewrite H6 in H4; rewrite sin_0 in H4; elim (Rlt_irrefl 0 H4). } - change (0 < (x - y) / 2) in H6; - generalize (Ropp_le_ge_contravar (- (PI / 2)) y H1). - rewrite Ropp_involutive. - intro H7; generalize (Rge_le (PI / 2) (- y) H7); clear H7; intro H7; - generalize (Rplus_le_compat x (PI / 2) (- y) (PI / 2) H0 H7). - rewrite Rplus_half_diag. - intro H8. - assert (Hyp : 0 < 2) by lra. - generalize - (Rmult_le_compat_l (/ 2) (x - y) PI - (Rlt_le 0 (/ 2) (Rinv_0_lt_compat 2 Hyp)) H8). - repeat rewrite (Rmult_comm (/ 2)). - intro H9; - generalize - (sin_gt_0 ((x - y) / 2) H6 - (Rle_lt_trans ((x - y) / 2) (PI / 2) PI H9 PI2_Rlt_PI)); - intro H10; - elim - (Rlt_irrefl (sin ((x - y) / 2)) - (Rlt_trans (sin ((x - y) / 2)) 0 (sin ((x - y) / 2)) H4 H10)). - - generalize (Rlt_minus (sin x) (sin y) H3); clear H3; intro H3; - rewrite form4 in H3; - generalize (Rplus_le_compat x (PI / 2) y (PI / 2) H0 H2). - rewrite Rplus_half_diag. - assert (Hyp : 0 < 2) by prove_sup0. - intro H4; - generalize - (Rmult_le_compat_l (/ 2) (x + y) PI - (Rlt_le 0 (/ 2) (Rinv_0_lt_compat 2 Hyp)) H4). - repeat rewrite (Rmult_comm (/ 2)). - clear H4; intro H4; - generalize (Rplus_le_compat (- (PI / 2)) x (- (PI / 2)) y H H1); - replace (- (PI / 2) + - (PI / 2)) with (- PI) by field. - intro H5; - generalize - (Rmult_le_compat_l (/ 2) (- PI) (x + y) - (Rlt_le 0 (/ 2) (Rinv_0_lt_compat 2 Hyp)) H5). - replace (/ 2 * (x + y)) with ((x + y) / 2) by apply Rmult_comm. - replace (/ 2 * - PI) with (- (PI / 2)) by field. - clear H5; intro H5; elim H4; intro H40. - 2:{ unfold Rdiv in H3. - rewrite H40 in H3; assert (H50 := cos_PI2); unfold Rdiv in H50; - rewrite H50 in H3; rewrite Rmult_0_r in H3; rewrite Rmult_0_l in H3; - elim (Rlt_irrefl 0 H3). } - elim H5; intro H50. - 2:{ rewrite <- H50 in H3; rewrite cos_neg in H3; rewrite cos_PI2 in H3; - rewrite Rmult_0_r in H3; rewrite Rmult_0_l in H3; - elim (Rlt_irrefl 0 H3). } - generalize (cos_gt_0 ((x + y) / 2) H50 H40); intro H6; - generalize (Rmult_lt_compat_l 2 0 (cos ((x + y) / 2)) Hyp H6). - rewrite Rmult_0_r. - clear H6; intro H6; case (Rcase_abs (sin ((x - y) / 2))); intro H7. - { assumption. } - generalize (Rge_le (sin ((x - y) / 2)) 0 H7); clear H7; intro H7; - generalize - (Rmult_le_pos (2 * cos ((x + y) / 2)) (sin ((x - y) / 2)) - (Rlt_le 0 (2 * cos ((x + y) / 2)) H6) H7); intro H8; - generalize - (Rle_lt_trans 0 (2 * cos ((x + y) / 2) * sin ((x - y) / 2)) 0 H8 H3); - intro H9; elim (Rlt_irrefl 0 H9). -Qed. - -Lemma sin_increasing_1 : - forall x y:R, - - (PI / 2) <= x -> - x <= PI / 2 -> - (PI / 2) <= y -> y <= PI / 2 -> x < y -> sin x < sin y. -Proof. - intros; generalize (Rplus_lt_compat_l x x y H3); intro H4; - generalize (Rplus_le_compat (- (PI / 2)) x (- (PI / 2)) x H H); - replace (- (PI / 2) + - (PI / 2)) with (- PI) by field. - assert (Hyp : 0 < 2) by prove_sup0. - intro H5; generalize (Rle_lt_trans (- PI) (x + x) (x + y) H5 H4); intro H6; - generalize - (Rmult_lt_compat_l (/ 2) (- PI) (x + y) (Rinv_0_lt_compat 2 Hyp) H6); - replace (/ 2 * - PI) with (- (PI / 2)) by field. - replace (/ 2 * (x + y)) with ((x + y) / 2) by apply Rmult_comm. - clear H4 H5 H6; intro H4; generalize (Rplus_lt_compat_l y x y H3); intro H5; - rewrite Rplus_comm in H5; - generalize (Rplus_le_compat y (PI / 2) y (PI / 2) H2 H2). - rewrite Rplus_half_diag. - intro H6; generalize (Rlt_le_trans (x + y) (y + y) PI H5 H6); intro H7; - generalize (Rmult_lt_compat_l (/ 2) (x + y) PI (Rinv_0_lt_compat 2 Hyp) H7); - replace (/ 2 * PI) with (PI / 2) by apply Rmult_comm. - replace (/ 2 * (x + y)) with ((x + y) / 2) by apply Rmult_comm. - clear H5 H6 H7; intro H5; generalize (Ropp_le_ge_contravar (- (PI / 2)) y H1); - rewrite Ropp_involutive; clear H1; intro H1; - generalize (Rge_le (PI / 2) (- y) H1); clear H1; intro H1; - generalize (Ropp_le_ge_contravar y (PI / 2) H2); clear H2; - intro H2; generalize (Rge_le (- y) (- (PI / 2)) H2); - clear H2; intro H2; generalize (Rplus_lt_compat_l (- y) x y H3); - replace (- y + x) with (x - y) by apply Rplus_comm. - rewrite Rplus_opp_l. - intro H6; - generalize (Rmult_lt_compat_l (/ 2) (x - y) 0 (Rinv_0_lt_compat 2 Hyp) H6); - rewrite Rmult_0_r; replace (/ 2 * (x - y)) with ((x - y) / 2) by apply Rmult_comm. - clear H6; intro H6; - generalize (Rplus_le_compat (- (PI / 2)) x (- (PI / 2)) (- y) H H2); - replace (- (PI / 2) + - (PI / 2)) with (- PI) by field. - intro H7; - generalize - (Rmult_le_compat_l (/ 2) (- PI) (x - y) - (Rlt_le 0 (/ 2) (Rinv_0_lt_compat 2 Hyp)) H7); - replace (/ 2 * - PI) with (- (PI / 2)) by field. - replace (/ 2 * (x - y)) with ((x - y) / 2) by apply Rmult_comm. - clear H7; intro H7; clear H H0 H1 H2; apply Rminus_lt; rewrite form4; - generalize (cos_gt_0 ((x + y) / 2) H4 H5); intro H8; - generalize (Rmult_lt_0_compat 2 (cos ((x + y) / 2)) Hyp H8); - clear H8; intro H8; cut (- PI < - (PI / 2)). - - intro H9; - generalize - (sin_lt_0_var ((x - y) / 2) - (Rlt_le_trans (- PI) (- (PI / 2)) ((x - y) / 2) H9 H7) H6); - intro H10; - generalize - (Rmult_lt_gt_compat_neg_l (sin ((x - y) / 2)) 0 ( - 2 * cos ((x + y) / 2)) H10 H8); intro H11; rewrite Rmult_0_r in H11; - rewrite Rmult_comm; assumption. - - apply Ropp_lt_gt_contravar; apply PI2_Rlt_PI. -Qed. - -Lemma sin_decreasing_0 : - forall x y:R, - x <= 3 * (PI / 2) -> - PI / 2 <= x -> y <= 3 * (PI / 2) -> PI / 2 <= y -> sin x < sin y -> y < x. -Proof. - intros; rewrite <- (sin_PI_x x) in H3; rewrite <- (sin_PI_x y) in H3; - generalize (Ropp_lt_gt_contravar (sin (PI - x)) (sin (PI - y)) H3); - repeat rewrite <- sin_neg; - generalize (Rplus_le_compat_l (- PI) x (3 * (PI / 2)) H); - generalize (Rplus_le_compat_l (- PI) (PI / 2) x H0); - generalize (Rplus_le_compat_l (- PI) y (3 * (PI / 2)) H1); - generalize (Rplus_le_compat_l (- PI) (PI / 2) y H2); - replace (- PI + x) with (x - PI) by apply Rplus_comm. - replace (- PI + PI / 2) with (- (PI / 2)) by field. - replace (- PI + y) with (y - PI) by apply Rplus_comm. - replace (- PI + 3 * (PI / 2)) with (PI / 2) by field. - replace (- (PI - x)) with (x - PI) by ring. - replace (- (PI - y)) with (y - PI) by ring. - intros; change (sin (y - PI) < sin (x - PI)) in H8; - apply Rplus_lt_reg_l with (- PI); rewrite Rplus_comm. - rewrite (Rplus_comm _ x). - apply (sin_increasing_0 (y - PI) (x - PI) H4 H5 H6 H7 H8). -Qed. - -Lemma sin_decreasing_1 : - forall x y:R, - x <= 3 * (PI / 2) -> - PI / 2 <= x -> y <= 3 * (PI / 2) -> PI / 2 <= y -> x < y -> sin y < sin x. -Proof. - intros; rewrite <- (sin_PI_x x); rewrite <- (sin_PI_x y); - generalize (Rplus_le_compat_l (- PI) x (3 * (PI / 2)) H); - generalize (Rplus_le_compat_l (- PI) (PI / 2) x H0); - generalize (Rplus_le_compat_l (- PI) y (3 * (PI / 2)) H1); - generalize (Rplus_le_compat_l (- PI) (PI / 2) y H2); - generalize (Rplus_lt_compat_l (- PI) x y H3); - replace (- PI + PI / 2) with (- (PI / 2)) by field. - replace (- PI + y) with (y - PI) by apply Rplus_comm. - replace (- PI + 3 * (PI / 2)) with (PI / 2) by field. - replace (- PI + x) with (x - PI) by apply Rplus_comm. - intros; apply Ropp_lt_cancel; repeat rewrite <- sin_neg; - replace (- (PI - x)) with (x - PI) by ring. - replace (- (PI - y)) with (y - PI) by ring. - apply (sin_increasing_1 (x - PI) (y - PI) H7 H8 H5 H6 H4). -Qed. - -Lemma sin_inj x y : -(PI/2) <= x <= PI/2 -> -(PI/2) <= y <= PI/2 -> sin x = sin y -> x = y. -Proof. -intros xP yP Hsin. -destruct (total_order_T x y) as [[H|H]|H]; auto. -- assert (sin x < sin y). - + now apply sin_increasing_1; lra. - + now lra. -- assert (sin y < sin x). - + now apply sin_increasing_1; lra. - + now lra. -Qed. - -Lemma cos_increasing_0 : - forall x y:R, - PI <= x -> x <= 2 * PI -> PI <= y -> y <= 2 * PI -> cos x < cos y -> x < y. -Proof. - intros x y H1 H2 H3 H4; rewrite <- (cos_neg x); rewrite <- (cos_neg y); - rewrite <- (cos_period (- x) 1); rewrite <- (cos_period (- y) 1); - unfold INR in |- *; - replace (- x + 2 * 1 * PI) with (PI / 2 - (x - 3 * (PI / 2))) by field. - replace (- y + 2 * 1 * PI) with (PI / 2 - (y - 3 * (PI / 2))) by field. - repeat rewrite cos_shift; intro H5; - generalize (Rplus_le_compat_l (-3 * (PI / 2)) PI x H1); - generalize (Rplus_le_compat_l (-3 * (PI / 2)) x (2 * PI) H2); - generalize (Rplus_le_compat_l (-3 * (PI / 2)) PI y H3); - generalize (Rplus_le_compat_l (-3 * (PI / 2)) y (2 * PI) H4). - replace (-3 * (PI / 2) + y) with (y - 3 * (PI / 2)) by ring. - replace (-3 * (PI / 2) + x) with (x - 3 * (PI / 2)) by ring. - replace (-3 * (PI / 2) + 2 * PI) with (PI / 2) by field. - replace (-3 * (PI / 2) + PI) with (- (PI / 2)) by field. - clear H1 H2 H3 H4; intros H1 H2 H3 H4; - apply Rplus_lt_reg_l with (-3 * (PI / 2)); - replace (-3 * (PI / 2) + x) with (x - 3 * (PI / 2)) by ring. - replace (-3 * (PI / 2) + y) with (y - 3 * (PI / 2)) by ring. - apply (sin_increasing_0 (x - 3 * (PI / 2)) (y - 3 * (PI / 2)) H4 H3 H2 H1 H5). -Qed. - -Lemma cos_increasing_1 : - forall x y:R, - PI <= x -> x <= 2 * PI -> PI <= y -> y <= 2 * PI -> x < y -> cos x < cos y. -Proof. - intros x y H1 H2 H3 H4 H5; - generalize (Rplus_le_compat_l (-3 * (PI / 2)) PI x H1); - generalize (Rplus_le_compat_l (-3 * (PI / 2)) x (2 * PI) H2); - generalize (Rplus_le_compat_l (-3 * (PI / 2)) PI y H3); - generalize (Rplus_le_compat_l (-3 * (PI / 2)) y (2 * PI) H4); - generalize (Rplus_lt_compat_l (-3 * (PI / 2)) x y H5); - rewrite <- (cos_neg x); rewrite <- (cos_neg y); - rewrite <- (cos_period (- x) 1); rewrite <- (cos_period (- y) 1); - unfold INR in |- *; replace (-3 * (PI / 2) + x) with (x - 3 * (PI / 2)) by ring. - replace (-3 * (PI / 2) + y) with (y - 3 * (PI / 2)) by ring. - replace (-3 * (PI / 2) + PI) with (- (PI / 2)) by field. - replace (-3 * (PI / 2) + 2 * PI) with (PI / 2) by field. - clear H1 H2 H3 H4 H5; intros H1 H2 H3 H4 H5; - replace (- x + 2 * 1 * PI) with (PI / 2 - (x - 3 * (PI / 2))) by field. - replace (- y + 2 * 1 * PI) with (PI / 2 - (y - 3 * (PI / 2))) by field. - repeat rewrite cos_shift; - apply - (sin_increasing_1 (x - 3 * (PI / 2)) (y - 3 * (PI / 2)) H5 H4 H3 H2 H1). -Qed. - -Lemma cos_decreasing_0 : - forall x y:R, - 0 <= x -> x <= PI -> 0 <= y -> y <= PI -> cos x < cos y -> y < x. -Proof. - intros; generalize (Ropp_lt_gt_contravar (cos x) (cos y) H3); - repeat rewrite <- neg_cos; intro H4; - change (cos (y + PI) < cos (x + PI)) in H4; rewrite (Rplus_comm x) in H4; - rewrite (Rplus_comm y) in H4; generalize (Rplus_le_compat_l PI 0 x H); - generalize (Rplus_le_compat_l PI x PI H0); - generalize (Rplus_le_compat_l PI 0 y H1); - generalize (Rplus_le_compat_l PI y PI H2); rewrite Rplus_0_r. - rewrite Rplus_diag. - clear H H0 H1 H2 H3; intros; apply Rplus_lt_reg_l with PI; - apply (cos_increasing_0 (PI + y) (PI + x) H0 H H2 H1 H4). -Qed. - -Lemma cos_decreasing_1 : - forall x y:R, - 0 <= x -> x <= PI -> 0 <= y -> y <= PI -> x < y -> cos y < cos x. -Proof. - intros; apply Ropp_lt_cancel; repeat rewrite <- neg_cos; - rewrite (Rplus_comm x); rewrite (Rplus_comm y); - generalize (Rplus_le_compat_l PI 0 x H); - generalize (Rplus_le_compat_l PI x PI H0); - generalize (Rplus_le_compat_l PI 0 y H1); - generalize (Rplus_le_compat_l PI y PI H2); rewrite Rplus_0_r. - rewrite Rplus_diag. - generalize (Rplus_lt_compat_l PI x y H3); clear H H0 H1 H2 H3; intros; - apply (cos_increasing_1 (PI + x) (PI + y) H3 H2 H1 H0 H). -Qed. - -Lemma cos_inj x y : 0 <= x <= PI -> 0 <= y <= PI -> cos x = cos y -> x = y. -Proof. -intros xP yP Hcos. -destruct (total_order_T x y) as [[H|H]|H]; auto. -- assert (cos y < cos x). - + now apply cos_decreasing_1; lra. - + now lra. -- assert (cos x < cos y). - + now apply cos_decreasing_1; lra. - + now lra. -Qed. - -Lemma tan_diff : - forall x y:R, - cos x <> 0 -> cos y <> 0 -> tan x - tan y = sin (x - y) / (cos x * cos y). -Proof. - intros; unfold tan in |- *; rewrite sin_minus. - field. - now split. -Qed. - -Lemma tan_increasing_0 : - forall x y:R, - - (PI / 4) <= x -> - x <= PI / 4 -> - (PI / 4) <= y -> y <= PI / 4 -> tan x < tan y -> x < y. -Proof. - intros; generalize PI4_RLT_PI2; intro H4; - generalize (Ropp_lt_gt_contravar (PI / 4) (PI / 2) H4); - intro H5; change (- (PI / 2) < - (PI / 4)) in H5; - generalize - (cos_gt_0 x (Rlt_le_trans (- (PI / 2)) (- (PI / 4)) x H5 H) - (Rle_lt_trans x (PI / 4) (PI / 2) H0 H4)); intro HP1; - generalize - (cos_gt_0 y (Rlt_le_trans (- (PI / 2)) (- (PI / 4)) y H5 H1) - (Rle_lt_trans y (PI / 4) (PI / 2) H2 H4)); intro HP2; - generalize - (not_eq_sym - (Rlt_not_eq 0 (cos x) - (cos_gt_0 x (Rlt_le_trans (- (PI / 2)) (- (PI / 4)) x H5 H) - (Rle_lt_trans x (PI / 4) (PI / 2) H0 H4)))); - intro H6; - generalize - (not_eq_sym - (Rlt_not_eq 0 (cos y) - (cos_gt_0 y (Rlt_le_trans (- (PI / 2)) (- (PI / 4)) y H5 H1) - (Rle_lt_trans y (PI / 4) (PI / 2) H2 H4)))); - intro H7; generalize (tan_diff x y H6 H7); intro H8; - generalize (Rlt_minus (tan x) (tan y) H3); clear H3; - intro H3; rewrite H8 in H3; cut (sin (x - y) < 0). - - intro H9; generalize (Ropp_le_ge_contravar (- (PI / 4)) y H1); - rewrite Ropp_involutive; intro H10; generalize (Rge_le (PI / 4) (- y) H10); - clear H10; intro H10; generalize (Ropp_le_ge_contravar y (PI / 4) H2); - intro H11; generalize (Rge_le (- y) (- (PI / 4)) H11); - clear H11; intro H11; - generalize (Rplus_le_compat (- (PI / 4)) x (- (PI / 4)) (- y) H H11); - generalize (Rplus_le_compat x (PI / 4) (- y) (PI / 4) H0 H10). - replace (PI / 4 + PI / 4) with (PI / 2) by field. - replace (- (PI / 4) + - (PI / 4)) with (- (PI / 2)) by field. - intros; case (Rtotal_order 0 (x - y)); intro H14. - + generalize - (sin_gt_0 (x - y) H14 (Rle_lt_trans (x - y) (PI / 2) PI H12 PI2_Rlt_PI)); - intro H15; elim (Rlt_irrefl 0 (Rlt_trans 0 (sin (x - y)) 0 H15 H9)). - + elim H14; intro H15. - * rewrite <- H15 in H9; rewrite sin_0 in H9; elim (Rlt_irrefl 0 H9). - * apply Rminus_lt; assumption. - - case (Rcase_abs (sin (x - y))); intro H9. - + assumption. - + generalize (Rge_le (sin (x - y)) 0 H9); clear H9; intro H9; - generalize (Rinv_0_lt_compat (cos x) HP1); intro H10; - generalize (Rinv_0_lt_compat (cos y) HP2); intro H11; - generalize (Rmult_lt_0_compat (/ cos x) (/ cos y) H10 H11); - replace (/ cos x * / cos y) with (/ (cos x * cos y)). - * intro H12; - generalize - (Rmult_le_pos (sin (x - y)) (/ (cos x * cos y)) H9 - (Rlt_le 0 (/ (cos x * cos y)) H12)); intro H13; - elim - (Rlt_irrefl 0 (Rle_lt_trans 0 (sin (x - y) * / (cos x * cos y)) 0 H13 H3)). - * apply Rinv_mult. -Qed. - -Lemma tan_increasing_1 : - forall x y:R, - - (PI / 4) <= x -> - x <= PI / 4 -> - (PI / 4) <= y -> y <= PI / 4 -> x < y -> tan x < tan y. -Proof. - intros; apply Rminus_lt; generalize PI4_RLT_PI2; intro H4; - generalize (Ropp_lt_gt_contravar (PI / 4) (PI / 2) H4); - intro H5; change (- (PI / 2) < - (PI / 4)) in H5; - generalize - (cos_gt_0 x (Rlt_le_trans (- (PI / 2)) (- (PI / 4)) x H5 H) - (Rle_lt_trans x (PI / 4) (PI / 2) H0 H4)); intro HP1; - generalize - (cos_gt_0 y (Rlt_le_trans (- (PI / 2)) (- (PI / 4)) y H5 H1) - (Rle_lt_trans y (PI / 4) (PI / 2) H2 H4)); intro HP2; - generalize - (not_eq_sym - (Rlt_not_eq 0 (cos x) - (cos_gt_0 x (Rlt_le_trans (- (PI / 2)) (- (PI / 4)) x H5 H) - (Rle_lt_trans x (PI / 4) (PI / 2) H0 H4)))); - intro H6; - generalize - (not_eq_sym - (Rlt_not_eq 0 (cos y) - (cos_gt_0 y (Rlt_le_trans (- (PI / 2)) (- (PI / 4)) y H5 H1) - (Rle_lt_trans y (PI / 4) (PI / 2) H2 H4)))); - intro H7; rewrite (tan_diff x y H6 H7); - generalize (Rinv_0_lt_compat (cos x) HP1); intro H10; - generalize (Rinv_0_lt_compat (cos y) HP2); intro H11; - generalize (Rmult_lt_0_compat (/ cos x) (/ cos y) H10 H11); - replace (/ cos x * / cos y) with (/ (cos x * cos y)). - - clear H10 H11; intro H8; generalize (Ropp_le_ge_contravar y (PI / 4) H2); - intro H11; generalize (Rge_le (- y) (- (PI / 4)) H11); - clear H11; intro H11; - generalize (Rplus_le_compat (- (PI / 4)) x (- (PI / 4)) (- y) H H11). - replace (- (PI / 4) + - (PI / 4)) with (- (PI / 2)) by field. - clear H11; intro H9; generalize (Rlt_minus x y H3); clear H3; intro H3; - clear H H0 H1 H2 H4 H5 HP1 HP2; generalize PI2_Rlt_PI; - intro H1; generalize (Ropp_lt_gt_contravar (PI / 2) PI H1); - clear H1; intro H1; - generalize - (sin_lt_0_var (x - y) (Rlt_le_trans (- PI) (- (PI / 2)) (x - y) H1 H9) H3); - intro H2; - generalize - (Rmult_lt_gt_compat_neg_l (sin (x - y)) 0 (/ (cos x * cos y)) H2 H8); - rewrite Rmult_0_r; intro H4; assumption. - - apply Rinv_mult. -Qed. - -Lemma sin_incr_0 : - forall x y:R, - - (PI / 2) <= x -> - x <= PI / 2 -> - (PI / 2) <= y -> y <= PI / 2 -> sin x <= sin y -> x <= y. -Proof. - intros; case (Rtotal_order (sin x) (sin y)); intro H4; - [ left; apply (sin_increasing_0 x y H H0 H1 H2 H4) - | elim H4; intro H5; - [ case (Rtotal_order x y); intro H6; - [ left; assumption - | elim H6; intro H7; - [ right; assumption - | generalize (sin_increasing_1 y x H1 H2 H H0 H7); intro H8; - rewrite H5 in H8; elim (Rlt_irrefl (sin y) H8) ] ] - | elim (Rlt_irrefl (sin x) (Rle_lt_trans (sin x) (sin y) (sin x) H3 H5)) ] ]. -Qed. - -Lemma sin_incr_1 : - forall x y:R, - - (PI / 2) <= x -> - x <= PI / 2 -> - (PI / 2) <= y -> y <= PI / 2 -> x <= y -> sin x <= sin y. -Proof. - intros; case (Rtotal_order x y); intro H4; - [ left; apply (sin_increasing_1 x y H H0 H1 H2 H4) - | elim H4; intro H5; - [ case (Rtotal_order (sin x) (sin y)); intro H6; - [ left; assumption - | elim H6; intro H7; - [ right; assumption - | generalize (sin_increasing_0 y x H1 H2 H H0 H7); intro H8; - rewrite H5 in H8; elim (Rlt_irrefl y H8) ] ] - | elim (Rlt_irrefl x (Rle_lt_trans x y x H3 H5)) ] ]. -Qed. - -Lemma sin_decr_0 : - forall x y:R, - x <= 3 * (PI / 2) -> - PI / 2 <= x -> - y <= 3 * (PI / 2) -> PI / 2 <= y -> sin x <= sin y -> y <= x. -Proof. - intros; case (Rtotal_order (sin x) (sin y)); intro H4; - [ left; apply (sin_decreasing_0 x y H H0 H1 H2 H4) - | elim H4; intro H5; - [ case (Rtotal_order x y); intro H6; - [ generalize (sin_decreasing_1 x y H H0 H1 H2 H6); intro H8; - rewrite H5 in H8; elim (Rlt_irrefl (sin y) H8) - | elim H6; intro H7; - [ right; symmetry in |- *; assumption | left; assumption ] ] - | elim (Rlt_irrefl (sin x) (Rle_lt_trans (sin x) (sin y) (sin x) H3 H5)) ] ]. -Qed. - -Lemma sin_decr_1 : - forall x y:R, - x <= 3 * (PI / 2) -> - PI / 2 <= x -> - y <= 3 * (PI / 2) -> PI / 2 <= y -> x <= y -> sin y <= sin x. -Proof. - intros; case (Rtotal_order x y); intro H4; - [ left; apply (sin_decreasing_1 x y H H0 H1 H2 H4) - | elim H4; intro H5; - [ case (Rtotal_order (sin x) (sin y)); intro H6; - [ generalize (sin_decreasing_0 x y H H0 H1 H2 H6); intro H8; - rewrite H5 in H8; elim (Rlt_irrefl y H8) - | elim H6; intro H7; - [ right; symmetry in |- *; assumption | left; assumption ] ] - | elim (Rlt_irrefl x (Rle_lt_trans x y x H3 H5)) ] ]. -Qed. - -Lemma cos_incr_0 : - forall x y:R, - PI <= x -> - x <= 2 * PI -> PI <= y -> y <= 2 * PI -> cos x <= cos y -> x <= y. -Proof. - intros; case (Rtotal_order (cos x) (cos y)); intro H4; - [ left; apply (cos_increasing_0 x y H H0 H1 H2 H4) - | elim H4; intro H5; - [ case (Rtotal_order x y); intro H6; - [ left; assumption - | elim H6; intro H7; - [ right; assumption - | generalize (cos_increasing_1 y x H1 H2 H H0 H7); intro H8; - rewrite H5 in H8; elim (Rlt_irrefl (cos y) H8) ] ] - | elim (Rlt_irrefl (cos x) (Rle_lt_trans (cos x) (cos y) (cos x) H3 H5)) ] ]. -Qed. - -Lemma cos_incr_1 : - forall x y:R, - PI <= x -> - x <= 2 * PI -> PI <= y -> y <= 2 * PI -> x <= y -> cos x <= cos y. -Proof. - intros; case (Rtotal_order x y); intro H4; - [ left; apply (cos_increasing_1 x y H H0 H1 H2 H4) - | elim H4; intro H5; - [ case (Rtotal_order (cos x) (cos y)); intro H6; - [ left; assumption - | elim H6; intro H7; - [ right; assumption - | generalize (cos_increasing_0 y x H1 H2 H H0 H7); intro H8; - rewrite H5 in H8; elim (Rlt_irrefl y H8) ] ] - | elim (Rlt_irrefl x (Rle_lt_trans x y x H3 H5)) ] ]. -Qed. - -Lemma cos_decr_0 : - forall x y:R, - 0 <= x -> x <= PI -> 0 <= y -> y <= PI -> cos x <= cos y -> y <= x. -Proof. - intros; case (Rtotal_order (cos x) (cos y)); intro H4; - [ left; apply (cos_decreasing_0 x y H H0 H1 H2 H4) - | elim H4; intro H5; - [ case (Rtotal_order x y); intro H6; - [ generalize (cos_decreasing_1 x y H H0 H1 H2 H6); intro H8; - rewrite H5 in H8; elim (Rlt_irrefl (cos y) H8) - | elim H6; intro H7; - [ right; symmetry in |- *; assumption | left; assumption ] ] - | elim (Rlt_irrefl (cos x) (Rle_lt_trans (cos x) (cos y) (cos x) H3 H5)) ] ]. -Qed. - -Lemma cos_decr_1 : - forall x y:R, - 0 <= x -> x <= PI -> 0 <= y -> y <= PI -> x <= y -> cos y <= cos x. -Proof. - intros; case (Rtotal_order x y); intro H4; - [ left; apply (cos_decreasing_1 x y H H0 H1 H2 H4) - | elim H4; intro H5; - [ case (Rtotal_order (cos x) (cos y)); intro H6; - [ generalize (cos_decreasing_0 x y H H0 H1 H2 H6); intro H8; - rewrite H5 in H8; elim (Rlt_irrefl y H8) - | elim H6; intro H7; - [ right; symmetry in |- *; assumption | left; assumption ] ] - | elim (Rlt_irrefl x (Rle_lt_trans x y x H3 H5)) ] ]. -Qed. - -Lemma tan_incr_0 : - forall x y:R, - - (PI / 4) <= x -> - x <= PI / 4 -> - (PI / 4) <= y -> y <= PI / 4 -> tan x <= tan y -> x <= y. -Proof. - intros; case (Rtotal_order (tan x) (tan y)); intro H4; - [ left; apply (tan_increasing_0 x y H H0 H1 H2 H4) - | elim H4; intro H5; - [ case (Rtotal_order x y); intro H6; - [ left; assumption - | elim H6; intro H7; - [ right; assumption - | generalize (tan_increasing_1 y x H1 H2 H H0 H7); intro H8; - rewrite H5 in H8; elim (Rlt_irrefl (tan y) H8) ] ] - | elim (Rlt_irrefl (tan x) (Rle_lt_trans (tan x) (tan y) (tan x) H3 H5)) ] ]. -Qed. - -Lemma tan_incr_1 : - forall x y:R, - - (PI / 4) <= x -> - x <= PI / 4 -> - (PI / 4) <= y -> y <= PI / 4 -> x <= y -> tan x <= tan y. -Proof. - intros; case (Rtotal_order x y); intro H4; - [ left; apply (tan_increasing_1 x y H H0 H1 H2 H4) - | elim H4; intro H5; - [ case (Rtotal_order (tan x) (tan y)); intro H6; - [ left; assumption - | elim H6; intro H7; - [ right; assumption - | generalize (tan_increasing_0 y x H1 H2 H H0 H7); intro H8; - rewrite H5 in H8; elim (Rlt_irrefl y H8) ] ] - | elim (Rlt_irrefl x (Rle_lt_trans x y x H3 H5)) ] ]. -Qed. - -(**********) -Lemma sin_eq_0_1 : forall x:R, (exists k : Z, x = IZR k * PI) -> sin x = 0. -Proof. - assert (forall n, sin (INR n * PI) = 0). { - intros n;induction n as [|n IHn]. - { change (INR 0) with 0. - replace (0 * PI) with 0 by ring. - exact sin_0. } - rewrite S_INR. - replace ((INR n + 1) * PI) with ((INR n) * PI + PI) by ring. - rewrite neg_sin,IHn. - ring. - } - intros x [k Hx]. - rewrite Hx;clear x Hx. - destruct (Z.abs_or_opp_abs k). - - replace (IZR k) with (INR (Z.to_nat k)). - { apply H. } - rewrite INR_IZR_INZ. - f_equal. - apply Z2Nat.id. - lia. - - replace (IZR k) with (- INR (Z.to_nat (- k))). - { replace (- INR (Z.to_nat (- k)) * PI) with (- (INR (Z.to_nat (- k)) * PI)) by ring. - rewrite sin_neg. - rewrite H;ring. } - rewrite INR_IZR_INZ. - rewrite <-opp_IZR. f_equal. - lia. -Qed. - -Lemma sin_eq_0_0 (x:R) : sin x = 0 -> exists k : Z, x = IZR k * PI. -Proof. - intros Hx. - destruct (euclidian_division x PI PI_neq0) as (q & r & EQ & Hr & Hr'). - exists q. - rewrite <- (Rplus_0_r (_*_)). subst. apply Rplus_eq_compat_l. - rewrite sin_plus in Hx. - assert (H : sin (IZR q * PI) = 0) by (apply sin_eq_0_1; now exists q). - rewrite H, Rmult_0_l, Rplus_0_l in Hx. - destruct (Rmult_integral _ _ Hx) as [H'|H']. - - exfalso. - generalize (sin2_cos2 (IZR q * PI)). - rewrite H, H', Rsqr_0, Rplus_0_l. - intros; now apply R1_neq_R0. - - rewrite Rabs_right in Hr'; [|left; apply PI_RGT_0]. - destruct Hr as [Hr | ->]; trivial. - exfalso. - generalize (sin_gt_0 r Hr Hr'). rewrite H'. apply Rlt_irrefl. -Qed. - -Lemma cos_eq_0_0 (x:R) : - cos x = 0 -> exists k : Z, x = IZR k * PI + PI / 2. -Proof. - rewrite cos_sin. intros Hx. - destruct (sin_eq_0_0 (PI/2 + x) Hx) as (k,Hk). clear Hx. - exists (k-1)%Z. rewrite <- Z_R_minus; simpl. - symmetry in Hk. field_simplify [Hk]. field. -Qed. - -Lemma cos_eq_0_1 (x:R) : - (exists k : Z, x = IZR k * PI + PI / 2) -> cos x = 0. -Proof. - rewrite cos_sin. intros (k,->). - replace (_ + _) with (IZR k * PI + PI) by field. - rewrite neg_sin, <- Ropp_0. apply Ropp_eq_compat. - apply sin_eq_0_1. now exists k. -Qed. - -Lemma sin_eq_O_2PI_0 (x:R) : - 0 <= x -> x <= 2 * PI -> sin x = 0 -> - x = 0 \/ x = PI \/ x = 2 * PI. -Proof. - intros Lo Hi Hx. destruct (sin_eq_0_0 x Hx) as (k,Hk). clear Hx. - destruct (Rtotal_order PI x) as [Hx|[Hx|Hx]]. - - right; right. - clear Lo. subst. - f_equal. change 2 with (IZR (- (-2))). f_equal. - apply Z.add_move_0_l. - apply one_IZR_lt1. - rewrite plus_IZR; simpl. - split. - + replace (-1) with (-2 + 1) by ring. - apply Rplus_lt_compat_l. - apply Rmult_lt_reg_r with PI; [apply PI_RGT_0|]. - now rewrite Rmult_1_l. - + apply Rle_lt_trans with 0; [|apply Rlt_0_1]. - replace 0 with (-2 + 2) by ring. - apply Rplus_le_compat_l. - apply Rmult_le_reg_r with PI; [apply PI_RGT_0|]. - trivial. - - right; left; auto. - - left. - clear Hi. subst. - replace 0 with (IZR 0 * PI) by apply Rmult_0_l. f_equal. f_equal. - apply one_IZR_lt1. - split. - + apply Rlt_le_trans with 0; - [rewrite <- Ropp_0; apply Ropp_gt_lt_contravar, Rlt_0_1 | ]. - apply Rmult_le_reg_r with PI; [apply PI_RGT_0|]. - now rewrite Rmult_0_l. - + apply Rmult_lt_reg_r with PI; [apply PI_RGT_0|]. - now rewrite Rmult_1_l. -Qed. - -Lemma sin_eq_O_2PI_1 (x:R) : - 0 <= x -> x <= 2 * PI -> - x = 0 \/ x = PI \/ x = 2 * PI -> sin x = 0. -Proof. - intros _ _ [ -> |[ -> | -> ]]. - - now rewrite sin_0. - - now rewrite sin_PI. - - now rewrite sin_2PI. -Qed. - -Lemma cos_eq_0_2PI_0 (x:R) : - 0 <= x -> x <= 2 * PI -> cos x = 0 -> - x = PI / 2 \/ x = 3 * (PI / 2). -Proof. - intros Lo Hi Hx. - destruct (Rtotal_order x (3 * (PI / 2))) as [LT|[EQ|GT]]. - - rewrite cos_sin in Hx. - assert (Lo' : 0 <= PI / 2 + x). - { apply Rplus_le_le_0_compat. - - apply Rlt_le, PI2_RGT_0. - - trivial. } - assert (Hi' : PI / 2 + x <= 2 * PI). - { apply Rlt_le. - replace (2 * PI) with (PI / 2 + 3 * (PI / 2)) by field. - now apply Rplus_lt_compat_l. } - destruct (sin_eq_O_2PI_0 (PI / 2 + x) Lo' Hi' Hx) as [H|[H|H]]. - + exfalso. - apply (Rplus_le_compat_l (PI/2)) in Lo. - rewrite Rplus_0_r, H in Lo. - apply (Rlt_irrefl 0 (Rlt_le_trans 0 (PI / 2) 0 PI2_RGT_0 Lo)). - + left. - apply (Rplus_eq_compat_l (-(PI/2))) in H. - ring_simplify in H. rewrite H. field. - + right. - apply (Rplus_eq_compat_l (-(PI/2))) in H. - ring_simplify in H. rewrite H. field. - - now right. - - exfalso. - destruct (cos_eq_0_0 x Hx) as (k,Hk). clear Hx Lo. - subst. - assert (LT : (k < 2)%Z). - { apply lt_IZR. simpl. - apply (Rmult_lt_reg_r PI); [apply PI_RGT_0|]. - apply Rlt_le_trans with (IZR k * PI + PI/2); trivial. - rewrite <- (Rplus_0_r (IZR k * PI)) at 1. - apply Rplus_lt_compat_l. apply PI2_RGT_0. } - assert (GT' : (1 < k)%Z). - { apply lt_IZR. simpl. - apply (Rmult_lt_reg_r PI); [apply PI_RGT_0|rewrite Rmult_1_l]. - replace (3*(PI/2)) with (PI/2 + PI) in GT by field. - rewrite Rplus_comm in GT. - now apply Rplus_lt_reg_l in GT. } - lia. -Qed. - -Lemma cos_eq_0_2PI_1 (x:R) : - 0 <= x -> x <= 2 * PI -> - x = PI / 2 \/ x = 3 * (PI / 2) -> cos x = 0. -Proof. - intros Lo Hi [ -> | -> ]. - - now rewrite cos_PI2. - - now rewrite cos_3PI2. -Qed. diff --git a/stdlib/theories/Reals/Rtrigo_alt.v b/stdlib/theories/Reals/Rtrigo_alt.v deleted file mode 100644 index 6646860acb14..000000000000 --- a/stdlib/theories/Reals/Rtrigo_alt.v +++ /dev/null @@ -1,297 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* - a <= 4 -> sin_approx a (2 * n + 1) <= sin a <= sin_approx a (2 * (n + 1)). -Proof. - intros; case (Req_dec a 0); intro Hyp_a. - { rewrite Hyp_a; rewrite sin_0; split; right; unfold sin_approx; - apply sum_eq_R0 || (symmetry ; apply sum_eq_R0); - intros; unfold sin_term; rewrite pow_add; - simpl; unfold Rdiv; rewrite Rmult_0_l; - ring. } - unfold sin_approx; assert (Hyp_a_pos:0 < a) by lra. - rewrite (decomp_sum (sin_term a) (2 * n + 1)). 2:lia. - rewrite (decomp_sum (sin_term a) (2 * (n + 1))). 2:lia. - replace (sin_term a 0) with a. - 2:{ unfold sin_term; simpl; unfold Rdiv; rewrite Rinv_1; - ring. } - assert - (sum_f_R0 (fun i:nat => sin_term a (S i)) (pred (2 * n + 1)) <= sin a - a /\ - sin a - a <= sum_f_R0 (fun i:nat => sin_term a (S i)) (pred (2 * (n + 1))) -> - a + sum_f_R0 (fun i:nat => sin_term a (S i)) (pred (2 * n + 1)) <= sin a /\ - sin a <= a + sum_f_R0 (fun i:nat => sin_term a (S i)) (pred (2 * (n + 1)))) by lra. - apply H1. - set (Un := fun n:nat => a ^ (2 * S n + 1) / INR (fact (2 * S n + 1))). - replace (pred (2 * n + 1)) with (2 * n)%nat by lia. - replace (pred (2 * (n + 1))) with (S (2 * n)) by lia. - replace (sum_f_R0 (fun i:nat => sin_term a (S i)) (2 * n)) with - (- sum_f_R0 (tg_alt Un) (2 * n)). - 2:{ replace (- sum_f_R0 (tg_alt Un) (2 * n)) with - (-1 * sum_f_R0 (tg_alt Un) (2 * n)) by ring. - rewrite scal_sum. - apply sum_eq; intros. - unfold sin_term, Un, tg_alt; - change ((-1) ^ S i) with (-1 * (-1) ^ i). - unfold Rdiv; ring. } - replace (sum_f_R0 (fun i:nat => sin_term a (S i)) (S (2 * n))) with - (- sum_f_R0 (tg_alt Un) (S (2 * n))). - 2:{ replace (- sum_f_R0 (tg_alt Un) (S (2 * n))) with - (-1 * sum_f_R0 (tg_alt Un) (S (2 * n))); [ rewrite scal_sum | ring ]. - apply sum_eq; intros; unfold sin_term, Un, tg_alt; - change ((-1) ^ S i) with (-1 * (-1) ^ i). - unfold Rdiv; ring. } - assert - (sum_f_R0 (tg_alt Un) (S (2 * n)) <= a - sin a <= - sum_f_R0 (tg_alt Un) (2 * n) -> - - sum_f_R0 (tg_alt Un) (2 * n) <= sin a - a <= - - sum_f_R0 (tg_alt Un) (S (2 * n))) by lra. - apply H2. - apply alternated_series_ineq. - - unfold Un_decreasing, Un; intro; - assert ((2 * S (S n0) + 1)%nat = S (S (2 * S n0 + 1))) by lia. - rewrite H3. - replace (a ^ S (S (2 * S n0 + 1))) with (a ^ (2 * S n0 + 1) * (a * a)) by (simpl;ring). - unfold Rdiv; rewrite Rmult_assoc; apply Rmult_le_compat_l. - { left; apply pow_lt; assumption. } - apply Rmult_le_reg_l with (INR (fact (S (S (2 * S n0 + 1))))). - { rewrite <- H3; apply lt_INR_0; apply Nat.neq_0_lt_0; red; intro; - elim (fact_neq_0 _ H4). } - rewrite <- H3; rewrite (Rmult_comm (INR (fact (2 * S (S n0) + 1)))); - rewrite Rmult_assoc; rewrite Rinv_l. - 2:{ apply INR_fact_neq_0. } - rewrite Rmult_1_r; rewrite H3; do 2 rewrite fact_simpl; do 2 rewrite mult_INR; - repeat rewrite Rmult_assoc; rewrite Rinv_r. - 2:{ apply INR_fact_neq_0. } - rewrite Rmult_1_r. - do 2 rewrite S_INR; rewrite plus_INR; rewrite mult_INR; repeat rewrite S_INR; - simpl; - replace - (((0 + 1 + 1) * (INR n0 + 1) + (0 + 1) + 1 + 1) * - ((0 + 1 + 1) * (INR n0 + 1) + (0 + 1) + 1)) with - (4 * INR n0 * INR n0 + 18 * INR n0 + 20); [ idtac | ring ]. - apply Rle_trans with 20. - + apply Rle_trans with 16. - 2:lra. - replace 16 with (Rsqr 4); [ idtac | ring_Rsqr ]. - apply Rsqr_incr_1;lra. - + rewrite <- (Rplus_0_l 20) at 1; - apply Rplus_le_compat_r. - pose proof (pos_INR n0). nra. - - assert (H3 := cv_speed_pow_fact a); unfold Un; unfold Un_cv in H3; - unfold Rdist in H3; unfold Un_cv; unfold Rdist; - intros; elim (H3 eps H4); intros N H5. - exists N; intros; apply H5. - lia. - - unfold sin. - destruct (exist_sin (Rsqr a)) as (x,p). - unfold sin_in, infinite_sum, Rdist in p; - unfold Un_cv, Rdist; - intros. - assert (H4:0 < eps / Rabs a). { - unfold Rdiv; apply Rmult_lt_0_compat. - - assumption. - - apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption. - } - destruct (p _ H4) as (N,H6). - exists N; intros. - replace (sum_f_R0 (tg_alt Un) n0) with - (a * (1 - sum_f_R0 (fun i:nat => sin_n i * Rsqr a ^ i) (S n0))). - { unfold Rminus; rewrite Rmult_plus_distr_l; rewrite Rmult_1_r; - rewrite Ropp_plus_distr; rewrite Ropp_involutive; - repeat rewrite Rplus_assoc; rewrite (Rplus_comm a); - rewrite (Rplus_comm (- a)); repeat rewrite Rplus_assoc; - rewrite Rplus_opp_l; rewrite Rplus_0_r; apply Rmult_lt_reg_l with (/ Rabs a). - { apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption. } - pattern (/ Rabs a) at 1; rewrite <- (Rabs_inv a). - rewrite <- Rabs_mult, Rmult_plus_distr_l, <- 2!Rmult_assoc, Rinv_l; - [ rewrite Rmult_1_l | assumption ]; - rewrite (Rmult_comm (/ Rabs a)), <- Rabs_Ropp, Ropp_plus_distr, Ropp_involutive, Rmult_1_l. - unfold Rminus, Rdiv in H6. apply H6; unfold ge; - apply Nat.le_trans with n0; [ exact H5 | apply Nat.le_succ_diag_r ]. } - rewrite (decomp_sum (fun i:nat => sin_n i * Rsqr a ^ i) (S n0)). - 2:lia. - replace (sin_n 0) with 1. - 2:{ unfold sin_n; unfold Rdiv; simpl; rewrite Rinv_1; - rewrite Rmult_1_r; reflexivity. } - simpl; rewrite Rmult_1_r; unfold Rminus; - rewrite Ropp_plus_distr; rewrite <- Rplus_assoc; rewrite Rplus_opp_r; - rewrite Rplus_0_l; rewrite Ropp_mult_distr_r_reverse; - rewrite <- Ropp_mult_distr_l_reverse; rewrite scal_sum; - apply sum_eq. - intros; unfold sin_n, Un, tg_alt; - replace ((-1) ^ S i) with (- (-1) ^ i) by (simpl;ring). - replace (a ^ (2 * S i + 1)) with (Rsqr a * Rsqr a ^ i * a). - { unfold Rdiv; ring. } - rewrite pow_add; rewrite pow_Rsqr; simpl; ring. -Qed. - -(**********) -Lemma pre_cos_bound : - forall (a:R) (n:nat), - - 2 <= a -> a <= 2 -> - cos_approx a (2 * n + 1) <= cos a <= cos_approx a (2 * (n + 1)). -Proof. - assert - (H:(forall (a:R) (n:nat), - 0 <= a -> - a <= 2 -> - cos_approx a (2 * n + 1) <= cos a <= cos_approx a (2 * (n + 1))) -> - forall (a:R) (n:nat), - - 2 <= a -> - a <= 2 -> - cos_approx a (2 * n + 1) <= cos a <= cos_approx a (2 * (n + 1))). { - intros; destruct (total_order_T 0 a) as [[Hlt|Heq]|Hgt];try (apply H;lra). - assert (0 < - a) by lra. - cut (forall (x:R) (n:nat), cos_approx x n = cos_approx (- x) n). - { intro; rewrite H3; rewrite (H3 a (2 * (n + 1))%nat); rewrite cos_sym; apply H;lra. } - intros; unfold cos_approx; apply sum_eq; intros; - unfold cos_term; do 2 rewrite pow_Rsqr; rewrite Rsqr_neg; - unfold Rdiv; reflexivity. - } - intros a n; apply H. - intros; unfold cos_approx. - rewrite (decomp_sum (cos_term a0) (2 * n0 + 1)). 2:lia. - rewrite (decomp_sum (cos_term a0) (2 * (n0 + 1))). 2:lia. - replace (cos_term a0 0) with 1. - 2:{ unfold cos_term; simpl; unfold Rdiv; rewrite Rinv_1; - ring. } - assert - (sum_f_R0 (fun i:nat => cos_term a0 (S i)) (pred (2 * n0 + 1)) <= cos a0 - 1 /\ - cos a0 - 1 <= - sum_f_R0 (fun i:nat => cos_term a0 (S i)) (pred (2 * (n0 + 1))) -> - 1 + sum_f_R0 (fun i:nat => cos_term a0 (S i)) (pred (2 * n0 + 1)) <= cos a0 /\ - cos a0 <= - 1 + sum_f_R0 (fun i:nat => cos_term a0 (S i)) (pred (2 * (n0 + 1)))). { - intro; elim H2; intros; split; - apply Rplus_le_reg_l with (-(1)); - rewrite <- Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_l; - rewrite (Rplus_comm (-1));assumption. - } - apply H2. - set (Un := fun n:nat => a0 ^ (2 * S n) / INR (fact (2 * S n))). - replace (pred (2 * n0 + 1)) with (2 * n0)%nat by lia. - replace (pred (2 * (n0 + 1))) with (S (2 * n0)) by lia. - replace (sum_f_R0 (fun i:nat => cos_term a0 (S i)) (2 * n0)) with - (- sum_f_R0 (tg_alt Un) (2 * n0)). - 2:{ replace (- sum_f_R0 (tg_alt Un) (2 * n0)) with - (-1 * sum_f_R0 (tg_alt Un) (2 * n0)); [ rewrite scal_sum | ring ]; - apply sum_eq; intros; unfold cos_term, Un, tg_alt; - change ((-1) ^ S i) with (-1 * (-1) ^ i). - unfold Rdiv; ring. } - replace (sum_f_R0 (fun i:nat => cos_term a0 (S i)) (S (2 * n0))) with - (- sum_f_R0 (tg_alt Un) (S (2 * n0))). - 2:{ replace (- sum_f_R0 (tg_alt Un) (S (2 * n0))) with - (-1 * sum_f_R0 (tg_alt Un) (S (2 * n0))); [ rewrite scal_sum | ring ]. - apply sum_eq; intros; unfold cos_term, Un, tg_alt; - change ((-1) ^ S i) with (-1 * (-1) ^ i). - unfold Rdiv; ring. } - assert - (sum_f_R0 (tg_alt Un) (S (2 * n0)) <= 1 - cos a0 <= - sum_f_R0 (tg_alt Un) (2 * n0) -> - - sum_f_R0 (tg_alt Un) (2 * n0) <= cos a0 - 1 <= - - sum_f_R0 (tg_alt Un) (S (2 * n0))) by lra. - apply H3. - apply alternated_series_ineq. - - unfold Un_decreasing; intro; unfold Un. - assert ((2 * S (S n1))%nat = S (S (2 * S n1))) by lia. - rewrite H4; - replace (a0 ^ S (S (2 * S n1))) with (a0 ^ (2 * S n1) * (a0 * a0)) by (simpl;ring). - unfold Rdiv; rewrite Rmult_assoc; apply Rmult_le_compat_l. - { apply pow_le; assumption. } - apply Rmult_le_reg_l with (INR (fact (S (S (2 * S n1))))). - { apply INR_fact_lt_0. } - rewrite <- H4; rewrite (Rmult_comm (INR (fact (2 * S (S n1))))); - rewrite Rmult_assoc; rewrite Rinv_l. - 2:(pose proof (INR_fact_lt_0 (2 * S (S n1)));lra). - rewrite Rmult_1_r; rewrite H4; do 2 rewrite fact_simpl; do 2 rewrite mult_INR; - repeat rewrite Rmult_assoc; rewrite Rinv_r. - 2:(pose proof (INR_fact_lt_0 (2 * S n1));lra). - rewrite Rmult_1_r; do 2 rewrite S_INR; rewrite mult_INR; repeat rewrite S_INR; - simpl; - replace - (((0 + 1 + 1) * (INR n1 + 1) + 1 + 1) * ((0 + 1 + 1) * (INR n1 + 1) + 1)) - with (4 * INR n1 * INR n1 + 14 * INR n1 + 12); [ idtac | ring ]. - apply Rle_trans with 12. - { nra. } - pose proof (pos_INR n1);nra. - - assert (H4 := cv_speed_pow_fact a0); unfold Un; unfold Un_cv in H4; - unfold Rdist in H4; unfold Un_cv; unfold Rdist; - intros; elim (H4 eps H5); intros N H6; exists N; intros. - apply H6; nia. - - unfold cos. destruct (exist_cos (Rsqr a0)) as (x,p). - unfold cos_in, infinite_sum, Rdist in p; - unfold Un_cv, Rdist; intros. - destruct (p _ H4) as (N,H6). - exists N; intros. - replace (sum_f_R0 (tg_alt Un) n1) with - (1 - sum_f_R0 (fun i:nat => cos_n i * Rsqr a0 ^ i) (S n1)). - { unfold Rminus; rewrite Ropp_plus_distr; rewrite Ropp_involutive; - repeat rewrite Rplus_assoc; rewrite (Rplus_comm 1); - rewrite (Rplus_comm (-(1))); repeat rewrite Rplus_assoc; - rewrite Rplus_opp_l; rewrite Rplus_0_r; rewrite <- Rabs_Ropp; - rewrite Ropp_plus_distr; rewrite Ropp_involutive; - unfold Rminus in H6; apply H6. - lia. } - rewrite (decomp_sum (fun i:nat => cos_n i * Rsqr a0 ^ i) (S n1)). - 2:lia. - replace (cos_n 0) with 1. - 2:{ unfold cos_n; unfold Rdiv; simpl; rewrite Rinv_1; - rewrite Rmult_1_r; reflexivity. } - simpl; rewrite Rmult_1_r; unfold Rminus; - rewrite Ropp_plus_distr; rewrite <- Rplus_assoc; rewrite Rplus_opp_r; - rewrite Rplus_0_l; - replace (- sum_f_R0 (fun i:nat => cos_n (S i) * (Rsqr a0 * Rsqr a0 ^ i)) n1) - with - (-1 * sum_f_R0 (fun i:nat => cos_n (S i) * (Rsqr a0 * Rsqr a0 ^ i)) n1); - [ idtac | ring ]; rewrite scal_sum; apply sum_eq; - intros; unfold cos_n, Un, tg_alt. - replace ((-1) ^ S i) with (- (-1) ^ i) by (simpl;ring). - replace (a0 ^ (2 * S i)) with (Rsqr a0 * Rsqr a0 ^ i) by (rewrite pow_Rsqr; reflexivity). - unfold Rdiv; ring. -Qed. diff --git a/stdlib/theories/Reals/Rtrigo_calc.v b/stdlib/theories/Reals/Rtrigo_calc.v deleted file mode 100644 index 1561c96d88bf..000000000000 --- a/stdlib/theories/Reals/Rtrigo_calc.v +++ /dev/null @@ -1,374 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* 0. -Proof. - assert (Hyp : 0 < 2); - [ prove_sup0 - | generalize (Rlt_le 0 2 Hyp); intro H1; red; intro H2; - generalize (sqrt_eq_0 2 H1 H2); intro H; absurd (2 = 0); - [ discrR | assumption ] ]. -Qed. - -Lemma R1_sqrt2_neq_0 : 1 / sqrt 2 <> 0. -Proof. - generalize (Rinv_neq_0_compat (sqrt 2) sqrt2_neq_0); intro H; - generalize (prod_neq_R0 1 (/ sqrt 2) R1_neq_R0 H); - intro H0; assumption. -Qed. - -Lemma sqrt3_2_neq_0 : 2 * sqrt 3 <> 0. -Proof. - apply prod_neq_R0; - [ discrR - | assert (Hyp : 0 < 3); - [ prove_sup0 - | generalize (Rlt_le 0 3 Hyp); intro H1; red; intro H2; - generalize (sqrt_eq_0 3 H1 H2); intro H; absurd (3 = 0); - [ discrR | assumption ] ] ]. -Qed. - -Lemma Rlt_sqrt2_0 : 0 < sqrt 2. -Proof. - assert (Hyp : 0 < 2); - [ prove_sup0 - | generalize (sqrt_positivity 2 (Rlt_le 0 2 Hyp)); intro H1; elim H1; - intro H2; - [ assumption - | absurd (0 = sqrt 2); - [ apply (not_eq_sym (A:=R)); apply sqrt2_neq_0 | assumption ] ] ]. -Qed. - -Lemma Rlt_sqrt3_0 : 0 < sqrt 3. -Proof. - cut (0%nat <> 1%nat); - [ intro H0; assert (Hyp : 0 < 2); - [ prove_sup0 - | generalize (Rlt_le 0 2 Hyp); intro H1; assert (Hyp2 : 0 < 3); - [ prove_sup0 - | generalize (Rlt_le 0 3 Hyp2); intro H2; - generalize (lt_INR_0 1 (proj1 (Nat.neq_0_lt_0 1) (Nat.neq_sym 0 1 H0))); - unfold INR; intro H3; - generalize (Rplus_lt_compat_l 2 0 1 H3); - rewrite Rplus_comm; rewrite Rplus_0_l; replace (2 + 1) with 3; - [ intro H4; generalize (sqrt_lt_1 2 3 H1 H2 H4); clear H3; intro H3; - apply (Rlt_trans 0 (sqrt 2) (sqrt 3) Rlt_sqrt2_0 H3) - | ring ] ] ] - | discriminate ]. -Qed. - -Lemma PI4_RGT_0 : 0 < PI / 4. -Proof. - unfold Rdiv; apply Rmult_lt_0_compat; - [ apply PI_RGT_0 | apply Rinv_0_lt_compat; prove_sup0 ]. -Qed. - -Lemma cos_PI4 : cos (PI / 4) = 1 / sqrt 2. -Proof with trivial. - apply Rsqr_inj... - - apply cos_ge_0... - + left; apply (Rlt_trans (- (PI / 2)) 0 (PI / 4) _PI2_RLT_0 PI4_RGT_0)... - + left; apply PI4_RLT_PI2... - - left; apply (Rmult_lt_0_compat 1 (/ sqrt 2))... - + prove_sup... - + apply Rinv_0_lt_compat; apply Rlt_sqrt2_0... - - rewrite Rsqr_div'. - rewrite Rsqr_1; rewrite Rsqr_sqrt... - + unfold Rsqr; pattern (cos (PI / 4)) at 1; - rewrite <- sin_cos_PI4; - replace (sin (PI / 4) * cos (PI / 4)) with - (1 / 2 * (2 * sin (PI / 4) * cos (PI / 4))) by field. - rewrite <- sin_2a; replace (2 * (PI / 4)) with (PI / 2) by field. - rewrite sin_PI2... - field. - + left; prove_sup... -Qed. - -Lemma sin_PI4 : sin (PI / 4) = 1 / sqrt 2. -Proof. - rewrite sin_cos_PI4; apply cos_PI4. -Qed. - -Lemma tan_PI4 : tan (PI / 4) = 1. -Proof. - unfold tan; rewrite sin_cos_PI4. - unfold Rdiv; apply Rinv_r. - change (cos (PI / 4) <> 0); rewrite cos_PI4; apply R1_sqrt2_neq_0. -Qed. - -Lemma cos_3PI4 : cos (3 * (PI / 4)) = -1 / sqrt 2. -Proof. - replace (3 * (PI / 4)) with (PI / 2 - - (PI / 4)) by field. - rewrite cos_shift; rewrite sin_neg; rewrite sin_PI4. - unfold Rdiv. - ring. -Qed. - -Lemma sin_3PI4 : sin (3 * (PI / 4)) = 1 / sqrt 2. -Proof. - replace (3 * (PI / 4)) with (PI / 2 - - (PI / 4)) by field. - now rewrite sin_shift, cos_neg, cos_PI4. -Qed. - -Lemma cos_PI6 : cos (PI / 6) = sqrt 3 / 2. -Proof with trivial. - apply Rsqr_inj... - - apply cos_ge_0... - + left; apply (Rlt_trans (- (PI / 2)) 0 (PI / 6) _PI2_RLT_0 PI6_RGT_0)... - + left; apply PI6_RLT_PI2... - - left; apply (Rmult_lt_0_compat (sqrt 3) (/ 2))... - + apply Rlt_sqrt3_0... - + apply Rinv_0_lt_compat; prove_sup0... - - rewrite Rsqr_div'. - rewrite cos2; unfold Rsqr; rewrite sin_PI6; rewrite sqrt_def... - + field. - + left ; prove_sup0. -Qed. - -Lemma tan_PI6 : tan (PI / 6) = 1 / sqrt 3. -Proof. - unfold tan; rewrite sin_PI6; rewrite cos_PI6; unfold Rdiv; - repeat rewrite Rmult_1_l; rewrite Rinv_mult. - rewrite Rinv_inv. - rewrite (Rmult_comm (/ 2)); rewrite Rmult_assoc; rewrite Rinv_r. - - apply Rmult_1_r. - - discrR. -Qed. - -Lemma sin_PI3 : sin (PI / 3) = sqrt 3 / 2. -Proof. - rewrite sin_PI3_cos_PI6; apply cos_PI6. -Qed. - -Lemma cos_PI3 : cos (PI / 3) = 1 / 2. -Proof. - rewrite sin_PI6_cos_PI3; apply sin_PI6. -Qed. - -Lemma tan_PI3 : tan (PI / 3) = sqrt 3. -Proof. - unfold tan; rewrite sin_PI3; rewrite cos_PI3; unfold Rdiv; - rewrite Rmult_1_l; rewrite Rinv_inv. - rewrite Rmult_assoc; rewrite Rinv_l. - - apply Rmult_1_r. - - discrR. -Qed. - -Lemma sin_2PI3 : sin (2 * (PI / 3)) = sqrt 3 / 2. -Proof. - rewrite <-Rplus_diag; rewrite sin_plus; rewrite sin_PI3; rewrite cos_PI3; - unfold Rdiv; repeat rewrite Rmult_1_l; rewrite (Rmult_comm (/ 2)); - repeat rewrite <- Rmult_assoc; rewrite <-Rplus_half_diag; - reflexivity. -Qed. - -Lemma cos_2PI3 : cos (2 * (PI / 3)) = -1 / 2. -Proof. - rewrite cos_2a, sin_PI3, cos_PI3. - replace (sqrt 3 / 2 * (sqrt 3 / 2)) with ((sqrt 3 * sqrt 3) / 4) by field. - rewrite sqrt_sqrt. - - field. - - left ; prove_sup0. -Qed. - -Lemma tan_2PI3 : tan (2 * (PI / 3)) = - sqrt 3. -Proof. - unfold tan; rewrite sin_2PI3, cos_2PI3. - field. -Qed. - -Lemma cos_5PI4 : cos (5 * (PI / 4)) = -1 / sqrt 2. -Proof. - replace (5 * (PI / 4)) with (PI / 4 + PI) by field. - rewrite neg_cos; rewrite cos_PI4; unfold Rdiv. - ring. -Qed. - -Lemma sin_5PI4 : sin (5 * (PI / 4)) = -1 / sqrt 2. -Proof. - replace (5 * (PI / 4)) with (PI / 4 + PI) by field. - rewrite neg_sin; rewrite sin_PI4; unfold Rdiv. - ring. -Qed. - -Lemma sin_cos5PI4 : cos (5 * (PI / 4)) = sin (5 * (PI / 4)). -Proof. - rewrite cos_5PI4; rewrite sin_5PI4; reflexivity. -Qed. - -Lemma Rgt_3PI2_0 : 0 < 3 * (PI / 2). -Proof. - apply Rmult_lt_0_compat; - [ prove_sup0 - | unfold Rdiv; apply Rmult_lt_0_compat; - [ apply PI_RGT_0 | apply Rinv_0_lt_compat; prove_sup0 ] ]. -Qed. - -Lemma Rgt_2PI_0 : 0 < 2 * PI. -Proof. - apply Rmult_lt_0_compat; [ prove_sup0 | apply PI_RGT_0 ]. -Qed. - -Lemma Rlt_PI_3PI2 : PI < 3 * (PI / 2). -Proof. - generalize PI2_RGT_0; intro H1; - generalize (Rplus_lt_compat_l PI 0 (PI / 2) H1); - replace (PI + PI / 2) with (3 * (PI / 2)). - - rewrite Rplus_0_r; intro H2; assumption. - - pattern PI at 2; rewrite <-Rplus_half_diag; ring. -Qed. - -Lemma Rlt_3PI2_2PI : 3 * (PI / 2) < 2 * PI. -Proof. - generalize PI2_RGT_0; intro H1; - generalize (Rplus_lt_compat_l (3 * (PI / 2)) 0 (PI / 2) H1); - replace (3 * (PI / 2) + PI / 2) with (2 * PI). - - rewrite Rplus_0_r; intro H2; assumption. - - rewrite <-Rplus_diag; pattern PI at 1 2; rewrite <-Rplus_half_diag; ring. -Qed. - -(***************************************************************) -(** Radian -> Degree | Degree -> Radian *) -(***************************************************************) - -Definition plat : R := 180. -Definition toRad (x:R) : R := x * PI * / plat. -Definition toDeg (x:R) : R := x * plat * / PI. - -Lemma rad_deg : forall x:R, toRad (toDeg x) = x. -Proof. - intro; unfold toRad, toDeg; - replace (x * plat * / PI * PI * / plat) with - (x * (plat * / plat) * (PI * / PI)); [ idtac | ring ]. - repeat rewrite Rinv_r. - - ring. - - apply PI_neq0. - - unfold plat; discrR. -Qed. - -Lemma toRad_inj : forall x y:R, toRad x = toRad y -> x = y. -Proof. - intros; unfold toRad in H; apply Rmult_eq_reg_l with PI. - - rewrite <- (Rmult_comm x); rewrite <- (Rmult_comm y). - apply Rmult_eq_reg_l with (/ plat). - + rewrite <- (Rmult_comm (x * PI)); rewrite <- (Rmult_comm (y * PI)); - assumption. - + apply Rinv_neq_0_compat; unfold plat; discrR. - - apply PI_neq0. -Qed. - -Lemma deg_rad : forall x:R, toDeg (toRad x) = x. -Proof. - intro x; apply toRad_inj; rewrite (rad_deg (toRad x)); reflexivity. -Qed. - -Definition sind (x:R) : R := sin (toRad x). -Definition cosd (x:R) : R := cos (toRad x). -Definition tand (x:R) : R := tan (toRad x). - -Lemma Rsqr_sin_cos_d_one : forall x:R, Rsqr (sind x) + Rsqr (cosd x) = 1. -Proof. - intro x; unfold sind; unfold cosd; apply sin2_cos2. -Qed. - -(***************************************************) -(** Other properties *) -(***************************************************) - -Lemma sin_lb_ge_0 : forall a:R, 0 <= a -> a <= PI / 2 -> 0 <= sin_lb a. -Proof. - intros; case (Rtotal_order 0 a); intro. - - left; apply sin_lb_gt_0; assumption. - - elim H1; intro. - + rewrite <- H2; unfold sin_lb; unfold sin_approx; - unfold sum_f_R0; unfold sin_term; - repeat rewrite pow_ne_zero. - * unfold Rdiv; repeat rewrite Rmult_0_l; repeat rewrite Rmult_0_r; - repeat rewrite Rplus_0_r; right; reflexivity. - * discriminate. - * discriminate. - * discriminate. - * discriminate. - + elim (Rlt_irrefl 0 (Rle_lt_trans 0 a 0 H H2)). -Qed. diff --git a/stdlib/theories/Reals/Rtrigo_def.v b/stdlib/theories/Reals/Rtrigo_def.v deleted file mode 100644 index 390d75a5b402..000000000000 --- a/stdlib/theories/Reals/Rtrigo_def.v +++ /dev/null @@ -1,350 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* / INR (fact i) * x ^ i) l. - -Lemma exp_cof_no_R0 : forall n:nat, / INR (fact n) <> 0. -Proof. - intro. - apply Rinv_neq_0_compat. - apply INR_fact_neq_0. -Qed. - -Lemma exist_exp : forall x:R, { l:R | exp_in x l }. -Proof. - intro; - generalize - (Alembert_C3 (fun n:nat => / INR (fact n)) x exp_cof_no_R0 Alembert_exp). - unfold Pser, exp_in. - trivial. -Defined. - -Definition exp (x:R) : R := proj1_sig (exist_exp x). - -Lemma pow_i : forall i:nat, (0 < i)%nat -> 0 ^ i = 0. -Proof. - intros; apply pow_ne_zero. - red; intro; rewrite H0 in H; elim (Nat.lt_irrefl _ H). -Qed. - -(* Value of [exp 0] *) -Lemma exp_0 : exp 0 = 1. -Proof. - cut (exp_in 0 1). - - cut (exp_in 0 (exp 0)). - + apply uniqueness_sum. - + exact (proj2_sig (exist_exp 0)). - - unfold exp_in; unfold infinite_sum; intros. - exists 0%nat. - intros; replace (sum_f_R0 (fun i:nat => / INR (fact i) * 0 ^ i) n) with 1. - + unfold Rdist; replace (1 - 1) with 0; - [ rewrite Rabs_R0; assumption | ring ]. - + induction n as [| n Hrecn]. - * simpl; rewrite Rinv_1; ring. - * rewrite tech5. - rewrite <- Hrecn. - -- simpl. - ring. - -- unfold ge; apply Nat.le_0_l. -Qed. - -(*****************************************) -(** * Definition of hyperbolic functions *) -(*****************************************) -Definition cosh (x:R) : R := (exp x + exp (- x)) / 2. -Definition sinh (x:R) : R := (exp x - exp (- x)) / 2. -Definition tanh (x:R) : R := sinh x / cosh x. - -Lemma cosh_0 : cosh 0 = 1. -Proof. - unfold cosh; rewrite Ropp_0; rewrite exp_0. - unfold Rdiv; rewrite Rinv_r; [ reflexivity | discrR ]. -Qed. - -Lemma sinh_0 : sinh 0 = 0. -Proof. - unfold sinh; rewrite Ropp_0; rewrite exp_0. - unfold Rminus, Rdiv; rewrite Rplus_opp_r; apply Rmult_0_l. -Qed. - -Definition cos_n (n:nat) : R := (-1) ^ n / INR (fact (2 * n)). - -Lemma simpl_cos_n : - forall n:nat, cos_n (S n) / cos_n n = - / INR (2 * S n * (2 * n + 1)). -Proof. - intro; unfold cos_n; replace (S n) with (n + 1)%nat by ring. - rewrite pow_add; unfold Rdiv; rewrite Rinv_mult. - rewrite Rinv_inv. - replace - ((-1) ^ n * (-1) ^ 1 * / INR (fact (2 * (n + 1))) * - (/ (-1) ^ n * INR (fact (2 * n)))) with - ((-1) ^ n * / (-1) ^ n * / INR (fact (2 * (n + 1))) * INR (fact (2 * n)) * - (-1) ^ 1); [ idtac | ring ]. - rewrite Rinv_r. - - rewrite Rmult_1_l; unfold pow; rewrite Rmult_1_r. - replace (2 * (n + 1))%nat with (S (S (2 * n))) by ring. - do 2 rewrite fact_simpl; do 2 rewrite mult_INR; - repeat rewrite Rinv_mult. - rewrite <- (Rmult_comm (-1)). - repeat rewrite Rmult_assoc; rewrite Rinv_l. - + rewrite Rmult_1_r. - replace (S (2 * n)) with (2 * n + 1)%nat by ring. - rewrite mult_INR; rewrite Rinv_mult. - ring. - + apply INR_fact_neq_0. - - apply pow_nonzero; discrR. -Qed. - -Lemma archimed_cor1 : - forall eps:R, 0 < eps -> exists N : nat, / INR N < eps /\ (0 < N)%nat. -Proof. - intros; assert (/ eps < IZR (up (/ eps))). { - assert (H0 := archimed (/ eps)). - elim H0; intros; assumption. - } - assert (0 <= up (/ eps))%Z. { - apply le_IZR; left; - apply Rlt_trans with (/ eps); - [ apply Rinv_0_lt_compat; assumption | assumption ]. - } - assert (H2 := IZN _ H1); elim H2; intros; exists (max x 1). - split. - - assert (0 < IZR (Z.of_nat x)). { - apply Rlt_trans with (/ eps). - - apply Rinv_0_lt_compat; assumption. - - rewrite H3 in H0; assumption. - } - rewrite INR_IZR_INZ; apply Rle_lt_trans with (/ IZR (Z.of_nat x)). - + apply Rmult_le_reg_l with (IZR (Z.of_nat x)). - { assumption. } - rewrite Rinv_r; - [ idtac | red; intro; rewrite H5 in H4; elim (Rlt_irrefl _ H4) ]. - apply Rmult_le_reg_l with (IZR (Z.of_nat (max x 1))). - * apply Rlt_le_trans with (IZR (Z.of_nat x)). - -- assumption. - -- repeat rewrite <- INR_IZR_INZ; apply le_INR; apply Nat.le_max_l. - * rewrite Rmult_1_r; rewrite (Rmult_comm (IZR (Z.of_nat (max x 1)))); - rewrite Rmult_assoc; rewrite Rinv_l. - -- rewrite Rmult_1_r; repeat rewrite <- INR_IZR_INZ; apply le_INR; - apply Nat.le_max_l. - -- rewrite <- INR_IZR_INZ; apply not_O_INR. - red; intro; assert (H6 := Nat.le_max_r x 1); cut (0 < 1)%nat; - [ intro | apply Nat.lt_0_succ ]; assert (H8 := Nat.lt_le_trans _ _ _ H7 H6); - rewrite H5 in H8; elim (Nat.lt_irrefl _ H8). - + pattern eps at 1; rewrite <- Rinv_inv. - apply Rinv_lt_contravar. - * apply Rmult_lt_0_compat; [ apply Rinv_0_lt_compat; assumption | assumption ]. - * rewrite H3 in H0; assumption. - - apply Nat.lt_le_trans with 1%nat; [ apply Nat.lt_0_succ | apply Nat.le_max_r ]. -Qed. - -Lemma Alembert_cos : Un_cv (fun n:nat => Rabs (cos_n (S n) / cos_n n)) 0. -Proof. - unfold Un_cv; intros. - assert (H0 := archimed_cor1 eps H). - elim H0; intros; exists x. - intros; rewrite simpl_cos_n; unfold Rdist; unfold Rminus; - rewrite Ropp_0; rewrite Rplus_0_r; rewrite Rabs_Rabsolu; - rewrite Rabs_Ropp; rewrite Rabs_right. - 2:{ apply Rle_ge; left; apply Rinv_0_lt_compat. - apply lt_INR_0. - replace (2 * S n * (2 * n + 1))%nat with (2 + (4 * (n * n) + 6 * n))%nat by ring. - apply Nat.lt_0_succ. } - rewrite mult_INR; rewrite Rinv_mult. - assert (/ INR (2 * S n) < 1). { - apply Rmult_lt_reg_l with (INR (2 * S n)). - - apply lt_INR_0; replace (2 * S n)%nat with (S (S (2 * n))). - + apply Nat.lt_0_succ. - + replace (S n) with (n + 1)%nat by ring. - ring. - - rewrite Rinv_r. - + rewrite Rmult_1_r. - apply (lt_INR 1). - nia. - + apply not_O_INR; discriminate. - } - cut (/ INR (2 * n + 1) < eps). - { intro; rewrite <- (Rmult_1_l eps). - apply Rmult_gt_0_lt_compat; try assumption. - - change (0 < / INR (2 * n + 1)); apply Rinv_0_lt_compat; - apply lt_INR_0. - replace (2 * n + 1)%nat with (S (2 * n)); [ apply Nat.lt_0_succ | ring ]. - - apply Rlt_0_1. } - assert (x < 2 * n + 1)%nat by nia. - assert (H5 := lt_INR _ _ H4). - apply Rlt_trans with (/ INR x). - 2:{ elim H1; intros; assumption. } - apply Rinv_lt_contravar. - { apply Rmult_lt_0_compat. - - apply lt_INR_0. nia. - - apply lt_INR_0; nia. } - assumption. -Qed. - -Lemma cosn_no_R0 : forall n:nat, cos_n n <> 0. -Proof. - intro; unfold cos_n; unfold Rdiv; apply prod_neq_R0. - - apply pow_nonzero; discrR. - - apply Rinv_neq_0_compat. - apply INR_fact_neq_0. -Qed. - -(**********) -Definition cos_in (x l:R) : Prop := - infinite_sum (fun i:nat => cos_n i * x ^ i) l. - -(**********) -Lemma exist_cos : forall x:R, { l:R | cos_in x l }. -Proof. - intro; generalize (Alembert_C3 cos_n x cosn_no_R0 Alembert_cos). - unfold Pser, cos_in; trivial. -Qed. - - -(** Definition of cosinus *) -Definition cos (x:R) : R := let (a,_) := exist_cos (Rsqr x) in a. - -Definition sin_n (n:nat) : R := (-1) ^ n / INR (fact (2 * n + 1)). - -Lemma simpl_sin_n : - forall n:nat, sin_n (S n) / sin_n n = - / INR ((2 * S n + 1) * (2 * S n)). -Proof. - intro; unfold sin_n; replace (S n) with (n + 1)%nat; [ idtac | ring ]. - rewrite pow_add; unfold Rdiv; rewrite Rinv_mult. - rewrite Rinv_inv. - replace - ((-1) ^ n * (-1) ^ 1 * / INR (fact (2 * (n + 1) + 1)) * - (/ (-1) ^ n * INR (fact (2 * n + 1)))) with - ((-1) ^ n * / (-1) ^ n * / INR (fact (2 * (n + 1) + 1)) * - INR (fact (2 * n + 1)) * (-1) ^ 1); [ idtac | ring ]. - rewrite Rinv_r. - 2:{ apply pow_nonzero; discrR. } - rewrite Rmult_1_l; unfold pow; rewrite Rmult_1_r; - replace (2 * (n + 1) + 1)%nat with (S (S (2 * n + 1))) by nia. - do 2 rewrite fact_simpl; do 2 rewrite mult_INR; - repeat rewrite Rinv_mult. - rewrite <- (Rmult_comm (-1)); repeat rewrite Rmult_assoc; - rewrite Rinv_l. - - rewrite Rmult_1_r; replace (S (2 * n + 1)) with (2 * (n + 1))%nat by nia. - repeat rewrite mult_INR; repeat rewrite Rinv_mult. - ring. - - apply INR_fact_neq_0. -Qed. - -Lemma Alembert_sin : Un_cv (fun n:nat => Rabs (sin_n (S n) / sin_n n)) 0. -Proof. - unfold Un_cv; intros; assert (H0 := archimed_cor1 eps H). - elim H0; intros; exists x. - intros; rewrite simpl_sin_n; unfold Rdist; unfold Rminus; - rewrite Ropp_0; rewrite Rplus_0_r; rewrite Rabs_Rabsolu; - rewrite Rabs_Ropp; rewrite Rabs_right. - 2:{ left; apply Rinv_0_lt_compat. - apply lt_INR_0. nia. } - rewrite mult_INR; rewrite Rinv_mult. - assert (/ INR (2 * S n) < 1). { - apply Rmult_lt_reg_l with (INR (2 * S n)). - - apply lt_INR_0; replace (2 * S n)%nat with (S (S (2 * n))); - [ apply Nat.lt_0_succ | ring ]. - - rewrite Rinv_r. - + rewrite Rmult_1_r. - apply (lt_INR 1). nia. - + apply not_O_INR; discriminate. - } - cut (/ INR (2 * S n + 1) < eps). - { intro; rewrite <- (Rmult_1_l eps); rewrite (Rmult_comm (/ INR (2 * S n + 1))); - apply Rmult_gt_0_lt_compat; try assumption. - - change (0 < / INR (2 * S n + 1)); apply Rinv_0_lt_compat; - apply lt_INR_0; nia. - - apply Rlt_0_1. } - assert (x < 2 * S n + 1)%nat by nia. - assert (H5 := lt_INR _ _ H4); apply Rlt_trans with (/ INR x). - { apply Rinv_lt_contravar. - - apply Rmult_lt_0_compat;apply lt_INR_0; nia. - - assumption. } - elim H1; intros; assumption. -Qed. - -Lemma sin_no_R0 : forall n:nat, sin_n n <> 0. -Proof. - intro; unfold sin_n; unfold Rdiv; apply prod_neq_R0. - - apply pow_nonzero; discrR. - - apply Rinv_neq_0_compat; apply INR_fact_neq_0. -Qed. - -(**********) -Definition sin_in (x l:R) : Prop := - infinite_sum (fun i:nat => sin_n i * x ^ i) l. - -(**********) -Lemma exist_sin : forall x:R, { l:R | sin_in x l }. -Proof. - intro; generalize (Alembert_C3 sin_n x sin_no_R0 Alembert_sin). - unfold Pser, sin_n; trivial. -Defined. - -(***********************) -(* Definition of sinus *) -Definition sin (x:R) : R := let (a,_) := exist_sin (Rsqr x) in x * a. - -(*********************************************) -(** * Properties *) -(*********************************************) - -Lemma cos_sym : forall x:R, cos x = cos (- x). -Proof. - intros; unfold cos; replace (Rsqr (- x)) with (Rsqr x). - - reflexivity. - - apply Rsqr_neg. -Qed. - -Lemma sin_antisym : forall x:R, sin (- x) = - sin x. -Proof. - intro; unfold sin; replace (Rsqr (- x)) with (Rsqr x); - [ idtac | apply Rsqr_neg ]. - case (exist_sin (Rsqr x)); intros; ring. -Qed. - -Lemma sin_0 : sin 0 = 0. -Proof. - unfold sin; case (exist_sin (Rsqr 0)). - intros; ring. -Qed. - -(* Value of [cos 0] *) -Lemma cos_0 : cos 0 = 1. -Proof. - cut (cos_in 0 1). - - cut (cos_in 0 (cos 0)). - + apply uniqueness_sum. - + rewrite <- Rsqr_0 at 1. - exact (proj2_sig (exist_cos (Rsqr 0))). - - unfold cos_in; unfold infinite_sum; intros; exists 0%nat. - intros. - unfold Rdist. - induction n as [| n Hrecn]. - + unfold cos_n; simpl. - unfold Rdiv; rewrite Rinv_1. - do 2 rewrite Rmult_1_r. - unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0; assumption. - + rewrite tech5. - replace (cos_n (S n) * 0 ^ S n) with 0. - * rewrite Rplus_0_r. - apply Hrecn; unfold ge; apply Nat.le_0_l. - * simpl; ring. -Qed. diff --git a/stdlib/theories/Reals/Rtrigo_facts.v b/stdlib/theories/Reals/Rtrigo_facts.v deleted file mode 100644 index e5902e1ce9a9..000000000000 --- a/stdlib/theories/Reals/Rtrigo_facts.v +++ /dev/null @@ -1,284 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* =0 -> - cos x = sqrt(1 - (sin x)Ā²). -Proof. - intros x H. - apply Rsqr_inj. - - lra. - - apply sqrt_pos. - - rewrite Rsqr_sqrt. - + apply cos2. - + pose proof sin2_bound x. - lra. -Qed. - -Lemma cos_sin_opp : forall x, cos x <=0 -> - cos x = - sqrt(1 - (sin x)Ā²). -Proof. - intros x H. - rewrite <- (Ropp_involutive (cos x)). - apply Ropp_eq_compat. - apply Rsqr_inj. - - lra. - - apply sqrt_pos. - - rewrite Rsqr_sqrt. - + rewrite <- Rsqr_neg. - apply cos2. - + pose proof sin2_bound x. - lra. -Qed. - -Lemma cos_sin_Rabs : forall x, - Rabs (cos x) = sqrt(1 - (sin x)Ā²). -Proof. - intros x. - unfold Rabs. - destruct (Rcase_abs (cos x)). - - rewrite <- (Ropp_involutive (sqrt (1 - (sin x)Ā²))). - apply Ropp_eq_compat. - apply cos_sin_opp; lra. - - apply cos_sin; assumption. -Qed. - -Lemma sin_cos : forall x, sin x >=0 -> - sin x = sqrt(1 - (cos x)Ā²). -Proof. - intros x H. - apply Rsqr_inj. - - lra. - - apply sqrt_pos. - - rewrite Rsqr_sqrt. - + apply sin2. - + pose proof cos2_bound x. - lra. -Qed. - -Lemma sin_cos_opp : forall x, sin x <=0 -> - sin x = - sqrt(1 - (cos x)Ā²). -Proof. - intros x H. - rewrite <- (Ropp_involutive (sin x)). - apply Ropp_eq_compat. - apply Rsqr_inj. - - lra. - - apply sqrt_pos. - - rewrite Rsqr_sqrt. - + rewrite <- Rsqr_neg. - apply sin2. - + pose proof cos2_bound x. - lra. -Qed. - -Lemma sin_cos_Rabs : forall x, - Rabs (sin x) = sqrt(1 - (cos x)Ā²). -Proof. - intros x. - unfold Rabs. - destruct (Rcase_abs (sin x)). - - rewrite <- ( Ropp_involutive (sqrt (1 - (cos x)Ā²))). - apply Ropp_eq_compat. - apply sin_cos_opp; lra. - - apply sin_cos; assumption. -Qed. - -(** ** Express tan with sin and cos *) - -Lemma tan_sin : forall x, 0 <= cos x -> - tan x = sin x / sqrt (1 - (sin x)Ā²). -Proof. - intros x H. - unfold tan. - rewrite <- (sqrt_Rsqr (cos x)) by assumption. - rewrite <- (cos2 x). - reflexivity. -Qed. - -Lemma tan_sin_opp : forall x, 0 > cos x -> - tan x = - (sin x / sqrt (1 - (sin x)Ā²)). -Proof. - intros x H. - unfold tan. - rewrite cos_sin_opp by lra. - apply Rdiv_opp_r. -Qed. - -(** Note: tan_sin_Rabs wouldn't make a lot of sense, because one would need Rabs on both sides *) - -Lemma tan_cos : forall x, 0 <= sin x -> - tan x = sqrt (1 - (cos x)Ā²) / cos x. -Proof. - intros x H. - unfold tan. - rewrite <- (sqrt_Rsqr (sin x)) by assumption. - rewrite <- (sin2 x). - reflexivity. -Qed. - -Lemma tan_cos_opp : forall x, 0 >= sin x -> - tan x = - sqrt (1 - (cos x)Ā²) / cos x. -Proof. - intros x H. - unfold tan. - rewrite sin_cos_opp by lra. - reflexivity. -Qed. - -(** ** Express sin and cos with tan *) - -Lemma sin_tan : forall x, 0 < cos x -> - sin x = tan x / sqrt (1 + (tan x)Ā²). -Proof. - intros. - assert(Hcosle:0<=cos x) by lra. - pose proof tan_sin x Hcosle as Htan. - pose proof (sin2 x); pose proof Rsqr_pos_lt (cos x). - rewrite Htan. - unfold Rdiv at 1 2. - rewrite Rmult_assoc, <- Rinv_mult. - rewrite <- sqrt_mult_alt by lra. - rewrite Rsqr_div', Rsqr_sqrt by lra. - field_simplify ((1 - (sin x)Ā²) * (1 + (sin x)Ā² / (1 - (sin x)Ā²))). - - rewrite sqrt_1. - field. - - lra. -Qed. - -Lemma cos_tan : forall x, 0 < cos x -> - cos x = 1 / sqrt (1 + (tan x)Ā²). -Proof. - intros. - destruct (Rcase_abs (sin x)) as [Hsignsin|Hsignsin]. - - assert(Hsinle:0>=sin x) by lra. - pose proof tan_cos_opp x Hsinle as Htan. - rewrite Htan. - rewrite Rsqr_div'. - rewrite <- Rsqr_neg. - pose proof cos2_bound x. - pose proof Rsqr_pos_lt (cos x) ltac:(lra). - pose proof sqrt_lt_R0 (cos x)Ā² ltac:(assumption). - rewrite Rsqr_sqrt. - 2:lra. - field_simplify( 1 + (1 - (cos x)Ā²) / (cos x)Ā² ). - 2:lra. - rewrite sqrt_div_alt. - 2:lra. - rewrite sqrt_1. - field_simplify_eq. - 2:lra. - rewrite sqrt_Rsqr;lra. - - assert(Hsinge:0<=sin x) by lra. - pose proof tan_cos x Hsinge as Htan. - rewrite Htan. - rewrite Rsqr_div'. - pose proof cos2_bound x. - pose proof Rsqr_pos_lt (cos x) ltac:(lra). - pose proof sqrt_lt_R0 (cos x)Ā² ltac:(assumption). - rewrite Rsqr_sqrt. - 2:lra. - field_simplify( 1 + (1 - (cos x)Ā²) / (cos x)Ā² ). - 2:lra. - rewrite sqrt_div_alt. - 2:lra. - rewrite sqrt_1. - field_simplify_eq. - 2:lra. - rewrite sqrt_Rsqr;lra. -Qed. - -(*********************************************************) -(** * Additional shift lemmas for sin, cos, tan *) -(*********************************************************) - -Lemma sin_pi_minus : forall x, - sin (PI - x) = sin x. -Proof. - intros x. - rewrite sin_minus, cos_PI, sin_PI. - ring. -Qed. - -Lemma sin_pi_plus : forall x, - sin (PI + x) = - sin x. -Proof. - intros x. - rewrite sin_plus, cos_PI, sin_PI. - ring. -Qed. - -Lemma cos_pi_minus : forall x, - cos (PI - x) = - cos x. -Proof. - intros x. - rewrite cos_minus, cos_PI, sin_PI. - ring. -Qed. - -Lemma cos_pi_plus : forall x, - cos (PI + x) = - cos x. -Proof. - intros x. - rewrite cos_plus, cos_PI, sin_PI. - ring. -Qed. - -Lemma tan_pi_minus : forall x, cos x <> 0 -> - tan (PI - x) = - tan x. -Proof. - intros x H. - unfold tan; rewrite sin_pi_minus, cos_pi_minus. - field; assumption. -Qed. - -Lemma tan_pi_plus : forall x, cos x <> 0 -> - tan (PI + x) = tan x. -Proof. - intros x H. - unfold tan; rewrite sin_pi_plus, cos_pi_plus. - field; assumption. -Qed. diff --git a/stdlib/theories/Reals/Rtrigo_fun.v b/stdlib/theories/Reals/Rtrigo_fun.v deleted file mode 100644 index 917e2a56bf8a..000000000000 --- a/stdlib/theories/Reals/Rtrigo_fun.v +++ /dev/null @@ -1,101 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* Rabs (/ INR (fact (S n)) * / / INR (fact n))) 0. -Proof. - unfold Un_cv; intros; destruct (Rgt_dec eps 1) as [Hgt|Hnotgt]. - - split with 0%nat; intros; rewrite (simpl_fact n); unfold Rdist; - rewrite (Rminus_0_r (Rabs (/ INR (S n)))); - rewrite (Rabs_Rabsolu (/ INR (S n))); cut (/ INR (S n) > 0). - + intro; rewrite (Rabs_pos_eq (/ INR (S n))). - * cut (/ eps - 1 < 0). - -- intro H2; generalize (Rlt_le_trans (/ eps - 1) 0 (INR n) H2 (pos_INR n)); - clear H2; intro; unfold Rminus in H2; - generalize (Rplus_lt_compat_l 1 (/ eps + -1) (INR n) H2); - replace (1 + (/ eps + -1)) with (/ eps); [ clear H2; intro | ring ]. - rewrite (Rplus_comm 1 (INR n)) in H2; rewrite <- (S_INR n) in H2; - generalize (Rmult_gt_0_compat (/ INR (S n)) eps H1 H); - intro; unfold Rgt in H3; - generalize (Rmult_lt_compat_l (/ INR (S n) * eps) (/ eps) (INR (S n)) H3 H2); - intro; rewrite (Rmult_assoc (/ INR (S n)) eps (/ eps)) in H4; - rewrite (Rinv_r eps (Rlt_dichotomy_converse eps 0 (or_intror (eps < 0) H))) - in H4; rewrite (let (H1, H2) := Rmult_ne (/ INR (S n)) in H1) in H4; - rewrite (Rmult_comm (/ INR (S n))) in H4; - rewrite (Rmult_assoc eps (/ INR (S n)) (INR (S n))) in H4; - rewrite (Rinv_l (INR (S n)) (not_O_INR (S n) (not_eq_sym (O_S n)))) in H4; - rewrite (let (H1, H2) := Rmult_ne eps in H1) in H4; - assumption. - -- apply Rlt_minus; unfold Rgt in Hgt; rewrite <- Rinv_1; - apply (Rinv_lt_contravar 1 eps); auto; - rewrite (let (H1, H2) := Rmult_ne eps in H2); unfold Rgt in H; - assumption. - * unfold Rgt in H1; apply Rlt_le; assumption. - + unfold Rgt; apply Rinv_0_lt_compat; apply lt_INR_0; apply Nat.lt_0_succ. - - cut (0 <= up (/ eps - 1))%Z. - + intro; elim (IZN (up (/ eps - 1)) H0); intros; split with x; intros; - rewrite (simpl_fact n); unfold Rdist; - rewrite (Rminus_0_r (Rabs (/ INR (S n)))); - rewrite (Rabs_Rabsolu (/ INR (S n))); cut (/ INR (S n) > 0). - * intro; rewrite (Rabs_pos_eq (/ INR (S n))). - -- cut (/ eps - 1 < INR x). - ++ intro ; - generalize - (Rlt_le_trans (/ eps - 1) (INR x) (INR n) H4 - (le_INR x n H2)); - clear H4; intro; unfold Rminus in H4; - generalize (Rplus_lt_compat_l 1 (/ eps + -1) (INR n) H4); - replace (1 + (/ eps + -1)) with (/ eps); [ clear H4; intro | ring ]. - rewrite (Rplus_comm 1 (INR n)) in H4; rewrite <- (S_INR n) in H4; - generalize (Rmult_gt_0_compat (/ INR (S n)) eps H3 H); - intro; unfold Rgt in H5; - generalize (Rmult_lt_compat_l (/ INR (S n) * eps) (/ eps) (INR (S n)) H5 H4); - intro; rewrite (Rmult_assoc (/ INR (S n)) eps (/ eps)) in H6; - rewrite (Rinv_r eps (Rlt_dichotomy_converse eps 0 (or_intror (eps < 0) H))) - in H6; rewrite (let (H1, H2) := Rmult_ne (/ INR (S n)) in H1) in H6; - rewrite (Rmult_comm (/ INR (S n))) in H6; - rewrite (Rmult_assoc eps (/ INR (S n)) (INR (S n))) in H6; - rewrite (Rinv_l (INR (S n)) (not_O_INR (S n) (not_eq_sym (O_S n)))) in H6; - rewrite (let (H1, H2) := Rmult_ne eps in H1) in H6; - assumption. - ++ cut (IZR (up (/ eps - 1)) = IZR (Z.of_nat x)); - [ intro | rewrite H1; trivial ]. - elim (archimed (/ eps - 1)); intros; clear H6; unfold Rgt in H5; - rewrite H4 in H5; rewrite INR_IZR_INZ; assumption. - -- unfold Rgt in H1; apply Rlt_le; assumption. - * unfold Rgt; apply Rinv_0_lt_compat; apply lt_INR_0; apply Nat.lt_0_succ. - + apply (le_O_IZR (up (/ eps - 1))); - apply (Rle_trans 0 (/ eps - 1) (IZR (up (/ eps - 1)))). - * generalize (Rnot_gt_le eps 1 Hnotgt); clear Hnotgt; unfold Rle; intro; elim H0; - clear H0; intro. - -- left; unfold Rgt in H; - generalize (Rmult_lt_compat_l (/ eps) eps 1 (Rinv_0_lt_compat eps H) H0); - rewrite - (Rinv_l eps - (not_eq_sym (Rlt_dichotomy_converse 0 eps (or_introl (0 > eps) H)))) - ; rewrite (let (H1, H2) := Rmult_ne (/ eps) in H1); - intro; fold (/ eps - 1 > 0); apply Rgt_minus; - unfold Rgt; assumption. - -- right; rewrite H0; rewrite Rinv_1; symmetry; apply Rminus_diag_eq; auto. - * elim (archimed (/ eps - 1)); intros; clear H1; unfold Rgt in H0; apply Rlt_le; - assumption. -Qed. diff --git a/stdlib/theories/Reals/Rtrigo_reg.v b/stdlib/theories/Reals/Rtrigo_reg.v deleted file mode 100644 index a99b3372e0cf..000000000000 --- a/stdlib/theories/Reals/Rtrigo_reg.v +++ /dev/null @@ -1,426 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* R -> R, - fn = - (fun (N:nat) (x:R) => (-1) ^ N / INR (fact (2 * N + 1)) * x ^ (2 * N)) -> - CVN_R fn. -Proof. - unfold CVN_R; unfold CVN_r; intros fn H r. - exists (fun n:nat => / INR (fact (2 * n + 1)) * r ^ (2 * n)). - cut - { l:R | - Un_cv - (fun n:nat => - sum_f_R0 - (fun k:nat => Rabs (/ INR (fact (2 * k + 1)) * r ^ (2 * k))) n) - l }. - { intros (x,p). - exists x. - split. - { apply p. } - intros; rewrite H; unfold Rdiv; do 2 rewrite Rabs_mult; - rewrite pow_1_abs; rewrite Rmult_1_l. - assert (0 < / INR (fact (2 * n + 1))). { - apply Rinv_0_lt_compat; apply INR_fact_lt_0. - } - rewrite (Rabs_right _ (Rle_ge _ _ (Rlt_le _ _ H1))). - apply Rmult_le_compat_l. - { left; apply H1. } - rewrite <- RPow_abs; apply pow_maj_Rabs. - rewrite Rabs_Rabsolu; unfold Boule in H0; rewrite Rminus_0_r in H0; left; - apply H0. } - assert ((r:R) <> 0). { - assert (H0 := cond_pos r); red; intro; rewrite H1 in H0; - elim (Rlt_irrefl _ H0). - } - apply Alembert_C2. - { intro; apply Rabs_no_R0. - apply prod_neq_R0. - { apply Rinv_neq_0_compat; apply INR_fact_neq_0. } - apply pow_nonzero; assumption. } - assert (H1 := Alembert_sin). - unfold sin_n in H1; unfold Un_cv in H1; unfold Un_cv; intros. - assert (0 < eps / Rsqr r). { - unfold Rdiv; apply Rmult_lt_0_compat; - [ assumption | apply Rinv_0_lt_compat; apply Rsqr_pos_lt; assumption ]. - } - elim (H1 _ H3); intros N0 H4. - exists N0; intros. - unfold Rdist; assert (H6 := H4 _ H5). - unfold Rdist in H5; - replace - (Rabs - (Rabs (/ INR (fact (2 * S n + 1)) * r ^ (2 * S n)) / - Rabs (/ INR (fact (2 * n + 1)) * r ^ (2 * n)))) with - (Rsqr r * - Rabs - ((-1) ^ S n / INR (fact (2 * S n + 1)) / - ((-1) ^ n / INR (fact (2 * n + 1))))). - { apply Rmult_lt_reg_l with (/ Rsqr r). - { apply Rinv_0_lt_compat; apply Rsqr_pos_lt; assumption. } - pattern (/ Rsqr r) at 1; rewrite <- (Rabs_right (/ Rsqr r)). - 2:{ apply Rle_ge; left; apply Rinv_0_lt_compat; apply Rsqr_pos_lt; assumption. } - rewrite <- Rabs_mult. - rewrite Rmult_minus_distr_l. - rewrite Rmult_0_r; rewrite <- Rmult_assoc; rewrite Rinv_l. - 2:{ unfold Rsqr; apply prod_neq_R0; assumption. } - rewrite Rmult_1_l; rewrite <- (Rmult_comm eps). - apply H6. } - unfold Rdiv; rewrite (Rmult_comm (Rsqr r)); repeat rewrite Rabs_mult; - rewrite Rabs_Rabsolu; rewrite pow_1_abs. - rewrite Rmult_1_l. - repeat rewrite Rmult_assoc; apply Rmult_eq_compat_l. - rewrite Rinv_mult. - rewrite Rinv_inv. - rewrite Rabs_mult. - rewrite Rabs_inv. - rewrite pow_1_abs; rewrite Rinv_1; rewrite Rmult_1_l. - rewrite Rinv_mult. - rewrite <- Rabs_inv. - rewrite Rinv_inv. - rewrite Rabs_mult. - do 2 rewrite Rabs_Rabsolu. - rewrite (Rmult_comm (Rabs (r ^ (2 * S n)))). - rewrite Rmult_assoc; apply Rmult_eq_compat_l. - rewrite Rabs_inv. - rewrite Rabs_Rabsolu. - repeat rewrite Rabs_right. - 2,3:apply Rle_ge; apply pow_le; left; apply (cond_pos r). - replace (r ^ (2 * S n)) with (r ^ (2 * n) * r * r). - 2:{ replace (2 * S n)%nat with (S (S (2 * n)));simpl;ring. } - do 2 rewrite <- Rmult_assoc. - rewrite Rinv_l. - 2:{ apply pow_nonzero; assumption. } - unfold Rsqr; ring. -Qed. - -(** (sin h)/h -> 1 when h -> 0 *) -Lemma derivable_pt_lim_sin_0 : derivable_pt_lim sin 0 1. -Proof. - unfold derivable_pt_lim; intros. - set - (fn := fun (N:nat) (x:R) => (-1) ^ N / INR (fact (2 * N + 1)) * x ^ (2 * N)). - assert (CVN_R fn) by (apply CVN_R_sin; unfold fn; reflexivity). - assert (cv:forall x:R, { l:R | Un_cv (fun N:nat => SP fn N x) l }) by apply (CVN_R_CVS _ X). - set (r := mkposreal _ Rlt_0_1). - assert (CVN_r fn r) by apply (X r). - assert (forall (n:nat) (y:R), Boule 0 r y -> continuity_pt (fn n) y). { - intros; unfold fn; - replace (fun x:R => (-1) ^ n / INR (fact (2 * n + 1)) * x ^ (2 * n)) with - (fct_cte ((-1) ^ n / INR (fact (2 * n + 1))) * pow_fct (2 * n))%F; - [ idtac | reflexivity ]. - apply continuity_pt_mult. - - apply derivable_continuous_pt. - apply derivable_pt_const. - - apply derivable_continuous_pt. - apply (derivable_pt_pow (2 * n) y). - } - assert (Boule 0 r 0). { - unfold Boule; unfold Rminus; rewrite Ropp_0; - rewrite Rplus_0_r; rewrite Rabs_R0; apply (cond_pos r). - } - assert (H2 := SFL_continuity_pt _ cv _ X0 H0 _ H1). - unfold continuity_pt in H2; unfold continue_in in H2; unfold limit1_in in H2; - unfold limit_in in H2; simpl in H2; unfold Rdist in H2. - elim (H2 _ H); intros alp H3. - elim H3; intros. - exists (mkposreal _ H4). - simpl; intros. - rewrite sin_0; rewrite Rplus_0_l; unfold Rminus; rewrite Ropp_0; - rewrite Rplus_0_r. - assert (Rabs (SFL fn cv h - SFL fn cv 0) < eps). { - apply H5. - split. - - unfold D_x, no_cond; split. - + trivial. - + apply (not_eq_sym (A:=R)); apply H6. - - unfold Rminus; rewrite Ropp_0; rewrite Rplus_0_r; apply H7. - } - assert (SFL fn cv 0 = 1). { - unfold SFL, sin. - case (cv 0) as (?,HUn). - eapply UL_sequence. - - apply HUn. - - unfold SP, fn; unfold Un_cv; intros; exists 1%nat; intros. - unfold Rdist; - replace - (sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k + 1)) * 0 ^ (2 * k)) n) - with 1. - + unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0; assumption. - + rewrite decomp_sum. - * simpl; rewrite Rmult_1_r; unfold Rdiv; rewrite Rinv_1; - rewrite Rmult_1_r; pattern 1 at 1; rewrite <- Rplus_0_r; - apply Rplus_eq_compat_l. - symmetry ; apply sum_eq_R0; intros. - rewrite Rmult_0_l; rewrite Rmult_0_r; reflexivity. - * unfold ge in H10; apply Nat.lt_le_trans with 1%nat; [ apply Nat.lt_succ_diag_r | apply H10 ]. - } - cut (SFL fn cv h = sin h / h). - { intro; rewrite H9 in H8; rewrite H10 in H8. - apply H8. } - unfold SFL, sin. - case (cv h) as (x,HUn). - case (exist_sin (Rsqr h)) as (x0,Hsin). - unfold Rdiv; rewrite (Rmult_inv_r_id_m h x0 H6). - eapply UL_sequence. - - apply HUn. - - unfold sin_in in Hsin; unfold sin_n, infinite_sum in Hsin; - unfold SP, fn, Un_cv; intros. - elim (Hsin _ H10); intros N0 H11. - exists N0; intros. - unfold Rdist; unfold Rdist in H11. - replace - (sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k + 1)) * h ^ (2 * k)) n) - with - (sum_f_R0 (fun i:nat => (-1) ^ i / INR (fact (2 * i + 1)) * Rsqr h ^ i) n). - + apply H11; assumption. - + apply sum_eq; intros; apply Rmult_eq_compat_l; unfold Rsqr; - rewrite pow_sqr; reflexivity. -Qed. - -(** ((cos h)-1)/h -> 0 when h -> 0 *) -Lemma derivable_pt_lim_cos_0 : derivable_pt_lim cos 0 0. -Proof. - unfold derivable_pt_lim; intros. - assert (H0 := derivable_pt_lim_sin_0). - unfold derivable_pt_lim in H0. - assert (0 < eps / 2) by lra. - elim (H0 _ H1); intros del H2. - assert (continuity_pt sin 0) by apply continuity_sin. - unfold continuity_pt in H3; unfold continue_in in H3; - unfold limit1_in in H3; unfold limit_in in H3; simpl in H3; - unfold Rdist in H3. - cut (0 < eps / 2); [ intro | assumption ]. - elim (H3 _ H4); intros del_c H5. - assert (0 < Rmin del del_c). { - unfold Rmin; case (Rle_dec del del_c); intro. - - apply (cond_pos del). - - elim H5; intros; assumption. - } - set (delta := mkposreal _ H6). - exists delta; intros. - rewrite Rplus_0_l; replace (cos h - cos 0) with (-2 * Rsqr (sin (h / 2))). - 2:{ pattern h at 2; replace h with (2 * (h / 2)) by field. - rewrite (cos_2a_sin (h / 2)). - rewrite cos_0; unfold Rsqr; ring. } - unfold Rminus; rewrite Ropp_0; rewrite Rplus_0_r. - change (-2) with (-(2)). - unfold Rdiv; do 2 rewrite Ropp_mult_distr_l_reverse. - rewrite Rabs_Ropp. - replace (2 * Rsqr (sin (h * / 2)) * / h) with - (sin (h / 2) * (sin (h / 2) / (h / 2) - 1) + sin (h / 2)). - 2:{ rewrite Rmult_minus_distr_l; rewrite Rmult_1_r; unfold Rminus; - rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r; - rewrite (Rmult_comm 2); unfold Rdiv, Rsqr. - field. - assumption. } - apply Rle_lt_trans with - (Rabs (sin (h / 2) * (sin (h / 2) / (h / 2) - 1)) + Rabs (sin (h / 2))). - { apply Rabs_triang. } - rewrite <-(Rplus_half_diag eps); apply Rplus_lt_compat. - - apply Rle_lt_trans with (Rabs (sin (h / 2) / (h / 2) - 1)). - { rewrite Rabs_mult; rewrite Rmult_comm; - pattern (Rabs (sin (h / 2) / (h / 2) - 1)) at 2; - rewrite <- Rmult_1_r; apply Rmult_le_compat_l. - { apply Rabs_pos. } - pose proof (SIN_bound (h/2));unfold Rabs. - destruct (Rcase_abs _);lra. } - cut (Rabs (h / 2) < del). - { intro; assert (h / 2 <> 0) by lra. - assert (H11 := H2 _ H10 H9). - rewrite Rplus_0_l in H11; rewrite sin_0 in H11. - rewrite Rminus_0_r in H11; apply H11. } - apply Rlt_trans with (del / 2). - 2:pose proof (cond_pos del);lra. - unfold Rdiv; rewrite Rabs_mult. - rewrite (Rabs_right (/ 2)). - 2:lra. - do 2 rewrite <- (Rmult_comm (/ 2)); apply Rmult_lt_compat_l. - { lra. } - apply Rlt_le_trans with (pos delta). - { assumption. } - unfold delta; simpl; apply Rmin_l. - - elim H5; intros; assert (H11 := H10 (h / 2)). - rewrite sin_0 in H11; do 2 rewrite Rminus_0_r in H11. - apply H11. - split. - { unfold D_x, no_cond; split;lra. } - apply Rlt_trans with (del_c / 2). - 2:{ lra. } - unfold Rdiv; rewrite Rabs_mult. - rewrite (Rabs_right (/ 2)). - 2:lra. - do 2 rewrite <- (Rmult_comm (/ 2)). - apply Rmult_lt_compat_l. - { lra. } - apply Rlt_le_trans with (pos delta). - + assumption. - + unfold delta; simpl; apply Rmin_r. -Qed. - -(**********) -Theorem derivable_pt_lim_sin : forall x:R, derivable_pt_lim sin x (cos x). -Proof. - intro; assert (H0 := derivable_pt_lim_sin_0). - assert (H := derivable_pt_lim_cos_0). - unfold derivable_pt_lim in H0, H. - unfold derivable_pt_lim; intros. - cut (0 < eps / 2); - [ intro - | unfold Rdiv; apply Rmult_lt_0_compat; - [ apply H1 | apply Rinv_0_lt_compat; prove_sup0 ] ]. - elim (H0 _ H2); intros alp1 H3. - elim (H _ H2); intros alp2 H4. - set (alp := Rmin alp1 alp2). - assert (0 < alp). { - unfold alp; unfold Rmin; case (Rle_dec alp1 alp2); intro. - - apply (cond_pos alp1). - - apply (cond_pos alp2). - } - exists (mkposreal _ H5); intros. - replace ((sin (x + h) - sin x) / h - cos x) with - (sin x * ((cos h - 1) / h) + cos x * (sin h / h - 1)). - 2:{ rewrite sin_plus; now field. } - eapply Rle_lt_trans. - { apply Rabs_triang. } - rewrite <-(Rplus_half_diag eps); apply Rplus_lt_compat. - - apply Rle_lt_trans with (Rabs ((cos h - 1) / h)). - + rewrite Rabs_mult; rewrite Rmult_comm; - pattern (Rabs ((cos h - 1) / h)) at 2; rewrite <- Rmult_1_r; - apply Rmult_le_compat_l. - { apply Rabs_pos. } - pose proof (SIN_bound x). - unfold Rabs; case (Rcase_abs (sin x)); lra. - + assert (Rabs h < alp2). { - apply Rlt_le_trans with alp. - - apply H7. - - unfold alp; apply Rmin_r. - } - assert (H9 := H4 _ H6 H8). - rewrite cos_0 in H9; rewrite Rplus_0_l in H9; rewrite Rminus_0_r in H9; - apply H9. - - apply Rle_lt_trans with (Rabs (sin h / h - 1)). - + rewrite Rabs_mult; rewrite Rmult_comm; - pattern (Rabs (sin h / h - 1)) at 2; rewrite <- Rmult_1_r; - apply Rmult_le_compat_l. - { apply Rabs_pos. } - pose proof (COS_bound x). - unfold Rabs; case (Rcase_abs (cos x)); lra. - + assert (Rabs h < alp1). { - apply Rlt_le_trans with alp. - - apply H7. - - unfold alp; apply Rmin_l. - } - assert (H9 := H3 _ H6 H8). - rewrite sin_0 in H9; rewrite Rplus_0_l in H9; rewrite Rminus_0_r in H9; - apply H9. -Qed. - -Lemma derivable_pt_lim_cos : forall x:R, derivable_pt_lim cos x (- sin x). -Proof. - intro; cut (forall h:R, sin (h + PI / 2) = cos h). - - intro; replace (- sin x) with (cos (x + PI / 2) * (1 + 0)). - + generalize (derivable_pt_lim_comp (id + fct_cte (PI / 2))%F sin); intros. - cut (derivable_pt_lim (id + fct_cte (PI / 2)) x (1 + 0)). - * cut (derivable_pt_lim sin ((id + fct_cte (PI / 2))%F x) (cos (x + PI / 2))). - -- intros; generalize (H0 _ _ _ H2 H1); - replace (comp sin (id + fct_cte (PI / 2))%F) with - (fun x:R => sin (x + PI / 2)); [ idtac | reflexivity ]. - unfold derivable_pt_lim; intros. - elim (H3 eps H4); intros. - exists x0. - intros; rewrite <- (H (x + h)); rewrite <- (H x); apply H5; assumption. - -- apply derivable_pt_lim_sin. - * apply derivable_pt_lim_plus. - -- apply derivable_pt_lim_id. - -- apply derivable_pt_lim_const. - + rewrite sin_cos; rewrite <- (Rplus_comm x); ring. - - intro; rewrite cos_sin; rewrite Rplus_comm; reflexivity. -Qed. - -Lemma derivable_pt_sin : forall x:R, derivable_pt sin x. -Proof. - unfold derivable_pt; intro. - exists (cos x). - apply derivable_pt_lim_sin. -Qed. - -Lemma derivable_pt_cos : forall x:R, derivable_pt cos x. -Proof. - unfold derivable_pt; intro. - exists (- sin x). - apply derivable_pt_lim_cos. -Qed. - -Lemma derivable_sin : derivable sin. -Proof. - unfold derivable; intro; apply derivable_pt_sin. -Qed. - -Lemma derivable_cos : derivable cos. -Proof. - unfold derivable; intro; apply derivable_pt_cos. -Qed. - -Lemma derive_pt_sin : - forall x:R, derive_pt sin x (derivable_pt_sin _) = cos x. -Proof. - intros; apply derive_pt_eq_0. - apply derivable_pt_lim_sin. -Qed. - -Lemma derive_pt_cos : - forall x:R, derive_pt cos x (derivable_pt_cos _) = - sin x. -Proof. - intros; apply derive_pt_eq_0. - apply derivable_pt_lim_cos. -Qed. diff --git a/stdlib/theories/Reals/Runcountable.v b/stdlib/theories/Reals/Runcountable.v deleted file mode 100644 index 23bf880129d0..000000000000 --- a/stdlib/theories/Reals/Runcountable.v +++ /dev/null @@ -1,440 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* A) (v : A -> nat) : Prop := - (forall x : A, u (v x) = x) /\ (forall n : nat, v (u n) = n). - -Definition in_holed_interval (a b hole : R) (u : nat -> R) (n : nat) : Prop := - Rlt a (u n) /\ Rlt (u n) b /\ u n <> hole. - -(* Here we use axiom total_order_T, which is not constructive *) -Lemma in_holed_interval_dec (a b h : R) (u : nat -> R) (n : nat) - : {in_holed_interval a b h u n} + {~in_holed_interval a b h u n}. -Proof. - destruct (total_order_T a (u n)) as [[l|e]|hi]. - - destruct (total_order_T b (u n)) as [[lb|eb]|hb]. - + right. intro H. destruct H. destruct H0. apply Rlt_asym in H0. contradiction. - + subst. right. intro H. destruct H. destruct H0. - pose proof (Rlt_asym (u n) (u n) H0). contradiction. - + destruct (Req_dec_T h (u n)). - * subst. right. intro H. destruct H. destruct H0. - exact (H1 eq_refl). - * left. split. - -- assumption. - -- split. - ++ assumption. - ++ intro H. subst. - exact (n0 eq_refl). - - subst. right. intro H. destruct H. pose proof (Rlt_asym (u n) (u n) H). contradiction. - - right. intro H. destruct H. apply Rlt_asym in H. contradiction. -Qed. - -Definition point_in_holed_interval (a b h : R) : R := - if Req_dec_T h (Rdiv (Rplus a b) (INR 2)) then (Rdiv (Rplus a h) (INR 2)) - else (Rdiv (Rplus a b) (INR 2)). - -Lemma middle_in_interval : forall a b : R, Rlt a b -> (a < (a + b) / INR 2 < b)%R. -Proof. - intros. - assert (twoNotZero: INR 2 <> 0%R). - { apply not_0_INR. intro abs. inversion abs. } - assert (twoAboveZero : (0 < / INR 2)%R). - { apply Rinv_0_lt_compat. apply lt_0_INR. apply le_n_S. apply le_S. apply le_n. } - assert (double : forall x : R, Rplus x x = ((INR 2) * x)%R) by - now intros x; rewrite S_INR, INR_1, Rmult_plus_distr_r, Rmult_1_l. - split. - - assert (a + a < a + b)%R. { apply (Rplus_lt_compat_l a a b). assumption. } - rewrite -> double in H0. apply (Rmult_lt_compat_l (/ (INR 2))) in H0. - + rewrite <- Rmult_assoc in H0. rewrite -> Rinv_l in H0. - * simpl in H0. - rewrite -> Rmult_1_l in H0. rewrite -> Rmult_comm in H0. assumption. - * assumption. - + assumption. - - assert (b + a < b + b)%R. { apply (Rplus_lt_compat_l b a b). assumption. } - rewrite -> Rplus_comm in H0. rewrite -> double in H0. - apply (Rmult_lt_compat_l (/ (INR 2))) in H0. - + rewrite <- Rmult_assoc in H0. rewrite -> Rinv_l in H0. - * simpl in H0. - rewrite -> Rmult_1_l in H0. rewrite -> Rmult_comm in H0. assumption. - * assumption. - + assumption. -Qed. - -Lemma point_in_holed_interval_works (a b h : R) : - Rlt a b -> let p := point_in_holed_interval a b h in - Rlt a p /\ Rlt p b /\ p <> h. -Proof. - intros. unfold point_in_holed_interval in p. - pose proof (middle_in_interval a b H). destruct H0. - destruct (Req_dec_T h ((a + b) / INR 2)). - - (* middle hole, p is quarter *) subst. - pose proof (middle_in_interval a ((a + b) / INR 2) H0). destruct H2. - split. - + assumption. - + split. - * apply (Rlt_trans p ((a + b) / INR 2)%R). - -- assumption. - -- assumption. - * apply Rlt_not_eq. assumption. - - split. - + assumption. - + split. - * assumption. - * intro abs. subst. contradiction. -Qed. - -(* An enumeration of R reaches any open interval of R, - extract the first two real numbers in it. *) -Definition first_in_holed_interval (u : nat -> R) (v : R -> nat) (a b h : R) - : enumeration R u v -> Rlt a b - -> { n : nat | in_holed_interval a b h u n - /\ forall k : nat, in_holed_interval a b h u k -> n <= k }. -Proof. - intros. apply epsilon_smallest. - - apply (in_holed_interval_dec a b h u). - - exists (v (point_in_holed_interval a b h)). - destruct H. unfold in_holed_interval. rewrite -> H. - apply point_in_holed_interval_works. assumption. -Defined. - -Lemma first_in_holed_interval_works (u : nat -> R) (v : R -> nat) (a b h : R) - (pen : enumeration R u v) (plow : Rlt a b) : - let (c,_) := first_in_holed_interval u v a b h pen plow in - forall x:R, Rlt a x -> Rlt x b -> x <> h -> x <> u c -> c < v x. -Proof. - destruct (first_in_holed_interval u v a b h pen plow) as [c [_ beyond]]. - destruct pen as [uv _]. intros x H H0 H1 x_uc. - assert (ihi : in_holed_interval a b h u (v x)). - { split. - - rewrite -> uv. assumption. - - rewrite -> uv. split; assumption. } - destruct (proj1 (Nat.lt_eq_cases _ _) (beyond (v x) ihi)) as [lcvx | ecvx]. - - exact lcvx. - - exfalso. apply x_uc. rewrite ecvx. rewrite -> uv. reflexivity. -Qed. - -Definition first_two_in_interval (u : nat -> R) (v : R -> nat) (a b : R) - (pen : enumeration R u v) (plow : Rlt a b) - : prod R R := - let (first_index, pr) := first_in_holed_interval u v a b b pen plow in - let (second_index, pr2) := first_in_holed_interval u v a b (u first_index) pen plow in - if Rle_dec (u first_index) (u second_index) then (u first_index, u second_index) - else (u second_index, u first_index). - -Lemma split_couple_eq : forall {a b c d : R}, (a,b) = (c,d) -> a = c /\ b = d. -Proof. - intros. injection H. intros. split. - - subst. reflexivity. - - subst. reflexivity. -Qed. - -Lemma first_two_in_interval_works (u : nat -> R) (v : R -> nat) (a b : R) - (pen : enumeration R u v) (plow : Rlt a b) : - let (c,d) := first_two_in_interval u v a b pen plow in - Rlt a c /\ Rlt c b - /\ Rlt a d /\ Rlt d b - /\ Rlt c d - /\ (forall x:R, Rlt a x -> Rlt x b -> x <> c -> x <> d -> v c < v x). -Proof. - intros. destruct (first_two_in_interval u v a b) as [r r0] eqn:ft. - unfold first_two_in_interval in ft. - pose proof (first_in_holed_interval_works u v a b b pen plow) as Wb. - destruct (first_in_holed_interval u v a b b pen plow) as [first_index pr]. - pose proof (first_in_holed_interval_works u v a b (u first_index) pen plow) as Wu. - destruct pr as [[H1 [H3 H4]] H2]. - destruct (first_in_holed_interval u v a b (u first_index) pen plow) - as [second_index pr2]. - destruct pr2 as [[H5 [H7 diff]] H6]. - destruct pen as [_ pen2]. - destruct (Rle_dec (u first_index) (u second_index)) as [lfs | nlfs]. - - destruct (split_couple_eq ft); subst; - repeat (split; [assumption | idtac]); split. - + destruct (Rle_lt_or_eq_dec _ _ lfs). - * assumption. - * exfalso. apply diff. symmetry. apply e. - + intros. rewrite -> pen2. - apply Wb; try assumption. apply Rlt_not_eq; assumption. - - destruct (split_couple_eq ft); subst; - repeat (split; [assumption | idtac]); split. - + apply Rnot_le_lt, nlfs. - + intros. rewrite -> pen2. apply Wu; assumption. -Qed. - -(* If u,v is an enumeration of R, this sequence of open intervals - tears the segment [0,1]. The recursive definition needs the proof that the - previous interval is ordered, hence the type. - - The first sequence is increasing, the second decreasing. - The first is below the second. - Therefore the first sequence has a limit, a least upper bound b, that u cannot reach, - which contradicts u (v b) = b. *) -Definition tearing_sequences (u : nat -> R) (v : R -> nat) - : (enumeration R u v) -> nat -> { ab : prod R R | Rlt (fst ab) (snd ab) }. -Proof. - intro pen. apply nat_rec. - - exists (INR 0, INR 1). simpl. apply Rlt_0_1. - - intros n [[a b] pr]. exists (first_two_in_interval u v a b pen pr). - pose proof (first_two_in_interval_works u v a b pen pr). - destruct (first_two_in_interval u v a b pen pr). apply H. -Defined. - -Lemma tearing_sequences_projsig (u : nat -> R) (v : R -> nat) (en : enumeration R u v) - (n : nat) - : let (I,pr) := tearing_sequences u v en n in - proj1_sig (tearing_sequences u v en (S n)) - = first_two_in_interval u v (fst I) (snd I) en pr. -Proof. - simpl. destruct (tearing_sequences u v en n) as [[a b] pr]. simpl. reflexivity. -Qed. - -(* The first tearing sequence in increasing, the second decreasing. - That means the tearing sequences are nested intervals. *) -Lemma tearing_sequences_inc_dec (u : nat -> R) (v : R -> nat) (pen : enumeration R u v) - : forall n : nat, - let I := proj1_sig (tearing_sequences u v pen n) in - let SI := proj1_sig (tearing_sequences u v pen (S n)) in - Rlt (fst I) (fst SI) /\ Rlt (snd SI) (snd I). -Proof. - intro n. simpl. destruct (tearing_sequences u v pen n) as [[a b] pr]. - simpl. pose proof (first_two_in_interval_works u v a b pen pr). - destruct (first_two_in_interval u v a b pen pr). - simpl. split. - - destruct H. assumption. - - destruct H as [H1 [H2 [H3 [H4 H5]]]]. assumption. -Qed. - -Lemma split_lt_succ : forall n m : nat, lt n (S m) -> lt n m \/ n = m. -Proof. - intros n m. generalize dependent n. induction m. - - intros. destruct n. - + right. reflexivity. - + exfalso. inversion H. inversion H1. - - intros. destruct n. - + left. unfold lt. apply -> Nat.succ_le_mono; apply Nat.le_0_l. - + apply Nat.lt_succ_lt_pred in H. simpl in H. specialize (IHm n H). destruct IHm. - * left. apply -> Nat.succ_lt_mono. assumption. - * subst. right. reflexivity. -Qed. - -Lemma increase_seq_transit (u : nat -> R) : - (forall n : nat, Rlt (u n) (u (S n))) -> (forall n m : nat, n < m -> Rlt (u n) (u m)). -Proof. - intros. induction m. - - intros. inversion H0. - - intros. destruct (split_lt_succ n m H0). - + apply (Rlt_trans (u n) (u m)). - * apply IHm. assumption. - * apply H. - + subst. apply H. -Qed. - -Lemma decrease_seq_transit (u : nat -> R) : - (forall n : nat, Rlt (u (S n)) (u n)) -> (forall n m : nat, n < m -> Rlt (u m) (u n)). -Proof. - intros. induction m. - - intros. inversion H0. - - intros. destruct (split_lt_succ n m H0). - + apply (Rlt_trans (u (S m)) (u m)). - * apply H. - * apply IHm. assumption. - + subst. apply H. -Qed. - -(* Either increase the first sequence, or decrease the second sequence, - until n = m and conclude by tearing_sequences_ordered *) -Lemma tearing_sequences_ordered_forall (u : nat -> R) (v : R -> nat) - (pen : enumeration R u v) : - forall n m : nat, let In := proj1_sig (tearing_sequences u v pen n) in - let Im := proj1_sig (tearing_sequences u v pen m) in - Rlt (fst In) (snd Im). -Proof. - intros. destruct (tearing_sequences u v pen n) eqn:tn. simpl in In. - destruct (tearing_sequences u v pen m) eqn:tm. simpl in Im. - destruct (n ?= m) eqn:order. - - apply Nat.compare_eq_iff in order. subst. rewrite -> tm in tn. - inversion tn. subst. assumption. - - apply Nat.compare_lt_iff in order. (* increase first sequence *) - apply (Rlt_trans (fst In) (fst Im)). - + remember (fun n => fst (proj1_sig (tearing_sequences u v pen n))) as fseq. - pose proof (increase_seq_transit fseq). - assert ((forall n : nat, (fseq n < fseq (S n))%R)). - { intro n0. rewrite -> Heqfseq. pose proof (tearing_sequences_inc_dec u v pen n0). - destruct (tearing_sequences u v pen (S n0)). simpl. - destruct ((tearing_sequences u v pen n0)). apply H0. } - specialize (H H0). rewrite -> Heqfseq in H. specialize (H n m order). - rewrite -> tn in H. rewrite -> tm in H. simpl in H. apply H. - + assumption. - - apply Nat.compare_gt_iff in order. (* decrease second sequence *) - apply (Rlt_trans (fst In) (snd In)). - + assumption. - + remember (fun n => snd (proj1_sig (tearing_sequences u v pen n))) as sseq. - pose proof (decrease_seq_transit sseq). - assert ((forall n : nat, (sseq (S n) < sseq n)%R)). - { intro n0. rewrite -> Heqsseq. pose proof (tearing_sequences_inc_dec u v pen n0). - destruct (tearing_sequences u v pen (S n0)). simpl. - destruct ((tearing_sequences u v pen n0)). apply H0. } - specialize (H H0). rewrite -> Heqsseq in H. specialize (H m n order). - rewrite -> tn in H. rewrite -> tm in H. apply H. -Qed. - -Definition tearing_elem_fst (u : nat -> R) (v : R -> nat) (pen : enumeration R u v) (x : R) - := exists n : nat, x = fst (proj1_sig (tearing_sequences u v pen n)). - -(* The limit of the first tearing sequence cannot be reached by u *) -Definition torn_number (u : nat -> R) (v : R -> nat) (pen : enumeration R u v) : - {m : R | is_lub (tearing_elem_fst u v pen) m}. -Proof. - intros. assert (bound (tearing_elem_fst u v pen)). - { exists (INR 1). intros x H0. destruct H0 as [n H0]. subst. left. - apply (tearing_sequences_ordered_forall u v pen n 0). } - apply (completeness (tearing_elem_fst u v pen) H). - exists (INR 0). exists 0. reflexivity. -Defined. - -Lemma torn_number_above_first_sequence (u : nat -> R) (v : R -> nat) (en : enumeration R u v) - : forall n : nat, Rlt (fst (proj1_sig (tearing_sequences u v en n))) - (proj1_sig (torn_number u v en)). -Proof. - intros. destruct (torn_number u v en) as [torn i]. simpl. - destruct (Rlt_le_dec (fst (proj1_sig (tearing_sequences u v en n))) torn). - - assumption. - - exfalso. - destruct i. (* Apply the first sequence once to make the inequality strict *) - assert (Rlt torn (fst (proj1_sig (tearing_sequences u v en (S n))))). - { apply (Rle_lt_trans torn (fst (proj1_sig (tearing_sequences u v en n)))). - - assumption. - apply tearing_sequences_inc_dec. } - clear r. specialize (H (fst (proj1_sig (tearing_sequences u v en (S n))))). - assert (tearing_elem_fst u v en (fst (proj1_sig (tearing_sequences u v en (S n))))). - { exists (S n). reflexivity. } - specialize (H H2). assert (Rlt torn torn). - { apply (Rlt_le_trans torn (fst (proj1_sig (tearing_sequences u v en (S n))))); - assumption. } - apply Rlt_irrefl in H3. contradiction. -Qed. - -(* The torn number is between both tearing sequences, so it could have been chosen - at each step. *) -Lemma torn_number_below_second_sequence (u : nat -> R) (v : R -> nat) - (en : enumeration R u v) : - forall n : nat, Rlt (proj1_sig (torn_number u v en)) - (snd (proj1_sig (tearing_sequences u v en n))). -Proof. - intros. destruct (torn_number u v en) as [torn i]. simpl. - destruct (Rlt_le_dec torn (snd (proj1_sig (tearing_sequences u v en n)))) - as [l|h]. - - assumption. - - exfalso. (* Apply the second sequence once to make the inequality strict *) - assert (Rlt (snd (proj1_sig (tearing_sequences u v en (S n)))) torn). - { apply (Rlt_le_trans (snd (proj1_sig (tearing_sequences u v en (S n)))) - (snd (proj1_sig (tearing_sequences u v en n))) torn). - - apply (tearing_sequences_inc_dec u v en n). - assumption. } - clear h. (* Then prove snd (tearing_sequences u v (S n)) is an upper bound of the first - sequence. It will yield the contradiction torn < torn. *) - assert (is_upper_bound (tearing_elem_fst u v en) - (snd (proj1_sig (tearing_sequences u v en (S n))))). - { intros x H0. destruct H0. subst. left. apply tearing_sequences_ordered_forall. } - destruct i. apply H2 in H0. - pose proof (Rle_lt_trans torn (snd (proj1_sig (tearing_sequences u v en (S n)))) torn H0 H). - apply Rlt_irrefl in H3. contradiction. -Qed. - -(* Here is the contradiction : the torn number's index is above a sequence - that tends to infinity *) -Lemma limit_index_above_all_indices (u : nat -> R) (v : R -> nat) (en : enumeration R u v) : - forall n : nat, v (fst (proj1_sig (tearing_sequences u v en (S n)))) - < v (proj1_sig (torn_number u v en)). -Proof. - intros. simpl. destruct (tearing_sequences u v en n) as [[r r0] H] eqn:tear. - (* The torn number was not chosen, so its index is above *) - simpl. - pose proof (first_two_in_interval_works u v r r0 en H). - destruct (first_two_in_interval u v r r0) eqn:ft. simpl. - assert (proj1_sig (tearing_sequences u v en (S n)) = (r1, r2)). - { simpl. rewrite -> tear. assumption. } - apply H0. - - pose proof (torn_number_above_first_sequence u v en n). rewrite -> tear in H2. assumption. - - pose proof (torn_number_below_second_sequence u v en n). rewrite -> tear in H2. assumption. - - pose proof (torn_number_above_first_sequence u v en (S n)). rewrite -> H1 in H2. simpl in H2. - intro H5. subst. apply Rlt_irrefl in H2. contradiction. - - pose proof (torn_number_below_second_sequence u v en (S n)). rewrite -> H1 in H2. simpl in H2. - intro H5. subst. apply Rlt_irrefl in H2. contradiction. -Qed. - -(* The indices increase because each time the minimum index is chosen *) -Lemma first_indices_increasing (u : nat -> R) (v : R -> nat) (H : enumeration R u v) - : forall n : nat, n <> 0 -> v (fst (proj1_sig (tearing_sequences u v H n))) - < v (fst (proj1_sig (tearing_sequences u v H (S n)))). -Proof. - intros. destruct n. - - contradiction. - - (* The n+1 and n+2 intervals are drawn from the n-th interval, which we note r r0 *) - destruct (tearing_sequences u v H n) as [[r r0] H1] eqn:In. simpl in H1. - (* Draw the n+1 interval *) - destruct (tearing_sequences u v H (S n)) as [[r1 r2] H2] eqn:ISn. simpl in H2. - (* Draw the n+2 interval *) - destruct (tearing_sequences u v H (S (S n))) as [[r3 r4] H3] eqn:ISSn. simpl in H3. - simpl. - - assert ((r1,r2) = first_two_in_interval u v r r0 H H1). - { simpl in ISn. rewrite -> In in ISn. inversion ISn. reflexivity. } - assert ((r3,r4) = first_two_in_interval u v r1 r2 H H2). - { pose proof (tearing_sequences_projsig u v H (S n)). rewrite -> ISn in H5. - rewrite -> ISSn in H5. apply H5. } - - pose proof (first_two_in_interval_works u v r r0 H H1) as firstChoiceWorks. - rewrite <- H4 in firstChoiceWorks. - destruct firstChoiceWorks as [fth [fth0 [fth1 [fth2 [fth3 fth4]]]]]. - - (* to prove the n+2 left bound in between r1 and r2 *) - pose proof (first_two_in_interval_works u v r1 r2 H H2). - rewrite <- H5 in H6. destruct H6 as [H6 [H7 [H8 [H9 [H10 H11]]]]]. apply fth4. - + apply (Rlt_trans r r1); assumption. - + apply (Rlt_trans r3 r2); assumption. - + intro abs. subst. apply Rlt_irrefl in H6. contradiction. - + intro abs. subst. apply Rlt_irrefl in H7. contradiction. -Qed. - -Theorem R_uncountable : forall u : nat -> R, ~Bijective u. -Proof. - intros u [v [H3 H4]]. pose proof (conj H4 H3) as H. - assert (forall n : nat, n + v (fst (proj1_sig (tearing_sequences u v H 1))) - <= v (fst (proj1_sig (tearing_sequences u v H (S n))))). - { induction n. - - simpl. apply Nat.le_refl. - - apply (Nat.le_trans (S n + v (fst (proj1_sig (tearing_sequences u v H 1)))) - (S (v (fst (proj1_sig (tearing_sequences u v H (S n))))))). - + simpl. apply -> Nat.succ_le_mono. assumption. - + apply first_indices_increasing. - intro H1. discriminate. } - assert (v (proj1_sig (torn_number u v H)) + v (fst (proj1_sig (tearing_sequences u v H 1))) - < v (proj1_sig (torn_number u v H))). - { pose proof (limit_index_above_all_indices u v H (v (proj1_sig (torn_number u v H)))). - specialize (H0 (v (proj1_sig (torn_number u v H)))). - apply (Nat.le_lt_trans (v (proj1_sig (torn_number u v H)) - + v (fst (proj1_sig (tearing_sequences u v H 1)))) - (v (fst (proj1_sig (tearing_sequences u v H (S (v (proj1_sig (torn_number u v H))))))))). - - assumption. - - assumption. } - assert (forall n m : nat, ~(n + m < n)). - { induction n. - - intros. intro H2. inversion H2. - - intro m. intro H2. simpl in H2. - apply Nat.lt_succ_lt_pred in H2. simpl in H2. apply IHn in H2. contradiction. } - apply H2 in H1. contradiction. -Qed. diff --git a/stdlib/theories/Reals/SeqProp.v b/stdlib/theories/Reals/SeqProp.v deleted file mode 100644 index 7a9c88047a73..000000000000 --- a/stdlib/theories/Reals/SeqProp.v +++ /dev/null @@ -1,1204 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* R) : Prop := - forall n:nat, Un (S n) <= Un n. -Definition opp_seq (Un:nat -> R) (n:nat) : R := - Un n. -Definition has_ub (Un:nat -> R) : Prop := bound (EUn Un). -Definition has_lb (Un:nat -> R) : Prop := bound (EUn (opp_seq Un)). - -(**********) -Lemma growing_cv : - forall Un:nat -> R, Un_growing Un -> has_ub Un -> { l:R | Un_cv Un l }. -Proof. - intros Un Hug Heub. - exists (proj1_sig (completeness (EUn Un) Heub (EUn_noempty Un))). - destruct (completeness _ Heub (EUn_noempty Un)) as (l, H). - now apply Un_cv_crit_lub. -Qed. - -Lemma decreasing_growing : - forall Un:nat -> R, Un_decreasing Un -> Un_growing (opp_seq Un). -Proof. - intro. - unfold Un_growing, opp_seq, Un_decreasing. - intros. - apply Ropp_le_contravar. - apply H. -Qed. - -Lemma decreasing_cv : - forall Un:nat -> R, Un_decreasing Un -> has_lb Un -> { l:R | Un_cv Un l }. -Proof. - intros. - cut ({ l:R | Un_cv (opp_seq Un) l } -> { l:R | Un_cv Un l }). - - intro X. - apply X. - apply growing_cv. - + apply decreasing_growing; assumption. - + exact H0. - - intros (x,p). - exists (- x). - unfold Un_cv in p. - unfold Rdist in p. - unfold opp_seq in p. - unfold Un_cv. - unfold Rdist. - intros. - elim (p eps H1); intros. - exists x0; intros. - assert (H4 := H2 n H3). - rewrite <- Rabs_Ropp. - replace (- (Un n - - x)) with (- Un n - x); [ assumption | ring ]. -Qed. - -(***********) -Lemma ub_to_lub : - forall Un:nat -> R, has_ub Un -> { l:R | is_lub (EUn Un) l }. -Proof. - intros. - unfold has_ub in H. - apply completeness. - - assumption. - - exists (Un 0%nat). - unfold EUn. - exists 0%nat; reflexivity. -Qed. - -(**********) -Lemma lb_to_glb : - forall Un:nat -> R, has_lb Un -> { l:R | is_lub (EUn (opp_seq Un)) l }. -Proof. - intros; unfold has_lb in H. - apply completeness. - - assumption. - - exists (- Un 0%nat). - exists 0%nat. - reflexivity. -Qed. - -Definition lub (Un:nat -> R) (pr:has_ub Un) : R := - let (a,_) := ub_to_lub Un pr in a. - -Definition glb (Un:nat -> R) (pr:has_lb Un) : R := - let (a,_) := lb_to_glb Un pr in - a. - -(* Compatibility with previous unappropriate terminology *) -Notation maj_sup := ub_to_lub (only parsing). -Notation min_inf := lb_to_glb (only parsing). -Notation majorant := lub (only parsing). -Notation minorant := glb (only parsing). - -Lemma maj_ss : - forall (Un:nat -> R) (k:nat), - has_ub Un -> has_ub (fun i:nat => Un (k + i)%nat). -Proof. - intros. - unfold has_ub in H. - unfold bound in H. - elim H; intros. - unfold is_upper_bound in H0. - unfold has_ub. - exists x. - unfold is_upper_bound. - intros. - apply H0. - elim H1; intros. - exists (k + x1)%nat; assumption. -Qed. - -Lemma min_ss : - forall (Un:nat -> R) (k:nat), - has_lb Un -> has_lb (fun i:nat => Un (k + i)%nat). -Proof. - intros. - unfold has_lb in H. - unfold bound in H. - elim H; intros. - unfold is_upper_bound in H0. - unfold has_lb. - exists x. - unfold is_upper_bound. - intros. - apply H0. - elim H1; intros. - exists (k + x1)%nat; assumption. -Qed. - -Definition sequence_ub (Un:nat -> R) (pr:has_ub Un) - (i:nat) : R := lub (fun k:nat => Un (i + k)%nat) (maj_ss Un i pr). - -Definition sequence_lb (Un:nat -> R) (pr:has_lb Un) - (i:nat) : R := glb (fun k:nat => Un (i + k)%nat) (min_ss Un i pr). - -(* Compatibility *) -Notation sequence_majorant := sequence_ub (only parsing). -Notation sequence_minorant := sequence_lb (only parsing). - -Lemma Wn_decreasing : - forall (Un:nat -> R) (pr:has_ub Un), Un_decreasing (sequence_ub Un pr). -Proof. - intros. - unfold Un_decreasing. - intro. - unfold sequence_ub. - pose proof (ub_to_lub (fun k:nat => Un (S n + k)%nat) (maj_ss Un (S n) pr)) as (x,(H1,H2)). - pose proof (ub_to_lub (fun k:nat => Un (n + k)%nat) (maj_ss Un n pr)) as (x0,(H3,H4)). - cut (lub (fun k:nat => Un (S n + k)%nat) (maj_ss Un (S n) pr) = x); - [ intro Maj1; rewrite Maj1 | idtac ]. - 1:cut (lub (fun k:nat => Un (n + k)%nat) (maj_ss Un n pr) = x0); - [ intro Maj2; rewrite Maj2 | idtac ]. - - apply H2. - unfold is_upper_bound. - intros x1 H5. - unfold is_upper_bound in H3. - apply H3. - elim H5; intros. - exists (1 + x2)%nat. - replace (n + (1 + x2))%nat with (S n + x2)%nat. - + assumption. - + replace (S n) with (1 + n)%nat; [ ring | ring ]. - - cut - (is_lub (EUn (fun k:nat => Un (n + k)%nat)) - (lub (fun k:nat => Un (n + k)%nat) (maj_ss Un n pr))). - + intros (H5,H6). - assert (H7 := H6 x0 H3). - assert - (H8 := H4 (lub (fun k:nat => Un (n + k)%nat) (maj_ss Un n pr)) H5). - apply Rle_antisym; assumption. - + unfold lub. - case (ub_to_lub (fun k:nat => Un (n + k)%nat) (maj_ss Un n pr)). - trivial. - - cut - (is_lub (EUn (fun k:nat => Un (S n + k)%nat)) - (lub (fun k:nat => Un (S n + k)%nat) (maj_ss Un (S n) pr))). - + intros (H5,H6). - assert (H7 := H6 x H1). - assert - (H8 := - H2 (lub (fun k:nat => Un (S n + k)%nat) (maj_ss Un (S n) pr)) H5). - apply Rle_antisym; assumption. - + unfold lub. - case (ub_to_lub (fun k:nat => Un (S n + k)%nat) (maj_ss Un (S n) pr)). - trivial. -Qed. - -Lemma Vn_growing : - forall (Un:nat -> R) (pr:has_lb Un), Un_growing (sequence_lb Un pr). -Proof. - intros. - unfold Un_growing. - intro. - unfold sequence_lb. - assert (H := lb_to_glb (fun k:nat => Un (S n + k)%nat) (min_ss Un (S n) pr)). - assert (H0 := lb_to_glb (fun k:nat => Un (n + k)%nat) (min_ss Un n pr)). - elim H; intros. - elim H0; intros. - cut (glb (fun k:nat => Un (S n + k)%nat) (min_ss Un (S n) pr) = - x); - [ intro Maj1; rewrite Maj1 | idtac ]. - 1:cut (glb (fun k:nat => Un (n + k)%nat) (min_ss Un n pr) = - x0); - [ intro Maj2; rewrite Maj2 | idtac ]. - - unfold is_lub in p. - unfold is_lub in p0. - elim p; intros. - apply Ropp_le_contravar. - apply H2. - elim p0; intros. - unfold is_upper_bound. - intros. - unfold is_upper_bound in H3. - apply H3. - elim H5; intros. - exists (1 + x2)%nat. - unfold opp_seq in H6. - unfold opp_seq. - replace (n + (1 + x2))%nat with (S n + x2)%nat. - + assumption. - + replace (S n) with (1 + n)%nat; [ ring | ring ]. - - cut - (is_lub (EUn (opp_seq (fun k:nat => Un (n + k)%nat))) - (- glb (fun k:nat => Un (n + k)%nat) (min_ss Un n pr))). - + intro. - unfold is_lub in p0; unfold is_lub in H1. - elim p0; intros; elim H1; intros. - assert (H6 := H5 x0 H2). - assert - (H7 := H3 (- glb (fun k:nat => Un (n + k)%nat) (min_ss Un n pr)) H4). - rewrite <- - (Ropp_involutive (glb (fun k:nat => Un (n + k)%nat) (min_ss Un n pr))) - . - apply Ropp_eq_compat; apply Rle_antisym; assumption. - + unfold glb. - case (lb_to_glb (fun k:nat => Un (n + k)%nat) (min_ss Un n pr)); simpl. - intro; rewrite Ropp_involutive. - trivial. - - cut - (is_lub (EUn (opp_seq (fun k:nat => Un (S n + k)%nat))) - (- glb (fun k:nat => Un (S n + k)%nat) (min_ss Un (S n) pr))). - + intro. - unfold is_lub in p; unfold is_lub in H1. - elim p; intros; elim H1; intros. - assert (H6 := H5 x H2). - assert - (H7 := - H3 (- glb (fun k:nat => Un (S n + k)%nat) (min_ss Un (S n) pr)) H4). - rewrite <- - (Ropp_involutive - (glb (fun k:nat => Un (S n + k)%nat) (min_ss Un (S n) pr))) - . - apply Ropp_eq_compat; apply Rle_antisym; assumption. - + unfold glb. - case (lb_to_glb (fun k:nat => Un (S n + k)%nat) (min_ss Un (S n) pr)); simpl. - intro; rewrite Ropp_involutive. - trivial. -Qed. - -(**********) -Lemma Vn_Un_Wn_order : - forall (Un:nat -> R) (pr1:has_ub Un) (pr2:has_lb Un) - (n:nat), sequence_lb Un pr2 n <= Un n <= sequence_ub Un pr1 n. -Proof. - intros. - split. - - unfold sequence_lb. - cut { l:R | is_lub (EUn (opp_seq (fun i:nat => Un (n + i)%nat))) l }. - + intro X. - elim X; intros. - replace (glb (fun k:nat => Un (n + k)%nat) (min_ss Un n pr2)) with (- x). - * unfold is_lub in p. - elim p; intros. - unfold is_upper_bound in H. - rewrite <- (Ropp_involutive (Un n)). - apply Ropp_le_contravar. - apply H. - exists 0%nat. - unfold opp_seq. - replace (n + 0)%nat with n; [ reflexivity | ring ]. - * cut - (is_lub (EUn (opp_seq (fun k:nat => Un (n + k)%nat))) - (- glb (fun k:nat => Un (n + k)%nat) (min_ss Un n pr2))). - -- intro. - unfold is_lub in p; unfold is_lub in H. - elim p; intros; elim H; intros. - assert (H4 := H3 x H0). - assert - (H5 := H1 (- glb (fun k:nat => Un (n + k)%nat) (min_ss Un n pr2)) H2). - rewrite <- - (Ropp_involutive (glb (fun k:nat => Un (n + k)%nat) (min_ss Un n pr2))) - . - apply Ropp_eq_compat; apply Rle_antisym; assumption. - -- unfold glb. - case (lb_to_glb (fun k:nat => Un (n + k)%nat) (min_ss Un n pr2)); simpl. - intro; rewrite Ropp_involutive. - trivial. - + apply lb_to_glb. - apply min_ss; assumption. - - unfold sequence_ub. - cut { l:R | is_lub (EUn (fun i:nat => Un (n + i)%nat)) l }. - + intro X. - elim X; intros. - replace (lub (fun k:nat => Un (n + k)%nat) (maj_ss Un n pr1)) with x. - * unfold is_lub in p. - elim p; intros. - unfold is_upper_bound in H. - apply H. - exists 0%nat. - replace (n + 0)%nat with n; [ reflexivity | ring ]. - * cut - (is_lub (EUn (fun k:nat => Un (n + k)%nat)) - (lub (fun k:nat => Un (n + k)%nat) (maj_ss Un n pr1))). - -- intro. - unfold is_lub in p; unfold is_lub in H. - elim p; intros; elim H; intros. - assert (H4 := H3 x H0). - assert - (H5 := H1 (lub (fun k:nat => Un (n + k)%nat) (maj_ss Un n pr1)) H2). - apply Rle_antisym; assumption. - -- unfold lub. - case (ub_to_lub (fun k:nat => Un (n + k)%nat) (maj_ss Un n pr1)). - intro; trivial. - + apply ub_to_lub. - apply maj_ss; assumption. -Qed. - -Lemma min_maj : - forall (Un:nat -> R) (pr1:has_ub Un) (pr2:has_lb Un), - has_ub (sequence_lb Un pr2). -Proof. - intros. - assert (H := Vn_Un_Wn_order Un pr1 pr2). - unfold has_ub. - unfold bound. - unfold has_ub in pr1. - unfold bound in pr1. - elim pr1; intros. - exists x. - unfold is_upper_bound. - intros. - unfold is_upper_bound in H0. - elim H1; intros. - rewrite H2. - apply Rle_trans with (Un x1). - - assert (H3 := H x1); elim H3; intros; assumption. - - apply H0. - exists x1; reflexivity. -Qed. - -Lemma maj_min : - forall (Un:nat -> R) (pr1:has_ub Un) (pr2:has_lb Un), - has_lb (sequence_ub Un pr1). -Proof. - intros. - assert (H := Vn_Un_Wn_order Un pr1 pr2). - unfold has_lb. - unfold bound. - unfold has_lb in pr2. - unfold bound in pr2. - elim pr2; intros. - exists x. - unfold is_upper_bound. - intros. - unfold is_upper_bound in H0. - elim H1; intros. - rewrite H2. - apply Rle_trans with (opp_seq Un x1). - - assert (H3 := H x1); elim H3; intros. - unfold opp_seq; apply Ropp_le_contravar. - assumption. - - apply H0. - exists x1; reflexivity. -Qed. - -(**********) -Lemma cauchy_maj : forall Un:nat -> R, Cauchy_crit Un -> has_ub Un. -Proof. - intros. - unfold has_ub. - apply cauchy_bound. - assumption. -Qed. - -(**********) -Lemma cauchy_opp : - forall Un:nat -> R, Cauchy_crit Un -> Cauchy_crit (opp_seq Un). -Proof. - intro. - unfold Cauchy_crit. - unfold Rdist. - intros. - elim (H eps H0); intros. - exists x; intros. - unfold opp_seq. - rewrite <- Rabs_Ropp. - replace (- (- Un n - - Un m)) with (Un n - Un m); - [ apply H1; assumption | ring ]. -Qed. - -(**********) -Lemma cauchy_min : forall Un:nat -> R, Cauchy_crit Un -> has_lb Un. -Proof. - intros. - unfold has_lb. - assert (H0 := cauchy_opp _ H). - apply cauchy_bound. - assumption. -Qed. - -(**********) -Lemma maj_cv : - forall (Un:nat -> R) (pr:Cauchy_crit Un), - { l:R | Un_cv (sequence_ub Un (cauchy_maj Un pr)) l }. -Proof. - intros. - apply decreasing_cv. - - apply Wn_decreasing. - - apply maj_min. - apply cauchy_min. - assumption. -Qed. - -(**********) -Lemma min_cv : - forall (Un:nat -> R) (pr:Cauchy_crit Un), - { l:R | Un_cv (sequence_lb Un (cauchy_min Un pr)) l }. -Proof. - intros. - apply growing_cv. - - apply Vn_growing. - - apply min_maj. - apply cauchy_maj. - assumption. -Qed. - -Lemma cond_eq : - forall x y:R, (forall eps:R, 0 < eps -> Rabs (x - y) < eps) -> x = y. -Proof. - intros. - destruct (total_order_T x y) as [[Hlt|Heq]|Hgt]. - - cut (0 < y - x). - + intro. - assert (H1 := H (y - x) H0). - rewrite <- Rabs_Ropp in H1. - cut (- (x - y) = y - x); [ intro; rewrite H2 in H1 | ring ]. - rewrite Rabs_right in H1. - * elim (Rlt_irrefl _ H1). - * left; assumption. - + apply Rplus_lt_reg_l with x. - rewrite Rplus_0_r; replace (x + (y - x)) with y; [ assumption | ring ]. - - assumption. - - cut (0 < x - y). - + intro. - assert (H1 := H (x - y) H0). - rewrite Rabs_right in H1. - * elim (Rlt_irrefl _ H1). - * left; assumption. - + apply Rplus_lt_reg_l with y. - rewrite Rplus_0_r; replace (y + (x - y)) with x; [ assumption | ring ]. -Qed. - -Lemma not_Rlt : forall r1 r2:R, ~ r1 < r2 -> r1 >= r2. -Proof. - intros r1 r2; generalize (Rtotal_order r1 r2); unfold Rge. - tauto. -Qed. - -(**********) -Lemma approx_maj : - forall (Un:nat -> R) (pr:has_ub Un) (eps:R), - 0 < eps -> exists k : nat, Rabs (lub Un pr - Un k) < eps. -Proof. - intros Un pr. - pose (Vn := fix aux n := match n with S n' => if Rle_lt_dec (aux n') (Un n) then Un n else aux n' | O => Un O end). - pose (In := fix aux n := match n with S n' => if Rle_lt_dec (Vn n) (Un n) then n else aux n' | O => O end). - - assert (VUI: forall n, Vn n = Un (In n)). { - induction n. - - easy. - - simpl. - destruct (Rle_lt_dec (Vn n) (Un (S n))) as [H1|H1]. - + destruct (Rle_lt_dec (Un (S n)) (Un (S n))) as [H2|H2]. - * easy. - * elim (Rlt_irrefl _ H2). - + destruct (Rle_lt_dec (Vn n) (Un (S n))) as [H2|H2]. - * elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H2 H1)). - * exact IHn. - } - - assert (HubV : has_ub Vn). { - destruct pr as (ub, Hub). - exists ub. - intros x (n, Hn). - rewrite Hn, VUI. - apply Hub. - now exists (In n). - } - - assert (HgrV : Un_growing Vn). { - intros n. - induction n. - - simpl. - destruct (Rle_lt_dec (Un O) (Un 1%nat)) as [H|_]. - + exact H. - + apply Rle_refl. - - simpl. - destruct (Rle_lt_dec (Vn n) (Un (S n))) as [H1|H1]. - + destruct (Rle_lt_dec (Un (S n)) (Un (S (S n)))) as [H2|H2]. - * exact H2. - * apply Rle_refl. - + destruct (Rle_lt_dec (Vn n) (Un (S (S n)))) as [H2|H2]. - * exact H2. - * apply Rle_refl. - } - - destruct (ub_to_lub Vn HubV) as (l, Hl). - unfold lub. - destruct (ub_to_lub Un pr) as (l', Hl'). - replace l' with l. - - intros eps Heps. - destruct (Un_cv_crit_lub Vn HgrV l Hl eps Heps) as (n, Hn). - exists (In n). - rewrite <- VUI. - rewrite Rabs_minus_sym. - apply Hn. - apply Nat.le_refl. - - - apply Rle_antisym. - + apply Hl. - intros n (k, Hk). - rewrite Hk, VUI. - apply Hl'. - now exists (In k). - + apply Hl'. - intros n (k, Hk). - rewrite Hk. - apply Rle_trans with (Vn k). - * clear. - induction k. - -- apply Rle_refl. - -- simpl. - destruct (Rle_lt_dec (Vn k) (Un (S k))) as [H|H]. - ++ apply Rle_refl. - ++ now apply Rlt_le. - * apply Hl. - now exists k. -Qed. - -(**********) -Lemma approx_min : - forall (Un:nat -> R) (pr:has_lb Un) (eps:R), - 0 < eps -> exists k : nat, Rabs (glb Un pr - Un k) < eps. -Proof. - intros Un pr. - unfold glb. - destruct lb_to_glb as (lb, Hlb). - intros eps Heps. - destruct (approx_maj _ pr eps Heps) as (n, Hn). - exists n. - unfold Rminus. - rewrite <- Ropp_plus_distr, Rabs_Ropp. - replace lb with (lub (opp_seq Un) pr). - - now rewrite <- (Ropp_involutive (Un n)). - - unfold lub. - destruct ub_to_lub as (ub, Hub). - apply Rle_antisym. - + apply Hub. - apply Hlb. - + apply Hlb. - apply Hub. -Qed. - -(** Unicity of limit for convergent sequences *) -Lemma UL_sequence : - forall (Un:nat -> R) (l1 l2:R), Un_cv Un l1 -> Un_cv Un l2 -> l1 = l2. -Proof. - intros Un l1 l2; unfold Un_cv; unfold Rdist; intros. - apply cond_eq. - intros; cut (0 < eps / 2); - [ intro - | unfold Rdiv; apply Rmult_lt_0_compat; - [ assumption | apply Rinv_0_lt_compat; prove_sup0 ] ]. - elim (H (eps / 2) H2); intros. - elim (H0 (eps / 2) H2); intros. - set (N := max x x0). - apply Rle_lt_trans with (Rabs (l1 - Un N) + Rabs (Un N - l2)). - - replace (l1 - l2) with (l1 - Un N + (Un N - l2)); - [ apply Rabs_triang | ring ]. - - rewrite <-(Rplus_half_diag eps); apply Rplus_lt_compat. - + rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; apply H3; - unfold ge, N; apply Nat.le_max_l. - + apply H4; unfold ge, N; apply Nat.le_max_r. -Qed. - -(**********) -Lemma CV_plus : - forall (An Bn:nat -> R) (l1 l2:R), - Un_cv An l1 -> Un_cv Bn l2 -> Un_cv (fun i:nat => An i + Bn i) (l1 + l2). -Proof. - unfold Un_cv; unfold Rdist; intros. - cut (0 < eps / 2); - [ intro - | unfold Rdiv; apply Rmult_lt_0_compat; - [ assumption | apply Rinv_0_lt_compat; prove_sup0 ] ]. - elim (H (eps / 2) H2); intros. - elim (H0 (eps / 2) H2); intros. - set (N := max x x0). - exists N; intros. - replace (An n + Bn n - (l1 + l2)) with (An n - l1 + (Bn n - l2)); - [ idtac | ring ]. - apply Rle_lt_trans with (Rabs (An n - l1) + Rabs (Bn n - l2)). - - apply Rabs_triang. - - rewrite <-(Rplus_half_diag eps); apply Rplus_lt_compat. - + apply H3; unfold ge; apply Nat.le_trans with N; - [ unfold N; apply Nat.le_max_l | assumption ]. - + apply H4; unfold ge; apply Nat.le_trans with N; - [ unfold N; apply Nat.le_max_r | assumption ]. -Qed. - -(**********) -Lemma cv_cvabs : - forall (Un:nat -> R) (l:R), - Un_cv Un l -> Un_cv (fun i:nat => Rabs (Un i)) (Rabs l). -Proof. - unfold Un_cv; unfold Rdist; intros. - elim (H eps H0); intros. - exists x; intros. - apply Rle_lt_trans with (Rabs (Un n - l)). - - apply Rabs_triang_inv2. - - apply H1; assumption. -Qed. - -(**********) -Lemma CV_Cauchy : - forall Un:nat -> R, { l:R | Un_cv Un l } -> Cauchy_crit Un. -Proof. - intros Un X; elim X; intros. - unfold Cauchy_crit; intros. - unfold Un_cv in p; unfold Rdist in p. - cut (0 < eps / 2); - [ intro - | unfold Rdiv; apply Rmult_lt_0_compat; - [ assumption | apply Rinv_0_lt_compat; prove_sup0 ] ]. - elim (p (eps / 2) H0); intros. - exists x0; intros. - unfold Rdist; - apply Rle_lt_trans with (Rabs (Un n - x) + Rabs (x - Un m)). - - replace (Un n - Un m) with (Un n - x + (x - Un m)); - [ apply Rabs_triang | ring ]. - - rewrite <-(Rplus_half_diag eps); apply Rplus_lt_compat. - + apply H1; assumption. - + rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; apply H1; assumption. -Qed. - -(**********) -Lemma maj_by_pos : - forall Un:nat -> R, - { l:R | Un_cv Un l } -> - exists l : R, 0 < l /\ (forall n:nat, Rabs (Un n) <= l). -Proof. - intros Un X; elim X; intros. - cut { l:R | Un_cv (fun k:nat => Rabs (Un k)) l }. - - intro X0. - assert (H := CV_Cauchy (fun k:nat => Rabs (Un k)) X0). - assert (H0 := cauchy_bound (fun k:nat => Rabs (Un k)) H). - elim H0; intros. - exists (x0 + 1). - cut (0 <= x0). - + intro. - split. - * apply Rplus_le_lt_0_compat; [ assumption | apply Rlt_0_1 ]. - * intros. - apply Rle_trans with x0. - -- unfold is_upper_bound in H1. - apply H1. - exists n; reflexivity. - -- pattern x0 at 1; rewrite <- Rplus_0_r; apply Rplus_le_compat_l; left; - apply Rlt_0_1. - + apply Rle_trans with (Rabs (Un 0%nat)). - * apply Rabs_pos. - * unfold is_upper_bound in H1. - apply H1. - exists 0%nat; reflexivity. - - exists (Rabs x). - apply cv_cvabs; assumption. -Qed. - -(**********) -Lemma CV_mult : - forall (An Bn:nat -> R) (l1 l2:R), - Un_cv An l1 -> Un_cv Bn l2 -> Un_cv (fun i:nat => An i * Bn i) (l1 * l2). -Proof. - intros. - assert (X:{ l:R | Un_cv An l }) by (exists l1; assumption). - assert (H1 := maj_by_pos An X). - elim H1; intros M H2. - elim H2; intros. - unfold Un_cv; unfold Rdist; intros. - cut (0 < eps / (2 * M)). - - intro. - case (Req_dec l2 0); intro. - + unfold Un_cv in H0; unfold Rdist in H0. - elim (H0 (eps / (2 * M)) H6); intros. - exists x; intros. - apply Rle_lt_trans with - (Rabs (An n * Bn n - An n * l2) + Rabs (An n * l2 - l1 * l2)). - { replace (An n * Bn n - l1 * l2) with - (An n * Bn n - An n * l2 + (An n * l2 - l1 * l2)); - [ apply Rabs_triang | ring ]. } - replace (Rabs (An n * Bn n - An n * l2)) with - (Rabs (An n) * Rabs (Bn n - l2)). - { replace (Rabs (An n * l2 - l1 * l2)) with 0. - - rewrite Rplus_0_r. - apply Rle_lt_trans with (M * Rabs (Bn n - l2)). - + do 2 rewrite <- (Rmult_comm (Rabs (Bn n - l2))). - apply Rmult_le_compat_l. - * apply Rabs_pos. - * apply H4. - + apply Rmult_lt_reg_l with (/ M). - { apply Rinv_0_lt_compat; apply H3. } - rewrite <- Rmult_assoc; rewrite Rinv_l. - * rewrite Rmult_1_l; rewrite (Rmult_comm (/ M)). - apply Rlt_trans with (eps / (2 * M)). - { apply H8; assumption. } - unfold Rdiv; rewrite Rinv_mult. - apply Rmult_lt_reg_l with 2. - { prove_sup0. } - replace (2 * (eps * (/ 2 * / M))) with (2 * / 2 * (eps * / M)); - [ idtac | ring ]. - rewrite Rinv_r. - -- rewrite Rmult_1_l; rewrite <-Rplus_diag. - pattern (eps * / M) at 1; rewrite <- Rplus_0_r. - apply Rplus_lt_compat_l; apply Rmult_lt_0_compat; - [ assumption | apply Rinv_0_lt_compat; assumption ]. - -- discrR. - * red; intro; rewrite H10 in H3; elim (Rlt_irrefl _ H3). - - rewrite H7; do 2 rewrite Rmult_0_r; unfold Rminus; - rewrite Rplus_opp_r; rewrite Rabs_R0; reflexivity. - } - replace (An n * Bn n - An n * l2) with (An n * (Bn n - l2)) by ring. - symmetry ; apply Rabs_mult. - + assert (0 < eps / (2 * Rabs l2)). { - unfold Rdiv; apply Rmult_lt_0_compat. - { assumption. } - apply Rinv_0_lt_compat; apply Rmult_lt_0_compat; - [ prove_sup0 | apply Rabs_pos_lt; assumption ]. - } - unfold Un_cv in H; unfold Rdist in H; unfold Un_cv in H0; - unfold Rdist in H0. - elim (H (eps / (2 * Rabs l2)) H8); intros N1 H9. - elim (H0 (eps / (2 * M)) H6); intros N2 H10. - set (N := max N1 N2). - exists N; intros. - apply Rle_lt_trans with - (Rabs (An n * Bn n - An n * l2) + Rabs (An n * l2 - l1 * l2)). - { replace (An n * Bn n - l1 * l2) with - (An n * Bn n - An n * l2 + (An n * l2 - l1 * l2)) by ring; - apply Rabs_triang. } - replace (Rabs (An n * Bn n - An n * l2)) with - (Rabs (An n) * Rabs (Bn n - l2)). - 1:replace (Rabs (An n * l2 - l1 * l2)) with (Rabs l2 * Rabs (An n - l1)). - * rewrite <-(Rplus_half_diag eps); apply Rplus_lt_compat. - -- apply Rle_lt_trans with (M * Rabs (Bn n - l2)). - { do 2 rewrite <- (Rmult_comm (Rabs (Bn n - l2))). - apply Rmult_le_compat_l. - - apply Rabs_pos. - - apply H4. } - apply Rmult_lt_reg_l with (/ M). - { apply Rinv_0_lt_compat; apply H3. } - rewrite <- Rmult_assoc; rewrite Rinv_l. - ++ rewrite Rmult_1_l; rewrite (Rmult_comm (/ M)). - apply Rlt_le_trans with (eps / (2 * M)). - ** apply H10. - unfold ge; apply Nat.le_trans with N. - { unfold N; apply Nat.le_max_r. } - assumption. - ** unfold Rdiv; rewrite Rinv_mult. - right; ring. - ++ red; intro; rewrite H12 in H3; elim (Rlt_irrefl _ H3). - -- apply Rmult_lt_reg_l with (/ Rabs l2). - { apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption. } - rewrite <- Rmult_assoc; rewrite Rinv_l. - ++ rewrite Rmult_1_l; apply Rlt_le_trans with (eps / (2 * Rabs l2)). - ** apply H9. - unfold ge; apply Nat.le_trans with N. - { unfold N; apply Nat.le_max_l. } - assumption. - ** unfold Rdiv; right; rewrite Rinv_mult. - ring. - ++ apply Rabs_no_R0; assumption. - * replace (An n * l2 - l1 * l2) with (l2 * (An n - l1)); - [ symmetry ; apply Rabs_mult | ring ]. - * replace (An n * Bn n - An n * l2) with (An n * (Bn n - l2)); - [ symmetry ; apply Rabs_mult | ring ]. - - unfold Rdiv; apply Rmult_lt_0_compat; - [ assumption - | apply Rinv_0_lt_compat; apply Rmult_lt_0_compat; - [ prove_sup0 | assumption ] ]. -Qed. - -Lemma tech9 : - forall Un:nat -> R, - Un_growing Un -> forall m n:nat, (m <= n)%nat -> Un m <= Un n. -Proof. - intros; unfold Un_growing in H. - induction n as [| n Hrecn]. - - induction m as [| m Hrecm]. - + right; reflexivity. - + elim (Nat.nle_succ_0 _ H0). - - cut ((m <= n)%nat \/ m = S n). - + intro; elim H1; intro. - * apply Rle_trans with (Un n). - -- apply Hrecn; assumption. - -- apply H. - * rewrite H2; right; reflexivity. - + inversion H0. - * right; reflexivity. - * left; assumption. -Qed. - -Lemma tech13 : - forall (An:nat -> R) (k:R), - 0 <= k < 1 -> - Un_cv (fun n:nat => Rabs (An (S n) / An n)) k -> - exists k0 : R, - k < k0 < 1 /\ - (exists N : nat, - (forall n:nat, (N <= n)%nat -> Rabs (An (S n) / An n) < k0)). -Proof. - intros; exists (k + (1 - k) / 2). - split. - 1:split. - - pattern k at 1; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l. - unfold Rdiv; apply Rmult_lt_0_compat. - + apply Rplus_lt_reg_l with k; rewrite Rplus_0_r; replace (k + (1 - k)) with 1; - [ elim H; intros; assumption | ring ]. - + apply Rinv_0_lt_compat; prove_sup0. - - apply Rmult_lt_reg_l with 2. - + prove_sup0. - + unfold Rdiv; rewrite Rmult_1_r; rewrite Rmult_plus_distr_l; - pattern 2 at 1; rewrite Rmult_comm; rewrite Rmult_assoc; - rewrite Rinv_l; [ idtac | discrR ]; rewrite Rmult_1_r; - replace (2 * k + (1 - k)) with (1 + k); [ idtac | ring ]. - elim H; intros. - apply Rplus_lt_compat_l; assumption. - - unfold Un_cv in H0; cut (0 < (1 - k) / 2). - + intro; elim (H0 ((1 - k) / 2) H1); intros. - exists x; intros. - assert (H4 := H2 n H3). - unfold Rdist in H4; rewrite <- Rabs_Rabsolu; - replace (Rabs (An (S n) / An n)) with (Rabs (An (S n) / An n) - k + k); - [ idtac | ring ]; - apply Rle_lt_trans with (Rabs (Rabs (An (S n) / An n) - k) + Rabs k). - * apply Rabs_triang. - * rewrite (Rabs_right k). - -- apply Rplus_lt_reg_l with (- k); rewrite <- (Rplus_comm k); - repeat rewrite <- Rplus_assoc; rewrite Rplus_opp_l; - repeat rewrite Rplus_0_l; apply H4. - -- apply Rle_ge; elim H; intros; assumption. - + unfold Rdiv; apply Rmult_lt_0_compat. - * apply Rplus_lt_reg_l with k; rewrite Rplus_0_r; elim H; intros; - replace (k + (1 - k)) with 1; [ assumption | ring ]. - * apply Rinv_0_lt_compat; prove_sup0. -Qed. - -(**********) -Lemma growing_ineq : - forall (Un:nat -> R) (l:R), - Un_growing Un -> Un_cv Un l -> forall n:nat, Un n <= l. -Proof. - intros; destruct (total_order_T (Un n) l) as [[Hlt|Heq]|Hgt]. - - left; assumption. - - right; assumption. - - cut (0 < Un n - l). - + intro; unfold Un_cv in H0; unfold Rdist in H0. - elim (H0 (Un n - l) H1); intros N1 H2. - set (N := max n N1). - cut (Un n - l <= Un N - l). - * intro; cut (Un N - l < Un n - l). - -- intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H3 H4)). - -- apply Rle_lt_trans with (Rabs (Un N - l)). - ++ apply RRle_abs. - ++ apply H2. - unfold ge, N; apply Nat.le_max_r. - * unfold Rminus; do 2 rewrite <- (Rplus_comm (- l)); - apply Rplus_le_compat_l. - apply tech9. - -- assumption. - -- unfold N; apply Nat.le_max_l. - + apply Rplus_lt_reg_l with l. - rewrite Rplus_0_r. - replace (l + (Un n - l)) with (Un n); [ assumption | ring ]. -Qed. - -(** Un->l => (-Un) -> (-l) *) -Lemma CV_opp : - forall (An:nat -> R) (l:R), Un_cv An l -> Un_cv (opp_seq An) (- l). -Proof. - intros An l. - unfold Un_cv; unfold Rdist; intros. - elim (H eps H0); intros. - exists x; intros. - unfold opp_seq; replace (- An n - - l) with (- (An n - l)); - [ rewrite Rabs_Ropp | ring ]. - apply H1; assumption. -Qed. - -(**********) -Lemma decreasing_ineq : - forall (Un:nat -> R) (l:R), - Un_decreasing Un -> Un_cv Un l -> forall n:nat, l <= Un n. -Proof. - intros. - assert (H1 := decreasing_growing _ H). - assert (H2 := CV_opp _ _ H0). - assert (H3 := growing_ineq _ _ H1 H2). - apply Ropp_le_cancel. - unfold opp_seq in H3; apply H3. -Qed. - -(**********) -Lemma CV_minus : - forall (An Bn:nat -> R) (l1 l2:R), - Un_cv An l1 -> Un_cv Bn l2 -> Un_cv (fun i:nat => An i - Bn i) (l1 - l2). -Proof. - intros. - replace (fun i:nat => An i - Bn i) with (fun i:nat => An i + opp_seq Bn i). - - unfold Rminus; apply CV_plus. - + assumption. - + apply CV_opp; assumption. - - unfold Rminus, opp_seq; reflexivity. -Qed. - -(** Un -> +oo *) -Definition cv_infty (Un:nat -> R) : Prop := - forall M:R, exists N : nat, (forall n:nat, (N <= n)%nat -> M < Un n). - -(** Un -> +oo => /Un -> O *) -Lemma cv_infty_cv_0 : - forall Un:nat -> R, cv_infty Un -> Un_cv (fun n:nat => / Un n) 0. -Proof. - unfold cv_infty, Un_cv; unfold Rdist; intros Un H0 eps H1. - elim (H0 (/ eps)); intros N0 H2. - exists N0; intros n H3. - unfold Rminus; rewrite Ropp_0; rewrite Rplus_0_r; - rewrite Rabs_inv. - destruct (Req_dec (Un n) 0) as [->|H]. - { now rewrite Rabs_R0, Rinv_0. } - apply Rmult_lt_reg_l with (Rabs (Un n)). - - apply Rabs_pos_lt; apply H. - - rewrite Rinv_r. - + apply Rmult_lt_reg_l with (/ eps). - * apply Rinv_0_lt_compat; assumption. - * rewrite Rmult_1_r; rewrite (Rmult_comm (/ eps)); rewrite Rmult_assoc; - rewrite Rinv_r. - -- rewrite Rmult_1_r; apply Rlt_le_trans with (Un n). - ++ apply H2; assumption. - ++ apply RRle_abs. - -- red; intro; rewrite H4 in H1; elim (Rlt_irrefl _ H1). - + apply Rabs_no_R0; apply H. -Qed. - -Lemma cv_infty_cv_R0_depr : - forall Un:nat -> R, - (forall n:nat, Un n <> 0) -> cv_infty Un -> Un_cv (fun n:nat => / Un n) 0. -Proof. - intros Un _. - apply cv_infty_cv_0. -Qed. - -#[deprecated(since="8.16",note="Use cv_infty_cv_0.")] -Notation cv_infty_cv_R0 := cv_infty_cv_R0_depr. - -(**********) -Lemma decreasing_prop : - forall (Un:nat -> R) (m n:nat), - Un_decreasing Un -> (m <= n)%nat -> Un n <= Un m. -Proof. - unfold Un_decreasing; intros. - induction n as [| n Hrecn]. - - induction m as [| m Hrecm]. - + right; reflexivity. - + elim (Nat.nle_succ_0 _ H0). - - cut ((m <= n)%nat \/ m = S n). - + intro; elim H1; intro. - * apply Rle_trans with (Un n). - -- apply H. - -- apply Hrecn; assumption. - * rewrite H2; right; reflexivity. - + inversion H0; [ right; reflexivity | left; assumption ]. -Qed. - -(** |x|^n/n! -> 0 *) -Lemma cv_speed_pow_fact : - forall x:R, Un_cv (fun n:nat => x ^ n / INR (fact n)) 0. -Proof. - intro; - cut - (Un_cv (fun n:nat => Rabs x ^ n / INR (fact n)) 0 -> - Un_cv (fun n:nat => x ^ n / INR (fact n)) 0). - { intro; apply H. - unfold Un_cv; unfold Rdist; intros; case (Req_dec x 0); - intro. - - exists 1%nat; intros. - rewrite H1; unfold Rminus; rewrite Ropp_0; rewrite Rplus_0_r; - rewrite Rabs_R0; rewrite pow_ne_zero; - [ unfold Rdiv; rewrite Rmult_0_l; rewrite Rabs_R0; assumption - | red; intro; rewrite H3 in H2; elim (Nat.nle_succ_diag_l _ H2) ]. - - assert (H2 := Rabs_pos_lt x H1); set (M := up (Rabs x)); cut (0 <= M)%Z. - + intro; elim (IZN M H3); intros M_nat H4. - set (Un := fun n:nat => Rabs x ^ (M_nat + n) / INR (fact (M_nat + n))). - cut (Un_cv Un 0); unfold Un_cv; unfold Rdist; intros. - * elim (H5 eps H0); intros N H6. - exists (M_nat + N)%nat; intros; - cut (exists p : nat, (p >= N)%nat /\ n = (M_nat + p)%nat). - { intro; elim H8; intros p H9. - elim H9; intros; rewrite H11; unfold Un in H6; apply H6; assumption. } - exists (n - M_nat)%nat. - split. - -- unfold ge; apply (fun p n m:nat => Nat.add_le_mono_l n m p) with M_nat; - rewrite (Nat.add_comm _ (n - M_nat)), Nat.sub_add. - { assumption. } - apply Nat.le_trans with (M_nat + N)%nat. - ++ apply Nat.le_add_r. - ++ assumption. - -- rewrite Nat.add_comm, Nat.sub_add; [reflexivity | ]; - apply Nat.le_trans with (M_nat + N)%nat; [ apply Nat.le_add_r | assumption ]. - * set (Vn := fun n:nat => Rabs x * (Un 0%nat / INR (S n))). - cut (1 <= M_nat)%nat. - 1:intro; cut (forall n:nat, 0 < Un n). - 1:intro; cut (Un_decreasing Un). - 1:intro; cut (forall n:nat, Un (S n) <= Vn n). - 1:intro; cut (Un_cv Vn 0). - -- unfold Un_cv; unfold Rdist; intros. - elim (H10 eps0 H5); intros N1 H11. - exists (S N1); intros. - cut (forall n:nat, 0 < Vn n). - { intro; apply Rle_lt_trans with (Rabs (Vn (pred n) - 0)). - 1:repeat rewrite Rabs_right. - - unfold Rminus; rewrite Ropp_0; do 2 rewrite Rplus_0_r; - replace n with (S (pred n)). - + apply H9. - + inversion H12; simpl; reflexivity. - - apply Rle_ge; unfold Rminus; rewrite Ropp_0; rewrite Rplus_0_r; left; - apply H13. - - apply Rle_ge; unfold Rminus; rewrite Ropp_0; rewrite Rplus_0_r; left; - apply H7. - - apply H11; unfold ge; apply le_S_n; replace (S (pred n)) with n; - [ unfold ge in H12; exact H12 | inversion H12; simpl; reflexivity ]. - } - intro; apply Rlt_le_trans with (Un (S n0)); [ apply H7 | apply H9 ]. - -- cut (cv_infty (fun n:nat => INR (S n))). - 1:intro; cut (Un_cv (fun n:nat => / INR (S n)) 0). - 1:unfold Un_cv, Rdist; intros; unfold Vn. - 1:cut (0 < eps1 / (Rabs x * Un 0%nat)). - ++ intro; elim (H11 _ H13); intros N H14. - exists N; intros; - replace (Rabs x * (Un 0%nat / INR (S n)) - 0) with - (Rabs x * Un 0%nat * (/ INR (S n) - 0)); - [ idtac | unfold Rdiv; ring ]. - rewrite Rabs_mult; apply Rmult_lt_reg_l with (/ Rabs (Rabs x * Un 0%nat)). - ** apply Rinv_0_lt_compat; apply Rabs_pos_lt. - apply prod_neq_R0. - { apply Rabs_no_R0; assumption. } - assert (H16 := H7 0%nat); red; intro; rewrite H17 in H16; - elim (Rlt_irrefl _ H16). - ** rewrite <- Rmult_assoc; rewrite Rinv_l. - { rewrite Rmult_1_l. - replace (/ Rabs (Rabs x * Un 0%nat) * eps1) with (eps1 / (Rabs x * Un 0%nat)). - - apply H14; assumption. - - unfold Rdiv; rewrite (Rabs_right (Rabs x * Un 0%nat)). - + apply Rmult_comm. - + apply Rle_ge; apply Rmult_le_pos. - * apply Rabs_pos. - * left; apply H7. - } - apply Rabs_no_R0. - apply prod_neq_R0; - [ apply Rabs_no_R0; assumption - | assert (H16 := H7 0%nat); red; intro; rewrite H17 in H16; - elim (Rlt_irrefl _ H16) ]. - ++ unfold Rdiv; apply Rmult_lt_0_compat. - { assumption. } - apply Rinv_0_lt_compat; apply Rmult_lt_0_compat. - { apply Rabs_pos_lt; assumption. } - apply H7. - ++ now apply (cv_infty_cv_0 (fun n:nat => INR (S n))). - ++ unfold cv_infty; intro; - destruct (total_order_T M0 0) as [[Hlt|Heq]|Hgt]. - ** exists 0%nat; intros. - apply Rlt_trans with 0; [ assumption | apply lt_INR_0; apply Nat.lt_0_succ ]. - ** exists 0%nat; intros; rewrite Heq; apply lt_INR_0; apply Nat.lt_0_succ. - ** set (M0_z := up M0). - assert (H10 := archimed M0). - cut (0 <= M0_z)%Z. - { intro; elim (IZN _ H11); intros M0_nat H12. - exists M0_nat; intros. - apply Rlt_le_trans with (IZR M0_z). - - elim H10; intros; assumption. - - rewrite H12; rewrite <- INR_IZR_INZ; apply le_INR. - apply Nat.le_trans with n; [ assumption | apply Nat.le_succ_diag_r ]. - } - apply le_IZR; left; simpl; unfold M0_z; - apply Rlt_trans with M0; [ assumption | elim H10; intros; assumption ]. - -- intro; apply Rle_trans with (Rabs x * Un n * / INR (S n)). - ++ unfold Un; replace (M_nat + S n)%nat with (M_nat + n + 1)%nat. - ** { rewrite pow_add; replace (Rabs x ^ 1) with (Rabs x); - [ idtac | simpl; ring ]. - unfold Rdiv; rewrite <- (Rmult_comm (Rabs x)); - repeat rewrite Rmult_assoc; repeat apply Rmult_le_compat_l. - - apply Rabs_pos. - - left; apply pow_lt; assumption. - - replace (M_nat + n + 1)%nat with (S (M_nat + n)). - + rewrite fact_simpl; rewrite Nat.mul_comm; rewrite mult_INR; - rewrite Rinv_mult. - apply Rmult_le_compat_l. - * left; apply Rinv_0_lt_compat; apply lt_INR_0; apply -> Nat.neq_0_lt_0; red; - intro; elim (fact_neq_0 _ H9). - * left; apply Rinv_lt_contravar. - -- apply Rmult_lt_0_compat; apply lt_INR_0; apply Nat.lt_0_succ. - -- apply lt_INR; apply -> Nat.succ_lt_mono. - pattern n at 1; replace n with (0 + n)%nat; [ idtac | reflexivity ]. - apply Nat.add_lt_mono_r. - apply Nat.lt_le_trans with 1%nat; [ apply Nat.lt_0_succ | assumption ]. - + ring. - } - ** ring. - ++ unfold Vn; rewrite Rmult_assoc; unfold Rdiv; - rewrite (Rmult_comm (Un 0%nat)); rewrite (Rmult_comm (Un n)). - repeat apply Rmult_le_compat_l. - ** apply Rabs_pos. - ** left; apply Rinv_0_lt_compat; apply lt_INR_0; apply Nat.lt_0_succ. - ** apply decreasing_prop; [ assumption | apply Nat.le_0_l ]. - -- unfold Un_decreasing; intro; unfold Un. - replace (M_nat + S n)%nat with (M_nat + n + 1)%nat by ring. - rewrite pow_add; unfold Rdiv; rewrite Rmult_assoc; - apply Rmult_le_compat_l. - { left; apply pow_lt; assumption. } - replace (Rabs x ^ 1) with (Rabs x); [ idtac | simpl; ring ]. - replace (M_nat + n + 1)%nat with (S (M_nat + n)) by ring. - apply Rmult_le_reg_l with (INR (fact (S (M_nat + n)))). - ++ apply lt_INR_0; apply Nat.neq_0_lt_0; red; intro; - elim (fact_neq_0 _ H8). - ++ rewrite (Rmult_comm (Rabs x)); rewrite <- Rmult_assoc; rewrite Rinv_r. - ** rewrite Rmult_1_l. - rewrite fact_simpl; rewrite mult_INR; rewrite Rmult_assoc; - rewrite Rinv_r. - { rewrite Rmult_1_r; apply Rle_trans with (INR M_nat). - - left; rewrite INR_IZR_INZ. - rewrite <- H4; assert (H8 := archimed (Rabs x)); elim H8; intros; assumption. - - apply le_INR; lia. - } - apply INR_fact_neq_0. - ** apply INR_fact_neq_0. - - -- intro; unfold Un; unfold Rdiv; apply Rmult_lt_0_compat. - { apply pow_lt; assumption. } - apply Rinv_0_lt_compat; apply lt_INR_0; apply Nat.neq_0_lt_0; red; intro; - elim (fact_neq_0 _ H7). - -- clear Un Vn; apply INR_le; simpl. - induction M_nat as [| M_nat HrecM_nat]. - ++ assert (H6 := archimed (Rabs x)); fold M in H6; elim H6; intros. - rewrite H4 in H7; rewrite <- INR_IZR_INZ in H7. - simpl in H7; elim (Rlt_irrefl _ (Rlt_trans _ _ _ H2 H7)). - ++ apply (le_INR 1); apply le_n_S; apply Nat.le_0_l. - + apply le_IZR; simpl; left; apply Rlt_trans with (Rabs x). - { assumption. } - elim (archimed (Rabs x)); intros; assumption. - } - unfold Un_cv; unfold Rdist; intros; elim (H eps H0); intros. - exists x0; intros; - apply Rle_lt_trans with (Rabs (Rabs x ^ n / INR (fact n) - 0)). - - unfold Rminus; rewrite Ropp_0; do 2 rewrite Rplus_0_r; - rewrite (Rabs_right (Rabs x ^ n / INR (fact n))). - + unfold Rdiv; rewrite Rabs_mult; rewrite (Rabs_right (/ INR (fact n))). - * rewrite RPow_abs; right; reflexivity. - * apply Rle_ge; left; apply Rinv_0_lt_compat; apply lt_INR_0; apply Nat.neq_0_lt_0; - red; intro; elim (fact_neq_0 _ H3). - + apply Rle_ge; unfold Rdiv; apply Rmult_le_pos. - * case (Req_dec x 0); intro. - -- rewrite H3; rewrite Rabs_R0. - induction n as [| n Hrecn]; - [ simpl; left; apply Rlt_0_1 - | simpl; rewrite Rmult_0_l; right; reflexivity ]. - -- left; apply pow_lt; apply Rabs_pos_lt; assumption. - * left; apply Rinv_0_lt_compat; apply lt_INR_0; apply Nat.neq_0_lt_0; red; - intro; elim (fact_neq_0 _ H3). - - apply H1; assumption. -Qed. diff --git a/stdlib/theories/Reals/SeqSeries.v b/stdlib/theories/Reals/SeqSeries.v deleted file mode 100644 index 6fa0f08d3cce..000000000000 --- a/stdlib/theories/Reals/SeqSeries.v +++ /dev/null @@ -1,400 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* R -> R) (An:nat -> R) (x l1 l2:R) - (N:nat), - Un_cv (fun n:nat => SP fn n x) l1 -> - Un_cv (fun n:nat => sum_f_R0 An n) l2 -> - (forall n:nat, Rabs (fn n x) <= An n) -> - Rabs (l1 - SP fn N x) <= l2 - sum_f_R0 An N. -Proof. - intros; - assert (X:{ l:R | Un_cv (fun n => sum_f_R0 (fun l => fn (S N + l)%nat x) n) l }). { - exists (l1 - SP fn N x). - unfold Un_cv in H; unfold Un_cv; intros. - elim (H eps H2); intros N0 H3. - unfold Rdist in H3; exists N0; intros. - unfold Rdist, SP. - replace - (sum_f_R0 (fun l:nat => fn (S N + l)%nat x) n - - (l1 - sum_f_R0 (fun k:nat => fn k x) N)) with - (sum_f_R0 (fun k:nat => fn k x) N + - sum_f_R0 (fun l:nat => fn (S N + l)%nat x) n - l1); - [ idtac | ring ]. - replace - (sum_f_R0 (fun k:nat => fn k x) N + - sum_f_R0 (fun l:nat => fn (S N + l)%nat x) n) with - (sum_f_R0 (fun k:nat => fn k x) (S (N + n))). - { unfold SP in H3; apply H3. - unfold ge; apply Nat.le_trans with n. - - apply H4. - - apply Nat.le_trans with (N + n)%nat. - + apply Nat.le_add_l. - + apply Nat.le_succ_diag_r. } - cut (0 <= N)%nat. - 2:{ apply Nat.le_0_l. } - cut (N < S (N + n))%nat. - 2:{ apply Nat.lt_succ_r. apply Nat.le_add_r. } - intros; assert (H7 := sigma_split (fun k:nat => fn k x) H6 H5). - unfold sigma in H7. - do 2 rewrite Nat.sub_0_r in H7. - replace (sum_f_R0 (fun k:nat => fn k x) (S (N + n))) with - (sum_f_R0 (fun k:nat => fn (0 + k)%nat x) (S (N + n))) by reflexivity. - replace (sum_f_R0 (fun k:nat => fn k x) N) with - (sum_f_R0 (fun k:nat => fn (0 + k)%nat x) N) by reflexivity. - assert ((S (N + n) - S N)%nat = n). { - apply INR_eq; rewrite minus_INR. - - do 2 rewrite S_INR; rewrite plus_INR; ring. - - apply -> Nat.succ_le_mono; apply Nat.le_add_r. - } - rewrite H8 in H7. - apply H7. - } - assert { l:R | Un_cv (fun n => sum_f_R0 (fun l => An (S N + l)%nat) n) l } as X0. { - exists (l2 - sum_f_R0 An N). - unfold Un_cv in H0; unfold Un_cv; intros. - elim (H0 eps H2); intros N0 H3. - unfold Rdist in H3; exists N0; intros. - unfold Rdist; - replace (sum_f_R0 (fun l:nat => An (S N + l)%nat) n - (l2 - sum_f_R0 An N)) - with (sum_f_R0 An N + sum_f_R0 (fun l:nat => An (S N + l)%nat) n - l2); - [ idtac | ring ]. - replace (sum_f_R0 An N + sum_f_R0 (fun l:nat => An (S N + l)%nat) n) with - (sum_f_R0 An (S (N + n))). - 2:{ cut (0 <= N)%nat. - 2:{ apply Nat.le_0_l. } - cut (N < S (N + n))%nat. - 2:{ apply Nat.lt_succ_r. apply Nat.le_add_r. } - intros; assert (H7 := sigma_split An H6 H5). - unfold sigma in H7. - do 2 rewrite Nat.sub_0_r in H7. - replace (sum_f_R0 An (S (N + n))) with - (sum_f_R0 (fun k:nat => An (0 + k)%nat) (S (N + n))) by reflexivity. - replace (sum_f_R0 An N) with (sum_f_R0 (fun k:nat => An (0 + k)%nat) N) by reflexivity. - assert ((S (N + n) - S N)%nat = n). { - apply INR_eq; rewrite minus_INR. - - do 2 rewrite S_INR; rewrite plus_INR; ring. - - apply -> Nat.succ_le_mono; apply Nat.le_add_r. - } - rewrite H8 in H7. - apply H7. - } - apply H3; unfold ge; apply Nat.le_trans with n. - - apply H4. - - apply Nat.le_trans with (N + n)%nat. - + apply Nat.le_add_l. - + apply Nat.le_succ_diag_r. - } - elim X; intros l1N H2. - elim X0; intros l2N H3. - cut (l1 - SP fn N x = l1N). - 1:intro; cut (l2 - sum_f_R0 An N = l2N). - { intro; rewrite H4; rewrite H5. - apply sum_cv_maj with - (fun l:nat => An (S N + l)%nat) (fun (l:nat) (x:R) => fn (S N + l)%nat x) x. - - unfold SP; apply H2. - - apply H3. - - intros; apply H1. } - { symmetry ; eapply UL_sequence. - { apply H3. } - unfold Un_cv in H0; unfold Un_cv; intros; elim (H0 eps H5); - intros N0 H6. - unfold Rdist in H6; exists N0; intros. - unfold Rdist; - replace (sum_f_R0 (fun l:nat => An (S N + l)%nat) n - (l2 - sum_f_R0 An N)) - with (sum_f_R0 An N + sum_f_R0 (fun l:nat => An (S N + l)%nat) n - l2); - [ idtac | ring ]. - replace (sum_f_R0 An N + sum_f_R0 (fun l:nat => An (S N + l)%nat) n) with - (sum_f_R0 An (S (N + n))). - { apply H6; unfold ge; apply Nat.le_trans with n. - - apply H7. - - apply Nat.le_trans with (N + n)%nat. - + apply Nat.le_add_l. - + apply Nat.le_succ_diag_r. } - cut (0 <= N)%nat. - 2:{ apply Nat.le_0_l. } - cut (N < S (N + n))%nat. - 2:{ apply Nat.lt_succ_r. apply Nat.le_add_r. } - intros; assert (H10 := sigma_split An H9 H8). - unfold sigma in H10. - do 2 rewrite Nat.sub_0_r in H10. - replace (sum_f_R0 An (S (N + n))) with - (sum_f_R0 (fun k:nat => An (0 + k)%nat) (S (N + n))) by reflexivity. - replace (sum_f_R0 An N) with (sum_f_R0 (fun k:nat => An (0 + k)%nat) N) by reflexivity. - cut ((S (N + n) - S N)%nat = n). - { intro; rewrite H11 in H10. - apply H10. } - apply INR_eq; rewrite minus_INR. - - do 2 rewrite S_INR; rewrite plus_INR; ring. - - apply le_n_S; apply Nat.le_add_r. } - symmetry ; eapply UL_sequence. - { apply H2. } - unfold Un_cv in H; unfold Un_cv; intros. - elim (H eps H4); intros N0 H5. - unfold Rdist in H5; exists N0; intros. - unfold Rdist, SP; - replace - (sum_f_R0 (fun l:nat => fn (S N + l)%nat x) n - - (l1 - sum_f_R0 (fun k:nat => fn k x) N)) with - (sum_f_R0 (fun k:nat => fn k x) N + - sum_f_R0 (fun l:nat => fn (S N + l)%nat x) n - l1); - [ idtac | ring ]. - replace - (sum_f_R0 (fun k:nat => fn k x) N + - sum_f_R0 (fun l:nat => fn (S N + l)%nat x) n) with - (sum_f_R0 (fun k:nat => fn k x) (S (N + n))). - { unfold SP in H5; apply H5; unfold ge; apply Nat.le_trans with n. - - apply H6. - - apply Nat.le_trans with (N + n)%nat. - + apply Nat.le_add_l. - + apply Nat.le_succ_diag_r. } - cut (0 <= N)%nat. - 2:{ apply Nat.le_0_l. } - cut (N < S (N + n))%nat. - 2:{ apply Nat.lt_succ_r. apply Nat.le_add_r. } - intros; assert (H9 := sigma_split (fun k:nat => fn k x) H8 H7). - unfold sigma in H9. - do 2 rewrite Nat.sub_0_r in H9. - replace (sum_f_R0 (fun k:nat => fn k x) (S (N + n))) with - (sum_f_R0 (fun k:nat => fn (0 + k)%nat x) (S (N + n))) by reflexivity. - replace (sum_f_R0 (fun k:nat => fn k x) N) with - (sum_f_R0 (fun k:nat => fn (0 + k)%nat x) N) by reflexivity. - cut ((S (N + n) - S N)%nat = n). - { intro; rewrite H10 in H9. - apply H9. } - apply INR_eq; rewrite minus_INR. - - do 2 rewrite S_INR; rewrite plus_INR; ring. - - apply le_n_S; apply Nat.le_add_r. -Qed. - -(** Comparaison of convergence for series *) -Lemma Rseries_CV_comp : - forall An Bn:nat -> R, - (forall n:nat, 0 <= An n <= Bn n) -> - { l:R | Un_cv (fun N:nat => sum_f_R0 Bn N) l } -> - { l:R | Un_cv (fun N:nat => sum_f_R0 An N) l }. -Proof. - intros An Bn H X; apply cv_cauchy_2. - assert (H0 := cv_cauchy_1 _ X). - unfold Cauchy_crit_series; unfold Cauchy_crit. - intros; elim (H0 eps H1); intros. - exists x; intros. - cut - (Rdist (sum_f_R0 An n) (sum_f_R0 An m) <= - Rdist (sum_f_R0 Bn n) (sum_f_R0 Bn m)). - { intro; apply Rle_lt_trans with (Rdist (sum_f_R0 Bn n) (sum_f_R0 Bn m)). - - assumption. - - apply H2; assumption. } - destruct (lt_eq_lt_dec n m) as [[| -> ]|]. - - rewrite (tech2 An n m); [ idtac | assumption ]. - rewrite (tech2 Bn n m); [ idtac | assumption ]. - unfold Rdist; unfold Rminus; do 2 rewrite Ropp_plus_distr; - do 2 rewrite <- Rplus_assoc; do 2 rewrite Rplus_opp_r; - do 2 rewrite Rplus_0_l; do 2 rewrite Rabs_Ropp; repeat rewrite Rabs_right. - + apply sum_Rle; intros. - elim (H (S n + n0)%nat); intros H7 H8. - apply H8. - + apply Rle_ge; apply cond_pos_sum; intro. - elim (H (S n + n0)%nat); intros. - apply Rle_trans with (An (S n + n0)%nat); assumption. - + apply Rle_ge; apply cond_pos_sum; intro. - elim (H (S n + n0)%nat); intros; assumption. - - unfold Rdist; unfold Rminus; - do 2 rewrite Rplus_opp_r; rewrite Rabs_R0; right; - reflexivity. - - rewrite (tech2 An m n); [ idtac | assumption ]. - rewrite (tech2 Bn m n); [ idtac | assumption ]. - unfold Rdist; unfold Rminus; do 2 rewrite Rplus_assoc; - rewrite (Rplus_comm (sum_f_R0 An m)); rewrite (Rplus_comm (sum_f_R0 Bn m)); - do 2 rewrite Rplus_assoc; do 2 rewrite Rplus_opp_l; - do 2 rewrite Rplus_0_r; repeat rewrite Rabs_right. - + apply sum_Rle; intros. - elim (H (S m + n0)%nat); intros H7 H8; apply H8. - + apply Rle_ge; apply cond_pos_sum; intro. - elim (H (S m + n0)%nat); intros. - apply Rle_trans with (An (S m + n0)%nat); assumption. - + apply Rle_ge. - apply cond_pos_sum; intro. - elim (H (S m + n0)%nat); intros; assumption. -Qed. - -(** Cesaro's theorem *) -Lemma Cesaro : - forall (An Bn:nat -> R) (l:R), - Un_cv Bn l -> - (forall n:nat, 0 < An n) -> - cv_infty (fun n:nat => sum_f_R0 An n) -> - Un_cv (fun n:nat => sum_f_R0 (fun k:nat => An k * Bn k) n / sum_f_R0 An n) - l. -Proof. - unfold Un_cv; intros; assert (H3 : forall n:nat, 0 < sum_f_R0 An n). - { intro; apply tech1; trivial. } - assert (H4 : forall n:nat, sum_f_R0 An n <> 0). - { intro; red; intro; assert (H5 := H3 n); rewrite H4 in H5; - elim (Rlt_irrefl _ H5). } - assert (H5 := cv_infty_cv_0 _ H1); assert (H6 : 0 < eps / 2). - { unfold Rdiv; apply Rmult_lt_0_compat. - - trivial. - - apply Rinv_0_lt_compat; prove_sup. } - elim (H _ H6); clear H; intros N1 H; - set (C := Rabs (sum_f_R0 (fun k:nat => An k * (Bn k - l)) N1)); - assert (H7 : exists N : nat, (forall n:nat, (N <= n)%nat -> C / sum_f_R0 An n < eps / 2)). - { case (Req_dec C 0); intro. - - exists 0%nat; intros. - rewrite H7; unfold Rdiv; rewrite Rmult_0_l; apply Rmult_lt_0_compat. - + trivial. - + apply Rinv_0_lt_compat; prove_sup. - - assert (H8 : 0 < eps / (2 * Rabs C)). - + unfold Rdiv; apply Rmult_lt_0_compat. - * trivial. - * apply Rinv_0_lt_compat; apply Rmult_lt_0_compat. - -- prove_sup. - -- apply Rabs_pos_lt;assumption. - + elim (H5 _ H8); intros; exists x; intros; assert (H11 := H9 _ H10); - unfold Rdist in H11; unfold Rminus in H11; rewrite Ropp_0 in H11; - rewrite Rplus_0_r in H11. - apply Rle_lt_trans with (Rabs (C / sum_f_R0 An n)). - { apply RRle_abs. } - unfold Rdiv; rewrite Rabs_mult; apply Rmult_lt_reg_l with (/ Rabs C). - { apply Rinv_0_lt_compat; apply Rabs_pos_lt;assumption. } - rewrite <- Rmult_assoc; rewrite Rinv_l. - * rewrite Rmult_1_l; replace (/ Rabs C * (eps * / 2)) with (eps / (2 * Rabs C)). - { trivial. } - field. - apply Rabs_no_R0;assumption. - * apply Rabs_no_R0;assumption. - } - elim H7; clear H7; intros N2 H7; set (N := max N1 N2); exists (S N); intros; - unfold Rdist; - replace (sum_f_R0 (fun k:nat => An k * Bn k) n / sum_f_R0 An n - l) with - (sum_f_R0 (fun k:nat => An k * (Bn k - l)) n / sum_f_R0 An n). - 2:{ replace (sum_f_R0 (fun k:nat => An k * (Bn k - l)) n) with - (sum_f_R0 (fun k:nat => An k * Bn k) n + - sum_f_R0 (fun k:nat => An k * - l) n). - - rewrite <- (scal_sum An n (- l)); field. trivial. - - rewrite <- plus_sum; apply sum_eq; intros; ring. } - assert (H9 : (N1 < n)%nat). - { apply Nat.lt_le_trans with (S N). - - apply Nat.lt_succ_r; unfold N; apply Nat.le_max_l. - - trivial. } - rewrite (tech2 (fun k:nat => An k * (Bn k - l)) _ _ H9); unfold Rdiv; - rewrite Rmult_plus_distr_r; - apply Rle_lt_trans with - (Rabs (sum_f_R0 (fun k:nat => An k * (Bn k - l)) N1 / sum_f_R0 An n) + - Rabs (sum_f_R0 (fun i:nat => An (S N1 + i)%nat * (Bn (S N1 + i)%nat - l)) - (n - S N1) / sum_f_R0 An n)). - { apply Rabs_triang. } - rewrite <-(Rplus_half_diag eps); apply Rplus_lt_compat. - { unfold Rdiv; rewrite Rabs_mult; fold C; rewrite Rabs_right. - - apply (H7 n); apply Nat.le_trans with (S N). - + apply Nat.le_trans with N; [ unfold N; apply Nat.le_max_r | apply Nat.le_succ_diag_r ]. - + trivial. - - apply Rle_ge; left; apply Rinv_0_lt_compat;trivial. } - - unfold Rdist in H; unfold Rdiv; rewrite Rabs_mult; - rewrite (Rabs_right (/ sum_f_R0 An n)). - 2:{ apply Rle_ge; left; apply Rinv_0_lt_compat;trivial. } - apply Rle_lt_trans with - (sum_f_R0 (fun i:nat => Rabs (An (S N1 + i)%nat * (Bn (S N1 + i)%nat - l))) - (n - S N1) * / sum_f_R0 An n). - { do 2 rewrite <- (Rmult_comm (/ sum_f_R0 An n)); apply Rmult_le_compat_l. - - left; apply Rinv_0_lt_compat;trivial. - - apply (Rsum_abs (fun i:nat => An (S N1 + i)%nat * (Bn (S N1 + i)%nat - l)) (n - S N1)). } - apply Rle_lt_trans with - (sum_f_R0 (fun i:nat => An (S N1 + i)%nat * (eps / 2)) (n - S N1) * - / sum_f_R0 An n). - - do 2 rewrite <- (Rmult_comm (/ sum_f_R0 An n)); apply Rmult_le_compat_l. - + left; apply Rinv_0_lt_compat. trivial. - + apply sum_Rle; intros; rewrite Rabs_mult; - pattern (An (S N1 + n0)%nat) at 2; - rewrite <- (Rabs_right (An (S N1 + n0)%nat)). - * apply Rmult_le_compat_l. - -- apply Rabs_pos. - -- left; apply H; unfold ge; apply Nat.le_trans with (S N1); - [ apply Nat.le_succ_diag_r | apply Nat.le_add_r ]. - * apply Rle_ge; left. trivial. - - rewrite <- (scal_sum (fun i:nat => An (S N1 + i)%nat) (n - S N1) (eps / 2)); - unfold Rdiv; repeat rewrite Rmult_assoc; apply Rmult_lt_compat_l. - { trivial. } - pattern (/ 2) at 2; rewrite <- Rmult_1_r; apply Rmult_lt_compat_l. - + apply Rinv_0_lt_compat; prove_sup. - + rewrite Rmult_comm; apply Rmult_lt_reg_l with (sum_f_R0 An n). - { trivial. } - rewrite <- Rmult_assoc; rewrite Rinv_r. - 2:{ trivial. } - rewrite Rmult_1_l; rewrite Rmult_1_r; rewrite (tech2 An N1 n). - 2:{ trivial. } - rewrite Rplus_comm; - pattern (sum_f_R0 (fun i:nat => An (S N1 + i)%nat) (n - S N1)) at 1; - rewrite <- Rplus_0_r; apply Rplus_lt_compat_l. - trivial. -Qed. - -Lemma Cesaro_1 : - forall (An:nat -> R) (l:R), - Un_cv An l -> Un_cv (fun n:nat => sum_f_R0 An (pred n) / INR n) l. -Proof. - intros Bn l H; set (An := fun _:nat => 1). - assert (H0 : forall n:nat, 0 < An n). - { intro; unfold An; apply Rlt_0_1. } - assert (H1 : forall n:nat, 0 < sum_f_R0 An n). - { intro; apply tech1. trivial. } - assert (H2 : cv_infty (fun n:nat => sum_f_R0 An n)). - { unfold cv_infty; intro; destruct (Rle_dec M 0) as [Hle|Hnle]. - - exists 0%nat; intros; apply Rle_lt_trans with 0; trivial. - - assert (H2 : 0 < M) by auto with real. - clear Hnle; set (m := up M); elim (archimed M); intros; - assert (H5 : (0 <= m)%Z). - + apply le_IZR; unfold m; simpl; left; apply Rlt_trans with M; trivial. - + elim (IZN _ H5); intros; exists x; intros; unfold An; rewrite sum_cte; - rewrite Rmult_1_l; apply Rlt_trans with (IZR (up M));trivial. - apply Rle_lt_trans with (INR x). - * rewrite INR_IZR_INZ; fold m; rewrite <- H6; right. trivial. - * apply lt_INR; apply Nat.lt_succ_r. trivial. } - assert (H3 := Cesaro _ _ _ H H0 H2). - unfold Un_cv; unfold Un_cv in H3; intros; elim (H3 _ H4); intros; - exists (S x); intros; unfold Rdist; unfold Rdist in H5; - apply Rle_lt_trans with - (Rabs - (sum_f_R0 (fun k:nat => An k * Bn k) (pred n) / sum_f_R0 An (pred n) - l)). - - right; - replace (sum_f_R0 Bn (pred n) / INR n - l) with - (sum_f_R0 (fun k:nat => An k * Bn k) (pred n) / sum_f_R0 An (pred n) - l);trivial. - unfold Rminus; do 2 rewrite <- (Rplus_comm (- l)); - apply Rplus_eq_compat_l. - unfold An; - replace (sum_f_R0 (fun k:nat => 1 * Bn k) (pred n)) with - (sum_f_R0 Bn (pred n)). - + rewrite sum_cte; rewrite Rmult_1_l; replace (S (pred n)) with n;trivial. - symmetry; apply Nat.lt_succ_pred with 0%nat; apply Nat.lt_le_trans with (S x);trivial. - apply Nat.lt_0_succ. - + apply sum_eq; intros; ring. - - apply H5; unfold ge; apply le_S_n; replace (S (pred n)) with n;trivial. - symmetry; apply Nat.lt_succ_pred with 0%nat; apply Nat.lt_le_trans with (S x);trivial. - apply Nat.lt_0_succ. -Qed. diff --git a/stdlib/theories/Reals/SplitAbsolu.v b/stdlib/theories/Reals/SplitAbsolu.v deleted file mode 100644 index f62d64b39c92..000000000000 --- a/stdlib/theories/Reals/SplitAbsolu.v +++ /dev/null @@ -1,25 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* - destruct (Rcase_abs X1) as [?Hlt|?Hge]; try split_case_Rabs - end. - - -Ltac split_Rabs := - match goal with - | id:context [(Rabs _)] |- _ => generalize id; clear id; try split_Rabs - | |- context [(Rabs ?X1)] => - unfold Rabs; try split_case_Rabs; intros - end. diff --git a/stdlib/theories/Reals/SplitRmult.v b/stdlib/theories/Reals/SplitRmult.v deleted file mode 100644 index 6b5fef249d50..000000000000 --- a/stdlib/theories/Reals/SplitRmult.v +++ /dev/null @@ -1,20 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* 0`` /\ ``r2<>0`` -> ``r1*r2<>0``. i*) - - -Require Import Rdefinitions Raxioms RIneq. - -Ltac split_Rmult := - match goal with - | |- ((?X1 * ?X2)%R <> 0%R) => - apply Rmult_integral_contrapositive; split; try split_Rmult - end. diff --git a/stdlib/theories/Reals/Sqrt_reg.v b/stdlib/theories/Reals/Sqrt_reg.v deleted file mode 100644 index ce6b8d275494..000000000000 --- a/stdlib/theories/Reals/Sqrt_reg.v +++ /dev/null @@ -1,326 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* Rabs (sqrt (1 + h) - 1) <= Rabs h. -Proof. - intros; assert (0 <= 1 + h). { - destruct (total_order_T h 0) as [[Hlt|Heq]|Hgt]. - + rewrite (Rabs_left h Hlt) in H. - apply Rplus_le_reg_l with (- h). - rewrite Rplus_0_r; rewrite Rplus_comm; rewrite Rplus_assoc; - rewrite Rplus_opp_r; rewrite Rplus_0_r; exact H. - + left; rewrite Heq; rewrite Rplus_0_r; apply Rlt_0_1. - + left; apply Rplus_lt_0_compat. - * apply Rlt_0_1. - * apply Hgt. - } - apply Rle_trans with (Rabs (sqrt (Rsqr (1 + h)) - 1)). - 2:{ rewrite sqrt_Rsqr. - - replace (1 + h - 1) with h; [ right; reflexivity | ring ]. - - apply H0. } - destruct (total_order_T h 0) as [[Hlt|Heq]|Hgt]. - - repeat rewrite Rabs_left. - + unfold Rminus; do 2 rewrite <- (Rplus_comm (-1)). - change (-1) with (-(1)). - do 2 rewrite Ropp_plus_distr; rewrite Ropp_involutive; - apply Rplus_le_compat_l. - apply Ropp_le_contravar; apply sqrt_le_1. - * apply Rle_0_sqr. - * apply H0. - * pattern (1 + h) at 2; rewrite <- Rmult_1_r; unfold Rsqr; - apply Rmult_le_compat_l; lra. - + apply Rplus_lt_reg_l with 1; rewrite Rplus_0_r; rewrite Rplus_comm; - unfold Rminus; rewrite Rplus_assoc; rewrite Rplus_opp_l; - rewrite Rplus_0_r. - pattern 1 at 2; rewrite <- sqrt_1; apply sqrt_lt_1. - * apply Rle_0_sqr. - * left; apply Rlt_0_1. - * pattern 1 at 2; rewrite <- Rsqr_1; apply Rsqr_incrst_1;lra. - + apply Rplus_lt_reg_l with 1; rewrite Rplus_0_r; rewrite Rplus_comm; - unfold Rminus; rewrite Rplus_assoc; rewrite Rplus_opp_l; - rewrite Rplus_0_r. - pattern 1 at 2; rewrite <- sqrt_1; apply sqrt_lt_1;lra. - - rewrite Heq; rewrite Rplus_0_r; rewrite Rsqr_1; rewrite sqrt_1; right; - reflexivity. - - repeat rewrite Rabs_right. - + unfold Rminus; do 2 rewrite <- (Rplus_comm (-1)); - apply Rplus_le_compat_l. - apply sqrt_le_1. - * apply H0. - * apply Rle_0_sqr. - * pattern (1 + h) at 1; rewrite <- Rmult_1_r; unfold Rsqr; - apply Rmult_le_compat_l;lra. - + apply Rle_ge; apply Rplus_le_reg_l with 1. - rewrite Rplus_0_r; rewrite Rplus_comm; unfold Rminus; - rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r. - pattern 1 at 1; rewrite <- sqrt_1; apply sqrt_le_1. - * left; apply Rlt_0_1. - * apply Rle_0_sqr. - * pattern 1 at 1; rewrite <- Rsqr_1; apply Rsqr_incr_1;lra. - + apply Rle_ge; left; apply Rplus_lt_reg_l with 1. - rewrite Rplus_0_r; rewrite Rplus_comm; unfold Rminus; - rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r. - pattern 1 at 1; rewrite <- sqrt_1; apply sqrt_lt_1;lra. -Qed. - -(** sqrt is continuous in 1 *) -Lemma sqrt_continuity_pt_R1 : continuity_pt sqrt 1. -Proof. - unfold continuity_pt; unfold continue_in; - unfold limit1_in; unfold limit_in; - unfold dist; simpl; unfold Rdist; - intros. - set (alpha := Rmin eps 1). - exists alpha; intros. - split. - - unfold alpha; unfold Rmin; case (Rle_dec eps 1); intro. - + assumption. - + apply Rlt_0_1. - - intros; elim H0; intros. - rewrite sqrt_1; replace x with (1 + (x - 1)); [ idtac | ring ]; - apply Rle_lt_trans with (Rabs (x - 1)). - + apply sqrt_var_maj. - apply Rle_trans with alpha. - * left; apply H2. - * unfold alpha; apply Rmin_r. - + apply Rlt_le_trans with alpha; - [ apply H2 | unfold alpha; apply Rmin_l ]. -Qed. - -(** sqrt is continuous forall x>0 *) -Lemma sqrt_continuity_pt : forall x:R, 0 < x -> continuity_pt sqrt x. -Proof. - intros; generalize sqrt_continuity_pt_R1. - unfold continuity_pt; unfold continue_in; - unfold limit1_in; unfold limit_in; - unfold dist; simpl; unfold Rdist; - intros. - assert (0 < eps / sqrt x). { - unfold Rdiv; apply Rmult_lt_0_compat. - - apply H1. - - apply Rinv_0_lt_compat; apply sqrt_lt_R0; apply H. - } - elim (H0 _ H2); intros alp_1 H3. - elim H3; intros. - set (alpha := alp_1 * x). - exists (Rmin alpha x); intros. - split. - { change (0 < Rmin alpha x); unfold Rmin; - case (Rle_dec alpha x); intro. - - unfold alpha; apply Rmult_lt_0_compat; assumption. - - apply H. } - intros; replace x0 with (x + (x0 - x)); [ idtac | ring ]; - replace (sqrt (x + (x0 - x)) - sqrt x) with - (sqrt x * (sqrt (1 + (x0 - x) / x) - sqrt 1)). - 2:{ unfold Rminus; rewrite Rmult_plus_distr_l; - rewrite Ropp_mult_distr_r_reverse; repeat rewrite <- sqrt_mult. - - rewrite Rmult_1_r; rewrite Rmult_plus_distr_l; rewrite Rmult_1_r; - unfold Rdiv; rewrite Rmult_comm; rewrite Rmult_assoc; - rewrite Rinv_l. - + rewrite Rmult_1_r; reflexivity. - + red; intro; rewrite H7 in H; elim (Rlt_irrefl _ H). - - left; apply H. - - left; apply Rlt_0_1. - - left; apply H. - - elim H6; intros. - destruct (Rcase_abs (x0 - x)) as [Hlt|Hgt]. - + rewrite (Rabs_left (x0 - x) Hlt) in H8. - rewrite Rplus_comm. - apply Rplus_le_reg_l with (- ((x0 - x) / x)). - rewrite Rplus_0_r; rewrite <- Rplus_assoc; rewrite Rplus_opp_l; - rewrite Rplus_0_l; unfold Rdiv; rewrite <- Ropp_mult_distr_l_reverse. - apply Rmult_le_reg_l with x. - * apply H. - * rewrite Rmult_1_r; rewrite Rmult_comm; rewrite Rmult_assoc; - rewrite Rinv_l. - -- rewrite Rmult_1_r; left; apply Rlt_le_trans with (Rmin alpha x). - ++ apply H8. - ++ apply Rmin_r. - -- lra. - + apply Rplus_le_le_0_compat. - * lra. - * unfold Rdiv; apply Rmult_le_pos. - -- lra. - -- left; apply Rinv_0_lt_compat; apply H. } - rewrite Rabs_mult; rewrite (Rabs_right (sqrt x)). - 2:{ apply Rle_ge; apply sqrt_positivity. - left; apply H. } - apply Rmult_lt_reg_l with (/ sqrt x). - { apply Rinv_0_lt_compat; apply sqrt_lt_R0; assumption. } - rewrite <- Rmult_assoc; rewrite Rinv_l. - 2:{ assert (H7 := sqrt_lt_R0 x H). lra. } - rewrite Rmult_1_l; rewrite Rmult_comm. - unfold Rdiv in H5. - case (Req_dec x x0); intro. - { rewrite H7; unfold Rminus, Rdiv; rewrite Rplus_opp_r; - rewrite Rmult_0_l; rewrite Rplus_0_r; rewrite Rplus_opp_r; - rewrite Rabs_R0. - apply Rmult_lt_0_compat. - - assumption. - - apply Rinv_0_lt_compat; rewrite <- H7; apply sqrt_lt_R0; assumption. } - apply H5. - split. - - unfold D_x, no_cond. - split. - + trivial. - + red; intro. - assert ((x0 - x) * / x = 0) by lra. - elim (Rmult_integral _ _ H9); intro. - { lra. } - assert (H11 := Rmult_eq_0_compat_r _ x H10). - rewrite Rinv_l in H11;lra. - - unfold Rminus; rewrite Rplus_comm; rewrite <- Rplus_assoc; - rewrite Rplus_opp_l; rewrite Rplus_0_l; elim H6; intros. - unfold Rdiv; rewrite Rabs_mult. - rewrite Rabs_inv. - rewrite (Rabs_right x). - + rewrite Rmult_comm; apply Rmult_lt_reg_l with x. - { apply H. } - rewrite <- Rmult_assoc; rewrite Rinv_r. - 2:{ lra. } - rewrite Rmult_1_l; rewrite Rmult_comm; fold alpha. - apply Rlt_le_trans with (Rmin alpha x). - * apply H9. - * apply Rmin_l. - + apply Rle_ge; left; apply H. -Qed. - -(** sqrt is derivable for all x>0 *) -Lemma derivable_pt_lim_sqrt : - forall x:R, 0 < x -> derivable_pt_lim sqrt x (/ (2 * sqrt x)). -Proof. - intros; set (g := fun h:R => sqrt x + sqrt (x + h)). - assert (continuity_pt g 0). { - replace g with (fct_cte (sqrt x) + comp sqrt (fct_cte x + id))%F; - [ idtac | reflexivity ]. - apply continuity_pt_plus. - - apply continuity_pt_const; unfold constant, fct_cte; intro; - reflexivity. - - apply continuity_pt_comp. - + apply continuity_pt_plus. - * apply continuity_pt_const; unfold constant, fct_cte; intro; - reflexivity. - * apply derivable_continuous_pt; apply derivable_pt_id. - + apply sqrt_continuity_pt. - unfold plus_fct, fct_cte, id; rewrite Rplus_0_r; apply H. - } - assert (g 0 <> 0). { - unfold g; rewrite Rplus_0_r. - assert (0 < sqrt x + sqrt x);[|lra]. - apply Rplus_lt_0_compat; apply sqrt_lt_R0; apply H. - } - intro; assert (H2 := continuity_pt_inv g 0 H0 H1). - unfold derivable_pt_lim; intros; unfold continuity_pt in H2; - unfold continue_in in H2; unfold limit1_in in H2; - unfold limit_in in H2; simpl in H2; unfold Rdist in H2. - elim (H2 eps H3); intros alpha H4. - elim H4; intros. - set (alpha1 := Rmin alpha x). - assert (0 < alpha1). { - unfold alpha1; unfold Rmin; case (Rle_dec alpha x); intro;lra. - } - exists (mkposreal alpha1 H7); intros. - replace ((sqrt (x + h) - sqrt x) / h) with (/ (sqrt x + sqrt (x + h))). - { unfold inv_fct, g in H6; replace (2 * sqrt x) with (sqrt x + sqrt (x + 0)). - - apply H6. - split. - + unfold D_x, no_cond. - split. - * trivial. - * apply (not_eq_sym (A:=R)); exact H8. - + unfold Rminus; rewrite Ropp_0; rewrite Rplus_0_r; - apply Rlt_le_trans with alpha1. - * exact H9. - * unfold alpha1; apply Rmin_l. - - rewrite Rplus_0_r; ring. } - assert (0 <= x + h). { - destruct (Rcase_abs h) as [Hlt|Hgt]. - 2:lra. - rewrite (Rabs_left h Hlt) in H9. - apply Rplus_le_reg_l with (- h). - rewrite Rplus_0_r; rewrite Rplus_comm; rewrite Rplus_assoc; - rewrite Rplus_opp_r; rewrite Rplus_0_r; left; apply Rlt_le_trans with alpha1. - - apply H9. - - unfold alpha1; apply Rmin_r. - } - assert (0 < sqrt x + sqrt (x + h)). { - apply Rplus_lt_le_0_compat. - - apply sqrt_lt_R0; apply H. - - apply sqrt_positivity; apply H10. - } - apply Rmult_eq_reg_l with (sqrt x + sqrt (x + h)). - 2:lra. - rewrite Rinv_r. - 2:lra. - rewrite Rplus_comm; unfold Rdiv; rewrite <- Rmult_assoc; - rewrite Rsqr_plus_minus; repeat rewrite Rsqr_sqrt. - 2,3: lra. - rewrite Rplus_comm; unfold Rminus; rewrite Rplus_assoc; - rewrite Rplus_opp_r; rewrite Rplus_0_r; rewrite Rinv_r;lra. -Qed. - -(**********) -Lemma derivable_pt_sqrt : forall x:R, 0 < x -> derivable_pt sqrt x. -Proof. - unfold derivable_pt; intros. - exists (/ (2 * sqrt x)). - apply derivable_pt_lim_sqrt; assumption. -Qed. - -(**********) -Lemma derive_pt_sqrt : - forall (x:R) (pr:0 < x), - derive_pt sqrt x (derivable_pt_sqrt _ pr) = / (2 * sqrt x). -Proof. - intros. - apply derive_pt_eq_0. - apply derivable_pt_lim_sqrt; assumption. -Qed. - -(** We show that sqrt is continuous for all x>=0 *) -(** Remark : by definition of sqrt (as extension of Rsqrt on |R), - we could also show that sqrt is continuous for all x *) -Lemma continuity_pt_sqrt : forall x:R, 0 <= x -> continuity_pt sqrt x. -Proof. - intros; case (Rtotal_order 0 x); intro. - { apply (sqrt_continuity_pt x H0). } - elim H0; intro. - 2:exfalso;lra. - unfold continuity_pt; unfold continue_in; - unfold limit1_in; unfold limit_in; - simpl; unfold Rdist; intros. - exists (Rsqr eps); intros. - split. - { change (0 < Rsqr eps); apply Rsqr_pos_lt;lra. } - intros; elim H3; intros. - rewrite <- H1; rewrite sqrt_0; unfold Rminus; rewrite Ropp_0; - rewrite Rplus_0_r; rewrite <- H1 in H5; unfold Rminus in H5; - rewrite Ropp_0 in H5; rewrite Rplus_0_r in H5. - destruct (Rcase_abs x0) as [Hlt|Hgt] eqn:Heqs. - { unfold sqrt. rewrite Heqs. - rewrite Rabs_R0; apply H2. } - rewrite Rabs_right. - 2: apply Rle_ge; apply sqrt_positivity; apply Rge_le; exact Hgt. - apply Rsqr_incrst_0. - - rewrite Rsqr_sqrt. - + rewrite (Rabs_right x0 Hgt) in H5; apply H5. - + apply Rge_le; exact Hgt. - - apply sqrt_positivity; apply Rge_le; exact Hgt. - - left; exact H2. -Qed. diff --git a/stdlib/theories/Relations/Operators_Properties.v b/stdlib/theories/Relations/Operators_Properties.v deleted file mode 100644 index c871afabfaf6..000000000000 --- a/stdlib/theories/Relations/Operators_Properties.v +++ /dev/null @@ -1,456 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* clos_trans R y z -> - clos_trans R x z. - Proof. - induction 1 as [b d H1|b|a b d H1 H2 IH1 IH2]; auto. - intro H. apply (t_trans _ _ _ d); auto. - constructor. auto. - Qed. - - (** Correctness of the reflexive-symmetric-transitive closure *) - - Lemma clos_rst_is_equiv : equivalence A (clos_refl_sym_trans R). - Proof. - apply Build_equivalence. - - exact (rst_refl A R). - - exact (rst_trans A R). - - exact (rst_sym A R). - Qed. - - (** Idempotency of the reflexive-symmetric-transitive closure operator *) - - Lemma clos_rst_idempotent : - inclusion (clos_refl_sym_trans (clos_refl_sym_trans R)) - (clos_refl_sym_trans R). - Proof. - red. - induction 1 as [x y H|x|x y H IH|x y z H IH H0 IH0]; auto with sets. - apply rst_trans with y; auto with sets. - Qed. - - End Clos_Refl_Sym_Trans. - - Section Equivalences. - - (** *** Equivalences between the different definition of the reflexive, - symmetric, transitive closures *) - - (** *** Contributed by P. CastĆ©ran *) - - (** Direct transitive closure vs left-step extension *) - - Lemma clos_t1n_trans : forall x y, clos_trans_1n R x y -> clos_trans R x y. - Proof. - induction 1 as [x y H|x y z H H0 IH0]. - - left; assumption. - - right with y; auto. - left; auto. - Qed. - - Lemma clos_trans_t1n : forall x y, clos_trans R x y -> clos_trans_1n R x y. - Proof. - induction 1 as [x y H|x y z H IHclos_trans1 H0 IHclos_trans2]. - - left; assumption. - - generalize IHclos_trans2; clear IHclos_trans2. - induction IHclos_trans1 as [x y H1|x y z0 H1 ? IHIHclos_trans1]. - + right with y; auto. - + right with y; auto. - eapply IHIHclos_trans1; auto. - apply clos_t1n_trans; auto. - Qed. - - Lemma clos_trans_t1n_iff : forall x y, - clos_trans R x y <-> clos_trans_1n R x y. - Proof. - split. - - apply clos_trans_t1n. - - apply clos_t1n_trans. - Qed. - - (** Direct transitive closure vs right-step extension *) - - Lemma clos_tn1_trans : forall x y, clos_trans_n1 R x y -> clos_trans R x y. - Proof. - induction 1 as [y H|y z H H0 ?]. - - left; assumption. - - right with y; auto. - left; assumption. - Qed. - - Lemma clos_trans_tn1 : forall x y, clos_trans R x y -> clos_trans_n1 R x y. - Proof. - induction 1 as [x y H|x y z H IHclos_trans1 H0 IHclos_trans2]. - - left; assumption. - - elim IHclos_trans2. - + intro y0; right with y. - * auto. - * auto. - + intro y0; intros. - right with y0; auto. - Qed. - - Lemma clos_trans_tn1_iff : forall x y, - clos_trans R x y <-> clos_trans_n1 R x y. - Proof. - split. - - apply clos_trans_tn1. - - apply clos_tn1_trans. - Qed. - - (** Direct reflexive-transitive closure is equivalent to - transitivity by left-step extension *) - - Lemma clos_rt1n_step : forall x y, R x y -> clos_refl_trans_1n R x y. - Proof. - intros x y H. - right with y;[assumption|left]. - Qed. - - Lemma clos_rtn1_step : forall x y, R x y -> clos_refl_trans_n1 R x y. - Proof. - intros x y H. - right with x;[assumption|left]. - Qed. - - Lemma clos_rt1n_rt : forall x y, - clos_refl_trans_1n R x y -> clos_refl_trans R x y. - Proof. - induction 1 as [|x y z]. - - constructor 2. - - constructor 3 with y; auto. - constructor 1; auto. - Qed. - - Lemma clos_rt_rt1n : forall x y, - clos_refl_trans R x y -> clos_refl_trans_1n R x y. - Proof. - induction 1 as [| |x y z H IHclos_refl_trans1 H0 IHclos_refl_trans2]. - - apply clos_rt1n_step; assumption. - - left. - - generalize IHclos_refl_trans2; clear IHclos_refl_trans2; - induction IHclos_refl_trans1 as [|x y z0 H1 ? IH]; auto. - - right with y; auto. - eapply IH; auto. - apply clos_rt1n_rt; auto. - Qed. - - Lemma clos_rt_rt1n_iff : forall x y, - clos_refl_trans R x y <-> clos_refl_trans_1n R x y. - Proof. - split. - - apply clos_rt_rt1n. - - apply clos_rt1n_rt. - Qed. - - (** Direct reflexive-transitive closure is equivalent to - transitivity by right-step extension *) - - Lemma clos_rtn1_rt : forall x y, - clos_refl_trans_n1 R x y -> clos_refl_trans R x y. - Proof. - induction 1 as [|y z]. - - constructor 2. - - constructor 3 with y; auto. - constructor 1; assumption. - Qed. - - Lemma clos_rt_rtn1 : forall x y, - clos_refl_trans R x y -> clos_refl_trans_n1 R x y. - Proof. - induction 1 as [| |x y z H1 IH1 H2 IH2]. - - apply clos_rtn1_step; auto. - - left. - - elim IH2; auto. - intro y0; intros. - right with y0; auto. - Qed. - - Lemma clos_rt_rtn1_iff : forall x y, - clos_refl_trans R x y <-> clos_refl_trans_n1 R x y. - Proof. - split. - - apply clos_rt_rtn1. - - apply clos_rtn1_rt. - Qed. - - (** Induction on the left transitive step *) - - Lemma clos_refl_trans_ind_left : - forall (x:A) (P:A -> Prop), P x -> - (forall y z:A, clos_refl_trans R x y -> P y -> R y z -> P z) -> - forall z:A, clos_refl_trans R x z -> P z. - Proof. - intros x P H H0 z H1. - revert H H0. - induction H1 as [x| |x y z H1 IH1 H2 IH2]; intros HP HIS; auto with sets. - - apply HIS with x; auto with sets. - - - apply IH2. - + apply IH1; auto with sets. - - + intro y0; intros; - apply HIS with y0; auto with sets. - apply rt_trans with y; auto with sets. - Qed. - - (** Induction on the right transitive step *) - - Lemma rt1n_ind_right : forall (P : A -> Prop) (z:A), - P z -> - (forall x y, R x y -> clos_refl_trans_1n R y z -> P y -> P x) -> - forall x, clos_refl_trans_1n R x z -> P x. - intros P z H H0 x; induction 1 as [|x y z]; auto. - apply H0 with y; auto. - Qed. - - Lemma clos_refl_trans_ind_right : forall (P : A -> Prop) (z:A), - P z -> - (forall x y, R x y -> P y -> clos_refl_trans R y z -> P x) -> - forall x, clos_refl_trans R x z -> P x. - intros P z Hz IH x Hxz. - apply clos_rt_rt1n_iff in Hxz. - elim Hxz using rt1n_ind_right; auto. - clear x Hxz. - intros x y Hxy Hyz Hy. - apply clos_rt_rt1n_iff in Hyz. - eauto. - Qed. - - (** Direct reflexive-symmetric-transitive closure is equivalent to - transitivity by symmetric left-step extension *) - - Lemma clos_rst1n_rst : forall x y, - clos_refl_sym_trans_1n R x y -> clos_refl_sym_trans R x y. - Proof. - induction 1 as [|x y z H]. - - constructor 2. - - constructor 4 with y; auto. - case H;[constructor 1|constructor 3; constructor 1]; auto. - Qed. - - Lemma clos_rst1n_trans : forall x y z, clos_refl_sym_trans_1n R x y -> - clos_refl_sym_trans_1n R y z -> clos_refl_sym_trans_1n R x z. - induction 1 as [|x y z0]. - - auto. - - intros; right with y; eauto. - Qed. - - Lemma clos_rst1n_sym : forall x y, clos_refl_sym_trans_1n R x y -> - clos_refl_sym_trans_1n R y x. - Proof. - intros x y H; elim H. - - constructor 1. - - intros x0 y0 z D H0 H1; apply clos_rst1n_trans with y0; auto. - right with x0. - + tauto. - + left. - Qed. - - Lemma clos_rst_rst1n : forall x y, - clos_refl_sym_trans R x y -> clos_refl_sym_trans_1n R x y. - induction 1 as [x y| | |]. - - constructor 2 with y; auto. - constructor 1. - - constructor 1. - - apply clos_rst1n_sym; auto. - - eapply clos_rst1n_trans; eauto. - Qed. - - Lemma clos_rst_rst1n_iff : forall x y, - clos_refl_sym_trans R x y <-> clos_refl_sym_trans_1n R x y. - Proof. - split. - - apply clos_rst_rst1n. - - apply clos_rst1n_rst. - Qed. - - (** Direct reflexive-symmetric-transitive closure is equivalent to - transitivity by symmetric right-step extension *) - - Lemma clos_rstn1_rst : forall x y, - clos_refl_sym_trans_n1 R x y -> clos_refl_sym_trans R x y. - Proof. - induction 1 as [|y z H]. - - constructor 2. - - constructor 4 with y; auto. - case H;[constructor 1|constructor 3; constructor 1]; auto. - Qed. - - Lemma clos_rstn1_trans : forall x y z, clos_refl_sym_trans_n1 R x y -> - clos_refl_sym_trans_n1 R y z -> clos_refl_sym_trans_n1 R x z. - Proof. - intros x y z H1 H2. - induction H2 as [|y0 z]. - - auto. - - right with y0; eauto. - Qed. - - Lemma clos_rstn1_sym : forall x y, clos_refl_sym_trans_n1 R x y -> - clos_refl_sym_trans_n1 R y x. - Proof. - intros x y H; elim H. - - constructor 1. - - intros y0 z D H0 H1. apply clos_rstn1_trans with y0; auto. - right with z. - + tauto. - + left. - Qed. - - Lemma clos_rst_rstn1 : forall x y, - clos_refl_sym_trans R x y -> clos_refl_sym_trans_n1 R x y. - Proof. - induction 1 as [x| | |]. - - constructor 2 with x; auto. - constructor 1. - - constructor 1. - - apply clos_rstn1_sym; auto. - - eapply clos_rstn1_trans; eauto. - Qed. - - Lemma clos_rst_rstn1_iff : forall x y, - clos_refl_sym_trans R x y <-> clos_refl_sym_trans_n1 R x y. - Proof. - split. - - apply clos_rst_rstn1. - - apply clos_rstn1_rst. - Qed. - - End Equivalences. - - Lemma clos_trans_transp_permute : forall x y, - transp _ (clos_trans R) x y <-> clos_trans (transp _ R) x y. - Proof. - split; induction 1; - (apply t_step; assumption) || eapply t_trans; eassumption. - Qed. - -End Properties. - -(* begin hide *) -(* Compatibility *) -Notation trans_tn1 := clos_trans_tn1 (only parsing). -Notation tn1_trans := clos_tn1_trans (only parsing). -Notation tn1_trans_equiv := clos_trans_tn1_iff (only parsing). - -Notation trans_t1n := clos_trans_t1n (only parsing). -Notation t1n_trans := clos_t1n_trans (only parsing). -Notation t1n_trans_equiv := clos_trans_t1n_iff (only parsing). - -Notation R_rtn1 := clos_rtn1_step (only parsing). -Notation trans_rt1n := clos_rt_rt1n (only parsing). -Notation rt1n_trans := clos_rt1n_rt (only parsing). -Notation rt1n_trans_equiv := clos_rt_rt1n_iff (only parsing). - -Notation R_rt1n := clos_rt1n_step (only parsing). -Notation trans_rtn1 := clos_rt_rtn1 (only parsing). -Notation rtn1_trans := clos_rtn1_rt (only parsing). -Notation rtn1_trans_equiv := clos_rt_rtn1_iff (only parsing). - -Notation rts1n_rts := clos_rst1n_rst (only parsing). -Notation rts_1n_trans := clos_rst1n_trans (only parsing). -Notation rts1n_sym := clos_rst1n_sym (only parsing). -Notation rts_rts1n := clos_rst_rst1n (only parsing). -Notation rts_rts1n_equiv := clos_rst_rst1n_iff (only parsing). - -Notation rtsn1_rts := clos_rstn1_rst (only parsing). -Notation rtsn1_trans := clos_rstn1_trans (only parsing). -Notation rtsn1_sym := clos_rstn1_sym (only parsing). -Notation rts_rtsn1 := clos_rst_rstn1 (only parsing). -Notation rts_rtsn1_equiv := clos_rst_rstn1_iff (only parsing). -(* end hide *) diff --git a/stdlib/theories/Relations/Relation_Definitions.v b/stdlib/theories/Relations/Relation_Definitions.v deleted file mode 100644 index 20de8e64c17d..000000000000 --- a/stdlib/theories/Relations/Relation_Definitions.v +++ /dev/null @@ -1 +0,0 @@ -From Corelib Require Export Relation_Definitions. diff --git a/stdlib/theories/Relations/Relation_Operators.v b/stdlib/theories/Relations/Relation_Operators.v deleted file mode 100644 index cdc5fa77cc78..000000000000 --- a/stdlib/theories/Relations/Relation_Operators.v +++ /dev/null @@ -1,274 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* Prop := - | t_step (y:A) : R x y -> clos_trans x y - | t_trans (y z:A) : clos_trans x y -> clos_trans y z -> clos_trans x z. - - (** Alternative definition by transitive extension on the left *) - - Inductive clos_trans_1n (x: A) : A -> Prop := - | t1n_step (y:A) : R x y -> clos_trans_1n x y - | t1n_trans (y z:A) : R x y -> clos_trans_1n y z -> clos_trans_1n x z. - - (** Alternative definition by transitive extension on the right *) - - Inductive clos_trans_n1 (x: A) : A -> Prop := - | tn1_step (y:A) : R x y -> clos_trans_n1 x y - | tn1_trans (y z:A) : R y z -> clos_trans_n1 x y -> clos_trans_n1 x z. - -End Transitive_Closure. - -(** ** Reflexive closure *) - -Section Reflexive_Closure. - Variable A : Type. - Variable R : relation A. - - (** Definition by direct transitive closure *) - - Inductive clos_refl (x: A) : A -> Prop := - | r_step (y:A) : R x y -> clos_refl x y - | r_refl : clos_refl x x. - -End Reflexive_Closure. - -(** ** Reflexive-transitive closure *) - -Section Reflexive_Transitive_Closure. - Variable A : Type. - Variable R : relation A. - - (** Definition by direct reflexive-transitive closure *) - - Inductive clos_refl_trans (x:A) : A -> Prop := - | rt_step (y:A) : R x y -> clos_refl_trans x y - | rt_refl : clos_refl_trans x x - | rt_trans (y z:A) : - clos_refl_trans x y -> clos_refl_trans y z -> clos_refl_trans x z. - - (** Alternative definition by transitive extension on the left *) - - Inductive clos_refl_trans_1n (x: A) : A -> Prop := - | rt1n_refl : clos_refl_trans_1n x x - | rt1n_trans (y z:A) : - R x y -> clos_refl_trans_1n y z -> clos_refl_trans_1n x z. - - (** Alternative definition by transitive extension on the right *) - - Inductive clos_refl_trans_n1 (x: A) : A -> Prop := - | rtn1_refl : clos_refl_trans_n1 x x - | rtn1_trans (y z:A) : - R y z -> clos_refl_trans_n1 x y -> clos_refl_trans_n1 x z. - -End Reflexive_Transitive_Closure. - -(** ** Reflexive-symmetric-transitive closure *) - -Section Reflexive_Symmetric_Transitive_Closure. - Variable A : Type. - Variable R : relation A. - - (** Definition by direct reflexive-symmetric-transitive closure *) - - Inductive clos_refl_sym_trans : relation A := - | rst_step (x y:A) : R x y -> clos_refl_sym_trans x y - | rst_refl (x:A) : clos_refl_sym_trans x x - | rst_sym (x y:A) : clos_refl_sym_trans x y -> clos_refl_sym_trans y x - | rst_trans (x y z:A) : - clos_refl_sym_trans x y -> - clos_refl_sym_trans y z -> clos_refl_sym_trans x z. - - (** Alternative definition by symmetric-transitive extension on the left *) - - Inductive clos_refl_sym_trans_1n (x: A) : A -> Prop := - | rst1n_refl : clos_refl_sym_trans_1n x x - | rst1n_trans (y z:A) : R x y \/ R y x -> - clos_refl_sym_trans_1n y z -> clos_refl_sym_trans_1n x z. - - (** Alternative definition by symmetric-transitive extension on the right *) - - Inductive clos_refl_sym_trans_n1 (x: A) : A -> Prop := - | rstn1_refl : clos_refl_sym_trans_n1 x x - | rstn1_trans (y z:A) : R y z \/ R z y -> - clos_refl_sym_trans_n1 x y -> clos_refl_sym_trans_n1 x z. - -End Reflexive_Symmetric_Transitive_Closure. - -(** ** Converse of a relation *) - -Section Converse. - Variable A : Type. - Variable R : relation A. - - Definition transp (x y:A) := R y x. -End Converse. - -(** ** Union of relations *) - -Section Union. - Variable A : Type. - Variables R1 R2 : relation A. - - Definition union (x y:A) := R1 x y \/ R2 x y. -End Union. - -(** ** Disjoint union of relations *) - -Section Disjoint_Union. -Variables A B : Type. -Variable leA : A -> A -> Prop. -Variable leB : B -> B -> Prop. - -Inductive le_AsB : A + B -> A + B -> Prop := - | le_aa (x y:A) : leA x y -> le_AsB (inl _ x) (inl _ y) - | le_ab (x:A) (y:B) : le_AsB (inl _ x) (inr _ y) - | le_bb (x y:B) : leB x y -> le_AsB (inr _ x) (inr _ y). - -End Disjoint_Union. - -(** ** Lexicographic order on dependent pairs *) - -Section Lexicographic_Product. - - Import SigTNotations. - - Variable A : Type. - Variable B : A -> Type. - Variable leA : A -> A -> Prop. - Variable leB : forall x:A, B x -> B x -> Prop. - - Inductive lexprod : sigT B -> sigT B -> Prop := - | left_lex : - forall (x x' : A) (y : B x) (y' : B x'), - leA x x' -> lexprod (x; y) (x'; y') - | right_lex : - forall (x : A) (y y' : B x), - leB x y y' -> lexprod (x; y) (x; y'). - -End Lexicographic_Product. - - -(** ** Lexicographic order on pairs *) - -Section Simple_Lexicographic_Product. - - Variable A : Type. - Variable B : Type. - Variable leA : A -> A -> Prop. - Variable leB : B -> B -> Prop. - - Inductive slexprod : A * B -> A * B -> Prop := - | left_slex : - forall (x x' : A) (y : B) (y' : B), - leA x x' -> slexprod (x, y) (x', y') - | right_slex : - forall (x : A) (y y' : B), - leB y y' -> slexprod (x, y) (x, y'). - - Lemma slexprod_lexprod p1 p2 : - slexprod p1 p2 <-> - lexprod _ _ leA (fun _ => leB) (sigT_of_prod p1) (sigT_of_prod p2). - Proof. - now split; intros HP; destruct p1, p2; inversion HP; constructor. - Qed. - -End Simple_Lexicographic_Product. - - -(** ** Product of relations *) - -Section Symmetric_Product. - Variable A : Type. - Variable B : Type. - Variable leA : A -> A -> Prop. - Variable leB : B -> B -> Prop. - - Inductive symprod : A * B -> A * B -> Prop := - | left_sym : - forall x x':A, leA x x' -> forall y:B, symprod (x, y) (x', y) - | right_sym : - forall y y':B, leB y y' -> forall x:A, symprod (x, y) (x, y'). - -End Symmetric_Product. - -(** ** Multiset of two relations *) - -Section Swap. - Variable A : Type. - Variable R : A -> A -> Prop. - - Inductive swapprod : A * A -> A * A -> Prop := - | sp_noswap x y (p:A * A) : symprod A A R R (x, y) p -> swapprod (x, y) p - | sp_swap x y (p:A * A) : symprod A A R R (x, y) p -> swapprod (y, x) p. -End Swap. - -Local Open Scope list_scope. - -Section Lexicographic_Exponentiation. - - Variable A : Set. - Variable leA : A -> A -> Prop. - Let Nil := nil (A:=A). - Let List := list A. - - Inductive Ltl : List -> List -> Prop := - | Lt_nil (a:A) (x:List) : Ltl Nil (a :: x) - | Lt_hd (a b:A) : leA a b -> forall x y:list A, Ltl (a :: x) (b :: y) - | Lt_tl (a:A) (x y:List) : Ltl x y -> Ltl (a :: x) (a :: y). - - Inductive Desc : List -> Prop := - | d_nil : Desc Nil - | d_one (x:A) : Desc (x :: Nil) - | d_conc (x y:A) (l:List) : - clos_refl A leA x y -> Desc (l ++ y :: Nil) -> Desc ((l ++ y :: Nil) ++ x :: Nil). - - Definition Pow : Set := sig Desc. - - Definition lex_exp (a b:Pow) : Prop := Ltl (proj1_sig a) (proj1_sig b). - -End Lexicographic_Exponentiation. - -#[global] -Hint Unfold transp union: sets. -#[global] -Hint Resolve t_step rt_step rt_refl rst_step rst_refl: sets. -#[global] -Hint Immediate rst_sym: sets. - -(* begin hide *) -(* Compatibility *) -Notation rts1n_refl := rst1n_refl (only parsing). -Notation rts1n_trans := rst1n_trans (only parsing). -Notation rtsn1_refl := rstn1_refl (only parsing). -Notation rtsn1_trans := rstn1_trans (only parsing). -(* end hide *) diff --git a/stdlib/theories/Relations/Relations.v b/stdlib/theories/Relations/Relations.v deleted file mode 100644 index ef0f1c476e24..000000000000 --- a/stdlib/theories/Relations/Relations.v +++ /dev/null @@ -1,30 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* B) (r:relation B), - equivalence B r -> equivalence A (fun x y:A => r (f x) (f y)). -Proof. - intros A B f r H; split; elim H; red; auto. - intros _ equiv_trans _ x y z H0 H1; apply equiv_trans with (f y); assumption. -Qed. - -Lemma inverse_image_of_eq : - forall (A B:Type) (f:A -> B), equivalence A (fun x y:A => f x = f y). -Proof. - intros A B f; split; red; - [ (* reflexivity *) reflexivity - | (* transitivity *) intros x y z; transitivity (f y); assumption - | (* symmetry *) intros; symmetry ; assumption ]. -Qed. diff --git a/stdlib/theories/Setoids/Setoid.v b/stdlib/theories/Setoids/Setoid.v deleted file mode 100644 index f6a485b23fec..000000000000 --- a/stdlib/theories/Setoids/Setoid.v +++ /dev/null @@ -1 +0,0 @@ -From Corelib Require Export Setoid. diff --git a/stdlib/theories/Sets/Classical_sets.v b/stdlib/theories/Sets/Classical_sets.v deleted file mode 100644 index 5e2eea0893ba..000000000000 --- a/stdlib/theories/Sets/Classical_sets.v +++ /dev/null @@ -1,129 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* Inhabited U A. - Proof. - intros A NI. - elim (not_all_ex_not U (fun x:U => ~ In U A x)). - - intros x H; apply Inhabited_intro with x. - apply NNPP; auto with sets. - - red; intro. - apply NI; red. - intros x H'; elim (H x); trivial with sets. - Qed. - - Lemma not_empty_Inhabited : - forall A:Ensemble U, A <> Empty_set U -> Inhabited U A. - Proof. - intros; apply not_included_empty_Inhabited. - red; auto with sets. - Qed. - - Lemma Inhabited_Setminus : - forall X Y:Ensemble U, - Included U X Y -> ~ Included U Y X -> Inhabited U (Setminus U Y X). - Proof. - intros X Y I NI. - elim (not_all_ex_not U (fun x:U => In U Y x -> In U X x) NI). - intros x YX. - apply Inhabited_intro with x. - apply Setminus_intro. - - apply not_imply_elim with (In U X x); trivial with sets. - - auto with sets. - Qed. - - Lemma Strict_super_set_contains_new_element : - forall X Y:Ensemble U, - Included U X Y -> X <> Y -> Inhabited U (Setminus U Y X). - Proof. - auto 7 using Inhabited_Setminus with sets. - Qed. - - Lemma Subtract_intro : - forall (A:Ensemble U) (x y:U), In U A y -> x <> y -> In U (Subtract U A x) y. - Proof. - unfold Subtract at 1; auto with sets. - Qed. - #[local] - Hint Resolve Subtract_intro : sets. - - Lemma Subtract_inv : - forall (A:Ensemble U) (x y:U), In U (Subtract U A x) y -> In U A y /\ x <> y. - Proof. - intros A x y H'; elim H'; auto with sets. - Qed. - - Lemma Included_Strict_Included : - forall X Y:Ensemble U, Included U X Y -> Strict_Included U X Y \/ X = Y. - Proof. - intros X Y H'; try assumption. - elim (classic (X = Y)); auto with sets. - Qed. - - Lemma Strict_Included_inv : - forall X Y:Ensemble U, - Strict_Included U X Y -> Included U X Y /\ Inhabited U (Setminus U Y X). - Proof. - intros X Y H'; red in H'. - split; [ tauto | idtac ]. - elim H'; intros H'0 H'1; try exact H'1; clear H'. - apply Strict_super_set_contains_new_element; auto with sets. - Qed. - - Lemma not_SIncl_empty : - forall X:Ensemble U, ~ Strict_Included U X (Empty_set U). - Proof. - intro X; red; intro H'; try exact H'. - lapply (Strict_Included_inv X (Empty_set U)); auto with sets. - intro H'0; elim H'0; intros H'1 H'2; elim H'2; clear H'0. - intros x H'0; elim H'0. - intro H'3; elim H'3. - Qed. - - Lemma Complement_Complement : - forall A:Ensemble U, Complement U (Complement U A) = A. - Proof. - unfold Complement; intros; apply Extensionality_Ensembles; - auto with sets. - red; split; auto with sets. - red; intros; apply NNPP; auto with sets. - Qed. - -End Ensembles_classical. - - #[global] - Hint Resolve Strict_super_set_contains_new_element Subtract_intro - not_SIncl_empty: sets. diff --git a/stdlib/theories/Sets/Constructive_sets.v b/stdlib/theories/Sets/Constructive_sets.v deleted file mode 100644 index ae6f215d80f1..000000000000 --- a/stdlib/theories/Sets/Constructive_sets.v +++ /dev/null @@ -1,147 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* Same_set U B C. - Proof. - intros B C H'; rewrite H'; auto with sets. - Qed. - - Lemma Noone_in_empty : forall x:U, ~ In U (Empty_set U) x. - Proof. - red; destruct 1. - Qed. - - Lemma Included_Empty : forall A:Ensemble U, Included U (Empty_set U) A. - Proof. - intro; red. - intros x H; elim (Noone_in_empty x); auto with sets. - Qed. - - Lemma Add_intro1 : - forall (A:Ensemble U) (x y:U), In U A y -> In U (Add U A x) y. - Proof. - unfold Add at 1; auto with sets. - Qed. - - Lemma Add_intro2 : forall (A:Ensemble U) (x:U), In U (Add U A x) x. - Proof. - unfold Add at 1; auto with sets. - Qed. - - Lemma Inhabited_add : forall (A:Ensemble U) (x:U), Inhabited U (Add U A x). - Proof. - intros A x. - apply Inhabited_intro with (x := x); auto using Add_intro2 with sets. - Qed. - - Lemma Inhabited_not_empty : - forall X:Ensemble U, Inhabited U X -> X <> Empty_set U. - Proof. - intros X H'; elim H'. - intros x H'0; red; intro H'1. - absurd (In U X x); auto with sets. - rewrite H'1; auto using Noone_in_empty with sets. - Qed. - - Lemma Add_not_Empty : forall (A:Ensemble U) (x:U), Add U A x <> Empty_set U. - Proof. - intros A x; apply Inhabited_not_empty; apply Inhabited_add. - Qed. - - Lemma not_Empty_Add : forall (A:Ensemble U) (x:U), Empty_set U <> Add U A x. - Proof. - intros; red; intro H; generalize (Add_not_Empty A x); auto with sets. - Qed. - - Lemma Singleton_inv : forall x y:U, In U (Singleton U x) y -> x = y. - Proof. - intros x y H'; elim H'; trivial with sets. - Qed. - - Lemma Singleton_intro : forall x y:U, x = y -> In U (Singleton U x) y. - Proof. - intros x y H'; rewrite H'; trivial with sets. - Qed. - - Lemma Union_inv : - forall (B C:Ensemble U) (x:U), In U (Union U B C) x -> In U B x \/ In U C x. - Proof. - intros B C x H'; elim H'; auto with sets. - Qed. - - Lemma Add_inv : - forall (A:Ensemble U) (x y:U), In U (Add U A x) y -> In U A y \/ x = y. - Proof. - intros A x y H'; induction H'. - - left; assumption. - - right; apply Singleton_inv; assumption. - Qed. - - Lemma Intersection_inv : - forall (B C:Ensemble U) (x:U), - In U (Intersection U B C) x -> In U B x /\ In U C x. - Proof. - intros B C x H'; elim H'; auto with sets. - Qed. - - Lemma Couple_inv : forall x y z:U, In U (Couple U x y) z -> z = x \/ z = y. - Proof. - intros x y z H'; elim H'; auto with sets. - Qed. - - Lemma Setminus_intro : - forall (A B:Ensemble U) (x:U), - In U A x -> ~ In U B x -> In U (Setminus U A B) x. - Proof. - unfold Setminus at 1; red; auto with sets. - Qed. - - Lemma Strict_Included_intro : - forall X Y:Ensemble U, Included U X Y /\ X <> Y -> Strict_Included U X Y. - Proof. - auto with sets. - Qed. - - Lemma Strict_Included_strict : forall X:Ensemble U, ~ Strict_Included U X X. - Proof. - intro X; red; intro H'; elim H'. - intros H'0 H'1; elim H'1; auto with sets. - Qed. - -End Ensembles_facts. - -#[global] -Hint Resolve Singleton_inv Singleton_intro Add_intro1 Add_intro2 - Intersection_inv Couple_inv Setminus_intro Strict_Included_intro - Strict_Included_strict Noone_in_empty Inhabited_not_empty Add_not_Empty - not_Empty_Add Inhabited_add Included_Empty: sets. diff --git a/stdlib/theories/Sets/Cpo.v b/stdlib/theories/Sets/Cpo.v deleted file mode 100644 index 6f7e5251ef99..000000000000 --- a/stdlib/theories/Sets/Cpo.v +++ /dev/null @@ -1,111 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* (forall y:U, In U B y -> R y x) -> Upper_Bound B x. - - Inductive Lower_Bound (B:Ensemble U) (x:U) : Prop := - Lower_Bound_definition : - In U C x -> (forall y:U, In U B y -> R x y) -> Lower_Bound B x. - - Inductive Lub (B:Ensemble U) (x:U) : Prop := - Lub_definition : - Upper_Bound B x -> (forall y:U, Upper_Bound B y -> R x y) -> Lub B x. - - Inductive Glb (B:Ensemble U) (x:U) : Prop := - Glb_definition : - Lower_Bound B x -> (forall y:U, Lower_Bound B y -> R y x) -> Glb B x. - - Inductive Bottom (bot:U) : Prop := - Bottom_definition : - In U C bot -> (forall y:U, In U C y -> R bot y) -> Bottom bot. - - Inductive Totally_ordered (B:Ensemble U) : Prop := - Totally_ordered_definition : - (Included U B C -> - forall x y:U, Included U (Couple U x y) B -> R x y \/ R y x) -> - Totally_ordered B. - - Definition Compatible : Relation U := - fun x y:U => - In U C x -> - In U C y -> exists z : _, In U C z /\ Upper_Bound (Couple U x y) z. - - Inductive Directed (X:Ensemble U) : Prop := - Definition_of_Directed : - Included U X C -> - Inhabited U X -> - (forall x1 x2:U, - Included U (Couple U x1 x2) X -> - exists x3 : _, In U X x3 /\ Upper_Bound (Couple U x1 x2) x3) -> - Directed X. - - Inductive Complete : Prop := - Definition_of_Complete : - (exists bot : _, Bottom bot) -> - (forall X:Ensemble U, Directed X -> exists bsup : _, Lub X bsup) -> - Complete. - - Inductive Conditionally_complete : Prop := - Definition_of_Conditionally_complete : - (forall X:Ensemble U, - Included U X C -> - (exists maj : _, Upper_Bound X maj) -> - exists bsup : _, Lub X bsup) -> Conditionally_complete. -End Bounds. - -#[global] -Hint Resolve Totally_ordered_definition Upper_Bound_definition - Lower_Bound_definition Lub_definition Glb_definition Bottom_definition - Definition_of_Complete Definition_of_Complete - Definition_of_Conditionally_complete : core. - -Section Specific_orders. - Variable U : Type. - - Record Cpo : Type := Definition_of_cpo - {PO_of_cpo : PO U; Cpo_cond : Complete U PO_of_cpo}. - - Record Chain : Type := Definition_of_chain - {PO_of_chain : PO U; - Chain_cond : Totally_ordered U PO_of_chain (@Carrier_of _ PO_of_chain)}. - -End Specific_orders. diff --git a/stdlib/theories/Sets/Ensembles.v b/stdlib/theories/Sets/Ensembles.v deleted file mode 100644 index 613d7617ec81..000000000000 --- a/stdlib/theories/Sets/Ensembles.v +++ /dev/null @@ -1,101 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* Prop. - - Definition In (A:Ensemble) (x:U) : Prop := A x. - - Definition Included (B C:Ensemble) : Prop := forall x:U, In B x -> In C x. - - Inductive Empty_set : Ensemble :=. - - Inductive Full_set : Ensemble := - Full_intro : forall x:U, In Full_set x. - -(** NB: The following definition builds-in equality of elements in [U] as - Leibniz equality. - - This may have to be changed if we replace [U] by a Setoid on [U] - with its own equality [eqs], with - [In_singleton: (y: U)(eqs x y) -> (In (Singleton x) y)]. *) - - Inductive Singleton (x:U) : Ensemble := - In_singleton : In (Singleton x) x. - - Inductive Union (B C:Ensemble) : Ensemble := - | Union_introl : forall x:U, In B x -> In (Union B C) x - | Union_intror : forall x:U, In C x -> In (Union B C) x. - - Definition Add (B:Ensemble) (x:U) : Ensemble := Union B (Singleton x). - - Inductive Intersection (B C:Ensemble) : Ensemble := - Intersection_intro : - forall x:U, In B x -> In C x -> In (Intersection B C) x. - - Inductive Couple (x y:U) : Ensemble := - | Couple_l : In (Couple x y) x - | Couple_r : In (Couple x y) y. - - Inductive Triple (x y z:U) : Ensemble := - | Triple_l : In (Triple x y z) x - | Triple_m : In (Triple x y z) y - | Triple_r : In (Triple x y z) z. - - Definition Complement (A:Ensemble) : Ensemble := fun x:U => ~ In A x. - - Definition Setminus (B C:Ensemble) : Ensemble := - fun x:U => In B x /\ ~ In C x. - - Definition Subtract (B:Ensemble) (x:U) : Ensemble := Setminus B (Singleton x). - - Inductive Disjoint (B C:Ensemble) : Prop := - Disjoint_intro : (forall x:U, ~ In (Intersection B C) x) -> Disjoint B C. - - Inductive Inhabited (B:Ensemble) : Prop := - Inhabited_intro : forall x:U, In B x -> Inhabited B. - - Definition Strict_Included (B C:Ensemble) : Prop := Included B C /\ B <> C. - - Definition Same_set (B C:Ensemble) : Prop := Included B C /\ Included C B. - - (** Extensionality Axiom *) - - Axiom Extensionality_Ensembles : forall A B:Ensemble, Same_set A B -> A = B. - -End Ensembles. - -#[global] -Hint Unfold In Included Same_set Strict_Included Add Setminus Subtract: sets. - -#[global] -Hint Resolve Union_introl Union_intror Intersection_intro In_singleton - Couple_l Couple_r Triple_l Triple_m Triple_r Disjoint_intro - Extensionality_Ensembles: sets. diff --git a/stdlib/theories/Sets/Finite_sets.v b/stdlib/theories/Sets/Finite_sets.v deleted file mode 100644 index b097ebb8b5ab..000000000000 --- a/stdlib/theories/Sets/Finite_sets.v +++ /dev/null @@ -1,83 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* Prop := - | Empty_is_finite : Finite (Empty_set U) - | Union_is_finite : - forall A:Ensemble U, - Finite A -> forall x:U, ~ In U A x -> Finite (Add U A x). - - Inductive cardinal : Ensemble U -> nat -> Prop := - | card_empty : cardinal (Empty_set U) 0 - | card_add : - forall (A:Ensemble U) (n:nat), - cardinal A n -> forall x:U, ~ In U A x -> cardinal (Add U A x) (S n). - -End Ensembles_finis. - -#[global] -Hint Resolve Empty_is_finite Union_is_finite: sets. -#[global] -Hint Resolve card_empty card_add: sets. - -Require Import Constructive_sets. - -Section Ensembles_finis_facts. - Variable U : Type. - - Lemma cardinal_invert : - forall (X:Ensemble U) (p:nat), - cardinal U X p -> - match p with - | O => X = Empty_set U - | S n => - exists A : _, - (exists x : _, X = Add U A x /\ ~ In U A x /\ cardinal U A n) - end. - Proof. - induction 1; simpl; auto. - exists A; exists x; auto. - Qed. - - Lemma cardinal_elim : - forall (X:Ensemble U) (p:nat), - cardinal U X p -> - match p with - | O => X = Empty_set U - | S n => Inhabited U X - end. - Proof. - intros X p C; elim C; simpl; trivial with sets. - Qed. - -End Ensembles_finis_facts. diff --git a/stdlib/theories/Sets/Finite_sets_facts.v b/stdlib/theories/Sets/Finite_sets_facts.v deleted file mode 100644 index 268adf765b41..000000000000 --- a/stdlib/theories/Sets/Finite_sets_facts.v +++ /dev/null @@ -1,236 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* exists n : nat, cardinal U X n. - Proof. - induction 1 as [| A _ [n H]]. - - exists 0; auto with sets. - - exists (S n); auto with sets. - Qed. - - Lemma cardinal_finite : - forall (X:Ensemble U) (n:nat), cardinal U X n -> Finite U X. - Proof. - induction 1; auto with sets. - Qed. - - Theorem Add_preserves_Finite : - forall (X:Ensemble U) (x:U), Finite U X -> Finite U (Add U X x). - Proof. - intros X x H'. - elim (classic (In U X x)); intro H'0; auto with sets. - rewrite (Non_disjoint_union U X x); auto with sets. - Qed. - - Theorem Singleton_is_finite : forall x:U, Finite U (Singleton U x). - Proof. - intro x; rewrite <- Empty_set_zero'. - apply Union_is_finite; auto with sets. - Qed. - - Theorem Union_preserves_Finite : - forall X Y:Ensemble U, Finite U X -> Finite U Y -> Finite U (Union U X Y). - Proof. - intros X Y HX HY. - induction HX. - - now rewrite Empty_set_zero. - - rewrite Union_commutative. - rewrite <- Union_add. - apply Add_preserves_Finite. - now rewrite Union_commutative. - Qed. - - Lemma Finite_downward_closed : - forall A:Ensemble U, - Finite U A -> forall X:Ensemble U, Included U X A -> Finite U X. - Proof. - intros A HA. - induction HA as [|A HA IHHA]; [ intros X HX | intros X HXAx ]. - - rewrite less_than_empty; auto with sets. - - destruct (Included_Add _ _ _ _ HXAx) as [|[X' [-> HX'A]]]; auto with sets. - Qed. - - Lemma Intersection_preserves_finite : - forall A:Ensemble U, - Finite U A -> forall X:Ensemble U, Finite U (Intersection U X A). - Proof. - intros A H' X; apply Finite_downward_closed with A; auto with sets. - Qed. - - Lemma cardinalO_empty : - forall X:Ensemble U, cardinal U X 0 -> X = Empty_set U. - Proof. - intros X H; apply (cardinal_invert U X 0); trivial with sets. - Qed. - - Lemma inh_card_gt_O : - forall X:Ensemble U, Inhabited U X -> forall n:nat, cardinal U X n -> n > 0. - Proof. - intros X [x HX] [] HCX. - - now rewrite (cardinalO_empty X HCX) in HX. - - apply Nat.lt_0_succ. - Qed. - - Lemma card_soustr_1 : - forall (X:Ensemble U) (n:nat), - cardinal U X n -> - forall x:U, In U X x -> cardinal U (Subtract U X x) (pred n). - Proof. - intros X n H. induction H as [|X n H IH x Hx]; intros x' Hx'. - - destruct Hx'. - - rewrite Nat.pred_succ. - apply Add_inv in Hx' as [Hx' | <-]. - + rewrite (add_soustr_xy _ _ x x') by (intros <-; contradiction Hx). - rewrite <- Nat.succ_pred_pos. - * apply card_add; [ apply (IH _ Hx') |]. - now intros [? _]%Subtract_inv. - * apply inh_card_gt_O with (X := X); [| assumption ]. - exact (Inhabited_intro _ _ _ Hx'). - + rewrite <- (Sub_Add_new _ _ _ Hx). assumption. - Qed. - - Lemma cardinal_Empty : forall m:nat, cardinal U (Empty_set U) m -> 0 = m. - Proof. - intros m Cm. - inversion Cm as [|X n _ x _ H]; [ reflexivity | ]. - symmetry in H. - now apply not_Empty_Add in H. - Qed. - - Lemma cardinal_is_functional : - forall (X:Ensemble U) (c1:nat), - cardinal U X c1 -> - forall (Y:Ensemble U) (c2:nat), cardinal U Y c2 -> X = Y -> c1 = c2. - Proof. - intros X c1 H'; elim H'. - - intros Y c2 H'0 <-; now apply cardinal_Empty. - - clear H' c1 X. - intros X n H' H'0 x H'1 Y c2 H'2. - elim H'2. - + intro H'3; now elim (not_Empty_Add U X x). - + clear H'2 c2 Y. - intros X0 c2 H'2 _ x0 H'4 H'5. - apply f_equal. - assert (H'6 : In U (Add U X x) x) by apply Add_intro2. - rewrite H'5 in H'6. - destruct (Add_inv _ _ _ _ H'6) as [H'7 | <-]. - * apply H'0 with (Y := Subtract U (Add U X0 x0) x). - -- rewrite <- Nat.pred_succ; apply card_soustr_1; auto with sets. - -- rewrite <- H'5; auto with sets. - * apply (H'0 _ _ H'2 (Simplify_add _ _ _ _ H'1 H'4 H'5)). - Qed. - - Lemma cardinal_unicity : - forall (X:Ensemble U) (n:nat), - cardinal U X n -> forall m:nat, cardinal U X m -> n = m. - Proof. - intros X ? ? ? ?; now apply cardinal_is_functional with X X. - Qed. - - Lemma card_Add_gen : - forall (A:Ensemble U) (x:U) (n n':nat), - cardinal U A n -> cardinal U (Add U A x) n' -> n' <= S n. - Proof. - intros A x n n' H0 H1. - elim (classic (In U A x)); intro H2. - - rewrite (Non_disjoint_union _ _ _ H2) in H1. - rewrite (cardinal_unicity _ _ H0 _ H1). - apply Nat.le_succ_diag_r. - - apply Nat.eq_le_incl. - apply cardinal_unicity with (X := Add U A x); auto with sets. - Qed. - - Lemma incl_st_card_lt : - forall (X:Ensemble U) (c1:nat), - cardinal U X c1 -> - forall (Y:Ensemble U) (c2:nat), - cardinal U Y c2 -> Strict_Included U X Y -> c2 > c1. - Proof. - intros X c1 H1. - induction H1 as [|X' ? HX' IH x Hx]; intros Y c2 HY Hsincl; - (inversion HY as [HXY Hc | ? ? ? ? ? HXY]; subst Y; [ apply not_SIncl_empty in Hsincl as [] |]). - - apply Nat.lt_0_succ. - - subst c2. apply -> Nat.succ_lt_mono. - refine (IH _ _ _ (incl_st_add_soustr _ _ _ _ Hx Hsincl)). - rewrite <- Nat.pred_succ. apply card_soustr_1; [ assumption | ]. - apply Hsincl, Add_intro2. - Qed. - - Lemma incl_card_le : - forall (X Y:Ensemble U) (n m:nat), - cardinal U X n -> cardinal U Y m -> Included U X Y -> n <= m. - Proof. - intros X Y n m HX HY HXY. - destruct (Included_Strict_Included _ _ _ HXY) as [HXY' | <-]. - - apply Nat.lt_le_incl. - now apply (incl_st_card_lt _ _ HX _ _ HY). - - apply Nat.eq_le_incl. - now apply cardinal_unicity with X. - Qed. - - Lemma Generalized_induction_on_finite_sets : - forall P:Ensemble U -> Prop, - (forall X:Ensemble U, - Finite U X -> - (forall Y:Ensemble U, Strict_Included U Y X -> P Y) -> P X) -> - forall X:Ensemble U, Finite U X -> P X. - Proof. - intros P HP X HX. - induction HX as [|X HX IH x Hx] in P, HP. - - apply HP; [ auto with sets | ]. - now intros Y [->%less_than_empty []]. - - enough (forall Y, Included U Y (Add U X x) -> P Y) by auto with sets. - revert Hx. apply IH. clear IH X HX. - intros Y HY IH' Hx Z HZYx. - apply HP; [ apply Finite_downward_closed with (Add _ Y x); auto with sets | ]. - intros Z' HZ'Z. - pose proof (Strict_inclusion_is_transitive_with_inclusion _ _ _ _ HZ'Z HZYx) as [HZ'Yx Hneq]. - case (Included_Add _ _ _ _ HZ'Yx) as [HZ'Y | [Y' [-> HY'Y]]]. - + case (classic (Z' = Y)) as [-> | Hneq']. - * apply (HP _ HY). - intros Y' [HY'Y Hneq']. - apply (IH' Y'); auto with sets. - * apply (IH' Z'); auto with sets. - + apply (IH' Y'); auto with sets. - now split; [| intros -> ]. - Qed. - -End Finite_sets_facts. diff --git a/stdlib/theories/Sets/Image.v b/stdlib/theories/Sets/Image.v deleted file mode 100644 index 1d3fe2d4e5be..000000000000 --- a/stdlib/theories/Sets/Image.v +++ /dev/null @@ -1,203 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* V) : Ensemble V := - Im_intro : forall x:U, In _ X x -> forall y:V, y = f x -> In _ (Im X f) y. - - Lemma Im_def : - forall (X:Ensemble U) (f:U -> V) (x:U), In _ X x -> In _ (Im X f) (f x). - Proof. - intros X f x H'; try assumption. - apply Im_intro with (x := x); auto with sets. - Qed. - - Lemma Im_add : - forall (X:Ensemble U) (x:U) (f:U -> V), - Im (Add _ X x) f = Add _ (Im X f) (f x). - Proof. - intros X x f. - apply Extensionality_Ensembles. - split; red; intros x0 H'. - - elim H'; intros. - rewrite H0. - elim Add_inv with U X x x1; auto using Im_def with sets. - destruct 1; auto using Im_def with sets. - - elim Add_inv with V (Im X f) (f x) x0. - + destruct 1 as [x0 H y H0]. - rewrite H0; auto using Im_def with sets. - + destruct 1; auto using Im_def with sets. - + trivial. - Qed. - - Lemma image_empty : forall f:U -> V, Im (Empty_set U) f = Empty_set V. - Proof. - intro f; try assumption. - apply Extensionality_Ensembles. - split; auto with sets. - red. - intros x H'; elim H'. - intros x0 H'0; elim H'0; auto with sets. - Qed. - - Lemma finite_image : - forall (X:Ensemble U) (f:U -> V), Finite _ X -> Finite _ (Im X f). - Proof. - intros X f H'; elim H'. - - rewrite (image_empty f); auto with sets. - - intros A H'0 H'1 x H'2; clear H' X. - rewrite (Im_add A x f); auto with sets. - apply Add_preserves_Finite; auto with sets. - Qed. - - Lemma Im_inv : - forall (X:Ensemble U) (f:U -> V) (y:V), - In _ (Im X f) y -> exists x : U, In _ X x /\ f x = y. - Proof. - intros X f y H'; elim H'. - intros x H'0 y0 H'1; rewrite H'1. - exists x; auto with sets. - Qed. - - Definition injective (f:U -> V) := forall x y:U, f x = f y -> x = y. - - Lemma not_injective_elim : - forall f:U -> V, - ~ injective f -> exists x : _, (exists y : _, f x = f y /\ x <> y). - Proof. - unfold injective; intros f H. - cut (exists x : _, ~ (forall y:U, f x = f y -> x = y)). - 2: apply not_all_ex_not with (P := fun x:U => forall y:U, f x = f y -> x = y); - trivial with sets. - destruct 1 as [x C]; exists x. - cut (exists y : _, ~ (f x = f y -> x = y)). - 2: apply not_all_ex_not with (P := fun y:U => f x = f y -> x = y); - trivial with sets. - destruct 1 as [y D]; exists y. - apply imply_to_and; trivial with sets. - Qed. - - Lemma cardinal_Im_intro : - forall (A:Ensemble U) (f:U -> V) (n:nat), - cardinal _ A n -> exists p : nat, cardinal _ (Im A f) p. - Proof. - intros. - apply finite_cardinal; apply finite_image. - apply cardinal_finite with n; trivial with sets. - Qed. - - Lemma In_Image_elim : - forall (A:Ensemble U) (f:U -> V), - injective f -> forall x:U, In _ (Im A f) (f x) -> In _ A x. - Proof. - intros. - elim Im_inv with A f (f x); trivial with sets. - intros z C; elim C; intros InAz E. - elim (H z x E); trivial with sets. - Qed. - - Lemma injective_preserves_cardinal : - forall (A:Ensemble U) (f:U -> V) (n:nat), - injective f -> - cardinal _ A n -> forall n':nat, cardinal _ (Im A f) n' -> n' = n. - Proof. - induction 2 as [| A n H'0 H'1 x H'2]; auto with sets. - - rewrite (image_empty f). - intros n' CE. - apply cardinal_unicity with V (Empty_set V); auto with sets. - - intro n'. - rewrite (Im_add A x f). - intro H'3. - elim cardinal_Im_intro with A f n; trivial with sets. - intros i CI. - lapply (H'1 i); trivial with sets. - cut (~ In _ (Im A f) (f x)). - + intros H0 H1. - apply cardinal_unicity with V (Add _ (Im A f) (f x)); trivial with sets. - apply card_add; auto with sets. - rewrite <- H1; trivial with sets. - + red; intro; apply H'2. - apply In_Image_elim with f; trivial with sets. - Qed. - - Lemma cardinal_decreases : - forall (A:Ensemble U) (f:U -> V) (n:nat), - cardinal U A n -> forall n':nat, cardinal V (Im A f) n' -> n' <= n. - Proof. - induction 1 as [| A n H'0 H'1 x H'2]; auto with sets. - - rewrite (image_empty f); intros. - cut (n' = 0). - + intro E; rewrite E; trivial with sets. - + apply cardinal_unicity with V (Empty_set V); auto with sets. - - intro n'. - rewrite (Im_add A x f). - elim cardinal_Im_intro with A f n; trivial with sets. - intros p C H'3. - apply Nat.le_trans with (S p). - + apply card_Add_gen with V (Im A f) (f x); trivial with sets. - + apply -> Nat.succ_le_mono; auto with sets. - Qed. - - Theorem Pigeonhole : - forall (A:Ensemble U) (f:U -> V) (n:nat), - cardinal U A n -> - forall n':nat, cardinal V (Im A f) n' -> n' < n -> ~ injective f. - Proof. - unfold not; intros A f n CAn n' CIfn' ltn'n I. - cut (n' = n). - - intro E; generalize ltn'n; rewrite E; exact (Nat.lt_irrefl n). - - apply injective_preserves_cardinal with (A := A) (f := f) (n := n); - trivial with sets. - Qed. - - Lemma Pigeonhole_principle : - forall (A:Ensemble U) (f:U -> V) (n:nat), - cardinal _ A n -> - forall n':nat, - cardinal _ (Im A f) n' -> - n' < n -> exists x : _, (exists y : _, f x = f y /\ x <> y). - Proof. - intros; apply not_injective_elim. - apply Pigeonhole with A n n'; trivial with sets. - Qed. - -End Image. - -#[global] -Hint Resolve Im_def image_empty finite_image: sets. diff --git a/stdlib/theories/Sets/Infinite_sets.v b/stdlib/theories/Sets/Infinite_sets.v deleted file mode 100644 index 1381607aaab8..000000000000 --- a/stdlib/theories/Sets/Infinite_sets.v +++ /dev/null @@ -1,242 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* Included U X A -> Approximant A X. -End Approx. - -#[global] -Hint Resolve Defn_of_Approximant : core. - -Section Infinite_sets. - Variable U : Type. - - Lemma make_new_approximant : - forall A X:Ensemble U, - ~ Finite U A -> Approximant U A X -> Inhabited U (Setminus U A X). - Proof. - intros A X H' H'0. - elim H'0; intros H'1 H'2. - apply Strict_super_set_contains_new_element; auto with sets. - red; intro H'3; apply H'. - rewrite <- H'3; auto with sets. - Qed. - - Lemma approximants_grow : - forall A X:Ensemble U, - ~ Finite U A -> - forall n:nat, - cardinal U X n -> - Included U X A -> exists Y : _, cardinal U Y (S n) /\ Included U Y A. - Proof. - intros A X H' n H'0; elim H'0; auto with sets. - - intro H'1. - cut (Inhabited U (Setminus U A (Empty_set U))). - + intro H'2; elim H'2. - intros x H'3. - exists (Add U (Empty_set U) x); auto with sets. - split. - * apply card_add; auto with sets. - * cut (In U A x). - -- intro H'4; red; auto with sets. - intros x0 H'5; elim H'5; auto with sets. - intros x1 H'6; elim H'6; auto with sets. - -- elim H'3; auto with sets. - + apply make_new_approximant; auto with sets. - - intros A0 n0 H'1 H'2 x H'3 H'5. - lapply H'2; [ intro H'6; elim H'6; clear H'2 | clear H'2 ]; auto with sets. - intros x0 H'2; try assumption. - elim H'2; intros H'7 H'8; try exact H'8; clear H'2. - elim (make_new_approximant A x0); auto with sets. - + intros x1 H'2; try assumption. - exists (Add U x0 x1); auto with sets. - split. - * apply card_add; auto with sets. - elim H'2; auto with sets. - * red. - intros x2 H'9; elim H'9; auto with sets. - intros x3 H'10; elim H'10; auto with sets. - elim H'2; auto with sets. - + auto with sets. - apply Defn_of_Approximant; auto with sets. - apply cardinal_finite with (n := S n0); auto with sets. - Qed. - - Lemma approximants_grow' : - forall A X:Ensemble U, - ~ Finite U A -> - forall n:nat, - cardinal U X n -> - Approximant U A X -> - exists Y : _, cardinal U Y (S n) /\ Approximant U A Y. - Proof. - intros A X H' n H'0 H'1; try assumption. - elim H'1. - intros H'2 H'3. - cut (exists Y : _, cardinal U Y (S n) /\ Included U Y A). - - intros [x H'4]; elim H'4; intros H'5 H'6; try exact H'5; clear H'4. - exists x; auto with sets. - split; [ auto with sets | idtac ]. - apply Defn_of_Approximant; auto with sets. - apply cardinal_finite with (n := S n); auto with sets. - - apply approximants_grow with (X := X); auto with sets. - Qed. - - Lemma approximant_can_be_any_size : - forall A X:Ensemble U, - ~ Finite U A -> - forall n:nat, exists Y : _, cardinal U Y n /\ Approximant U A Y. - Proof. - intros A H' H'0 n; elim n. - - exists (Empty_set U); auto with sets. - - intros n0 H'1; elim H'1. - intros x H'2. - apply approximants_grow' with (X := x); tauto. - Qed. - - Variable V : Type. - - Theorem Image_set_continuous : - forall (A:Ensemble U) (f:U -> V) (X:Ensemble V), - Finite V X -> - Included V X (Im U V A f) -> - exists n : _, - (exists Y : _, (cardinal U Y n /\ Included U Y A) /\ Im U V Y f = X). - Proof. - intros A f X H'; elim H'. - - intro H'0; exists 0. - exists (Empty_set U); auto with sets. - - intros A0 H'0 H'1 x H'2 H'3; try assumption. - lapply H'1; - [ intro H'4; elim H'4; intros n E; elim E; clear H'4 H'1 | clear H'1 ]; - auto with sets. - intros x0 H'1; try assumption. - exists (S n); try assumption. - elim H'1; intros H'4 H'5; elim H'4; intros H'6 H'7; try exact H'6; - clear H'4 H'1. - clear E. - generalize H'2. - rewrite <- H'5. - intro H'1; try assumption. - red in H'3. - generalize (H'3 x). - intro H'4; lapply H'4; [ intro H'8; try exact H'8; clear H'4 | clear H'4 ]; - auto with sets. - specialize Im_inv with (U := U) (V := V) (X := A) (f := f) (y := x); - intro H'11; lapply H'11; [ intro H'13; elim H'11; clear H'11 | clear H'11 ]; - auto with sets. - intros x1 H'4; try assumption. - apply ex_intro with (x := Add U x0 x1). - split; [ split; [ try assumption | idtac ] | idtac ]. - + apply card_add; auto with sets. - red; intro H'9; try exact H'9. - apply H'1. - elim H'4; intros H'10 H'11; rewrite <- H'11; clear H'4; auto with sets. - + elim H'4; intros H'9 H'10; try exact H'9; clear H'4; auto with sets. - red; auto with sets. - intros x2 H'4; elim H'4; auto with sets. - intros x3 H'11; elim H'11; auto with sets. - + elim H'4; intros H'9 H'10; rewrite <- H'10; clear H'4; auto with sets. - apply Im_add; auto with sets. - Qed. - - Theorem Image_set_continuous' : - forall (A:Ensemble U) (f:U -> V) (X:Ensemble V), - Approximant V (Im U V A f) X -> - exists Y : _, Approximant U A Y /\ Im U V Y f = X. - Proof. - intros A f X H'; try assumption. - cut - (exists n : _, - (exists Y : _, (cardinal U Y n /\ Included U Y A) /\ Im U V Y f = X)). - - intro H'0; elim H'0; intros n E; elim E; clear H'0. - intros x H'0; try assumption. - elim H'0; intros H'1 H'2; elim H'1; intros H'3 H'4; try exact H'3; - clear H'1 H'0; auto with sets. - exists x. - split; [ idtac | try assumption ]. - apply Defn_of_Approximant; auto with sets. - apply cardinal_finite with (n := n); auto with sets. - - apply Image_set_continuous; auto with sets. - + elim H'; auto with sets. - + elim H'; auto with sets. - Qed. - - Theorem Pigeonhole_bis : - forall (A:Ensemble U) (f:U -> V), - ~ Finite U A -> Finite V (Im U V A f) -> ~ injective U V f. - Proof. - intros A f H'0 H'1; try assumption. - elim (Image_set_continuous' A f (Im U V A f)); auto with sets. - intros x H'2; elim H'2; intros H'3 H'4; try exact H'3; clear H'2. - elim (make_new_approximant A x); auto with sets. - intros x0 H'2; elim H'2. - intros H'5 H'6. - elim (finite_cardinal V (Im U V A f)); auto with sets. - intros n E. - elim (finite_cardinal U x); auto with sets. - - intros n0 E0. - apply Pigeonhole with (A := Add U x x0) (n := S n0) (n' := n). - + apply card_add; auto with sets. - + rewrite (Im_add U V x x0 f); auto with sets. - cut (In V (Im U V x f) (f x0)). - * intro H'8. - rewrite (Non_disjoint_union V (Im U V x f) (f x0)); auto with sets. - rewrite H'4; auto with sets. - * elim (Extension V (Im U V x f) (Im U V A f)); auto with sets. - + apply Nat.lt_succ_r. - apply cardinal_decreases with (U := U) (V := V) (A := x) (f := f); - auto with sets. - rewrite H'4; auto with sets. - - elim H'3; auto with sets. - Qed. - - Theorem Pigeonhole_ter : - forall (A:Ensemble U) (f:U -> V) (n:nat), - injective U V f -> Finite V (Im U V A f) -> Finite U A. - Proof. - intros A f H' H'0 H'1. - apply NNPP. - red; intro H'2. - elim (Pigeonhole_bis A f); auto with sets. - Qed. - -End Infinite_sets. diff --git a/stdlib/theories/Sets/Integers.v b/stdlib/theories/Sets/Integers.v deleted file mode 100644 index e783527ef4d4..000000000000 --- a/stdlib/theories/Sets/Integers.v +++ /dev/null @@ -1,159 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* exists m : nat, Upper_Bound nat nat_po X m. - Proof. - intros X H'; elim H'. - - exists 0. - apply Upper_Bound_definition. - + unfold nat_po. simpl. apply triv_nat. - + intros y H'0; elim H'0; auto with sets arith. - - intros A H'0 H'1 x H'2; try assumption. - elim H'1; intros x0 H'3; clear H'1. - elim le_total_order. - simpl. - intro H'1; try assumption. - lapply H'1; [ intro H'4; idtac | try assumption ]; auto with sets arith. - generalize (H'4 x0 x). - clear H'4. - clear H'1. - intro H'1; lapply H'1; - [ intro H'4; elim H'4; - [ intro H'5; try exact H'5; clear H'4 H'1 | intro H'5; clear H'4 H'1 ] - | clear H'1 ]. - + exists x. - apply Upper_Bound_definition. - * simpl. apply triv_nat. - * intros y H'1; elim H'1. - -- generalize le_trans. - intro H'4; red in H'4. - intros x1 H'6; try assumption. - apply H'4 with (y := x0). - ++ elim H'3; simpl; auto with sets arith. - ++ trivial. - -- intros x1 H'4; elim H'4. unfold nat_po; simpl; trivial. - + exists x0. - apply Upper_Bound_definition. - * unfold nat_po. simpl. apply triv_nat. - * intros y H'1; elim H'1. - -- intros x1 H'4; try assumption. - elim H'3; simpl; auto with sets arith. - -- intros x1 H'4; elim H'4; auto with sets arith. - + red. - intros x1 H'1; elim H'1; apply triv_nat. - Qed. - - Lemma Integers_has_no_ub : - ~ (exists m : nat, Upper_Bound nat nat_po Integers m). - Proof. - red; intro H'; elim H'. - intros x H'0. - elim H'0; intros H'1 H'2. - cut (In nat Integers (S x)). - - intro H'3. - specialize H'2 with (y := S x); lapply H'2; - [ intro H'5; clear H'2 | try assumption; clear H'2 ]. - apply Nat.nle_succ_diag_l in H'5; assumption. - - apply triv_nat. - Qed. - - Lemma Integers_infinite : ~ Finite nat Integers. - Proof. - generalize Integers_has_no_ub. - intro H'; red; intro H'0; try exact H'0. - apply H'. - apply Finite_subset_has_lub; auto with sets arith. - Qed. - -End Integers_sect. diff --git a/stdlib/theories/Sets/Multiset.v b/stdlib/theories/Sets/Multiset.v deleted file mode 100644 index c60b3d19beee..000000000000 --- a/stdlib/theories/Sets/Multiset.v +++ /dev/null @@ -1,194 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* A -> Prop. - Hypothesis eqA_equiv : Equivalence eqA. - Hypothesis Aeq_dec : forall x y:A, {eqA x y} + {~ eqA x y}. - - Inductive multiset : Type := - Bag : (A -> nat) -> multiset. - - Definition EmptyBag := Bag (fun a:A => 0). - Definition SingletonBag (a:A) := - Bag (fun a':A => match Aeq_dec a a' with - | left _ => 1 - | right _ => 0 - end). - - Definition multiplicity (m:multiset) (a:A) : nat := let (f) := m in f a. - - (** multiset equality *) - Definition meq (m1 m2:multiset) := - forall a:A, multiplicity m1 a = multiplicity m2 a. - - Lemma meq_refl : forall x:multiset, meq x x. - Proof. - destruct x; unfold meq; reflexivity. - Qed. - - Lemma meq_trans : forall x y z:multiset, meq x y -> meq y z -> meq x z. - Proof. - unfold meq. - destruct x; destruct y; destruct z. - intros; rewrite H; auto. - Qed. - - Lemma meq_sym : forall x y:multiset, meq x y -> meq y x. - Proof. - unfold meq. - destruct x; destruct y; auto. - Qed. - - (** multiset union *) - Definition munion (m1 m2:multiset) := - Bag (fun a:A => multiplicity m1 a + multiplicity m2 a). - - Lemma munion_empty_left : forall x:multiset, meq x (munion EmptyBag x). - Proof. - unfold meq; unfold munion; simpl; auto. - Qed. - - Lemma munion_empty_right : forall x:multiset, meq x (munion x EmptyBag). - Proof. - unfold meq; unfold munion; simpl; auto. - Qed. - - Lemma munion_comm : forall x y:multiset, meq (munion x y) (munion y x). - Proof. - unfold meq; unfold multiplicity; unfold munion. - destruct x; destruct y; intros; apply Nat.add_comm. - Qed. - - Lemma munion_ass : - forall x y z:multiset, meq (munion (munion x y) z) (munion x (munion y z)). - Proof. - unfold meq; unfold munion; unfold multiplicity. - destruct x; destruct y; destruct z; intros; symmetry; apply Nat.add_assoc. - Qed. - - Lemma meq_left : - forall x y z:multiset, meq x y -> meq (munion x z) (munion y z). - Proof. - unfold meq; unfold munion; unfold multiplicity. - destruct x; destruct y; destruct z. - intros; elim H; reflexivity. - Qed. - - Lemma meq_right : - forall x y z:multiset, meq x y -> meq (munion z x) (munion z y). - Proof. - unfold meq; unfold munion; unfold multiplicity. - destruct x; destruct y; destruct z. - intros; elim H; auto. - Qed. - - (** Here we should make multiset an abstract datatype, by hiding [Bag], - [munion], [multiplicity]; all further properties are proved abstractly *) - - Lemma munion_rotate : - forall x y z:multiset, meq (munion x (munion y z)) (munion z (munion x y)). - Proof. - intros; apply (op_rotate multiset munion meq). - - apply munion_comm. - - apply munion_ass. - - exact meq_trans. - - exact meq_sym. - - trivial. - Qed. - - Lemma meq_congr : - forall x y z t:multiset, meq x y -> meq z t -> meq (munion x z) (munion y t). - Proof. - intros; apply (cong_congr multiset munion meq); auto using meq_left, meq_right. - exact meq_trans. - Qed. - - Lemma munion_perm_left : - forall x y z:multiset, meq (munion x (munion y z)) (munion y (munion x z)). - Proof. - intros; apply (perm_left multiset munion meq); auto using munion_comm, munion_ass, meq_left, meq_right, meq_sym. - exact meq_trans. - Qed. - - Lemma multiset_twist1 : - forall x y z t:multiset, - meq (munion x (munion (munion y z) t)) (munion (munion y (munion x t)) z). - Proof. - intros; apply (twist multiset munion meq); auto using munion_comm, munion_ass, meq_sym, meq_left, meq_right. - exact meq_trans. - Qed. - - Lemma multiset_twist2 : - forall x y z t:multiset, - meq (munion x (munion (munion y z) t)) (munion (munion y (munion x z)) t). - Proof. - intros; apply meq_trans with (munion (munion x (munion y z)) t). - - apply meq_sym; apply munion_ass. - - apply meq_left; apply munion_perm_left. - Qed. - - (** specific for treesort *) - - Lemma treesort_twist1 : - forall x y z t u:multiset, - meq u (munion y z) -> - meq (munion x (munion u t)) (munion (munion y (munion x t)) z). - Proof. - intros; apply meq_trans with (munion x (munion (munion y z) t)). - - apply meq_right; apply meq_left; trivial. - - apply multiset_twist1. - Qed. - - Lemma treesort_twist2 : - forall x y z t u:multiset, - meq u (munion y z) -> - meq (munion x (munion u t)) (munion (munion y (munion x z)) t). - Proof. - intros; apply meq_trans with (munion x (munion (munion y z) t)). - - apply meq_right; apply meq_left; trivial. - - apply multiset_twist2. - Qed. - - (** SingletonBag *) - - Lemma meq_singleton : forall a a', - eqA a a' -> meq (SingletonBag a) (SingletonBag a'). - Proof. - intros; red; simpl; intro a0. - destruct (Aeq_dec a a0) as [Ha|Ha]; rewrite H in Ha; - decide (Aeq_dec a' a0) with Ha; reflexivity. - Qed. - -(*i theory of minter to do similarly -(* multiset intersection *) -Definition minter := [m1,m2:multiset] - (Bag [a:A](min (multiplicity m1 a)(multiplicity m2 a))). -i*) - -End multiset_defs. - -Unset Implicit Arguments. - -#[global] -Hint Unfold meq multiplicity: datatypes. -#[global] -Hint Resolve munion_empty_right munion_comm munion_ass meq_left meq_right - munion_empty_left: datatypes. -#[global] -Hint Immediate meq_sym: datatypes. diff --git a/stdlib/theories/Sets/Partial_Order.v b/stdlib/theories/Sets/Partial_Order.v deleted file mode 100644 index 1a3da7f77bb3..000000000000 --- a/stdlib/theories/Sets/Partial_Order.v +++ /dev/null @@ -1,104 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* Rel_of p x y /\ x <> y. - - Inductive covers (y x:U) : Prop := - Definition_of_covers : - Strict_Rel_of x y -> - ~ (exists z : _, Strict_Rel_of x z /\ Strict_Rel_of z y) -> - covers y x. - -End Partial_orders. - -#[global] -Hint Unfold Carrier_of Rel_of Strict_Rel_of: sets. -#[global] -Hint Resolve Definition_of_covers: sets. - - -Section Partial_order_facts. - Variable U : Type. - Variable D : PO U. - - Lemma Strict_Rel_Transitive_with_Rel : - forall x y z:U, - Strict_Rel_of U D x y -> @Rel_of U D y z -> Strict_Rel_of U D x z. - Proof. - unfold Strict_Rel_of at 1. - red. - elim D; simpl. - intros C R H' H'0; elim H'0. - intros H'1 H'2 H'3 x y z H'4 H'5; split. - - apply H'2 with (y := y); tauto. - - red; intro H'6. - elim H'4; intros H'7 H'8; apply H'8; clear H'4. - apply H'3; auto. - rewrite H'6; tauto. - Qed. - - Lemma Strict_Rel_Transitive_with_Rel_left : - forall x y z:U, - @Rel_of U D x y -> Strict_Rel_of U D y z -> Strict_Rel_of U D x z. - Proof. - unfold Strict_Rel_of at 1. - red. - elim D; simpl. - intros C R H' H'0; elim H'0. - intros H'1 H'2 H'3 x y z H'4 H'5; split. - - apply H'2 with (y := y); tauto. - - red; intro H'6. - elim H'5; intros H'7 H'8; apply H'8; clear H'5. - apply H'3; auto. - rewrite <- H'6; auto. - Qed. - - Lemma Strict_Rel_Transitive : Transitive U (Strict_Rel_of U D). - red. - intros x y z H' H'0. - apply Strict_Rel_Transitive_with_Rel with (y := y); - [ intuition | unfold Strict_Rel_of in H', H'0; intuition ]. - Qed. -End Partial_order_facts. diff --git a/stdlib/theories/Sets/Permut.v b/stdlib/theories/Sets/Permut.v deleted file mode 100644 index 346a53fdfbd0..000000000000 --- a/stdlib/theories/Sets/Permut.v +++ /dev/null @@ -1,89 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* U -> U. - Variable cong : U -> U -> Prop. - - Hypothesis op_comm : forall x y:U, cong (op x y) (op y x). - Hypothesis op_ass : forall x y z:U, cong (op (op x y) z) (op x (op y z)). - - Hypothesis cong_left : forall x y z:U, cong x y -> cong (op x z) (op y z). - Hypothesis cong_right : forall x y z:U, cong x y -> cong (op z x) (op z y). - Hypothesis cong_trans : forall x y z:U, cong x y -> cong y z -> cong x z. - Hypothesis cong_sym : forall x y:U, cong x y -> cong y x. - - (** Remark. we do not need: [Hypothesis cong_refl : (x:U)(cong x x)]. *) - - Lemma cong_congr : - forall x y z t:U, cong x y -> cong z t -> cong (op x z) (op y t). - Proof. - intros; apply cong_trans with (op y z). - - apply cong_left; trivial. - - apply cong_right; trivial. - Qed. - - Lemma comm_right : forall x y z:U, cong (op x (op y z)) (op x (op z y)). - Proof. - intros; apply cong_right; apply op_comm. - Qed. - - Lemma comm_left : forall x y z:U, cong (op (op x y) z) (op (op y x) z). - Proof. - intros; apply cong_left; apply op_comm. - Qed. - - Lemma perm_right : forall x y z:U, cong (op (op x y) z) (op (op x z) y). - Proof. - intros. - apply cong_trans with (op x (op y z)). - - apply op_ass. - - apply cong_trans with (op x (op z y)). - + apply cong_right; apply op_comm. - + apply cong_sym; apply op_ass. - Qed. - - Lemma perm_left : forall x y z:U, cong (op x (op y z)) (op y (op x z)). - Proof. - intros. - apply cong_trans with (op (op x y) z). - - apply cong_sym; apply op_ass. - - apply cong_trans with (op (op y x) z). - + apply cong_left; apply op_comm. - + apply op_ass. - Qed. - - Lemma op_rotate : forall x y z t:U, cong (op x (op y z)) (op z (op x y)). - Proof. - intros; apply cong_trans with (op (op x y) z). - - apply cong_sym; apply op_ass. - - apply op_comm. - Qed. - - (** Needed for treesort ... *) - Lemma twist : - forall x y z t:U, cong (op x (op (op y z) t)) (op (op y (op x t)) z). - Proof. - intros. - apply cong_trans with (op x (op (op y t) z)). - - apply cong_right; apply perm_right. - - apply cong_trans with (op (op x (op y t)) z). - + apply cong_sym; apply op_ass. - + apply cong_left; apply perm_left. - Qed. - -End Axiomatisation. diff --git a/stdlib/theories/Sets/Powerset.v b/stdlib/theories/Sets/Powerset.v deleted file mode 100644 index e59703a81b52..000000000000 --- a/stdlib/theories/Sets/Powerset.v +++ /dev/null @@ -1,211 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* In (Ensemble U) (Power_set A) X. -#[local] -Hint Resolve Definition_of_Power_set : core. - -Theorem Empty_set_minimal : forall X:Ensemble U, Included U (Empty_set U) X. -intro X; red. -intros x H'; elim H'. -Qed. -#[local] -Hint Resolve Empty_set_minimal : core. - -Theorem Power_set_Inhabited : - forall X:Ensemble U, Inhabited (Ensemble U) (Power_set X). -intro X. -apply Inhabited_intro with (Empty_set U); auto with sets. -Qed. -#[local] -Hint Resolve Power_set_Inhabited : core. - -Theorem Inclusion_is_an_order : Order (Ensemble U) (Included U). -auto 6 with sets. -Qed. -#[local] -Hint Resolve Inclusion_is_an_order : core. - -Theorem Inclusion_is_transitive : Transitive (Ensemble U) (Included U). -elim Inclusion_is_an_order; auto with sets. -Qed. -#[local] -Hint Resolve Inclusion_is_transitive : core. - -Definition Power_set_PO : Ensemble U -> PO (Ensemble U). -intro A; try assumption. -apply Definition_of_PO with (Power_set A) (Included U); auto with sets. -Defined. -#[local] -Hint Unfold Power_set_PO : core. - -Theorem Strict_Rel_is_Strict_Included : - same_relation (Ensemble U) (Strict_Included U) - (Strict_Rel_of (Ensemble U) (Power_set_PO (Full_set U))). -auto with sets. -Qed. -#[local] -Hint Resolve Strict_Rel_Transitive Strict_Rel_is_Strict_Included : core. - -Lemma Strict_inclusion_is_transitive_with_inclusion : - forall x y z:Ensemble U, - Strict_Included U x y -> Included U y z -> Strict_Included U x z. -intros x y z H' H'0; try assumption. -elim Strict_Rel_is_Strict_Included. -unfold contains. -intros H'1 H'2; try assumption. -apply H'1. -apply Strict_Rel_Transitive_with_Rel with (y := y); auto with sets. -Qed. - -Lemma Strict_inclusion_is_transitive_with_inclusion_left : - forall x y z:Ensemble U, - Included U x y -> Strict_Included U y z -> Strict_Included U x z. -intros x y z H' H'0; try assumption. -elim Strict_Rel_is_Strict_Included. -unfold contains. -intros H'1 H'2; try assumption. -apply H'1. -apply Strict_Rel_Transitive_with_Rel_left with (y := y); auto with sets. -Qed. - -Lemma Strict_inclusion_is_transitive : - Transitive (Ensemble U) (Strict_Included U). -apply cong_transitive_same_relation with - (R := Strict_Rel_of (Ensemble U) (Power_set_PO (Full_set U))); - auto with sets. -Qed. - -Theorem Empty_set_is_Bottom : - forall A:Ensemble U, Bottom (Ensemble U) (Power_set_PO A) (Empty_set U). -intro A; apply Bottom_definition; simpl; auto with sets. -Qed. -#[local] -Hint Resolve Empty_set_is_Bottom : core. - -Theorem Union_minimal : - forall a b X:Ensemble U, - Included U a X -> Included U b X -> Included U (Union U a b) X. -intros a b X H' H'0; red. -intros x H'1; elim H'1; auto with sets. -Qed. -#[local] -Hint Resolve Union_minimal : core. - -Theorem Intersection_maximal : - forall a b X:Ensemble U, - Included U X a -> Included U X b -> Included U X (Intersection U a b). -auto with sets. -Qed. - -Theorem Union_increases_l : forall a b:Ensemble U, Included U a (Union U a b). -auto with sets. -Qed. - -Theorem Union_increases_r : forall a b:Ensemble U, Included U b (Union U a b). -auto with sets. -Qed. - -Theorem Intersection_decreases_l : - forall a b:Ensemble U, Included U (Intersection U a b) a. -intros a b; red. -intros x H'; elim H'; auto with sets. -Qed. - -Theorem Intersection_decreases_r : - forall a b:Ensemble U, Included U (Intersection U a b) b. -intros a b; red. -intros x H'; elim H'; auto with sets. -Qed. -#[local] -Hint Resolve Union_increases_l Union_increases_r Intersection_decreases_l - Intersection_decreases_r : core. - -Theorem Union_is_Lub : - forall A a b:Ensemble U, - Included U a A -> - Included U b A -> - Lub (Ensemble U) (Power_set_PO A) (Couple (Ensemble U) a b) (Union U a b). -intros A a b H' H'0. -apply Lub_definition; simpl. -- apply Upper_Bound_definition; simpl; auto with sets. - intros y H'1; elim H'1; auto with sets. -- intros y H'1; elim H'1; simpl; auto with sets. -Qed. - -Theorem Intersection_is_Glb : - forall A a b:Ensemble U, - Included U a A -> - Included U b A -> - Glb (Ensemble U) (Power_set_PO A) (Couple (Ensemble U) a b) - (Intersection U a b). -intros A a b H' H'0. -apply Glb_definition; simpl. -- apply Lower_Bound_definition; simpl; auto with sets. - + apply Definition_of_Power_set. - generalize Inclusion_is_transitive; intro IT; red in IT; apply IT with a; - auto with sets. - + intros y H'1; elim H'1; auto with sets. -- intros y H'1; elim H'1; simpl; auto with sets. -Qed. - -End The_power_set_partial_order. - -#[global] -Hint Resolve Empty_set_minimal: sets. -#[global] -Hint Resolve Power_set_Inhabited: sets. -#[global] -Hint Resolve Inclusion_is_an_order: sets. -#[global] -Hint Resolve Inclusion_is_transitive: sets. -#[global] -Hint Resolve Union_minimal: sets. -#[global] -Hint Resolve Union_increases_l: sets. -#[global] -Hint Resolve Union_increases_r: sets. -#[global] -Hint Resolve Intersection_decreases_l: sets. -#[global] -Hint Resolve Intersection_decreases_r: sets. -#[global] -Hint Resolve Empty_set_is_Bottom: sets. -#[global] -Hint Resolve Strict_inclusion_is_transitive: sets. diff --git a/stdlib/theories/Sets/Powerset_Classical_facts.v b/stdlib/theories/Sets/Powerset_Classical_facts.v deleted file mode 100644 index 609f41665af9..000000000000 --- a/stdlib/theories/Sets/Powerset_Classical_facts.v +++ /dev/null @@ -1,345 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* - Strict_Included U (Add U A x) (Add U B x) -> Strict_Included U A B. - Proof. - intros A B x H' H'0; red. - lapply (Strict_Included_inv U (Add U A x) (Add U B x)); auto with sets. - clear H'0; intro H'0; split. - - apply incl_add_x with (x := x); tauto. - - elim H'0; intros H'1 H'2; elim H'2; clear H'0 H'2. - intros x0 H'0. - red; intro H'2. - elim H'0; clear H'0. - rewrite <- H'2; auto with sets. - Qed. - - Lemma incl_soustr_in : - forall (X:Ensemble U) (x:U), In U X x -> Included U (Subtract U X x) X. - Proof. - intros X x H'; red. - intros x0 H'0; elim H'0; auto with sets. - Qed. - - Lemma incl_soustr : - forall (X Y:Ensemble U) (x:U), - Included U X Y -> Included U (Subtract U X x) (Subtract U Y x). - Proof. - intros X Y x H'; red. - intros x0 H'0; elim H'0. - intros H'1 H'2. - apply Subtract_intro; auto with sets. - Qed. - - Lemma incl_soustr_add_l : - forall (X:Ensemble U) (x:U), Included U (Subtract U (Add U X x) x) X. - Proof. - intros X x; red. - intros x0 H'; elim H'; auto with sets. - intro H'0; elim H'0; auto with sets. - intros t H'1 H'2; elim H'2; auto with sets. - Qed. - - Lemma incl_soustr_add_r : - forall (X:Ensemble U) (x:U), - ~ In U X x -> Included U X (Subtract U (Add U X x) x). - Proof. - intros X x H'; red. - intros x0 H'0; try assumption. - apply Subtract_intro; auto with sets. - red; intro H'1; apply H'; rewrite H'1; auto with sets. - Qed. - #[local] - Hint Resolve incl_soustr_add_r: sets. - - Lemma add_soustr_2 : - forall (X:Ensemble U) (x:U), - In U X x -> Included U X (Add U (Subtract U X x) x). - Proof. - intros X x H'; red. - intros x0 H'0; try assumption. - elim (classic (x = x0)); intro K; auto with sets. - elim K; auto with sets. - Qed. - - Lemma add_soustr_1 : - forall (X:Ensemble U) (x:U), - In U X x -> Included U (Add U (Subtract U X x) x) X. - Proof. - intros X x H'; red. - intros x0 H'0; elim H'0; auto with sets. - - intros y H'1; elim H'1; auto with sets. - - intros t H'1; try assumption. - rewrite <- (Singleton_inv U x t); auto with sets. - Qed. - - Lemma add_soustr_xy : - forall (X:Ensemble U) (x y:U), - x <> y -> Subtract U (Add U X x) y = Add U (Subtract U X y) x. - Proof. - intros X x y H'; apply Extensionality_Ensembles. - split; red. - - intros x0 H'0; elim H'0; auto with sets. - intro H'1; elim H'1. - + intros u H'2 H'3; try assumption. - apply Add_intro1. - apply Subtract_intro; auto with sets. - + intros t H'2 H'3; try assumption. - elim (Singleton_inv U x t); auto with sets. - - intros u H'2; try assumption. - elim (Add_inv U (Subtract U X y) x u); auto with sets. - + intro H'0; elim H'0; auto with sets. - + intro H'0; rewrite <- H'0; auto with sets. - Qed. - - Lemma incl_st_add_soustr : - forall (X Y:Ensemble U) (x:U), - ~ In U X x -> - Strict_Included U (Add U X x) Y -> Strict_Included U X (Subtract U Y x). - Proof. - intros X Y x H' H'0; apply sincl_add_x with (x := x); auto using add_soustr_1 with sets. - split. - - elim H'0. - intros H'1 H'2. - generalize (Inclusion_is_transitive U). - intro H'4; red in H'4. - apply H'4 with (y := Y); auto using add_soustr_2 with sets. - - red in H'0. - elim H'0; intros H'1 H'2; try exact H'1; clear H'0. (* PB *) - red; intro H'0; apply H'2. - rewrite H'0; auto 8 using add_soustr_xy, add_soustr_1, add_soustr_2 with sets. - Qed. - - Lemma Sub_Add_new : - forall (X:Ensemble U) (x:U), ~ In U X x -> X = Subtract U (Add U X x) x. - Proof. - auto using incl_soustr_add_l with sets. - Qed. - - Lemma Simplify_add : - forall (X X0:Ensemble U) (x:U), - ~ In U X x -> ~ In U X0 x -> Add U X x = Add U X0 x -> X = X0. - Proof. - intros X X0 x H' H'0 H'1; try assumption. - rewrite (Sub_Add_new X x); auto with sets. - rewrite (Sub_Add_new X0 x); auto with sets. - rewrite H'1; auto with sets. - Qed. - - Lemma Included_Add : - forall (X A:Ensemble U) (x:U), - Included U X (Add U A x) -> - Included U X A \/ (exists A' : _, X = Add U A' x /\ Included U A' A). - Proof. - intros X A x H'0; try assumption. - elim (classic (In U X x)). - - intro H'1; right; try assumption. - exists (Subtract U X x). - split; auto using incl_soustr_in, add_soustr_xy, add_soustr_1, add_soustr_2 with sets. - red in H'0. - red. - intros x0 H'2; try assumption. - lapply (Subtract_inv U X x x0); auto with sets. - intro H'3; elim H'3; intros K K'; clear H'3. - lapply (H'0 x0); auto with sets. - intro H'3; try assumption. - lapply (Add_inv U A x x0); auto with sets. - intro H'4; elim H'4; - [ intro H'5; try exact H'5; clear H'4 | intro H'5; clear H'4 ]. - elim K'; auto with sets. - - intro H'1; left; try assumption. - red in H'0. - red. - intros x0 H'2; try assumption. - lapply (H'0 x0); auto with sets. - intro H'3; try assumption. - lapply (Add_inv U A x x0); auto with sets. - intro H'4; elim H'4; - [ intro H'5; try exact H'5; clear H'4 | intro H'5; clear H'4 ]. - absurd (In U X x0); auto with sets. - rewrite <- H'5; auto with sets. - Qed. - - Lemma setcover_inv : - forall A x y:Ensemble U, - covers (Ensemble U) (Power_set_PO U A) y x -> - Strict_Included U x y /\ - (forall z:Ensemble U, Included U x z -> Included U z y -> x = z \/ z = y). - Proof. - intros A x y H'; elim H'. - unfold Strict_Rel_of; simpl. - intros H'0 H'1; split; [ auto with sets | idtac ]. - intros z H'2 H'3; try assumption. - elim (classic (x = z)); auto with sets. - intro H'4; right; try assumption. - elim (classic (z = y)); auto with sets. - intro H'5; try assumption. - elim H'1. - exists z; auto with sets. - Qed. - - Theorem Add_covers : - forall A a:Ensemble U, - Included U a A -> - forall x:U, - In U A x -> - ~ In U a x -> covers (Ensemble U) (Power_set_PO U A) (Add U a x) a. - Proof. - intros A a H' x H'0 H'1; try assumption. - apply setcover_intro; auto with sets. - - red. - split; [ idtac | red; intro H'2; try exact H'2 ]; auto with sets. - apply H'1. - rewrite H'2; auto with sets. - - red; intro H'2; elim H'2; clear H'2. - intros z H'2; elim H'2; intros H'3 H'4; try exact H'3; clear H'2. - lapply (Strict_Included_inv U a z); auto with sets; clear H'3. - intro H'2; elim H'2; intros H'3 H'5; elim H'5; clear H'2 H'5. - intros x0 H'2; elim H'2. - intros H'5 H'6; try assumption. - generalize H'4; intro K. - red in H'4. - elim H'4; intros H'8 H'9; red in H'8; clear H'4. - lapply (H'8 x0); auto with sets. - intro H'7; try assumption. - elim (Add_inv U a x x0); auto with sets. - intro H'15. - cut (Included U (Add U a x) z). - + intro H'10; try assumption. - red in K. - elim K; intros H'11 H'12; apply H'12; clear K; auto with sets. - + rewrite H'15. - red. - intros x1 H'10; elim H'10; auto with sets. - intros x2 H'11; elim H'11; auto with sets. - Qed. - - Theorem covers_Add : - forall A a a':Ensemble U, - Included U a A -> - Included U a' A -> - covers (Ensemble U) (Power_set_PO U A) a' a -> - exists x : _, a' = Add U a x /\ In U A x /\ ~ In U a x. - Proof. - intros A a a' H' H'0 H'1; try assumption. - elim (setcover_inv A a a'); auto with sets. - intros H'6 H'7. - clear H'1. - elim (Strict_Included_inv U a a'); auto with sets. - intros H'5 H'8; elim H'8. - intros x H'1; elim H'1. - intros H'2 H'3; try assumption. - exists x. - split; [ try assumption | idtac ]. - - clear H'8 H'1. - elim (H'7 (Add U a x)); auto with sets. - + intro H'1. - absurd (a = Add U a x); auto with sets. - red; intro H'8; try exact H'8. - apply H'3. - rewrite H'8; auto with sets. - + auto with sets. - red. - intros x0 H'1; elim H'1; auto with sets. - intros x1 H'8; elim H'8; auto with sets. - - split; [ idtac | try assumption ]. - red in H'0; auto with sets. - Qed. - - Theorem covers_is_Add : - forall A a a':Ensemble U, - Included U a A -> - Included U a' A -> - (covers (Ensemble U) (Power_set_PO U A) a' a <-> - (exists x : _, a' = Add U a x /\ In U A x /\ ~ In U a x)). - Proof. - intros A a a' H' H'0; split; intro K. - - apply covers_Add with (A := A); auto with sets. - - elim K. - intros x H'1; elim H'1; intros H'2 H'3; rewrite H'2; clear H'1. - apply Add_covers; intuition. - Qed. - - Theorem Singleton_atomic : - forall (x:U) (A:Ensemble U), - In U A x -> - covers (Ensemble U) (Power_set_PO U A) (Singleton U x) (Empty_set U). - Proof. - intros x A H'. - rewrite <- (Empty_set_zero' U x). - apply Add_covers; auto with sets. - Qed. - - Lemma less_than_singleton : - forall (X:Ensemble U) (x:U), - Strict_Included U X (Singleton U x) -> X = Empty_set U. - Proof. - intros X x H'; try assumption. - red in H'. - lapply (Singleton_atomic x (Full_set U)); - [ intro H'2; try exact H'2 | apply Full_intro ]. - elim H'; intros H'0 H'1; try exact H'1; clear H'. - elim (setcover_inv (Full_set U) (Empty_set U) (Singleton U x)); - [ intros H'6 H'7; try exact H'7 | idtac ]; auto with sets. - elim (H'7 X); [ intro H'5; try exact H'5 | intro H'5 | idtac | idtac ]; - auto with sets. - elim H'1; auto with sets. - Qed. - -End Sets_as_an_algebra. - -#[global] -Hint Resolve incl_soustr_in: sets. -#[global] -Hint Resolve incl_soustr: sets. -#[global] -Hint Resolve incl_soustr_add_l: sets. -#[global] -Hint Resolve incl_soustr_add_r: sets. -#[global] -Hint Resolve add_soustr_1 add_soustr_2: sets. -#[global] -Hint Resolve add_soustr_xy: sets. diff --git a/stdlib/theories/Sets/Powerset_facts.v b/stdlib/theories/Sets/Powerset_facts.v deleted file mode 100644 index 8049f017f51c..000000000000 --- a/stdlib/theories/Sets/Powerset_facts.v +++ /dev/null @@ -1,355 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* X = Empty_set U. - Proof. - auto with sets. - Qed. - - Theorem Union_commutative : forall A B:Ensemble U, Union U A B = Union U B A. - Proof. - auto with sets. - Qed. - - Theorem Union_associative : - forall A B C:Ensemble U, Union U (Union U A B) C = Union U A (Union U B C). - Proof. - auto 9 with sets. - Qed. - - Theorem Union_idempotent : forall A:Ensemble U, Union U A A = A. - Proof. - auto 7 with sets. - Qed. - - Lemma Union_absorbs : - forall A B:Ensemble U, Included U B A -> Union U A B = A. - Proof. - auto 7 with sets. - Qed. - - Theorem Couple_as_union : - forall x y:U, Union U (Singleton U x) (Singleton U y) = Couple U x y. - Proof. - intros x y; apply Extensionality_Ensembles; split; red. - - intros x0 H'; elim H'; (intros x1 H'0; elim H'0; auto with sets). - - intros x0 H'; elim H'; auto with sets. - Qed. - - Theorem Triple_as_union : - forall x y z:U, - Union U (Union U (Singleton U x) (Singleton U y)) (Singleton U z) = - Triple U x y z. - Proof. - intros x y z; apply Extensionality_Ensembles; split; red. - - intros x0 H'; elim H'. - + intros x1 H'0; elim H'0; (intros x2 H'1; elim H'1; auto with sets). - + intros x1 H'0; elim H'0; auto with sets. - - intros x0 H'; elim H'; auto with sets. - Qed. - - Theorem Triple_as_Couple : forall x y:U, Couple U x y = Triple U x x y. - Proof. - intros x y. - rewrite <- (Couple_as_union x y). - rewrite <- (Union_idempotent (Singleton U x)). - apply Triple_as_union. - Qed. - - Theorem Triple_as_Couple_Singleton : - forall x y z:U, Triple U x y z = Union U (Couple U x y) (Singleton U z). - Proof. - intros x y z. - rewrite <- (Triple_as_union x y z). - rewrite <- (Couple_as_union x y); auto with sets. - Qed. - - Theorem Intersection_commutative : - forall A B:Ensemble U, Intersection U A B = Intersection U B A. - Proof. - intros A B. - apply Extensionality_Ensembles. - split; red; intros x H'; elim H'; auto with sets. - Qed. - - Theorem Distributivity : - forall A B C:Ensemble U, - Intersection U A (Union U B C) = - Union U (Intersection U A B) (Intersection U A C). - Proof. - intros A B C. - apply Extensionality_Ensembles. - split; red; intros x H'. - - elim H'. - intros x0 H'0 H'1; generalize H'0. - elim H'1; auto with sets. - - elim H'; intros x0 H'0; elim H'0; auto with sets. - Qed. - - Lemma Distributivity_l - : forall (A B C : Ensemble U), - Intersection U (Union U A B) C = - Union U (Intersection U A C) (Intersection U B C). - Proof. - intros A B C. - rewrite Intersection_commutative. - rewrite Distributivity. - f_equal; apply Intersection_commutative. - Qed. - - Theorem Distributivity' : - forall A B C:Ensemble U, - Union U A (Intersection U B C) = - Intersection U (Union U A B) (Union U A C). - Proof. - intros A B C. - apply Extensionality_Ensembles. - split; red; intros x H'. - - elim H'; auto with sets. - intros x0 H'0; elim H'0; auto with sets. - - elim H'. - intros x0 H'0; elim H'0; auto with sets. - intros x1 H'1 H'2; try exact H'2. - generalize H'1. - elim H'2; auto with sets. - Qed. - - Theorem Union_add : - forall (A B:Ensemble U) (x:U), Add U (Union U A B) x = Union U A (Add U B x). - Proof. - unfold Add; auto using Union_associative with sets. - Qed. - - Theorem Non_disjoint_union : - forall (X:Ensemble U) (x:U), In U X x -> Add U X x = X. - Proof. - intros X x H'; unfold Add. - apply Extensionality_Ensembles; red. - split; red; auto with sets. - intros x0 H'0; elim H'0; auto with sets. - intros t H'1; elim H'1; auto with sets. - Qed. - - Theorem Non_disjoint_union' : - forall (X:Ensemble U) (x:U), ~ In U X x -> Subtract U X x = X. - Proof. - intros X x H'; unfold Subtract. - apply Extensionality_Ensembles. - split; red; auto with sets. - - intros x0 H'0; elim H'0; auto with sets. - - intros x0 H'0; apply Setminus_intro; auto with sets. - red; intro H'1; elim H'1. - lapply (Singleton_inv U x x0); auto with sets. - intro H'4; apply H'; rewrite H'4; auto with sets. - Qed. - - Lemma singlx : forall x y:U, In U (Add U (Empty_set U) x) y -> x = y. - Proof. - intro x; rewrite (Empty_set_zero' x); auto with sets. - Qed. - - Lemma incl_add : - forall (A B:Ensemble U) (x:U), - Included U A B -> Included U (Add U A x) (Add U B x). - Proof. - intros A B x H'; red; auto with sets. - intros x0 H'0. - lapply (Add_inv U A x x0); auto with sets. - intro H'1; elim H'1; - [ intro H'2; clear H'1 | intro H'2; rewrite <- H'2; clear H'1 ]; - auto with sets. - Qed. - - Lemma incl_add_x : - forall (A B:Ensemble U) (x:U), - ~ In U A x -> Included U (Add U A x) (Add U B x) -> Included U A B. - Proof. - unfold Included. - intros A B x H' H'0 x0 H'1. - lapply (H'0 x0); auto with sets. - intro H'2; lapply (Add_inv U B x x0); auto with sets. - intro H'3; elim H'3; - [ intro H'4; try exact H'4; clear H'3 | intro H'4; clear H'3 ]. - absurd (In U A x0); auto with sets. - rewrite <- H'4; auto with sets. - Qed. - - Lemma Add_commutative : - forall (A:Ensemble U) (x y:U), Add U (Add U A x) y = Add U (Add U A y) x. - Proof. - intros A x y. - unfold Add. - rewrite (Union_associative A (Singleton U x) (Singleton U y)). - rewrite (Union_commutative (Singleton U x) (Singleton U y)). - rewrite <- (Union_associative A (Singleton U y) (Singleton U x)); - auto with sets. - Qed. - - Lemma Add_commutative' : - forall (A:Ensemble U) (x y z:U), - Add U (Add U (Add U A x) y) z = Add U (Add U (Add U A z) x) y. - Proof. - intros A x y z. - rewrite (Add_commutative (Add U A x) y z). - rewrite (Add_commutative A x z); auto with sets. - Qed. - - Lemma Add_distributes : - forall (A B:Ensemble U) (x y:U), - Included U B A -> Add U (Add U A x) y = Union U (Add U A x) (Add U B y). - Proof. - intros A B x y H'; try assumption. - rewrite <- (Union_add (Add U A x) B y). - unfold Add at 4. - rewrite (Union_commutative A (Singleton U x)). - rewrite Union_associative. - rewrite (Union_absorbs A B H'). - rewrite (Union_commutative (Singleton U x) A). - auto with sets. - Qed. - - Lemma setcover_intro : - forall (U:Type) (A x y:Ensemble U), - Strict_Included U x y -> - ~ (exists z : _, Strict_Included U x z /\ Strict_Included U z y) -> - covers (Ensemble U) (Power_set_PO U A) y x. - Proof. - intros; apply Definition_of_covers; auto with sets. - Qed. - - Lemma Disjoint_Intersection: - forall A s1 s2, Disjoint A s1 s2 -> Intersection A s1 s2 = Empty_set A. - Proof. - intros. apply Extensionality_Ensembles. split. - * destruct H. - intros x H1. unfold In in *. exfalso. intuition. apply (H _ H1). - * intuition. - Qed. - - Lemma Intersection_Empty_set_l: - forall A s, Intersection A (Empty_set A) s = Empty_set A. - Proof. - intros. auto with sets. - Qed. - - Lemma Intersection_Empty_set_r: - forall A s, Intersection A s (Empty_set A) = Empty_set A. - Proof. - intros. auto with sets. - Qed. - - Lemma Seminus_Empty_set_l: - forall A s, Setminus A (Empty_set A) s = Empty_set A. - Proof. - intros. apply Extensionality_Ensembles. split. - * intros x H1. destruct H1. unfold In in *. assumption. - * intuition. - Qed. - - Lemma Seminus_Empty_set_r: - forall A s, Setminus A s (Empty_set A) = s. - Proof. - intros. apply Extensionality_Ensembles. split. - * intros x H1. destruct H1. unfold In in *. assumption. - * intuition. - Qed. - - Lemma Setminus_Union_l: - forall A s1 s2 s3, - Setminus A (Union A s1 s2) s3 = Union A (Setminus A s1 s3) (Setminus A s2 s3). - Proof. - intros. apply Extensionality_Ensembles. split. - * intros x H. inversion H. inversion H0; intuition. - * intros x H. constructor; inversion H; inversion H0; intuition. - Qed. - - Lemma Setminus_Union_r: - forall A s1 s2 s3, - Setminus A s1 (Union A s2 s3) = Setminus A (Setminus A s1 s2) s3. - Proof. - intros. apply Extensionality_Ensembles. split. - * intros x H. inversion H. constructor. - -- intuition. - -- contradict H1. intuition. - * intros x H. inversion H. inversion H0. constructor; intuition. inversion H4; intuition. - Qed. - - Lemma Setminus_Disjoint_noop: - forall A s1 s2, - Intersection A s1 s2 = Empty_set A -> Setminus A s1 s2 = s1. - Proof. - intros. apply Extensionality_Ensembles. split. - * intros x H1. inversion_clear H1. intuition. - * intros x H1. constructor; intuition. contradict H. - apply Inhabited_not_empty. - exists x. intuition. - Qed. - - Lemma Setminus_Included_empty: - forall A s1 s2, - Included A s1 s2 -> Setminus A s1 s2 = Empty_set A. - Proof. - intros. apply Extensionality_Ensembles. split. - * intros x H1. inversion_clear H1. contradiction H2. intuition. - * intuition. - Qed. - -End Sets_as_an_algebra. - -#[global] -Hint Resolve Empty_set_zero Empty_set_zero' Union_associative Union_add - singlx incl_add: sets. diff --git a/stdlib/theories/Sets/Relations_1.v b/stdlib/theories/Sets/Relations_1.v deleted file mode 100644 index e88e2343c08d..000000000000 --- a/stdlib/theories/Sets/Relations_1.v +++ /dev/null @@ -1,69 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* U -> Prop. - Variable R : Relation. - - Definition Reflexive : Prop := forall x:U, R x x. - - Definition Transitive : Prop := forall x y z:U, R x y -> R y z -> R x z. - - Definition Symmetric : Prop := forall x y:U, R x y -> R y x. - - Definition Antisymmetric : Prop := forall x y:U, R x y -> R y x -> x = y. - - Definition contains (R R':Relation) : Prop := - forall x y:U, R' x y -> R x y. - - Definition same_relation (R R':Relation) : Prop := - contains R R' /\ contains R' R. - - Inductive Preorder : Prop := - Definition_of_preorder : Reflexive -> Transitive -> Preorder. - - Inductive Order : Prop := - Definition_of_order : - Reflexive -> Transitive -> Antisymmetric -> Order. - - Inductive Equivalence : Prop := - Definition_of_equivalence : - Reflexive -> Transitive -> Symmetric -> Equivalence. - - Inductive PER : Prop := - Definition_of_PER : Symmetric -> Transitive -> PER. - -End Relations_1. -#[global] -Hint Unfold Reflexive Transitive Antisymmetric Symmetric contains - same_relation: sets. -#[global] -Hint Resolve Definition_of_preorder Definition_of_order - Definition_of_equivalence Definition_of_PER: sets. diff --git a/stdlib/theories/Sets/Relations_1_facts.v b/stdlib/theories/Sets/Relations_1_facts.v deleted file mode 100644 index d19ce2fe26b4..000000000000 --- a/stdlib/theories/Sets/Relations_1_facts.v +++ /dev/null @@ -1,118 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* ~ R x y. - -Theorem Rsym_imp_notRsym : - forall (U:Type) (R:Relation U), - Symmetric U R -> Symmetric U (Complement U R). -Proof. -unfold Symmetric, Complement. -intros U R H' x y H'0; red; intro H'1; apply H'0; auto with sets. -Qed. - -Theorem Equiv_from_preorder : - forall (U:Type) (R:Relation U), - Preorder U R -> Equivalence U (fun x y:U => R x y /\ R y x). -Proof. -intros U R H'; elim H'; intros H'0 H'1. -apply Definition_of_equivalence. -- red in H'0; auto 10 with sets. -- red in H'1; red; auto 10 with sets. - intros x y z h; elim h; intros H'3 H'4; clear h. - intro h; elim h; intros H'5 H'6; clear h. - split; apply H'1 with y; auto 10 with sets. -- red; intros x y h; elim h; intros H'3 H'4; auto 10 with sets. -Qed. -#[global] -Hint Resolve Equiv_from_preorder : core. - -Theorem Equiv_from_order : - forall (U:Type) (R:Relation U), - Order U R -> Equivalence U (fun x y:U => R x y /\ R y x). -Proof. -intros U R H'; elim H'; auto 10 with sets. -Qed. -#[global] -Hint Resolve Equiv_from_order : core. - -Theorem contains_is_preorder : - forall U:Type, Preorder (Relation U) (contains U). -Proof. -auto 10 with sets. -Qed. -#[global] -Hint Resolve contains_is_preorder : core. - -Theorem same_relation_is_equivalence : - forall U:Type, Equivalence (Relation U) (same_relation U). -Proof. -unfold same_relation at 1; auto 10 with sets. -Qed. -#[global] -Hint Resolve same_relation_is_equivalence : core. - -Theorem cong_reflexive_same_relation : - forall (U:Type) (R R':Relation U), - same_relation U R R' -> Reflexive U R -> Reflexive U R'. -Proof. -unfold same_relation; intuition. -Qed. - -Theorem cong_symmetric_same_relation : - forall (U:Type) (R R':Relation U), - same_relation U R R' -> Symmetric U R -> Symmetric U R'. -Proof. - compute; intros; elim H; intros; clear H; - apply (H3 y x (H0 x y (H2 x y H1))). -(*Intuition.*) -Qed. - -Theorem cong_antisymmetric_same_relation : - forall (U:Type) (R R':Relation U), - same_relation U R R' -> Antisymmetric U R -> Antisymmetric U R'. -Proof. - compute; intros; elim H; intros; clear H; - apply (H0 x y (H3 x y H1) (H3 y x H2)). -(*Intuition.*) -Qed. - -Theorem cong_transitive_same_relation : - forall (U:Type) (R R':Relation U), - same_relation U R R' -> Transitive U R -> Transitive U R'. -Proof. -intros U R R' H' H'0; red. -elim H'. -intros H'1 H'2 x y z H'3 H'4; apply H'2. -apply H'0 with y; auto with sets. -Qed. diff --git a/stdlib/theories/Sets/Relations_2.v b/stdlib/theories/Sets/Relations_2.v deleted file mode 100644 index 7913dcd8840f..000000000000 --- a/stdlib/theories/Sets/Relations_2.v +++ /dev/null @@ -1,60 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* Prop := - | Rstar_0 : Rstar x x - | Rstar_n : forall y z:U, R x y -> Rstar y z -> Rstar x z. - -Inductive Rstar1 (x:U) : U -> Prop := - | Rstar1_0 : Rstar1 x x - | Rstar1_1 : forall y:U, R x y -> Rstar1 x y - | Rstar1_n : forall y z:U, Rstar1 x y -> Rstar1 y z -> Rstar1 x z. - -Inductive Rplus (x:U) : U -> Prop := - | Rplus_0 : forall y:U, R x y -> Rplus x y - | Rplus_n : forall y z:U, R x y -> Rplus y z -> Rplus x z. - -Definition Strongly_confluent : Prop := - forall x a b:U, R x a -> R x b -> ex (fun z:U => R a z /\ R b z). - -End Relations_2. - -#[global] -Hint Resolve Rstar_0: sets. -#[global] -Hint Resolve Rstar1_0: sets. -#[global] -Hint Resolve Rstar1_1: sets. -#[global] -Hint Resolve Rplus_0: sets. diff --git a/stdlib/theories/Sets/Relations_2_facts.v b/stdlib/theories/Sets/Relations_2_facts.v deleted file mode 100644 index 2fefa4c71cb8..000000000000 --- a/stdlib/theories/Sets/Relations_2_facts.v +++ /dev/null @@ -1,153 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* x = y \/ (exists u : _, R x u /\ Rstar U R u y). -Proof. -intros U R x y H'; elim H'; auto with sets. -intros x0 y0 z H'0 H'1 H'2; right; exists y0; auto with sets. -Qed. - -Theorem Rstar_equiv_Rstar1 : - forall (U:Type) (R:Relation U), same_relation U (Rstar U R) (Rstar1 U R). -Proof. -generalize Rstar_contains_R; intro T; red in T. -intros U R; unfold same_relation, contains. -split; intros x y H'; elim H'; auto with sets. -- generalize Rstar_transitive; intro T1; red in T1. - intros x0 y0 z H'0 H'1 H'2 H'3; apply T1 with y0; auto with sets. -- intros x0 y0 z H'0 H'1 H'2; apply Rstar1_n with y0; auto with sets. -Qed. - -Theorem Rsym_imp_Rstarsym : - forall (U:Type) (R:Relation U), Symmetric U R -> Symmetric U (Rstar U R). -Proof. -intros U R H'; red. -intros x y H'0; elim H'0; auto with sets. -intros x0 y0 z H'1 H'2 H'3. -generalize Rstar_transitive; intro T1; red in T1. -apply T1 with y0; auto with sets. -apply Rstar_n with x0; auto with sets. -Qed. - -Theorem Sstar_contains_Rstar : - forall (U:Type) (R S:Relation U), - contains U (Rstar U S) R -> contains U (Rstar U S) (Rstar U R). -Proof. -unfold contains. -intros U R S H' x y H'0; elim H'0; auto with sets. -generalize Rstar_transitive; intro T1; red in T1. -intros x0 y0 z H'1 H'2 H'3; apply T1 with y0; auto with sets. -Qed. - -Theorem star_monotone : - forall (U:Type) (R S:Relation U), - contains U S R -> contains U (Rstar U S) (Rstar U R). -Proof. -intros U R S H'. -apply Sstar_contains_Rstar; auto with sets. -generalize (Rstar_contains_R U S); auto with sets. -Qed. - -Theorem RstarRplus_RRstar : - forall (U:Type) (R:Relation U) (x y z:U), - Rstar U R x y -> Rplus U R y z -> exists u : _, R x u /\ Rstar U R u z. -Proof. -generalize Rstar_contains_Rplus; intro T; red in T. -generalize Rstar_transitive; intro T1; red in T1. -intros U R x y z H'; elim H'. -- intros x0 H'0; elim H'0. - + intros x1 y0 H'1; exists y0; auto with sets. - + intros x1 y0 z0 H'1 H'2 H'3; exists y0; auto with sets. -- intros x0 y0 z0 H'0 H'1 H'2 H'3; exists y0. - split; [ try assumption | idtac ]. - apply T1 with z0; auto with sets. -Qed. - -Theorem Lemma1 : - forall (U:Type) (R:Relation U), - Strongly_confluent U R -> - forall x b:U, - Rstar U R x b -> - forall a:U, R x a -> exists z : _, Rstar U R a z /\ R b z. -Proof. -intros U R H' x b H'0; elim H'0. -- intros x0 a H'1; exists a; auto with sets. -- intros x0 y z H'1 H'2 H'3 a H'4. - red in H'. - specialize H' with (x := x0) (a := a) (b := y); lapply H'; - [ intro H'8; lapply H'8; - [ intro H'9; try exact H'9; clear H'8 H' | clear H'8 H' ] - | clear H' ]; auto with sets. - elim H'9. - intros t H'5; elim H'5; intros H'6 H'7; try exact H'6; clear H'5. - elim (H'3 t); auto with sets. - intros z1 H'5; elim H'5; intros H'8 H'10; try exact H'8; clear H'5. - exists z1; split; [ idtac | assumption ]. - apply Rstar_n with t; auto with sets. -Qed. diff --git a/stdlib/theories/Sets/Relations_3.v b/stdlib/theories/Sets/Relations_3.v deleted file mode 100644 index 7328f2c3dfe9..000000000000 --- a/stdlib/theories/Sets/Relations_3.v +++ /dev/null @@ -1,67 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* R x z -> coherent y z. - - Definition Locally_confluent : Prop := forall x:U, locally_confluent x. - - Definition confluent (x:U) : Prop := - forall y z:U, Rstar U R x y -> Rstar U R x z -> coherent y z. - - Definition Confluent : Prop := forall x:U, confluent x. - - Inductive noetherian (x: U) : Prop := - definition_of_noetherian : - (forall y:U, R x y -> noetherian y) -> noetherian x. - - Definition Noetherian : Prop := forall x:U, noetherian x. - -End Relations_3. -#[global] -Hint Unfold coherent: sets. -#[global] -Hint Unfold locally_confluent: sets. -#[global] -Hint Unfold confluent: sets. -#[global] -Hint Unfold Confluent: sets. -#[global] -Hint Resolve definition_of_noetherian: sets. -#[global] -Hint Unfold Noetherian: sets. diff --git a/stdlib/theories/Sets/Relations_3_facts.v b/stdlib/theories/Sets/Relations_3_facts.v deleted file mode 100644 index 762a18586b51..000000000000 --- a/stdlib/theories/Sets/Relations_3_facts.v +++ /dev/null @@ -1,172 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* coherent U R x y. -Proof. -intros U R x y H'; red. -exists y; auto with sets. -Qed. -#[global] -Hint Resolve Rstar_imp_coherent : core. - -Theorem coherent_symmetric : - forall (U:Type) (R:Relation U), Symmetric U (coherent U R). -Proof. -unfold coherent at 1. -intros U R; red. -intros x y H'; elim H'. -intros z H'0; exists z; tauto. -Qed. - -Theorem Strong_confluence : - forall (U:Type) (R:Relation U), Strongly_confluent U R -> Confluent U R. -Proof. -intros U R H'; red. -intro x; red; intros a b H'0. -unfold coherent at 1. -generalize b; clear b. -elim H'0; clear H'0. -- intros x0 b H'1; exists b; auto with sets. -- intros x0 y z H'1 H'2 H'3 b H'4. - generalize (Lemma1 U R); intro h; lapply h; - [ intro H'0; generalize (H'0 x0 b); intro h0; lapply h0; - [ intro H'5; generalize (H'5 y); intro h1; lapply h1; - [ intro h2; elim h2; intros z0 h3; elim h3; intros H'6 H'7; - clear h h0 h1 h2 h3 - | clear h h0 h1 ] - | clear h h0 ] - | clear h ]; auto with sets. - generalize (H'3 z0); intro h; lapply h; - [ intro h0; elim h0; intros z1 h1; elim h1; intros H'8 H'9; clear h h0 h1 - | clear h ]; auto with sets. - exists z1; split; auto with sets. - apply Rstar_n with z0; auto with sets. -Qed. - -Theorem Strong_confluence_direct : - forall (U:Type) (R:Relation U), Strongly_confluent U R -> Confluent U R. -Proof. -intros U R H'; red. -intro x; red; intros a b H'0. -unfold coherent at 1. -generalize b; clear b. -elim H'0; clear H'0. -- intros x0 b H'1; exists b; auto with sets. -- intros x0 y z H'1 H'2 H'3 b H'4. - cut (ex (fun t:U => Rstar U R y t /\ R b t)). - + intro h; elim h; intros t h0; elim h0; intros H'0 H'5; clear h h0. - generalize (H'3 t); intro h; lapply h; - [ intro h0; elim h0; intros z0 h1; elim h1; intros H'6 H'7; clear h h0 h1 - | clear h ]; auto with sets. - exists z0; split; [ assumption | idtac ]. - apply Rstar_n with t; auto with sets. - + generalize H'1; generalize y; clear H'1. - elim H'4. - * intros x1 y0 H'0; exists y0; auto with sets. - * intros x1 y0 z0 H'0 H'1 H'5 y1 H'6. - red in H'. - generalize (H' x1 y0 y1); intro h; lapply h; - [ intro H'7; lapply H'7; - [ intro h0; elim h0; intros z1 h1; elim h1; intros H'8 H'9; - clear h H'7 h0 h1 - | clear h ] - | clear h ]; auto with sets. - generalize (H'5 z1); intro h; lapply h; - [ intro h0; elim h0; intros t h1; elim h1; intros H'7 H'10; clear h h0 h1 - | clear h ]; auto with sets. - exists t; split; auto with sets. - apply Rstar_n with z1; auto with sets. -Qed. - -Theorem Noetherian_contains_Noetherian : - forall (U:Type) (R R':Relation U), - Noetherian U R -> contains U R R' -> Noetherian U R'. -Proof. -unfold Noetherian at 2. -intros U R R' H' H'0 x. -elim (H' x); auto with sets. -Qed. - -Theorem Newman : - forall (U:Type) (R:Relation U), - Noetherian U R -> Locally_confluent U R -> Confluent U R. -Proof. -intros U R H' H'0; red; intro x. -elim (H' x); unfold confluent. -intros x0 H'1 H'2 y z H'3 H'4. -generalize (Rstar_cases U R x0 y); intro h; lapply h; - [ intro h0; elim h0; - [ clear h h0; intro h1 - | intro h1; elim h1; intros u h2; elim h2; intros H'5 H'6; - clear h h0 h1 h2 ] - | clear h ]; auto with sets. -- elim h1; auto with sets. -- generalize (Rstar_cases U R x0 z); intro h; lapply h; - [ intro h0; elim h0; - [ clear h h0; intro h1 - | intro h1; elim h1; intros v h2; elim h2; intros H'7 H'8; - clear h h0 h1 h2 ] - | clear h ]; auto with sets. - + elim h1; generalize coherent_symmetric; intro t; red in t; auto with sets. - + unfold Locally_confluent, locally_confluent, coherent in H'0. - generalize (H'0 x0 u v); intro h; lapply h; - [ intro H'9; lapply H'9; - [ intro h0; elim h0; intros t h1; elim h1; intros H'10 H'11; - clear h H'9 h0 h1 - | clear h ] - | clear h ]; auto with sets. - clear H'0. - unfold coherent at 1 in H'2. - generalize (H'2 u); intro h; lapply h; - [ intro H'0; generalize (H'0 y t); intro h0; lapply h0; - [ intro H'9; lapply H'9; - [ intro h1; elim h1; intros y1 h2; elim h2; intros H'12 H'13; - clear h h0 H'9 h1 h2 - | clear h h0 ] - | clear h h0 ] - | clear h ]; auto with sets. - generalize Rstar_transitive; intro T; red in T. - generalize (H'2 v); intro h; lapply h; - [ intro H'9; generalize (H'9 y1 z); intro h0; lapply h0; - [ intro H'14; lapply H'14; - [ intro h1; elim h1; intros z1 h2; elim h2; intros H'15 H'16; - clear h h0 H'14 h1 h2 - | clear h h0 ] - | clear h h0 ] - | clear h ]; auto with sets. - * red; (exists z1; split); auto with sets. - apply T with y1; auto with sets. - * apply T with t; auto with sets. -Qed. diff --git a/stdlib/theories/Sets/Uniset.v b/stdlib/theories/Sets/Uniset.v deleted file mode 100644 index 554c939bd45d..000000000000 --- a/stdlib/theories/Sets/Uniset.v +++ /dev/null @@ -1,223 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* A -> Prop. -Hypothesis eqA_dec : forall x y:A, {eqA x y} + {~ eqA x y}. - -Inductive uniset : Set := - Charac : (A -> bool) -> uniset. - -Definition charac (s:uniset) (a:A) : bool := let (f) := s in f a. - -Definition Emptyset := Charac (fun a:A => false). - -Definition Fullset := Charac (fun a:A => true). - -Definition Singleton (a:A) := - Charac - (fun a':A => - match eqA_dec a a' with - | left h => true - | right h => false - end). - -Definition In (s:uniset) (a:A) : Prop := charac s a = true. -#[local] -Hint Unfold In : core. - -(** uniset inclusion *) -Definition incl (s1 s2:uniset) := forall a:A, Bool.le (charac s1 a) (charac s2 a). -#[local] -Hint Unfold incl : core. - -(** uniset equality *) -Definition seq (s1 s2:uniset) := forall a:A, charac s1 a = charac s2 a. -#[local] -Hint Unfold seq : core. - -Lemma le_refl : forall b, Bool.le b b. -Proof. -destruct b; simpl; auto. -Qed. -#[local] -Hint Resolve le_refl : core. - -Lemma incl_left : forall s1 s2:uniset, seq s1 s2 -> incl s1 s2. -Proof. -unfold incl; intros s1 s2 E a; elim (E a); auto. -Qed. - -Lemma incl_right : forall s1 s2:uniset, seq s1 s2 -> incl s2 s1. -Proof. -unfold incl; intros s1 s2 E a; elim (E a); auto. -Qed. - -Lemma seq_refl : forall x:uniset, seq x x. -Proof. -destruct x; unfold seq; auto. -Qed. -#[local] -Hint Resolve seq_refl : core. - -Lemma seq_trans : forall x y z:uniset, seq x y -> seq y z -> seq x z. -Proof. -unfold seq. -destruct x; destruct y; destruct z; simpl; intros. -rewrite H; auto. -Qed. - -Lemma seq_sym : forall x y:uniset, seq x y -> seq y x. -Proof. -unfold seq. -destruct x; destruct y; simpl; auto. -Qed. - -(** uniset union *) -Definition union (m1 m2:uniset) := - Charac (fun a:A => orb (charac m1 a) (charac m2 a)). - -Lemma union_empty_left : forall x:uniset, seq x (union Emptyset x). -Proof. -unfold seq; unfold union; simpl; auto. -Qed. -#[local] -Hint Resolve union_empty_left : core. - -Lemma union_empty_right : forall x:uniset, seq x (union x Emptyset). -Proof. -unfold seq; unfold union; simpl. -intros x a; rewrite (orb_b_false (charac x a)); auto. -Qed. -#[local] -Hint Resolve union_empty_right : core. - -Lemma union_comm : forall x y:uniset, seq (union x y) (union y x). -Proof. -unfold seq; unfold charac; unfold union. -destruct x; destruct y; auto with bool. -Qed. -#[local] -Hint Resolve union_comm : core. - -Lemma union_ass : - forall x y z:uniset, seq (union (union x y) z) (union x (union y z)). -Proof. -unfold seq; unfold union; unfold charac. -destruct x; destruct y; destruct z; auto with bool. -Qed. -#[local] -Hint Resolve union_ass : core. - -Lemma seq_left : forall x y z:uniset, seq x y -> seq (union x z) (union y z). -Proof. -unfold seq; unfold union; unfold charac. -destruct x; destruct y; destruct z. -intros; elim H; auto. -Qed. -#[local] -Hint Resolve seq_left : core. - -Lemma seq_right : forall x y z:uniset, seq x y -> seq (union z x) (union z y). -Proof. -unfold seq; unfold union; unfold charac. -destruct x; destruct y; destruct z. -intros; elim H; auto. -Qed. -#[local] -Hint Resolve seq_right : core. - - -(** All the proofs that follow duplicate [Multiset_of_A] *) - -(** Here we should make uniset an abstract datatype, by hiding [Charac], - [union], [charac]; all further properties are proved abstractly *) - -Lemma union_rotate : - forall x y z:uniset, seq (union x (union y z)) (union z (union x y)). -Proof. -intros; apply (op_rotate uniset union seq); auto. -exact seq_trans. -Qed. - -Lemma seq_congr : - forall x y z t:uniset, seq x y -> seq z t -> seq (union x z) (union y t). -Proof. -intros; apply (cong_congr uniset union seq); auto. -exact seq_trans. -Qed. - -Lemma union_perm_left : - forall x y z:uniset, seq (union x (union y z)) (union y (union x z)). -Proof. -intros; apply (perm_left uniset union seq); auto. -exact seq_trans. -Qed. - -Lemma uniset_twist1 : - forall x y z t:uniset, - seq (union x (union (union y z) t)) (union (union y (union x t)) z). -Proof. -intros; apply (twist uniset union seq); auto. -exact seq_trans. -Qed. - -Lemma uniset_twist2 : - forall x y z t:uniset, - seq (union x (union (union y z) t)) (union (union y (union x z)) t). -Proof. -intros; apply seq_trans with (union (union x (union y z)) t). -- apply seq_sym; apply union_ass. -- apply seq_left; apply union_perm_left. -Qed. - -(** specific for treesort *) - -Lemma treesort_twist1 : - forall x y z t u:uniset, - seq u (union y z) -> - seq (union x (union u t)) (union (union y (union x t)) z). -Proof. -intros; apply seq_trans with (union x (union (union y z) t)). -- apply seq_right; apply seq_left; trivial. -- apply uniset_twist1. -Qed. - -Lemma treesort_twist2 : - forall x y z t u:uniset, - seq u (union y z) -> - seq (union x (union u t)) (union (union y (union x z)) t). -Proof. -intros; apply seq_trans with (union x (union (union y z) t)). -- apply seq_right; apply seq_left; trivial. -- apply uniset_twist2. -Qed. - - -(*i theory of minter to do similarly -(* uniset intersection *) -Definition minter := [m1,m2:uniset] - (Charac [a:A](andb (charac m1 a)(charac m2 a))). -i*) - -End defs. - -Unset Implicit Arguments. diff --git a/stdlib/theories/Sorting/CPermutation.v b/stdlib/theories/Sorting/CPermutation.v deleted file mode 100644 index 710ad7dc6730..000000000000 --- a/stdlib/theories/Sorting/CPermutation.v +++ /dev/null @@ -1,288 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* list A -> Prop := -| cperm : forall l1 l2, CPermutation (l1 ++ l2) (l2 ++ l1). - -Instance CPermutation_Permutation : Proper (CPermutation ==> (@Permutation A)) id. -Proof. intros ? ? [? ?]; apply Permutation_app_comm. Qed. - -(** Some facts about [CPermutation] *) - -Theorem CPermutation_nil : forall l, CPermutation [] l -> l = []. -Proof. -intros l HC; inversion HC as [l1 l2 Heq]; subst. -now apply app_eq_nil in Heq; destruct Heq; subst. -Qed. - -Theorem CPermutation_nil_cons : forall l a, ~ CPermutation [] (a :: l). -Proof. intros l a HC; apply CPermutation_nil in HC; inversion HC. Qed. - -Theorem CPermutation_nil_app_cons : forall l1 l2 a, - ~ CPermutation [] (l1 ++ a ::l2). -Proof. -intros l1 l2 a HC; apply CPermutation_nil in HC; destruct l1; inversion HC. -Qed. - -Lemma CPermutation_split : forall l1 l2, - CPermutation l1 l2 <-> exists n, l2 = skipn n l1 ++ firstn n l1. -Proof. -intros l1 l2; split. -- intros [l1' l2']. - exists (length l1'). - rewrite skipn_app, skipn_all, Nat.sub_diag; simpl; f_equal. - now rewrite firstn_app, firstn_all, Nat.sub_diag; simpl; rewrite app_nil_r. -- now intros [n ->]; rewrite <- (firstn_skipn n) at 1. -Qed. - - -(** Equivalence relation *) - -Theorem CPermutation_refl : forall l, CPermutation l l. -Proof. -intros l; now rewrite <- (app_nil_l l) at 1; rewrite <- (app_nil_r l) at 2. -Qed. - -Instance CPermutation_refl' : Proper (Logic.eq ==> CPermutation) id. -Proof. intros ? ? ->; apply CPermutation_refl. Qed. - -Theorem CPermutation_sym : forall l l', CPermutation l l' -> CPermutation l' l. -Proof. now intros ? ? [? ?]. Qed. - -Theorem CPermutation_trans : forall l l' l'', - CPermutation l l' -> CPermutation l' l'' -> CPermutation l l''. -Proof. -intros l l' l'' HC1 HC2. -inversion HC1 as [l1 l2]; inversion HC2 as [l3 l4 Heq Heq']; subst. -clear - Heq; revert l1 l2 l4 Heq; clear; induction l3; simpl; intros. -- now subst; rewrite app_nil_r. -- destruct l2 as [| b]. - + simpl in Heq; subst. - now rewrite app_nil_r, app_comm_cons. - + inversion Heq as [[Heqb Heq']]; subst. - replace (l1 ++ b :: l2) with ((l1 ++ b :: nil) ++ l2) - by now rewrite <- app_assoc, <- app_comm_cons. - replace (l4 ++ b :: l3) with ((l4 ++ b :: nil) ++ l3) - by now rewrite <- app_assoc, <- app_comm_cons. - apply IHl3. - now rewrite 2 app_assoc, Heq'. -Qed. - -End CPermutation. - -#[global] -Hint Resolve CPermutation_refl : core. - -(* These hints do not reduce the size of the problem to solve and they - must be used with care to avoid combinatoric explosions *) - -Local Hint Resolve cperm CPermutation_sym CPermutation_trans : core. - -#[global] -Instance CPermutation_Equivalence A : Equivalence (@CPermutation A) | 10 := { - Equivalence_Reflexive := @CPermutation_refl A ; - Equivalence_Symmetric := @CPermutation_sym A ; - Equivalence_Transitive := @CPermutation_trans A }. - - -Section CPermutation_properties. - -Variable A B:Type. - -Implicit Types a b : A. -Implicit Types l : list A. - -(** Compatibility with others operations on lists *) - -Lemma CPermutation_app : forall l1 l2 l3, - CPermutation (l1 ++ l2) l3 -> CPermutation (l2 ++ l1) l3. -Proof. intros l1 l2 l3 HC; now transitivity (l1 ++ l2). Qed. - -Theorem CPermutation_app_comm : forall l1 l2, CPermutation (l1 ++ l2) (l2 ++ l1). -Proof. apply cperm. Qed. - -Lemma CPermutation_app_rot : forall l1 l2 l3, - CPermutation (l1 ++ l2 ++ l3) (l2 ++ l3 ++ l1). -Proof. intros l1 l2 l3; now rewrite (app_assoc l2). Qed. - -Lemma CPermutation_cons_append : forall l a, - CPermutation (a :: l) (l ++ [a]). -Proof. intros l a; now rewrite <- (app_nil_l l), app_comm_cons. Qed. - -Lemma CPermutation_morph_cons : forall P : list A -> Prop, - (forall a l, P (l ++ [a]) -> P (a :: l)) -> - Proper (@CPermutation A ==> iff) P. -Proof. -enough (forall P : list A -> Prop, - (forall a l, P (l ++ [a]) -> P (a :: l)) -> - forall l1 l2, CPermutation l1 l2 -> P l1 -> P l2) - as Himp - by now intros P HP l1 l2 HC; split; [ | symmetry in HC ]; apply Himp. -intros P HP l1 l2 [l1' l2']. -revert l1'; induction l2' using rev_ind; intros l1' HPl. -- now rewrite app_nil_r in HPl. -- rewrite app_assoc in HPl. - apply HP in HPl. - rewrite <- app_assoc, <- app_comm_cons, app_nil_l. - now apply IHl2'. -Qed. - -Lemma CPermutation_length_1 : forall a b, CPermutation [a] [b] -> a = b. -Proof. intros; now apply Permutation_length_1, CPermutation_Permutation. Qed. - -Lemma CPermutation_length_1_inv : forall a l, CPermutation [a] l -> l = [a]. -Proof. intros; now apply Permutation_length_1_inv, CPermutation_Permutation. Qed. - -Lemma CPermutation_swap : forall a b, CPermutation [a; b] [b; a]. -Proof. -intros; now change [a; b] with ([a] ++ [b]); change [b; a] with ([b] ++ [a]). -Qed. - -Lemma CPermutation_length_2 : forall a1 a2 b1 b2, - CPermutation [a1; a2] [b1; b2] -> - a1 = b1 /\ a2 = b2 \/ a1 = b2 /\ a2 = b1. -Proof. intros; now apply Permutation_length_2, CPermutation_Permutation. Qed. - -Lemma CPermutation_length_2_inv : forall a b l, - CPermutation [a; b] l -> l = [a; b] \/ l = [b; a]. -Proof. intros; now apply Permutation_length_2_inv, CPermutation_Permutation. Qed. - -Lemma CPermutation_vs_elt_inv : forall l l1 l2 a, - CPermutation l (l1 ++ a :: l2) -> - exists l' l'', l2 ++ l1 = l'' ++ l' /\ l = l' ++ a :: l''. -Proof. -intros l l1 l2 a HC. -inversion HC as [l1' l2' Heq' Heq]; clear HC; subst. -enough (exists l3, (l2' ++ l3 = l1 /\ l1' = l3 ++ a :: l2) - \/ (l2' = l1 ++ a :: l3 /\ l3 ++ l1' = l2)) - as [l3 [[<- ->]|[-> <-]]]. -- exists l3, (l2 ++ l2'); rewrite app_comm_cons; intuition. -- exists (l1' ++ l1), l3; intuition. -- revert l1' l2' l2 Heq; induction l1; simpl; intros l1' l2' l2 Heq. - + destruct l2'; inversion Heq; subst. - * exists nil; intuition. - * exists l2'; intuition. - + destruct l2'; inversion Heq; subst. - * exists (a0 :: l1); intuition. - * apply IHl1 in H1 as [l3 [[<- ->]|[-> <-]]]; exists l3; intuition. -Qed. - -Lemma CPermutation_vs_cons_inv : forall l l0 a, - CPermutation l (a :: l0) -> exists l' l'', l0 = l'' ++ l' /\ l = l' ++ a :: l''. -Proof. intros; rewrite <- (app_nil_r l0); now apply CPermutation_vs_elt_inv. Qed. - -End CPermutation_properties. - - -(** [rev], [in], [map], [Forall], [Exists], etc. *) - -Global Instance CPermutation_rev A : - Proper (@CPermutation A ==> @CPermutation A) (@rev A) | 10. -Proof. -intro l; induction l; intros l' HC. -- now apply CPermutation_nil in HC; subst. -- symmetry in HC. - destruct (CPermutation_vs_cons_inv HC) as [l1 [l2 [-> ->]]]. - simpl; rewrite ? rev_app_distr; simpl. - now rewrite <- app_assoc. -Qed. - -Global Instance CPermutation_in A a : - Proper (@CPermutation A ==> Basics.impl) (In a). -Proof. -intros l l' HC Hin. -now apply Permutation_in with l; [ apply CPermutation_Permutation | ]. -Qed. - -Global Instance CPermutation_in' A : - Proper (Logic.eq ==> @CPermutation A ==> iff) (@In A) | 10. -Proof. intros a a' <- l l' HC; split; now apply CPermutation_in. Qed. - -Global Instance CPermutation_map A B (f : A -> B) : - Proper (@CPermutation A ==> @CPermutation B) (map f) | 10. -Proof. now intros ? ? [l1 l2]; rewrite 2 map_app. Qed. - -Lemma CPermutation_map_inv A B : forall (f : A -> B) m l, - CPermutation m (map f l) -> exists l', m = map f l' /\ CPermutation l l'. -Proof. -induction m as [| b m]; intros l HC. -- exists nil; split; auto. - destruct l; auto. - apply CPermutation_nil in HC; inversion HC. -- symmetry in HC. - destruct (CPermutation_vs_cons_inv HC) as [m1 [m2 [-> Heq]]]. - apply map_eq_app in Heq as [l1 [l1' [-> [<- Heq]]]]. - apply map_eq_cons in Heq as [a [l1'' [-> [<- <-]]]]. - exists (a :: l1'' ++ l1); split. - + now simpl; rewrite map_app. - + now rewrite app_comm_cons. -Qed. - -Lemma CPermutation_image A B : forall (f : A -> B) a l l', - CPermutation (a :: l) (map f l') -> exists a', a = f a'. -Proof. -intros f a l l' HP. -now apply CPermutation_Permutation, Permutation_image in HP. -Qed. - -#[global] -Instance CPermutation_Forall A (P : A -> Prop) : - Proper (@CPermutation A ==> Basics.impl) (Forall P). -Proof. -intros ? ? [? ?] HF. -now apply Forall_app in HF; apply Forall_app. -Qed. - -#[global] -Instance CPermutation_Exists A (P : A -> Prop) : - Proper (@CPermutation A ==> Basics.impl) (Exists P). -Proof. -intros ? ? [? ?] HE. -apply Exists_app in HE; apply Exists_app; intuition. -Qed. - -Lemma CPermutation_Forall2 A B (P : A -> B -> Prop) : - forall l1 l1' l2, CPermutation l1 l1' -> Forall2 P l1 l2 -> exists l2', - CPermutation l2 l2' /\ Forall2 P l1' l2'. -Proof. -intros ? ? ? [? ?] HF. -apply Forall2_app_inv_l in HF as (l2' & l2'' & HF' & HF'' & ->). -exists (l2'' ++ l2'); intuition. -now apply Forall2_app. -Qed. - - -(** As an equivalence relation compatible with some operations, -[CPermutation] can be used through [rewrite]. *) -Example CPermutation_rewrite_rev A (l1 l2 l3: list A) : - CPermutation l1 l2 -> - CPermutation (rev l1) l3 -> CPermutation l3 (rev l2). -Proof. intros HP1 HP2; rewrite <- HP1, HP2; reflexivity. Qed. diff --git a/stdlib/theories/Sorting/Heap.v b/stdlib/theories/Sorting/Heap.v deleted file mode 100644 index 3ef9b1bc0440..000000000000 --- a/stdlib/theories/Sorting/Heap.v +++ /dev/null @@ -1,322 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* leA x y. - Hypothesis leA_trans : forall x y z:A, leA x y -> leA y z -> leA x z. - Hypothesis leA_antisym : forall x y:A, leA x y -> leA y x -> eqA x y. - - #[local] - Hint Resolve leA_refl : core. - #[local] - Hint Immediate eqA_dec leA_dec leA_antisym : core. - - Let emptyBag := EmptyBag A. - Let singletonBag := SingletonBag _ eqA_dec. - - Inductive Tree := - | Tree_Leaf : Tree - | Tree_Node : A -> Tree -> Tree -> Tree. - - (** [a] is lower than a Tree [T] if [T] is a Leaf - or [T] is a Node holding [b>a] *) - - #[deprecated(since="8.3", note="Use mergesort.v")] - Definition leA_Tree (a:A) (t:Tree) := - match t with - | Tree_Leaf => True - | Tree_Node b T1 T2 => leA a b - end. - - #[deprecated(since="8.3", note="Use mergesort.v")] - Lemma leA_Tree_Leaf : forall a:A, leA_Tree a Tree_Leaf. - Proof. - simpl; auto with datatypes. - Qed. - - #[deprecated(since="8.3", note="Use mergesort.v")] - Lemma leA_Tree_Node : - forall (a b:A) (G D:Tree), leA a b -> leA_Tree a (Tree_Node b G D). - Proof. - simpl; auto with datatypes. - Qed. - - - (** ** The heap property *) - - Inductive is_heap : Tree -> Prop := - | nil_is_heap : is_heap Tree_Leaf - | node_is_heap : - forall (a:A) (T1 T2:Tree), - leA_Tree a T1 -> - leA_Tree a T2 -> - is_heap T1 -> is_heap T2 -> is_heap (Tree_Node a T1 T2). - - #[deprecated(since="8.3", note="Use mergesort.v")] - Lemma invert_heap : - forall (a:A) (T1 T2:Tree), - is_heap (Tree_Node a T1 T2) -> - leA_Tree a T1 /\ leA_Tree a T2 /\ is_heap T1 /\ is_heap T2. - Proof. - intros; inversion H; auto with datatypes. - Qed. - - (* This lemma ought to be generated automatically by the Inversion tools *) - #[deprecated(since="8.3", note="Use mergesort.v")] - Lemma is_heap_rect : - forall P:Tree -> Type, - P Tree_Leaf -> - (forall (a:A) (T1 T2:Tree), - leA_Tree a T1 -> - leA_Tree a T2 -> - is_heap T1 -> P T1 -> is_heap T2 -> P T2 -> P (Tree_Node a T1 T2)) -> - forall T:Tree, is_heap T -> P T. - Proof. - simple induction T; auto with datatypes. - intros a G PG D PD PN. - elim (invert_heap a G D); auto with datatypes. - intros H1 H2; elim H2; intros H3 H4; elim H4; intros. - apply X0; auto with datatypes. - Qed. - - (* This lemma ought to be generated automatically by the Inversion tools *) - #[deprecated(since="8.3", note="Use mergesort.v")] - Lemma is_heap_rec : - forall P:Tree -> Set, - P Tree_Leaf -> - (forall (a:A) (T1 T2:Tree), - leA_Tree a T1 -> - leA_Tree a T2 -> - is_heap T1 -> P T1 -> is_heap T2 -> P T2 -> P (Tree_Node a T1 T2)) -> - forall T:Tree, is_heap T -> P T. - Proof. - simple induction T; auto with datatypes. - intros a G PG D PD PN. - elim (invert_heap a G D); auto with datatypes. - intros H1 H2; elim H2; intros H3 H4; elim H4; intros. - apply X; auto with datatypes. - Qed. - - #[deprecated(since="8.3", note="Use mergesort.v")] - Lemma low_trans : - forall (T:Tree) (a b:A), leA a b -> leA_Tree b T -> leA_Tree a T. - Proof. - simple induction T; auto with datatypes. - intros; simpl; apply leA_trans with b; auto with datatypes. - Qed. - - (** ** Merging two sorted lists *) - - Inductive merge_lem (l1 l2:list A) : Type := - merge_exist : - forall l:list A, - Sorted leA l -> - meq (list_contents _ eqA_dec l) - (munion (list_contents _ eqA_dec l1) (list_contents _ eqA_dec l2)) -> - (forall a, HdRel leA a l1 -> HdRel leA a l2 -> HdRel leA a l) -> - merge_lem l1 l2. - Import Morphisms. - - Instance: Equivalence (@meq A). - Proof. constructor; auto with datatypes. red. apply meq_trans. Defined. - - Instance: Proper (@meq A ++> @meq _ ++> @meq _) (@munion A). - Proof. intros x y H x' y' H'. now apply meq_congr. Qed. - - #[deprecated(since="8.3", note="Use mergesort.v")] - Lemma merge : - forall l1:list A, Sorted leA l1 -> - forall l2:list A, Sorted leA l2 -> merge_lem l1 l2. - Proof. - fix merge 1; intros; destruct l1. - - apply merge_exist with l2; auto with datatypes. - - rename l1 into l. - revert l2 H0. fix merge0 1. intros. - destruct l2 as [|a0 l0]. - + apply merge_exist with (a :: l); simpl; auto with datatypes. - + induction (leA_dec a a0) as [Hle|Hle]. - - * (* 1 (leA a a0) *) - apply Sorted_inv in H. destruct H. - destruct (merge l H (a0 :: l0) H0) as [l1 H2 H3 H4]. - apply merge_exist with (a :: l1). - -- clear merge merge0. - auto using cons_sort, cons_leA with datatypes. - -- simpl. rewrite H3. now rewrite munion_ass. - -- intros. apply cons_leA. - apply (@HdRel_inv _ leA) with l; trivial with datatypes. - - * (* 2 (leA a0 a) *) - apply Sorted_inv in H0. destruct H0. - destruct (merge0 l0 H0) as [l1 H2 H3 H4]. clear merge merge0. - apply merge_exist with (a0 :: l1); - auto using cons_sort, cons_leA with datatypes. - -- simpl; rewrite H3. simpl. setoid_rewrite munion_ass at 1. rewrite munion_comm. - repeat rewrite munion_ass. setoid_rewrite munion_comm at 3. reflexivity. - -- intros. apply cons_leA. - apply (@HdRel_inv _ leA) with l0; trivial with datatypes. - Qed. - - (** ** From trees to multisets *) - - (** contents of a tree as a multiset *) - - (** Nota Bene : In what follows the definition of SingletonBag - in not used. Actually, we could just take as postulate: - [Parameter SingletonBag : A->multiset]. *) - - #[deprecated(since="8.3", note="Use mergesort.v")] - Fixpoint contents (t:Tree) : multiset A := - match t with - | Tree_Leaf => emptyBag - | Tree_Node a t1 t2 => - munion (contents t1) (munion (contents t2) (singletonBag a)) - end. - - - (** equivalence of two trees is equality of corresponding multisets *) - #[deprecated(since="8.3", note="Use mergesort.v")] - Definition equiv_Tree (t1 t2:Tree) := meq (contents t1) (contents t2). - - - - (** * From lists to sorted lists *) - - (** ** Specification of heap insertion *) - - Inductive insert_spec (a:A) (T:Tree) : Type := - insert_exist : - forall T1:Tree, - is_heap T1 -> - meq (contents T1) (munion (contents T) (singletonBag a)) -> - (forall b:A, leA b a -> leA_Tree b T -> leA_Tree b T1) -> - insert_spec a T. - - - #[deprecated(since="8.3", note="Use mergesort.v")] - Lemma insert : forall T:Tree, is_heap T -> forall a:A, insert_spec a T. - Proof. - simple induction 1; intros. - - apply insert_exist with (Tree_Node a Tree_Leaf Tree_Leaf); - auto using node_is_heap, nil_is_heap, leA_Tree_Leaf with datatypes. - - simpl; unfold meq, munion; auto using node_is_heap with datatypes. - elim (leA_dec a a0); intros. - + elim (X a0); intros. - apply insert_exist with (Tree_Node a T2 T0); - auto using node_is_heap, nil_is_heap, leA_Tree_Leaf with datatypes. - simpl; apply treesort_twist1; trivial with datatypes. - + elim (X a); intros T3 HeapT3 ConT3 LeA. - apply insert_exist with (Tree_Node a0 T2 T3); - auto using node_is_heap, nil_is_heap, leA_Tree_Leaf with datatypes. - * apply node_is_heap; auto using node_is_heap, nil_is_heap, leA_Tree_Leaf with datatypes. - -- apply low_trans with a; auto with datatypes. - -- apply LeA; auto with datatypes. - apply low_trans with a; auto with datatypes. - * simpl; apply treesort_twist2; trivial with datatypes. - Qed. - - - (** ** Building a heap from a list *) - - Inductive build_heap (l:list A) : Type := - heap_exist : - forall T:Tree, - is_heap T -> - meq (list_contents _ eqA_dec l) (contents T) -> build_heap l. - - #[deprecated(since="8.3", note="Use mergesort.v")] - Lemma list_to_heap : forall l:list A, build_heap l. - Proof. - simple induction l. - - apply (heap_exist nil Tree_Leaf); auto with datatypes. - simpl; unfold meq; exact nil_is_heap. - - simple induction 1. - intros T i m; elim (insert T i a). - intros; apply heap_exist with T1; simpl; auto with datatypes. - apply meq_trans with (munion (contents T) (singletonBag a)). - + apply meq_trans with (munion (singletonBag a) (contents T)). - * apply meq_right; trivial with datatypes. - * apply munion_comm. - + apply meq_sym; trivial with datatypes. - Qed. - - - (** ** Building the sorted list *) - - Inductive flat_spec (T:Tree) : Type := - flat_exist : - forall l:list A, - Sorted leA l -> - (forall a:A, leA_Tree a T -> HdRel leA a l) -> - meq (contents T) (list_contents _ eqA_dec l) -> flat_spec T. - - #[deprecated(since="8.3", note="Use mergesort.v")] - Lemma heap_to_list : forall T:Tree, is_heap T -> flat_spec T. - Proof. - intros T h; elim h; intros. - - apply flat_exist with (nil (A:=A)); auto with datatypes. - - elim X; intros l1 s1 i1 m1; elim X0; intros l2 s2 i2 m2. - elim (merge _ s1 _ s2); intros. - apply flat_exist with (a :: l); simpl; auto with datatypes. - apply meq_trans with - (munion (list_contents _ eqA_dec l1) - (munion (list_contents _ eqA_dec l2) (singletonBag a))). - + apply meq_congr; auto with datatypes. - + apply meq_trans with - (munion (singletonBag a) - (munion (list_contents _ eqA_dec l1) (list_contents _ eqA_dec l2))). - * apply munion_rotate. - * apply meq_right; apply meq_sym; trivial with datatypes. - Qed. - - - (** * Specification of treesort *) - - #[deprecated(since="8.3", note="Use mergesort.v")] - Theorem treesort : - forall l:list A, - {m : list A | Sorted leA m & permutation _ eqA_dec l m}. - Proof. - intro l; unfold permutation. - elim (list_to_heap l). - intros. - elim (heap_to_list T); auto with datatypes. - intros. - exists l0; auto with datatypes. - apply meq_trans with (contents T); trivial with datatypes. - Qed. - -End defs. diff --git a/stdlib/theories/Sorting/Mergesort.v b/stdlib/theories/Sorting/Mergesort.v deleted file mode 100644 index 2a4421c9eced..000000000000 --- a/stdlib/theories/Sorting/Mergesort.v +++ /dev/null @@ -1,272 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* -> Sortclass. - -(** The main module defining [mergesort] on a given boolean - order [<=?]. We require minimal hypotheses : this boolean - order should only be total: [forall x y, (x<=?y) \/ (y<=?x)]. - Transitivity is not mandatory, but without it one can - only prove [LocallySorted] and not [StronglySorted]. -*) - -Module Sort (Import X:Orders.TotalLeBool'). - -Fixpoint merge l1 l2 := - let fix merge_aux l2 := - match l1, l2 with - | [], _ => l2 - | _, [] => l1 - | a1::l1', a2::l2' => - if a1 <=? a2 then a1 :: merge l1' l2 else a2 :: merge_aux l2' - end - in merge_aux l2. - -(** We implement mergesort using an explicit stack of pending mergings. - Pending merging are represented like a binary number where digits are - either None (denoting 0) or Some list to merge (denoting 1). The n-th - digit represents the pending list to be merged at level n, if any. - Merging a list to a stack is like adding 1 to the binary number - represented by the stack but the carry is propagated by merging the - lists. In practice, when used in mergesort, the n-th digit, if non 0, - carries a list of length 2^n. For instance, adding singleton list - [3] to the stack Some [4]::Some [2;6]::None::Some [1;3;5;5] - reduces to propagate the carry [3;4] (resulting of the merge of [3] - and [4]) to the list Some [2;6]::None::Some [1;3;5;5], which reduces - to propagating the carry [2;3;4;6] (resulting of the merge of [3;4] and - [2;6]) to the list None::Some [1;3;5;5], which locally produces - Some [2;3;4;6]::Some [1;3;5;5], i.e. which produces the final result - None::None::Some [2;3;4;6]::Some [1;3;5;5]. - - For instance, here is how [6;2;3;1;5] is sorted: - -<< - operation stack list - iter_merge [] [6;2;3;1;5] - = append_list_to_stack [ + [6]] [2;3;1;5] - -> iter_merge [[6]] [2;3;1;5] - = append_list_to_stack [[6] + [2]] [3;1;5] - = append_list_to_stack [ + [2;6];] [3;1;5] - -> iter_merge [[2;6];] [3;1;5] - = append_list_to_stack [[2;6]; + [3]] [1;5] - -> merge_list [[2;6];[3]] [1;5] - = append_list_to_stack [[2;6];[3] + [1] [5] - = append_list_to_stack [[2;6] + [1;3];] [5] - = append_list_to_stack [ + [1;2;3;6];;] [5] - -> merge_list [[1;2;3;6];;] [5] - = append_list_to_stack [[1;2;3;6];; + [5]] [] - -> merge_stack [[1;2;3;6];;[5]] - = [1;2;3;5;6] ->> - The complexity of the algorithm is n*log n, since there are - 2^(p-1) mergings to do of length 2, 2^(p-2) of length 4, ..., 2^0 - of length 2^p for a list of length 2^p. The algorithm does not need - explicitly cutting the list in 2 parts at each step since it the - successive accumulation of fragments on the stack which ensures - that lists are merged on a dichotomic basis. -*) - -Fixpoint merge_list_to_stack stack l := - match stack with - | [] => [Some l] - | None :: stack' => Some l :: stack' - | Some l' :: stack' => None :: merge_list_to_stack stack' (merge l' l) - end. - -Fixpoint merge_stack stack := - match stack with - | [] => [] - | None :: stack' => merge_stack stack' - | Some l :: stack' => merge l (merge_stack stack') - end. - -Fixpoint iter_merge stack l := - match l with - | [] => merge_stack stack - | a::l' => iter_merge (merge_list_to_stack stack [a]) l' - end. - -Definition sort := iter_merge []. - -(** The proof of correctness *) - -Local Notation Sorted := (LocallySorted leb) (only parsing). - -Fixpoint SortedStack stack := - match stack with - | [] => True - | None :: stack' => SortedStack stack' - | Some l :: stack' => Sorted l /\ SortedStack stack' - end. - -Local Ltac invert H := inversion H; subst; clear H. - -Fixpoint flatten_stack (stack : list (option (list t))) := - match stack with - | [] => [] - | None :: stack' => flatten_stack stack' - | Some l :: stack' => l ++ flatten_stack stack' - end. - -Theorem Sorted_merge : forall l1 l2, - Sorted l1 -> Sorted l2 -> Sorted (merge l1 l2). -Proof. - induction l1; induction l2; intros; simpl; auto. - destruct (a <=? a0) eqn:Heq1. - - invert H. - + simpl. constructor; trivial; rewrite Heq1; constructor. - + assert (Sorted (merge (b::l) (a0::l2))) by (apply IHl1; auto). - clear H0 H3 IHl1; simpl in *. - destruct (b <=? a0); constructor; auto || rewrite Heq1; constructor. - - assert (a0 <=? a) by - (destruct (leb_total a0 a) as [H'|H']; trivial || (rewrite Heq1 in H'; inversion H')). - invert H0. - + constructor; trivial. - + assert (Sorted (merge (a::l1) (b::l))) by auto using IHl1. - clear IHl2; simpl in *. - destruct (a <=? b); constructor; auto. -Qed. - -Theorem Permuted_merge : forall l1 l2, Permutation (l1++l2) (merge l1 l2). -Proof. - induction l1; simpl merge; intro. - - assert (forall l, (fix merge_aux (l0 : list t) : list t := l0) l = l) - as -> by (destruct l; trivial). (* Technical lemma *) - apply Permutation_refl. - - induction l2. - + rewrite app_nil_r. apply Permutation_refl. - + destruct (a <=? a0). - * constructor; apply IHl1. - * apply Permutation_sym, Permutation_cons_app, Permutation_sym, IHl2. -Qed. - -Theorem Sorted_merge_list_to_stack : forall stack l, - SortedStack stack -> Sorted l -> SortedStack (merge_list_to_stack stack l). -Proof. - induction stack as [|[|]]; intros; simpl. - - auto. - - apply IHstack. - + destruct H as (_,H1). fold SortedStack in H1. auto. - + apply Sorted_merge; auto; destruct H; auto. - - auto. -Qed. - -Theorem Permuted_merge_list_to_stack : forall stack l, - Permutation (l ++ flatten_stack stack) (flatten_stack (merge_list_to_stack stack l)). -Proof. - induction stack as [|[]]; simpl; intros. - - reflexivity. - - rewrite app_assoc. - etransitivity. - + apply Permutation_app_tail. - etransitivity. - * apply Permutation_app_comm. - * apply Permuted_merge. - + apply IHstack. - - reflexivity. -Qed. - -Theorem Sorted_merge_stack : forall stack, - SortedStack stack -> Sorted (merge_stack stack). -Proof. -induction stack as [|[|]]; simpl; intros. -- constructor; auto. -- apply Sorted_merge; tauto. -- auto. -Qed. - -Theorem Permuted_merge_stack : forall stack, - Permutation (flatten_stack stack) (merge_stack stack). -Proof. -induction stack as [|[]]; simpl. -- trivial. -- transitivity (l ++ merge_stack stack). - + apply Permutation_app_head; trivial. - + apply Permuted_merge. -- assumption. -Qed. - -Theorem Sorted_iter_merge : forall stack l, - SortedStack stack -> Sorted (iter_merge stack l). -Proof. - intros stack l H; induction l in stack, H |- *; simpl. - - auto using Sorted_merge_stack. - - assert (Sorted [a]) by constructor. - auto using Sorted_merge_list_to_stack. -Qed. - -Theorem Permuted_iter_merge : forall l stack, - Permutation (flatten_stack stack ++ l) (iter_merge stack l). -Proof. - induction l; simpl; intros. - - rewrite app_nil_r. apply Permuted_merge_stack. - - change (a::l) with ([a]++l). - rewrite app_assoc. - etransitivity. - + apply Permutation_app_tail. - etransitivity. - * apply Permutation_app_comm. - * apply Permuted_merge_list_to_stack. - + apply IHl. -Qed. - -Theorem LocallySorted_sort : forall l, Sorted (sort l). -Proof. -intro; apply Sorted_iter_merge. constructor. -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. -intro; apply (Permuted_iter_merge l []). -Qed. - -Corollary StronglySorted_sort : forall l, - Transitive leb -> StronglySorted leb (sort l). -Proof. auto using Sorted_StronglySorted, Sorted_sort. Qed. - -End Sort. - -(** An example *) - -Module NatOrder <: TotalLeBool. - Definition t := nat. - Fixpoint leb x y := - match x, y with - | 0, _ => true - | _, 0 => false - | S x', S y' => leb x' y' - end. - Infix "<=?" := leb (at level 70, no associativity). - Theorem leb_total : forall a1 a2, a1 <=? a2 \/ a2 <=? a1. - Proof. - induction a1; destruct a2; simpl; auto. - Qed. -End NatOrder. - -Module Import NatSort := Sort NatOrder. - -Example SimpleMergeExample := Eval compute in sort [5;3;6;1;8;6;0]. diff --git a/stdlib/theories/Sorting/PermutEq.v b/stdlib/theories/Sorting/PermutEq.v deleted file mode 100644 index 93aedef489ad..000000000000 --- a/stdlib/theories/Sorting/PermutEq.v +++ /dev/null @@ -1,231 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* 0 < multiplicity (list_contents l) a. - Proof. - intros; split; intro H. - - eapply In_InA, multiplicity_InA in H; eauto with typeclass_instances. - - eapply multiplicity_InA, InA_alt in H as (y & -> & H); eauto with typeclass_instances. - Qed. - - Lemma multiplicity_In_O : - forall l a, ~ In a l -> multiplicity (list_contents l) a = 0. - Proof. - intros l a; rewrite multiplicity_In; - destruct (multiplicity (list_contents l) a); auto. - destruct 1; auto with arith. - Qed. - - Lemma multiplicity_In_S : - forall l a, In a l -> multiplicity (list_contents l) a >= 1. - Proof. - intros l a; rewrite multiplicity_In; auto. - Qed. - - Lemma multiplicity_NoDup : - forall l, NoDup l <-> (forall a, multiplicity (list_contents l) a <= 1). - Proof. - induction l. - - simpl. - split; auto with arith. - intros; apply NoDup_nil. - - split; simpl. - + inversion_clear 1. - rewrite IHl in H1. - intros; destruct (eq_dec a a0) as [H2|H2]; simpl; auto. - subst a0. - rewrite multiplicity_In_O; auto. - + intros; constructor. - * rewrite multiplicity_In. - generalize (H a). - destruct (eq_dec a a) as [H0|H0]. - -- destruct (multiplicity (list_contents l) a); auto with arith. - simpl; inversion 1. - inversion H3. - -- destruct H0; auto. - * rewrite IHl; intros. - generalize (H a0); auto with arith. - destruct (eq_dec a a0); simpl; auto with arith. - Qed. - - Lemma NoDup_permut : - forall l l', NoDup l -> NoDup l' -> - (forall x, In x l <-> In x l') -> permutation l l'. - Proof. - intros. - red; unfold meq; intros. - rewrite multiplicity_NoDup in H, H0. - generalize (H a) (H0 a) (H1 a); clear H H0 H1. - do 2 rewrite multiplicity_In. - intros H H' [H0 H0']. - destruct (multiplicity (list_contents l) a) as [|[|n]], - (multiplicity (list_contents l') a) as [|[|n']]; - [ tauto | | | | tauto | | | | ]; try solve [intuition auto with arith]; exfalso. - - now inversion H'. - - now inversion H. - - now inversion H. - Qed. - - (** Permutation is compatible with In. *) - Lemma permut_In_In : - forall l1 l2 e, permutation l1 l2 -> In e l1 -> In e l2. - Proof. - unfold PermutSetoid.permutation, meq; intros l1 l2 e P IN. - generalize (P e); clear P. - destruct (In_dec eq_dec e l2) as [H|H]; auto. - rewrite (multiplicity_In_O _ _ H). - intros. - generalize (multiplicity_In_S _ _ IN). - rewrite H0. - inversion 1. - Qed. - - Lemma permut_cons_In : - forall l1 l2 e, permutation (e :: l1) l2 -> In e l2. - Proof. - intros; eapply permut_In_In; eauto. - red; auto. - Qed. - - (** Permutation of an empty list. *) - Lemma permut_nil : - forall l, permutation l nil -> l = nil. - Proof. - intro l; destruct l as [ | e l ]; trivial. - assert (In e (e::l)) by (red; auto). - intro Abs; generalize (permut_In_In _ Abs H). - inversion 1. - Qed. - - (** When used with [eq], this permutation notion is equivalent to - the one defined in [List.v]. *) - - Lemma permutation_Permutation : - forall l l', Permutation l l' <-> permutation l l'. - Proof. - split. - - induction 1. - + apply permut_refl. - + apply permut_cons; auto. - + change (permutation (y::x::l) ((x::nil)++y::l)). - apply permut_add_cons_inside; simpl; apply permut_refl. - + apply permut_trans with l'; auto. - - revert l'. - induction l. - + intros. - rewrite (permut_nil (permut_sym H)). - apply Permutation_refl. - + intros. - destruct (In_split _ _ (permut_cons_In H)) as (h2,(t2,H1)). - subst l'. - apply Permutation_cons_app. - apply IHl. - apply permut_remove_hd with a; auto with typeclass_instances. - Qed. - - (** Permutation for short lists. *) - - Lemma permut_length_1: - forall a b, permutation (a :: nil) (b :: nil) -> a=b. - Proof. - intros a b; unfold PermutSetoid.permutation, meq; intro P; - generalize (P b); clear P; simpl. - destruct (eq_dec b b) as [H|H]; [ | destruct H; auto]. - destruct (eq_dec a b); simpl; auto; intros; discriminate. - Qed. - - Lemma permut_length_2 : - forall a1 b1 a2 b2, permutation (a1 :: b1 :: nil) (a2 :: b2 :: nil) -> - (a1=a2) /\ (b1=b2) \/ (a1=b2) /\ (a2=b1). - Proof. - intros a1 b1 a2 b2 P. - assert (H:=permut_cons_In P). - inversion_clear H. - - left; split; auto. - apply permut_length_1. - red; red; intros. - generalize (P a); clear P; simpl. - destruct (eq_dec a1 a) as [H2|H2]; - destruct (eq_dec a2 a) as [H3|H3]; auto. - + destruct H3; transitivity a1; auto. - + destruct H2; transitivity a2; auto. - - right. - inversion_clear H0; [|inversion H]. - split; auto. - apply permut_length_1. - red; red; intros. - generalize (P a); clear P; simpl. - destruct (eq_dec a1 a) as [H2|H2]; - destruct (eq_dec b2 a) as [H3|H3]; auto. - + simpl; rewrite <- plus_n_Sm; inversion 1; auto. - + destruct H3; transitivity a1; auto. - + destruct H2; transitivity b2; auto. - Qed. - - (** Permutation is compatible with length. *) - Lemma permut_length : - forall l1 l2, permutation l1 l2 -> length l1 = length l2. - Proof. - induction l1; intros l2 H. - - rewrite (permut_nil (permut_sym H)); auto. - - destruct (In_split _ _ (permut_cons_In H)) as (h2,(t2,H1)). - subst l2. - rewrite length_app. - simpl; rewrite <- plus_n_Sm; f_equal. - rewrite <- length_app. - apply IHl1. - apply permut_remove_hd with a; auto with typeclass_instances. - Qed. - - Variable B : Type. - Variable eqB_dec : forall x y:B, { x=y }+{ ~x=y }. - - (** Permutation is compatible with map. *) - - Lemma permutation_map : - forall f l1 l2, permutation l1 l2 -> - PermutSetoid.permutation _ eqB_dec (map f l1) (map f l2). - Proof. - intros f; induction l1. - - intros l2 P; rewrite (permut_nil (permut_sym P)); apply permut_refl. - - intros l2 P. - simpl. - destruct (In_split _ _ (permut_cons_In P)) as (h2,(t2,H1)). - subst l2. - rewrite map_app. - simpl. - apply permut_add_cons_inside. - rewrite <- map_app. - apply IHl1; auto. - apply permut_remove_hd with a; auto with typeclass_instances. - Qed. - -End Perm. diff --git a/stdlib/theories/Sorting/PermutSetoid.v b/stdlib/theories/Sorting/PermutSetoid.v deleted file mode 100644 index 6e97438e9c57..000000000000 --- a/stdlib/theories/Sorting/PermutSetoid.v +++ /dev/null @@ -1,546 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* emptyBag - | a :: l => munion (singletonBag a) (list_contents l) - end. - -Lemma list_contents_app : - forall l m:list A, - meq (list_contents (l ++ m)) (munion (list_contents l) (list_contents m)). -Proof. - simple induction l; simpl; auto with datatypes. - intros. - apply meq_trans with - (munion (singletonBag a) (munion (list_contents l0) (list_contents m))); - auto with datatypes. -Qed. - -(** * [permutation]: definition and basic properties *) - -Definition permutation (l m:list A) := meq (list_contents l) (list_contents m). - -Lemma permut_refl : forall l:list A, permutation l l. -Proof. - unfold permutation; auto with datatypes. -Qed. - -Lemma permut_sym : - forall l1 l2 : list A, permutation l1 l2 -> permutation l2 l1. -Proof. - unfold permutation, meq; intros; symmetry; trivial. -Qed. - -Lemma permut_trans : - forall l m n:list A, permutation l m -> permutation m n -> permutation l n. -Proof. - unfold permutation; intros. - apply meq_trans with (list_contents m); auto with datatypes. -Qed. - -Lemma permut_cons_eq : - forall l m:list A, - permutation l m -> forall a a', eqA a a' -> permutation (a :: l) (a' :: m). -Proof. - unfold permutation; simpl; intros. - apply meq_trans with (munion (singletonBag a') (list_contents l)). - - apply meq_left, meq_singleton; auto. - - auto with datatypes. -Qed. - -Lemma permut_cons : - forall l m:list A, - permutation l m -> forall a:A, permutation (a :: l) (a :: m). -Proof. - unfold permutation; simpl; auto with datatypes. -Qed. - -Lemma permut_app : - forall l l' m m':list A, - permutation l l' -> permutation m m' -> permutation (l ++ m) (l' ++ m'). -Proof. - unfold permutation; intros. - apply meq_trans with (munion (list_contents l) (list_contents m)); - auto using permut_cons, list_contents_app with datatypes. - apply meq_trans with (munion (list_contents l') (list_contents m')); - auto using permut_cons, list_contents_app with datatypes. - apply meq_trans with (munion (list_contents l') (list_contents m)); - auto using permut_cons, list_contents_app with datatypes. -Qed. - -Lemma permut_add_inside_eq : - forall a a' l1 l2 l3 l4, eqA a a' -> - permutation (l1 ++ l2) (l3 ++ l4) -> - permutation (l1 ++ a :: l2) (l3 ++ a' :: l4). -Proof. - unfold permutation, meq in *; intros. - specialize H0 with a0. - repeat rewrite list_contents_app in *; simpl in *. - destruct (eqA_dec a a0) as [Ha|Ha]; rewrite H in Ha; - decide (eqA_dec a' a0) with Ha; simpl; auto with arith. - do 2 rewrite <- plus_n_Sm; f_equal; auto. -Qed. - -Lemma permut_add_inside : - forall a l1 l2 l3 l4, - permutation (l1 ++ l2) (l3 ++ l4) -> - permutation (l1 ++ a :: l2) (l3 ++ a :: l4). -Proof. - unfold permutation, meq in *; intros. - generalize (H a0); clear H. - do 4 rewrite list_contents_app. - simpl. - destruct (eqA_dec a a0); simpl; auto with arith. - do 2 rewrite <- plus_n_Sm; f_equal; auto. -Qed. - -Lemma permut_add_cons_inside_eq : - forall a a' l l1 l2, eqA a a' -> - permutation l (l1 ++ l2) -> - permutation (a :: l) (l1 ++ a' :: l2). -Proof. - intros; - replace (a :: l) with ([] ++ a :: l); trivial; - apply permut_add_inside_eq; trivial. -Qed. - -Lemma permut_add_cons_inside : - forall a l l1 l2, - permutation l (l1 ++ l2) -> - permutation (a :: l) (l1 ++ a :: l2). -Proof. - intros; - replace (a :: l) with ([] ++ a :: l); trivial; - apply permut_add_inside; trivial. -Qed. - -Lemma permut_middle : - forall (l m:list A) (a:A), permutation (a :: l ++ m) (l ++ a :: m). -Proof. - intros; apply permut_add_cons_inside; auto using permut_sym, permut_refl. -Qed. - -Lemma permut_sym_app : - forall l1 l2, permutation (l1 ++ l2) (l2 ++ l1). -Proof. - intros l1 l2; - unfold permutation, meq; - intro a; do 2 rewrite list_contents_app; simpl; - auto with arith. -Qed. - -Lemma permut_rev : - forall l, permutation l (rev l). -Proof. - induction l. - - simpl; trivial using permut_refl. - - simpl. - apply permut_add_cons_inside. - rewrite app_nil_r. trivial. -Qed. - -(** * Some inversion results. *) -Lemma permut_conv_inv : - forall e l1 l2, permutation (e :: l1) (e :: l2) -> permutation l1 l2. -Proof. - intros e l1 l2; unfold permutation, meq; simpl; intros H a; - generalize (H a); lia. -Qed. - -Lemma permut_app_inv1 : - forall l l1 l2, permutation (l1 ++ l) (l2 ++ l) -> permutation l1 l2. -Proof. - intros l l1 l2; unfold permutation, meq; simpl; - intros H a; generalize (H a); clear H. - do 2 rewrite list_contents_app. - simpl. - lia. -Qed. - -(** we can use [multiplicity] to define [InA] and [NoDupA]. *) - -Fact if_eqA_then : forall a a' (B:Type)(b b':B), - eqA a a' -> (if eqA_dec a a' then b else b') = b. -Proof. - intros. destruct eqA_dec as [_|NEQ]; auto. - contradict NEQ; auto. -Qed. - -Lemma permut_app_inv2 : - forall l l1 l2, permutation (l ++ l1) (l ++ l2) -> permutation l1 l2. -Proof. - intros l l1 l2; unfold permutation, meq; simpl; - intros H a; generalize (H a); clear H. - do 2 rewrite list_contents_app. - simpl. - lia. -Qed. - -Lemma permut_remove_hd_eq : - forall l l1 l2 a b, eqA a b -> - permutation (a :: l) (l1 ++ b :: l2) -> permutation l (l1 ++ l2). -Proof. - unfold permutation, meq; simpl; intros l l1 l2 a b Heq H a0. - specialize H with a0. - rewrite list_contents_app in *. simpl in *. - destruct (eqA_dec a _) as [Ha|Ha]; rewrite Heq in Ha; revert H; - decide (eqA_dec b a0) with Ha; lia. -Qed. - -Lemma permut_remove_hd : - forall l l1 l2 a, - permutation (a :: l) (l1 ++ a :: l2) -> permutation l (l1 ++ l2). -Proof. - pose proof (Equivalence_Reflexive (R := eqA)); - eauto using permut_remove_hd_eq. -Qed. - -Fact if_eqA_else : forall a a' (B:Type)(b b':B), - ~eqA a a' -> (if eqA_dec a a' then b else b') = b'. -Proof. - intros. decide (eqA_dec a a') with H; auto. -Qed. - -Fact if_eqA_refl : forall a (B:Type)(b b':B), - (if eqA_dec a a then b else b') = b. -Proof. - intros; apply (decide_left (eqA_dec a a)); auto with *. -Qed. - -(** PL: Inutilisable dans un rewrite sans un change prealable. *) - -Global Instance if_eqA (B:Type)(b b':B) : - Proper (eqA==>eqA==>@eq _) (fun x y => if eqA_dec x y then b else b'). -Proof. - intros x x' Hxx' y y' Hyy'. - intros; destruct (eqA_dec x y) as [H|H]; - destruct (eqA_dec x' y') as [H'|H']; auto. - - contradict H'; transitivity x; auto with *; transitivity y; auto with *. - - contradict H; transitivity x'; auto with *; transitivity y'; auto with *. -Qed. - -Fact if_eqA_rewrite_l : forall a1 a1' a2 (B:Type)(b b':B), - eqA a1 a1' -> (if eqA_dec a1 a2 then b else b') = - (if eqA_dec a1' a2 then b else b'). -Proof. - intros; destruct (eqA_dec a1 a2) as [A1|A1]; - destruct (eqA_dec a1' a2) as [A1'|A1']; auto. - - contradict A1'; transitivity a1; eauto with *. - - contradict A1; transitivity a1'; eauto with *. -Qed. - -Fact if_eqA_rewrite_r : forall a1 a2 a2' (B:Type)(b b':B), - eqA a2 a2' -> (if eqA_dec a1 a2 then b else b') = - (if eqA_dec a1 a2' then b else b'). -Proof. - intros; destruct (eqA_dec a1 a2) as [A2|A2]; - destruct (eqA_dec a1 a2') as [A2'|A2']; auto. - - contradict A2'; transitivity a2; eauto with *. - - contradict A2; transitivity a2'; eauto with *. -Qed. - - -Global Instance multiplicity_eqA (l:list A) : - Proper (eqA==>@eq _) (multiplicity (list_contents l)). -Proof. - intros x x' Hxx'. - induction l as [|y l Hl]; simpl; auto. - rewrite (@if_eqA_rewrite_r y x x'); auto. -Qed. - -Lemma multiplicity_InA : - forall l a, InA eqA a l <-> 0 < multiplicity (list_contents l) a. -Proof. - induction l. - - simpl. - split; inversion 1. - - simpl. - intros a'; split; intros H. - + inversion_clear H. - * apply (decide_left (eqA_dec a a')); auto with *. - * destruct (eqA_dec a a'); auto with *. simpl; rewrite <- IHl; auto. - + destruct (eqA_dec a a'); auto with *. right. rewrite IHl; auto. -Qed. - -Lemma multiplicity_InA_O : - forall l a, ~ InA eqA a l -> multiplicity (list_contents l) a = 0. -Proof. - intros l a; rewrite multiplicity_InA; - destruct (multiplicity (list_contents l) a); auto with arith. - destruct 1; auto with arith. -Qed. - -Lemma multiplicity_InA_S : - forall l a, InA eqA a l -> multiplicity (list_contents l) a >= 1. -Proof. - intros l a; rewrite multiplicity_InA; auto with arith. -Qed. - -Lemma multiplicity_NoDupA : forall l, - NoDupA eqA l <-> (forall a, multiplicity (list_contents l) a <= 1). -Proof. - induction l. - - simpl. - split; auto with arith. - - split; simpl. - + inversion_clear 1. - rewrite IHl in H1. - intros; destruct (eqA_dec a a0) as [EQ|NEQ]; simpl; auto with *. - rewrite <- EQ. - rewrite multiplicity_InA_O; auto. - + intros; constructor. - * rewrite multiplicity_InA. - specialize (H a). - rewrite if_eqA_refl in H. - clear IHl; lia. - * rewrite IHl; intros. - specialize (H a0). lia. -Qed. - -(** Permutation is compatible with InA. *) -Lemma permut_InA_InA : - forall l1 l2 e, permutation l1 l2 -> InA eqA e l1 -> InA eqA e l2. -Proof. - intros l1 l2 e. - do 2 rewrite multiplicity_InA. - unfold permutation, meq. - intros H;rewrite H; auto. -Qed. - -Lemma permut_cons_InA : - forall l1 l2 e, permutation (e :: l1) l2 -> InA eqA e l2. -Proof. - intros; apply (permut_InA_InA (e:=e) H); auto with *. -Qed. - -(** Permutation of an empty list. *) -Lemma permut_nil : - forall l, permutation l [] -> l = []. -Proof. - intro l; destruct l as [ | e l ]; trivial. - assert (InA eqA e (e::l)) by (auto with *). - intro Abs; generalize (permut_InA_InA Abs H). - inversion 1. -Qed. - -(** Permutation for short lists. *) - -Lemma permut_length_1: - forall a b, permutation [a] [b] -> eqA a b. -Proof. - intros a b; unfold permutation, meq. - intro P; specialize (P b); simpl in *. - rewrite if_eqA_refl in *. - destruct (eqA_dec a b); simpl; auto; discriminate. -Qed. - -Lemma permut_length_2 : - forall a1 b1 a2 b2, permutation [a1; b1] [a2; b2] -> - (eqA a1 a2) /\ (eqA b1 b2) \/ (eqA a1 b2) /\ (eqA a2 b1). -Proof. - intros a1 b1 a2 b2 P. - assert (H:=permut_cons_InA P). - inversion_clear H. - - left; split; auto. - apply permut_length_1. - red; red; intros. - specialize (P a). simpl in *. - rewrite (@if_eqA_rewrite_l a1 a2 a) in P by auto. lia. - - right. - inversion_clear H0; [|inversion H]. - split; auto. - apply permut_length_1. - red; red; intros. - specialize (P a); simpl in *. - rewrite (@if_eqA_rewrite_l a1 b2 a) in P by auto. lia. -Qed. - -(** Permutation is compatible with length. *) -Lemma permut_length : - forall l1 l2, permutation l1 l2 -> length l1 = length l2. -Proof. - induction l1; intros l2 H. - - rewrite (permut_nil (permut_sym H)); auto. - - assert (H0:=permut_cons_InA H). - destruct (InA_split H0) as (h2,(b,(t2,(H1,H2)))). - subst l2. - rewrite length_app. - simpl; rewrite <- plus_n_Sm; f_equal. - rewrite <- length_app. - apply IHl1. - apply permut_remove_hd with b. - apply permut_trans with (a::l1); auto. - revert H1; unfold permutation, meq; simpl. - intros; f_equal; auto. - rewrite (@if_eqA_rewrite_l a b a0); auto. -Qed. - -Lemma NoDupA_equivlistA_permut : - forall l l', NoDupA eqA l -> NoDupA eqA l' -> - equivlistA eqA l l' -> permutation l l'. -Proof. - intros. - red; unfold meq; intros. - rewrite multiplicity_NoDupA in H, H0. - generalize (H a) (H0 a) (H1 a); clear H H0 H1. - do 2 rewrite multiplicity_InA. - destruct 3; lia. -Qed. - -End Permut. - -Section Permut_map. - -Variables A B : Type. - -Variable eqA : relation A. -Hypothesis eqA_dec : forall x y:A, {eqA x y} + {~ eqA x y}. -Hypothesis eqA_equiv : Equivalence eqA. - -Variable eqB : B->B->Prop. -Hypothesis eqB_dec : forall x y:B, { eqB x y }+{ ~eqB x y }. -Hypothesis eqB_trans : Transitive eqB. - -(** Permutation is compatible with map. *) - -Lemma permut_map : - forall f, - (Proper (eqA==>eqB) f) -> - forall l1 l2, permutation _ eqA_dec l1 l2 -> - permutation _ eqB_dec (map f l1) (map f l2). -Proof. - intros f; induction l1. - - intros l2 P; rewrite (permut_nil eqA_equiv (permut_sym P)); apply permut_refl. - - intros l2 P. - simpl. - assert (H0:=permut_cons_InA eqA_equiv P). - destruct (InA_split H0) as (h2,(b,(t2,(H1,H2)))). - subst l2. - rewrite map_app. - simpl. - apply permut_trans with (f b :: map f l1). - + revert H1; unfold permutation, meq; simpl. - intros; f_equal; auto. - destruct (eqB_dec (f b) a0) as [H2|H2]; - destruct (eqB_dec (f a) a0) as [H3|H3]; auto. - * destruct H3; transitivity (f b); auto with *. - * destruct H2; transitivity (f a); auto with *. - + apply permut_add_cons_inside. - rewrite <- map_app. - apply IHl1; auto. - apply permut_remove_hd with b; trivial. - apply permut_trans with (a::l1); auto. - revert H1; unfold permutation, meq; simpl. - intros; f_equal; auto. - rewrite (@if_eqA_rewrite_l _ _ eqA_equiv eqA_dec a b a0); auto. -Qed. - -End Permut_map. - -Require Import Permutation. - -Section Permut_permut. - -Variable A : Type. - -Variable eqA : relation A. -Hypothesis eqA_dec : forall x y:A, {eqA x y} + {~ eqA x y}. -Hypothesis eqA_equiv : Equivalence eqA. - -Lemma Permutation_impl_permutation : forall l l', - Permutation l l' -> permutation _ eqA_dec l l'. -Proof. - induction 1. - - apply permut_refl. - - apply permut_cons; auto using Equivalence_Reflexive. - - change (x :: y :: l) with ([x] ++ y :: l); - apply permut_add_cons_inside; simpl; - apply permut_cons_eq; - pose proof (Equivalence_Reflexive (R := eqA)); - auto using permut_refl. - - apply permut_trans with l'; trivial. -Qed. - -Lemma permut_eqA : forall l l', Forall2 eqA l l' -> permutation _ eqA_dec l l'. -Proof. - induction 1. - - apply permut_refl. - - apply permut_cons_eq; trivial. -Qed. - -Lemma permutation_Permutation : forall l l', - permutation _ eqA_dec l l' <-> - exists l'', Permutation l l'' /\ Forall2 eqA l'' l'. -Proof. - split; intro H. - - (* -> *) - induction l in l', H |- *. - + exists []; apply permut_sym, permut_nil in H as ->; auto using Forall2. - + pose proof H as H'. - apply permut_cons_InA, InA_split in H - as (l1 & y & l2 & Heq & ->); trivial. - apply permut_remove_hd_eq, IHl in H' - as (l'' & IHP & IHA); clear IHl; trivial. - apply Forall2_app_inv_r in IHA as (l1'' & l2'' & Hl1 & Hl2 & ->). - exists (l1'' ++ a :: l2''); split. - * apply Permutation_cons_app; trivial. - * apply Forall2_app, Forall2_cons; trivial. - - (* <- *) - destruct H as (l'' & H & Heq). - apply permut_trans with l''. - + apply Permutation_impl_permutation; trivial. - + apply permut_eqA; trivial. -Qed. - -End Permut_permut. - -(* begin hide *) -(** For compatibility *) -Notation permut_right := permut_cons (only parsing). -Notation permut_tran := permut_trans (only parsing). -(* end hide *) diff --git a/stdlib/theories/Sorting/Permutation.v b/stdlib/theories/Sorting/Permutation.v deleted file mode 100644 index a6807f41e5c7..000000000000 --- a/stdlib/theories/Sorting/Permutation.v +++ /dev/null @@ -1,966 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* list A -> Prop := -| perm_nil: Permutation [] [] -| perm_skip x l l' : Permutation l l' -> Permutation (x::l) (x::l') -| perm_swap x y l : Permutation (y::x::l) (x::y::l) -| perm_trans l l' l'' : - Permutation l l' -> Permutation l' l'' -> Permutation l l''. - -Local Hint Constructors Permutation : core. - -(** Some facts about [Permutation] *) - -Theorem Permutation_nil : forall (l : list A), Permutation [] l -> l = []. -Proof. - intros l HF. - remember (@nil A) as m in HF. - induction HF; discriminate || auto. -Qed. - -Theorem Permutation_nil_cons : forall (l : list A) (x : A), - ~ Permutation nil (x::l). -Proof. - intros l x HF. - apply Permutation_nil in HF; discriminate. -Qed. - -(** Permutation over lists is a equivalence relation *) - -Theorem Permutation_refl : forall l : list A, Permutation l l. -Proof. - induction l; constructor. exact IHl. -Qed. - -Instance Permutation_refl' : Proper (Logic.eq ==> Permutation) id. -Proof. - intros x y Heq; rewrite Heq; apply Permutation_refl. -Qed. - -Theorem Permutation_sym : forall l l' : list A, - Permutation l l' -> Permutation l' l. -Proof. - intros l l' Hperm; induction Hperm; auto. - apply perm_trans with (l':=l'); assumption. -Qed. - -Theorem Permutation_trans : forall l l' l'' : list A, - Permutation l l' -> Permutation l' l'' -> Permutation l l''. -Proof. - exact perm_trans. -Qed. - -End Permutation. - -#[global] -Hint Resolve Permutation_refl perm_nil perm_skip : core. - -(* These hints do not reduce the size of the problem to solve and they - must be used with care to avoid combinatoric explosions *) - -Local Hint Resolve perm_swap perm_trans : core. -Local Hint Resolve Permutation_sym Permutation_trans : core. - -(* This provides reflexivity, symmetry and transitivity and rewriting - on morphims to come *) - -#[global] -Instance Permutation_Equivalence A : Equivalence (@Permutation A) := { - Equivalence_Reflexive := @Permutation_refl A ; - Equivalence_Symmetric := @Permutation_sym A ; - Equivalence_Transitive := @Permutation_trans A }. - -Lemma Permutation_morph_transp A : forall P : list A -> Prop, - (forall a b l1 l2, P (l1 ++ a :: b :: l2) -> P (l1 ++ b :: a :: l2)) -> - Proper (@Permutation A ==> Basics.impl) P. -Proof. - intros P HT l1 l2 HP. - enough (forall l0, P (l0 ++ l1) -> P (l0 ++ l2)) as IH - by (intro; rewrite <- (app_nil_l l2); now apply (IH nil)). - induction HP; intuition. - rewrite <- (app_nil_l l'), app_comm_cons, app_assoc. - now apply IHHP; rewrite <- app_assoc. -Qed. - -#[export] -Instance Permutation_cons A : - Proper (Logic.eq ==> @Permutation A ==> @Permutation A) (@cons A). -Proof. - repeat intro; subst; auto using perm_skip. -Qed. - - -Section Permutation_properties. - -Variable A B:Type. - -Implicit Types a : A. -Implicit Types l m : list A. - -(** Compatibility with others operations on lists *) - -Theorem Permutation_in : forall (l l' : list A) (x : A), - Permutation l l' -> In x l -> In x l'. -Proof. - intros l l' x Hperm; induction Hperm; simpl; tauto. -Qed. - -Global Instance Permutation_in' : - Proper (Logic.eq ==> @Permutation A ==> iff) (@In A). -Proof. - repeat red; intros; subst; eauto using Permutation_in. -Qed. - -Lemma Permutation_app_tail : forall (l l' tl : list A), - Permutation l l' -> Permutation (l++tl) (l'++tl). -Proof. - intros l l' tl Hperm; induction Hperm as [|x l l'|x y l|l l' l'']; simpl; auto. - eapply Permutation_trans with (l':=l'++tl); trivial. -Qed. - -Lemma Permutation_app_head : forall (l tl tl' : list A), - Permutation tl tl' -> Permutation (l++tl) (l++tl'). -Proof. - intros l tl tl' Hperm; induction l; - [trivial | repeat rewrite <- app_comm_cons; constructor; assumption]. -Qed. - -Theorem Permutation_app : forall (l m l' m' : list A), - Permutation l l' -> Permutation m m' -> Permutation (l++m) (l'++m'). -Proof. - intros l m l' m' Hpermll' Hpermmm'; - induction Hpermll' as [|x l l'|x y l|l l' l'']; - repeat rewrite <- app_comm_cons; auto. - - apply Permutation_trans with (l' := (x :: y :: l ++ m)); - [idtac | repeat rewrite app_comm_cons; apply Permutation_app_head]; trivial. - - apply Permutation_trans with (l' := (l' ++ m')); try assumption. - apply Permutation_app_tail; assumption. -Qed. - -#[export] Instance Permutation_app' : - Proper (@Permutation A ==> @Permutation A ==> @Permutation A) (@app A). -Proof. - repeat intro; now apply Permutation_app. -Qed. - -Lemma Permutation_add_inside : forall a (l l' tl tl' : list A), - Permutation l l' -> Permutation tl tl' -> - Permutation (l ++ a :: tl) (l' ++ a :: tl'). -Proof. - intros; apply Permutation_app; auto. -Qed. - -Lemma Permutation_cons_append : forall (l : list A) x, - Permutation (x :: l) (l ++ x :: nil). -Proof. induction l; intros; auto. simpl. rewrite <- IHl; auto. Qed. -Local Hint Resolve Permutation_cons_append : core. - -Theorem Permutation_app_comm : forall (l l' : list A), - Permutation (l ++ l') (l' ++ l). -Proof. - induction l as [|x l]; simpl; intro l'. - - rewrite app_nil_r; trivial. - - rewrite IHl. - rewrite app_comm_cons, Permutation_cons_append. - now rewrite <- app_assoc. -Qed. -Local Hint Resolve Permutation_app_comm : core. - -Lemma Permutation_app_rot : forall l1 l2 l3: list A, - Permutation (l1 ++ l2 ++ l3) (l2 ++ l3 ++ l1). -Proof. - intros l1 l2 l3; now rewrite (app_assoc l2). -Qed. -Local Hint Resolve Permutation_app_rot : core. - -Lemma Permutation_app_swap_app : forall l1 l2 l3: list A, - Permutation (l1 ++ l2 ++ l3) (l2 ++ l1 ++ l3). -Proof. - intros. - rewrite 2 app_assoc. - apply Permutation_app_tail, Permutation_app_comm. -Qed. -Local Hint Resolve Permutation_app_swap_app : core. - -Lemma Permutation_app_middle : forall l l1 l2 l3 l4, - Permutation (l1 ++ l2) (l3 ++ l4) -> - Permutation (l1 ++ l ++ l2) (l3 ++ l ++ l4). -Proof. - intros l l1 l2 l3 l4 HP. - now rewrite Permutation_app_swap_app, HP, Permutation_app_swap_app. -Qed. - -Theorem Permutation_cons_app : forall (l l1 l2:list A) a, - Permutation l (l1 ++ l2) -> Permutation (a :: l) (l1 ++ a :: l2). -Proof. - intros l l1 l2 a H. rewrite H. - rewrite app_comm_cons, Permutation_cons_append. - now rewrite <- app_assoc. -Qed. -Local Hint Resolve Permutation_cons_app : core. - -Lemma Permutation_Add a l l' : Add a l l' -> Permutation (a::l) l'. -Proof. - induction 1; simpl; trivial. - rewrite perm_swap. now apply perm_skip. -Qed. - -Theorem Permutation_middle : forall (l1 l2:list A) a, - Permutation (a :: l1 ++ l2) (l1 ++ a :: l2). -Proof. - auto. -Qed. -Local Hint Resolve Permutation_middle : core. - -Lemma Permutation_middle2 : forall l1 l2 l3 a b, - Permutation (a :: b :: l1 ++ l2 ++ l3) (l1 ++ a :: l2 ++ b :: l3). -Proof. - intros l1 l2 l3 a b. - apply Permutation_cons_app. - rewrite 2 app_assoc. - now apply Permutation_cons_app. -Qed. -Local Hint Resolve Permutation_middle2 : core. - -Lemma Permutation_elt : forall l1 l2 l1' l2' (a:A), - Permutation (l1 ++ l2) (l1' ++ l2') -> - Permutation (l1 ++ a :: l2) (l1' ++ a :: l2'). -Proof. - intros l1 l2 l1' l2' a HP. - transitivity (a :: l1 ++ l2); auto. -Qed. - -Theorem Permutation_rev : forall (l : list A), Permutation l (rev l). -Proof. - induction l as [| x l]; simpl; trivial. now rewrite IHl at 1. -Qed. - -Global Instance Permutation_rev' : - Proper (@Permutation A ==> @Permutation A) (@rev A). -Proof. - repeat intro; now rewrite <- 2 Permutation_rev. -Qed. - -Theorem Permutation_length : forall (l l' : list A), - Permutation l l' -> length l = length l'. -Proof. - intros l l' Hperm; induction Hperm; simpl; auto. now transitivity (length l'). -Qed. - -Global Instance Permutation_length' : - Proper (@Permutation A ==> Logic.eq) (@length A) | 10. -Proof. - exact Permutation_length. -Qed. - -Global Instance Permutation_Forall (P : A -> Prop) : - Proper ((@Permutation A) ==> Basics.impl) (Forall P). -Proof. - intros l1 l2 HP. - induction HP; intro HF; auto. - - inversion_clear HF; auto. - - inversion_clear HF as [ | ? ? HF1 HF2]. - inversion_clear HF2; auto. -Qed. - -Global Instance Permutation_Exists (P : A -> Prop) : - Proper ((@Permutation A) ==> Basics.impl) (Exists P). -Proof. - intros l1 l2 HP. - induction HP; intro HF; auto. - - inversion_clear HF; auto. - - inversion_clear HF as [ | ? ? HF1 ]; auto. - inversion_clear HF1; auto. -Qed. - -Lemma Permutation_Forall2 (P : A -> B -> Prop) : - forall l1 l1' (l2 : list B), Permutation l1 l1' -> Forall2 P l1 l2 -> - exists l2' : list B, Permutation l2 l2' /\ Forall2 P l1' l2'. -Proof. - intros l1 l1' l2 HP. - revert l2; induction HP; intros l2 HF; inversion HF as [ | ? b ? ? HF1 HF2 ]; subst. - - now exists nil. - - apply IHHP in HF2 as [l2' [HP2 HF2]]. - exists (b :: l2'); auto. - - inversion_clear HF2 as [ | ? b' ? l2' HF3 HF4 ]. - exists (b' :: b :: l2'); auto. - - apply Permutation_nil in HP1; subst. - apply Permutation_nil in HP2; subst. - now exists nil. - - apply IHHP1 in HF as [l2' [HP2' HF2']]. - apply IHHP2 in HF2' as [l2'' [HP2'' HF2'']]. - exists l2''; split; auto. - now transitivity l2'. -Qed. - -Theorem Permutation_ind_bis : - forall P : list A -> list A -> Prop, - P [] [] -> - (forall x l l', Permutation l l' -> P l l' -> P (x :: l) (x :: l')) -> - (forall x y l l', Permutation l l' -> P l l' -> P (y :: x :: l) (x :: y :: l')) -> - (forall l l' l'', Permutation l l' -> P l l' -> Permutation l' l'' -> P l' l'' -> P l l'') -> - forall l l', Permutation l l' -> P l l'. -Proof. - intros P Hnil Hskip Hswap Htrans. - induction 1; auto. - - apply Htrans with (x::y::l); auto. - + apply Hswap; auto. - induction l; auto. - + apply Hskip; auto. - apply Hskip; auto. - induction l; auto. - - eauto. -Qed. - -Theorem Permutation_nil_app_cons : forall (l l' : list A) (x : A), - ~ Permutation nil (l++x::l'). -Proof. - intros l l' x HF. - apply Permutation_nil in HF. destruct l; discriminate. -Qed. - -Ltac InvAdd := repeat (match goal with - | H: Add ?x _ (_ :: _) |- _ => inversion H; clear H; subst - end). - -Ltac finish_basic_perms H := - try constructor; try rewrite perm_swap; try constructor; trivial; - (rewrite <- H; now apply Permutation_Add) || - (rewrite H; symmetry; now apply Permutation_Add). - -Theorem Permutation_Add_inv a l1 l2 : - Permutation l1 l2 -> forall l1' l2', Add a l1' l1 -> Add a l2' l2 -> - Permutation l1' l2'. -Proof. - revert l1 l2. refine (Permutation_ind_bis _ _ _ _ _). - - (* nil *) - inversion_clear 1. - - (* skip *) - intros x l1 l2 PE IH. intros. InvAdd; try finish_basic_perms PE. - constructor. now apply IH. - - (* swap *) - intros x y l1 l2 PE IH. intros. InvAdd; try finish_basic_perms PE. - rewrite perm_swap; do 2 constructor. now apply IH. - - (* trans *) - intros l1 l l2 PE IH PE' IH' l1' l2' AD1 AD2. - assert (Ha : In a l). { rewrite <- PE. rewrite (Add_in AD1). simpl; auto. } - destruct (Add_inv _ _ Ha) as (l',AD). - transitivity l'; auto. -Qed. - -Theorem Permutation_app_inv (l1 l2 l3 l4:list A) a : - Permutation (l1++a::l2) (l3++a::l4) -> Permutation (l1++l2) (l3 ++ l4). -Proof. - intros. eapply Permutation_Add_inv; eauto using Add_app. -Qed. - -Theorem Permutation_cons_inv l l' a : - Permutation (a::l) (a::l') -> Permutation l l'. -Proof. - intro. eapply Permutation_Add_inv; eauto using Add_head. -Qed. - -Theorem Permutation_cons_app_inv l l1 l2 a : - Permutation (a :: l) (l1 ++ a :: l2) -> Permutation l (l1 ++ l2). -Proof. - intro. eapply Permutation_Add_inv; eauto using Add_head, Add_app. -Qed. - -Theorem Permutation_app_inv_l : forall l l1 l2, - Permutation (l ++ l1) (l ++ l2) -> Permutation l1 l2. -Proof. - induction l; simpl; auto. - intros. - apply IHl. - apply Permutation_cons_inv with a; auto. -Qed. - -Theorem Permutation_app_inv_r l l1 l2 : - Permutation (l1 ++ l) (l2 ++ l) -> Permutation l1 l2. -Proof. - rewrite 2 (Permutation_app_comm _ l). apply Permutation_app_inv_l. -Qed. - -Lemma Permutation_app_inv_m l l1 l2 l3 l4 : - Permutation (l1 ++ l ++ l2) (l3 ++ l ++ l4) -> - Permutation (l1 ++ l2) (l3 ++ l4). -Proof. - intros HP. - apply (Permutation_app_inv_l l). - transitivity (l1 ++ l ++ l2); auto. - transitivity (l3 ++ l ++ l4); auto. -Qed. - -Lemma Permutation_length_1_inv: forall a l, Permutation [a] l -> l = [a]. -Proof. - intros a l H; remember [a] as m in H. - induction H; try (injection Heqm as [= -> ->]); - discriminate || auto. - apply Permutation_nil in H as ->; trivial. -Qed. - -Lemma Permutation_length_1: forall a b, Permutation [a] [b] -> a = b. -Proof. - intros a b H. - apply Permutation_length_1_inv in H; injection H as [= ->]; trivial. -Qed. - -Lemma Permutation_length_2_inv : - forall a1 a2 l, Permutation [a1;a2] l -> l = [a1;a2] \/ l = [a2;a1]. -Proof. - intros a1 a2 l H; remember [a1;a2] as m in H. - revert a1 a2 Heqm. - induction H; intros; try (injection Heqm as [= ? ?]; subst); - discriminate || (try tauto). - - apply Permutation_length_1_inv in H as ->; left; auto. - - apply IHPermutation1 in Heqm as [H1|H1]; apply IHPermutation2 in H1 as []; - auto. -Qed. - -Lemma Permutation_length_2 : - forall a1 a2 b1 b2, Permutation [a1;a2] [b1;b2] -> - a1 = b1 /\ a2 = b2 \/ a1 = b2 /\ a2 = b1. -Proof. - intros a1 b1 a2 b2 H. - apply Permutation_length_2_inv in H as [H|H]; injection H as [= -> ->]; auto. -Qed. - -Lemma Permutation_vs_elt_inv : forall l l1 l2 a, - Permutation l (l1 ++ a :: l2) -> exists l' l'', l = l' ++ a :: l''. -Proof. - intros l l1 l2 a HP. - symmetry in HP. - apply (Permutation_in a), in_split in HP; trivial. - apply in_elt. -Qed. - -Lemma Permutation_vs_cons_inv : forall l l1 a, - Permutation l (a :: l1) -> exists l' l'', l = l' ++ a :: l''. -Proof. - intros l l1 a HP. - rewrite <- (app_nil_l (a :: l1)) in HP. - apply (Permutation_vs_elt_inv _ _ _ HP). -Qed. - -Lemma Permutation_vs_cons_cons_inv : forall l l' a b, - Permutation l (a :: b :: l') -> - exists l1 l2 l3, l = l1 ++ a :: l2 ++ b :: l3 \/ l = l1 ++ b :: l2 ++ a :: l3. -Proof. - intros l l' a b HP. - destruct (Permutation_vs_cons_inv HP) as [l1 [l2]]; subst. - symmetry in HP. - apply Permutation_cons_app_inv in HP. - apply (Permutation_in b), in_app_or in HP; [|now apply in_eq]. - destruct HP as [(l3 & l4 & ->)%in_split | (l3 & l4 & ->)%in_split]. - - exists l3, l4, l2; right. - now rewrite <-app_assoc; simpl. - - now exists l1, l3, l4; left. -Qed. - -Lemma NoDup_Permutation l l' : NoDup l -> NoDup l' -> - (forall x:A, In x l <-> In x l') -> Permutation l l'. -Proof. - intros N. revert l'. induction N as [|a l Hal Hl IH]. - - destruct l'; simpl; auto. - intros Hl' H. exfalso. rewrite (H a); auto. - - intros l' Hl' H. - assert (Ha : In a l') by (apply H; simpl; auto). - destruct (Add_inv _ _ Ha) as (l'' & AD). - rewrite <- (Permutation_Add AD). - apply perm_skip. - apply IH; clear IH. - * now apply (NoDup_Add AD). - * split. - + apply incl_Add_inv with a l'; trivial. intro. apply H. - + intro Hx. - assert (Hx' : In x (a::l)). - { apply H. rewrite (Add_in AD). now right. } - destruct Hx'; simpl; trivial. subst. - rewrite (NoDup_Add AD) in Hl'. tauto. -Qed. - -Lemma NoDup_Permutation_bis l l' : NoDup l -> - length l' <= length l -> incl l l' -> Permutation l l'. -Proof. - intros. apply NoDup_Permutation; auto. - - now apply NoDup_incl_NoDup with l. - - split; auto. - apply NoDup_length_incl; trivial. -Qed. - -Lemma Permutation_NoDup l l' : Permutation l l' -> NoDup l -> NoDup l'. -Proof. - induction 1; auto. - - inversion_clear 1; constructor; eauto using Permutation_in. - - inversion_clear 1 as [|? ? H1 H2]. inversion_clear H2; simpl in *. - constructor. - + simpl; intuition. - + constructor; intuition. -Qed. - -Global Instance Permutation_NoDup' : - Proper (@Permutation A ==> iff) (@NoDup A). -Proof. - repeat red; eauto using Permutation_NoDup. -Qed. - -Lemma Permutation_repeat x n l : - Permutation l (repeat x n) -> l = repeat x n. -Proof. - revert n; induction l as [|y l IHl] ; simpl; intros n HP; auto. - - now apply Permutation_nil in HP; inversion HP. - - assert (y = x) as Heq by (now apply repeat_spec with n, (Permutation_in _ HP); left); subst. - destruct n; simpl; simpl in HP. - + symmetry in HP; apply Permutation_nil in HP; inversion HP. - + f_equal; apply IHl. - now apply Permutation_cons_inv with x. -Qed. - -Lemma Permutation_incl_cons_inv_r (l1 l2 : list A) a : incl l1 (a :: l2) -> - exists n l3, Permutation l1 (repeat a n ++ l3) /\ incl l3 l2. -Proof. - induction l1 as [|b l1 IH]. - - intros _. now exists 0, nil. - - intros [Hb Hincl] %incl_cons_inv. - destruct (IH Hincl) as [n [l3 [Hl1 Hl3l2]]]. - destruct Hb. - + subst b. exists (S n), l3. eauto. - + exists n, (b :: l3). eauto using incl_cons. -Qed. - -Lemma Permutation_pigeonhole l1 l2 : incl l1 l2 -> length l2 < length l1 -> - exists a l3, Permutation l1 (a :: a :: l3). -Proof. - induction l2 as [|a l2 IH] in l1 |- *. - - intros -> %incl_l_nil [] %PeanoNat.Nat.nlt_0_r. - - intros [[|[|n]] [l4 [Hl1 Hl4]]] %Permutation_incl_cons_inv_r Hlen. - + apply IH. - * unfold incl. eauto using Permutation_in. - * eauto using PeanoNat.Nat.lt_trans. - + assert (Hl2l4 : length l2 < length l4). - { rewrite (Permutation_length Hl1) in Hlen. - now apply PeanoNat.Nat.succ_lt_mono. } - destruct (IH l4 Hl4 Hl2l4) as [b [l3 Hl4l3]]. - exists b, (a :: l3). - apply (Permutation_trans Hl1). - now apply (Permutation_cons_app (b :: b :: nil)). - + now exists a, (repeat a n ++ l4). -Qed. - -Lemma Permutation_pigeonhole_rel (R : B -> A -> Prop) (l1 : list B) l2 : - Forall (fun b => Exists (R b) l2) l1 -> - length l2 < length l1 -> - exists b b' (l3 : list B), Permutation l1 (b :: b' :: l3) /\ exists a, In a l2 /\ R b a /\ R b' a. -Proof. - intros [l2' [Hl2'l1 Hl2'l2]]%Forall_Exists_exists_Forall2. - intros Hl2l2'. rewrite (Forall2_length Hl2'l1) in Hl2l2'. - destruct (Permutation_pigeonhole Hl2'l2 Hl2l2') as [a [l3 Hl2']]. - destruct (Permutation_Forall2 Hl2' (Forall2_flip Hl2'l1)) as [l1' [Hl1l1' Hl1']]. - destruct (Forall2_app_inv_l [a; a] l3 Hl1') as [lbb' [l1'' [Ha [? ?]]]]. - assert (Hlbb' := Forall2_length Ha). - destruct lbb' as [|b lb']; [easy|]. - apply Forall2_cons_iff in Ha as [Hba Ha]. - destruct lb' as [|b' l]; [easy|]. - apply Forall2_cons_iff in Ha as [Hb'a Ha]. - inversion Ha. subst. exists b, b', l1''. - split; [easy|]. exists a. - split; eauto using Permutation_in, in_eq. -Qed. - -Hypothesis eq_dec : forall x y : A, {x = y}+{x <> y}. - -Lemma Permutation_count_occ l1 l2 : - Permutation l1 l2 <-> forall x, count_occ eq_dec l1 x = count_occ eq_dec l2 x. -Proof. - split. - - induction 1 as [ | y l1 l2 HP IHP | y z l | l1 l2 l3 HP1 IHP1 HP2 IHP2 ]; - cbn; intros a; auto. - + now rewrite IHP. - + destruct (eq_dec y a); destruct (eq_dec z a); auto. - + now rewrite IHP1, IHP2. - - revert l2; induction l1 as [|y l1 IHl1]; cbn; intros l2 Hocc. - + replace l2 with (@nil A); auto. - symmetry; apply (count_occ_inv_nil eq_dec); intuition. - + assert (exists l2' l2'', l2 = l2' ++ y :: l2'') as [l2' [l2'' ->]]. - { specialize (Hocc y). - destruct (eq_dec y y); intuition. - apply in_split, (count_occ_In eq_dec). - rewrite <- Hocc; apply Nat.lt_0_succ. } - apply Permutation_cons_app, IHl1. - intros z; specialize (Hocc z); destruct (eq_dec y z) as [Heq | Hneq]. - * rewrite (count_occ_elt_eq _ _ _ Heq) in Hocc. - now injection Hocc. - * now rewrite (count_occ_elt_neq _ _ _ Hneq) in Hocc. -Qed. - -End Permutation_properties. - -Section Permutation_map. - -Variable A B : Type. -Variable f : A -> B. - -Lemma Permutation_map l l' : - Permutation l l' -> Permutation (map f l) (map f l'). -Proof. - induction 1; simpl; eauto. -Qed. - -Global Instance Permutation_map' : - Proper (@Permutation A ==> @Permutation B) (map f). -Proof. - exact Permutation_map. -Qed. - -Lemma Permutation_map_inv : forall l1 l2, - Permutation l1 (map f l2) -> exists l3, l1 = map f l3 /\ Permutation l2 l3. -Proof. - induction l1; intros l2 HP. - - exists nil; split; auto. - apply Permutation_nil in HP. - destruct l2; auto. - inversion HP. - - symmetry in HP. - destruct (Permutation_vs_cons_inv HP) as [l3 [l4 Heq]]. - destruct (map_eq_app _ _ _ _ Heq) as [l1' [l2' [Heq1 [Heq2 Heq3]]]]; subst. - destruct (map_eq_cons _ _ Heq3) as [b [l1'' [Heq1' [Heq2' Heq3']]]]; subst. - rewrite map_app in HP; simpl in HP. - symmetry in HP. - apply Permutation_cons_app_inv in HP. - rewrite <- map_app in HP. - destruct (IHl1 _ HP) as [l3 [Heq1'' Heq2'']]; subst. - exists (b :: l3); split; auto. - symmetry in Heq2''; symmetry; apply (Permutation_cons_app _ _ _ Heq2''). -Qed. - -Lemma Permutation_image : forall a l l', - Permutation (a :: l) (map f l') -> exists a', a = f a'. -Proof. - intros a l l' HP. - destruct (Permutation_map_inv _ HP) as [l'' [Heq _]]. - destruct l'' as [ | a' l'']; inversion_clear Heq. - now exists a'. -Qed. - -Lemma Permutation_elt_map_inv: forall l1 l2 l3 l4 a, - Permutation (l1 ++ a :: l2) (l3 ++ map f l4) -> (forall b, a <> f b) -> - exists l1' l2', l3 = l1' ++ a :: l2'. -Proof. - intros l1 l2 l3 l4 a HP Hf. - apply (Permutation_in a), in_app_or in HP; [| now apply in_elt]. - destruct HP as [HP%in_split | (x & Heq & ?)%in_map_iff]; trivial; subst. - now contradiction (Hf x). -Qed. - -Global Instance Permutation_flat_map (g : A -> list B) : - Proper ((@Permutation A) ==> (@Permutation B)) (flat_map g). -Proof. - intros l1; induction l1; intros l2 HP. - - now apply Permutation_nil in HP; subst. - - symmetry in HP. - destruct (Permutation_vs_cons_inv HP) as [l' [l'']]; subst. - symmetry in HP. - apply Permutation_cons_app_inv in HP. - rewrite flat_map_app; simpl. - rewrite <- (app_nil_l _). - apply Permutation_app_middle; simpl. - rewrite <- flat_map_app. - apply (IHl1 _ HP). -Qed. - -End Permutation_map. - -Lemma Permutation_map_same_l {A} (f : A -> A) (l : list A) : - List.NoDup (List.map f l) -> List.incl (List.map f l) l -> Permutation (List.map f l) l. -Proof. - intros; eapply Permutation.NoDup_Permutation_bis; rewrite ?List.length_map; trivial. -Qed. - -Lemma nat_bijection_Permutation n f : - bFun n f -> - Injective f -> - let l := seq 0 n in Permutation (map f l) l. -Proof. - intros Hf BD. - apply NoDup_Permutation_bis; auto using Injective_map_NoDup, seq_NoDup. - * now rewrite length_map. - * intros x. rewrite in_map_iff. intros (y & <- & Hy'). - rewrite in_seq in *. simpl in *. - destruct Hy' as (_,Hy'). - split; [ apply Nat.le_0_l | auto ]. -Qed. - -Section Permutation_alt. -Variable A:Type. -Implicit Type a : A. -Implicit Type l : list A. - -(** Alternative characterization of permutation - via [nth_error] and [nth] *) - -Let adapt f n := - let m := f (S n) in if le_lt_dec m (f 0) then m else pred m. - -Local Definition adapt_injective f : Injective f -> Injective (adapt f). -Proof. - unfold adapt. intros Hf x y EQ. - destruct le_lt_dec as [LE|LT]; destruct le_lt_dec as [LE'|LT']. - - now apply eq_add_S, Hf. - - apply Nat.lt_eq_cases in LE. - destruct LE as [LT|EQ']; [|now apply Hf in EQ']. - unfold lt in LT. rewrite EQ in LT. - rewrite (Nat.lt_succ_pred _ _ LT') in LT. - elim (proj1 (Nat.lt_nge _ _) LT' LT). - - apply Nat.lt_eq_cases in LE'. - destruct LE' as [LT'|EQ']; [|now apply Hf in EQ']. - unfold lt in LT'. rewrite <- EQ in LT'. - rewrite (Nat.lt_succ_pred _ _ LT) in LT'. - elim (proj1 (Nat.lt_nge _ _) LT LT'). - - apply eq_add_S, Hf. - now rewrite <- (Nat.lt_succ_pred _ _ LT), <- (Nat.lt_succ_pred _ _ LT'), EQ. -Defined. - -Local Definition adapt_ok a l1 l2 f : Injective f -> length l1 = f 0 -> - forall n, nth_error (l1++a::l2) (f (S n)) = nth_error (l1++l2) (adapt f n). -Proof. - unfold adapt. intros Hf E n. - destruct le_lt_dec as [LE|LT]. - - apply Nat.lt_eq_cases in LE. - destruct LE as [LT|EQ]; [|now apply Hf in EQ]. - rewrite <- E in LT. - rewrite 2 nth_error_app1; auto. - - rewrite <- (Nat.lt_succ_pred _ _ LT) at 1. - rewrite <- E, <- (Nat.lt_succ_pred _ _ LT) in LT. - rewrite 2 nth_error_app2. - + rewrite Nat.sub_succ_l; [ reflexivity | ]. - apply Nat.lt_succ_r; assumption. - + apply Nat.lt_succ_r; assumption. - + apply Nat.lt_le_incl; assumption. -Defined. - -Lemma Permutation_nth_error l l' : - Permutation l l' <-> - (length l = length l' /\ - exists f:nat->nat, - Injective f /\ forall n, nth_error l' n = nth_error l (f n)). -Proof. - split. - { intros P. - split; [now apply Permutation_length|]. - induction P. - - exists (fun n => n). - split; try red; auto. - - destruct IHP as (f & Hf & Hf'). - exists (fun n => match n with O => O | S n => S (f n) end). - split; try red. - * intros [|y] [|z]; simpl; now auto. - * intros [|n]; simpl; auto. - - exists (fun n => match n with 0 => 1 | 1 => 0 | n => n end). - split; try red. - * intros [|[|z]] [|[|t]]; simpl; now auto. - * intros [|[|n]]; simpl; auto. - - destruct IHP1 as (f & Hf & Hf'). - destruct IHP2 as (g & Hg & Hg'). - exists (fun n => f (g n)). - split; try red. - * auto. - * intros n. rewrite <- Hf'; auto. } - { revert l. induction l'. - - intros [|l] (E & _); now auto. - - intros l (E & f & Hf & Hf'). - simpl in E. - assert (Ha : nth_error l (f 0) = Some a) - by (symmetry; apply (Hf' 0)). - destruct (nth_error_split l (f 0) Ha) as (l1 & l2 & L12 & L1). - rewrite L12. rewrite <- Permutation_middle. constructor. - apply IHl'; split; [|exists (adapt f); split]. - * revert E. rewrite L12, !length_app. simpl. - rewrite <- plus_n_Sm. now injection 1. - * now apply adapt_injective. - * intro n. rewrite <- (adapt_ok a), <- L12; auto. - apply (Hf' (S n)). } -Qed. - -Lemma Permutation_nth_error_bis l l' : - Permutation l l' <-> - exists f:nat->nat, - Injective f /\ - bFun (length l) f /\ - (forall n, nth_error l' n = nth_error l (f n)). -Proof. - rewrite Permutation_nth_error; split. - - intros (E & f & Hf & Hf'). - exists f. do 2 (split; trivial). - intros n Hn. - destruct (Nat.le_gt_cases (length l) (f n)) as [LE|LT]; trivial. - rewrite <- nth_error_None, <- Hf', nth_error_None, <- E in LE. - elim (proj1 (Nat.lt_nge _ _) Hn LE). - - intros (f & Hf & Hf2 & Hf3); split; [|exists f; auto]. - assert (H : length l' <= length l') by auto. - rewrite <- nth_error_None, Hf3, nth_error_None in H. - destruct (Nat.le_gt_cases (length l) (length l')) as [LE|LT]; - [|apply Hf2 in LT; elim (proj1 (Nat.lt_nge _ _) LT H)]. - apply Nat.lt_eq_cases in LE. destruct LE as [LT|EQ]; trivial. - rewrite <- nth_error_Some, Hf3, nth_error_Some in LT. - assert (Hf' : bInjective (length l) f). - { intros x y _ _ E. now apply Hf. } - rewrite (bInjective_bSurjective Hf2) in Hf'. - destruct (Hf' _ LT) as (y & Hy & Hy'). - apply Hf in Hy'. subst y. elim (Nat.lt_irrefl _ Hy). -Qed. - -Lemma Permutation_nth l l' d : - Permutation l l' <-> - (let n := length l in - length l' = n /\ - exists f:nat->nat, - bFun n f /\ - bInjective n f /\ - (forall x, x < n -> nth x l' d = nth (f x) l d)). -Proof. - split. - - intros H. - assert (E := Permutation_length H). - split; auto. - apply Permutation_nth_error_bis in H. - destruct H as (f & Hf & Hf2 & Hf3). - exists f. split; [|split]; auto. - + intros x y _ _ Hxy. now apply Hf. - + intros n Hn. rewrite <- 2 nth_default_eq. unfold nth_default. - now rewrite Hf3. - - intros (E & f & Hf1 & Hf2 & Hf3). - rewrite Permutation_nth_error. - split; auto. - exists (fun n => if le_lt_dec (length l) n then n else f n). - split. - * intros x y. - destruct le_lt_dec as [LE|LT]; - destruct le_lt_dec as [LE'|LT']; auto. - + apply Hf1 in LT'. intros ->. - elim (Nat.lt_irrefl (f y)). eapply Nat.lt_le_trans; eauto. - + apply Hf1 in LT. intros <-. - elim (Nat.lt_irrefl (f x)). eapply Nat.lt_le_trans; eauto. - * intros n. - destruct le_lt_dec as [LE|LT]. - + assert (LE' : length l' <= n) by (now rewrite E). - rewrite <- nth_error_None in LE, LE'. congruence. - + assert (LT' : n < length l') by (now rewrite E). - specialize (Hf3 n LT). rewrite <- 2 nth_default_eq in Hf3. - unfold nth_default in Hf3. - apply Hf1 in LT. - rewrite <- nth_error_Some in LT, LT'. - do 2 destruct nth_error; congruence. -Qed. - -End Permutation_alt. - -#[global] -Instance Permutation_list_sum : Proper (@Permutation nat ==> eq) list_sum | 10. -Proof. - intros l1 l2 HP; induction HP; simpl; intuition. - - rewrite 2 (Nat.add_comm x). - apply Nat.add_assoc. - - now transitivity (list_sum l'). -Qed. - -#[global] -Instance Permutation_list_max : Proper (@Permutation nat ==> eq) list_max | 10. -Proof. - intros l1 l2 HP; induction HP; simpl; intuition. - - rewrite 2 (Nat.max_comm x). - apply Nat.max_assoc. - - now transitivity (list_max l'). -Qed. - -Section Permutation_transp. - -Variable A:Type. - -(** Permutation definition based on transpositions for induction with fixed length *) -Inductive Permutation_transp : list A -> list A -> Prop := -| perm_t_refl : forall l, Permutation_transp l l -| perm_t_swap : forall x y l1 l2, Permutation_transp (l1 ++ y :: x :: l2) (l1 ++ x :: y :: l2) -| perm_t_trans l l' l'' : - Permutation_transp l l' -> Permutation_transp l' l'' -> Permutation_transp l l''. - -Instance Permutation_transp_sym : Symmetric Permutation_transp. -Proof. - intros l1 l2 HP; induction HP; subst; try (now constructor). - now apply (perm_t_trans IHHP2). -Qed. - -Global Instance Permutation_transp_equiv : Equivalence Permutation_transp | 100. -Proof. - split. - - intros l; apply perm_t_refl. - - apply Permutation_transp_sym. - - intros l1 l2 l3 ;apply perm_t_trans. -Qed. - -Lemma Permutation_transp_cons : forall (x : A) l1 l2, - Permutation_transp l1 l2 -> Permutation_transp (x :: l1) (x :: l2). -Proof. - intros x l1 l2 HP. - induction HP. - - reflexivity. - - rewrite 2 app_comm_cons. - apply perm_t_swap. - - now transitivity (x :: l'). -Qed. - -Lemma Permutation_Permutation_transp : forall l1 l2 : list A, - Permutation l1 l2 <-> Permutation_transp l1 l2. -Proof. - intros l1 l2; split; intros HP; induction HP; intuition auto. - - solve_relation. - - now apply Permutation_transp_cons. - - rewrite <- (app_nil_l (y :: _)). - rewrite <- (app_nil_l (x :: y :: _)). - apply perm_t_swap. - - now transitivity l'. - - apply Permutation_app_head. - apply perm_swap. - - now transitivity l'. -Qed. - -Lemma Permutation_ind_transp : forall P : list A -> list A -> Prop, - (forall l, P l l) -> - (forall x y l1 l2, P (l1 ++ y :: x :: l2) (l1 ++ x :: y :: l2)) -> - (forall l l' l'', - Permutation l l' -> P l l' -> Permutation l' l'' -> P l' l'' -> P l l'') -> - forall l1 l2, Permutation l1 l2 -> P l1 l2. -Proof. - intros P Hr Ht Htr l1 l2 HP; apply Permutation_Permutation_transp in HP. - revert Hr Ht Htr; induction HP; intros Hr Ht Htr; auto. - apply (Htr _ l'); intuition; now apply Permutation_Permutation_transp. -Qed. - -End Permutation_transp. - -(* begin hide *) -Notation Permutation_app_swap := Permutation_app_comm (only parsing). -(* end hide *) diff --git a/stdlib/theories/Sorting/Sorted.v b/stdlib/theories/Sorting/Sorted.v deleted file mode 100644 index b66702c9d952..000000000000 --- a/stdlib/theories/Sorting/Sorted.v +++ /dev/null @@ -1,163 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* A -> Prop. - - (** Locally sorted: consecutive elements of the list are ordered *) - - Inductive LocallySorted : list A -> Prop := - | LSorted_nil : LocallySorted [] - | LSorted_cons1 a : LocallySorted [a] - | LSorted_consn a b l : - LocallySorted (b :: l) -> R a b -> LocallySorted (a :: b :: l). - - (** Alternative two-step definition of being locally sorted *) - - Inductive HdRel a : list A -> Prop := - | HdRel_nil : HdRel a [] - | HdRel_cons b l : R a b -> HdRel a (b :: l). - - Inductive Sorted : list A -> Prop := - | Sorted_nil : Sorted [] - | Sorted_cons a l : Sorted l -> HdRel a l -> Sorted (a :: l). - - Lemma HdRel_inv : forall a b l, HdRel a (b :: l) -> R a b. - Proof. - inversion 1; auto. - Qed. - - Lemma Sorted_inv : - forall a l, Sorted (a :: l) -> Sorted l /\ HdRel a l. - Proof. - intros a l H; inversion H; auto. - Qed. - - Lemma Sorted_rect : - forall P:list A -> Type, - P [] -> - (forall a l, Sorted l -> P l -> HdRel a l -> P (a :: l)) -> - forall l:list A, Sorted l -> P l. - Proof. - intros P ? ? l. - induction l. - - firstorder using Sorted_inv. - - firstorder using Sorted_inv. - Qed. - - Lemma Sorted_LocallySorted_iff : forall l, Sorted l <-> LocallySorted l. - Proof. - split; [induction 1 as [|a l [|]]| induction 1]; - auto using Sorted, LocallySorted, HdRel. - match goal with H1 : HdRel a (_ :: _) |- _ => inversion H1 end. - subst; auto using LocallySorted. - Qed. - - (** Strongly sorted: elements of the list are pairwise ordered *) - - Inductive StronglySorted : list A -> Prop := - | SSorted_nil : StronglySorted [] - | SSorted_cons a l : StronglySorted l -> Forall (R a) l -> StronglySorted (a :: l). - - Lemma StronglySorted_inv : forall a l, StronglySorted (a :: l) -> - StronglySorted l /\ Forall (R a) l. - Proof. - intros a l H; inversion H; auto. - Defined. - - Lemma StronglySorted_rect : - forall P:list A -> Type, - P [] -> - (forall a l, StronglySorted l -> P l -> Forall (R a) l -> P (a :: l)) -> - forall l, StronglySorted l -> P l. - Proof. - intros P ? ? l; induction l; firstorder using StronglySorted_inv. - Defined. - - Lemma StronglySorted_rec : - forall P:list A -> Type, - P [] -> - (forall a l, StronglySorted l -> P l -> Forall (R a) l -> P (a :: l)) -> - forall l, StronglySorted l -> P l. - Proof. - firstorder using StronglySorted_rect. - Qed. - - Lemma StronglySorted_Sorted : forall l, StronglySorted l -> Sorted l. - Proof. - induction 1 as [|? ? ? ? HForall]; constructor; trivial. - destruct HForall; constructor; trivial. - Qed. - - Lemma Sorted_extends : - Transitive R -> forall a l, Sorted (a::l) -> Forall (R a) l. - Proof. - intros H a l H0. - change match a :: l with [] => True | a :: l => Forall (R a) l end. - induction H0 as [|? ? ? ? H1]; [trivial|]. - destruct H1; constructor; trivial. - eapply Forall_impl; [|eassumption]. - firstorder. - Qed. - - Lemma Sorted_StronglySorted : - Transitive R -> forall l, Sorted l -> StronglySorted l. - Proof. - induction 2; constructor; trivial. - apply Sorted_extends; trivial. - constructor; trivial. - Qed. - -End defs. - -#[global] -Hint Constructors HdRel : core. -#[global] -Hint Constructors Sorted : core. - -(* begin hide *) -(* Compatibility with deprecated file Sorting.v *) -Notation lelistA := HdRel (only parsing). -Notation nil_leA := HdRel_nil (only parsing). -Notation cons_leA := HdRel_cons (only parsing). - -Notation sort := Sorted (only parsing). -Notation nil_sort := Sorted_nil (only parsing). -Notation cons_sort := Sorted_cons (only parsing). - -Notation lelistA_inv := HdRel_inv (only parsing). -Notation sort_inv := Sorted_inv (only parsing). -Notation sort_rect := Sorted_rect (only parsing). -(* end hide *) diff --git a/stdlib/theories/Sorting/Sorting.v b/stdlib/theories/Sorting/Sorting.v deleted file mode 100644 index 09224148f46f..000000000000 --- a/stdlib/theories/Sorting/Sorting.v +++ /dev/null @@ -1,12 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* Ascii c a1 a2 a3 a4 a5 a6 a7 - end. - -(** Definition of a decidable function that is effective *) - -Definition ascii_dec : forall a b : ascii, {a = b} + {a <> b}. -Proof. - decide equality; apply bool_dec. -Defined. - -Local Open Scope lazy_bool_scope. - -Definition eqb (a b : ascii) : bool := - match a, b with - | Ascii a0 a1 a2 a3 a4 a5 a6 a7, - Ascii b0 b1 b2 b3 b4 b5 b6 b7 => - Bool.eqb a0 b0 &&& Bool.eqb a1 b1 &&& Bool.eqb a2 b2 &&& Bool.eqb a3 b3 - &&& Bool.eqb a4 b4 &&& Bool.eqb a5 b5 &&& Bool.eqb a6 b6 &&& Bool.eqb a7 b7 - end. - -Infix "=?" := eqb : char_scope. - -Lemma eqb_spec (a b : ascii) : reflect (a = b) (a =? b)%char. -Proof. - destruct a, b; simpl. - do 8 (case Bool.eqb_spec; [ intros -> | constructor; now intros [= ] ]). - now constructor. -Qed. - -Local Ltac t_eqb := - repeat first [ congruence - | progress subst - | apply conj - | match goal with - | [ |- context[eqb ?x ?y] ] => destruct (eqb_spec x y) - end - | intro ]. -Lemma eqb_refl x : (x =? x)%char = true. Proof. t_eqb. Qed. -Lemma eqb_sym x y : (x =? y)%char = (y =? x)%char. Proof. t_eqb. Qed. -Lemma eqb_eq n m : (n =? m)%char = true <-> n = m. Proof. t_eqb. Qed. -Lemma eqb_neq x y : (x =? y)%char = false <-> x <> y. Proof. t_eqb. Qed. -Lemma eqb_compat: Morphisms.Proper (Morphisms.respectful eq (Morphisms.respectful eq eq)) eqb. -Proof. t_eqb. Qed. - -(** * Conversion between natural numbers modulo 256 and ascii characters *) - -(** Auxiliary function that turns a positive into an ascii by - looking at the last 8 bits, ie z mod 2^8 *) - -Definition ascii_of_pos : positive -> ascii := - let loop := fix loop n p := - match n with - | O => zero - | S n' => - match p with - | xH => one - | xI p' => shift true (loop n' p') - | xO p' => shift false (loop n' p') - end - end - in loop 8. - -(** Conversion from [N] to [ascii] *) - -Definition ascii_of_N (n : N) := - match n with - | N0 => zero - | Npos p => ascii_of_pos p - end. - -(** Same for [nat] *) - -Definition ascii_of_nat (a : nat) := ascii_of_N (N.of_nat a). - -(** The opposite functions *) - -Local Open Scope list_scope. - -Fixpoint N_of_digits (l:list bool) : N := - match l with - | nil => 0 - | b :: l' => (if b then 1 else 0) + 2*(N_of_digits l') - end%N. - -Definition N_of_ascii (a : ascii) : N := - let (a0,a1,a2,a3,a4,a5,a6,a7) := a in - N_of_digits (a0::a1::a2::a3::a4::a5::a6::a7::nil). - -Definition nat_of_ascii (a : ascii) : nat := N.to_nat (N_of_ascii a). - -(** Proofs that we have indeed opposite function (below 256) *) - -Theorem ascii_N_embedding : - forall a : ascii, ascii_of_N (N_of_ascii a) = a. -Proof. - intro a; destruct a as [[|][|][|][|][|][|][|][|]]; vm_compute; reflexivity. -Qed. - -Theorem N_ascii_embedding : - forall n:N, (n < 256)%N -> N_of_ascii (ascii_of_N n) = n. -Proof. -intro n; destruct n as [|p]. -- reflexivity. -- do 8 (destruct p as [p|p|]; [ | | intros; vm_compute; reflexivity ]); - intro H; vm_compute in H; destruct p; discriminate. -Qed. - -Theorem N_ascii_bounded : - forall a : ascii, (N_of_ascii a < 256)%N. -Proof. - intro a; destruct a as [[|][|][|][|][|][|][|][|]]; vm_compute; reflexivity. -Qed. - -Theorem ascii_nat_embedding : - forall a : ascii, ascii_of_nat (nat_of_ascii a) = a. -Proof. - intro a; destruct a as [[|][|][|][|][|][|][|][|]]; compute; reflexivity. -Qed. - -Theorem nat_ascii_embedding : - forall n : nat, n < 256 -> nat_of_ascii (ascii_of_nat n) = n. -Proof. - intros. unfold nat_of_ascii, ascii_of_nat. - rewrite N_ascii_embedding. - - apply Nat2N.id. - - unfold N.lt. - change 256%N with (N.of_nat 256). - rewrite <- Nat2N.inj_compare. - now apply Nat.compare_lt_iff. -Qed. - -Theorem nat_ascii_bounded : - forall a : ascii, nat_of_ascii a < 256. -Proof. - intro a; unfold nat_of_ascii. - change 256 with (N.to_nat 256). - rewrite <- Nat.compare_lt_iff, <- N2Nat.inj_compare, N.compare_lt_iff. - apply N_ascii_bounded. -Qed. - -Definition compare (a b : ascii) : comparison := - N.compare (N_of_ascii a) (N_of_ascii b). - -Lemma compare_antisym (a b : ascii) : - compare a b = CompOpp (compare b a). -Proof. apply N.compare_antisym. Qed. - -Lemma compare_eq_iff (a b : ascii) : compare a b = Eq -> a = b. -Proof. - unfold compare. - intros H. - apply N.compare_eq_iff in H. - rewrite <- ascii_N_embedding. - rewrite <- H. - rewrite ascii_N_embedding. - reflexivity. -Qed. - -Definition ltb (a b : ascii) : bool := - if compare a b is Lt then true else false. - -Definition leb (a b : ascii) : bool := - if compare a b is Gt then false else true. - -Lemma leb_antisym (a b : ascii) : - leb a b = true -> leb b a = true -> a = b. -Proof. - unfold leb. - rewrite compare_antisym. - destruct (compare b a) eqn:Hcmp; simpl in *; intuition. - - apply compare_eq_iff in Hcmp. intuition. - - discriminate H. - - discriminate H0. -Qed. - -Lemma leb_total (a b : ascii) : leb a b = true \/ leb b a = true. -Proof. - unfold leb. - rewrite compare_antisym. - destruct (compare b a); intuition. -Qed. - -Infix "?=" := compare : char_scope. -Infix "= 128 do not denote - stand-alone utf8 characters so that only the notation "nnn" is - available for them (unless your terminal is able to represent them, - which is typically not the case in coqide). - *) - -Definition ascii_of_byte (b : byte) : ascii - := let '(b0, (b1, (b2, (b3, (b4, (b5, (b6, b7))))))) := Byte.to_bits b in - Ascii b0 b1 b2 b3 b4 b5 b6 b7. - -Definition byte_of_ascii (a : ascii) : byte - := let (b0, b1, b2, b3, b4, b5, b6, b7) := a in - Byte.of_bits (b0, (b1, (b2, (b3, (b4, (b5, (b6, b7))))))). - -Lemma ascii_of_byte_of_ascii x : ascii_of_byte (byte_of_ascii x) = x. -Proof. - cbv [ascii_of_byte byte_of_ascii]. - destruct x; rewrite to_bits_of_bits; reflexivity. -Qed. - -Lemma byte_of_ascii_of_byte x : byte_of_ascii (ascii_of_byte x) = x. -Proof. - cbv [ascii_of_byte byte_of_ascii]. - repeat match goal with - | [ |- context[match ?x with pair _ _ => _ end] ] - => rewrite (surjective_pairing x) - | [ |- context[(fst ?x, snd ?x)] ] - => rewrite <- (surjective_pairing x) - end. - rewrite of_bits_to_bits; reflexivity. -Qed. - -Lemma ascii_of_byte_via_N x : ascii_of_byte x = ascii_of_N (Byte.to_N x). -Proof. destruct x; reflexivity. Qed. - -Lemma ascii_of_byte_via_nat x : ascii_of_byte x = ascii_of_nat (Byte.to_nat x). -Proof. destruct x; reflexivity. Qed. - -Lemma byte_of_ascii_via_N x : Some (byte_of_ascii x) = Byte.of_N (N_of_ascii x). -Proof. - rewrite <- (ascii_of_byte_of_ascii x); destruct (byte_of_ascii x); reflexivity. -Qed. - -Lemma byte_of_ascii_via_nat x : Some (byte_of_ascii x) = Byte.of_nat (nat_of_ascii x). -Proof. - rewrite <- (ascii_of_byte_of_ascii x); destruct (byte_of_ascii x); reflexivity. -Qed. - -Module Export AsciiSyntax. - String Notation ascii ascii_of_byte byte_of_ascii : char_scope. -End AsciiSyntax. - -Local Open Scope char_scope. - -Example Space := " ". -Example DoubleQuote := """". -Example Beep := "007". diff --git a/stdlib/theories/Strings/BinaryString.v b/stdlib/theories/Strings/BinaryString.v deleted file mode 100644 index 94fb82216bee..000000000000 --- a/stdlib/theories/Strings/BinaryString.v +++ /dev/null @@ -1,149 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* (pos_bin_app p q)~0 - | q~1 => (pos_bin_app p q)~1 - | 1 => p~1 - end. - -Module Raw. - Fixpoint of_pos (p : positive) (rest : string) : string - := match p with - | 1 => String "1" rest - | p'~0 => of_pos p' (String "0" rest) - | p'~1 => of_pos p' (String "1" rest) - end. - - Fixpoint to_N (s : string) (rest : N) - : N - := match s with - | "" => rest - | String ch s' - => to_N - s' - match ascii_to_digit ch with - | Some v => N.add v (N.double rest) - | None => N0 - end - end. - - Fixpoint to_N_of_pos (p : positive) (rest : string) (base : N) {struct p} - : to_N (of_pos p rest) base - = to_N rest match base with - | N0 => N.pos p - | Npos v => Npos (pos_bin_app v p) - end. - Proof. - destruct p as [p|p|]; destruct base; try reflexivity; - cbn; rewrite to_N_of_pos; reflexivity. - Qed. -End Raw. - -Definition of_pos (p : positive) : string - := String "0" (String "b" (Raw.of_pos p "")). -Definition of_N (n : N) : string - := match n with - | N0 => "0b0" - | Npos p => of_pos p - end. -Definition of_Z (z : Z) : string - := match z with - | Zneg p => String "-" (of_pos p) - | Z0 => "0b0" - | Zpos p => of_pos p - end. -Definition of_nat (n : nat) : string - := of_N (N.of_nat n). - -Definition to_N (s : string) : N - := match s with - | String s0 (String sb s) - => if ascii_dec s0 "0" - then if ascii_dec sb "b" - then Raw.to_N s N0 - else N0 - else N0 - | _ => N0 - end. -Definition to_pos (s : string) : positive - := match to_N s with - | N0 => 1 - | Npos p => p - end. -Definition to_Z (s : string) : Z - := let '(is_neg, n) := match s with - | String s0 s' - => if ascii_dec s0 "-" - then (true, to_N s') - else (false, to_N s) - | EmptyString => (false, to_N s) - end in - match n with - | N0 => Z0 - | Npos p => if is_neg then Zneg p else Zpos p - end. -Definition to_nat (s : string) : nat - := N.to_nat (to_N s). - -Lemma to_N_of_N (n : N) - : to_N (of_N n) - = n. -Proof. - destruct n; [ reflexivity | apply Raw.to_N_of_pos ]. -Qed. - -Lemma Z_of_of_Z (z : Z) - : to_Z (of_Z z) - = z. -Proof. - cbv [of_Z to_Z]; destruct z as [|z|z]; cbn; - try reflexivity; - rewrite Raw.to_N_of_pos; cbn; reflexivity. -Qed. - -Lemma to_nat_of_nat (n : nat) - : to_nat (of_nat n) - = n. -Proof. - cbv [to_nat of_nat]; - rewrite to_N_of_N, Nnat.Nat2N.id; reflexivity. -Qed. - -Lemma to_pos_of_pos (p : positive) - : to_pos (of_pos p) - = p. -Proof. - cbv [of_pos to_pos to_N]; cbn; - rewrite Raw.to_N_of_pos; cbn; reflexivity. -Qed. - -Example of_pos_1 : of_pos 1 = "0b1" := eq_refl. -Example of_pos_2 : of_pos 2 = "0b10" := eq_refl. -Example of_pos_3 : of_pos 3 = "0b11" := eq_refl. -Example of_N_0 : of_N 0 = "0b0" := eq_refl. -Example of_Z_0 : of_Z 0 = "0b0" := eq_refl. -Example of_Z_m1 : of_Z (-1) = "-0b1" := eq_refl. -Example of_nat_0 : of_nat 0 = "0b0" := eq_refl. diff --git a/stdlib/theories/Strings/Byte.v b/stdlib/theories/Strings/Byte.v deleted file mode 100644 index 3bfa34ffa3c1..000000000000 --- a/stdlib/theories/Strings/Byte.v +++ /dev/null @@ -1,1211 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* eqb x y = true. -Proof. intro; subst y; destruct x; reflexivity. Defined. - -Lemma byte_dec_bl x y (H : eqb x y = true) : x = y. -Proof. - rewrite <- (of_bits_to_bits x), <- (of_bits_to_bits y). - unfold eqb in H; revert H. - assert (H : forall (P : bool -> bool -> Prop) b1 b2 b3, (b3 = true -> P b1 b1) -> (b3 && Bool.eqb b1 b2)%bool = true -> P b1 b2). - { intros ???? H [? <-%Bool.eqb_prop]%Bool.andb_true_iff. now apply H. } - destruct (to_bits x) as (? & ? & ? & ? & ? & ? & ? & ?). - destruct (to_bits y) as (? & ? & ? & ? & ? & ? & ? & ?). - do 7 refine (H (fun _ _ => _) _ _ _ _). - now intros <-%Bool.eqb_prop. -Qed. - -Lemma eqb_false x y : eqb x y = false -> x <> y. -Proof. intros H H'; pose proof (byte_dec_lb H'); congruence. Qed. - -Definition byte_eq_dec (x y : byte) : {x = y} + {x <> y} - := (if eqb x y as beq return eqb x y = beq -> _ - then fun pf => left (byte_dec_bl x y pf) - else fun pf => right (eqb_false pf)) - eq_refl. - -Section nat. - Definition to_nat (x : byte) : nat - := match x with - | x00 => 0 - | x01 => 1 - | x02 => 2 - | x03 => 3 - | x04 => 4 - | x05 => 5 - | x06 => 6 - | x07 => 7 - | x08 => 8 - | x09 => 9 - | x0a => 10 - | x0b => 11 - | x0c => 12 - | x0d => 13 - | x0e => 14 - | x0f => 15 - | x10 => 16 - | x11 => 17 - | x12 => 18 - | x13 => 19 - | x14 => 20 - | x15 => 21 - | x16 => 22 - | x17 => 23 - | x18 => 24 - | x19 => 25 - | x1a => 26 - | x1b => 27 - | x1c => 28 - | x1d => 29 - | x1e => 30 - | x1f => 31 - | x20 => 32 - | x21 => 33 - | x22 => 34 - | x23 => 35 - | x24 => 36 - | x25 => 37 - | x26 => 38 - | x27 => 39 - | x28 => 40 - | x29 => 41 - | x2a => 42 - | x2b => 43 - | x2c => 44 - | x2d => 45 - | x2e => 46 - | x2f => 47 - | x30 => 48 - | x31 => 49 - | x32 => 50 - | x33 => 51 - | x34 => 52 - | x35 => 53 - | x36 => 54 - | x37 => 55 - | x38 => 56 - | x39 => 57 - | x3a => 58 - | x3b => 59 - | x3c => 60 - | x3d => 61 - | x3e => 62 - | x3f => 63 - | x40 => 64 - | x41 => 65 - | x42 => 66 - | x43 => 67 - | x44 => 68 - | x45 => 69 - | x46 => 70 - | x47 => 71 - | x48 => 72 - | x49 => 73 - | x4a => 74 - | x4b => 75 - | x4c => 76 - | x4d => 77 - | x4e => 78 - | x4f => 79 - | x50 => 80 - | x51 => 81 - | x52 => 82 - | x53 => 83 - | x54 => 84 - | x55 => 85 - | x56 => 86 - | x57 => 87 - | x58 => 88 - | x59 => 89 - | x5a => 90 - | x5b => 91 - | x5c => 92 - | x5d => 93 - | x5e => 94 - | x5f => 95 - | x60 => 96 - | x61 => 97 - | x62 => 98 - | x63 => 99 - | x64 => 100 - | x65 => 101 - | x66 => 102 - | x67 => 103 - | x68 => 104 - | x69 => 105 - | x6a => 106 - | x6b => 107 - | x6c => 108 - | x6d => 109 - | x6e => 110 - | x6f => 111 - | x70 => 112 - | x71 => 113 - | x72 => 114 - | x73 => 115 - | x74 => 116 - | x75 => 117 - | x76 => 118 - | x77 => 119 - | x78 => 120 - | x79 => 121 - | x7a => 122 - | x7b => 123 - | x7c => 124 - | x7d => 125 - | x7e => 126 - | x7f => 127 - | x80 => 128 - | x81 => 129 - | x82 => 130 - | x83 => 131 - | x84 => 132 - | x85 => 133 - | x86 => 134 - | x87 => 135 - | x88 => 136 - | x89 => 137 - | x8a => 138 - | x8b => 139 - | x8c => 140 - | x8d => 141 - | x8e => 142 - | x8f => 143 - | x90 => 144 - | x91 => 145 - | x92 => 146 - | x93 => 147 - | x94 => 148 - | x95 => 149 - | x96 => 150 - | x97 => 151 - | x98 => 152 - | x99 => 153 - | x9a => 154 - | x9b => 155 - | x9c => 156 - | x9d => 157 - | x9e => 158 - | x9f => 159 - | xa0 => 160 - | xa1 => 161 - | xa2 => 162 - | xa3 => 163 - | xa4 => 164 - | xa5 => 165 - | xa6 => 166 - | xa7 => 167 - | xa8 => 168 - | xa9 => 169 - | xaa => 170 - | xab => 171 - | xac => 172 - | xad => 173 - | xae => 174 - | xaf => 175 - | xb0 => 176 - | xb1 => 177 - | xb2 => 178 - | xb3 => 179 - | xb4 => 180 - | xb5 => 181 - | xb6 => 182 - | xb7 => 183 - | xb8 => 184 - | xb9 => 185 - | xba => 186 - | xbb => 187 - | xbc => 188 - | xbd => 189 - | xbe => 190 - | xbf => 191 - | xc0 => 192 - | xc1 => 193 - | xc2 => 194 - | xc3 => 195 - | xc4 => 196 - | xc5 => 197 - | xc6 => 198 - | xc7 => 199 - | xc8 => 200 - | xc9 => 201 - | xca => 202 - | xcb => 203 - | xcc => 204 - | xcd => 205 - | xce => 206 - | xcf => 207 - | xd0 => 208 - | xd1 => 209 - | xd2 => 210 - | xd3 => 211 - | xd4 => 212 - | xd5 => 213 - | xd6 => 214 - | xd7 => 215 - | xd8 => 216 - | xd9 => 217 - | xda => 218 - | xdb => 219 - | xdc => 220 - | xdd => 221 - | xde => 222 - | xdf => 223 - | xe0 => 224 - | xe1 => 225 - | xe2 => 226 - | xe3 => 227 - | xe4 => 228 - | xe5 => 229 - | xe6 => 230 - | xe7 => 231 - | xe8 => 232 - | xe9 => 233 - | xea => 234 - | xeb => 235 - | xec => 236 - | xed => 237 - | xee => 238 - | xef => 239 - | xf0 => 240 - | xf1 => 241 - | xf2 => 242 - | xf3 => 243 - | xf4 => 244 - | xf5 => 245 - | xf6 => 246 - | xf7 => 247 - | xf8 => 248 - | xf9 => 249 - | xfa => 250 - | xfb => 251 - | xfc => 252 - | xfd => 253 - | xfe => 254 - | xff => 255 - end. - - Definition of_nat (x : nat) : option byte - := match x with - | 0 => Some x00 - | 1 => Some x01 - | 2 => Some x02 - | 3 => Some x03 - | 4 => Some x04 - | 5 => Some x05 - | 6 => Some x06 - | 7 => Some x07 - | 8 => Some x08 - | 9 => Some x09 - | 10 => Some x0a - | 11 => Some x0b - | 12 => Some x0c - | 13 => Some x0d - | 14 => Some x0e - | 15 => Some x0f - | 16 => Some x10 - | 17 => Some x11 - | 18 => Some x12 - | 19 => Some x13 - | 20 => Some x14 - | 21 => Some x15 - | 22 => Some x16 - | 23 => Some x17 - | 24 => Some x18 - | 25 => Some x19 - | 26 => Some x1a - | 27 => Some x1b - | 28 => Some x1c - | 29 => Some x1d - | 30 => Some x1e - | 31 => Some x1f - | 32 => Some x20 - | 33 => Some x21 - | 34 => Some x22 - | 35 => Some x23 - | 36 => Some x24 - | 37 => Some x25 - | 38 => Some x26 - | 39 => Some x27 - | 40 => Some x28 - | 41 => Some x29 - | 42 => Some x2a - | 43 => Some x2b - | 44 => Some x2c - | 45 => Some x2d - | 46 => Some x2e - | 47 => Some x2f - | 48 => Some x30 - | 49 => Some x31 - | 50 => Some x32 - | 51 => Some x33 - | 52 => Some x34 - | 53 => Some x35 - | 54 => Some x36 - | 55 => Some x37 - | 56 => Some x38 - | 57 => Some x39 - | 58 => Some x3a - | 59 => Some x3b - | 60 => Some x3c - | 61 => Some x3d - | 62 => Some x3e - | 63 => Some x3f - | 64 => Some x40 - | 65 => Some x41 - | 66 => Some x42 - | 67 => Some x43 - | 68 => Some x44 - | 69 => Some x45 - | 70 => Some x46 - | 71 => Some x47 - | 72 => Some x48 - | 73 => Some x49 - | 74 => Some x4a - | 75 => Some x4b - | 76 => Some x4c - | 77 => Some x4d - | 78 => Some x4e - | 79 => Some x4f - | 80 => Some x50 - | 81 => Some x51 - | 82 => Some x52 - | 83 => Some x53 - | 84 => Some x54 - | 85 => Some x55 - | 86 => Some x56 - | 87 => Some x57 - | 88 => Some x58 - | 89 => Some x59 - | 90 => Some x5a - | 91 => Some x5b - | 92 => Some x5c - | 93 => Some x5d - | 94 => Some x5e - | 95 => Some x5f - | 96 => Some x60 - | 97 => Some x61 - | 98 => Some x62 - | 99 => Some x63 - | 100 => Some x64 - | 101 => Some x65 - | 102 => Some x66 - | 103 => Some x67 - | 104 => Some x68 - | 105 => Some x69 - | 106 => Some x6a - | 107 => Some x6b - | 108 => Some x6c - | 109 => Some x6d - | 110 => Some x6e - | 111 => Some x6f - | 112 => Some x70 - | 113 => Some x71 - | 114 => Some x72 - | 115 => Some x73 - | 116 => Some x74 - | 117 => Some x75 - | 118 => Some x76 - | 119 => Some x77 - | 120 => Some x78 - | 121 => Some x79 - | 122 => Some x7a - | 123 => Some x7b - | 124 => Some x7c - | 125 => Some x7d - | 126 => Some x7e - | 127 => Some x7f - | 128 => Some x80 - | 129 => Some x81 - | 130 => Some x82 - | 131 => Some x83 - | 132 => Some x84 - | 133 => Some x85 - | 134 => Some x86 - | 135 => Some x87 - | 136 => Some x88 - | 137 => Some x89 - | 138 => Some x8a - | 139 => Some x8b - | 140 => Some x8c - | 141 => Some x8d - | 142 => Some x8e - | 143 => Some x8f - | 144 => Some x90 - | 145 => Some x91 - | 146 => Some x92 - | 147 => Some x93 - | 148 => Some x94 - | 149 => Some x95 - | 150 => Some x96 - | 151 => Some x97 - | 152 => Some x98 - | 153 => Some x99 - | 154 => Some x9a - | 155 => Some x9b - | 156 => Some x9c - | 157 => Some x9d - | 158 => Some x9e - | 159 => Some x9f - | 160 => Some xa0 - | 161 => Some xa1 - | 162 => Some xa2 - | 163 => Some xa3 - | 164 => Some xa4 - | 165 => Some xa5 - | 166 => Some xa6 - | 167 => Some xa7 - | 168 => Some xa8 - | 169 => Some xa9 - | 170 => Some xaa - | 171 => Some xab - | 172 => Some xac - | 173 => Some xad - | 174 => Some xae - | 175 => Some xaf - | 176 => Some xb0 - | 177 => Some xb1 - | 178 => Some xb2 - | 179 => Some xb3 - | 180 => Some xb4 - | 181 => Some xb5 - | 182 => Some xb6 - | 183 => Some xb7 - | 184 => Some xb8 - | 185 => Some xb9 - | 186 => Some xba - | 187 => Some xbb - | 188 => Some xbc - | 189 => Some xbd - | 190 => Some xbe - | 191 => Some xbf - | 192 => Some xc0 - | 193 => Some xc1 - | 194 => Some xc2 - | 195 => Some xc3 - | 196 => Some xc4 - | 197 => Some xc5 - | 198 => Some xc6 - | 199 => Some xc7 - | 200 => Some xc8 - | 201 => Some xc9 - | 202 => Some xca - | 203 => Some xcb - | 204 => Some xcc - | 205 => Some xcd - | 206 => Some xce - | 207 => Some xcf - | 208 => Some xd0 - | 209 => Some xd1 - | 210 => Some xd2 - | 211 => Some xd3 - | 212 => Some xd4 - | 213 => Some xd5 - | 214 => Some xd6 - | 215 => Some xd7 - | 216 => Some xd8 - | 217 => Some xd9 - | 218 => Some xda - | 219 => Some xdb - | 220 => Some xdc - | 221 => Some xdd - | 222 => Some xde - | 223 => Some xdf - | 224 => Some xe0 - | 225 => Some xe1 - | 226 => Some xe2 - | 227 => Some xe3 - | 228 => Some xe4 - | 229 => Some xe5 - | 230 => Some xe6 - | 231 => Some xe7 - | 232 => Some xe8 - | 233 => Some xe9 - | 234 => Some xea - | 235 => Some xeb - | 236 => Some xec - | 237 => Some xed - | 238 => Some xee - | 239 => Some xef - | 240 => Some xf0 - | 241 => Some xf1 - | 242 => Some xf2 - | 243 => Some xf3 - | 244 => Some xf4 - | 245 => Some xf5 - | 246 => Some xf6 - | 247 => Some xf7 - | 248 => Some xf8 - | 249 => Some xf9 - | 250 => Some xfa - | 251 => Some xfb - | 252 => Some xfc - | 253 => Some xfd - | 254 => Some xfe - | 255 => Some xff - | _ => None - end. - - Lemma of_to_nat x : of_nat (to_nat x) = Some x. - Proof. destruct x; reflexivity. Qed. - - Lemma to_of_nat x y : of_nat x = Some y -> to_nat y = x. - Proof. - intros E. - pose (P := fun n : nat => match of_nat n with Some z => to_nat z = n | None => True end). - enough (H : P x) by now subst P; simpl in H; rewrite E in H. - clear y E. revert x. - assert (H : forall P, P 0 -> (forall n, P (S n)) -> forall n, P n) by now intros ??? [|?]. - now do 256 refine (H _ eq_refl _). - Qed. - - Lemma to_of_nat_iff x y : of_nat x = Some y <-> to_nat y = x. - Proof. split; intro; subst; (apply of_to_nat || apply to_of_nat); assumption. Qed. - - Lemma to_of_nat_option_map x : option_map to_nat (of_nat x) = if Nat.leb x 255 then Some x else None. - Proof. - pose (P := (fun n : nat => option_map to_nat (of_nat n) = (if Nat.leb n 255 then Some n else None))). - change (P x). revert x. - assert (H : forall P, P 0 -> (forall n, P (S n)) -> forall n, P n) by now intros ??? [|?]. - now do 256 (refine (H _ eq_refl _)). - Qed. - - Lemma to_nat_bounded x : to_nat x <= 255. - Proof. - apply PeanoNat.Nat.leb_le. - generalize (to_of_nat_option_map (to_nat x)). - rewrite of_to_nat. - now destruct (Nat.leb (to_nat x) 255). - Qed. - - Lemma of_nat_None_iff x : of_nat x = None <-> 255 < x. - Proof. - assert (H := to_of_nat_option_map x). - split. - - intros E. rewrite E in H. - now destruct (PeanoNat.Nat.leb_spec x 255). - - intros E%PeanoNat.Nat.leb_gt. rewrite E in H. - now destruct (of_nat x). - Qed. -End nat. - -Section N. - Local Open Scope N_scope. - - Definition to_N (x : byte) : N - := match x with - | x00 => 0 - | x01 => 1 - | x02 => 2 - | x03 => 3 - | x04 => 4 - | x05 => 5 - | x06 => 6 - | x07 => 7 - | x08 => 8 - | x09 => 9 - | x0a => 10 - | x0b => 11 - | x0c => 12 - | x0d => 13 - | x0e => 14 - | x0f => 15 - | x10 => 16 - | x11 => 17 - | x12 => 18 - | x13 => 19 - | x14 => 20 - | x15 => 21 - | x16 => 22 - | x17 => 23 - | x18 => 24 - | x19 => 25 - | x1a => 26 - | x1b => 27 - | x1c => 28 - | x1d => 29 - | x1e => 30 - | x1f => 31 - | x20 => 32 - | x21 => 33 - | x22 => 34 - | x23 => 35 - | x24 => 36 - | x25 => 37 - | x26 => 38 - | x27 => 39 - | x28 => 40 - | x29 => 41 - | x2a => 42 - | x2b => 43 - | x2c => 44 - | x2d => 45 - | x2e => 46 - | x2f => 47 - | x30 => 48 - | x31 => 49 - | x32 => 50 - | x33 => 51 - | x34 => 52 - | x35 => 53 - | x36 => 54 - | x37 => 55 - | x38 => 56 - | x39 => 57 - | x3a => 58 - | x3b => 59 - | x3c => 60 - | x3d => 61 - | x3e => 62 - | x3f => 63 - | x40 => 64 - | x41 => 65 - | x42 => 66 - | x43 => 67 - | x44 => 68 - | x45 => 69 - | x46 => 70 - | x47 => 71 - | x48 => 72 - | x49 => 73 - | x4a => 74 - | x4b => 75 - | x4c => 76 - | x4d => 77 - | x4e => 78 - | x4f => 79 - | x50 => 80 - | x51 => 81 - | x52 => 82 - | x53 => 83 - | x54 => 84 - | x55 => 85 - | x56 => 86 - | x57 => 87 - | x58 => 88 - | x59 => 89 - | x5a => 90 - | x5b => 91 - | x5c => 92 - | x5d => 93 - | x5e => 94 - | x5f => 95 - | x60 => 96 - | x61 => 97 - | x62 => 98 - | x63 => 99 - | x64 => 100 - | x65 => 101 - | x66 => 102 - | x67 => 103 - | x68 => 104 - | x69 => 105 - | x6a => 106 - | x6b => 107 - | x6c => 108 - | x6d => 109 - | x6e => 110 - | x6f => 111 - | x70 => 112 - | x71 => 113 - | x72 => 114 - | x73 => 115 - | x74 => 116 - | x75 => 117 - | x76 => 118 - | x77 => 119 - | x78 => 120 - | x79 => 121 - | x7a => 122 - | x7b => 123 - | x7c => 124 - | x7d => 125 - | x7e => 126 - | x7f => 127 - | x80 => 128 - | x81 => 129 - | x82 => 130 - | x83 => 131 - | x84 => 132 - | x85 => 133 - | x86 => 134 - | x87 => 135 - | x88 => 136 - | x89 => 137 - | x8a => 138 - | x8b => 139 - | x8c => 140 - | x8d => 141 - | x8e => 142 - | x8f => 143 - | x90 => 144 - | x91 => 145 - | x92 => 146 - | x93 => 147 - | x94 => 148 - | x95 => 149 - | x96 => 150 - | x97 => 151 - | x98 => 152 - | x99 => 153 - | x9a => 154 - | x9b => 155 - | x9c => 156 - | x9d => 157 - | x9e => 158 - | x9f => 159 - | xa0 => 160 - | xa1 => 161 - | xa2 => 162 - | xa3 => 163 - | xa4 => 164 - | xa5 => 165 - | xa6 => 166 - | xa7 => 167 - | xa8 => 168 - | xa9 => 169 - | xaa => 170 - | xab => 171 - | xac => 172 - | xad => 173 - | xae => 174 - | xaf => 175 - | xb0 => 176 - | xb1 => 177 - | xb2 => 178 - | xb3 => 179 - | xb4 => 180 - | xb5 => 181 - | xb6 => 182 - | xb7 => 183 - | xb8 => 184 - | xb9 => 185 - | xba => 186 - | xbb => 187 - | xbc => 188 - | xbd => 189 - | xbe => 190 - | xbf => 191 - | xc0 => 192 - | xc1 => 193 - | xc2 => 194 - | xc3 => 195 - | xc4 => 196 - | xc5 => 197 - | xc6 => 198 - | xc7 => 199 - | xc8 => 200 - | xc9 => 201 - | xca => 202 - | xcb => 203 - | xcc => 204 - | xcd => 205 - | xce => 206 - | xcf => 207 - | xd0 => 208 - | xd1 => 209 - | xd2 => 210 - | xd3 => 211 - | xd4 => 212 - | xd5 => 213 - | xd6 => 214 - | xd7 => 215 - | xd8 => 216 - | xd9 => 217 - | xda => 218 - | xdb => 219 - | xdc => 220 - | xdd => 221 - | xde => 222 - | xdf => 223 - | xe0 => 224 - | xe1 => 225 - | xe2 => 226 - | xe3 => 227 - | xe4 => 228 - | xe5 => 229 - | xe6 => 230 - | xe7 => 231 - | xe8 => 232 - | xe9 => 233 - | xea => 234 - | xeb => 235 - | xec => 236 - | xed => 237 - | xee => 238 - | xef => 239 - | xf0 => 240 - | xf1 => 241 - | xf2 => 242 - | xf3 => 243 - | xf4 => 244 - | xf5 => 245 - | xf6 => 246 - | xf7 => 247 - | xf8 => 248 - | xf9 => 249 - | xfa => 250 - | xfb => 251 - | xfc => 252 - | xfd => 253 - | xfe => 254 - | xff => 255 - end. - - Definition of_N (x : N) : option byte - := match x with - | 0 => Some x00 - | 1 => Some x01 - | 2 => Some x02 - | 3 => Some x03 - | 4 => Some x04 - | 5 => Some x05 - | 6 => Some x06 - | 7 => Some x07 - | 8 => Some x08 - | 9 => Some x09 - | 10 => Some x0a - | 11 => Some x0b - | 12 => Some x0c - | 13 => Some x0d - | 14 => Some x0e - | 15 => Some x0f - | 16 => Some x10 - | 17 => Some x11 - | 18 => Some x12 - | 19 => Some x13 - | 20 => Some x14 - | 21 => Some x15 - | 22 => Some x16 - | 23 => Some x17 - | 24 => Some x18 - | 25 => Some x19 - | 26 => Some x1a - | 27 => Some x1b - | 28 => Some x1c - | 29 => Some x1d - | 30 => Some x1e - | 31 => Some x1f - | 32 => Some x20 - | 33 => Some x21 - | 34 => Some x22 - | 35 => Some x23 - | 36 => Some x24 - | 37 => Some x25 - | 38 => Some x26 - | 39 => Some x27 - | 40 => Some x28 - | 41 => Some x29 - | 42 => Some x2a - | 43 => Some x2b - | 44 => Some x2c - | 45 => Some x2d - | 46 => Some x2e - | 47 => Some x2f - | 48 => Some x30 - | 49 => Some x31 - | 50 => Some x32 - | 51 => Some x33 - | 52 => Some x34 - | 53 => Some x35 - | 54 => Some x36 - | 55 => Some x37 - | 56 => Some x38 - | 57 => Some x39 - | 58 => Some x3a - | 59 => Some x3b - | 60 => Some x3c - | 61 => Some x3d - | 62 => Some x3e - | 63 => Some x3f - | 64 => Some x40 - | 65 => Some x41 - | 66 => Some x42 - | 67 => Some x43 - | 68 => Some x44 - | 69 => Some x45 - | 70 => Some x46 - | 71 => Some x47 - | 72 => Some x48 - | 73 => Some x49 - | 74 => Some x4a - | 75 => Some x4b - | 76 => Some x4c - | 77 => Some x4d - | 78 => Some x4e - | 79 => Some x4f - | 80 => Some x50 - | 81 => Some x51 - | 82 => Some x52 - | 83 => Some x53 - | 84 => Some x54 - | 85 => Some x55 - | 86 => Some x56 - | 87 => Some x57 - | 88 => Some x58 - | 89 => Some x59 - | 90 => Some x5a - | 91 => Some x5b - | 92 => Some x5c - | 93 => Some x5d - | 94 => Some x5e - | 95 => Some x5f - | 96 => Some x60 - | 97 => Some x61 - | 98 => Some x62 - | 99 => Some x63 - | 100 => Some x64 - | 101 => Some x65 - | 102 => Some x66 - | 103 => Some x67 - | 104 => Some x68 - | 105 => Some x69 - | 106 => Some x6a - | 107 => Some x6b - | 108 => Some x6c - | 109 => Some x6d - | 110 => Some x6e - | 111 => Some x6f - | 112 => Some x70 - | 113 => Some x71 - | 114 => Some x72 - | 115 => Some x73 - | 116 => Some x74 - | 117 => Some x75 - | 118 => Some x76 - | 119 => Some x77 - | 120 => Some x78 - | 121 => Some x79 - | 122 => Some x7a - | 123 => Some x7b - | 124 => Some x7c - | 125 => Some x7d - | 126 => Some x7e - | 127 => Some x7f - | 128 => Some x80 - | 129 => Some x81 - | 130 => Some x82 - | 131 => Some x83 - | 132 => Some x84 - | 133 => Some x85 - | 134 => Some x86 - | 135 => Some x87 - | 136 => Some x88 - | 137 => Some x89 - | 138 => Some x8a - | 139 => Some x8b - | 140 => Some x8c - | 141 => Some x8d - | 142 => Some x8e - | 143 => Some x8f - | 144 => Some x90 - | 145 => Some x91 - | 146 => Some x92 - | 147 => Some x93 - | 148 => Some x94 - | 149 => Some x95 - | 150 => Some x96 - | 151 => Some x97 - | 152 => Some x98 - | 153 => Some x99 - | 154 => Some x9a - | 155 => Some x9b - | 156 => Some x9c - | 157 => Some x9d - | 158 => Some x9e - | 159 => Some x9f - | 160 => Some xa0 - | 161 => Some xa1 - | 162 => Some xa2 - | 163 => Some xa3 - | 164 => Some xa4 - | 165 => Some xa5 - | 166 => Some xa6 - | 167 => Some xa7 - | 168 => Some xa8 - | 169 => Some xa9 - | 170 => Some xaa - | 171 => Some xab - | 172 => Some xac - | 173 => Some xad - | 174 => Some xae - | 175 => Some xaf - | 176 => Some xb0 - | 177 => Some xb1 - | 178 => Some xb2 - | 179 => Some xb3 - | 180 => Some xb4 - | 181 => Some xb5 - | 182 => Some xb6 - | 183 => Some xb7 - | 184 => Some xb8 - | 185 => Some xb9 - | 186 => Some xba - | 187 => Some xbb - | 188 => Some xbc - | 189 => Some xbd - | 190 => Some xbe - | 191 => Some xbf - | 192 => Some xc0 - | 193 => Some xc1 - | 194 => Some xc2 - | 195 => Some xc3 - | 196 => Some xc4 - | 197 => Some xc5 - | 198 => Some xc6 - | 199 => Some xc7 - | 200 => Some xc8 - | 201 => Some xc9 - | 202 => Some xca - | 203 => Some xcb - | 204 => Some xcc - | 205 => Some xcd - | 206 => Some xce - | 207 => Some xcf - | 208 => Some xd0 - | 209 => Some xd1 - | 210 => Some xd2 - | 211 => Some xd3 - | 212 => Some xd4 - | 213 => Some xd5 - | 214 => Some xd6 - | 215 => Some xd7 - | 216 => Some xd8 - | 217 => Some xd9 - | 218 => Some xda - | 219 => Some xdb - | 220 => Some xdc - | 221 => Some xdd - | 222 => Some xde - | 223 => Some xdf - | 224 => Some xe0 - | 225 => Some xe1 - | 226 => Some xe2 - | 227 => Some xe3 - | 228 => Some xe4 - | 229 => Some xe5 - | 230 => Some xe6 - | 231 => Some xe7 - | 232 => Some xe8 - | 233 => Some xe9 - | 234 => Some xea - | 235 => Some xeb - | 236 => Some xec - | 237 => Some xed - | 238 => Some xee - | 239 => Some xef - | 240 => Some xf0 - | 241 => Some xf1 - | 242 => Some xf2 - | 243 => Some xf3 - | 244 => Some xf4 - | 245 => Some xf5 - | 246 => Some xf6 - | 247 => Some xf7 - | 248 => Some xf8 - | 249 => Some xf9 - | 250 => Some xfa - | 251 => Some xfb - | 252 => Some xfc - | 253 => Some xfd - | 254 => Some xfe - | 255 => Some xff - | _ => None - end. - - Lemma of_to_N x : of_N (to_N x) = Some x. - Proof. destruct x; reflexivity. Qed. - - Lemma to_of_N x y : of_N x = Some y -> to_N y = x. - Proof. - intros E. - pose (P := fun n : N => match of_N n with Some z => to_N z = n | None => True end). - enough (H : P x) by now subst P; simpl in H; rewrite E in H. - clear E y. - destruct x as [|p]; [reflexivity|revert p]. - assert (H : forall P, (forall p, P (xI p)) -> (forall p, P (xO p)) -> P xH -> forall p, P p) by now intros ???? []. - (do 8 refine (H _ _ _ eq_refl)); exact (fun _ => I). - Qed. - - Lemma to_of_N_iff x y : of_N x = Some y <-> to_N y = x. - Proof. split; intro; subst; (apply of_to_N || apply to_of_N); assumption. Qed. - - Lemma to_of_N_option_map x : option_map to_N (of_N x) = if N.leb x 255 then Some x else None. - Proof. - cbv [of_N]; - repeat match goal with - | [ |- context[match ?x with _ => _ end] ] => is_var x; destruct x - end; - reflexivity. - Qed. - - Lemma to_N_bounded x : to_N x <= 255. - Proof. - apply N.leb_le. - generalize (to_of_N_option_map (to_N x)). - rewrite of_to_N. - now destruct (N.leb (to_N x) 255). - Qed. - - Lemma of_N_None_iff x : of_N x = None <-> 255 < x. - Proof. - assert (H := to_of_N_option_map x). - split. - - intros E. rewrite E in H. - now destruct (N.leb_spec x 255). - - intros E%N.leb_gt. rewrite E in H. - now destruct (of_N x). - Qed. - - Lemma to_N_via_nat x : to_N x = N.of_nat (to_nat x). - Proof. destruct x; reflexivity. Qed. - - Lemma to_nat_via_N x : to_nat x = N.to_nat (to_N x). - Proof. destruct x; reflexivity. Qed. - - Lemma of_N_via_nat x : of_N x = of_nat (N.to_nat x). - Proof. - destruct (of_N x) as [b|] eqn:H1. - { rewrite to_of_N_iff in H1; subst. - destruct b; reflexivity. } - { rewrite of_N_None_iff, <- N.compare_lt_iff in H1. - symmetry; rewrite of_nat_None_iff, <- PeanoNat.Nat.compare_lt_iff. - rewrite Nat2N.inj_compare, N2Nat.id; assumption. } - Qed. - - Lemma of_nat_via_N x : of_nat x = of_N (N.of_nat x). - Proof. - destruct (of_nat x) as [b|] eqn:H1. - { rewrite to_of_nat_iff in H1; subst. - destruct b; reflexivity. } - { rewrite of_nat_None_iff, <- PeanoNat.Nat.compare_lt_iff in H1. - symmetry; rewrite of_N_None_iff, <- N.compare_lt_iff. - rewrite N2Nat.inj_compare, Nat2N.id; assumption. } - Qed. -End N. diff --git a/stdlib/theories/Strings/HexString.v b/stdlib/theories/Strings/HexString.v deleted file mode 100644 index 4dbab23d58cf..000000000000 --- a/stdlib/theories/Strings/HexString.v +++ /dev/null @@ -1,231 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* p~0~0~0~1 - | 2 => p~0~0~1~0 - | 3 => p~0~0~1~1 - | 4 => p~0~1~0~0 - | 5 => p~0~1~0~1 - | 6 => p~0~1~1~0 - | 7 => p~0~1~1~1 - | 8 => p~1~0~0~0 - | 9 => p~1~0~0~1 - | 10 => p~1~0~1~0 - | 11 => p~1~0~1~1 - | 12 => p~1~1~0~0 - | 13 => p~1~1~0~1 - | 14 => p~1~1~1~0 - | 15 => p~1~1~1~1 - | q~0~0~0~0 => (pos_hex_app p q)~0~0~0~0 - | q~0~0~0~1 => (pos_hex_app p q)~0~0~0~1 - | q~0~0~1~0 => (pos_hex_app p q)~0~0~1~0 - | q~0~0~1~1 => (pos_hex_app p q)~0~0~1~1 - | q~0~1~0~0 => (pos_hex_app p q)~0~1~0~0 - | q~0~1~0~1 => (pos_hex_app p q)~0~1~0~1 - | q~0~1~1~0 => (pos_hex_app p q)~0~1~1~0 - | q~0~1~1~1 => (pos_hex_app p q)~0~1~1~1 - | q~1~0~0~0 => (pos_hex_app p q)~1~0~0~0 - | q~1~0~0~1 => (pos_hex_app p q)~1~0~0~1 - | q~1~0~1~0 => (pos_hex_app p q)~1~0~1~0 - | q~1~0~1~1 => (pos_hex_app p q)~1~0~1~1 - | q~1~1~0~0 => (pos_hex_app p q)~1~1~0~0 - | q~1~1~0~1 => (pos_hex_app p q)~1~1~0~1 - | q~1~1~1~0 => (pos_hex_app p q)~1~1~1~0 - | q~1~1~1~1 => (pos_hex_app p q)~1~1~1~1 - end. - -Module Raw. - Fixpoint of_pos (p : positive) (rest : string) : string - := match p with - | 1 => String "1" rest - | 2 => String "2" rest - | 3 => String "3" rest - | 4 => String "4" rest - | 5 => String "5" rest - | 6 => String "6" rest - | 7 => String "7" rest - | 8 => String "8" rest - | 9 => String "9" rest - | 10 => String "a" rest - | 11 => String "b" rest - | 12 => String "c" rest - | 13 => String "d" rest - | 14 => String "e" rest - | 15 => String "f" rest - | p'~0~0~0~0 => of_pos p' (String "0" rest) - | p'~0~0~0~1 => of_pos p' (String "1" rest) - | p'~0~0~1~0 => of_pos p' (String "2" rest) - | p'~0~0~1~1 => of_pos p' (String "3" rest) - | p'~0~1~0~0 => of_pos p' (String "4" rest) - | p'~0~1~0~1 => of_pos p' (String "5" rest) - | p'~0~1~1~0 => of_pos p' (String "6" rest) - | p'~0~1~1~1 => of_pos p' (String "7" rest) - | p'~1~0~0~0 => of_pos p' (String "8" rest) - | p'~1~0~0~1 => of_pos p' (String "9" rest) - | p'~1~0~1~0 => of_pos p' (String "a" rest) - | p'~1~0~1~1 => of_pos p' (String "b" rest) - | p'~1~1~0~0 => of_pos p' (String "c" rest) - | p'~1~1~0~1 => of_pos p' (String "d" rest) - | p'~1~1~1~0 => of_pos p' (String "e" rest) - | p'~1~1~1~1 => of_pos p' (String "f" rest) - end. - - Fixpoint to_N (s : string) (rest : N) - : N - := match s with - | "" => rest - | String ch s' - => to_N - s' - match ascii_to_digit ch with - | Some v => N.add v (N.mul 16 rest) - | None => N0 - end - end. - - Fixpoint to_N_of_pos (p : positive) (rest : string) (base : N) {struct p} - : to_N (of_pos p rest) base - = to_N rest match base with - | N0 => N.pos p - | Npos v => Npos (pos_hex_app v p) - end. - Proof. - do 4 try destruct p as [p|p|]; destruct base; try reflexivity; - cbn; rewrite to_N_of_pos; reflexivity. - Qed. -End Raw. - -Definition of_pos (p : positive) : string - := String "0" (String "x" (Raw.of_pos p "")). -Definition of_N (n : N) : string - := match n with - | N0 => "0x0" - | Npos p => of_pos p - end. -Definition of_Z (z : Z) : string - := match z with - | Zneg p => String "-" (of_pos p) - | Z0 => "0x0" - | Zpos p => of_pos p - end. -Definition of_nat (n : nat) : string - := of_N (N.of_nat n). - -Definition to_N (s : string) : N - := match s with - | String s0 (String so s) - => if ascii_dec s0 "0" - then if ascii_dec so "x" - then Raw.to_N s N0 - else N0 - else N0 - | _ => N0 - end. -Definition to_pos (s : string) : positive - := match to_N s with - | N0 => 1 - | Npos p => p - end. -Definition to_Z (s : string) : Z - := let '(is_neg, n) := match s with - | String s0 s' - => if ascii_dec s0 "-" - then (true, to_N s') - else (false, to_N s) - | EmptyString => (false, to_N s) - end in - match n with - | N0 => Z0 - | Npos p => if is_neg then Zneg p else Zpos p - end. -Definition to_nat (s : string) : nat - := N.to_nat (to_N s). - -Lemma to_N_of_N (n : N) - : to_N (of_N n) - = n. -Proof. - destruct n; [ reflexivity | apply Raw.to_N_of_pos ]. -Qed. - -Lemma to_Z_of_Z (z : Z) - : to_Z (of_Z z) - = z. -Proof. - cbv [of_Z to_Z]; destruct z as [|z|z]; cbn; - try reflexivity; - rewrite Raw.to_N_of_pos; cbn; reflexivity. -Qed. - -Lemma to_nat_of_nat (n : nat) - : to_nat (of_nat n) - = n. -Proof. - cbv [to_nat of_nat]; - rewrite to_N_of_N, Nnat.Nat2N.id; reflexivity. -Qed. - -Lemma to_pos_of_pos (p : positive) - : to_pos (of_pos p) - = p. -Proof. - cbv [of_pos to_pos to_N]; cbn; - rewrite Raw.to_N_of_pos; cbn; reflexivity. -Qed. - -Example of_pos_1 : of_pos 1 = "0x1" := eq_refl. -Example of_pos_2 : of_pos 2 = "0x2" := eq_refl. -Example of_pos_3 : of_pos 3 = "0x3" := eq_refl. -Example of_pos_7 : of_pos 7 = "0x7" := eq_refl. -Example of_pos_8 : of_pos 8 = "0x8" := eq_refl. -Example of_pos_9 : of_pos 9 = "0x9" := eq_refl. -Example of_pos_10 : of_pos 10 = "0xa" := eq_refl. -Example of_pos_11 : of_pos 11 = "0xb" := eq_refl. -Example of_pos_12 : of_pos 12 = "0xc" := eq_refl. -Example of_pos_13 : of_pos 13 = "0xd" := eq_refl. -Example of_pos_14 : of_pos 14 = "0xe" := eq_refl. -Example of_pos_15 : of_pos 15 = "0xf" := eq_refl. -Example of_pos_16 : of_pos 16 = "0x10" := eq_refl. -Example of_N_0 : of_N 0 = "0x0" := eq_refl. -Example of_Z_0 : of_Z 0 = "0x0" := eq_refl. -Example of_Z_m1 : of_Z (-1) = "-0x1" := eq_refl. -Example of_nat_0 : of_nat 0 = "0x0" := eq_refl. diff --git a/stdlib/theories/Strings/OctalString.v b/stdlib/theories/Strings/OctalString.v deleted file mode 100644 index 9118555f8817..000000000000 --- a/stdlib/theories/Strings/OctalString.v +++ /dev/null @@ -1,181 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* p~0~0~1 - | 2 => p~0~1~0 - | 3 => p~0~1~1 - | 4 => p~1~0~0 - | 5 => p~1~0~1 - | 6 => p~1~1~0 - | 7 => p~1~1~1 - | q~0~0~0 => (pos_oct_app p q)~0~0~0 - | q~0~0~1 => (pos_oct_app p q)~0~0~1 - | q~0~1~0 => (pos_oct_app p q)~0~1~0 - | q~0~1~1 => (pos_oct_app p q)~0~1~1 - | q~1~0~0 => (pos_oct_app p q)~1~0~0 - | q~1~0~1 => (pos_oct_app p q)~1~0~1 - | q~1~1~0 => (pos_oct_app p q)~1~1~0 - | q~1~1~1 => (pos_oct_app p q)~1~1~1 - end. - -Module Raw. - Fixpoint of_pos (p : positive) (rest : string) : string - := match p with - | 1 => String "1" rest - | 2 => String "2" rest - | 3 => String "3" rest - | 4 => String "4" rest - | 5 => String "5" rest - | 6 => String "6" rest - | 7 => String "7" rest - | p'~0~0~0 => of_pos p' (String "0" rest) - | p'~0~0~1 => of_pos p' (String "1" rest) - | p'~0~1~0 => of_pos p' (String "2" rest) - | p'~0~1~1 => of_pos p' (String "3" rest) - | p'~1~0~0 => of_pos p' (String "4" rest) - | p'~1~0~1 => of_pos p' (String "5" rest) - | p'~1~1~0 => of_pos p' (String "6" rest) - | p'~1~1~1 => of_pos p' (String "7" rest) - end. - - Fixpoint to_N (s : string) (rest : N) - : N - := match s with - | "" => rest - | String ch s' - => to_N - s' - match ascii_to_digit ch with - | Some v => N.add v (N.mul 8 rest) - | None => N0 - end - end. - - Fixpoint to_N_of_pos (p : positive) (rest : string) (base : N) {struct p} - : to_N (of_pos p rest) base - = to_N rest match base with - | N0 => N.pos p - | Npos v => Npos (pos_oct_app v p) - end. - Proof. - do 3 try destruct p as [p|p|]; destruct base; try reflexivity; - cbn; rewrite to_N_of_pos; reflexivity. - Qed. -End Raw. - -Definition of_pos (p : positive) : string - := String "0" (String "o" (Raw.of_pos p "")). -Definition of_N (n : N) : string - := match n with - | N0 => "0o0" - | Npos p => of_pos p - end. -Definition of_Z (z : Z) : string - := match z with - | Zneg p => String "-" (of_pos p) - | Z0 => "0o0" - | Zpos p => of_pos p - end. -Definition of_nat (n : nat) : string - := of_N (N.of_nat n). - -Definition to_N (s : string) : N - := match s with - | String s0 (String so s) - => if ascii_dec s0 "0" - then if ascii_dec so "o" - then Raw.to_N s N0 - else N0 - else N0 - | _ => N0 - end. -Definition to_pos (s : string) : positive - := match to_N s with - | N0 => 1 - | Npos p => p - end. -Definition to_Z (s : string) : Z - := let '(is_neg, n) := match s with - | String s0 s' - => if ascii_dec s0 "-" - then (true, to_N s') - else (false, to_N s) - | EmptyString => (false, to_N s) - end in - match n with - | N0 => Z0 - | Npos p => if is_neg then Zneg p else Zpos p - end. -Definition to_nat (s : string) : nat - := N.to_nat (to_N s). - -Lemma to_N_of_N (n : N) - : to_N (of_N n) - = n. -Proof. - destruct n; [ reflexivity | apply Raw.to_N_of_pos ]. -Qed. - -Lemma to_Z_of_Z (z : Z) - : to_Z (of_Z z) - = z. -Proof. - cbv [of_Z to_Z]; destruct z as [|z|z]; cbn; - try reflexivity; - rewrite Raw.to_N_of_pos; cbn; reflexivity. -Qed. - -Lemma to_nat_of_nat (n : nat) - : to_nat (of_nat n) - = n. -Proof. - cbv [to_nat of_nat]; - rewrite to_N_of_N, Nnat.Nat2N.id; reflexivity. -Qed. - -Lemma to_pos_of_pos (p : positive) - : to_pos (of_pos p) - = p. -Proof. - cbv [of_pos to_pos to_N]; cbn; - rewrite Raw.to_N_of_pos; cbn; reflexivity. -Qed. - -Example of_pos_1 : of_pos 1 = "0o1" := eq_refl. -Example of_pos_2 : of_pos 2 = "0o2" := eq_refl. -Example of_pos_3 : of_pos 3 = "0o3" := eq_refl. -Example of_pos_7 : of_pos 7 = "0o7" := eq_refl. -Example of_pos_8 : of_pos 8 = "0o10" := eq_refl. -Example of_N_0 : of_N 0 = "0o0" := eq_refl. -Example of_Z_0 : of_Z 0 = "0o0" := eq_refl. -Example of_Z_m1 : of_Z (-1) = "-0o1" := eq_refl. -Example of_nat_0 : of_nat 0 = "0o0" := eq_refl. diff --git a/stdlib/theories/Strings/PString.v b/stdlib/theories/Strings/PString.v deleted file mode 100644 index 54427a764f74..000000000000 --- a/stdlib/theories/Strings/PString.v +++ /dev/null @@ -1,659 +0,0 @@ -From Stdlib Require Import Uint63. -From Stdlib Require Export PrimString. -From Stdlib Require Export PrimStringAxioms. - -From Stdlib.micromega Require Import Lia. -From Stdlib.micromega Require Import ZifyUint63. -From Stdlib.micromega Require Import Zify. -Require Import Stdlib.Numbers.Cyclic.Int63.Ring63. -From Stdlib Require Import ZArith. - -#[local] Open Scope Z_scope. -#[local] Open Scope list_scope. -#[local] Arguments to_Z _/ : simpl nomatch. - -#[local] Instance Op_max_length : ZifyClasses.CstOp max_length := - { TCst := 16777211%Z ; TCstInj := eq_refl }. -Add Zify CstOp Op_max_length. - -#[local] Ltac case_if := - lazymatch goal with - | |- context C [if ?b then _ else _] => destruct b eqn:? - | H : context C [if ?b then _ else _] |- _ => destruct b eqn:? - end. - -(** Derived properties of to_list and of_list. *) - -Lemma to_list_inj (s1 s2 : string) : - to_list s1 = to_list s2 -> s1 = s2. -Proof. - intros H. rewrite <-(of_to_list s1), <-(of_to_list s2), H. - reflexivity. -Qed. - -Lemma to_of_list (l : list char63) : - List.Forall char63_valid l -> - Z.of_nat (List.length l) <= to_Z max_length -> - to_list (of_list l) = l. -Proof. - induction l as [|c l IH]; simpl; intros Hvalid Hlen; [reflexivity|]. - apply List.Forall_cons_iff in Hvalid as [Hvalid1 Hvalid2]. - rewrite cat_spec, make_spec, Hvalid1, IH; [|assumption|simpl; lia]. - rewrite List.firstn_all2; [reflexivity|simpl; lia]. -Qed. - -(** Alternative specifications with explicit bounds. *) - -Lemma get_spec_in_bounds (s : string) (i : int) : - to_Z i < to_Z (length s) -> - char63_valid (get s i) /\ - List.nth_error (to_list s) (to_nat i) = Some (get s i). -Proof. - intros Hlt. rewrite get_spec. split. - - pose proof to_list_char63_valid s as Hs. - apply List.Forall_nth; [assumption|]. rewrite <-length_spec. lia. - - apply List.nth_error_nth'. rewrite <-length_spec. lia. -Qed. - -Lemma get_spec_not_in_bounds (s : string) (i : int) : - to_Z (length s) <= to_Z i -> - get s i = 0%uint63. -Proof. - intros Hle. rewrite get_spec, List.nth_overflow; [reflexivity|]. - rewrite <-length_spec. lia. -Qed. - -Lemma make_spec_valid_length (i : int) (c : char63) : - to_Z i <= to_Z max_length -> - to_list (make i c) = List.repeat (c land 255)%uint63 (to_nat i). -Proof. - intros Hle. rewrite make_spec, Nat.min_l; [reflexivity | lia]. -Qed. - -Lemma make_spec_invalid_length (i : int) (c : char63) : - to_Z max_length < to_Z i -> - to_list (make i c) = List.repeat (c land 255)%uint63 (to_nat max_length). -Proof. - intros Hle. rewrite make_spec, Nat.min_r; [reflexivity | lia]. -Qed. - -Lemma cat_spec_valid_length (s1 s2 : string) : - to_Z (length s1) + to_Z (length s2) <= to_Z max_length -> - to_list (cat s1 s2) = to_list s1 ++ to_list s2. -Proof. - intros Hlen. rewrite cat_spec, List.firstn_all2; [reflexivity|]. - rewrite List.length_app, <-!length_spec. lia. -Qed. - -(** * Properties of string length *) - -Lemma valid_length (s : string) : - to_Z (length s) <= to_Z max_length. -Proof. - pose proof (to_list_length s) as Hvalid. - rewrite <-(length_spec s) in Hvalid. lia. -Qed. - -Lemma length_spec_int (s : string) : - length s = of_Z (Z.of_nat (List.length (to_list s))). -Proof. - apply to_Z_inj. rewrite <-length_spec. - rewrite of_Z_spec, Z.mod_small, Z2Nat.id; lia. -Qed. - -Lemma length_spec_Z (s : string) : - to_Z (length s) = Z.of_nat (List.length (to_list s)). -Proof. - rewrite <-length_spec. rewrite Z2Nat.id; lia. -Qed. - -Lemma make_length_spec (i : int) (c : char63) : - to_Z i <= to_Z max_length -> - length (make i c) = i. -Proof. - intros Hvalid. - pose proof (length_spec (make i c)) as Hlen. - rewrite (make_spec_valid_length i c Hvalid) in Hlen. - rewrite List.repeat_length in Hlen. lia. -Qed. - -Lemma sub_length_spec (s : string) (off len : int) : - to_Z off <= to_Z (length s) -> - to_Z len <= to_Z (length s) - to_Z off -> - length (sub s off len) = len. -Proof. - intros Hoff Hlen. - pose proof (length_spec (sub s off len)) as Hs. - rewrite sub_spec, List.firstn_length_le in Hs; [lia|]. - rewrite List.length_skipn, <-length_spec. lia. -Qed. - -Lemma cat_length_spec (s1 s2 : string) : - length (cat s1 s2) = Uint63.min max_length (length s1 + length s2)%uint63. -Proof. - rewrite length_spec_int, cat_spec, List.length_firstn. - rewrite Nat2Z.inj_min, Z2Nat.id; [|lia]. - rewrite List.length_app, <-!length_spec. - rewrite <-Z2Nat.inj_add; [|lia|lia]. - rewrite Z2Nat.id; [|lia]. - assert (to_Z (length s1) + to_Z (length s2) = - (to_Z (length s1) + to_Z (length s2)) mod wB) as ->. - { rewrite Z.mod_small; [reflexivity|]. split; [lia|]. - pose proof valid_length s1 as Hs1. - pose proof valid_length s2 as Hs2. - simpl in *. lia. } - rewrite <-add_spec, <-Uint63.min_spec, of_to_Z. reflexivity. -Qed. - -Lemma cat_length_spec_no_overflow (s1 s2 : string) : - to_Z (length s1) + to_Z (length s2) <= to_Z max_length -> - length (cat s1 s2) = (length s1 + length s2)%uint63. -Proof. - intros Hlen. rewrite cat_length_spec. unfold min. - destruct (max_length ā‰¤? length s1 + length s2)%uint63 eqn:Hle; [|reflexivity]. - rewrite leb_spec, add_spec, Z.mod_small in Hle; [|lia]. - apply to_Z_inj. rewrite add_spec, Z.mod_small; lia. -Qed. - -(** * Properties of string get *) - -Lemma get_char63_valid (s : string) (i : int) : - char63_valid (get s i). -Proof. - rewrite get_spec. - destruct (to_nat i - to_Z j < to_Z i -> - get (make i c) j = (c land 255)%uint63. -Proof. - intros Hmax Hj. rewrite get_spec, make_spec. - rewrite List.nth_repeat_lt; [reflexivity|lia]. -Qed. - -Lemma make_get_spec_valid (i j : int) (c : char63) : - to_Z j < to_Z max_length -> - to_Z j < to_Z i -> - char63_valid c -> - get (make i c) j = c. -Proof. - intros. rewrite make_get_spec; assumption. -Qed. - -Lemma sub_get_spec (s : string) (off len i : int) : - to_Z off + to_Z i < wB -> - to_Z i < to_Z len -> - get (sub s off len) i = get s (off + i). -Proof. - intros Hno Hi. - rewrite !get_spec, sub_spec. - rewrite List.nth_firstn, List.nth_skipn. case_if; [|lia]. - f_equal. rewrite Uint63.add_spec, Z.mod_small; lia. -Qed. - -Lemma cat_get_spec_l (s1 s2 : string) (i : int) : - to_Z i < to_Z (length s1) -> - get (cat s1 s2) i = get s1 i. -Proof. - intros Hi. - pose proof valid_length s1 as Hs1. - rewrite !get_spec, cat_spec. - rewrite List.nth_firstn. case_if; [|lia]. - rewrite List.app_nth1; [reflexivity|]. - rewrite <-length_spec. lia. -Qed. - -Lemma cat_get_spec_r (s1 s2 : string) (i : int) : - to_Z (length s1) <= to_Z i -> - to_Z i < to_Z max_length -> - get (cat s1 s2) i = get s2 (i - length s1). -Proof. - intros H1 H2. - rewrite !get_spec, cat_spec. - rewrite List.nth_firstn. case_if; [|lia]. - rewrite List.app_nth2; [|rewrite <-length_spec; lia]. - rewrite <-length_spec, Uint63.sub_spec, Z.mod_small; [|lia]. - rewrite Z2Nat.inj_sub; [reflexivity|lia]. -Qed. - -(** * Properties of string comparison *) - -Lemma char63_compare_refl (c1 c2 : char63) : - char63_compare c1 c2 = Eq <-> c1 = c2. -Proof. - rewrite Uint63.compare_spec, Z.compare_eq_iff. - split; [apply to_Z_inj|intros <-; reflexivity]. -Qed. - -Lemma char63_compare_antisym (c1 c2 : char63) : - char63_compare c2 c1 = CompOpp (char63_compare c1 c2). -Proof. - rewrite !Uint63.compare_spec. apply Z.compare_antisym. -Qed. - -Lemma char63_compare_trans (c1 c2 c3 : char63) (c : comparison) : - char63_compare c1 c2 = c -> char63_compare c2 c3 = c -> char63_compare c1 c3 = c. -Proof. - destruct c. - - rewrite !char63_compare_refl. intros -> ->. reflexivity. - - rewrite !Uint63.compare_spec. apply Zcompare_Lt_trans. - - rewrite !Uint63.compare_spec. apply Zcompare_Gt_trans. -Qed. - -Lemma compare_refl (s : string) : compare s s = Eq. -Proof. - rewrite PrimStringAxioms.compare_spec. - apply (List.list_compare_refl _ char63_compare_refl). reflexivity. -Qed. - -Lemma compare_antisym (s1 s2 : string) : - compare s2 s1 = CompOpp (compare s1 s2). -Proof. - rewrite !PrimStringAxioms.compare_spec. - apply List.list_compare_antisym. - - apply char63_compare_refl. - - apply char63_compare_antisym. -Qed. - -Lemma compare_trans (c : comparison) (s1 s2 s3 : string) : - compare s1 s2 = c -> compare s2 s3 = c -> compare s1 s3 = c. -Proof. - rewrite !PrimStringAxioms.compare_spec. - apply List.list_compare_trans. - - apply char63_compare_refl. - - apply char63_compare_trans. - - apply char63_compare_antisym. -Qed. - -Lemma compare_eq_correct (s1 s2 : string) : - compare s1 s2 = Eq -> s1 = s2. -Proof. - rewrite compare_spec, (List.list_compare_refl _ char63_compare_refl). - apply to_list_inj. -Qed. - -Lemma string_eq_ext (s1 s2 : string) : - (length s1 = length s2 /\ - forall i, to_Z i < to_Z (length s1) -> get s1 i = get s2 i) -> - s1 = s2. -Proof. - intros [Hlen Hget]. apply to_list_inj. - apply (List.nth_ext _ _ 0%uint63 0%uint63). - + rewrite <-!length_spec, Hlen. reflexivity. - + intros n Hn. rewrite <-length_spec in Hn. - assert (n = to_nat (of_nat n)) as ->. - { rewrite of_Z_spec, Z.mod_small, Nat2Z.id; lia. } - rewrite <-!get_spec. apply Hget. - rewrite of_Z_spec, Z.mod_small; lia. -Qed. - -Lemma to_list_firstn_skipn_middle (s : string) (i : int) : - to_Z i < to_Z (length s) -> - to_list s = List.firstn (to_nat i) (to_list s) ++ - get s i :: List.skipn (to_nat (i + 1)) (to_list s). -Proof. - intros Hi. - assert (to_nat (i + 1) = S (to_nat i)) as ->. - { rewrite add_spec, Z.mod_small, Z2Nat.inj_add; lia. } - symmetry. apply List.firstn_skipn_middle. - rewrite get_spec. apply List.nth_error_nth'. - rewrite <-length_spec. lia. -Qed. - -Lemma compare_spec (s1 s2 : string) (c : comparison) : - compare s1 s2 = c <-> - exists i, - to_Z i <= to_Z (length s1) /\ - to_Z i <= to_Z (length s2) /\ - (forall j, to_Z j < to_Z i -> get s1 j = get s2 j) /\ - match (i =? length s1, i =? length s2)%uint63 with - | (true , true ) => c = Eq - | (true , false) => c = Lt - | (false, true ) => c = Gt - | (false, false) => - match Uint63.compare (get s1 i) (get s2 i) with - | Eq => False - | ci => c = ci - end - end. -Proof. - rewrite compare_spec. split. - - pose proof List.list_compareP _ char63_compare_refl (to_list s1) (to_list s2) as Hcmp. - revert Hcmp. remember (List.list_compare _ _ _) as c' eqn:Hc'. intros Hcmp Hcc'. - induction Hcmp as [H|y ys H|x xs H|????? H1 H2 H|????? H1 H2 H]; clear Hc'; subst c. - + apply to_list_inj in H. subst s2. exists (length s1). - rewrite eqb_eq, Z.eqb_refl. repeat split; lia. - + exists (length s1). - rewrite !eqb_eq, Z.eqb_refl, !length_spec_Z, H, List.length_app. - repeat split; [lia|lia| |]. - * intros j Hj. rewrite !get_spec, H. rewrite List.app_nth1; [reflexivity|lia]. - * simpl in *. case_if; [exfalso; lia|reflexivity]. - + exists (length s2). - rewrite !eqb_eq, Z.eqb_refl, !length_spec_Z, H, List.length_app. - repeat split; [lia|lia| |]. - * intros j Hj. rewrite !get_spec, H. rewrite List.app_nth1; [reflexivity|lia]. - * simpl in *. case_if; [exfalso; lia|reflexivity]. - + exists (of_nat (List.length prefix)). - assert (Z.of_nat (List.length prefix) < wB) as Hprefix. - { pose proof f_equal (@List.length _) H1 as Hlen. - pose proof valid_length s1 as Hmax. - rewrite <-length_spec, List.length_app in Hlen. lia. } - rewrite !eqb_eq, !length_spec_Z, H1, H2, !List.length_app. - rewrite of_Z_spec, Z.mod_small; [|lia]. - repeat split; [lia|lia| |]. - * intros i Hj. rewrite !get_spec, H1, H2, !List.app_nth1; [reflexivity|lia|lia]. - * simpl in *; repeat case_if; try lia. - rewrite !get_spec, H1, H2. - do 2 (rewrite List.app_nth2; [|rewrite of_Z_spec, Z.mod_small; lia]). - rewrite !of_Z_spec, Z.mod_small, Nat2Z.id, Nat.sub_diag; [|lia]. - simpl. rewrite H. reflexivity. - + exists (of_nat (List.length prefix)). - assert (Z.of_nat (List.length prefix) < wB) as Hprefix. - { pose proof f_equal (@List.length _) H1 as Hlen. - pose proof valid_length s1 as Hmax. - rewrite <-length_spec, List.length_app in Hlen. lia. } - rewrite !eqb_eq, !length_spec_Z, H1, H2, !List.length_app. - rewrite of_Z_spec, Z.mod_small; [|lia]. - repeat split; [lia|lia| |]. - * intros i Hj. rewrite !get_spec, H1, H2, !List.app_nth1; [reflexivity|lia|lia]. - * simpl in *; repeat case_if; try lia. - rewrite !get_spec, H1, H2. - do 2 (rewrite List.app_nth2; [|rewrite of_Z_spec, Z.mod_small; lia]). - rewrite !of_Z_spec, Z.mod_small, Nat2Z.id, Nat.sub_diag; [|lia]. - simpl. rewrite H. reflexivity. - - intros (i & Hs1 & Hs2 & Hget & H). - pose proof valid_length s1 as Hlen1. - pose proof valid_length s2 as Hlen2. - apply (List.list_compare_spec_complete char63_compare_refl). - repeat case_if; subst. - + apply List.ListCompareEq. f_equal. apply string_eq_ext. split; [lia|]. - intros j Hj. apply Hget. lia. - + assert (to_Z (length s1) < to_Z (length s2)) as Hlen by lia. - assert (i = length s1) by lia; subst i. - apply (List.ListCompareShorter _ _ (get s2 (length s1)) - (List.skipn (to_nat (length s1 + 1)) (to_list s2))). - rewrite (to_list_firstn_skipn_middle s2 (length s1)) at 1; [|lia]. - f_equal. apply (List.nth_ext _ _ 0%uint63 0%uint63). - { rewrite List.length_firstn, <-!length_spec. lia. } - rewrite List.length_firstn, <-!length_spec, Nat.min_l; [|lia]. - intros n Hn. rewrite List.nth_firstn. case_if; [|lia]. - pose proof Hget (of_nat n). rewrite !get_spec in H. - rewrite of_Z_spec, Z.mod_small, Nat2Z.id in H; [|lia]. - symmetry. apply H. lia. - + assert (to_Z (length s2) < to_Z (length s1)) as Hlen by lia. - assert (i = length s2) by lia; subst i. - eapply (List.ListCompareLonger _ _ (get s1 (length s2)) - (List.skipn (to_nat (length s2 + 1)) (to_list s1))). - rewrite (to_list_firstn_skipn_middle s1 (length s2)) at 1; [|lia]. - f_equal. apply (List.nth_ext _ _ 0%uint63 0%uint63). - { rewrite List.length_firstn, <-!length_spec. lia. } - rewrite List.length_firstn, <-!length_spec, Nat.min_l; [|lia]. - intros n Hn. rewrite List.nth_firstn. case_if; [|lia]. - pose proof Hget (of_nat n). rewrite !get_spec in H. - rewrite of_Z_spec, Z.mod_small, Nat2Z.id in H; [|lia]. - apply H. lia. - + enough ( - exists p l1 l2, - to_list s1 = p ++ get s1 i :: l1 /\ - to_list s2 = p ++ get s2 i :: l2 - ) as (p & l1 & l2 & Hp1 & Hp2). - { revert H. destruct (_ ?= _)%uint63 eqn:Hi; [intros []|intros -> ..]. - - eapply List.ListCompareLt; solve [eauto]. - - eapply List.ListCompareGt; solve [eauto]. } - exists (to_list (sub s1 0 i)). - exists (to_list (sub s1 (i + 1) (length s1 - i - 1))). - exists (to_list (sub s2 (i + 1) (length s2 - i - 1))). - rewrite !sub_spec; simpl. - rewrite !(List.firstn_all2 (n:=to_nat (length _ - _ - _))). - 2-3: repeat progress rewrite ?List.length_skipn, ?Uint63.add_spec, - ?Uint63.sub_spec, ?Z.mod_small, ?Z.min_r, <-?length_spec; simpl; lia. - split; [apply to_list_firstn_skipn_middle; lia|]. - rewrite (to_list_firstn_skipn_middle s2 i) at 1; [|lia]. - enough (sub s2 0 i = sub s1 0 i) as H12. - { f_equal. apply (f_equal to_list) in H12. revert H12. - rewrite !sub_spec. simpl. intros ->. reflexivity. } - apply string_eq_ext; split. - { rewrite !sub_length_spec; lia. } - rewrite sub_length_spec; [|lia|lia]. - intros j Hj. rewrite !sub_get_spec; [|lia..]. - ring_simplify (0 + j)%uint63. symmetry. apply Hget. assumption. -Qed. - -Lemma compare_eq (s1 s2 : string) : compare s1 s2 = Eq <-> s1 = s2. -Proof. split; [apply compare_eq_correct|intros []; apply compare_refl]. Qed. - -Lemma compare_lt_spec (s1 s2 : string) : - compare s1 s2 = Lt <-> - exists i, - to_Z i <= to_Z (length s1) /\ - to_Z i <= to_Z (length s2) /\ - (forall j, to_Z j < to_Z i -> get s1 j = get s2 j) /\ - ((i = length s1 /\ to_Z i < to_Z (length s2)) \/ - (to_Z i < to_Z (length s1) /\ - to_Z i < to_Z (length s2) /\ - char63_compare (get s1 i) (get s2 i) = Lt)). -Proof. - rewrite compare_spec. - setoid_rewrite Uint63Axioms.compare_def_spec; unfold compare_def. - split. - - intros [i (H1 & H2 & Hget & Heq)]; exists i. - repeat split; [assumption..|]. - repeat case_if; try inversion Heq; try lia. - right. repeat split; lia. - - intros [i (H1 & H2 & Hget & H)]; exists i. - repeat split; [assumption..|]. - destruct H as [(-> & Hi)|(Hi1 & Hi2 & H)]. - + repeat case_if; try reflexivity; lia. - + repeat case_if; try reflexivity; try inversion H; lia. -Qed. - -(** * Properties of make *) - -Lemma make_0 (c : char63) : make 0 c = ""%pstring. -Proof. - apply to_list_inj. rewrite make_spec. reflexivity. -Qed. - -(** * Properties of cat *) - -Lemma length_0_empty (s : string) : length s = 0%uint63 -> s = ""%pstring. -Proof. - pose proof valid_length s as Hs. rewrite length_spec_Z in Hs. - rewrite length_spec_int. intros H%eq_int_inj. - rewrite of_Z_spec, Z.mod_small in H; [|lia]. - apply to_list_inj. destruct (to_list s); simpl in *; [reflexivity|lia]. -Qed. - -Lemma cat_empty_l (s : string) : cat ""%pstring s = s. -Proof. - pose proof valid_length s as Hs. - apply string_eq_ext. split. - - rewrite cat_length_spec_no_overflow; simpl; [ring|assumption]. - - intros i Hi. - rewrite cat_length_spec_no_overflow in Hi; [|simpl in * |- *; lia]. - simpl in Hi. ring_simplify (0 + length s)%uint63 in Hi. - rewrite cat_get_spec_r; simpl in *; [|lia|lia]. - ring_simplify (i - 0)%uint63. reflexivity. -Qed. - -Lemma cat_empty_r (s : string) : cat s ""%pstring = s. -Proof. - pose proof valid_length s as Hs. - apply string_eq_ext. split. - - rewrite cat_length_spec_no_overflow; simpl in *; [ring|lia]. - - intros i Hi. - rewrite cat_length_spec_no_overflow in Hi; [|simpl in * |- *; lia]. - simpl in Hi. ring_simplify (length s + 0)%uint63 in Hi. - rewrite cat_get_spec_l; [reflexivity|assumption]. -Qed. - -Lemma cat_assoc (s1 s2 s3 : string) : - cat (cat s1 s2) s3 = cat s1 (cat s2 s3). -Proof. - apply string_eq_ext. - rewrite !cat_length_spec. - pose proof valid_length s1 as Hs1. - pose proof valid_length s2 as Hs2. - pose proof valid_length s3 as Hs3. - simpl in *. - rewrite !min_add_min_n_same; [|rewrite add_spec, Z.mod_small; lia]. - rewrite !min_add_n_min_same; [|rewrite add_spec, Z.mod_small; lia]. - split; [f_equal; ring|]. intros i Hi. - rewrite !get_spec, !cat_spec. - rewrite Uint63.min_spec, !add_spec, !Z.mod_small in Hi. - 2-3: repeat rewrite Z.mod_small; lia. - rewrite !List.nth_firstn. - case_if; [|reflexivity]. - destruct (to_Z i - to_Z len2 <= to_Z len1 - to_Z off2 -> - sub (sub s off1 len1) off2 len2 = sub s (off1 + off2)%uint63 len2. -Proof. - intros H1 H2. apply to_list_inj. rewrite !sub_spec. - rewrite <-H1, Z2Nat.inj_add; [|lia|lia]. clear H1. - rewrite !List.skipn_firstn_comm. - rewrite List.firstn_firstn, List.skipn_skipn. - f_equal; [lia|f_equal; lia]. -Qed. - -(** Properties of to_list and of_list *) - -Lemma of_list_length (l : list char63) : - Z.of_nat (List.length l) <= to_Z max_length -> - length (of_list l) = of_Z (Z.of_nat (List.length l)). -Proof. - induction l as [|c l IH]; [reflexivity|]. - assert (List.length (c :: l) = S (List.length l)) as -> by reflexivity. - rewrite Nat2Z.inj_succ. intros Hlen; simpl. - pose proof (IH ltac:(lia)) as IH. - rewrite cat_length_spec_no_overflow. - 2: rewrite IH, make_length_spec, of_Z_spec, Z.mod_small; lia. - rewrite make_length_spec; [|lia]. - rewrite IH. apply to_Z_inj. - rewrite of_Z_spec, Z.mod_small; [|lia]. - rewrite Uint63.add_spec, Z.mod_small. - 2: rewrite of_Z_spec, Z.mod_small; lia. - rewrite of_Z_spec, Z.mod_small; lia. -Qed. - -Lemma of_list_app (l1 l2 : list char63) : - of_list (l1 ++ l2) = cat (of_list l1) (of_list l2). -Proof. - revert l2; induction l1 as [|c l1 IH]; intros l2; simpl. - - rewrite cat_empty_l. reflexivity. - - rewrite IH. rewrite cat_assoc. reflexivity. -Qed. - -Lemma to_list_cat (s1 s2 : string) : - (to_Z (length s1) + to_Z (length s2) <= to_Z max_length)%Z -> - to_list (cat s1 s2) = app (to_list s1) (to_list s2). -Proof. - rewrite cat_spec. intros Hlen. - rewrite List.firstn_all2; [reflexivity|]. - rewrite List.length_app, <-!length_spec. lia. -Qed. - -(** * Ordered type *) - -From Stdlib Require OrderedType. - -Module OT <: OrderedType.OrderedType with Definition t := string. - Definition t := string. - - Definition eq s1 s2 := compare s1 s2 = Eq. - Definition lt s1 s2 := compare s1 s2 = Lt. - - Lemma eq_refl (s : t) : eq s s. - Proof. apply compare_refl. Qed. - - Lemma eq_sym (s1 s2 : t) : eq s1 s2 -> eq s2 s1. - Proof. unfold eq. intros Heq. rewrite compare_antisym, Heq. reflexivity. Qed. - - Lemma eq_trans (s1 s2 s3 : t) : eq s1 s2 -> eq s2 s3 -> eq s1 s3. - Proof. unfold eq. apply compare_trans. Qed. - - Lemma lt_trans (s1 s2 s3 : t) : lt s1 s2 -> lt s2 s3 -> lt s1 s3. - Proof. unfold lt. apply compare_trans. Qed. - - Lemma lt_not_eq (s1 s2 : t) : lt s1 s2 -> not (eq s1 s2). - Proof. unfold lt, eq. intros ->. discriminate. Qed. - - #[program] - Definition compare (s1 s2 : t) : OrderedType.Compare lt eq s1 s2 := - match compare s1 s2 with - | Eq => OrderedType.EQ _ - | Lt => OrderedType.LT _ - | Gt => OrderedType.GT _ - end. - Next Obligation. symmetry. assumption. Defined. - Next Obligation. symmetry. assumption. Defined. - Next Obligation. unfold lt. rewrite compare_antisym, <-Heq_anonymous. reflexivity. Defined. - - Hint Immediate eq_sym : core. - Hint Resolve eq_refl eq_trans lt_not_eq lt_trans : core. - - Definition eq_dec (s1 s2 : t) : {eq s1 s2} + {~ eq s1 s2}. - Proof. - unfold eq. - destruct (PrimString.compare s1 s2). - - left. reflexivity. - - right. discriminate. - - right. discriminate. - Qed. -End OT. diff --git a/stdlib/theories/Strings/PrimString.v b/stdlib/theories/Strings/PrimString.v deleted file mode 100644 index 5cfc1b0ebc1a..000000000000 --- a/stdlib/theories/Strings/PrimString.v +++ /dev/null @@ -1 +0,0 @@ -From Corelib Require Export PrimString. diff --git a/stdlib/theories/Strings/PrimStringAxioms.v b/stdlib/theories/Strings/PrimStringAxioms.v deleted file mode 100644 index 4a5c6bea9030..000000000000 --- a/stdlib/theories/Strings/PrimStringAxioms.v +++ /dev/null @@ -1 +0,0 @@ -From Corelib Require Export PrimStringAxioms. diff --git a/stdlib/theories/Strings/String.v b/stdlib/theories/Strings/String.v deleted file mode 100644 index 7f4d51306df3..000000000000 --- a/stdlib/theories/Strings/String.v +++ /dev/null @@ -1,559 +0,0 @@ -(* -*- coding: utf-8 -*- *) -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* string -> string. - -Declare Scope string_scope. -Delimit Scope string_scope with string. -Bind Scope string_scope with string. -Local Open Scope string_scope. - -Register string as core.string.type. -Register EmptyString as core.string.empty. -Register String as core.string.string. - -(** Equality is decidable *) - -Definition string_dec : forall s1 s2 : string, {s1 = s2} + {s1 <> s2}. -Proof. - decide equality; apply ascii_dec. -Defined. - -Local Open Scope lazy_bool_scope. - -Fixpoint eqb s1 s2 : bool := - match s1, s2 with - | EmptyString, EmptyString => true - | String c1 s1', String c2 s2' => Ascii.eqb c1 c2 &&& eqb s1' s2' - | _,_ => false - end. - -Infix "=?" := eqb : string_scope. - -Lemma eqb_spec s1 s2 : Bool.reflect (s1 = s2) (s1 =? s2)%string. -Proof. - revert s2. induction s1 as [|? s1 IHs1]; - intro s2; destruct s2; try (constructor; easy); simpl. - case Ascii.eqb_spec; simpl; [intros -> | constructor; now intros [= ]]. - case IHs1; [intros ->; now constructor | constructor; now intros [= ]]. -Qed. - -Local Ltac t_eqb := - repeat first [ congruence - | progress subst - | apply conj - | match goal with - | [ |- context[eqb ?x ?y] ] => destruct (eqb_spec x y) - end - | intro ]. -Lemma eqb_refl x : (x =? x)%string = true. Proof. t_eqb. Qed. -Lemma eqb_sym x y : (x =? y)%string = (y =? x)%string. Proof. t_eqb. Qed. -Lemma eqb_eq n m : (n =? m)%string = true <-> n = m. Proof. t_eqb. Qed. -Lemma eqb_neq x y : (x =? y)%string = false <-> x <> y. Proof. t_eqb. Qed. -Lemma eqb_compat: Morphisms.Proper (Morphisms.respectful eq (Morphisms.respectful eq eq)) eqb. -Proof. t_eqb. Qed. - -(** *** Compare strings lexicographically *) - -Fixpoint compare (s1 s2 : string) : comparison := - match s1, s2 with - | EmptyString, EmptyString => Eq - | EmptyString, String _ _ => Lt - | String _ _ , EmptyString => Gt - | String c1 s1', String c2 s2' => - match Ascii.compare c1 c2 with - | Eq => compare s1' s2' - | ne => ne - end - end. - -Lemma compare_antisym : forall s1 s2 : string, - compare s1 s2 = CompOpp (compare s2 s1). -Proof. - induction s1, s2; intuition. - simpl. - rewrite Ascii.compare_antisym. - destruct (Ascii.compare a0 a); simpl; intuition. -Qed. - -Lemma compare_eq_iff : forall s1 s2 : string, - compare s1 s2 = Eq -> s1 = s2. -Proof. - induction s1, s2; intuition; inversion H. - destruct (Ascii.compare a a0) eqn:Heq; try discriminate H1. - apply Ascii.compare_eq_iff in Heq. - apply IHs1 in H1. - subst. - reflexivity. -Qed. - -Definition ltb (s1 s2 : string) : bool := - if compare s1 s2 is Lt then true else false. - -Definition leb (s1 s2 : string) : bool := - if compare s1 s2 is Gt then false else true. - -Lemma leb_antisym (s1 s2 : string) : - leb s1 s2 = true -> leb s2 s1 = true -> s1 = s2. -Proof. - unfold leb. - rewrite compare_antisym. - destruct (compare s2 s1) eqn:Hcmp; simpl in *; intuition. - - apply compare_eq_iff in Hcmp. intuition. - - discriminate H. - - discriminate H0. -Qed. - -Lemma leb_total (s1 s2 : string) : leb s1 s2 = true \/ leb s2 s1 = true. -Proof. - unfold leb. - rewrite compare_antisym. - destruct (compare s2 s1); intuition. -Qed. - -Infix "?=" := compare : string_scope. -Infix " s2 - | String c s1' => String c (s1' ++ s2) - end -where "s1 ++ s2" := (append s1 s2) : string_scope. - -(******************************) -(** Length *) -(******************************) - -Fixpoint length (s : string) : nat := - match s with - | EmptyString => 0 - | String c s' => S (length s') - end. - -(******************************) -(** Nth character of a string *) -(******************************) - -Fixpoint get (n : nat) (s : string) {struct s} : option ascii := - match s with - | EmptyString => None - | String c s' => match n with - | O => Some c - | S n' => get n' s' - end - end. - -(** Two lists that are identical through get are syntactically equal *) - -Theorem get_correct : - forall s1 s2 : string, (forall n : nat, get n s1 = get n s2) <-> s1 = s2. -Proof. -intros s1; elim s1; simpl. -- intros s2; case s2; simpl; split; auto. - + intros H; generalize (H O); intros H1; inversion H1. - + intros; discriminate. -- intros a s1' Rec s2; case s2 as [|? s]; simpl; split; auto. - + intros H; generalize (H O); intros H1; inversion H1. - + intros; discriminate. - + intros H; generalize (H O); simpl; intros H1; inversion H1. - case (Rec s). - intros H0; rewrite H0; auto. - intros n; exact (H (S n)). - + intros [= H1 H2]. - rewrite H2; trivial. - rewrite H1; auto. -Qed. - -(** The first elements of [s1 ++ s2] are the ones of [s1] *) - -Theorem append_correct1 : - forall (s1 s2 : string) (n : nat), - n < length s1 -> get n s1 = get n (s1 ++ s2). -Proof. -intros s1; elim s1; simpl; auto. -- intros s2 n H; inversion H. -- intros a s1' Rec s2 n; case n; simpl; auto. - intros n0 H; apply Rec; auto. - apply Nat.succ_lt_mono; auto. -Qed. - -(** The last elements of [s1 ++ s2] are the ones of [s2] *) - -Theorem append_correct2 : - forall (s1 s2 : string) (n : nat), - get n s2 = get (n + length s1) (s1 ++ s2). -Proof. -intros s1; elim s1; simpl; auto. -- intros s2 n; rewrite Nat.add_comm; simpl; auto. -- intros a s1' Rec s2 n; case n; simpl; auto. - intros. - (replace (n0 + S (length s1')) - with (S n0 + length s1') by now rewrite Nat.add_succ_r); auto. -Qed. - -(** *** Substrings *) - -(** [substring n m s] returns the substring of [s] that starts - at position [n] and of length [m]; - if this does not make sense it returns [""] *) - -Fixpoint substring (n m : nat) (s : string) : string := - match n, m, s with - | O, O, _ => EmptyString - | O, S m', EmptyString => s - | O, S m', String c s' => String c (substring 0 m' s') - | S n', _, EmptyString => s - | S n', _, String c s' => substring n' m s' - end. - -(** The substring is included in the initial string *) - -Theorem substring_correct1 : - forall (s : string) (n m p : nat), - p < m -> get p (substring n m s) = get (p + n) s. -Proof. -intros s; elim s; simpl; auto. -- intros n; case n; simpl; auto. - intros m; case m; simpl; auto. -- intros a s' Rec; intros n; case n; simpl; auto. - + intros m; case m; simpl; auto. - * intros p H; inversion H. - * intros m' p; case p; simpl; auto. - intros n0 H; apply Rec; simpl; auto. - apply <- Nat.succ_lt_mono; auto. - + intros n' m p H; rewrite Nat.add_succ_r; auto. -Qed. - -(** The substring has at most [m] elements *) - -Theorem substring_correct2 : - forall (s : string) (n m p : nat), m <= p -> get p (substring n m s) = None. -Proof. -intros s; elim s; simpl; auto. -- intros n; case n; simpl; auto. - intros m; case m; simpl; auto. -- intros a s' Rec; intros n; case n; simpl; auto. - intros m; case m; simpl; auto. - intros m' p; case p; simpl; auto. - + intros H; inversion H. - + intros n0 H; apply Rec; simpl; auto. - apply <- Nat.succ_le_mono; auto. -Qed. - -(** *** Concatenating lists of strings *) - -(** [concat sep sl] concatenates the list of strings [sl], inserting - the separator string [sep] between each. *) - -Fixpoint concat (sep : string) (ls : list string) := - match ls with - | nil => EmptyString - | cons x nil => x - | cons x xs => x ++ sep ++ concat sep xs - end. - -(** *** Test functions *) - -(** Test if [s1] is a prefix of [s2] *) - -Fixpoint prefix (s1 s2 : string) {struct s2} : bool := - match s1 with - | EmptyString => true - | String a s1' => - match s2 with - | EmptyString => false - | String b s2' => - match ascii_dec a b with - | left _ => prefix s1' s2' - | right _ => false - end - end - end. - -(** If [s1] is a prefix of [s2], it is the [substring] of length - [length s1] starting at position [O] of [s2] *) - -Theorem prefix_correct : - forall s1 s2 : string, - prefix s1 s2 = true <-> substring 0 (length s1) s2 = s1. -Proof. -intros s1; elim s1; simpl; auto. -- intros s2; case s2; simpl; split; auto. -- intros a s1' Rec s2; case s2; simpl; auto. - + split; intros; discriminate. - + intros b s2'; case (ascii_dec a b); simpl; auto. - * intros e; case (Rec s2'); intros H1 H2; split; intros H3; auto. - -- rewrite e; rewrite H1; auto. - -- apply H2; injection H3; auto. - * intros n; split; intros H; try discriminate. - case n; injection H; auto. -Qed. - -(** Test if, starting at position [n], [s1] occurs in [s2]; if - so it returns the position *) - -Fixpoint index (n : nat) (s1 s2 : string) : option nat := - match s2, n with - | EmptyString, O => - match s1 with - | EmptyString => Some O - | String a s1' => None - end - | EmptyString, S n' => None - | String b s2', O => - if prefix s1 s2 then Some O - else - match index O s1 s2' with - | Some n => Some (S n) - | None => None - end - | String b s2', S n' => - match index n' s1 s2' with - | Some n => Some (S n) - | None => None - end - end. - -(* Dirty trick to avoid locally that prefix reduces itself *) -Opaque prefix. - -(** If the result of [index] is [Some m], [s1] in [s2] at position [m] *) - -Theorem index_correct1 : - forall (n m : nat) (s1 s2 : string), - index n s1 s2 = Some m -> substring m (length s1) s2 = s1. -Proof. -intros n m s1 s2; generalize n m s1; clear n m s1; elim s2; simpl; - auto. -- intros n; case n; simpl; auto. - + intros m s1; case s1; simpl; auto. - * intros [= <-]; auto. - * intros; discriminate. - + intros; discriminate. -- intros b s2' Rec n m s1. - case n; simpl; auto. - + generalize (prefix_correct s1 (String b s2')); - case (prefix s1 (String b s2')). - * intros H0 [= <-]; auto. - case H0; simpl; auto. - * case m; simpl; auto. - -- case (index O s1 s2'); intros; discriminate. - -- intros m'; generalize (Rec O m' s1); case (index O s1 s2'); auto. - ++ intros x H H0 H1; apply H; injection H1; auto. - ++ intros; discriminate. - + intros n'; case m; simpl; auto. - * case (index n' s1 s2'); intros; discriminate. - * intros m'; generalize (Rec n' m' s1); case (index n' s1 s2'); auto. - -- intros x H H1; apply H; injection H1; auto. - -- intros; discriminate. -Qed. - -(** If the result of [index] is [Some m], - [s1] does not occur in [s2] before [m] *) - -Theorem index_correct2 : - forall (n m : nat) (s1 s2 : string), - index n s1 s2 = Some m -> - forall p : nat, n <= p -> p < m -> substring p (length s1) s2 <> s1. -Proof. -intros n m s1 s2; generalize n m s1; clear n m s1; elim s2; simpl; - auto. -- intros n; case n; simpl; auto. - + intros m s1; case s1; simpl; auto. - * intros [= <-]. - intros p H0 H2; inversion H2. - * intros; discriminate. - + intros; discriminate. -- intros b s2' Rec n m s1. - case n; simpl; auto. - + generalize (prefix_correct s1 (String b s2')); - case (prefix s1 (String b s2')). - * intros H0 [= <-]; auto. - intros p H2 H3; inversion H3. - * case m; simpl; auto. - -- case (index 0 s1 s2'); intros; discriminate. - -- intros m'; generalize (Rec O m' s1); case (index 0 s1 s2'); auto. - ++ intros x H H0 H1 p; try case p; simpl; auto. - ** intros H2 H3; red; intros H4; case H0. - intros H5 H6; absurd (false = true); auto with bool. - ** { intros n0 H2 H3; apply H; auto. - - injection H1; auto. - - apply Nat.le_0_l. - - apply <- Nat.succ_lt_mono; auto. - } - ++ intros; discriminate. - + intros n'; case m; simpl; auto. - * case (index n' s1 s2'); intros; discriminate. - * intros m'; generalize (Rec n' m' s1); case (index n' s1 s2'); auto. - -- intros x H H0 p; case p; simpl; auto. - ++ intros H1; inversion H1; auto. - ++ intros n0 H1 H2; apply H; auto. - ** injection H0; auto. - ** apply <- Nat.succ_le_mono; auto. - ** apply <- Nat.succ_lt_mono; auto. - -- intros; discriminate. -Qed. - -(** If the result of [index] is [None], [s1] does not occur in [s2] - after [n] *) - -Theorem index_correct3 : - forall (n m : nat) (s1 s2 : string), - index n s1 s2 = None -> - s1 <> EmptyString -> n <= m -> substring m (length s1) s2 <> s1. -Proof. -intros n m s1 s2; generalize n m s1; clear n m s1; elim s2; simpl; - auto. -- intros n; case n; simpl; auto. - + intros m s1; case s1; simpl; auto. - case m; intros; red; intros; discriminate. - + intros n' m; case m; auto. - intros s1; case s1; simpl; auto. -- intros b s2' Rec n m s1. - case n; simpl; auto. - + generalize (prefix_correct s1 (String b s2')); - case (prefix s1 (String b s2')). - * intros; discriminate. - * case m; simpl; auto with bool. - -- case s1; simpl; auto. - intros a s H H0 H1 H2; red; intros H3; case H. - intros H4 H5; absurd (false = true); auto with bool. - -- case s1; simpl; auto. - intros a s n0 H H0 H1 H2; - change (substring n0 (length (String a s)) s2' <> String a s); - apply (Rec O); auto. - ++ generalize H0; case (index 0 (String a s) s2'); simpl; auto; intros; - discriminate. - ++ apply Nat.le_0_l. - + intros n'; case m; simpl; auto. - * intros H H0 H1; inversion H1. - * intros n0 H H0 H1; apply (Rec n'); auto. - -- generalize H; case (index n' s1 s2'); simpl; auto; intros; - discriminate. - -- apply Nat.succ_le_mono; auto. -Qed. - -(* Back to normal for prefix *) -Transparent prefix. - -(** If we are searching for the [Empty] string and the answer is no - this means that [n] is greater than the size of [s] *) - -Theorem index_correct4 : - forall (n : nat) (s : string), - index n EmptyString s = None -> length s < n. -Proof. -intros n s; generalize n; clear n; elim s; simpl; auto. -- intros n; case n; simpl; auto. - + intros; discriminate. - + intros; apply Nat.lt_0_succ. -- intros a s' H n; case n; simpl; auto. - + intros; discriminate. - + intros n'; generalize (H n'); case (index n' EmptyString s'); simpl; - auto. - * intros; discriminate. - * intros H0 H1. apply -> Nat.succ_lt_mono; auto. -Qed. - -(** Same as [index] but with no optional type, we return [0] when it - does not occur *) - -Definition findex n s1 s2 := - match index n s1 s2 with - | Some n => n - | None => O - end. - -(** *** Conversion to/from [list ascii] and [list byte] *) - -Fixpoint string_of_list_ascii (s : list ascii) : string - := match s with - | nil => EmptyString - | cons ch s => String ch (string_of_list_ascii s) - end. - -Fixpoint list_ascii_of_string (s : string) : list ascii - := match s with - | EmptyString => nil - | String ch s => cons ch (list_ascii_of_string s) - end. - -Lemma string_of_list_ascii_of_string s : string_of_list_ascii (list_ascii_of_string s) = s. -Proof. - induction s as [|? ? IHs]; [ reflexivity | cbn; apply f_equal, IHs ]. -Defined. - -Lemma list_ascii_of_string_of_list_ascii s : list_ascii_of_string (string_of_list_ascii s) = s. -Proof. - induction s as [|? ? IHs]; [ reflexivity | cbn; apply f_equal, IHs ]. -Defined. - -Definition string_of_list_byte (s : list byte) : string - := string_of_list_ascii (List.map ascii_of_byte s). - -Definition list_byte_of_string (s : string) : list byte - := List.map byte_of_ascii (list_ascii_of_string s). - -Lemma string_of_list_byte_of_string s : string_of_list_byte (list_byte_of_string s) = s. -Proof. - cbv [string_of_list_byte list_byte_of_string]. - erewrite List.map_map, List.map_ext, List.map_id, string_of_list_ascii_of_string; [ reflexivity | intro ]. - apply ascii_of_byte_of_ascii. -Qed. - -Lemma list_byte_of_string_of_list_byte s : list_byte_of_string (string_of_list_byte s) = s. -Proof. - cbv [string_of_list_byte list_byte_of_string]. - erewrite list_ascii_of_string_of_list_ascii, List.map_map, List.map_ext, List.map_id; [ reflexivity | intro ]. - apply byte_of_ascii_of_byte. -Qed. - -(** *** Concrete syntax *) - -(** - The concrete syntax for strings in scope string_scope follows the - Coq convention for strings: all ascii characters of code less than - 128 are literals to the exception of the character `double quote' - which must be doubled. - - Strings that involve ascii characters of code >= 128 which are not - part of a valid utf8 sequence of characters are not representable - using the Coq string notation (use explicitly the String constructor - with the ascii codes of the characters). - *) - -Module Export StringSyntax. - String Notation string string_of_list_byte list_byte_of_string : string_scope. -End StringSyntax. - -Example HelloWorld := " ""Hello world!"" -". diff --git a/stdlib/theories/Structures/DecidableType.v b/stdlib/theories/Structures/DecidableType.v deleted file mode 100644 index 0827c6d8918c..000000000000 --- a/stdlib/theories/Structures/DecidableType.v +++ /dev/null @@ -1,164 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* split : core. - - (* eqke is stricter than eqk *) - - Lemma eqke_eqk : forall x x', eqke x x' -> eqk x x'. - Proof. - unfold eqk, eqke; intuition. - Qed. - - (* eqk, eqke are equalities *) - - Lemma eqk_refl : forall e, eqk e e. - Proof. auto. Qed. - - Lemma eqke_refl : forall e, eqke e e. - Proof. auto. Qed. - - Lemma eqk_sym : forall e e', eqk e e' -> eqk e' e. - Proof. auto. Qed. - - Lemma eqke_sym : forall e e', eqke e e' -> eqke e' e. - Proof. unfold eqke; intuition. Qed. - - Lemma eqk_trans : forall e e' e'', eqk e e' -> eqk e' e'' -> eqk e e''. - Proof. eauto. Qed. - - Lemma eqke_trans : forall e e' e'', eqke e e' -> eqke e' e'' -> eqke e e''. - Proof. - unfold eqke; intuition; [ eauto | congruence ]. - Qed. - - #[local] - Hint Resolve eqk_trans eqke_trans eqk_refl eqke_refl : core. - #[local] - Hint Immediate eqk_sym eqke_sym : core. - - Global Instance eqk_equiv : Equivalence eqk. - Proof. split; eauto. Qed. - - Global Instance eqke_equiv : Equivalence eqke. - Proof. split; eauto. Qed. - - Lemma InA_eqke_eqk : - forall x m, InA eqke x m -> InA eqk x m. - Proof. - unfold eqke; induction 1; intuition. - Qed. - #[local] - Hint Resolve InA_eqke_eqk : core. - - Lemma InA_eqk : forall p q m, eqk p q -> InA eqk p m -> InA eqk q m. - Proof. - intros p q m **; apply InA_eqA with p; auto using eqk_equiv. - Qed. - - Definition MapsTo (k:key)(e:elt):= InA eqke (k,e). - Definition In k m := exists e:elt, MapsTo k e m. - - #[local] - Hint Unfold MapsTo In : core. - - (* An alternative formulation for [In k l] is [exists e, InA eqk (k,e) l] *) - - Lemma In_alt : forall k l, In k l <-> exists e, InA eqk (k,e) l. - Proof. - intros k l; split; intros [y H]. - - exists y; auto. - - induction H as [a l eq|a l H IH]. - + destruct a as [k' y']. - exists y'; auto. - + destruct IH as [e H0]. - exists e; auto. - Qed. - - Lemma MapsTo_eq : forall l x y e, eq x y -> MapsTo x e l -> MapsTo y e l. - Proof. - intros l x y e **; unfold MapsTo in *; apply InA_eqA with (x,e); auto using eqke_equiv. - Qed. - - Lemma In_eq : forall l x y, eq x y -> In x l -> In y l. - Proof. - destruct 2 as (e,E); exists e; eapply MapsTo_eq; eauto. - Qed. - - Lemma In_inv : forall k k' e l, In k ((k',e) :: l) -> eq k k' \/ In k l. - Proof. - inversion 1 as [? H0]. - inversion_clear H0 as [? ? H1|]; eauto. - destruct H1; simpl in *; intuition. - Qed. - - Lemma In_inv_2 : forall k k' e e' l, - InA eqk (k, e) ((k', e') :: l) -> ~ eq k k' -> InA eqk (k, e) l. - Proof. - inversion_clear 1 as [? ? H0|? ? H0]; compute in H0; intuition. - Qed. - - Lemma In_inv_3 : forall x x' l, - InA eqke x (x' :: l) -> ~ eqk x x' -> InA eqke x l. - Proof. - inversion_clear 1 as [? ? H0|? ? H0]; compute in H0; intuition. - Qed. - - End Elt. - - #[global] - Hint Unfold eqk eqke : core. - #[global] - Hint Extern 2 (eqke ?a ?b) => split : core. - #[global] - Hint Resolve eqk_trans eqke_trans eqk_refl eqke_refl : core. - #[global] - Hint Immediate eqk_sym eqke_sym : core. - #[global] - Hint Resolve InA_eqke_eqk : core. - #[global] - Hint Unfold MapsTo In : core. - #[global] - Hint Resolve In_inv_2 In_inv_3 : core. - -End KeyDecidableType. diff --git a/stdlib/theories/Structures/DecidableTypeEx.v b/stdlib/theories/Structures/DecidableTypeEx.v deleted file mode 100644 index 2f89fa2b0ca9..000000000000 --- a/stdlib/theories/Structures/DecidableTypeEx.v +++ /dev/null @@ -1,96 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* eq y x. - Proof. - intros (x1,x2) (y1,y2); unfold eq; simpl; intuition. - Qed. - - Lemma eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z. - Proof. - intros (x1,x2) (y1,y2) (z1,z2); unfold eq; simpl; intuition eauto. - Qed. - - Definition eq_dec : forall x y, { eq x y }+{ ~eq x y }. - Proof. - intros (x1,x2) (y1,y2); unfold eq; simpl. - destruct (D1.eq_dec x1 y1); destruct (D2.eq_dec x2 y2); intuition. - Defined. - -End PairDecidableType. - -(** Similarly for pairs of UsualDecidableType *) - -Module PairUsualDecidableType(D1 D2:UsualDecidableType) <: UsualDecidableType. - Definition t := prod D1.t D2.t. - Definition eq := @eq t. - Definition eq_refl := @eq_refl t. - Definition eq_sym := @eq_sym t. - Definition eq_trans := @eq_trans t. - Definition eq_dec : forall x y, { eq x y }+{ ~eq x y }. - Proof. - intros (x1,x2) (y1,y2); - destruct (D1.eq_dec x1 y1); destruct (D2.eq_dec x2 y2); - unfold eq, D1.eq, D2.eq in *; simpl; - (left; f_equal; auto; fail) || - (right; injection; auto). - Defined. - -End PairUsualDecidableType. diff --git a/stdlib/theories/Structures/Equalities.v b/stdlib/theories/Structures/Equalities.v deleted file mode 100644 index 760e61dabf0b..000000000000 --- a/stdlib/theories/Structures/Equalities.v +++ /dev/null @@ -1,285 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* t -> Prop. -End HasEq. - -Module Type Eq := Typ <+ HasEq. - -Module Type EqNotation (Import E:Eq). - Infix "==" := eq (at level 70, no associativity). - Notation "x ~= y" := (~eq x y) (at level 70, no associativity). -End EqNotation. - -Module Type Eq' := Eq <+ EqNotation. - -(** * Specification of the equality via the [Equivalence] type class *) - -Module Type IsEq (Import E:Eq). -#[global] - Declare Instance eq_equiv : Equivalence eq. -End IsEq. - -(** * Earlier specification of equality by three separate lemmas. *) - -Module Type IsEqOrig (Import E:Eq'). - Axiom eq_refl : forall x : t, x==x. - Axiom eq_sym : forall x y : t, x==y -> y==x. - Axiom eq_trans : forall x y z : t, x==y -> y==z -> x==z. - #[global] - Hint Immediate eq_sym : core. - #[global] - Hint Resolve eq_refl eq_trans : core. -End IsEqOrig. - -(** * Types with decidable equality *) - -Module Type HasEqDec (Import E:Eq'). - Parameter eq_dec : forall x y : t, { x==y } + { ~ x==y }. -End HasEqDec. - -(** * Boolean Equality *) - -(** Having [eq_dec] is the same as having a boolean equality plus - a correctness proof. *) - -Module Type HasEqb (Import T:Typ). - Parameter Inline eqb : t -> t -> bool. -End HasEqb. - -Module Type EqbSpec (T:Typ)(X:HasEq T)(Y:HasEqb T). - Parameter eqb_eq : forall x y, Y.eqb x y = true <-> X.eq x y. -End EqbSpec. - -Module Type EqbNotation (T:Typ)(E:HasEqb T). - Infix "=?" := E.eqb (at level 70, no associativity). -End EqbNotation. - -Module Type HasEqBool (E:Eq) := HasEqb E <+ EqbSpec E E. - -(** From these basic blocks, we can build many combinations - of static standalone module types. *) - -Module Type EqualityType := Eq <+ IsEq. - -Module Type EqualityTypeOrig := Eq <+ IsEqOrig. - -Module Type EqualityTypeBoth <: EqualityType <: EqualityTypeOrig - := Eq <+ IsEq <+ IsEqOrig. - -Module Type DecidableType <: EqualityType - := Eq <+ IsEq <+ HasEqDec. - -Module Type DecidableTypeOrig <: EqualityTypeOrig - := Eq <+ IsEqOrig <+ HasEqDec. - -Module Type DecidableTypeBoth <: DecidableType <: DecidableTypeOrig - := EqualityTypeBoth <+ HasEqDec. - -Module Type BooleanEqualityType <: EqualityType - := Eq <+ IsEq <+ HasEqBool. - -Module Type BooleanDecidableType <: DecidableType <: BooleanEqualityType - := Eq <+ IsEq <+ HasEqDec <+ HasEqBool. - -Module Type DecidableTypeFull <: DecidableTypeBoth <: BooleanDecidableType - := Eq <+ IsEq <+ IsEqOrig <+ HasEqDec <+ HasEqBool. - -(** Same, with notation for [eq] *) - -Module Type EqualityType' := EqualityType <+ EqNotation. -Module Type EqualityTypeOrig' := EqualityTypeOrig <+ EqNotation. -Module Type EqualityTypeBoth' := EqualityTypeBoth <+ EqNotation. -Module Type DecidableType' := DecidableType <+ EqNotation. -Module Type DecidableTypeOrig' := DecidableTypeOrig <+ EqNotation. -Module Type DecidableTypeBoth' := DecidableTypeBoth <+ EqNotation. -Module Type BooleanEqualityType' := - BooleanEqualityType <+ EqNotation <+ EqbNotation. -Module Type BooleanDecidableType' := - BooleanDecidableType <+ EqNotation <+ EqbNotation. -Module Type DecidableTypeFull' := DecidableTypeFull <+ EqNotation. - -(** * Compatibility wrapper from/to the old version of - [EqualityType] and [DecidableType] *) - -Module BackportEq (E:Eq)(F:IsEq E) <: IsEqOrig E. - Definition eq_refl := @Equivalence_Reflexive _ _ F.eq_equiv. - Definition eq_sym := @Equivalence_Symmetric _ _ F.eq_equiv. - Definition eq_trans := @Equivalence_Transitive _ _ F.eq_equiv. -End BackportEq. - -Module UpdateEq (E:Eq)(F:IsEqOrig E) <: IsEq E. -#[global] - Instance eq_equiv : Equivalence E.eq. - Proof. exact (Build_Equivalence _ F.eq_refl F.eq_sym F.eq_trans). Qed. -End UpdateEq. - -Module Backport_ET (E:EqualityType) <: EqualityTypeBoth - := E <+ BackportEq. - -Module Update_ET (E:EqualityTypeOrig) <: EqualityTypeBoth - := E <+ UpdateEq. - -Module Backport_DT (E:DecidableType) <: DecidableTypeBoth - := E <+ BackportEq. - -Module Update_DT (E:DecidableTypeOrig) <: DecidableTypeBoth - := E <+ UpdateEq. - - -(** * Having [eq_dec] is equivalent to having [eqb] and its spec. *) - -Module HasEqDec2Bool (E:Eq)(F:HasEqDec E) <: HasEqBool E. - Definition eqb x y := if F.eq_dec x y then true else false. - Lemma eqb_eq : forall x y, eqb x y = true <-> E.eq x y. - Proof. - intros x y. unfold eqb. destruct F.eq_dec as [EQ|NEQ]. - - auto with *. - - split. - + discriminate. - + intro EQ; elim NEQ; auto. - Qed. -End HasEqDec2Bool. - -Module HasEqBool2Dec (E:Eq)(F:HasEqBool E) <: HasEqDec E. - Lemma eq_dec : forall x y, {E.eq x y}+{~E.eq x y}. - Proof. - intros x y. assert (H:=F.eqb_eq x y). - destruct (F.eqb x y); [left|right]. - - apply -> H; auto. - - intro EQ. apply H in EQ. discriminate. - Defined. -End HasEqBool2Dec. - -Module Dec2Bool (E:DecidableType) <: BooleanDecidableType - := E <+ HasEqDec2Bool. - -Module Bool2Dec (E:BooleanEqualityType) <: BooleanDecidableType - := E <+ HasEqBool2Dec. - - -(** Some properties of boolean equality *) - -Module BoolEqualityFacts (Import E : BooleanEqualityType'). - -(** [eqb] is compatible with [eq] *) - -#[global] -Instance eqb_compat : Proper (E.eq ==> E.eq ==> Logic.eq) eqb. -Proof. -intros x x' Exx' y y' Eyy'. -apply eq_true_iff_eq. -now rewrite 2 eqb_eq, Exx', Eyy'. -Qed. - -(** Alternative specification of [eqb] based on [reflect]. *) - -Lemma eqb_spec x y : reflect (x==y) (x =? y). -Proof. -apply iff_reflect. symmetry. apply eqb_eq. -Defined. - -(** Negated form of [eqb_eq] *) - -Lemma eqb_neq x y : (x =? y) = false <-> x ~= y. -Proof. -now rewrite <- not_true_iff_false, eqb_eq. -Qed. - -(** Basic equality laws for [eqb] *) - -Lemma eqb_refl x : (x =? x) = true. -Proof. -now apply eqb_eq. -Qed. - -Lemma eqb_sym x y : (x =? y) = (y =? x). -Proof. -apply eq_true_iff_eq. now rewrite 2 eqb_eq. -Qed. - -(** Transitivity is a particular case of [eqb_compat] *) - -End BoolEqualityFacts. - - -(** * UsualDecidableType - - A particular case of [DecidableType] where the equality is - the usual one of Coq. *) - -Module Type HasUsualEq (Import T:Typ) <: HasEq T. - Definition eq := @Logic.eq t. -End HasUsualEq. - -Module Type UsualEq <: Eq := Typ <+ HasUsualEq. - -Module Type UsualIsEq (E:UsualEq) <: IsEq E. - (* No Instance syntax to avoid saturating the Equivalence tables *) - Definition eq_equiv : Equivalence E.eq := eq_equivalence. -End UsualIsEq. - -Module Type UsualIsEqOrig (E:UsualEq) <: IsEqOrig E. - Definition eq_refl := @Logic.eq_refl E.t. - Definition eq_sym := @Logic.eq_sym E.t. - Definition eq_trans := @Logic.eq_trans E.t. -End UsualIsEqOrig. - -Module Type UsualEqualityType <: EqualityType - := UsualEq <+ UsualIsEq. - -Module Type UsualDecidableType <: DecidableType - := UsualEq <+ UsualIsEq <+ HasEqDec. - -Module Type UsualDecidableTypeOrig <: DecidableTypeOrig - := UsualEq <+ UsualIsEqOrig <+ HasEqDec. - -Module Type UsualDecidableTypeBoth <: DecidableTypeBoth - := UsualEq <+ UsualIsEq <+ UsualIsEqOrig <+ HasEqDec. - -Module Type UsualBoolEq := UsualEq <+ HasEqBool. - -Module Type UsualDecidableTypeFull <: DecidableTypeFull - := UsualEq <+ UsualIsEq <+ UsualIsEqOrig <+ HasEqDec <+ HasEqBool. - - -(** Some shortcuts for easily building a [UsualDecidableType] *) - -Module Type MiniDecidableType. - Include Typ. - Parameter eq_dec : forall x y : t, {x=y}+{~x=y}. -End MiniDecidableType. - -Module Make_UDT (M:MiniDecidableType) <: UsualDecidableTypeBoth - := M <+ HasUsualEq <+ UsualIsEq <+ UsualIsEqOrig. - -Module Make_UDTF (M:UsualBoolEq) <: UsualDecidableTypeFull - := M <+ UsualIsEq <+ UsualIsEqOrig <+ HasEqBool2Dec. diff --git a/stdlib/theories/Structures/EqualitiesFacts.v b/stdlib/theories/Structures/EqualitiesFacts.v deleted file mode 100644 index c7138f85f071..000000000000 --- a/stdlib/theories/Structures/EqualitiesFacts.v +++ /dev/null @@ -1,239 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* D.eq k k'. - Proof. now destruct 1. Qed. - - Lemma eqke_2 {elt} k k' (e e':elt) : eqke (k,e) (k',e') -> e=e'. - Proof. now destruct 1. Qed. - - Lemma eqk_def {elt} k k' (e e':elt) : eqk (k,e) (k',e') = D.eq k k'. - Proof. reflexivity. Defined. - - Lemma eqk_def' {elt} (p q:key*elt) : eqk p q = D.eq (fst p) (fst q). - Proof. reflexivity. Qed. - - Lemma eqk_1 {elt} k k' (e e':elt) : eqk (k,e) (k',e') -> D.eq k k'. - Proof. trivial. Qed. - - #[global] - Hint Resolve eqke_1 eqke_2 eqk_1 : core. - - (* Additional facts *) - - Lemma InA_eqke_eqk {elt} p (m:list (key*elt)) : - InA eqke p m -> InA eqk p m. - Proof. - induction 1; firstorder. - Qed. - #[global] - Hint Resolve InA_eqke_eqk : core. - - 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 auto with crelations. - Qed. - - Lemma InA_eqk {elt} p q (m:list (key*elt)) : - eqk p q -> InA eqk p m -> InA eqk q m. - Proof. - now intros <-. - Qed. - - Definition MapsTo {elt} (k:key)(e:elt):= InA eqke (k,e). - Definition In {elt} k m := exists e:elt, MapsTo k e m. - - #[global] - Hint Unfold MapsTo In : core. - - (* Alternative formulations for [In k l] *) - - Lemma In_alt {elt} k (l:list (key*elt)) : - In k l <-> exists e, InA eqk (k,e) l. - Proof. - unfold In, MapsTo. - split; intros (e,H). - - exists e; auto. - - apply InA_eqk_eqke in H. destruct H as ((k',e'),(E,H)). - compute in E. exists e'. now rewrite E. - Qed. - - Lemma In_alt' {elt} (l:list (key*elt)) k e : - In k l <-> InA eqk (k,e) l. - Proof. - rewrite In_alt. firstorder. eapply InA_eqk; eauto. now compute. - Qed. - - Lemma In_alt2 {elt} k (l:list (key*elt)) : - In k l <-> Exists (fun p => D.eq k (fst p)) l. - Proof. - unfold In, MapsTo. - setoid_rewrite Exists_exists; setoid_rewrite InA_alt. - firstorder. - exists (snd x), x; auto. - Qed. - - Lemma In_nil {elt} k : In k (@nil (key*elt)) <-> False. - Proof. - rewrite In_alt2; apply Exists_nil. - Qed. - - Lemma In_cons {elt} k p (l:list (key*elt)) : - In k (p::l) <-> D.eq k (fst p) \/ In k l. - Proof. - rewrite !In_alt2, Exists_cons; intuition. - Qed. - -#[global] - Instance MapsTo_compat {elt} : - Proper (D.eq==>Logic.eq==>equivlistA eqke==>iff) (@MapsTo elt). - Proof. - intros x x' Hx e e' He l l' Hl. unfold MapsTo. - rewrite Hx, He, Hl; intuition. - Qed. - -#[global] - Instance In_compat {elt} : Proper (D.eq==>equivlistA eqk==>iff) (@In elt). - Proof. - intros x x' Hx l l' Hl. rewrite !In_alt. - setoid_rewrite Hl. setoid_rewrite Hx. intuition. - Qed. - - Lemma MapsTo_eq {elt} (l:list (key*elt)) x y e : - D.eq x y -> MapsTo x e l -> MapsTo y e l. - Proof. now intros <-. Qed. - - Lemma In_eq {elt} (l:list (key*elt)) x y : - D.eq x y -> In x l -> In y l. - Proof. now intros <-. Qed. - - Lemma In_inv {elt} k k' e (l:list (key*elt)) : - In k ((k',e) :: l) -> D.eq k k' \/ In k l. - Proof. - intros (e',H). red in H. rewrite InA_cons, eqke_def in H. - intuition. right. now exists e'. - Qed. - - Lemma In_inv_2 {elt} k k' e e' (l:list (key*elt)) : - InA eqk (k, e) ((k', e') :: l) -> ~ D.eq k k' -> InA eqk (k, e) l. - Proof. - rewrite InA_cons, eqk_def. intuition. - Qed. - - Lemma In_inv_3 {elt} x x' (l:list (key*elt)) : - InA eqke x (x' :: l) -> ~ eqk x x' -> InA eqke x l. - Proof. - rewrite InA_cons. destruct 1 as [H|H]; trivial. destruct 1. - eauto with *. - Qed. - - #[global] - Hint Extern 2 (eqke ?a ?b) => split : core. - #[global] - Hint Resolve InA_eqke_eqk : core. - #[global] - Hint Resolve In_inv_2 In_inv_3 : core. - -End KeyDecidableType. - - -(** * PairDecidableType - - From two decidable types, we can build a new DecidableType - over their cartesian product. *) - -Module PairDecidableType(D1 D2:DecidableType) <: DecidableType. - - Definition t := (D1.t * D2.t)%type. - - Definition eq := (D1.eq * D2.eq)%signature. - -#[global] - Instance eq_equiv : Equivalence eq := _. - - Definition eq_dec : forall x y, { eq x y }+{ ~eq x y }. - Proof. - intros (x1,x2) (y1,y2); unfold eq; simpl. - destruct (D1.eq_dec x1 y1); destruct (D2.eq_dec x2 y2); - compute; intuition. - Defined. - -End PairDecidableType. - -(** Similarly for pairs of UsualDecidableType *) - -Module PairUsualDecidableType(D1 D2:UsualDecidableType) <: UsualDecidableType. - Definition t := (D1.t * D2.t)%type. - Definition eq := @eq t. -#[global] - Instance eq_equiv : Equivalence eq := _. - Definition eq_dec : forall x y, { eq x y }+{ ~eq x y }. - Proof. - intros (x1,x2) (y1,y2); - destruct (D1.eq_dec x1 y1); destruct (D2.eq_dec x2 y2); - unfold eq, D1.eq, D2.eq in *; simpl; - (left; f_equal; auto; fail) || - (right; intros [=]; auto). - Defined. - -End PairUsualDecidableType. - -(** And also for pairs of UsualDecidableTypeFull *) - -Module PairUsualDecidableTypeFull (D1 D2:UsualDecidableTypeFull) - <: UsualDecidableTypeFull. - - Module M := PairUsualDecidableType D1 D2. - Include Backport_DT (M). - Include HasEqDec2Bool. - -End PairUsualDecidableTypeFull. diff --git a/stdlib/theories/Structures/GenericMinMax.v b/stdlib/theories/Structures/GenericMinMax.v deleted file mode 100644 index df67069bacd1..000000000000 --- a/stdlib/theories/Structures/GenericMinMax.v +++ /dev/null @@ -1,662 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* t -> t. - Parameter max_l : forall x y, y<=x -> max x y == x. - Parameter max_r : forall x y, x<=y -> max x y == y. -End HasMax. - -Module Type HasMin (Import E:EqLe'). - Parameter Inline min : t -> t -> t. - Parameter min_l : forall x y, x<=y -> min x y == x. - Parameter min_r : forall x y, y<=x -> min x y == y. -End HasMin. - -Module Type HasMinMax (E:EqLe) := HasMax E <+ HasMin E. - - -(** ** Any [OrderedTypeFull] can be equipped by [max] and [min] - based on the compare function. *) - -Definition gmax {A} (cmp : A->A->comparison) x y := - match cmp x y with Lt => y | _ => x end. -Definition gmin {A} (cmp : A->A->comparison) x y := - match cmp x y with Gt => y | _ => x end. - -Module GenericMinMax (Import O:OrderedTypeFull') <: HasMinMax O. - - Definition max := gmax O.compare. - Definition min := gmin O.compare. - - Lemma ge_not_lt x y : y<=x -> x False. - Proof. - intros H H'. - apply (StrictOrder_Irreflexive x). - rewrite le_lteq in *; destruct H as [H|H]. - - transitivity y; auto. - - rewrite H in H'; auto. - Qed. - - Lemma max_l x y : y<=x -> max x y == x. - Proof. - intros. unfold max, gmax. case compare_spec; auto with relations. - intros; elim (ge_not_lt x y); auto. - Qed. - - Lemma max_r x y : x<=y -> max x y == y. - Proof. - intros. unfold max, gmax. case compare_spec; auto with relations. - intros; elim (ge_not_lt y x); auto. - Qed. - - Lemma min_l x y : x<=y -> min x y == x. - Proof. - intros. unfold min, gmin. case compare_spec; auto with relations. - intros; elim (ge_not_lt y x); auto. - Qed. - - Lemma min_r x y : y<=x -> min x y == y. - Proof. - intros. unfold min, gmin. case compare_spec; auto with relations. - intros; elim (ge_not_lt x y); auto. - Qed. - -End GenericMinMax. - - -(** ** Consequences of the minimalist interface: facts about [max] and [min]. *) - -Module MinMaxLogicalProperties (Import O:TotalOrder')(Import M:HasMinMax O). - Module Import Private_Tac := !MakeOrderTac O O. - -(** An alternative characterisation of [max], equivalent to - [max_l /\ max_r] *) - -Lemma max_spec n m : - (n < m /\ max n m == m) \/ (m <= n /\ max n m == n). -Proof. - destruct (lt_total n m); [left|right]. - - split; auto. apply max_r. rewrite le_lteq; auto. - - assert (m <= n) by (rewrite le_lteq; intuition auto with relations). - split; auto. now apply max_l. -Qed. - -(** A more symmetric version of [max_spec], based only on [le]. - Beware that left and right alternatives overlap. *) - -Lemma max_spec_le n m : - (n <= m /\ max n m == m) \/ (m <= n /\ max n m == n). -Proof. - destruct (max_spec n m); [left|right]; intuition; order. -Qed. - -#[global] -Instance : Proper (eq==>eq==>iff) le. -Proof. repeat red. intuition order. Qed. - -#[global] -Instance max_compat : Proper (eq==>eq==>eq) max. -Proof. - intros x x' Hx y y' Hy. - assert (H1 := max_spec x y). assert (H2 := max_spec x' y'). - set (m := max x y) in *; set (m' := max x' y') in *; clearbody m m'. - rewrite <- Hx, <- Hy in *. - destruct (lt_total x y); intuition order. -Qed. - -(** A function satisfying the same specification is equal to [max]. *) - -Lemma max_unicity n m p : - ((n < m /\ p == m) \/ (m <= n /\ p == n)) -> p == max n m. -Proof. - assert (Hm := max_spec n m). - destruct (lt_total n m); intuition; order. -Qed. - -Lemma max_unicity_ext f : - (forall n m, (n < m /\ f n m == m) \/ (m <= n /\ f n m == n)) -> - (forall n m, f n m == max n m). -Proof. - intros. apply max_unicity; auto. -Qed. - -(** [max] commutes with monotone functions. *) - -Lemma max_mono f : - (Proper (eq ==> eq) f) -> - (Proper (le ==> le) f) -> - forall x y, max (f x) (f y) == f (max x y). -Proof. - intros Eqf Lef x y. - destruct (max_spec x y) as [(H,E)|(H,E)]; rewrite E; - destruct (max_spec (f x) (f y)) as [(H',E')|(H',E')]; auto. - - assert (f x <= f y) by (apply Lef; order). order. - - assert (f y <= f x) by (apply Lef; order). order. -Qed. - -(** *** Semi-lattice algebraic properties of [max] *) - -Lemma max_id n : max n n == n. -Proof. - apply max_l; order. -Qed. - -Notation max_idempotent := max_id (only parsing). - -Lemma max_assoc m n p : max m (max n p) == max (max m n) p. -Proof. - destruct (max_spec n p) as [(H,E)|(H,E)]; rewrite E; - destruct (max_spec m n) as [(H',E')|(H',E')]; rewrite E', ?E; try easy. - - apply max_r; order. - - symmetry. apply max_l; order. -Qed. - -Lemma max_comm n m : max n m == max m n. -Proof. - destruct (max_spec m n) as [(H,E)|(H,E)]; rewrite E; - (apply max_r || apply max_l); order. -Qed. - -Ltac solve_max := - match goal with |- context [max ?n ?m] => - destruct (max_spec n m); intuition; order - end. - -(** *** Least-upper bound properties of [max] *) - -Lemma le_max_l n m : n <= max n m. -Proof. solve_max. Qed. - -Lemma le_max_r n m : m <= max n m. -Proof. solve_max. Qed. - -Lemma max_l_iff n m : max n m == n <-> m <= n. -Proof. solve_max. Qed. - -Lemma max_r_iff n m : max n m == m <-> n <= m. -Proof. solve_max. Qed. - -Lemma max_le n m p : p <= max n m -> p <= n \/ p <= m. -Proof. - destruct (max_spec n m); [right|left]; intuition; order. -Qed. - -Lemma max_le_iff n m p : p <= max n m <-> p <= n \/ p <= m. -Proof. - split. - - apply max_le. - - solve_max. -Qed. - -Lemma max_lt_iff n m p : p < max n m <-> p < n \/ p < m. -Proof. - destruct (max_spec n m); intuition; - order || (right; order) || (left; order). -Qed. - -Lemma max_lub_l n m p : max n m <= p -> n <= p. -Proof. solve_max. Qed. - -Lemma max_lub_r n m p : max n m <= p -> m <= p. -Proof. solve_max. Qed. - -Lemma max_lub n m p : n <= p -> m <= p -> max n m <= p. -Proof. solve_max. Qed. - -Lemma max_lub_iff n m p : max n m <= p <-> n <= p /\ m <= p. -Proof. solve_max. Qed. - -Lemma max_lub_lt n m p : n < p -> m < p -> max n m < p. -Proof. solve_max. Qed. - -Lemma max_lub_lt_iff n m p : max n m < p <-> n < p /\ m < p. -Proof. solve_max. Qed. - -Lemma max_le_compat_l n m p : n <= m -> max p n <= max p m. -Proof. intros. apply max_lub_iff. solve_max. Qed. - -Lemma max_le_compat_r n m p : n <= m -> max n p <= max m p. -Proof. intros. apply max_lub_iff. solve_max. Qed. - -Lemma max_le_compat n m p q : n <= m -> p <= q -> max n p <= max m q. -Proof. - intros Hnm Hpq. - assert (LE := max_le_compat_l _ _ m Hpq). - assert (LE' := max_le_compat_r _ _ p Hnm). - order. -Qed. - -(** Properties of [min] *) - -Lemma min_spec n m : - (n < m /\ min n m == n) \/ (m <= n /\ min n m == m). -Proof. - destruct (lt_total n m); [left|right]. - - split; auto. apply min_l. rewrite le_lteq; auto. - - assert (m <= n) by (rewrite le_lteq; intuition auto with relations). - split; auto. now apply min_r. -Qed. - -Lemma min_spec_le n m : - (n <= m /\ min n m == n) \/ (m <= n /\ min n m == m). -Proof. - destruct (min_spec n m); [left|right]; intuition; order. -Qed. - -#[global] -Instance min_compat : Proper (eq==>eq==>eq) min. -Proof. -intros x x' Hx y y' Hy. -assert (H1 := min_spec x y). assert (H2 := min_spec x' y'). -set (m := min x y) in *; set (m' := min x' y') in *; clearbody m m'. -rewrite <- Hx, <- Hy in *. -destruct (lt_total x y); intuition order. -Qed. - -Lemma min_unicity n m p : - ((n < m /\ p == n) \/ (m <= n /\ p == m)) -> p == min n m. -Proof. - assert (Hm := min_spec n m). - destruct (lt_total n m); intuition; order. -Qed. - -Lemma min_unicity_ext f : - (forall n m, (n < m /\ f n m == n) \/ (m <= n /\ f n m == m)) -> - (forall n m, f n m == min n m). -Proof. - intros. apply min_unicity; auto. -Qed. - -Lemma min_mono f : - (Proper (eq ==> eq) f) -> - (Proper (le ==> le) f) -> - forall x y, min (f x) (f y) == f (min x y). -Proof. - intros Eqf Lef x y. - destruct (min_spec x y) as [(H,E)|(H,E)]; rewrite E; - destruct (min_spec (f x) (f y)) as [(H',E')|(H',E')]; auto. - - assert (f x <= f y) by (apply Lef; order). order. - - assert (f y <= f x) by (apply Lef; order). order. -Qed. - -Lemma min_id n : min n n == n. -Proof. - apply min_l; order. -Qed. - -Notation min_idempotent := min_id (only parsing). - -Lemma min_assoc m n p : min m (min n p) == min (min m n) p. -Proof. - destruct (min_spec n p) as [(H,E)|(H,E)]; rewrite E; - destruct (min_spec m n) as [(H',E')|(H',E')]; rewrite E', ?E; try easy. - - symmetry. apply min_l; order. - - apply min_r; order. -Qed. - -Lemma min_comm n m : min n m == min m n. -Proof. - destruct (min_spec m n) as [(H,E)|(H,E)]; rewrite E; - (apply min_r || apply min_l); order. -Qed. - -Ltac solve_min := - match goal with |- context [min ?n ?m] => - destruct (min_spec n m); intuition; order - end. - -Lemma le_min_r n m : min n m <= m. -Proof. solve_min. Qed. - -Lemma le_min_l n m : min n m <= n. -Proof. solve_min. Qed. - -Lemma min_l_iff n m : min n m == n <-> n <= m. -Proof. solve_min. Qed. - -Lemma min_r_iff n m : min n m == m <-> m <= n. -Proof. solve_min. Qed. - -Lemma min_le n m p : min n m <= p -> n <= p \/ m <= p. -Proof. - destruct (min_spec n m); [left|right]; intuition; order. -Qed. - -Lemma min_le_iff n m p : min n m <= p <-> n <= p \/ m <= p. -Proof. - split. - - apply min_le. - - solve_min. -Qed. - -Lemma min_lt_iff n m p : min n m < p <-> n < p \/ m < p. -Proof. - destruct (min_spec n m); intuition; - order || (right; order) || (left; order). -Qed. - -Lemma min_glb_l n m p : p <= min n m -> p <= n. -Proof. solve_min. Qed. - -Lemma min_glb_r n m p : p <= min n m -> p <= m. -Proof. solve_min. Qed. - -Lemma min_glb n m p : p <= n -> p <= m -> p <= min n m. -Proof. solve_min. Qed. - -Lemma min_glb_iff n m p : p <= min n m <-> p <= n /\ p <= m. -Proof. solve_min. Qed. - -Lemma min_glb_lt n m p : p < n -> p < m -> p < min n m. -Proof. solve_min. Qed. - -Lemma min_glb_lt_iff n m p : p < min n m <-> p < n /\ p < m. -Proof. solve_min. Qed. - -Lemma min_le_compat_l n m p : n <= m -> min p n <= min p m. -Proof. intros. apply min_glb_iff. solve_min. Qed. - -Lemma min_le_compat_r n m p : n <= m -> min n p <= min m p. -Proof. intros. apply min_glb_iff. solve_min. Qed. - -Lemma min_le_compat n m p q : n <= m -> p <= q -> - min n p <= min m q. -Proof. - intros Hnm Hpq. - assert (LE := min_le_compat_l _ _ m Hpq). - assert (LE' := min_le_compat_r _ _ p Hnm). - order. -Qed. - -(** *** Combined properties of min and max *) - -Lemma min_max_absorption n m : max n (min n m) == n. -Proof. - intros. - destruct (min_spec n m) as [(C,E)|(C,E)]; rewrite E. - - apply max_l. order. - - destruct (max_spec n m); intuition; order. -Qed. - -Lemma max_min_absorption n m : min n (max n m) == n. -Proof. - intros. - destruct (max_spec n m) as [(C,E)|(C,E)]; rewrite E. - - destruct (min_spec n m) as [(C',E')|(C',E')]; auto. order. - - apply min_l; auto. order. -Qed. - -(** Distributivity *) - -Lemma max_min_distr n m p : - max n (min m p) == min (max n m) (max n p). -Proof. - symmetry. apply min_mono. - - eauto with *. - - repeat red; intros. apply max_le_compat_l; auto. -Qed. - -Lemma min_max_distr n m p : - min n (max m p) == max (min n m) (min n p). -Proof. - symmetry. apply max_mono. - - eauto with *. - - repeat red; intros. apply min_le_compat_l; auto. -Qed. - -(** Modularity *) - -Lemma max_min_modular n m p : - max n (min m (max n p)) == min (max n m) (max n p). -Proof. - rewrite <- max_min_distr. - destruct (max_spec n p) as [(C,E)|(C,E)]; rewrite E; auto with *. - destruct (min_spec m n) as [(C',E')|(C',E')]; rewrite E'. - - rewrite 2 max_l; try order. rewrite min_le_iff; auto. - - rewrite 2 max_l; try order. rewrite min_le_iff; auto. -Qed. - -Lemma min_max_modular n m p : - min n (max m (min n p)) == max (min n m) (min n p). -Proof. - intros. rewrite <- min_max_distr. - destruct (min_spec n p) as [(C,E)|(C,E)]; rewrite E; auto with *. - destruct (max_spec m n) as [(C',E')|(C',E')]; rewrite E'. - - rewrite 2 min_l; try order. rewrite max_le_iff; right; order. - - rewrite 2 min_l; try order. rewrite max_le_iff; auto. -Qed. - -(** Disassociativity *) - -Lemma max_min_disassoc n m p : - min n (max m p) <= max (min n m) p. -Proof. - intros. rewrite min_max_distr. - auto using max_le_compat_l, le_min_r. -Qed. - -(** Anti-monotonicity swaps the role of [min] and [max] *) - -Lemma max_min_antimono f : - Proper (eq==>eq) f -> - Proper (le==>flip le) f -> - forall x y, max (f x) (f y) == f (min x y). -Proof. - intros Eqf Lef x y. - destruct (min_spec x y) as [(H,E)|(H,E)]; rewrite E; - destruct (max_spec (f x) (f y)) as [(H',E')|(H',E')]; auto. - - assert (f y <= f x) by (apply Lef; order). order. - - assert (f x <= f y) by (apply Lef; order). order. -Qed. - -Lemma min_max_antimono f : - Proper (eq==>eq) f -> - Proper (le==>flip le) f -> - forall x y, min (f x) (f y) == f (max x y). -Proof. - intros Eqf Lef x y. - destruct (max_spec x y) as [(H,E)|(H,E)]; rewrite E; - destruct (min_spec (f x) (f y)) as [(H',E')|(H',E')]; auto. - - assert (f y <= f x) by (apply Lef; order). order. - - assert (f x <= f y) by (apply Lef; order). order. -Qed. - -End MinMaxLogicalProperties. - - -(** ** Properties requiring a decidable order *) - -Module MinMaxDecProperties (Import O:OrderedTypeFull')(Import M:HasMinMax O). - -(** Induction principles for [max]. *) - -Lemma max_case_strong n m (P:t -> Type) : - (forall x y, x==y -> P x -> P y) -> - (m<=n -> P n) -> (n<=m -> P m) -> P (max n m). -Proof. -intros Compat Hl Hr. -destruct (CompSpec2Type (compare_spec n m)) as [EQ|LT|GT]. -- assert (n<=m) by (rewrite le_lteq; auto). - apply (Compat m), Hr; auto. symmetry; apply max_r; auto. -- assert (n<=m) by (rewrite le_lteq; auto). - apply (Compat m), Hr; auto. symmetry; apply max_r; auto. -- assert (m<=n) by (rewrite le_lteq; auto). - apply (Compat n), Hl; auto. symmetry; apply max_l; auto. -Defined. - -Lemma max_case n m (P:t -> Type) : - (forall x y, x == y -> P x -> P y) -> - P n -> P m -> P (max n m). -Proof. intros. apply max_case_strong; auto. Defined. - -(** [max] returns one of its arguments. *) - -Lemma max_dec n m : {max n m == n} + {max n m == m}. -Proof. - apply max_case; auto with relations. - intros x y H [E|E]; [left|right]; rewrite <-H; auto. -Defined. - -(** Idem for [min] *) - -Lemma min_case_strong n m (P:O.t -> Type) : - (forall x y, x == y -> P x -> P y) -> - (n<=m -> P n) -> (m<=n -> P m) -> P (min n m). -Proof. -intros Compat Hl Hr. -destruct (CompSpec2Type (compare_spec n m)) as [EQ|LT|GT]. -- assert (n<=m) by (rewrite le_lteq; auto). - apply (Compat n), Hl; auto. symmetry; apply min_l; auto. -- assert (n<=m) by (rewrite le_lteq; auto). - apply (Compat n), Hl; auto. symmetry; apply min_l; auto. -- assert (m<=n) by (rewrite le_lteq; auto). - apply (Compat m), Hr; auto. symmetry; apply min_r; auto. -Defined. - -Lemma min_case n m (P:O.t -> Type) : - (forall x y, x == y -> P x -> P y) -> - P n -> P m -> P (min n m). -Proof. intros. apply min_case_strong; auto. Defined. - -Lemma min_dec n m : {min n m == n} + {min n m == m}. -Proof. - intros. apply min_case; auto with relations. - intros x y H [E|E]; [left|right]; rewrite <- E; auto with relations. -Defined. - -End MinMaxDecProperties. - -Module MinMaxProperties (Import O:OrderedTypeFull')(Import M:HasMinMax O). - Module OT := OTF_to_TotalOrder O. - Include MinMaxLogicalProperties OT M. - Include MinMaxDecProperties O M. - Definition max_l := max_l. - Definition max_r := max_r. - Definition min_l := min_l. - Definition min_r := min_r. - Notation max_monotone := max_mono. - Notation min_monotone := min_mono. - Notation max_min_antimonotone := max_min_antimono. - Notation min_max_antimonotone := min_max_antimono. -End MinMaxProperties. - - -(** ** When the equality is Leibniz, we can skip a few [Proper] precondition. *) - -Module UsualMinMaxLogicalProperties - (Import O:UsualTotalOrder')(Import M:HasMinMax O). - - Include MinMaxLogicalProperties O M. - - Lemma max_monotone f : Proper (le ==> le) f -> - forall x y, max (f x) (f y) = f (max x y). - Proof. intros; apply max_mono; auto. congruence. Qed. - - Lemma min_monotone f : Proper (le ==> le) f -> - forall x y, min (f x) (f y) = f (min x y). - Proof. intros; apply min_mono; auto. congruence. Qed. - - Lemma min_max_antimonotone f : Proper (le ==> flip le) f -> - forall x y, min (f x) (f y) = f (max x y). - Proof. intros; apply min_max_antimono; auto. congruence. Qed. - - Lemma max_min_antimonotone f : Proper (le ==> flip le) f -> - forall x y, max (f x) (f y) = f (min x y). - Proof. intros; apply max_min_antimono; auto. congruence. Qed. - -End UsualMinMaxLogicalProperties. - - -Module UsualMinMaxDecProperties - (Import O:UsualOrderedTypeFull')(Import M:HasMinMax O). - - Module Import Private_Dec := MinMaxDecProperties O M. - - Lemma max_case_strong : forall n m (P:t -> Type), - (m<=n -> P n) -> (n<=m -> P m) -> P (max n m). - Proof. intros; apply max_case_strong; auto. congruence. Defined. - - Lemma max_case : forall n m (P:t -> Type), - P n -> P m -> P (max n m). - Proof. intros; apply max_case_strong; auto. Defined. - - Lemma max_dec : forall n m, {max n m = n} + {max n m = m}. - Proof. exact max_dec. Defined. - - Lemma min_case_strong : forall n m (P:O.t -> Type), - (n<=m -> P n) -> (m<=n -> P m) -> P (min n m). - Proof. intros; apply min_case_strong; auto. congruence. Defined. - - Lemma min_case : forall n m (P:O.t -> Type), - P n -> P m -> P (min n m). - Proof. intros. apply min_case_strong; auto. Defined. - - Lemma min_dec : forall n m, {min n m = n} + {min n m = m}. - Proof. exact min_dec. Defined. - -End UsualMinMaxDecProperties. - -Module UsualMinMaxProperties - (Import O:UsualOrderedTypeFull')(Import M:HasMinMax O). - Module OT := OTF_to_TotalOrder O. - Include UsualMinMaxLogicalProperties OT M. - Include UsualMinMaxDecProperties O M. - Definition max_l := max_l. - Definition max_r := max_r. - Definition min_l := min_l. - Definition min_r := min_r. -End UsualMinMaxProperties. - - -(** From [TotalOrder] and [HasMax] and [HasEqDec], we can prove - that the order is decidable and build an [OrderedTypeFull]. *) - -Module TOMaxEqDec_to_Compare - (Import O:TotalOrder')(Import M:HasMax O)(Import E:HasEqDec O) <: HasCompare O. - - Definition compare x y := - if eq_dec x y then Eq - else if eq_dec (M.max x y) y then Lt else Gt. - - Lemma compare_spec x y : CompSpec eq lt x y (compare x y). - Proof. - unfold compare; repeat destruct eq_dec; auto; constructor. - - destruct (lt_total x y); auto. - absurd (x==y); auto. transitivity (max x y); auto. - symmetry. apply max_l. rewrite le_lteq; intuition. - - destruct (lt_total y x); auto. - absurd (max x y == y); auto. apply max_r; rewrite le_lteq; intuition auto with relations. - Qed. - -End TOMaxEqDec_to_Compare. - -Module TOMaxEqDec_to_OTF (O:TotalOrder)(M:HasMax O)(E:HasEqDec O) - <: OrderedTypeFull - := O <+ E <+ TOMaxEqDec_to_Compare O M E. - - - -(** TODO: Some Remaining questions... - ---> Compare with a type-classes version ? - ---> Is max_unicity and max_unicity_ext really convenient to express - that any possible definition of max will in fact be equivalent ? - ---> Is it possible to avoid copy-paste about min even more ? - -*) diff --git a/stdlib/theories/Structures/OrderedType.v b/stdlib/theories/Structures/OrderedType.v deleted file mode 100644 index e0e57ae60f3c..000000000000 --- a/stdlib/theories/Structures/OrderedType.v +++ /dev/null @@ -1,522 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* X -> Prop) (x y : X) : Type := - | LT : lt x y -> Compare lt eq x y - | EQ : eq x y -> Compare lt eq x y - | GT : lt y x -> Compare lt eq x y. - -Arguments LT [X lt eq x y] _. -Arguments EQ [X lt eq x y] _. -Arguments GT [X lt eq x y] _. - -Create HintDb ordered_type. - -Module Type MiniOrderedType. - - Parameter Inline t : Type. - - Parameter Inline eq : t -> t -> Prop. - Parameter Inline lt : t -> t -> Prop. - - Axiom eq_refl : forall x : t, eq x x. - Axiom eq_sym : forall x y : t, eq x y -> eq y x. - Axiom eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z. - - Axiom lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z. - Axiom lt_not_eq : forall x y : t, lt x y -> ~ eq x y. - - Parameter compare : forall x y : t, Compare lt eq x y. - - #[global] - Hint Immediate eq_sym : ordered_type. - #[global] - Hint Resolve eq_refl eq_trans lt_not_eq lt_trans : ordered_type. - -End MiniOrderedType. - -Module Type OrderedType. - Include MiniOrderedType. - - (** A [eq_dec] can be deduced from [compare] below. But adding this - redundant field allows seeing an OrderedType as a DecidableType. *) - Parameter eq_dec : forall x y, { eq x y } + { ~ eq x y }. - -End OrderedType. - -Module MOT_to_OT (Import O : MiniOrderedType) <: OrderedType. - Include O. - - Definition eq_dec : forall x y : t, {eq x y} + {~ eq x y}. - Proof with auto with ordered_type. - intros x y; elim (compare x y); intro H; [ right | left | right ]... - assert (~ eq y x)... - Defined. - -End MOT_to_OT. - -(** * Ordered types properties *) - -(** Additional properties that can be derived from signature - [OrderedType]. *) - -Module OrderedTypeFacts (Import O: OrderedType). - -#[global] - Instance eq_equiv : Equivalence eq. - Proof. split; [ exact eq_refl | exact eq_sym | exact eq_trans ]. Qed. - - Lemma lt_antirefl : forall x, ~ lt x x. - Proof. - intros x; intro; absurd (eq x x); auto with ordered_type. - Qed. - -#[global] - Instance lt_strorder : StrictOrder lt. - Proof. split; [ exact lt_antirefl | exact lt_trans]. Qed. - - Lemma lt_eq : forall x y z, lt x y -> eq y z -> lt x z. - Proof with auto with ordered_type. - intros x y z H ?; destruct (compare x z) as [Hlt|Heq|Hlt]; auto. - - elim (lt_not_eq H); apply eq_trans with z... - - elim (lt_not_eq (lt_trans Hlt H))... - Qed. - - Lemma eq_lt : forall x y z, eq x y -> lt y z -> lt x z. - Proof with auto with ordered_type. - intros x y z H H0; destruct (compare x z) as [Hlt|Heq|Hlt]; auto. - - elim (lt_not_eq H0); apply eq_trans with x... - - elim (lt_not_eq (lt_trans H0 Hlt))... - Qed. - -#[global] - Instance lt_compat : Proper (eq==>eq==>iff) lt. - apply proper_sym_impl_iff_2; auto with *. - intros x x' Hx y y' Hy H. - apply eq_lt with x; auto with ordered_type. - apply lt_eq with y; auto. - Qed. - - Lemma lt_total : forall x y, lt x y \/ eq x y \/ lt y x. - Proof. intros x y; destruct (compare x y); auto. Qed. - - Module TO. - Definition t := t. - Definition eq := eq. - Definition lt := lt. - Definition le x y := lt x y \/ eq x y. - End TO. - Module IsTO. - Definition eq_equiv := eq_equiv. - Definition lt_strorder := lt_strorder. - Definition lt_compat := lt_compat. - Definition lt_total := lt_total. - Lemma le_lteq x y : TO.le x y <-> lt x y \/ eq x y. - Proof. reflexivity. Qed. - End IsTO. - Module OrderTac := !MakeOrderTac TO IsTO. - Ltac order := OrderTac.order. - - Lemma le_eq x y z : ~lt x y -> eq y z -> ~lt x z. Proof. order. Qed. - Lemma eq_le x y z : eq x y -> ~lt y z -> ~lt x z. Proof. order. Qed. - Lemma neq_eq x y z : ~eq x y -> eq y z -> ~eq x z. Proof. order. Qed. - Lemma eq_neq x y z : eq x y -> ~eq y z -> ~eq x z. Proof. order. Qed. - Lemma le_lt_trans x y z : ~lt y x -> lt y z -> lt x z. Proof. order. Qed. - Lemma lt_le_trans x y z : lt x y -> ~lt z y -> lt x z. Proof. order. Qed. - Lemma le_neq x y : ~lt x y -> ~eq x y -> lt y x. Proof. order. Qed. - Lemma le_trans x y z : ~lt y x -> ~lt z y -> ~lt z x. Proof. order. Qed. - Lemma le_antisym x y : ~lt y x -> ~lt x y -> eq x y. Proof. order. Qed. - Lemma neq_sym x y : ~eq x y -> ~eq y x. Proof. order. Qed. - Lemma lt_le x y : lt x y -> ~lt y x. Proof. order. Qed. - Lemma gt_not_eq x y : lt y x -> ~ eq x y. Proof. order. Qed. - Lemma eq_not_lt x y : eq x y -> ~ lt x y. Proof. order. Qed. - Lemma eq_not_gt x y : eq x y -> ~ lt y x. Proof. order. Qed. - Lemma lt_not_gt x y : lt x y -> ~ lt y x. Proof. order. Qed. - - #[global] - Hint Resolve gt_not_eq eq_not_lt : ordered_type. - #[global] - Hint Immediate eq_lt lt_eq le_eq eq_le neq_eq eq_neq : ordered_type. - #[global] - Hint Resolve eq_not_gt lt_antirefl lt_not_gt : ordered_type. - - Lemma elim_compare_eq : - forall x y : t, - eq x y -> exists H : eq x y, compare x y = EQ H. - Proof. - intros x y H; case (compare x y); intros H'; try (exfalso; order). - exists H'; auto. - Qed. - - Lemma elim_compare_lt : - forall x y : t, - lt x y -> exists H : lt x y, compare x y = LT H. - Proof. - intros x y H; case (compare x y); intros H'; try (exfalso; order). - exists H'; auto. - Qed. - - Lemma elim_compare_gt : - forall x y : t, - lt y x -> exists H : lt y x, compare x y = GT H. - Proof. - intros x y H; case (compare x y); intros H'; try (exfalso; order). - exists H'; auto. - Qed. - - Ltac elim_comp := - match goal with - | |- ?e => match e with - | context ctx [ compare ?a ?b ] => - let H := fresh in - (destruct (compare a b) as [H|H|H]; try order) - end - end. - - Ltac elim_comp_eq x y := - elim (elim_compare_eq (x:=x) (y:=y)); - [ intros _1 _2; rewrite _2; clear _1 _2 | auto ]. - - Ltac elim_comp_lt x y := - elim (elim_compare_lt (x:=x) (y:=y)); - [ intros _1 _2; rewrite _2; clear _1 _2 | auto ]. - - Ltac elim_comp_gt x y := - elim (elim_compare_gt (x:=x) (y:=y)); - [ intros _1 _2; rewrite _2; clear _1 _2 | auto ]. - - (** For compatibility reasons *) - Definition eq_dec := eq_dec. - - Lemma lt_dec : forall x y : t, {lt x y} + {~ lt x y}. - Proof. - intros x y; elim (compare x y); [ left | right | right ]; auto with ordered_type. - Defined. - - Definition eqb x y : bool := if eq_dec x y then true else false. - - Lemma eqb_alt : - forall x y, eqb x y = match compare x y with EQ _ => true | _ => false end. - Proof. - unfold eqb; intros x y; destruct (eq_dec x y); elim_comp; auto. - Qed. - -(* Specialization of results about lists modulo. *) - -Section ForNotations. - -Notation In:=(InA eq). -Notation Inf:=(lelistA lt). -Notation Sort:=(sort lt). -Notation NoDup:=(NoDupA eq). - -Lemma In_eq : forall l x y, eq x y -> In x l -> In y l. -Proof. exact (InA_eqA eq_equiv). Qed. - -Lemma ListIn_In : forall l x, List.In x l -> In x l. -Proof. exact (In_InA eq_equiv). Qed. - -Lemma Inf_lt : forall l x y, lt x y -> Inf y l -> Inf x l. -Proof. exact (InfA_ltA lt_strorder). Qed. - -Lemma Inf_eq : forall l x y, eq x y -> Inf y l -> Inf x l. -Proof. exact (InfA_eqA eq_equiv lt_compat). Qed. - -Lemma Sort_Inf_In : forall l x a, Sort l -> Inf a l -> In x l -> lt a x. -Proof. exact (SortA_InfA_InA eq_equiv lt_strorder lt_compat). Qed. - -Lemma ListIn_Inf : forall l x, (forall y, List.In y l -> lt x y) -> Inf x l. -Proof. exact (@In_InfA t lt). Qed. - -Lemma In_Inf : forall l x, (forall y, In y l -> lt x y) -> Inf x l. -Proof. exact (InA_InfA eq_equiv (ltA:=lt)). Qed. - -Lemma Inf_alt : - forall l x, Sort l -> (Inf x l <-> (forall y, In y l -> lt x y)). -Proof. exact (InfA_alt eq_equiv lt_strorder lt_compat). Qed. - -Lemma Sort_NoDup : forall l, Sort l -> NoDup l. -Proof. exact (SortA_NoDupA eq_equiv lt_strorder lt_compat). Qed. - -End ForNotations. - -#[global] -Hint Resolve ListIn_In Sort_NoDup Inf_lt : ordered_type. -#[global] -Hint Immediate In_eq Inf_lt : ordered_type. - -End OrderedTypeFacts. - -Module KeyOrderedType(O:OrderedType). - Import O. - Module MO:=OrderedTypeFacts(O). - Import MO. - - Section Elt. - Variable elt : Type. - Notation key:=t. - - Definition eqk (p p':key*elt) := eq (fst p) (fst p'). - Definition eqke (p p':key*elt) := - eq (fst p) (fst p') /\ (snd p) = (snd p'). - Definition ltk (p p':key*elt) := lt (fst p) (fst p'). - - #[local] - Hint Unfold eqk eqke ltk : ordered_type. - #[local] - Hint Extern 2 (eqke ?a ?b) => split : ordered_type. - - (* eqke is stricter than eqk *) - - Lemma eqke_eqk : forall x x', eqke x x' -> eqk x x'. - Proof. - unfold eqk, eqke; intuition. - Qed. - - (* ltk ignore the second components *) - - Lemma ltk_right_r : forall x k e e', ltk x (k,e) -> ltk x (k,e'). - Proof. auto. Qed. - - Lemma ltk_right_l : forall x k e e', ltk (k,e) x -> ltk (k,e') x. - Proof. auto. Qed. - #[local] - Hint Immediate ltk_right_r ltk_right_l : ordered_type. - - (* eqk, eqke are equalities, ltk is a strict order *) - - Lemma eqk_refl : forall e, eqk e e. - Proof. auto with ordered_type. Qed. - - Lemma eqke_refl : forall e, eqke e e. - Proof. auto with ordered_type. Qed. - - Lemma eqk_sym : forall e e', eqk e e' -> eqk e' e. - Proof. auto with ordered_type. Qed. - - Lemma eqke_sym : forall e e', eqke e e' -> eqke e' e. - Proof. unfold eqke; intuition auto with relations. Qed. - - Lemma eqk_trans : forall e e' e'', eqk e e' -> eqk e' e'' -> eqk e e''. - Proof. eauto with ordered_type. Qed. - - Lemma eqke_trans : forall e e' e'', eqke e e' -> eqke e' e'' -> eqke e e''. - Proof. - unfold eqke; intuition; [ eauto with ordered_type | congruence ]. - Qed. - - Lemma ltk_trans : forall e e' e'', ltk e e' -> ltk e' e'' -> ltk e e''. - Proof. eauto with ordered_type. Qed. - - Lemma ltk_not_eqk : forall e e', ltk e e' -> ~ eqk e e'. - Proof. unfold eqk, ltk; auto with ordered_type. Qed. - - Lemma ltk_not_eqke : forall e e', ltk e e' -> ~eqke e e'. - Proof. - unfold eqke, ltk; intuition; simpl in *; subst. - match goal with H : lt _ _, H1 : eq _ _ |- _ => exact (lt_not_eq H H1) end. - Qed. - - #[local] - Hint Resolve eqk_trans eqke_trans eqk_refl eqke_refl : ordered_type. - #[local] - Hint Resolve ltk_trans ltk_not_eqk ltk_not_eqke : ordered_type. - #[local] - Hint Immediate eqk_sym eqke_sym : ordered_type. - - Global Instance eqk_equiv : Equivalence eqk. - Proof. constructor; eauto with ordered_type. Qed. - - Global Instance eqke_equiv : Equivalence eqke. - Proof. split; eauto with ordered_type. Qed. - - Global Instance ltk_strorder : StrictOrder ltk. - Proof. constructor; eauto with ordered_type. intros x; apply (irreflexivity (x:=fst x)). Qed. - - Global Instance ltk_compat : Proper (eqk==>eqk==>iff) ltk. - Proof. - intros (x,e) (x',e') Hxx' (y,f) (y',f') Hyy'; compute. - compute in Hxx'; compute in Hyy'. rewrite Hxx', Hyy'; auto. - Qed. - - Global Instance ltk_compat' : Proper (eqke==>eqke==>iff) ltk. - Proof. - intros (x,e) (x',e') (Hxx',_) (y,f) (y',f') (Hyy',_); compute. - compute in Hxx'; compute in Hyy'. rewrite Hxx', Hyy'; auto. - Qed. - - (* Additional facts *) - - Lemma eqk_not_ltk : forall x x', eqk x x' -> ~ltk x x'. - Proof. - unfold eqk, ltk; simpl; auto with ordered_type. - Qed. - - Lemma ltk_eqk : forall e e' e'', ltk e e' -> eqk e' e'' -> ltk e e''. - Proof. eauto with ordered_type. Qed. - - Lemma eqk_ltk : forall e e' e'', eqk e e' -> ltk e' e'' -> ltk e e''. - Proof. - intros (k,e) (k',e') (k'',e''). - unfold ltk, eqk; simpl; eauto with ordered_type. - Qed. - #[local] - Hint Resolve eqk_not_ltk : ordered_type. - #[local] - Hint Immediate ltk_eqk eqk_ltk : ordered_type. - - Lemma InA_eqke_eqk : - forall x m, InA eqke x m -> InA eqk x m. - Proof. - unfold eqke; induction 1; intuition. - Qed. - #[local] - Hint Resolve InA_eqke_eqk : ordered_type. - - Definition MapsTo (k:key)(e:elt):= InA eqke (k,e). - Definition In k m := exists e:elt, MapsTo k e m. - Notation Sort := (sort ltk). - Notation Inf := (lelistA ltk). - - #[local] - Hint Unfold MapsTo In : ordered_type. - - (* An alternative formulation for [In k l] is [exists e, InA eqk (k,e) l] *) - - Lemma In_alt : forall k l, In k l <-> exists e, InA eqk (k,e) l. - Proof with auto with ordered_type. - intros k l; split; intros [y H]. - - exists y... - - induction H as [a l eq|a l H IH]. - + destruct a as [k' y']. - exists y'... - + destruct IH as [e H0]. - exists e... - Qed. - - Lemma MapsTo_eq : forall l x y e, eq x y -> MapsTo x e l -> MapsTo y e l. - Proof. - intros l x y e **; unfold MapsTo in *; apply InA_eqA with (x,e); eauto with *. - Qed. - - Lemma In_eq : forall l x y, eq x y -> In x l -> In y l. - Proof. - destruct 2 as (e,E); exists e; eapply MapsTo_eq; eauto. - Qed. - - Lemma Inf_eq : forall l x x', eqk x x' -> Inf x' l -> Inf x l. - Proof. exact (InfA_eqA eqk_equiv ltk_compat). Qed. - - Lemma Inf_lt : forall l x x', ltk x x' -> Inf x' l -> Inf x l. - Proof. exact (InfA_ltA ltk_strorder). Qed. - - #[local] - Hint Immediate Inf_eq : ordered_type. - #[local] - Hint Resolve Inf_lt : ordered_type. - - Lemma Sort_Inf_In : - forall l p q, Sort l -> Inf q l -> InA eqk p l -> ltk q p. - Proof. - exact (SortA_InfA_InA eqk_equiv ltk_strorder ltk_compat). - Qed. - - Lemma Sort_Inf_NotIn : - forall l k e, Sort l -> Inf (k,e) l -> ~In k l. - Proof. - intros l k e H H0; red; intros H1. - destruct H1 as [e' H2]. - elim (@ltk_not_eqk (k,e) (k,e')). - - eapply Sort_Inf_In; eauto with ordered_type. - - red; simpl; auto with ordered_type. - Qed. - - Lemma Sort_NoDupA: forall l, Sort l -> NoDupA eqk l. - Proof. - exact (SortA_NoDupA eqk_equiv ltk_strorder ltk_compat). - Qed. - - Lemma Sort_In_cons_1 : forall e l e', Sort (e::l) -> InA eqk e' l -> ltk e e'. - Proof. - inversion 1; intros; eapply Sort_Inf_In; eauto. - Qed. - - Lemma Sort_In_cons_2 : forall l e e', Sort (e::l) -> InA eqk e' (e::l) -> - ltk e e' \/ eqk e e'. - Proof. - intros l; inversion_clear 2; auto with ordered_type. - left; apply Sort_In_cons_1 with l; auto. - Qed. - - Lemma Sort_In_cons_3 : - forall x l k e, Sort ((k,e)::l) -> In x l -> ~eq x k. - Proof. - inversion_clear 1 as [|? ? H0 H1]; red; intros H H2. - destruct (Sort_Inf_NotIn H0 H1 (In_eq H2 H)). - Qed. - - Lemma In_inv : forall k k' e l, In k ((k',e) :: l) -> eq k k' \/ In k l. - Proof. - inversion 1 as [? H0]. - inversion_clear H0 as [? ? H1|]; eauto with ordered_type. - destruct H1; simpl in *; intuition. - Qed. - - Lemma In_inv_2 : forall k k' e e' l, - InA eqk (k, e) ((k', e') :: l) -> ~ eq k k' -> InA eqk (k, e) l. - Proof. - inversion_clear 1 as [? ? H0|? ? H0]; compute in H0; intuition. - Qed. - - Lemma In_inv_3 : forall x x' l, - InA eqke x (x' :: l) -> ~ eqk x x' -> InA eqke x l. - Proof. - inversion_clear 1 as [? ? H0|? ? H0]; compute in H0; intuition. - Qed. - - End Elt. - - #[global] - Hint Unfold eqk eqke ltk : ordered_type. - #[global] - Hint Extern 2 (eqke ?a ?b) => split : ordered_type. - #[global] - Hint Resolve eqk_trans eqke_trans eqk_refl eqke_refl : ordered_type. - #[global] - Hint Resolve ltk_trans ltk_not_eqk ltk_not_eqke : ordered_type. - #[global] - Hint Immediate eqk_sym eqke_sym : ordered_type. - #[global] - Hint Resolve eqk_not_ltk : ordered_type. - #[global] - Hint Immediate ltk_eqk eqk_ltk : ordered_type. - #[global] - Hint Resolve InA_eqke_eqk : ordered_type. - #[global] - Hint Unfold MapsTo In : ordered_type. - #[global] - Hint Immediate Inf_eq : ordered_type. - #[global] - Hint Resolve Inf_lt : ordered_type. - #[global] - Hint Resolve Sort_Inf_NotIn : ordered_type. - #[global] - Hint Resolve In_inv_2 In_inv_3 : ordered_type. - -End KeyOrderedType. diff --git a/stdlib/theories/Structures/OrderedTypeAlt.v b/stdlib/theories/Structures/OrderedTypeAlt.v deleted file mode 100644 index 84f1eb73ad37..000000000000 --- a/stdlib/theories/Structures/OrderedTypeAlt.v +++ /dev/null @@ -1,120 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* t -> comparison. - - Infix "?=" := compare (at level 70, no associativity). - - Parameter compare_sym : - forall x y, (y?=x) = CompOpp (x?=y). - Parameter compare_trans : - forall c x y z, (x?=y) = c -> (y?=z) = c -> (x?=z) = c. - -End OrderedTypeAlt. - -(** From this new presentation to the original one. *) - -Module OrderedType_from_Alt (O:OrderedTypeAlt) <: OrderedType. - Import O. - - Definition t := t. - - Definition eq x y := (x?=y) = Eq. - Definition lt x y := (x?=y) = Lt. - - Lemma eq_refl : forall x, eq x x. - Proof. - intro x. - unfold eq. - assert (H:=compare_sym x x). - destruct (x ?= x); simpl in *; try discriminate; auto. - Qed. - - Lemma eq_sym : forall x y, eq x y -> eq y x. - Proof. - unfold eq; intros. - rewrite compare_sym. - rewrite H; simpl; auto. - Qed. - - Definition eq_trans := (compare_trans Eq). - - Definition lt_trans := (compare_trans Lt). - - Lemma lt_not_eq : forall x y, lt x y -> ~eq x y. - Proof. - unfold eq, lt; intros. - rewrite H; discriminate. - Qed. - - Definition compare : forall x y, Compare lt eq x y. - Proof. - intros. - case_eq (x ?= y); intros. - - apply EQ; auto. - - apply LT; auto. - - apply GT; red. - rewrite compare_sym; rewrite H; auto. - Defined. - - Definition eq_dec : forall x y, { eq x y } + { ~ eq x y }. - Proof. - intros; unfold eq. - case (x ?= y); [ left | right | right ]; auto; discriminate. - Defined. - -End OrderedType_from_Alt. - -(** From the original presentation to this alternative one. *) - -Module OrderedType_to_Alt (O:OrderedType) <: OrderedTypeAlt. - Import O. - Module MO:=OrderedTypeFacts(O). - Import MO. - - Definition t := t. - - Definition compare x y := match compare x y with - | LT _ => Lt - | EQ _ => Eq - | GT _ => Gt - end. - - Infix "?=" := compare (at level 70, no associativity). - - Lemma compare_sym : - forall x y, (y?=x) = CompOpp (x?=y). - Proof. - intros x y; unfold compare. - destruct O.compare; elim_comp; simpl; auto. - Qed. - - Lemma compare_trans : - forall c x y z, (x?=y) = c -> (y?=z) = c -> (x?=z) = c. - Proof. - intros c x y z. - destruct c; unfold compare; - do 2 (destruct O.compare; intros; try discriminate); - elim_comp; auto. - Qed. - -End OrderedType_to_Alt. diff --git a/stdlib/theories/Structures/OrderedTypeEx.v b/stdlib/theories/Structures/OrderedTypeEx.v deleted file mode 100644 index 7c7143334ac6..000000000000 --- a/stdlib/theories/Structures/OrderedTypeEx.v +++ /dev/null @@ -1,548 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* t -> Prop. - Definition eq_refl := @eq_refl t. - Definition eq_sym := @eq_sym t. - Definition eq_trans := @eq_trans t. - Axiom lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z. - Axiom lt_not_eq : forall x y : t, lt x y -> ~ eq x y. - Parameter compare : forall x y : t, Compare lt eq x y. - Parameter eq_dec : forall x y : t, { eq x y } + { ~ eq x y }. -End UsualOrderedType. - -(** a [UsualOrderedType] is in particular an [OrderedType]. *) - -Module UOT_to_OT (U:UsualOrderedType) <: OrderedType := U. - -(** [nat] is an ordered type with respect to the usual order on natural numbers. *) - -Module Nat_as_OT <: UsualOrderedType. - - Definition t := nat. - - Definition eq := @eq nat. - Definition eq_refl := @eq_refl t. - Definition eq_sym := @eq_sym t. - Definition eq_trans := @eq_trans t. - - Definition lt := lt. - - Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z. - Proof. unfold lt; intros; apply Nat.lt_trans with y; auto. Qed. - - Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y. - Proof. unfold lt, eq; intros ? ? LT ->; revert LT; apply Nat.lt_irrefl. Qed. - - Definition compare x y : Compare lt eq x y. - Proof. - case_eq (Nat.compare x y); intro. - - apply EQ. now apply nat_compare_eq. - - apply LT. now apply nat_compare_Lt_lt. - - apply GT. now apply nat_compare_Gt_gt. - Defined. - - Definition eq_dec := eq_nat_dec. - -End Nat_as_OT. - - -(** [Z] is an ordered type with respect to the usual order on integers. *) - -Local Open Scope Z_scope. - -Module Z_as_OT <: UsualOrderedType. - - Definition t := Z. - Definition eq := @eq Z. - Definition eq_refl := @eq_refl t. - Definition eq_sym := @eq_sym t. - Definition eq_trans := @eq_trans t. - - Definition lt (x y:Z) := (x y x ~ x=y. - Proof. intros x y LT ->; revert LT; apply Z.lt_irrefl. Qed. - - Definition compare x y : Compare lt eq x y. - Proof. - case_eq (x ?= y); intro. - - apply EQ. now apply Z.compare_eq. - - apply LT. assumption. - - apply GT. now apply Z.gt_lt. - Defined. - - Definition eq_dec := Z.eq_dec. - -End Z_as_OT. - -(** [positive] is an ordered type with respect to the usual order on natural numbers. *) - -Local Open Scope positive_scope. - -Module Positive_as_OT <: UsualOrderedType. - Definition t:=positive. - Definition eq:=@eq positive. - Definition eq_refl := @eq_refl t. - Definition eq_sym := @eq_sym t. - Definition eq_trans := @eq_trans t. - - Definition lt := Pos.lt. - - Definition lt_trans := Pos.lt_trans. - - Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y. - Proof. - intros x y H. contradict H. rewrite H. apply Pos.lt_irrefl. - Qed. - - Definition compare x y : Compare lt eq x y. - Proof. - case_eq (x ?= y); intros H. - - apply EQ. now apply Pos.compare_eq. - - apply LT; assumption. - - apply GT. now apply Pos.gt_lt. - Defined. - - Definition eq_dec := Pos.eq_dec. - -End Positive_as_OT. - - -(** [N] is an ordered type with respect to the usual order on natural numbers. *) - -Module N_as_OT <: UsualOrderedType. - Definition t:=N. - Definition eq:=@eq N. - Definition eq_refl := @eq_refl t. - Definition eq_sym := @eq_sym t. - Definition eq_trans := @eq_trans t. - - Definition lt := N.lt. - Definition lt_trans := N.lt_trans. - Definition lt_not_eq := N.lt_neq. - - Definition compare x y : Compare lt eq x y. - Proof. - case_eq (x ?= y)%N; intro. - - apply EQ. now apply N.compare_eq. - - apply LT. assumption. - - apply GT. now apply N.gt_lt. - Defined. - - Definition eq_dec := N.eq_dec. - -End N_as_OT. - - -(** From two ordered types, we can build a new OrderedType - over their cartesian product, using the lexicographic order. *) - -Module PairOrderedType(O1 O2:OrderedType) <: OrderedType. - Module MO1:=OrderedTypeFacts(O1). - Module MO2:=OrderedTypeFacts(O2). - - Definition t := prod O1.t O2.t. - - Definition eq x y := O1.eq (fst x) (fst y) /\ O2.eq (snd x) (snd y). - - Definition lt x y := - O1.lt (fst x) (fst y) \/ - (O1.eq (fst x) (fst y) /\ O2.lt (snd x) (snd y)). - - Lemma eq_refl : forall x : t, eq x x. - Proof. - intros (x1,x2); red; simpl; auto with ordered_type. - Qed. - - Lemma eq_sym : forall x y : t, eq x y -> eq y x. - Proof. - intros (x1,x2) (y1,y2); unfold eq; simpl; intuition auto with relations. - Qed. - - Lemma eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z. - Proof. - intros (x1,x2) (y1,y2) (z1,z2); unfold eq; simpl; intuition eauto with ordered_type. - Qed. - - Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z. - Proof. - intros (x1,x2) (y1,y2) (z1,z2); unfold eq, lt; simpl; intuition. - - left; eauto with ordered_type. - - left; eapply MO1.lt_eq; eauto. - - left; eapply MO1.eq_lt; eauto. - - right; split; eauto with ordered_type. - Qed. - - Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y. - Proof. - intros (x1,x2) (y1,y2); unfold eq, lt; simpl; intuition. - - apply (O1.lt_not_eq H0 H1). - - apply (O2.lt_not_eq H3 H2). - Qed. - - Definition compare : forall x y : t, Compare lt eq x y. - intros (x1,x2) (y1,y2). - destruct (O1.compare x1 y1). - - apply LT; unfold lt; auto. - - destruct (O2.compare x2 y2). - + apply LT; unfold lt; auto. - + apply EQ; unfold eq; auto. - + apply GT; unfold lt; auto with ordered_type. - - apply GT; unfold lt; auto. - Defined. - - Definition eq_dec : forall x y : t, {eq x y} + {~ eq x y}. - Proof. - intros; elim (compare x y); intro H; [ right | left | right ]; auto. - - auto using lt_not_eq. - - assert (~ eq y x); auto using lt_not_eq, eq_sym. - Defined. - -End PairOrderedType. - - -(** Even if [positive] can be seen as an ordered type with respect to the - usual order (see above), we can also use a lexicographic order over bits - (lower bits are considered first). This is more natural when using - [positive] as indexes for sets or maps (see FSetPositive and FMapPositive. *) - -Module PositiveOrderedTypeBits <: UsualOrderedType. - Definition t:=positive. - Definition eq:=@eq positive. - Definition eq_refl := @eq_refl t. - Definition eq_sym := @eq_sym t. - Definition eq_trans := @eq_trans t. - - Fixpoint bits_lt (p q:positive) : Prop := - match p, q with - | xH, xI _ => True - | xH, _ => False - | xO p, xO q => bits_lt p q - | xO _, _ => True - | xI p, xI q => bits_lt p q - | xI _, _ => False - end. - - Definition lt:=bits_lt. - - Lemma bits_lt_trans : - forall x y z : positive, bits_lt x y -> bits_lt y z -> bits_lt x z. - Proof. - induction x. - - induction y; destruct z; simpl; eauto; intuition. - - induction y; destruct z; simpl; eauto; intuition. - - induction y; destruct z; simpl; eauto; intuition. - Qed. - - Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z. - Proof. - exact bits_lt_trans. - Qed. - - Lemma bits_lt_antirefl : forall x : positive, ~ bits_lt x x. - Proof. - induction x; simpl; auto. - Qed. - - Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y. - Proof. - intros; intro. - rewrite <- H0 in H; clear H0 y. - unfold lt in H. - exact (bits_lt_antirefl x H). - Qed. - - Definition compare : forall x y : t, Compare lt eq x y. - Proof. - induction x; destruct y. - + (* I I *) - destruct (IHx y) as [l|e|g]. - * apply LT; auto. - * apply EQ; rewrite e; red; auto. - * apply GT; auto. - + (* I O *) - apply GT; simpl; auto. - + (* I H *) - apply GT; simpl; auto. - + (* O I *) - apply LT; simpl; auto. - + (* O O *) - destruct (IHx y) as [l|e|g]. - * apply LT; auto. - * apply EQ; rewrite e; red; auto. - * apply GT; auto. - + (* O H *) - apply LT; simpl; auto. - + (* H I *) - apply LT; simpl; auto. - + (* H O *) - apply GT; simpl; auto. - + (* H H *) - apply EQ; red; auto. - Qed. - - Lemma eq_dec (x y: positive): {x = y} + {x <> y}. - Proof. - intros. case_eq (x ?= y); intros. - - left. now apply Pos.compare_eq. - - right. intro. subst y. now rewrite (Pos.compare_refl x) in *. - - right. intro. subst y. now rewrite (Pos.compare_refl x) in *. - Qed. - -End PositiveOrderedTypeBits. - -Module Ascii_as_OT <: UsualOrderedType. - Definition t := ascii. - - Definition eq := @eq ascii. - Definition eq_refl := @eq_refl t. - Definition eq_sym := @eq_sym t. - Definition eq_trans := @eq_trans t. - - Definition cmp : ascii -> ascii -> comparison := Ascii.compare. - - Lemma cmp_eq (a b : ascii): - cmp a b = Eq <-> a = b. - Proof. - unfold cmp, Ascii.compare. - rewrite N.compare_eq_iff. - split. 2:{ intro. now subst. } - intro H. - rewrite<- (ascii_N_embedding a). - rewrite<- (ascii_N_embedding b). - now rewrite H. - Qed. - - Lemma cmp_lt_nat (a b : ascii): - cmp a b = Lt <-> (nat_of_ascii a < nat_of_ascii b)%nat. - Proof. - unfold cmp. unfold nat_of_ascii, Ascii.compare. - rewrite N2Nat.inj_compare. - rewrite Nat.compare_lt_iff. - reflexivity. - Qed. - - Lemma cmp_antisym (a b : ascii): - cmp a b = CompOpp (cmp b a). - Proof. - unfold cmp. - apply N.compare_antisym. - Qed. - - Definition lt (x y : ascii) := (N_of_ascii x < N_of_ascii y)%N. - - Lemma lt_trans (x y z : ascii): - lt x y -> lt y z -> lt x z. - Proof. - apply N.lt_trans. - Qed. - - Lemma lt_not_eq (x y : ascii): - lt x y -> x <> y. - Proof. - intros L H. subst. - exact (N.lt_irrefl _ L). - Qed. - - Local Lemma compare_helper_eq {a b : ascii} (E : cmp a b = Eq): - a = b. - Proof. - now apply cmp_eq. - Qed. - - Local Lemma compare_helper_gt {a b : ascii} (G : cmp a b = Gt): - lt b a. - Proof. - now apply N.compare_gt_iff. - Qed. - - Definition compare (a b : ascii) : Compare lt eq a b := - match cmp a b as z return _ = z -> _ with - | Lt => fun E => LT E - | Gt => fun E => GT (compare_helper_gt E) - | Eq => fun E => EQ (compare_helper_eq E) - end Logic.eq_refl. - - Definition eq_dec (x y : ascii): {x = y} + { ~ (x = y)} := ascii_dec x y. -End Ascii_as_OT. - -(** [String] is an ordered type with respect to the usual lexical order. *) - -Module String_as_OT <: UsualOrderedType. - - Definition t := string. - - Definition eq := @eq string. - Definition eq_refl := @eq_refl t. - Definition eq_sym := @eq_sym t. - Definition eq_trans := @eq_trans t. - - Inductive lts : string -> string -> Prop := - | lts_empty : forall a s, lts EmptyString (String a s) - | lts_tail : forall a s1 s2, lts s1 s2 -> lts (String a s1) (String a s2) - | lts_head : forall (a b : ascii) s1 s2, - lt (nat_of_ascii a) (nat_of_ascii b) -> - lts (String a s1) (String b s2). - - Definition lt := lts. - - Lemma nat_of_ascii_inverse a b : nat_of_ascii a = nat_of_ascii b -> a = b. - Proof. - intro H. - rewrite <- (ascii_nat_embedding a). - rewrite <- (ascii_nat_embedding b). - apply f_equal; auto. - Qed. - - Lemma lts_tail_unique a s1 s2 : lt (String a s1) (String a s2) -> - lt s1 s2. - Proof. - intro H; inversion H; subst; auto. - remember (nat_of_ascii a) as x. - apply Nat.lt_irrefl in H1; inversion H1. - Qed. - - Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z. - Proof. - induction x; intros y z H1 H2. - - destruct y as [| b y']; inversion H1. - destruct z as [| c z']; inversion H2; constructor. - - destruct y as [| b y']; inversion H1; subst; - destruct z as [| c z']; inversion H2; subst. - + constructor. eapply IHx; eauto. - + constructor; assumption. - + constructor; assumption. - + constructor. eapply Nat.lt_trans; eassumption. - Qed. - - Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y. - Proof. - induction x; intros y LT. - - inversion LT. intro. inversion H. - - inversion LT; subst; intros EQ. - * specialize (IHx s2 H2). - inversion EQ; subst; auto. - apply IHx; unfold eq; auto. - * inversion EQ; subst; auto. - apply Nat.lt_irrefl in H2; auto. - Qed. - - Definition cmp : string -> string -> comparison := String.compare. - - Lemma cmp_eq (a b : string): - cmp a b = Eq <-> a = b. - Proof. - revert b. - induction a, b; try easy. - cbn. - remember (Ascii.compare _ _) as c eqn:Heqc. symmetry in Heqc. - destruct c; split; try discriminate; - try rewrite Ascii_as_OT.cmp_eq in Heqc; try subst; - try rewrite IHa; intro H. - { now subst. } - { now inversion H. } - { inversion H; subst. rewrite<- Heqc. now rewrite Ascii_as_OT.cmp_eq. } - { inversion H; subst. rewrite<- Heqc. now rewrite Ascii_as_OT.cmp_eq. } - Qed. - - Lemma cmp_antisym (a b : string): - cmp a b = CompOpp (cmp b a). - Proof. - revert b. - induction a, b; try easy. - cbn. rewrite IHa. clear IHa. - remember (Ascii.compare _ _) as c eqn:Heqc. symmetry in Heqc. - destruct c; rewrite Ascii_as_OT.cmp_antisym in Heqc; - destruct Ascii_as_OT.cmp; cbn in *; easy. - Qed. - - Lemma cmp_lt (a b : string): - cmp a b = Lt <-> lt a b. - Proof. - revert b. - induction a as [ | a_head a_tail ], b; try easy; cbn. - { split; trivial. intro. apply lts_empty. } - remember (Ascii.compare _ _) as c eqn:Heqc. symmetry in Heqc. - destruct c; split; intro H; try discriminate; trivial. - { - rewrite Ascii_as_OT.cmp_eq in Heqc. subst. - apply String_as_OT.lts_tail. - apply IHa_tail. - assumption. - } - { - rewrite Ascii_as_OT.cmp_eq in Heqc. subst. - inversion H; subst. { rewrite IHa_tail. assumption. } - exfalso. apply (Nat.lt_irrefl (nat_of_ascii a)). assumption. - } - { - apply String_as_OT.lts_head. - rewrite<- Ascii_as_OT.cmp_lt_nat. - assumption. - } - { - exfalso. inversion H; subst. - { - assert(X: Ascii.compare a a = Eq). { apply Ascii_as_OT.cmp_eq. trivial. } - rewrite Heqc in X. discriminate. - } - rewrite<- Ascii_as_OT.cmp_lt_nat in *. - unfold Ascii_as_OT.cmp in *. - rewrite Heqc in *. discriminate. - } - Qed. - - Local Lemma compare_helper_lt {a b : string} (L : cmp a b = Lt): - lt a b. - Proof. - now apply cmp_lt. - Qed. - - Local Lemma compare_helper_gt {a b : string} (G : cmp a b = Gt): - lt b a. - Proof. - rewrite cmp_antisym in G. - rewrite CompOpp_iff in G. - now apply cmp_lt. - Qed. - - Local Lemma compare_helper_eq {a b : string} (E : cmp a b = Eq): - a = b. - Proof. - now apply cmp_eq. - Qed. - - Definition compare (a b : string) : Compare lt eq a b := - match cmp a b as z return _ = z -> _ with - | Lt => fun E => LT (compare_helper_lt E) - | Gt => fun E => GT (compare_helper_gt E) - | Eq => fun E => EQ (compare_helper_eq E) - end Logic.eq_refl. - - Definition eq_dec (x y : string): {x = y} + { ~ (x = y)} := string_dec x y. -End String_as_OT. diff --git a/stdlib/theories/Structures/Orders.v b/stdlib/theories/Structures/Orders.v deleted file mode 100644 index 6f0a7d3295de..000000000000 --- a/stdlib/theories/Structures/Orders.v +++ /dev/null @@ -1,368 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* t -> Prop. -End HasLt. - -Module Type HasLe (Import T:Typ). - Parameter Inline(40) le : t -> t -> Prop. -End HasLe. - -Module Type EqLt := Typ <+ HasEq <+ HasLt. -Module Type EqLe := Typ <+ HasEq <+ HasLe. -Module Type EqLtLe := Typ <+ HasEq <+ HasLt <+ HasLe. - -(** Versions with nice notations *) - -Module Type LtNotation (E:EqLt). - Infix "<" := E.lt. - Notation "x > y" := (y= y" := (y<=x) (only parsing). - Notation "x <= y <= z" := (x<=y /\ y<=z). -End LeNotation. - -Module Type LtLeNotation (E:EqLtLe). - Include LtNotation E <+ LeNotation E. - Notation "x <= y < z" := (x<=y /\ yeq==>iff) lt. -End IsStrOrder. - -Module Type LeIsLtEq (Import E:EqLtLe'). - Axiom le_lteq : forall x y, x<=y <-> x t -> comparison. -End HasCmp. - -Module Type CmpNotation (T:Typ)(C:HasCmp T). - Infix "?=" := C.compare (at level 70, no associativity). -End CmpNotation. - -Module Type CmpSpec (Import E:EqLt')(Import C:HasCmp E). - Axiom compare_spec : forall x y, CompareSpec (x==y) (x true | _ => false end. - - Lemma eqb_eq : forall x y, eqb x y = true <-> x==y. - Proof. - unfold eqb. intros x y. - destruct (compare_spec x y) as [H|H|H]; split; auto; try discriminate. - - intros EQ; rewrite EQ in H; elim (StrictOrder_Irreflexive _ H). - - intros EQ; rewrite EQ in H; elim (StrictOrder_Irreflexive _ H). - Qed. - -End Compare2EqBool. - -Module DSO_to_OT (O:DecStrOrder) <: OrderedType := - O <+ Compare2EqBool <+ HasEqBool2Dec. - -(** From [OrderedType] To [OrderedTypeFull] (adding [<=]) *) - -Module OT_to_Full (O:OrderedType') <: OrderedTypeFull. - Include O. - Definition le x y := x x-> Sortclass. -#[global] -Hint Unfold is_true : core. - -Module Type HasLeb (Import T:Typ). - Parameter Inline leb : t -> t -> bool. -End HasLeb. - -Module Type HasLtb (Import T:Typ). - Parameter Inline ltb : t -> t -> bool. -End HasLtb. - -Module Type LebNotation (T:Typ)(E:HasLeb T). - Infix "<=?" := E.leb (at level 70, no associativity). -End LebNotation. - -Module Type LtbNotation (T:Typ)(E:HasLtb T). - Infix " X.le x y. -End LebSpec. - -Module Type LtbSpec (T:Typ)(X:HasLt T)(Y:HasLtb T). - Parameter ltb_lt : forall x y, Y.ltb x y = true <-> X.lt x y. -End LtbSpec. - -Module Type LeBool := Typ <+ HasLeb. -Module Type LtBool := Typ <+ HasLtb. -Module Type LeBool' := LeBool <+ LebNotation. -Module Type LtBool' := LtBool <+ LtbNotation. - -Module Type LebIsTotal (Import X:LeBool'). - Axiom leb_total : forall x y, (x <=? y) = true \/ (y <=? x) = true. -End LebIsTotal. - -Module Type TotalLeBool := LeBool <+ LebIsTotal. -Module Type TotalLeBool' := LeBool' <+ LebIsTotal. - -Module Type LebIsTransitive (Import X:LeBool'). - Axiom leb_trans : Transitive X.leb. -End LebIsTransitive. - -Module Type TotalTransitiveLeBool := TotalLeBool <+ LebIsTransitive. -Module Type TotalTransitiveLeBool' := TotalLeBool' <+ LebIsTransitive. - -(** Grouping all boolean comparison functions *) - -Module Type HasBoolOrdFuns (T:Typ) := HasEqb T <+ HasLtb T <+ HasLeb T. - -Module Type HasBoolOrdFuns' (T:Typ) := - HasBoolOrdFuns T <+ EqbNotation T <+ LtbNotation T <+ LebNotation T. - -Module Type BoolOrdSpecs (O:EqLtLe)(F:HasBoolOrdFuns O) := - EqbSpec O O F <+ LtbSpec O O F <+ LebSpec O O F. - -Module Type OrderFunctions (E:EqLtLe) := - HasCompare E <+ HasBoolOrdFuns E <+ BoolOrdSpecs E. -Module Type OrderFunctions' (E:EqLtLe) := - HasCompare E <+ CmpNotation E <+ HasBoolOrdFuns' E <+ BoolOrdSpecs E. - -(** * From [OrderedTypeFull] to [TotalTransitiveLeBool] *) - -Module OTF_to_TTLB (Import O : OrderedTypeFull') <: TotalTransitiveLeBool. - - Definition leb x y := - match compare x y with Gt => false | _ => true end. - - Lemma leb_le : forall x y, leb x y <-> x <= y. - Proof. - intros x y. unfold leb. rewrite le_lteq. - destruct (compare_spec x y) as [EQ|LT|GT]; split; auto. - - discriminate. - - intros LE. elim (StrictOrder_Irreflexive x). - destruct LE as [LT|EQ]. - + now transitivity y. - + now rewrite <- EQ in GT. - Qed. - - Lemma leb_total : forall x y, leb x y \/ leb y x. - Proof. - intros x y. rewrite 2 leb_le. rewrite 2 le_lteq. - destruct (compare_spec x y); intuition. - Qed. - - Lemma leb_trans : Transitive leb. - Proof. - intros x y z. rewrite !leb_le, !le_lteq. - intros [Hxy|Hxy] [Hyz|Hyz]. - - left; transitivity y; auto. - - left; rewrite <- Hyz; auto. - - left; rewrite Hxy; auto. - - right; transitivity y; auto. - Qed. - - Definition t := t. - -End OTF_to_TTLB. - - -(** * From [TotalTransitiveLeBool] to [OrderedTypeFull] - - [le] is [leb ... = true]. - [eq] is [le /\ swap le]. - [lt] is [le /\ ~swap le]. -*) - -Local Open Scope bool_scope. - -Module TTLB_to_OTF (Import O : TotalTransitiveLeBool') <: OrderedTypeFull. - - Definition t := t. - - Definition le x y : Prop := x <=? y. - Definition eq x y : Prop := le x y /\ le y x. - Definition lt x y : Prop := le x y /\ ~le y x. - - Definition compare x y := - if x <=? y then (if y <=? x then Eq else Lt) else Gt. - - Lemma compare_spec : forall x y, CompSpec eq lt x y (compare x y). - Proof. - intros x y. unfold compare. - case_eq (x <=? y). - - case_eq (y <=? x). - + constructor. split; auto. - + constructor. split; congruence. - - constructor. destruct (leb_total x y); split; congruence. - Qed. - - Definition eqb x y := (x <=? y) && (y <=? x). - - Lemma eqb_eq : forall x y, eqb x y <-> eq x y. - Proof. - intros. unfold eq, eqb, le. - case leb; simpl; intuition auto; discriminate. - Qed. - - Include HasEqBool2Dec. - -#[global] - Instance eq_equiv : Equivalence eq. - Proof. - split. - - intros x; unfold eq, le. destruct (leb_total x x); auto. - - intros x y; unfold eq, le. intuition. - - intros x y z; unfold eq, le. intuition; apply leb_trans with y; auto. - Qed. - -#[global] - Instance lt_strorder : StrictOrder lt. - Proof. - split. - - intros x. unfold lt; red; intuition. - - intros x y z; unfold lt, le. intuition. - + apply leb_trans with y; auto. - + absurd (z <=? y); auto. - apply leb_trans with x; auto. - Qed. - -#[global] - Instance lt_compat : Proper (eq ==> eq ==> iff) lt. - Proof. - apply proper_sym_impl_iff_2; auto with *. - intros x x' Hx y y' Hy' H. unfold eq, lt, le in *. - intuition. - - apply leb_trans with x; auto. - apply leb_trans with y; auto. - - absurd (y <=? x); auto. - apply leb_trans with x'; auto. - apply leb_trans with y'; auto. - Qed. - - Lemma le_lteq : forall x y, le x y <-> lt x y \/ eq x y. - Proof. - intros x y. - unfold lt, eq, le. - split; [ | intuition ]. - intros LE. - case_eq (y <=? x); [right|left]; intuition auto; discriminate. - Qed. - -End TTLB_to_OTF. diff --git a/stdlib/theories/Structures/OrdersAlt.v b/stdlib/theories/Structures/OrdersAlt.v deleted file mode 100644 index a2d0fc972ad1..000000000000 --- a/stdlib/theories/Structures/OrdersAlt.v +++ /dev/null @@ -1,248 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* t -> comparison. - - Infix "?=" := compare (at level 70, no associativity). - - Parameter compare_sym : - forall x y, (y?=x) = CompOpp (x?=y). - Parameter compare_trans : - forall c x y z, (x?=y) = c -> (y?=z) = c -> (x?=z) = c. - -End OrderedTypeAlt. - -(** ** From OrderedTypeOrig to OrderedType. *) - -Module Update_OT (O:OrderedTypeOrig) <: OrderedType. - - Include Update_DT O. (* Provides : t eq eq_equiv eq_dec *) - - Definition lt := O.lt. - -#[global] - Instance lt_strorder : StrictOrder lt. - Proof. - split. - - intros x Hx. apply (O.lt_not_eq Hx); auto with *. - - exact O.lt_trans. - Qed. - -#[global] - Instance lt_compat : Proper (eq==>eq==>iff) lt. - Proof. - apply proper_sym_impl_iff_2; auto with *. - intros x x' Hx y y' Hy H. - assert (H0 : lt x' y). { - destruct (O.compare x' y) as [H'|H'|H']; auto. - - elim (O.lt_not_eq H). transitivity x'; auto with *. - - elim (O.lt_not_eq (O.lt_trans H H')); auto. - } - destruct (O.compare x' y') as [H'|H'|H']; auto. - - elim (O.lt_not_eq H). - transitivity x'; auto with *. transitivity y'; auto with *. - - elim (O.lt_not_eq (O.lt_trans H' H0)); auto with *. - Qed. - - Definition compare x y := - match O.compare x y with - | EQ _ => Eq - | LT _ => Lt - | GT _ => Gt - end. - - Lemma compare_spec : forall x y, CompSpec eq lt x y (compare x y). - Proof. - intros; unfold compare; destruct O.compare; auto. - Qed. - -End Update_OT. - -(** ** From OrderedType to OrderedTypeOrig. *) - -Module Backport_OT (O:OrderedType) <: OrderedTypeOrig. - - Include Backport_DT O. (* Provides : t eq eq_refl eq_sym eq_trans eq_dec *) - - Definition lt := O.lt. - - Lemma lt_not_eq : forall x y, lt x y -> ~eq x y. - Proof. - intros x y L E; rewrite E in L. apply (StrictOrder_Irreflexive y); auto. - Qed. - - Lemma lt_trans : Transitive lt. - Proof. apply O.lt_strorder. Qed. - - Definition compare : forall x y, Compare lt eq x y. - Proof. - intros x y; destruct (CompSpec2Type (O.compare_spec x y)); - [apply EQ|apply LT|apply GT]; auto. - Defined. - -End Backport_OT. - - -(** ** From OrderedTypeAlt to OrderedType. *) - -Module OT_from_Alt (Import O:OrderedTypeAlt) <: OrderedType. - - Definition t := t. - - Definition eq x y := (x?=y) = Eq. - Definition lt x y := (x?=y) = Lt. - -#[global] - Instance eq_equiv : Equivalence eq. - Proof. - split; red. - - (* refl *) - unfold eq; intros x. - assert (H:=compare_sym x x). - destruct (x ?= x); simpl in *; auto; discriminate. - - (* sym *) - unfold eq; intros x y H. - rewrite compare_sym, H; simpl; auto. - - (* trans *) - apply compare_trans. - Qed. - -#[global] - Instance lt_strorder : StrictOrder lt. - Proof. - split; repeat red; unfold lt; try apply compare_trans. - intros x H. - assert (eq x x) by reflexivity. - unfold eq in *; congruence. - Qed. - - Lemma lt_eq : forall x y z, lt x y -> eq y z -> lt x z. - Proof. - unfold lt, eq; intros x y z Hxy Hyz. - destruct (compare x z) eqn:Hxz; auto. - - rewrite compare_sym, CompOpp_iff in Hyz. simpl in Hyz. - rewrite (compare_trans Hxz Hyz) in Hxy; discriminate. - - rewrite compare_sym, CompOpp_iff in Hxy. simpl in Hxy. - rewrite (compare_trans Hxy Hxz) in Hyz; discriminate. - Qed. - - Lemma eq_lt : forall x y z, eq x y -> lt y z -> lt x z. - Proof. - unfold lt, eq; intros x y z Hxy Hyz. - destruct (compare x z) eqn:Hxz; auto. - - rewrite compare_sym, CompOpp_iff in Hxy. simpl in Hxy. - rewrite (compare_trans Hxy Hxz) in Hyz; discriminate. - - rewrite compare_sym, CompOpp_iff in Hyz. simpl in Hyz. - rewrite (compare_trans Hxz Hyz) in Hxy; discriminate. - Qed. - -#[global] - Instance lt_compat : Proper (eq==>eq==>iff) lt. - Proof. - apply proper_sym_impl_iff_2; auto with *. - repeat red; intros. - eapply lt_eq; eauto. eapply eq_lt; eauto. symmetry; auto. - Qed. - - Definition compare := O.compare. - - Lemma compare_spec : forall x y, CompSpec eq lt x y (compare x y). - Proof. - unfold eq, lt, compare; intros. - destruct (O.compare x y) eqn:H; auto. - apply CompGt. - rewrite compare_sym, H; auto. - Qed. - - Definition eq_dec : forall x y, { eq x y } + { ~ eq x y }. - Proof. - intros; unfold eq. - case (x ?= y); [ left | right | right ]; auto; discriminate. - Defined. - -End OT_from_Alt. - -(** From the original presentation to this alternative one. *) - -Module OT_to_Alt (Import O:OrderedType) <: OrderedTypeAlt. - - Definition t := t. - Definition compare := compare. - - Infix "?=" := compare (at level 70, no associativity). - - Lemma compare_sym : - forall x y, (y?=x) = CompOpp (x?=y). - Proof. - intros x y; unfold compare. - destruct (compare_spec x y) as [U|U|U]; - destruct (compare_spec y x) as [V|V|V]; auto. - - rewrite U in V. elim (StrictOrder_Irreflexive y); auto. - - rewrite U in V. elim (StrictOrder_Irreflexive y); auto. - - rewrite V in U. elim (StrictOrder_Irreflexive x); auto. - - rewrite V in U. elim (StrictOrder_Irreflexive x); auto. - - rewrite V in U. elim (StrictOrder_Irreflexive x); auto. - - rewrite V in U. elim (StrictOrder_Irreflexive y); auto. - Qed. - - Lemma compare_Eq : forall x y, compare x y = Eq <-> eq x y. - Proof. - unfold compare. - intros x y; destruct (compare_spec x y); intuition; - try discriminate. - - rewrite H0 in H. elim (StrictOrder_Irreflexive y); auto. - - rewrite H0 in H. elim (StrictOrder_Irreflexive y); auto. - Qed. - - Lemma compare_Lt : forall x y, compare x y = Lt <-> lt x y. - Proof. - unfold compare. - intros x y; destruct (compare_spec x y); intuition; - try discriminate. - - rewrite H in H0. elim (StrictOrder_Irreflexive y); auto. - - rewrite H in H0. elim (StrictOrder_Irreflexive x); auto. - Qed. - - Lemma compare_Gt : forall x y, compare x y = Gt <-> lt y x. - Proof. - intros x y. rewrite compare_sym, CompOpp_iff. apply compare_Lt. - Qed. - - Lemma compare_trans : - forall c x y z, (x?=y) = c -> (y?=z) = c -> (x?=z) = c. - Proof. - intros c x y z. - destruct c; unfold compare; - rewrite ?compare_Eq, ?compare_Lt, ?compare_Gt; - transitivity y; auto. - Qed. - -End OT_to_Alt. diff --git a/stdlib/theories/Structures/OrdersEx.v b/stdlib/theories/Structures/OrdersEx.v deleted file mode 100644 index bbd2b13faed9..000000000000 --- a/stdlib/theories/Structures/OrdersEx.v +++ /dev/null @@ -1,251 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* eq==>iff) lt. - Proof. - compute. - intros (x1,x2) (x1',x2') (X1,X2) (y1,y2) (y1',y2') (Y1,Y2). - rewrite X1,X2,Y1,Y2; intuition. - Qed. - - Definition compare x y := - match O1.compare (fst x) (fst y) with - | Eq => O2.compare (snd x) (snd y) - | Lt => Lt - | Gt => Gt - end. - - Lemma compare_spec : forall x y, CompSpec eq lt x y (compare x y). - Proof. - intros (x1,x2) (y1,y2); unfold compare; simpl. - destruct (O1.compare_spec x1 y1); try (constructor; compute; auto). - destruct (O2.compare_spec x2 y2); constructor; compute; auto with relations. - Qed. - -End PairOrderedType. - -(** Even if [positive] can be seen as an ordered type with respect to the - usual order (see above), we can also use a lexicographic order over bits - (lower bits are considered first). This is more natural when using - [positive] as indexes for sets or maps (see MSetPositive). *) - -Local Open Scope positive. - -Module PositiveOrderedTypeBits <: UsualOrderedType. - Definition t:=positive. - Include HasUsualEq <+ UsualIsEq. - Definition eqb := Pos.eqb. - Definition eqb_eq := Pos.eqb_eq. - Include HasEqBool2Dec. - - Fixpoint bits_lt (p q:positive) : Prop := - match p, q with - | xH, xI _ => True - | xH, _ => False - | xO p, xO q => bits_lt p q - | xO _, _ => True - | xI p, xI q => bits_lt p q - | xI _, _ => False - end. - - Definition lt:=bits_lt. - - Lemma bits_lt_antirefl : forall x : positive, ~ bits_lt x x. - Proof. - induction x; simpl; auto. - Qed. - - Lemma bits_lt_trans : - forall x y z : positive, bits_lt x y -> bits_lt y z -> bits_lt x z. - Proof. - induction x; destruct y,z; simpl; eauto; intuition. - Qed. - -#[global] - Instance lt_compat : Proper (eq==>eq==>iff) lt. - Proof. - intros x x' Hx y y' Hy. rewrite Hx, Hy; intuition. - Qed. - -#[global] - Instance lt_strorder : StrictOrder lt. - Proof. - split; [ exact bits_lt_antirefl | exact bits_lt_trans ]. - Qed. - - Fixpoint compare x y := - match x, y with - | x~1, y~1 => compare x y - | _~1, _ => Gt - | x~0, y~0 => compare x y - | _~0, _ => Lt - | 1, _~1 => Lt - | 1, 1 => Eq - | 1, _~0 => Gt - end. - - Lemma compare_spec : forall x y, CompSpec eq lt x y (compare x y). - Proof. - unfold eq, lt. - induction x; destruct y; try constructor; simpl; auto. - - destruct (IHx y); subst; auto. - - destruct (IHx y); subst; auto. - Qed. - -End PositiveOrderedTypeBits. - -Module Ascii_as_OT <: UsualOrderedType. - Definition t := ascii. - Include HasUsualEq <+ UsualIsEq. - Definition eqb := Ascii.eqb. - Definition eqb_eq := Ascii.eqb_eq. - Include HasEqBool2Dec. - - Definition compare (a b : ascii) := N_as_OT.compare (N_of_ascii a) (N_of_ascii b). - Definition lt (a b : ascii) := N_as_OT.lt (N_of_ascii a) (N_of_ascii b). - -#[global] - Instance lt_compat : Proper (eq==>eq==>iff) lt. - Proof. - intros x x' Hx y y' Hy. rewrite Hx, Hy; intuition. - Qed. - -#[global] - Instance lt_strorder : StrictOrder lt. - Proof. - split; unfold lt; [ intro | intros ??? ]; eapply N_as_OT.lt_strorder. - Qed. - - Lemma compare_spec : forall x y, CompSpec eq lt x y (compare x y). - Proof. - intros x y; unfold eq, lt, compare. - destruct (N_as_OT.compare_spec (N_of_ascii x) (N_of_ascii y)) as [H|H|H]; constructor; try assumption. - now rewrite <- (ascii_N_embedding x), <- (ascii_N_embedding y), H. - Qed. -End Ascii_as_OT. - -(** [String] is an ordered type with respect to the usual lexical order. *) - -Module String_as_OT <: UsualOrderedType. - Definition t := string. - Include HasUsualEq <+ UsualIsEq. - Definition eqb := String.eqb. - Definition eqb_eq := String.eqb_eq. - Include HasEqBool2Dec. - - Fixpoint compare (a b : string) - := match a, b with - | EmptyString, EmptyString => Eq - | EmptyString, _ => Lt - | String _ _, EmptyString => Gt - | String a_head a_tail, String b_head b_tail => - match Ascii_as_OT.compare a_head b_head with - | Lt => Lt - | Gt => Gt - | Eq => compare a_tail b_tail - end - end. - - Definition lt (a b : string) := compare a b = Lt. - -#[global] - Instance lt_compat : Proper (eq==>eq==>iff) lt. - Proof. - intros x x' Hx y y' Hy. rewrite Hx, Hy; intuition. - Qed. - - Lemma compare_spec : forall x y, CompSpec eq lt x y (compare x y). - Proof. - unfold eq, lt. - induction x as [|x xs IHxs], y as [|y ys]; cbn [compare]; try constructor; cbn [compare]; try reflexivity. - specialize (IHxs ys). - destruct (Ascii_as_OT.compare x y) eqn:H; [ destruct IHxs; constructor | constructor | constructor ]; cbn [compare]. - all: destruct (Ascii_as_OT.compare_spec y x), (Ascii_as_OT.compare_spec x y); cbv [Ascii_as_OT.eq] in *; try congruence; subst. - all: exfalso; eapply irreflexivity; (idtac + etransitivity); eassumption. - Qed. - -#[global] - Instance lt_strorder : StrictOrder lt. - Proof. - split; unfold lt; [ intro x | intros x y z ]; unfold complement. - { induction x as [|x xs IHxs]; cbn [compare]; [ congruence | ]. - destruct (Ascii_as_OT.compare x x) eqn:H; try congruence. - exfalso; eapply irreflexivity; eassumption. } - { revert x y z. - induction x as [|x xs IHxs], y as [|y ys], z as [|z zs]; cbn [compare]; try congruence. - specialize (IHxs ys zs). - destruct (Ascii_as_OT.compare x y) eqn:Hxy, (Ascii_as_OT.compare y z) eqn:Hyz, (Ascii_as_OT.compare x z) eqn:Hxz; - try intuition (congruence || eauto). - all: destruct (Ascii_as_OT.compare_spec x y), (Ascii_as_OT.compare_spec y z), (Ascii_as_OT.compare_spec x z); - try discriminate. - all: unfold Ascii_as_OT.eq in *; subst. - all: exfalso; eapply irreflexivity; (idtac + etransitivity); (idtac + etransitivity); eassumption. } - Qed. -End String_as_OT. diff --git a/stdlib/theories/Structures/OrdersFacts.v b/stdlib/theories/Structures/OrdersFacts.v deleted file mode 100644 index 0930a8d0c1c9..000000000000 --- a/stdlib/theories/Structures/OrdersFacts.v +++ /dev/null @@ -1,466 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* y==x := Equivalence_Symmetric x y. - - Definition eq_trans (x y z:t) : x==y -> y==z -> x==z := - Equivalence_Transitive x y z. - - Definition lt_trans (x y z:t) : x y x b | _ => b' end). - Proof. - destruct eq_dec; elim_compare x y; auto; order. - Qed. - - Lemma eqb_alt : - forall x y, eqb x y = match compare x y with Eq => true | _ => false end. - Proof. - unfold eqb; intros; apply if_eq_dec. - Qed. - -#[global] - Instance eqb_compat : Proper (eq==>eq==>Logic.eq) eqb. - Proof. - intros x x' Hxx' y y' Hyy'. - rewrite 2 eqb_alt, Hxx', Hyy'; auto. - Qed. - -End OrderedTypeFacts. - - -(** * Tests of the order tactic - - Is it at least capable of proving some basic properties ? *) - -Module OrderedTypeTest (Import O:OrderedType'). - Module Import MO := OrderedTypeFacts O. - Local Open Scope order. - Lemma lt_not_eq x y : x ~x==y. Proof. order. Qed. - Lemma lt_eq x y z : x y==z -> x y x y==z -> x<=z. Proof. order. Qed. - Lemma eq_le x y z : x==y -> y<=z -> x<=z. Proof. order. Qed. - Lemma neq_eq x y z : ~x==y -> y==z -> ~x==z. Proof. order. Qed. - Lemma eq_neq x y z : x==y -> ~y==z -> ~x==z. Proof. order. Qed. - Lemma le_lt_trans x y z : x<=y -> y x y<=z -> x y<=z -> x<=z. Proof. order. Qed. - Lemma le_antisym x y : x<=y -> y<=x -> x==y. Proof. order. Qed. - Lemma le_neq x y : x<=y -> ~x==y -> x ~y==x. Proof. order. Qed. - Lemma lt_le x y : x x<=y. Proof. order. Qed. - Lemma gt_not_eq x y : y ~x==y. Proof. order. Qed. - Lemma eq_not_lt x y : x==y -> ~x ~ y ~ y ~xeq==>iff) lt. -Proof. unfold lt; auto with *. Qed. - -Lemma le_lteq : forall x y, le x y <-> lt x y \/ eq x y. -Proof. intros; unfold le, lt, flip. rewrite O.le_lteq; intuition auto with relations. Qed. - -Definition compare := flip O.compare. - -Lemma compare_spec : forall x y, CompSpec eq lt x y (compare x y). -Proof. -intros x y; unfold compare, eq, lt, flip. -destruct (O.compare_spec y x); auto with relations. -Qed. - -End OrderedTypeRev. - -Unset Implicit Arguments. - -(** * Order relations derived from a [compare] function. - - We factorize here some common properties for ZArith, NArith - and co, where [lt] and [le] are defined in terms of [compare]. - Note that we do not require anything here concerning compatibility - of [compare] w.r.t [eq], nor anything concerning transitivity. -*) - -Module Type CompareBasedOrder (Import E:EqLtLe')(Import C:HasCmp E). - Include CmpNotation E C. - Include IsEq E. - Axiom compare_eq_iff : forall x y, (x ?= y) = Eq <-> x == y. - Axiom compare_lt_iff : forall x y, (x ?= y) = Lt <-> x < y. - Axiom compare_le_iff : forall x y, (x ?= y) <> Gt <-> x <= y. - Axiom compare_antisym : forall x y, (y ?= x) = CompOpp (x ?= y). -End CompareBasedOrder. - -Module Type CompareBasedOrderFacts - (Import E:EqLtLe') - (Import C:HasCmp E) - (Import O:CompareBasedOrder E C). - - Lemma compare_spec x y : CompareSpec (x==y) (x x==y. - Proof. - apply compare_eq_iff. - Qed. - - Lemma compare_refl x : (x ?= x) = Eq. - Proof. - now apply compare_eq_iff. - Qed. - - Lemma compare_gt_iff x y : (x ?= y) = Gt <-> y Lt <-> y<=x. - Proof. - now rewrite <- compare_le_iff, compare_antisym, CompOpp_iff. - Qed. - - Lemma compare_ngt_iff x y : (x ?= y) <> Gt <-> ~(y Lt <-> ~(x ~(x<=y). - Proof. - rewrite <- compare_le_iff. - destruct compare; split; easy || now destruct 1. - Qed. - - Lemma compare_nge_iff x y : (x ?= y) = Lt <-> ~(y<=x). - Proof. - now rewrite <- compare_nle_iff, compare_antisym, CompOpp_iff. - Qed. - - Lemma lt_irrefl x : ~ (x n < m \/ n==m. - Proof. - rewrite <- compare_lt_iff, <- compare_le_iff, <- compare_eq_iff. - destruct (n ?= m); now intuition. - Qed. - -End CompareBasedOrderFacts. - -(** Basic facts about boolean comparisons *) - -Module Type BoolOrderFacts - (Import E:EqLtLe') - (Import C:HasCmp E) - (Import F:HasBoolOrdFuns' E) - (Import O:CompareBasedOrder E C) - (Import S:BoolOrdSpecs E F). - -Include CompareBasedOrderFacts E C O. - -(** Nota : apart from [eqb_compare] below, facts about [eqb] - are in BoolEqualityFacts *) - -(** Alternate specifications based on [BoolSpec] and [reflect] *) - -Lemma leb_spec0 x y : reflect (x<=y) (x<=?y). -Proof. - apply iff_reflect. symmetry. apply leb_le. -Defined. - -Lemma leb_spec x y : BoolSpec (x<=y) (y ~ (x <= y). -Proof. -now rewrite <- not_true_iff_false, leb_le. -Qed. - -Lemma leb_gt x y : x <=? y = false <-> y < x. -Proof. -now rewrite leb_nle, <- compare_lt_iff, compare_nge_iff. -Qed. - -Lemma ltb_nlt x y : x ~ (x < y). -Proof. -now rewrite <- not_true_iff_false, ltb_lt. -Qed. - -Lemma ltb_ge x y : x y <= x. -Proof. -now rewrite ltb_nlt, <- compare_le_iff, compare_ngt_iff. -Qed. - -(** Basic equality laws for boolean tests *) - -Lemma leb_refl x : x <=? x = true. -Proof. -apply leb_le. apply lt_eq_cases. now right. -Qed. - -Lemma leb_antisym x y : y <=? x = negb (x true | _ => false end. -Proof. -apply eq_true_iff_eq. rewrite eqb_eq, <- compare_eq_iff. -now destruct compare. -Qed. - -Lemma ltb_compare x y : - (x true | _ => false end. -Proof. -apply eq_true_iff_eq. rewrite ltb_lt, <- compare_lt_iff. -now destruct compare. -Qed. - -Lemma leb_compare x y : - (x <=? y) = match compare x y with Gt => false | _ => true end. -Proof. -apply eq_true_iff_eq. rewrite leb_le, <- compare_le_iff. -now destruct compare. -Qed. - -End BoolOrderFacts. diff --git a/stdlib/theories/Structures/OrdersLists.v b/stdlib/theories/Structures/OrdersLists.v deleted file mode 100644 index 3e6f841a4f5e..000000000000 --- a/stdlib/theories/Structures/OrdersLists.v +++ /dev/null @@ -1,169 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* In x l -> In y l. -Proof. intros. rewrite <- H; auto. Qed. - -Lemma ListIn_In : forall l x, List.In x l -> In x l. -Proof. exact (In_InA O.eq_equiv). Qed. - -Lemma Inf_lt : forall l x y, O.lt x y -> Inf y l -> Inf x l. -Proof. exact (InfA_ltA O.lt_strorder). Qed. - -Lemma Inf_eq : forall l x y, O.eq x y -> Inf y l -> Inf x l. -Proof. exact (InfA_eqA O.eq_equiv O.lt_compat). Qed. - -Lemma Sort_Inf_In : forall l x a, Sort l -> Inf a l -> In x l -> O.lt a x. -Proof. exact (SortA_InfA_InA O.eq_equiv O.lt_strorder O.lt_compat). Qed. - -Lemma ListIn_Inf : forall l x, (forall y, List.In y l -> O.lt x y) -> Inf x l. -Proof. exact (@In_InfA O.t O.lt). Qed. - -Lemma In_Inf : forall l x, (forall y, In y l -> O.lt x y) -> Inf x l. -Proof. exact (InA_InfA O.eq_equiv (ltA:=O.lt)). Qed. - -Lemma Inf_alt : - forall l x, Sort l -> (Inf x l <-> (forall y, In y l -> O.lt x y)). -Proof. exact (InfA_alt O.eq_equiv O.lt_strorder O.lt_compat). Qed. - -Lemma Sort_NoDup : forall l, Sort l -> NoDup l. -Proof. exact (SortA_NoDupA O.eq_equiv O.lt_strorder O.lt_compat) . Qed. - -#[global] -Hint Resolve ListIn_In Sort_NoDup Inf_lt : core. -#[global] -Hint Immediate In_eq Inf_lt : core. - -End OrderedTypeLists. - - -(** * Results about keys and data as manipulated in the future MMaps. *) - -Module KeyOrderedType(O:OrderedType). - Include KeyDecidableType(O). (* provides eqk, eqke *) - - Local Notation key:=O.t. - Local Open Scope signature_scope. - - Definition ltk {elt} : relation (key*elt) := O.lt @@1. - - #[global] - Hint Unfold ltk : core. - - (* ltk is a strict order *) - -#[global] - Instance ltk_strorder {elt} : StrictOrder (@ltk elt) := _. - -#[global] - Instance ltk_compat {elt} : Proper (eqk==>eqk==>iff) (@ltk elt). - Proof. unfold eqk, ltk; auto with *. Qed. - -#[global] - Instance ltk_compat' {elt} : Proper (eqke==>eqke==>iff) (@ltk elt). - Proof. eapply subrelation_proper; eauto with *. Qed. - - (* Additional facts *) - -#[global] - Instance pair_compat {elt} : Proper (O.eq==>Logic.eq==>eqke) (@pair key elt). - Proof. apply pair_compat. Qed. - - Section Elt. - Variable elt : Type. - Implicit Type p q : key*elt. - Implicit Type l m : list (key*elt). - - Lemma ltk_not_eqk p q : ltk p q -> ~ eqk p q. - Proof. - intros LT EQ; rewrite EQ in LT. - elim (StrictOrder_Irreflexive _ LT). - Qed. - - Lemma ltk_not_eqke p q : ltk p q -> ~eqke p q. - Proof. - intros LT EQ; rewrite EQ in LT. - elim (StrictOrder_Irreflexive _ LT). - Qed. - - Notation Sort := (sort ltk). - Notation Inf := (lelistA ltk). - - Lemma Inf_eq l x x' : eqk x x' -> Inf x' l -> Inf x l. - Proof. now intros <-. Qed. - - Lemma Inf_lt l x x' : ltk x x' -> Inf x' l -> Inf x l. - Proof. apply InfA_ltA; auto with *. Qed. - - #[local] - Hint Immediate Inf_eq : core. - #[local] - Hint Resolve Inf_lt : core. - - Lemma Sort_Inf_In l p q : Sort l -> Inf q l -> InA eqk p l -> ltk q p. - Proof. apply SortA_InfA_InA; auto with *. Qed. - - Lemma Sort_Inf_NotIn l k e : Sort l -> Inf (k,e) l -> ~In k l. - Proof. - intros; red; intros. - destruct H1 as [e' H2]. - elim (@ltk_not_eqk (k,e) (k,e')). - - eapply Sort_Inf_In; eauto. - - repeat red; reflexivity. - Qed. - - Lemma Sort_NoDupA l : Sort l -> NoDupA eqk l. - Proof. apply SortA_NoDupA; auto with *. Qed. - - Lemma Sort_In_cons_1 l p q : Sort (p::l) -> InA eqk q l -> ltk p q. - Proof. - intros; invlist sort; eapply Sort_Inf_In; eauto. - Qed. - - Lemma Sort_In_cons_2 l p q : Sort (p::l) -> InA eqk q (p::l) -> - ltk p q \/ eqk p q. - Proof. - intros; invlist InA; auto with relations. - left; apply Sort_In_cons_1 with l; auto with relations. - Qed. - - Lemma Sort_In_cons_3 x l k e : - Sort ((k,e)::l) -> In x l -> ~O.eq x k. - Proof. - intros; invlist sort; red; intros. - eapply Sort_Inf_NotIn; eauto using In_eq. - Qed. - - End Elt. - - #[global] - Hint Resolve ltk_not_eqk ltk_not_eqke : core. - #[global] - Hint Immediate Inf_eq : core. - #[global] - Hint Resolve Inf_lt : core. - #[global] - Hint Resolve Sort_Inf_NotIn : core. - -End KeyOrderedType. diff --git a/stdlib/theories/Structures/OrdersTac.v b/stdlib/theories/Structures/OrdersTac.v deleted file mode 100644 index 0d6d6a391328..000000000000 --- a/stdlib/theories/Structures/OrdersTac.v +++ /dev/null @@ -1,279 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* le y z -> le x z]. -*) - -Inductive ord : Set := OEQ | OLT | OLE. -Definition trans_ord o o' := - match o, o' with - | OEQ, _ => o' - | _, OEQ => o - | OLE, OLE => OLE - | _, _ => OLT - end. -Local Infix "+" := trans_ord. - - -(** ** The tactic requirements : a total order - - We need : - - an equivalence [eq], - - a strict order [lt] total and compatible with [eq], - - a larger order [le] synonym for [lt\/eq]. - - This used to be provided here via a [TotalOrder], but - for technical reasons related to extraction, we now ask - for two separate parts: relations in a [EqLtLe] + properties in - [IsTotalOrder]. Note that [TotalOrder = EqLtLe <+ IsTotalOrder] -*) - -Module Type IsTotalOrder (O:EqLtLe) := - IsEq O <+ IsStrOrder O <+ LeIsLtEq O <+ LtIsTotal O. - -(** ** Properties that will be used by the [order] tactic *) - -Module OrderFacts (Import O:EqLtLe)(P:IsTotalOrder O). -Include EqLtLeNotation O. - -(** Reflexivity rules *) - -Lemma eq_refl : forall x, x==x. -Proof. reflexivity. Qed. - -Lemma le_refl : forall x, x<=x. -Proof. intros; rewrite P.le_lteq; right; reflexivity. Qed. - -Lemma lt_irrefl : forall x, ~ x y==x. -Proof. auto with *. Qed. - -Lemma le_antisym : forall x y, x<=y -> y<=x -> x==y. -Proof. - intros x y; rewrite 2 P.le_lteq. intuition auto with relations. - elim (StrictOrder_Irreflexive x); transitivity y; auto. -Qed. - -Lemma neq_sym : forall x y, ~x==y -> ~y==x. -Proof. auto using eq_sym. Qed. - -(** Transitivity rules : first, a generic formulation, then instances*) - -Ltac subst_eqns := - match goal with - | H : _==_ |- _ => (rewrite H || rewrite <- H); clear H; subst_eqns - | _ => idtac - end. - -Definition interp_ord o := - match o with OEQ => O.eq | OLT => O.lt | OLE => O.le end. -Local Notation "#" := interp_ord. - -Lemma trans o o' x y z : #o x y -> #o' y z -> #(o+o') x z. -Proof. -destruct o, o'; simpl; -rewrite ?P.le_lteq; intuition auto; -subst_eqns; pose proof (StrictOrder_Transitive x y z); eauto with *. -Qed. - -Definition eq_trans x y z : x==y -> y==z -> x==z := @trans OEQ OEQ x y z. -Definition le_trans x y z : x<=y -> y<=z -> x<=z := @trans OLE OLE x y z. -Definition lt_trans x y z : x y x y x y<=z -> x y x y==z -> x y<=z -> x<=z := @trans OEQ OLE x y z. -Definition le_eq x y z : x<=y -> y==z -> x<=z := @trans OLE OEQ x y z. - -Lemma eq_neq : forall x y z, x==y -> ~y==z -> ~x==z. -Proof. eauto using eq_trans, eq_sym. Qed. - -Lemma neq_eq : forall x y z, ~x==y -> y==z -> ~x==z. -Proof. eauto using eq_trans, eq_sym. Qed. - -(** (double) negation rules *) - -Lemma not_neq_eq : forall x y, ~~x==y -> x==y. -Proof. -intros x y H. destruct (P.lt_total x y) as [H'|[H'|H']]; auto; - destruct H; intro H; rewrite H in H'; eapply lt_irrefl; eauto. -Qed. - -Lemma not_ge_lt : forall x y, ~y<=x -> x x<=y. -Proof. -intros x y H. rewrite P.le_lteq. generalize (P.lt_total x y); intuition. -Qed. - -Lemma le_neq_lt : forall x y, x<=y -> ~x==y -> x

~ (n|p)). - -Lemma Z_0_1_more x : 0<=x -> x=0 \/ x=1 \/ 1 prime p. -Proof. - split; intros (Hp,H). - - (* prime -> prime' *) - constructor; trivial; intros n Hn. - constructor; auto with zarith; intros x Hxn Hxp. - rewrite <- Z.divide_abs_l in Hxn, Hxp |- *. - assert (Hx := Z.abs_nonneg x). - set (y:=Z.abs x) in *; clearbody y; clear x; rename y into x. - destruct (Z_0_1_more x Hx) as [->|[->|Hx']]. - + exfalso. apply Z.divide_0_l in Hxn. - absurd (1 <= n). - * rewrite Hxn; red; auto. - * intuition. - + now exists 1. - + elim (H x); auto. - split; trivial. - apply Z.le_lt_trans with n; try tauto. - apply Z.divide_pos_le; auto with zarith. - apply Z.lt_le_trans with (2 := proj1 Hn); red; auto. - - (* prime' -> prime *) - constructor; trivial. intros n Hn Hnp. - case (Zis_gcd_unique n p n 1). - + constructor; auto with zarith. - + apply H; auto with zarith. - now intuition; apply Z.lt_le_incl. - + intros H1; intuition; subst n; discriminate. - + intros H1; intuition; subst n; discriminate. -Qed. - -Theorem square_not_prime: forall a, ~ prime (a * a). -Proof. - intros a Ha. - rewrite <- (Z.abs_square a) in Ha. - assert (H:=Z.abs_nonneg a). - set (b:=Z.abs a) in *; clearbody b; clear a; rename b into a. - rewrite <- prime_alt in Ha; destruct Ha as (Ha,Ha'). - assert (H' : 1 < a) by now apply (Z.square_lt_simpl_nonneg 1). - apply (Ha' a). - + split; trivial. - rewrite <- (Z.mul_1_l a) at 1. - apply Z.mul_lt_mono_pos_r; auto. - apply Z.lt_trans with (2 := H'); red; auto. - + exists a; auto. -Qed. - -Theorem prime_div_prime: forall p q, - prime p -> prime q -> (p | q) -> p = q. -Proof. - intros p q H H1 H2; - assert (Hp: 0 < p); try apply Z.lt_le_trans with 2; try apply prime_ge_2; auto with zarith. - assert (Hq: 0 < q); try apply Z.lt_le_trans with 2; try apply prime_ge_2; auto with zarith. - case prime_divisors with (2 := H2); auto. - - intros H4; contradict Hp; subst; discriminate. - - intros [H4| [H4 | H4]]; subst; auto. - + contradict H; auto; apply not_prime_1. - + contradict Hp; apply Zle_not_lt, (Z.opp_le_mono _ 0). - now rewrite Z.opp_involutive; apply Z.lt_le_incl. -Qed. - -Notation Zgcd_is_pos := Z.gcd_nonneg (only parsing). - -Theorem Zgcd_spec : forall x y : Z, {z : Z | Zis_gcd x y z /\ 0 <= z}. -Proof. - intros x y; exists (Z.gcd x y). - split; [apply Zgcd_is_gcd | apply Z.gcd_nonneg]. -Qed. - -Theorem Zdivide_Zgcd: forall p q r : Z, - (p | q) -> (p | r) -> (p | Z.gcd q r). -Proof. - intros. now apply Z.gcd_greatest. -Qed. - -Theorem Zis_gcd_gcd: forall a b c : Z, - 0 <= c -> Zis_gcd a b c -> Z.gcd a b = c. -Proof. - intros a b c H1 H2. - case (Zis_gcd_uniqueness_apart_sign a b c (Z.gcd a b)); auto. - - apply Zgcd_is_gcd; auto. - - Z.le_elim H1. - + generalize (Z.gcd_nonneg a b); auto with zarith. - intros H3 H4; contradict H3. - rewrite <- (Z.opp_involutive (Z.gcd a b)), <- H4. - now apply Zlt_not_le, Z.opp_lt_mono; rewrite Z.opp_involutive. - + subst. now case (Z.gcd a b). -Qed. - -Notation Zgcd_inv_0_l := Z.gcd_eq_0_l (only parsing). -Notation Zgcd_inv_0_r := Z.gcd_eq_0_r (only parsing). - -Theorem Zgcd_div_swap0 : forall a b : Z, - 0 < Z.gcd a b -> - 0 < b -> - (a / Z.gcd a b) * b = a * (b/Z.gcd a b). -Proof. - intros a b Hg Hb. - assert (F := Zgcd_is_gcd a b); inversion F as [F1 F2 F3]. - pattern b at 2; rewrite (Zdivide_Zdiv_eq (Z.gcd a b) b); auto. - repeat rewrite Z.mul_assoc; f_equal. - rewrite Z.mul_comm. - rewrite <- Zdivide_Zdiv_eq; auto. -Qed. - -Theorem Zgcd_div_swap : forall a b c : Z, - 0 < Z.gcd a b -> - 0 < b -> - (c * a) / Z.gcd a b * b = c * a * (b/Z.gcd a b). -Proof. - intros a b c Hg Hb. - assert (F := Zgcd_is_gcd a b); inversion F as [F1 F2 F3]. - pattern b at 2; rewrite (Zdivide_Zdiv_eq (Z.gcd a b) b); auto. - repeat rewrite Z.mul_assoc; f_equal. - rewrite Zdivide_Zdiv_eq_2; auto. - repeat rewrite <- Z.mul_assoc; f_equal. - rewrite Z.mul_comm. - rewrite <- Zdivide_Zdiv_eq; auto. -Qed. - -Lemma Zgcd_ass a b c : Z.gcd (Z.gcd a b) c = Z.gcd a (Z.gcd b c). -Proof. - symmetry. apply Z.gcd_assoc. -Qed. - -Notation Zgcd_Zabs := Z.gcd_abs_l (only parsing). -Notation Zgcd_0 := Z.gcd_0_r (only parsing). -Notation Zgcd_1 := Z.gcd_1_r (only parsing). - -#[global] -Hint Resolve Z.gcd_0_r Z.gcd_1_r : zarith. - -Theorem Zgcd_1_rel_prime : forall a b, - Z.gcd a b = 1 <-> rel_prime a b. -Proof. - unfold rel_prime; intros a b; split; intro H. - - rewrite <- H; apply Zgcd_is_gcd. - - case (Zis_gcd_unique a b (Z.gcd a b) 1); auto. - + apply Zgcd_is_gcd. - + intros H2; absurd (0 <= Z.gcd a b); auto with zarith. - * rewrite H2; red; auto. - * generalize (Z.gcd_nonneg a b); auto with zarith. -Qed. - -Definition rel_prime_dec: forall a b, - { rel_prime a b }+{ ~ rel_prime a b }. -Proof. - intros a b; case (Z.eq_dec (Z.gcd a b) 1); intros H1. - - left; apply -> Zgcd_1_rel_prime; auto. - - right; contradict H1; apply <- Zgcd_1_rel_prime; auto. -Defined. - -Definition prime_dec_aux: - forall p m, - { forall n, 1 < n < m -> rel_prime n p } + - { exists n, 1 < n < m /\ ~ rel_prime n p }. -Proof. - intros p m. - case (Z_lt_dec 1 m); intros H1; - [ | left; intros n ?; exfalso; - contradict H1; apply Z.lt_trans with n; intuition]. - pattern m; apply natlike_rec; auto with zarith. - - left; intros n ?; exfalso. - absurd (1 < 0); try discriminate. - apply Z.lt_trans with n; intuition. - - intros x Hx IH; destruct IH as [F|E]. - + destruct (rel_prime_dec x p) as [Y|N]. - * left; intros n [HH1 HH2]. - rewrite Z.lt_succ_r in HH2. - Z.le_elim HH2; subst; auto with zarith. - * case (Z_lt_dec 1 x); intros HH1. - -- right; exists x; split; auto with zarith. - -- left; intros n [HHH1 HHH2]; contradict HHH1; auto with zarith. - apply Zle_not_lt; apply Z.le_trans with x. - ++ now apply Zlt_succ_le. - ++ now apply Znot_gt_le; contradict HH1; apply Z.gt_lt. - + right; destruct E as (n,((H0,H2),H3)); exists n; auto with zarith. - - apply Z.le_trans with (2 := Z.lt_le_incl _ _ H1); discriminate. -Defined. - -Definition prime_dec: forall p, { prime p }+{ ~ prime p }. -Proof. - intros p; case (Z_lt_dec 1 p); intros H1. - + case (prime_dec_aux p p); intros H2. - * left; apply prime_intro; auto. - intros n (Hn1,Hn2). Z.le_elim Hn1; auto; subst n. - constructor; auto with zarith. - * right; intros H3; inversion_clear H3 as [Hp1 Hp2]. - case H2; intros n [Hn1 Hn2]; case Hn2; auto with zarith. - now apply Hp2; intuition; apply Z.lt_le_incl. - + right; intros H3; inversion_clear H3 as [Hp1 Hp2]; case H1; auto. -Defined. - -Theorem not_prime_divide: - forall p, 1 < p -> ~ prime p -> exists n, 1 < n < p /\ (n | p). -Proof. - intros p Hp Hp1. - case (prime_dec_aux p p); intros H1. - - elim Hp1; constructor; auto. - intros n (Hn1,Hn2). - Z.le_elim Hn1; auto with zarith. - subst n; constructor; auto with zarith. - - case H1; intros n (Hn1,Hn2). - destruct (Z_0_1_more _ (Z.gcd_nonneg n p)) as [H|[H|H]]. - + exfalso. apply Z.gcd_eq_0_l in H. - absurd (1 < n). - * rewrite H; discriminate. - * now intuition. - + elim Hn2. red. rewrite <- H. apply Zgcd_is_gcd. - + exists (Z.gcd n p); split; [ split; auto | apply Z.gcd_divide_r ]. - apply Z.le_lt_trans with n; auto with zarith. - * apply Z.divide_pos_le; auto with zarith. - -- apply Z.lt_trans with 1; intuition. - -- apply Z.gcd_divide_l. - * intuition. -Qed. diff --git a/stdlib/theories/ZArith/Zorder.v b/stdlib/theories/ZArith/Zorder.v deleted file mode 100644 index 491dc6eb176a..000000000000 --- a/stdlib/theories/ZArith/Zorder.v +++ /dev/null @@ -1,644 +0,0 @@ -(* -*- coding: utf-8 -*- *) -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* m}. -Proof. - unfold ">", "<". generalize (Z.compare_eq n m). - destruct (n ?= m); [ left; right | left; left | right]; auto. -Defined. - -Theorem Ztrichotomy n m : n < m \/ n = m \/ n > m. -Proof. - Z.swap_greater. apply Z.lt_trichotomy. -Qed. - -(**********************************************************************) -(** * Decidability of equality and order on Z *) - -Notation dec_eq := Z.eq_decidable (only parsing). -Notation dec_Zle := Z.le_decidable (only parsing). -Notation dec_Zlt := Z.lt_decidable (only parsing). - -Theorem dec_Zne n m : decidable (Zne n m). -Proof. - destruct (Z.eq_decidable n m); [right|left]; subst; auto. -Qed. - -Theorem dec_Zgt n m : decidable (n > m). -Proof. - destruct (Z.lt_decidable m n); [left|right]; Z.swap_greater; auto. -Qed. - -Theorem dec_Zge n m : decidable (n >= m). -Proof. - destruct (Z.le_decidable m n); [left|right]; Z.swap_greater; auto. -Qed. - -Theorem not_Zeq n m : n <> m -> n < m \/ m < n. -Proof. - apply Z.lt_gt_cases. -Qed. - -(** * Relating strict and large orders *) - -Notation Zgt_iff_lt := Z.gt_lt_iff (only parsing). -Notation Zge_iff_le := Z.ge_le_iff (only parsing). - -Lemma Zle_not_lt n m : n <= m -> ~ m < n. -Proof. - apply Z.le_ngt. -Qed. - -Lemma Zlt_not_le n m : n < m -> ~ m <= n. -Proof. - apply Z.lt_nge. -Qed. - -Lemma Zle_not_gt n m : n <= m -> ~ n > m. -Proof. - trivial. -Qed. - -Lemma Zgt_not_le n m : n > m -> ~ n <= m. -Proof. - Z.swap_greater. apply Z.lt_nge. -Qed. - -Lemma Znot_ge_lt n m : ~ n >= m -> n < m. -Proof. - Z.swap_greater. apply Z.nle_gt. -Qed. - -Lemma Znot_lt_ge n m : ~ n < m -> n >= m. -Proof. - trivial. -Qed. - -Lemma Znot_gt_le n m: ~ n > m -> n <= m. -Proof. - trivial. -Qed. - -Lemma Znot_le_gt n m : ~ n <= m -> n > m. -Proof. - Z.swap_greater. apply Z.nle_gt. -Qed. - -Lemma not_Zne n m : ~ Zne n m -> n = m. -Proof. - intros H. - destruct (Z.eq_decidable n m); [assumption|now elim H]. -Qed. - -(** * Equivalence and order properties *) - -(** Reflexivity *) - -Notation Zeq_le := Z.eq_le_incl (only parsing). - -#[global] -Hint Resolve Z.le_refl: zarith. - -(** Antisymmetry *) - -Notation Zle_antisym := Z.le_antisymm (only parsing). - -(** Asymmetry *) - -Notation Zlt_asym := Z.lt_asymm (only parsing). - -Lemma Zgt_asym n m : n > m -> ~ m > n. -Proof. - Z.swap_greater. apply Z.lt_asymm. -Qed. - -(** Irreflexivity *) - -Notation Zlt_not_eq := Z.lt_neq (only parsing). - -Lemma Zgt_irrefl n : ~ n > n. -Proof. - Z.swap_greater. apply Z.lt_irrefl. -Qed. - -(** Large = strict or equal *) - -Notation Zlt_le_weak := Z.lt_le_incl (only parsing). -Notation Zle_lt_or_eq_iff := Z.lt_eq_cases (only parsing). - -Lemma Zle_lt_or_eq n m : n <= m -> n < m \/ n = m. -Proof. - apply Z.lt_eq_cases. -Qed. - -(** Dichotomy *) - -Notation Zle_or_lt := Z.le_gt_cases (only parsing). - -(** Transitivity of strict orders *) - -Lemma Zgt_trans n m p : n > m -> m > p -> n > p. -Proof. - Z.swap_greater. intros; now transitivity m. -Qed. - -(** Mixed transitivity *) - -Lemma Zle_gt_trans n m p : m <= n -> m > p -> n > p. -Proof. - Z.swap_greater. Z.order. -Qed. - -Lemma Zgt_le_trans n m p : n > m -> p <= m -> n > p. -Proof. - Z.swap_greater. Z.order. -Qed. - -(** Transitivity of large orders *) - -Lemma Zge_trans n m p : n >= m -> m >= p -> n >= p. -Proof. - Z.swap_greater. Z.order. -Qed. - -#[global] -Hint Resolve Z.le_trans: zarith. - -(** * Compatibility of order and operations on Z *) - -(** ** Successor *) - -(** Compatibility of successor wrt to order *) - -Lemma Zsucc_le_compat n m : m <= n -> Z.succ m <= Z.succ n. -Proof. - apply Z.succ_le_mono. -Qed. - -Lemma Zsucc_lt_compat n m : n < m -> Z.succ n < Z.succ m. -Proof. - apply Z.succ_lt_mono. -Qed. - -Lemma Zsucc_gt_compat n m : m > n -> Z.succ m > Z.succ n. -Proof. - Z.swap_greater. apply Z.succ_lt_mono. -Qed. - -#[global] -Hint Resolve Zsucc_le_compat: zarith. - -(** Simplification of successor wrt to order *) - -Lemma Zsucc_gt_reg n m : Z.succ m > Z.succ n -> m > n. -Proof. - Z.swap_greater. apply Z.succ_lt_mono. -Qed. - -Lemma Zsucc_le_reg n m : Z.succ m <= Z.succ n -> m <= n. -Proof. - apply Z.succ_le_mono. -Qed. - -Lemma Zsucc_lt_reg n m : Z.succ n < Z.succ m -> n < m. -Proof. - apply Z.succ_lt_mono. -Qed. - -(** Special base instances of order *) - -Notation Zlt_succ := Z.lt_succ_diag_r (only parsing). -Notation Zlt_pred := Z.lt_pred_l (only parsing). - -Lemma Zgt_succ n : Z.succ n > n. -Proof. - Z.swap_greater. apply Z.lt_succ_diag_r. -Qed. - -Lemma Znot_le_succ n : ~ Z.succ n <= n. -Proof. - apply Z.lt_nge, Z.lt_succ_diag_r. -Qed. - -(** Relating strict and large order using successor or predecessor *) - -Lemma Zgt_le_succ n m : m > n -> Z.succ n <= m. -Proof. - Z.swap_greater. apply Z.le_succ_l. -Qed. - -Lemma Zle_gt_succ n m : n <= m -> Z.succ m > n. -Proof. - Z.swap_greater. apply Z.lt_succ_r. -Qed. - -Lemma Zle_lt_succ n m : n <= m -> n < Z.succ m. -Proof. - apply Z.lt_succ_r. -Qed. - -Lemma Zlt_le_succ n m : n < m -> Z.succ n <= m. -Proof. - apply Z.le_succ_l. -Qed. - -Lemma Zgt_succ_le n m : Z.succ m > n -> n <= m. -Proof. - Z.swap_greater. apply Z.lt_succ_r. -Qed. - -Lemma Zlt_succ_le n m : n < Z.succ m -> n <= m. -Proof. - apply Z.lt_succ_r. -Qed. - -Lemma Zle_succ_gt n m : Z.succ n <= m -> m > n. -Proof. - Z.swap_greater. apply Z.le_succ_l. -Qed. - -(** Weakening order *) - -Notation Zle_succ := Z.le_succ_diag_r (only parsing). -Notation Zle_pred := Z.le_pred_l (only parsing). -Notation Zlt_lt_succ := Z.lt_lt_succ_r (only parsing). -Notation Zle_le_succ := Z.le_le_succ_r (only parsing). - -Lemma Zle_succ_le n m : Z.succ n <= m -> n <= m. -Proof. - intros. now apply Z.lt_le_incl, Z.le_succ_l. -Qed. - -#[global] -Hint Resolve Z.le_succ_diag_r: zarith. -#[global] -Hint Resolve Z.le_le_succ_r: zarith. - -(** Relating order wrt successor and order wrt predecessor *) - -Lemma Zgt_succ_pred n m : m > Z.succ n -> Z.pred m > n. -Proof. - Z.swap_greater. apply Z.lt_succ_lt_pred. -Qed. - -Lemma Zlt_succ_pred n m : Z.succ n < m -> n < Z.pred m. -Proof. - apply Z.lt_succ_lt_pred. -Qed. - -(** Relating strict order and large order on positive *) - -Lemma Zlt_0_le_0_pred n : 0 < n -> 0 <= Z.pred n. -Proof. - apply Z.lt_le_pred. -Qed. - -Lemma Zgt_0_le_0_pred n : n > 0 -> 0 <= Z.pred n. -Proof. - Z.swap_greater. apply Z.lt_le_pred. -Qed. - -(** Special cases of ordered integers *) - -Lemma Zle_neg_pos : forall p q:positive, Zneg p <= Zpos q. -Proof. - exact Pos2Z.neg_le_pos. -Qed. - -Lemma Zgt_pos_0 : forall p:positive, Zpos p > 0. -Proof. - easy. -Qed. - -(* weaker but useful (in [Z.pow] for instance) *) -Lemma Zle_0_pos : forall p:positive, 0 <= Zpos p. -Proof. - exact Pos2Z.pos_is_nonneg. -Qed. - -Lemma Zlt_neg_0 : forall p:positive, Zneg p < 0. -Proof. - exact Pos2Z.neg_is_neg. -Qed. - -Lemma Zle_0_nat : forall n:nat, 0 <= Z.of_nat n. -Proof. - intros n; induction n; simpl; intros. - - apply Z.le_refl. - - easy. -Qed. - -#[global] -Hint Immediate Z.eq_le_incl: zarith. - -(** Derived lemma *) - -Lemma Zgt_succ_gt_or_eq n m : Z.succ n > m -> n > m \/ m = n. -Proof. - Z.swap_greater. intros. now apply Z.lt_eq_cases, Z.lt_succ_r. -Qed. - -(** ** Addition *) -(** Compatibility of addition wrt to order *) - -Notation Zplus_lt_le_compat := Z.add_lt_le_mono (only parsing). -Notation Zplus_le_lt_compat := Z.add_le_lt_mono (only parsing). -Notation Zplus_le_compat := Z.add_le_mono (only parsing). -Notation Zplus_lt_compat := Z.add_lt_mono (only parsing). - -Lemma Zplus_gt_compat_l n m p : n > m -> p + n > p + m. -Proof. - Z.swap_greater. apply Z.add_lt_mono_l. -Qed. - -Lemma Zplus_gt_compat_r n m p : n > m -> n + p > m + p. -Proof. - Z.swap_greater. apply Z.add_lt_mono_r. -Qed. - -Lemma Zplus_le_compat_l n m p : n <= m -> p + n <= p + m. -Proof. - apply Z.add_le_mono_l. -Qed. - -Lemma Zplus_le_compat_r n m p : n <= m -> n + p <= m + p. -Proof. - apply Z.add_le_mono_r. -Qed. - -Lemma Zplus_lt_compat_l n m p : n < m -> p + n < p + m. -Proof. - apply Z.add_lt_mono_l. -Qed. - -Lemma Zplus_lt_compat_r n m p : n < m -> n + p < m + p. -Proof. - apply Z.add_lt_mono_r. -Qed. - -(** Compatibility of addition wrt to being positive *) - -Notation Zplus_le_0_compat := Z.add_nonneg_nonneg (only parsing). - -(** Simplification of addition wrt to order *) - -Lemma Zplus_le_reg_l n m p : p + n <= p + m -> n <= m. -Proof. - apply Z.add_le_mono_l. -Qed. - -Lemma Zplus_le_reg_r n m p : n + p <= m + p -> n <= m. -Proof. - apply Z.add_le_mono_r. -Qed. - -Lemma Zplus_lt_reg_l n m p : p + n < p + m -> n < m. -Proof. - apply Z.add_lt_mono_l. -Qed. - -Lemma Zplus_lt_reg_r n m p : n + p < m + p -> n < m. -Proof. - apply Z.add_lt_mono_r. -Qed. - -Lemma Zplus_gt_reg_l n m p : p + n > p + m -> n > m. -Proof. - Z.swap_greater. apply Z.add_lt_mono_l. -Qed. - -Lemma Zplus_gt_reg_r n m p : n + p > m + p -> n > m. -Proof. - Z.swap_greater. apply Z.add_lt_mono_r. -Qed. - -(** ** Multiplication *) -(** Compatibility of multiplication by a positive wrt to order *) - -Lemma Zmult_le_compat_r n m p : n <= m -> 0 <= p -> n * p <= m * p. -Proof. - intros. now apply Z.mul_le_mono_nonneg_r. -Qed. - -Lemma Zmult_le_compat_l n m p : n <= m -> 0 <= p -> p * n <= p * m. -Proof. - intros. now apply Z.mul_le_mono_nonneg_l. -Qed. - -Lemma Zmult_lt_compat_r n m p : 0 < p -> n < m -> n * p < m * p. -Proof. - apply Z.mul_lt_mono_pos_r. -Qed. - -Lemma Zmult_gt_compat_r n m p : p > 0 -> n > m -> n * p > m * p. -Proof. - Z.swap_greater. apply Z.mul_lt_mono_pos_r. -Qed. - -Lemma Zmult_gt_0_lt_compat_r n m p : p > 0 -> n < m -> n * p < m * p. -Proof. - Z.swap_greater. apply Z.mul_lt_mono_pos_r. -Qed. - -Lemma Zmult_gt_0_le_compat_r n m p : p > 0 -> n <= m -> n * p <= m * p. -Proof. - Z.swap_greater. apply Z.mul_le_mono_pos_r. -Qed. - -Lemma Zmult_lt_0_le_compat_r n m p : 0 < p -> n <= m -> n * p <= m * p. -Proof. - apply Z.mul_le_mono_pos_r. -Qed. - -Lemma Zmult_gt_0_lt_compat_l n m p : p > 0 -> n < m -> p * n < p * m. -Proof. - Z.swap_greater. apply Z.mul_lt_mono_pos_l. -Qed. - -Lemma Zmult_lt_compat_l n m p : 0 < p -> n < m -> p * n < p * m. -Proof. - apply Z.mul_lt_mono_pos_l. -Qed. - -Lemma Zmult_gt_compat_l n m p : p > 0 -> n > m -> p * n > p * m. -Proof. - Z.swap_greater. apply Z.mul_lt_mono_pos_l. -Qed. - -Lemma Zmult_ge_compat_r n m p : n >= m -> p >= 0 -> n * p >= m * p. -Proof. - Z.swap_greater. intros. now apply Z.mul_le_mono_nonneg_r. -Qed. - -Lemma Zmult_ge_compat_l n m p : n >= m -> p >= 0 -> p * n >= p * m. -Proof. - Z.swap_greater. intros. now apply Z.mul_le_mono_nonneg_l. -Qed. - -Lemma Zmult_ge_compat n m p q : - n >= p -> m >= q -> p >= 0 -> q >= 0 -> n * m >= p * q. -Proof. - Z.swap_greater. intros. now apply Z.mul_le_mono_nonneg. -Qed. - -Lemma Zmult_le_compat n m p q : - n <= p -> m <= q -> 0 <= n -> 0 <= m -> n * m <= p * q. -Proof. - intros. now apply Z.mul_le_mono_nonneg. -Qed. - -(** Simplification of multiplication by a positive wrt to being positive *) - -Lemma Zmult_gt_0_lt_reg_r n m p : p > 0 -> n * p < m * p -> n < m. -Proof. - Z.swap_greater. apply Z.mul_lt_mono_pos_r. -Qed. - -Lemma Zmult_lt_reg_r n m p : 0 < p -> n * p < m * p -> n < m. -Proof. - apply Z.mul_lt_mono_pos_r. -Qed. - -Lemma Zmult_le_reg_r n m p : p > 0 -> n * p <= m * p -> n <= m. -Proof. - Z.swap_greater. apply Z.mul_le_mono_pos_r. -Qed. - -Lemma Zmult_lt_0_le_reg_r n m p : 0 < p -> n * p <= m * p -> n <= m. -Proof. - apply Z.mul_le_mono_pos_r. -Qed. - -Lemma Zmult_ge_reg_r n m p : p > 0 -> n * p >= m * p -> n >= m. -Proof. - Z.swap_greater. apply Z.mul_le_mono_pos_r. -Qed. - -Lemma Zmult_gt_reg_r n m p : p > 0 -> n * p > m * p -> n > m. -Proof. - Z.swap_greater. apply Z.mul_lt_mono_pos_r. -Qed. - -Lemma Zmult_lt_compat n m p q : - 0 <= n < p -> 0 <= m < q -> n * m < p * q. -Proof. - intros (Hn,Hnp) (Hm,Hmq). now apply Z.mul_lt_mono_nonneg. -Qed. - -Lemma Zmult_lt_compat2 n m p q : - 0 < n <= p -> 0 < m < q -> n * m < p * q. -Proof. - intros (Hn, Hnp) (Hm,Hmq). - apply Z.le_lt_trans with (p * m). - - apply Z.mul_le_mono_pos_r; trivial. - - apply Z.mul_lt_mono_pos_l; Z.order. -Qed. - -(** Compatibility of multiplication by a positive wrt to being positive *) - -Notation Zmult_le_0_compat := Z.mul_nonneg_nonneg (only parsing). -Notation Zmult_lt_0_compat := Z.mul_pos_pos (only parsing). -Notation Zmult_lt_O_compat := Z.mul_pos_pos (only parsing). - -Lemma Zmult_gt_0_compat n m : n > 0 -> m > 0 -> n * m > 0. -Proof. - Z.swap_greater. apply Z.mul_pos_pos. -Qed. - -(* To remove someday ... *) - -Lemma Zmult_gt_0_le_0_compat n m : n > 0 -> 0 <= m -> 0 <= m * n. -Proof. - Z.swap_greater. intros. apply Z.mul_nonneg_nonneg. - - trivial. - - now apply Z.lt_le_incl. -Qed. - -(** Simplification of multiplication by a positive wrt to being positive *) - -Lemma Zmult_le_0_reg_r n m : n > 0 -> 0 <= m * n -> 0 <= m. -Proof. - Z.swap_greater. apply Z.mul_nonneg_cancel_r. -Qed. - -Lemma Zmult_lt_0_reg_r n m : 0 < n -> 0 < m * n -> 0 < m. -Proof. - apply Z.mul_pos_cancel_r. -Qed. - -Lemma Zmult_gt_0_lt_0_reg_r n m : n > 0 -> 0 < m * n -> 0 < m. -Proof. - Z.swap_greater. apply Z.mul_pos_cancel_r. -Qed. - -Lemma Zmult_gt_0_reg_l n m : n > 0 -> n * m > 0 -> m > 0. -Proof. - Z.swap_greater. apply Z.mul_pos_cancel_l. -Qed. - -(** ** Square *) -(** Simplification of square wrt order *) - -Lemma Zlt_square_simpl n m : 0 <= n -> m * m < n * n -> m < n. -Proof. - apply Z.square_lt_simpl_nonneg. -Qed. - -Lemma Zgt_square_simpl n m : n >= 0 -> n * n > m * m -> n > m. -Proof. - Z.swap_greater. apply Z.square_lt_simpl_nonneg. -Qed. - -(** * Equivalence between inequalities *) - -Notation Zle_plus_swap := Z.le_add_le_sub_r (only parsing). -Notation Zlt_plus_swap := Z.lt_add_lt_sub_r (only parsing). -Notation Zlt_minus_simpl_swap := Z.lt_sub_pos (only parsing). - -Lemma Zeq_plus_swap n m p : n + p = m <-> n = m - p. -Proof. - apply Z.add_move_r. -Qed. - -Lemma Zlt_0_minus_lt n m : 0 < n - m -> m < n. -Proof. - apply Z.lt_0_sub. -Qed. - -Lemma Zle_0_minus_le n m : 0 <= n - m -> m <= n. -Proof. - apply Z.le_0_sub. -Qed. - -Lemma Zle_minus_le_0 n m : m <= n -> 0 <= n - m. -Proof. - apply Z.le_0_sub. -Qed. - -(** For compatibility *) -Notation Zlt_O_minus_lt := Zlt_0_minus_lt (only parsing). diff --git a/stdlib/theories/ZArith/Zpow_alt.v b/stdlib/theories/ZArith/Zpow_alt.v deleted file mode 100644 index b36880bab1ba..000000000000 --- a/stdlib/theories/ZArith/Zpow_alt.v +++ /dev/null @@ -1,85 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* 1 - | Zpos p => Pos.iter_op Z.mul p n - | Zneg p => 0 - end. - -Infix "^^" := Zpower_alt (at level 30, right associativity) : Z_scope. - -Lemma Piter_mul_acc : forall f, - (forall x y:Z, (f x)*y = f (x*y)) -> - forall p k, Pos.iter f k p = (Pos.iter f 1 p)*k. -Proof. - intros f Hf. - induction p; simpl; intros. - - set (g := Pos.iter f 1 p) in *. now rewrite !IHp, Hf, Z.mul_assoc. - - set (g := Pos.iter f 1 p) in *. now rewrite !IHp, Z.mul_assoc. - - now rewrite Hf, Z.mul_1_l. -Qed. - -Lemma Piter_op_square : forall p a, - Pos.iter_op Z.mul p (a*a) = (Pos.iter_op Z.mul p a)*(Pos.iter_op Z.mul p a). -Proof. - induction p; simpl; intros; trivial. now rewrite IHp, Z.mul_shuffle1. -Qed. - -Lemma Zpower_equiv a b : a^^b = a^b. -Proof. - destruct b as [|p|p]; trivial. - unfold Zpower_alt, Z.pow, Z.pow_pos. - revert a. - induction p; simpl; intros. - - f_equal. - rewrite Piter_mul_acc. - + now rewrite Piter_op_square, IHp. - + intros. symmetry; apply Z.mul_assoc. - - rewrite Piter_mul_acc. - + now rewrite Piter_op_square, IHp. - + intros. symmetry; apply Z.mul_assoc. - - now Z.nzsimpl. -Qed. - -Lemma Zpower_alt_0_r n : n^^0 = 1. -Proof. reflexivity. Qed. - -Lemma Zpower_alt_succ_r a b : 0<=b -> a^^(Z.succ b) = a * a^^b. -Proof. - destruct b as [|b|b]; intros Hb; simpl. - - now Z.nzsimpl. - - now rewrite Pos.add_1_r, Pos.iter_op_succ by apply Z.mul_assoc. - - now elim Hb. -Qed. - -Lemma Zpower_alt_neg_r a b : b<0 -> a^^b = 0. -Proof. - now destruct b. -Qed. - -Lemma Zpower_alt_Ppow p q : (Zpos p)^^(Zpos q) = Zpos (p^q). -Proof. - now rewrite Zpower_equiv, Pos2Z.inj_pow. -Qed. diff --git a/stdlib/theories/ZArith/Zpow_def.v b/stdlib/theories/ZArith/Zpow_def.v deleted file mode 100644 index d571eae5a790..000000000000 --- a/stdlib/theories/ZArith/Zpow_def.v +++ /dev/null @@ -1,33 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* 0 < Z.pow_pos x p. -Proof. intros. now apply (Z.pow_pos_nonneg x (Zpos p)). Qed. - -Notation Zpower_1_r := Z.pow_1_r (only parsing). -Notation Zpower_1_l := Z.pow_1_l (only parsing). -Notation Zpower_0_l := Z.pow_0_l' (only parsing). -Notation Zpower_0_r := Z.pow_0_r (only parsing). -Notation Zpower_2 := Z.pow_2_r (only parsing). -Notation Zpower_gt_0 := Z.pow_pos_nonneg (only parsing). -Notation Zpower_ge_0 := Z.pow_nonneg (only parsing). -Notation Zpower_Zabs := Z.abs_pow (only parsing). -Notation Zpower_Zsucc := Z.pow_succ_r (only parsing). -Notation Zpower_mult := Z.pow_mul_r (only parsing). -Notation Zpower_le_monotone2 := Z.pow_le_mono_r (only parsing). - -Theorem Zpower_le_monotone a b c : - 0 < a -> 0 <= b <= c -> a^b <= a^c. -Proof. intros. now apply Z.pow_le_mono_r. Qed. - -Theorem Zpower_lt_monotone a b c : - 1 < a -> 0 <= b < c -> a^b < a^c. -Proof. intros. apply Z.pow_lt_mono_r; lia. Qed. - -Theorem Zpower_gt_1 x y : 1 < x -> 0 < y -> 1 < x^y. -Proof. apply Z.pow_gt_1. Qed. - -Theorem Zmult_power p q r : 0 <= r -> (p*q)^r = p^r * q^r. -Proof. intros. apply Z.pow_mul_l. Qed. - -#[global] -Hint Resolve Z.pow_nonneg Z.pow_pos_nonneg : zarith. - -Theorem Zpower_le_monotone3 a b c : - 0 <= c -> 0 <= a <= b -> a^c <= b^c. -Proof. intros. now apply Z.pow_le_mono_l. Qed. - -Lemma Zpower_le_monotone_inv a b c : - 1 < a -> 0 < b -> a^b <= a^c -> b <= c. -Proof. - intros Ha Hb H. apply (Z.pow_le_mono_r_iff a); trivial. - apply Z.lt_le_incl; apply (Z.pow_gt_1 a); trivial. - apply Z.lt_le_trans with (a^b); trivial. now apply Z.pow_gt_1. -Qed. - -Notation Zpower_nat_Zpower := Zpower_nat_Zpower (only parsing). - -Theorem Zpower2_lt_lin n : 0 <= n -> n < 2^n. -Proof. intros. now apply Z.pow_gt_lin_r. Qed. - -Theorem Zpower2_le_lin n : 0 <= n -> n <= 2^n. -Proof. intros. apply Z.lt_le_incl. now apply Z.pow_gt_lin_r. Qed. - -Lemma Zpower2_Psize n p : - Zpos p < 2^(Z.of_nat n) <-> (Pos.size_nat p <= n)%nat. -Proof. - revert p; induction n as [|n IHn]. - - intros p; destruct p; now split. - - assert (Hn := Nat2Z.is_nonneg n). - intros p; destruct p as [p|p|]; simpl Pos.size_nat. - + specialize IHn with p. - rewrite Nat2Z.inj_succ, Z.pow_succ_r; lia. - + specialize IHn with p. - rewrite Nat2Z.inj_succ, Z.pow_succ_r; lia. - + split. - * lia. - * intros _. apply Z.pow_gt_1. - -- easy. - -- now rewrite Nat2Z.inj_succ, Z.lt_succ_r. -Qed. - -(** * Z.pow and modulo *) - -Theorem Zpower_mod p q n : - 0 < n -> (p^q) mod n = ((p mod n)^q) mod n. -Proof. - intros Hn; destruct (Z.le_gt_cases 0 q) as [H1|H1]. - - pattern q; apply Wf_Z.natlike_ind; trivial. - clear q H1. intros q Hq Rec. rewrite !Z.pow_succ_r; trivial. - rewrite Z.mul_mod_idemp_l by lia. - rewrite Z.mul_mod, Rec, <- Z.mul_mod by lia. reflexivity. - - rewrite !Z.pow_neg_r; auto with zarith. -Qed. - -(** A direct way to compute Z.pow modulo **) - -Fixpoint Zpow_mod_pos (a: Z)(m: positive)(n : Z) : Z := - match m with - | xH => a mod n - | xO m' => - let z := Zpow_mod_pos a m' n in - match z with - | 0 => 0 - | _ => (z * z) mod n - end - | xI m' => - let z := Zpow_mod_pos a m' n in - match z with - | 0 => 0 - | _ => (z * z * a) mod n - end - end. - -Definition Zpow_mod a m n := - match m with - | 0 => 1 mod n - | Zpos p => Zpow_mod_pos a p n - | Zneg p => 0 - end. - -Theorem Zpow_mod_pos_correct a m n : - n <> 0 -> Zpow_mod_pos a m n = (Z.pow_pos a m) mod n. -Proof. - intros Hn. induction m as [m IHm|m IHm|]. - - rewrite Pos.xI_succ_xO at 2. rewrite <- Pos.add_1_r, <- Pos.add_diag. - rewrite 2 Zpower_pos_is_exp, Zpower_pos_1_r. - rewrite Z.mul_mod, (Z.mul_mod (Z.pow_pos a m)) by trivial. - rewrite <- IHm, <- Z.mul_mod by trivial. - simpl. now destruct (Zpow_mod_pos a m n). - - rewrite <- Pos.add_diag at 2. - rewrite Zpower_pos_is_exp. - rewrite Z.mul_mod by trivial. - rewrite <- IHm. - simpl. now destruct (Zpow_mod_pos a m n). - - now rewrite Zpower_pos_1_r. -Qed. - -Theorem Zpow_mod_correct a m n : - n <> 0 -> Zpow_mod a m n = (a ^ m) mod n. -Proof. - intros Hn. destruct m; simpl; trivial. - - apply Zpow_mod_pos_correct; auto with zarith. -Qed. - -(* Complements about power and number theory. *) - -Lemma Zpower_divide p q : 0 < q -> (p | p ^ q). -Proof. - exists (p^(q - 1)). - rewrite Z.mul_comm, <- Z.pow_succ_r by lia; f_equal; lia. -Qed. - -Theorem rel_prime_Zpower_r i p q : - 0 <= i -> rel_prime p q -> rel_prime p (q^i). -Proof. - intros Hi Hpq; pattern i; apply natlike_ind; auto with zarith. - - simpl. apply rel_prime_sym, rel_prime_1. - - clear i Hi. intros i Hi Rec; rewrite Z.pow_succ_r; auto. - apply rel_prime_mult; auto. -Qed. - -Theorem rel_prime_Zpower i j p q : - 0 <= i -> 0 <= j -> rel_prime p q -> rel_prime (p^i) (q^j). -Proof. - intros Hi Hj H. apply rel_prime_Zpower_r; trivial. - apply rel_prime_sym. apply rel_prime_Zpower_r; trivial. - now apply rel_prime_sym. -Qed. - -Theorem prime_power_prime p q n : - 0 <= n -> prime p -> prime q -> (p | q^n) -> p = q. -Proof. - intros Hn Hp Hq; pattern n; apply natlike_ind; auto; clear n Hn. - - simpl; intros. - assert (2<=p) by (apply prime_ge_2; auto). - assert (p<=1) by (apply Z.divide_pos_le; auto with zarith). - lia. - - intros n Hn Rec. - rewrite Z.pow_succ_r by trivial. intros H. - assert (2<=p) by (apply prime_ge_2; auto). - assert (2<=q) by (apply prime_ge_2; auto). - destruct prime_mult with (2 := H); auto. - apply prime_div_prime; auto. -Qed. - -Theorem Zdivide_power_2 x p n : - 0 <= n -> 0 <= x -> prime p -> (x | p^n) -> exists m, x = p^m. -Proof. - intros Hn Hx; revert p n Hn. generalize Hx. - pattern x; apply Z_lt_induction; auto. - clear x Hx; intros x IH Hx p n Hn Hp H. - Z.le_elim Hx; subst. - - apply Z.le_succ_l in Hx; simpl in Hx. - Z.le_elim Hx; subst. - + (* x > 1 *) - case (prime_dec x); intros Hpr. - * exists 1; rewrite Z.pow_1_r; apply prime_power_prime with n; auto. - * case not_prime_divide with (2 := Hpr); auto. - intros p1 ((Hp1, Hpq1),(q1,->)). - assert (Hq1 : 0 < q1) by (apply Z.mul_lt_mono_pos_r with p1; lia). - destruct (IH p1) with p n as (r1,Hr1). 3-4: assumption. 1-2: lia. - -- transitivity (q1 * p1); trivial. exists q1; auto with zarith. - -- destruct (IH q1) with p n as (r2,Hr2). 3-4: assumption. 2: lia. - ++ split. - ** lia. - ** rewrite <- (Z.mul_1_r q1) at 1. - apply Z.mul_lt_mono_pos_l; auto with zarith. - ++ transitivity (q1 * p1); trivial. exists p1; auto with zarith. - ++ exists (r2 + r1); subst. - symmetry. apply Z.pow_add_r. - ** generalize Hq1; case r2; now auto with zarith. - ** generalize Hp1; case r1; now auto with zarith. - + (* x = 1 *) - exists 0; rewrite Z.pow_0_r; auto. - - (* x = 0 *) - exists n; destruct H as [? H]; rewrite Z.mul_0_r in H; auto. -Qed. - -(** * Z.square: a direct definition of [z^2] *) - -Notation Psquare_correct := Pos.square_spec (only parsing). -Notation Zsquare_correct := Z.square_spec (only parsing). diff --git a/stdlib/theories/ZArith/Zpower.v b/stdlib/theories/ZArith/Zpower.v deleted file mode 100644 index e2557e952210..000000000000 --- a/stdlib/theories/ZArith/Zpower.v +++ /dev/null @@ -1,353 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* Z.mul z). - -Lemma Zpower_nat_0_r z : Zpower_nat z 0 = 1. -Proof. reflexivity. Qed. - -Lemma Zpower_nat_succ_r n z : Zpower_nat z (S n) = z * (Zpower_nat z n). -Proof. reflexivity. Qed. - -(** [Zpower_nat_is_exp] says [Zpower_nat] is a morphism for - [plus : nat->nat->nat] and [Z.mul : Z->Z->Z] *) - -Lemma Zpower_nat_is_exp : - forall (n m:nat) (z:Z), - Zpower_nat z (n + m) = Zpower_nat z n * Zpower_nat z m. -Proof. - intros n; induction n as [|n IHn]. - - intros. now rewrite Zpower_nat_0_r, Z.mul_1_l. - - intros. simpl. now rewrite IHn, Z.mul_assoc. -Qed. - -(** Conversions between powers of unary and binary integers *) - -Lemma Zpower_pos_nat (z : Z) (p : positive) : - Z.pow_pos z p = Zpower_nat z (Pos.to_nat p). -Proof. - apply Pos2Nat.inj_iter. -Qed. - -Lemma Zpower_nat_Z (z : Z) (n : nat) : - Zpower_nat z n = z ^ (Z.of_nat n). -Proof. - induction n. - - trivial. - - rewrite Zpower_nat_succ_r, Nat2Z.inj_succ, Z.pow_succ_r. - + now f_equal. - + apply Nat2Z.is_nonneg. -Qed. - -Theorem Zpower_nat_Zpower z n : 0 <= n -> - z^n = Zpower_nat z (Z.abs_nat n). -Proof. - intros. now rewrite Zpower_nat_Z, Zabs2Nat.id_abs, Z.abs_eq. -Qed. - -(** The function [(Z.pow_pos z)] is a morphism - for [Pos.add : positive->positive->positive] and [Z.mul : Z->Z->Z] *) - -Lemma Zpower_pos_is_exp (n m : positive)(z:Z) : - Z.pow_pos z (n + m) = Z.pow_pos z n * Z.pow_pos z m. -Proof. - now apply (Z.pow_add_r z (Zpos n) (Zpos m)). -Qed. - -#[global] -Hint Immediate Zpower_nat_is_exp Zpower_pos_is_exp : zarith. -#[global] -Hint Unfold Z.pow_pos Zpower_nat: zarith. - -Theorem Zpower_exp x n m : - n >= 0 -> m >= 0 -> x ^ (n + m) = x ^ n * x ^ m. -Proof. - Z.swap_greater. apply Z.pow_add_r. -Qed. - -Section Powers_of_2. - - (** * Powers of 2 *) - - (** For the powers of two, that will be widely used, a more direct - calculus is possible. [shift n m] computes [2^n * m], i.e. - [m] shifted by [n] positions *) - - Definition shift_nat (n:nat) (z:positive) := nat_rect _ z (fun _ => xO) n. - Definition shift_pos (n z:positive) := Pos.iter xO z n. - Definition shift (n:Z) (z:positive) := - match n with - | Z0 => z - | Zpos p => Pos.iter xO z p - | Zneg p => z - end. - - Definition two_power_nat (n:nat) := Zpos (shift_nat n 1). - Definition two_power_pos (x:positive) := Zpos (shift_pos x 1). - - Definition two_p (x:Z) := - match x with - | Z0 => 1 - | Zpos y => two_power_pos y - | Zneg y => 0 - end. - - (** Equivalence with notions defined in BinInt *) - - Lemma shift_nat_equiv n p : shift_nat n p = Pos.shiftl_nat p n. - Proof. reflexivity. Qed. - - Lemma shift_pos_equiv n p : shift_pos n p = Pos.shiftl p (Npos n). - Proof. reflexivity. Qed. - - Lemma shift_equiv n p : 0<=n -> Zpos (shift n p) = Z.shiftl (Zpos p) n. - Proof. - destruct n. - - trivial. - - simpl; intros. now apply Pos.iter_swap_gen. - - now destruct 1. - Qed. - - Lemma two_power_nat_equiv n : two_power_nat n = 2 ^ (Z.of_nat n). - Proof. - induction n as [|n IHn]. - - trivial. - - now rewrite Nat2Z.inj_succ, Z.pow_succ_r, <- IHn by apply Nat2Z.is_nonneg. - Qed. - - Lemma two_power_pos_equiv p : two_power_pos p = 2 ^ Zpos p. - Proof. - now apply Pos.iter_swap_gen. - Qed. - - Lemma two_p_equiv x : two_p x = 2 ^ x. - Proof. - destruct x; trivial. apply two_power_pos_equiv. - Qed. - - (** Properties of these old versions of powers of two *) - - Lemma two_power_nat_S n : two_power_nat (S n) = 2 * two_power_nat n. - Proof. reflexivity. Qed. - - Lemma shift_nat_plus n m x : - shift_nat (n + m) x = shift_nat n (shift_nat m x). - Proof. - induction n; simpl; now f_equal. - Qed. - - Theorem shift_nat_correct n x : - Zpos (shift_nat n x) = Zpower_nat 2 n * Zpos x. - Proof. - induction n as [|n IHn]. - - trivial. - - now rewrite Zpower_nat_succ_r, <- Z.mul_assoc, <- IHn. - Qed. - - Theorem two_power_nat_correct n : two_power_nat n = Zpower_nat 2 n. - Proof. - now rewrite two_power_nat_equiv, Zpower_nat_Z. - Qed. - - Lemma shift_pos_nat p x : shift_pos p x = shift_nat (Pos.to_nat p) x. - Proof. - apply Pos2Nat.inj_iter. - Qed. - - Lemma two_power_pos_nat p : two_power_pos p = two_power_nat (Pos.to_nat p). - Proof. - unfold two_power_pos. now rewrite shift_pos_nat. - Qed. - - Theorem shift_pos_correct p x : - Zpos (shift_pos p x) = Z.pow_pos 2 p * Zpos x. - Proof. - now rewrite shift_pos_nat, Zpower_pos_nat, shift_nat_correct. - Qed. - - Theorem two_power_pos_correct x : two_power_pos x = Z.pow_pos 2 x. - Proof. - apply two_power_pos_equiv. - Qed. - - Theorem two_power_pos_is_exp x y : - two_power_pos (x + y) = two_power_pos x * two_power_pos y. - Proof. - rewrite 3 two_power_pos_equiv. now apply (Z.pow_add_r 2 (Zpos x) (Zpos y)). - Qed. - - Lemma two_p_correct x : two_p x = 2^x. - Proof (two_p_equiv x). - - Theorem two_p_is_exp x y : - 0 <= x -> 0 <= y -> two_p (x + y) = two_p x * two_p y. - Proof. - rewrite !two_p_equiv. apply Z.pow_add_r. - Qed. - - Lemma two_p_gt_ZERO x : 0 <= x -> two_p x > 0. - Proof. - Z.swap_greater. rewrite two_p_equiv. now apply Z.pow_pos_nonneg. - Qed. - - Lemma two_p_S x : 0 <= x -> two_p (Z.succ x) = 2 * two_p x. - Proof. - rewrite !two_p_equiv. now apply Z.pow_succ_r. - Qed. - - Lemma two_p_pred x : 0 <= x -> two_p (Z.pred x) < two_p x. - Proof. - rewrite !two_p_equiv. intros. apply Z.pow_lt_mono_r; auto using Z.lt_pred_l. - reflexivity. - Qed. - -End Powers_of_2. - -#[global] -Hint Resolve two_p_gt_ZERO: zarith. -#[global] -Hint Immediate two_p_pred two_p_S: zarith. - -Section power_div_with_rest. - - (** * Division by a power of two. *) - - (** To [x:Z] and [p:positive], [q],[r] are associated such that - [x = 2^p.q + r] and [0 <= r < 2^p] *) - - (** Invariant: [d*q + r = d'*q + r /\ d' = 2*d /\ 0<=r (0, r) - | Zpos xH => (0, d + r) - | Zpos (xI n) => (Zpos n, d + r) - | Zpos (xO n) => (Zpos n, r) - | Zneg xH => (-1, d + r) - | Zneg (xI n) => (Zneg n - 1, d + r) - | Zneg (xO n) => (Zneg n, r) - end, 2 * d). - - Definition Zdiv_rest (x:Z) (p:positive) := - let (qr, d) := Pos.iter Zdiv_rest_aux (x, 0, 1) p in qr. - - Lemma Zdiv_rest_correct1 (x:Z) (p:positive) : - let (_, d) := Pos.iter Zdiv_rest_aux (x, 0, 1) p in - d = two_power_pos p. - Proof. - rewrite Pos2Nat.inj_iter, two_power_pos_nat. - induction (Pos.to_nat p); simpl; trivial. - destruct (nat_rect _ _ _ _) as ((q,r),d). - unfold Zdiv_rest_aux. rewrite two_power_nat_S; now f_equal. - Qed. - - Lemma Zdiv_rest_correct2 (x:Z) (p:positive) : - let '(q,r,d) := Pos.iter Zdiv_rest_aux (x, 0, 1) p in - x = q * d + r /\ 0 <= r < d. - Proof. - apply Pos.iter_invariant; [|rewrite Z.mul_1_r, Z.add_0_r; repeat split; auto; discriminate]. - intros ((q,r),d) (H,(H1',H2')). unfold Zdiv_rest_aux. - assert (H1 : 0 < d) by now apply Z.le_lt_trans with (1 := H1'). - assert (H2 : 0 <= d + r) by now apply Z.add_nonneg_nonneg; auto; apply Z.lt_le_incl. - assert (H3 : d + r < 2 * d) - by now rewrite <-Z.add_diag; apply Z.add_lt_mono_l. - assert (H4 : r < 2 * d) by now - apply Z.lt_le_trans with (1 * d); [ - rewrite Z.mul_1_l; auto | - apply Z.mul_le_mono_nonneg_r; try discriminate; - now apply Z.lt_le_incl]. - destruct q as [ |[q|q| ]|[q|q| ]]. - - repeat split; auto. - - rewrite Pos2Z.inj_xI, Z.mul_add_distr_r in H. - rewrite Z.mul_shuffle3, Z.mul_assoc. - rewrite Z.mul_1_l in H; rewrite Z.add_assoc. - repeat split; auto with zarith. - - rewrite Pos2Z.inj_xO in H. - rewrite Z.mul_shuffle3, Z.mul_assoc. - repeat split; auto. - - rewrite Z.mul_1_l in H; repeat split; auto. - - rewrite Pos2Z.neg_xI, Z.mul_sub_distr_r in H. - rewrite Z.mul_sub_distr_r, Z.mul_shuffle3, Z.mul_assoc. - repeat split; auto. - rewrite !Z.mul_1_l, H, Z.add_assoc. - apply (f_equal2 Z.add); auto. - rewrite <- Z.sub_sub_distr, <- !Z.add_diag, Z.add_simpl_r. - now rewrite Z.mul_1_l. - - rewrite Pos2Z.neg_xO in H. - rewrite Z.mul_shuffle3, Z.mul_assoc. - repeat split; auto. - - repeat split; auto. - rewrite H, (Z.mul_opp_l 1), Z.mul_1_l, Z.add_assoc. - apply (f_equal2 Z.add); auto. - rewrite Z.add_comm, <- Z.add_diag. - rewrite Z.mul_add_distr_l. - replace (-1 * d) with (-d). - + now rewrite Z.add_assoc, Z.add_opp_diag_r . - + now rewrite (Z.mul_opp_l 1), <-(Z.mul_opp_l 1). - Qed. - - (** Old-style rich specification by proof of existence *) - - Inductive Zdiv_rest_proofs (x:Z) (p:positive) : Set := - Zdiv_rest_proof : - forall q r:Z, - x = q * two_power_pos p + r -> - 0 <= r -> r < two_power_pos p -> Zdiv_rest_proofs x p. - - Lemma Zdiv_rest_correct (x:Z) (p:positive) : Zdiv_rest_proofs x p. - Proof. - generalize (Zdiv_rest_correct1 x p); generalize (Zdiv_rest_correct2 x p). - destruct (Pos.iter Zdiv_rest_aux (x, 0, 1) p) as ((q,r),d). - intros (H1,(H2,H3)) ->. now exists q r. - Qed. - - (** Direct correctness of [Zdiv_rest] *) - - Lemma Zdiv_rest_ok x p : - let (q,r) := Zdiv_rest x p in - x = q * 2^(Zpos p) + r /\ 0 <= r < 2^(Zpos p). - Proof. - unfold Zdiv_rest. - generalize (Zdiv_rest_correct1 x p); generalize (Zdiv_rest_correct2 x p). - destruct (Pos.iter Zdiv_rest_aux (x, 0, 1) p) as ((q,r),d). - intros H ->. now rewrite two_power_pos_equiv in H. - Qed. - - (** Equivalence with [Z.shiftr] *) - - Lemma Zdiv_rest_shiftr x p : - fst (Zdiv_rest x p) = Z.shiftr x (Zpos p). - Proof. - generalize (Zdiv_rest_ok x p). destruct (Zdiv_rest x p) as (q,r). - intros (H,H'). simpl. - rewrite Z.shiftr_div_pow2 by easy. - apply Z.div_unique_pos with r; trivial. now rewrite Z.mul_comm. - Qed. - -End power_div_with_rest. diff --git a/stdlib/theories/ZArith/Zquot.v b/stdlib/theories/ZArith/Zquot.v deleted file mode 100644 index ba0502234150..000000000000 --- a/stdlib/theories/ZArith/Zquot.v +++ /dev/null @@ -1,449 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* 0] condition - whenever possible. *) - -Lemma Zrem_0_l a : Z.rem 0 a = 0. -Proof. now destruct a. Qed. - -Lemma Zquot_0_l a : 0Ć·a = 0. -Proof. now destruct a. Qed. - -#[global] -Hint Resolve Zrem_0_l Zrem_0_r Zquot_0_l Zquot_0_r Z.quot_1_r Z.rem_1_r - : zarith. - -Ltac zero_or_not a := - destruct (Z.eq_decidable a 0) as [->|?]; - [rewrite ?Zquot_0_l, ?Zrem_0_l, ?Zquot_0_r, ?Zrem_0_r; - try lia; - auto with zarith|]. - -Lemma Z_rem_same a : Z.rem a a = 0. -Proof. zero_or_not a. now apply Z.rem_same. Qed. - -Lemma Z_rem_mult a b : Z.rem (a*b) b = 0. -Proof. zero_or_not b. now apply Z.rem_mul. Qed. - -(** * Division and Opposite *) - -(* The precise equalities that are invalid with "historic" Zdiv. *) - -Theorem Zquot_opp_l a b : (-a)Ć·b = -(aĆ·b). -Proof. zero_or_not b. now apply Z.quot_opp_l. Qed. - -Theorem Zquot_opp_r a b : aĆ·(-b) = -(aĆ·b). -Proof. zero_or_not b. now apply Z.quot_opp_r. Qed. - -Theorem Zrem_opp_l a b : Z.rem (-a) b = -(Z.rem a b). -Proof. zero_or_not b. now apply Z.rem_opp_l. Qed. - -Theorem Zrem_opp_r a b : Z.rem a (-b) = Z.rem a b. -Proof. zero_or_not b. now apply Z.rem_opp_r. Qed. - -Theorem Zquot_opp_opp a b : (-a)Ć·(-b) = aĆ·b. -Proof. zero_or_not b. now apply Z.quot_opp_opp. Qed. - -Theorem Zrem_opp_opp a b : Z.rem (-a) (-b) = -(Z.rem a b). -Proof. zero_or_not b. now apply Z.rem_opp_opp. Qed. - -(** The sign of the remainder is the one of [a]. Due to the possible - nullity of [a], a general result is to be stated in the following form: -*) - -Theorem Zrem_sgn a b : 0 <= Z.sgn (Z.rem a b) * Z.sgn a. -Proof. - zero_or_not b. - - zero_or_not (Z.rem a b). - rewrite Z.rem_sign_nz; trivial. apply Z.square_nonneg. -Qed. - -(** This can also be said in a simpler way: *) - -Theorem Zrem_sgn2 a b : 0 <= (Z.rem a b) * a. -Proof. - zero_or_not b. - - apply Z.square_nonneg. - - now apply Z.rem_sign_mul. -Qed. - -(** Reformulation of [Z.rem_bound_abs] in 2 then 4 particular cases. *) - -Theorem Zrem_lt_pos a b : 0<=a -> b<>0 -> 0 <= Z.rem a b < Z.abs b. -Proof. - intros; generalize (Z.rem_nonneg a b) (Z.rem_bound_abs a b); - lia. -Qed. - -Theorem Zrem_lt_neg a b : a<=0 -> b<>0 -> -Z.abs b < Z.rem a b <= 0. -Proof. - intros; generalize (Z.rem_nonpos a b) (Z.rem_bound_abs a b); - lia. -Qed. - -Theorem Zrem_lt_pos_pos a b : 0<=a -> 0 0 <= Z.rem a b < b. -Proof. - intros; generalize (Zrem_lt_pos a b); lia. -Qed. - -Theorem Zrem_lt_pos_neg a b : 0<=a -> b<0 -> 0 <= Z.rem a b < -b. -Proof. - intros; generalize (Zrem_lt_pos a b); lia. -Qed. - -Theorem Zrem_lt_neg_pos a b : a<=0 -> 0 -b < Z.rem a b <= 0. -Proof. - intros; generalize (Zrem_lt_neg a b); lia. -Qed. - -Theorem Zrem_lt_neg_neg a b : a<=0 -> b<0 -> b < Z.rem a b <= 0. -Proof. - intros; generalize (Zrem_lt_neg a b); lia. -Qed. - - -(** * Unicity results *) - -Definition Remainder a b r := - (0 <= a /\ 0 <= r < Z.abs b) \/ (a <= 0 /\ -Z.abs b < r <= 0). - -Definition Remainder_alt a b r := - Z.abs r < Z.abs b /\ 0 <= r * a. - -Lemma Remainder_equiv : forall a b r, - Remainder a b r <-> Remainder_alt a b r. -Proof. - unfold Remainder, Remainder_alt; intuition auto with zarith. - - lia. - - lia. - - rewrite <-(Z.mul_opp_opp). apply Z.mul_nonneg_nonneg; lia. - - assert (0 <= Z.sgn r * Z.sgn a). - { rewrite <-Z.sgn_mul, Z.sgn_nonneg; auto. } - destruct r; simpl Z.sgn in *; lia. -Qed. - -Theorem Zquot_mod_unique_full a b q r : - Remainder a b r -> a = b*q + r -> q = aĆ·b /\ r = Z.rem a b. -Proof. - destruct 1 as [(H,H0)|(H,H0)]; intros. - - apply Zdiv_mod_unique with b; auto. - + apply Zrem_lt_pos; auto. - lia. - + rewrite <- H1; apply Z.quot_rem'. - - - rewrite <- (Z.opp_involutive a). - rewrite Zquot_opp_l, Zrem_opp_l. - generalize (Zdiv_mod_unique b (-q) (-aĆ·b) (-r) (Z.rem (-a) b)). - generalize (Zrem_lt_pos (-a) b). - rewrite <-Z.quot_rem', Z.mul_opp_r, <-Z.opp_add_distr, <-H1. - lia. -Qed. - -Theorem Zquot_unique_full a b q r : - Remainder a b r -> a = b*q + r -> q = aĆ·b. -Proof. - intros; destruct (Zquot_mod_unique_full a b q r); auto. -Qed. - -Theorem Zrem_unique_full a b q r : - Remainder a b r -> a = b*q + r -> r = Z.rem a b. -Proof. - intros; destruct (Zquot_mod_unique_full a b q r); auto. -Qed. - -(** * Order results about Zrem and Zquot *) - -(* Division of positive numbers is positive. *) - -Lemma Z_quot_pos a b : 0 <= a -> 0 <= b -> 0 <= aĆ·b. -Proof. intros. zero_or_not b. apply Z.quot_pos; lia. Qed. - -(** As soon as the divisor is greater or equal than 2, - the division is strictly decreasing. *) - -Lemma Z_quot_lt a b : 0 < a -> 2 <= b -> aĆ·b < a. -Proof. intros. apply Z.quot_lt; lia. Qed. - -(** [<=] is compatible with a positive division. *) - -Lemma Z_quot_monotone a b c : 0<=c -> a<=b -> aĆ·c <= bĆ·c. -Proof. intros. zero_or_not c. apply Z.quot_le_mono; lia. Qed. - -(** With our choice of division, rounding of (aĆ·b) is always done toward 0: *) - -Lemma Z_mult_quot_le a b : 0 <= a -> 0 <= b*(aĆ·b) <= a. -Proof. intros. zero_or_not b. apply Z.mul_quot_le; auto with zarith. Qed. - -Lemma Z_mult_quot_ge a b : a <= 0 -> a <= b*(aĆ·b) <= 0. -Proof. intros. zero_or_not b. apply Z.mul_quot_ge; auto with zarith. Qed. - -(** The previous inequalities between [b*(aĆ·b)] and [a] are exact - iff the modulo is zero. *) - -Lemma Z_quot_exact_full a b : a = b*(aĆ·b) <-> Z.rem a b = 0. -Proof. intros. zero_or_not b. apply Z.quot_exact; auto. Qed. - -(** A modulo cannot grow beyond its starting point. *) - -Theorem Zrem_le a b : 0 <= a -> 0 <= b -> Z.rem a b <= a. -Proof. intros. zero_or_not b. apply Z.rem_le; lia. Qed. - -(** Some additional inequalities about Zdiv. *) - -Theorem Zquot_le_upper_bound: - forall a b q, 0 < b -> a <= q*b -> aĆ·b <= q. -Proof. intros a b q; rewrite Z.mul_comm; apply Z.quot_le_upper_bound. Qed. - -Theorem Zquot_lt_upper_bound: - forall a b q, 0 <= a -> 0 < b -> a < q*b -> aĆ·b < q. -Proof. intros a b q; rewrite Z.mul_comm; apply Z.quot_lt_upper_bound. Qed. - -Theorem Zquot_le_lower_bound: - forall a b q, 0 < b -> q*b <= a -> q <= aĆ·b. -Proof. intros a b q; rewrite Z.mul_comm; apply Z.quot_le_lower_bound. Qed. - -Theorem Zquot_sgn: forall a b, - 0 <= Z.sgn (aĆ·b) * Z.sgn a * Z.sgn b. -Proof. - destruct a as [ |a|a]; destruct b as [ |b|b]; simpl; auto with zarith; - unfold Z.quot; simpl; destruct N.pos_div_eucl; simpl; destruct n; simpl; auto with zarith. -Qed. - -(** * Relations between usual operations and Z.modulo and Z.div *) - -(** First, a result that used to be always valid with Zdiv, - but must be restricted here. - For instance, now (9+(-5)*2) rem 2 = -1 <> 1 = 9 rem 2 *) - -Lemma Z_rem_plus : forall a b c:Z, - 0 <= (a+b*c) * a -> - Z.rem (a + b * c) c = Z.rem a c. -Proof. intros. zero_or_not c. apply Z.rem_add; auto with zarith. Qed. - -Lemma Z_quot_plus : forall a b c:Z, - 0 <= (a+b*c) * a -> c<>0 -> - (a + b * c) Ć· c = a Ć· c + b. -Proof. intros. apply Z.quot_add; auto with zarith. Qed. - -Theorem Z_quot_plus_l: forall a b c : Z, - 0 <= (a*b+c)*c -> b<>0 -> - b<>0 -> (a * b + c) Ć· b = a + c Ć· b. -Proof. intros. apply Z.quot_add_l; auto with zarith. Qed. - -(** Cancellations. *) - -Lemma Zquot_mult_cancel_r : forall a b c:Z, - c<>0 -> (a*c)Ć·(b*c) = aĆ·b. -Proof. intros. zero_or_not b. apply Z.quot_mul_cancel_r; auto. Qed. - -Lemma Zquot_mult_cancel_l : forall a b c:Z, - c<>0 -> (c*a)Ć·(c*b) = aĆ·b. -Proof. - intros. rewrite (Z.mul_comm c b). zero_or_not b. - rewrite (Z.mul_comm b c). apply Z.quot_mul_cancel_l; auto. -Qed. - -Lemma Zmult_rem_distr_l: forall a b c, - Z.rem (c*a) (c*b) = c * (Z.rem a b). -Proof. - intros. zero_or_not c. rewrite (Z.mul_comm c b). zero_or_not b. - rewrite (Z.mul_comm b c). apply Z.mul_rem_distr_l; auto. -Qed. - -Lemma Zmult_rem_distr_r: forall a b c, - Z.rem (a*c) (b*c) = (Z.rem a b) * c. -Proof. - intros. zero_or_not b. rewrite (Z.mul_comm b c). zero_or_not c. - rewrite (Z.mul_comm c b). apply Z.mul_rem_distr_r; auto. -Qed. - -(** Operations modulo. *) - -Theorem Zrem_rem: forall a n, Z.rem (Z.rem a n) n = Z.rem a n. -Proof. intros. zero_or_not n. apply Z.rem_rem; auto. Qed. - -Theorem Zmult_rem: forall a b n, - Z.rem (a * b) n = Z.rem (Z.rem a n * Z.rem b n) n. -Proof. intros. zero_or_not n. apply Z.mul_rem; auto. Qed. - -(** addition and modulo - - Generally speaking, unlike with Zdiv, we don't have - (a+b) rem n = (a rem n + b rem n) rem n - for any a and b. - For instance, take (8 + (-10)) rem 3 = -2 whereas - (8 rem 3 + (-10 rem 3)) rem 3 = 1. *) - -Theorem Zplus_rem: forall a b n, - 0 <= a * b -> - Z.rem (a + b) n = Z.rem (Z.rem a n + Z.rem b n) n. -Proof. intros. zero_or_not n. apply Z.add_rem; auto. Qed. - -Lemma Zplus_rem_idemp_l: forall a b n, - 0 <= a * b -> - Z.rem (Z.rem a n + b) n = Z.rem (a + b) n. -Proof. intros. zero_or_not n. apply Z.add_rem_idemp_l; auto. Qed. - -Lemma Zplus_rem_idemp_r: forall a b n, - 0 <= a*b -> - Z.rem (b + Z.rem a n) n = Z.rem (b + a) n. -Proof. - intros. zero_or_not n. apply Z.add_rem_idemp_r; auto. - rewrite Z.mul_comm; auto. -Qed. - -Lemma Zmult_rem_idemp_l: forall a b n, Z.rem (Z.rem a n * b) n = Z.rem (a * b) n. -Proof. intros. zero_or_not n. apply Z.mul_rem_idemp_l; auto. Qed. - -Lemma Zmult_rem_idemp_r: forall a b n, Z.rem (b * Z.rem a n) n = Z.rem (b * a) n. -Proof. intros. zero_or_not n. apply Z.mul_rem_idemp_r; auto. Qed. - -(** Unlike with Zdiv, the following result is true without restrictions. *) - -Lemma Zquot_Zquot : forall a b c, (aĆ·b)Ć·c = aĆ·(b*c). -Proof. - intros. zero_or_not b. rewrite Z.mul_comm. zero_or_not c. - rewrite Z.mul_comm. apply Z.quot_quot; auto. -Qed. - -(** A last inequality: *) - -Theorem Zquot_mult_le: - forall a b c, 0<=a -> 0<=b -> 0<=c -> c*(aĆ·b) <= (c*a)Ć·b. -Proof. intros. zero_or_not b. apply Z.quot_mul_le; lia. Qed. - -(** Z.rem is related to divisibility (see more in Znumtheory) *) - -Lemma Zrem_divides : forall a b, - Z.rem a b = 0 <-> exists c, a = b*c. -Proof. - intros. zero_or_not b. - - firstorder. - - rewrite Z.rem_divide; trivial. - split; intros (c,Hc); exists c; subst; auto with zarith. -Qed. - -(** Particular case : dividing by 2 is related with parity *) - -Lemma Zquot2_odd_remainder : forall a, - Remainder a 2 (if Z.odd a then Z.sgn a else 0). -Proof. - intros [ |p|p]. - - simpl. - left. simpl. auto with zarith. - - left. destruct p; simpl; lia. - - right. destruct p; simpl; split; now auto with zarith. -Qed. - -Lemma Zrem_odd : forall a, Z.rem a 2 = if Z.odd a then Z.sgn a else 0. -Proof. - intros. symmetry. - apply Zrem_unique_full with (Z.quot2 a). - - apply Zquot2_odd_remainder. - - apply Zeven.Zquot2_odd_eqn. -Qed. - -Lemma Zrem_even : forall a, Z.rem a 2 = if Z.even a then 0 else Z.sgn a. -Proof. - intros a. rewrite Zrem_odd, <-Z.negb_even. now destruct Z.even. -Qed. - -Lemma Zeven_rem : forall a, Z.even a = Z.eqb (Z.rem a 2) 0. -Proof. - intros a. rewrite Zrem_even. - destruct a as [ |p|p]; trivial; now destruct p. -Qed. - -Lemma Zodd_rem : forall a, Z.odd a = negb (Z.eqb (Z.rem a 2) 0). -Proof. - intros a. rewrite Zrem_odd. - destruct a as [ |p|p]; trivial; now destruct p. -Qed. - -(** * Interaction with "historic" Zdiv *) - -(** They agree at least on positive numbers: *) - -Theorem Zquotrem_Zdiv_eucl_pos : forall a b:Z, 0 <= a -> 0 < b -> - aĆ·b = a/b /\ Z.rem a b = a mod b. -Proof. - intros. - apply Zdiv_mod_unique with b. - - apply Zrem_lt_pos; lia. - - rewrite Z.abs_eq by lia. apply Z_mod_lt; lia. - - rewrite <- Z_div_mod_eq_full. - symmetry; apply Z.quot_rem; lia. -Qed. - -Theorem Zquot_Zdiv_pos : forall a b, 0 <= a -> 0 <= b -> - aĆ·b = a/b. -Proof. - intros a b Ha Hb. Z.le_elim Hb. - - generalize (Zquotrem_Zdiv_eucl_pos a b Ha Hb); intuition. - - subst; now rewrite Zquot_0_r, Zdiv_0_r. -Qed. - -Theorem Zrem_Zmod_pos : forall a b, 0 <= a -> 0 < b -> - Z.rem a b = a mod b. -Proof. - intros a b Ha Hb; generalize (Zquotrem_Zdiv_eucl_pos a b Ha Hb); - intuition. -Qed. - -(** Modulos are null at the same places *) - -Theorem Zrem_Zmod_zero : forall a b, b<>0 -> - (Z.rem a b = 0 <-> a mod b = 0). -Proof. - intros. - rewrite Zrem_divides, Zmod_divides; intuition. -Qed. diff --git a/stdlib/theories/ZArith/Zwf.v b/stdlib/theories/ZArith/Zwf.v deleted file mode 100644 index 7177fb0141fb..000000000000 --- a/stdlib/theories/ZArith/Zwf.v +++ /dev/null @@ -1,93 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* Acc (Zwf c) a). { - clear a; simple induction n; intros. - - (** n= 0 *) - case H; intros. - + lia. - + apply Acc_intro; unfold Zwf; intros. - lia. - - (** inductive case *) - case H0; clear H0; intro; auto. - apply Acc_intro; intros. - apply H. - unfold Zwf in H1. - case (Z.le_gt_cases c y); intro. 2: lia. - left. - apply Nat.lt_le_trans with (f a); auto with arith. - unfold f. - lia. - } - apply (H (S (f a))); auto. - Qed. - -End wf_proof. - -#[global] -Hint Resolve Zwf_well_founded: datatypes. - - -(** We also define the other family of relations: - - [x (Zwf_up c) y] iff [y < x <= c] - *) - -Definition Zwf_up (c x y:Z) := y < x <= c. - -(** and we prove that [(Zwf_up c)] is well founded *) - -Section wf_proof_up. - - Variable c : Z. - - (** The proof of well-foundness is classic: we do the proof by induction - on a measure in nat, which is here [|c-x|] *) - - Let f (z:Z) := Z.abs_nat (c - z). - - Lemma Zwf_up_well_founded : well_founded (Zwf_up c). - Proof. - apply well_founded_lt_compat with (f := f). - unfold Zwf_up, f. - lia. - Qed. - -End wf_proof_up. - -#[global] -Hint Resolve Zwf_up_well_founded: datatypes. diff --git a/stdlib/theories/ZArith/auxiliary.v b/stdlib/theories/ZArith/auxiliary.v deleted file mode 100644 index b62113f93a3d..000000000000 --- a/stdlib/theories/ZArith/auxiliary.v +++ /dev/null @@ -1,95 +0,0 @@ -(* -*- coding: utf-8 -*- *) -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* Zne (n + - m) 0. -Proof. - unfold Zne. now rewrite <- Z.sub_move_0_r. -Qed. - -Theorem Zegal_left n m : n = m -> n + - m = 0. -Proof. - apply Z.sub_move_0_r. -Qed. - -Theorem Zle_left n m : n <= m -> 0 <= m + - n. -Proof. - apply Z.le_0_sub. -Qed. - -Theorem Zle_left_rev n m : 0 <= m + - n -> n <= m. -Proof. - apply Z.le_0_sub. -Qed. - -Theorem Zlt_left_rev n m : 0 < m + - n -> n < m. -Proof. - apply Z.lt_0_sub. -Qed. - -Theorem Zlt_left_lt n m : n < m -> 0 < m + - n. -Proof. - apply Z.lt_0_sub. -Qed. - -Theorem Zlt_left n m : n < m -> 0 <= m + -1 + - n. -Proof. - intros. rewrite Z.add_shuffle0. change (-1) with (- Z.succ 0). - now apply Z.le_0_sub, Z.le_succ_l, Z.lt_0_sub. -Qed. - -Theorem Zge_left n m : n >= m -> 0 <= n + - m. -Proof. - Z.swap_greater. apply Z.le_0_sub. -Qed. - -Theorem Zgt_left n m : n > m -> 0 <= n + -1 + - m. -Proof. - Z.swap_greater. apply Zlt_left. -Qed. - -Theorem Zgt_left_gt n m : n > m -> n + - m > 0. -Proof. - Z.swap_greater. apply Z.lt_0_sub. -Qed. - -Theorem Zgt_left_rev n m : n + - m > 0 -> n > m. -Proof. - Z.swap_greater. apply Z.lt_0_sub. -Qed. - -Theorem Zle_mult_approx n m p : - n > 0 -> p > 0 -> 0 <= m -> 0 <= m * n + p. -Proof. - Z.swap_greater. intros. Z.order_pos. -Qed. - -Theorem Zmult_le_approx n m p : - n > 0 -> n > p -> 0 <= m * n + p -> 0 <= m. -Proof. - Z.swap_greater. intros. apply Z.lt_succ_r. - apply Z.mul_pos_cancel_r with n; trivial. Z.nzsimpl. - apply Z.le_lt_trans with (m*n+p); trivial. - now apply Z.add_lt_mono_l. -Qed. diff --git a/stdlib/theories/_CoqProject b/stdlib/theories/_CoqProject deleted file mode 100644 index 72435fa4978d..000000000000 --- a/stdlib/theories/_CoqProject +++ /dev/null @@ -1 +0,0 @@ --R . Stdlib diff --git a/stdlib/theories/btauto/Algebra.v b/stdlib/theories/btauto/Algebra.v deleted file mode 100644 index ab74074f46b4..000000000000 --- a/stdlib/theories/btauto/Algebra.v +++ /dev/null @@ -1,595 +0,0 @@ -Require Import Bool PArith DecidableClass Ring Lia. - -Ltac bool := -repeat match goal with -| [ H : ?P && ?Q = true |- _ ] => - apply andb_true_iff in H; destruct H -| |- ?P && ?Q = true => - apply <- andb_true_iff; split -end. - -Arguments decide P /H. - -#[export] -Hint Extern 5 => progress bool : core. - -Ltac define t x H := -set (x := t) in *; assert (H : t = x) by reflexivity; clearbody x. - -Lemma Decidable_sound : forall P (H : Decidable P), - decide P = true -> P. -Proof. -intros P H Hp; apply -> Decidable_spec; assumption. -Qed. - -Lemma Decidable_complete : forall P (H : Decidable P), - P -> decide P = true. -Proof. -intros P H Hp; apply <- Decidable_spec; assumption. -Qed. - -Lemma Decidable_sound_alt : forall P (H : Decidable P), - ~ P -> decide P = false. -Proof. -intros P [wit spec] Hd; destruct wit; simpl; tauto. -Qed. - -Lemma Decidable_complete_alt : forall P (H : Decidable P), - decide P = false -> ~ P. -Proof. - intros P [wit spec] Hd Hc; simpl in *; intuition congruence. -Qed. - -Ltac try_rewrite := -repeat match goal with -| [ H : ?P |- _ ] => rewrite H -end. - -(* We opacify here decide for proofs, and will make it transparent for - reflexive tactics later on. *) - -Global Opaque decide. - -Ltac tac_decide := -match goal with -| [ H : @decide ?P ?D = true |- _ ] => apply (@Decidable_sound P D) in H -| [ H : @decide ?P ?D = false |- _ ] => apply (@Decidable_complete_alt P D) in H -| [ |- @decide ?P ?D = true ] => apply (@Decidable_complete P D) -| [ |- @decide ?P ?D = false ] => apply (@Decidable_sound_alt P D) -| [ |- negb ?b = true ] => apply negb_true_iff -| [ |- negb ?b = false ] => apply negb_false_iff -| [ H : negb ?b = true |- _ ] => apply negb_true_iff in H -| [ H : negb ?b = false |- _ ] => apply negb_false_iff in H -end. - -Ltac try_decide := repeat tac_decide. - -Ltac make_decide P := match goal with -| [ |- context [@decide P ?D] ] => - let b := fresh "b" in - let H := fresh "H" in - define (@decide P D) b H; destruct b; try_decide -| [ X : context [@decide P ?D] |- _ ] => - let b := fresh "b" in - let H := fresh "H" in - define (@decide P D) b H; destruct b; try_decide -end. - -Ltac case_decide := match goal with -| [ |- context [@decide ?P ?D] ] => - let b := fresh "b" in - let H := fresh "H" in - define (@decide P D) b H; destruct b; try_decide -| [ X : context [@decide ?P ?D] |- _ ] => - let b := fresh "b" in - let H := fresh "H" in - define (@decide P D) b H; destruct b; try_decide -| [ |- context [Pos.compare ?x ?y] ] => - destruct (Pos.compare_spec x y); try lia -| [ X : context [Pos.compare ?x ?y] |- _ ] => - destruct (Pos.compare_spec x y); try lia -end. - -Section Definitions. - -(** * Global, inductive definitions. *) - -(** A Horner polynomial is either a constant, or a product P Ɨ (i + Q), where i - is a variable. *) - -Inductive poly := -| Cst : bool -> poly -| Poly : poly -> positive -> poly -> poly. - -(* TODO: We should use [positive] instead of [nat] to encode variables, for - efficiency purpose. *) - -Inductive null : poly -> Prop := -| null_intro : null (Cst false). - -(** Polynomials satisfy a uniqueness condition whenever they are valid. A - polynomial [p] satisfies [valid n p] whenever it is well-formed and each of - its variable indices is < [n]. *) - -Inductive valid : positive -> poly -> Prop := -| valid_cst : forall k c, valid k (Cst c) -| valid_poly : forall k p i q, - Pos.lt i k -> ~ null q -> valid i p -> valid (Pos.succ i) q -> valid k (Poly p i q). - -(** Linear polynomials are valid polynomials in which every variable appears at - most once. *) - -Inductive linear : positive -> poly -> Prop := -| linear_cst : forall k c, linear k (Cst c) -| linear_poly : forall k p i q, Pos.lt i k -> ~ null q -> - linear i p -> linear i q -> linear k (Poly p i q). - -End Definitions. - -Section Computational. - -Program Instance Decidable_PosEq : forall (p q : positive), Decidable (p = q) := - { Decidable_witness := Pos.eqb p q }. -Next Obligation. -apply Pos.eqb_eq. -Qed. - -Program Instance Decidable_PosLt : forall p q, Decidable (Pos.lt p q) := - { Decidable_witness := Pos.ltb p q }. -Next Obligation. -apply Pos.ltb_lt. -Qed. - -Program Instance Decidable_PosLe : forall p q, Decidable (Pos.le p q) := - { Decidable_witness := Pos.leb p q }. -Next Obligation. -apply Pos.leb_le. -Qed. - -(** * The core reflexive part. *) - -#[local] -Hint Constructors valid : core. - -Fixpoint beq_poly pl pr := -match pl with -| Cst cl => - match pr with - | Cst cr => decide (cl = cr) - | Poly _ _ _ => false - end -| Poly pl il ql => - match pr with - | Cst _ => false - | Poly pr ir qr => - decide (il = ir) && beq_poly pl pr && beq_poly ql qr - end -end. - -(* We could do that with [decide equality] but dependency in proofs is heavy *) -Program Instance Decidable_eq_poly : forall (p q : poly), Decidable (eq p q) := { - Decidable_witness := beq_poly p q -}. - -Next Obligation. -split. -- revert q; induction p; intros [] ?; simpl in *; bool; try_decide; - f_equal; first [intuition congruence|auto]. -- revert q; induction p; intros [] Heq; simpl in *; bool; try_decide; intuition; - try injection Heq; first[congruence|intuition]. -Qed. - -Program Instance Decidable_null : forall p, Decidable (null p) := { - Decidable_witness := match p with Cst false => true | _ => false end -}. -Next Obligation. -split. -- destruct p as [[]|]; first [discriminate|constructor]. -- inversion 1; trivial. -Qed. - -Definition list_nth {A} p (l : list A) def := - Pos.peano_rect (fun _ => list A -> A) - (fun l => match l with nil => def | cons t l => t end) - (fun _ F l => match l with nil => def | cons t l => F l end) p l. - -Fixpoint eval var (p : poly) := -match p with -| Cst c => c -| Poly p i q => - let vi := list_nth i var false in - xorb (eval var p) (andb vi (eval var q)) -end. - -Fixpoint valid_dec k p := -match p with -| Cst c => true -| Poly p i q => - negb (decide (null q)) && decide (i < k)%positive && - valid_dec i p && valid_dec (Pos.succ i) q -end. - -Program Instance Decidable_valid : forall n p, Decidable (valid n p) := { - Decidable_witness := valid_dec n p -}. -Next Obligation. -split. -- revert n; induction p; unfold valid_dec in *; intuition; bool; try_decide; auto. -- intros H; induction H; unfold valid_dec in *; bool; try_decide; auto. -Qed. - -(** Basic algebra *) - -(* Addition of polynomials *) - -Fixpoint poly_add pl {struct pl} := -match pl with -| Cst cl => - fix F pr := match pr with - | Cst cr => Cst (xorb cl cr) - | Poly pr ir qr => Poly (F pr) ir qr - end -| Poly pl il ql => - fix F pr {struct pr} := match pr with - | Cst cr => Poly (poly_add pl pr) il ql - | Poly pr ir qr => - match Pos.compare il ir with - | Eq => - let qs := poly_add ql qr in - (* Ensure validity *) - if decide (null qs) then poly_add pl pr - else Poly (poly_add pl pr) il qs - | Gt => Poly (poly_add pl (Poly pr ir qr)) il ql - | Lt => Poly (F pr) ir qr - end - end -end. - -(* Multiply a polynomial by a constant *) - -Fixpoint poly_mul_cst v p := -match p with -| Cst c => Cst (andb c v) -| Poly p i q => - let r := poly_mul_cst v q in - (* Ensure validity *) - if decide (null r) then poly_mul_cst v p - else Poly (poly_mul_cst v p) i r -end. - -(* Multiply a polynomial by a monomial *) - -Fixpoint poly_mul_mon k p := -match p with -| Cst c => - if decide (null p) then p - else Poly (Cst false) k p -| Poly p i q => - if decide (i <= k)%positive then Poly (Cst false) k (Poly p i q) - else Poly (poly_mul_mon k p) i (poly_mul_mon k q) -end. - -(* Multiplication of polynomials *) - -Fixpoint poly_mul pl {struct pl} := -match pl with -| Cst cl => poly_mul_cst cl -| Poly pl il ql => - fun pr => - (* Multiply by a factor *) - let qs := poly_mul ql pr in - (* Ensure validity *) - if decide (null qs) then poly_mul pl pr - else poly_add (poly_mul pl pr) (poly_mul_mon il qs) -end. - -(** Quotienting a polynomial by the relation X_i^2 ~ X_i *) - -(* Remove the multiple occurrences of monomials x_k *) - -Fixpoint reduce_aux k p := -match p with -| Cst c => Cst c -| Poly p i q => - if decide (i = k) then poly_add (reduce_aux k p) (reduce_aux k q) - else - let qs := reduce_aux i q in - (* Ensure validity *) - if decide (null qs) then (reduce_aux k p) - else Poly (reduce_aux k p) i qs -end. - -(* Rewrite any x_k ^ {n + 1} to x_k *) - -Fixpoint reduce p := -match p with -| Cst c => Cst c -| Poly p i q => - let qs := reduce_aux i q in - (* Ensure validity *) - if decide (null qs) then reduce p - else Poly (reduce p) i qs -end. - -End Computational. - -Section Validity. - -(* Decision procedure of validity *) - -#[local] -Hint Constructors valid linear : core. - -Lemma valid_le_compat : forall k l p, valid k p -> (k <= l)%positive -> valid l p. -Proof. -intros k l p H Hl; induction H; constructor; eauto. -now eapply Pos.lt_le_trans; eassumption. -Qed. - -Lemma linear_le_compat : forall k l p, linear k p -> (k <= l)%positive -> linear l p. -Proof. -intros k l p H; revert l; induction H; constructor; eauto; lia. -Qed. - -Lemma linear_valid_incl : forall k p, linear k p -> valid k p. -Proof. -intros k p H; induction H; constructor; auto. -eapply valid_le_compat; eauto; lia. -Qed. - -End Validity. - -Section Evaluation. - -(* Useful simple properties *) - -Lemma eval_null_zero : forall p var, null p -> eval var p = false. -Proof. -intros p var []; reflexivity. -Qed. - -Lemma eval_extensional_eq_compat : forall p var1 var2, - (forall x, list_nth x var1 false = list_nth x var2 false) -> eval var1 p = eval var2 p. -Proof. -intros p var1 var2 H; induction p; simpl; try_rewrite; auto. -Qed. - -Lemma eval_suffix_compat : forall k p var1 var2, - (forall i, (i < k)%positive -> list_nth i var1 false = list_nth i var2 false) -> valid k p -> - eval var1 p = eval var2 p. -Proof. -intros k p var1 var2 Hvar Hv; revert var1 var2 Hvar. -induction Hv; intros var1 var2 Hvar; simpl; [now auto|]. -rewrite Hvar; [|now auto]; erewrite (IHHv1 var1 var2). - + erewrite (IHHv2 var1 var2); [ring|]. - intros; apply Hvar; lia. - + intros; apply Hvar; lia. -Qed. - -End Evaluation. - -Section Algebra. - -(* Compatibility with evaluation *) - -Lemma poly_add_compat : forall pl pr var, eval var (poly_add pl pr) = xorb (eval var pl) (eval var pr). -Proof. -intros pl; induction pl; intros pr var; simpl. -- induction pr; simpl; auto; solve [try_rewrite; ring]. -- induction pr; simpl; auto; try solve [try_rewrite; simpl; ring]. - destruct (Pos.compare_spec p p0); repeat case_decide; simpl; first [try_rewrite; ring|idtac]. - + try_rewrite; ring_simplify; repeat rewrite xorb_assoc. - match goal with [ |- context [xorb (andb ?b1 ?b2) (andb ?b1 ?b3)] ] => - replace (xorb (andb b1 b2) (andb b1 b3)) with (andb b1 (xorb b2 b3)) by ring - end. - rewrite <- IHpl2. - match goal with [ H : null ?p |- _ ] => rewrite (eval_null_zero _ _ H) end; ring. - + simpl; rewrite IHpl1; simpl; ring. -Qed. - -Lemma poly_mul_cst_compat : forall v p var, - eval var (poly_mul_cst v p) = andb v (eval var p). -Proof. -intros v p; induction p; intros var; simpl; [ring|]. -case_decide; simpl; try_rewrite; [ring_simplify|ring]. -replace (v && list_nth p2 var false && eval var p3) with (list_nth p2 var false && (v && eval var p3)) by ring. -rewrite <- IHp2; inversion H; simpl; ring. -Qed. - -Lemma poly_mul_mon_compat : forall i p var, - eval var (poly_mul_mon i p) = (list_nth i var false && eval var p). -Proof. -intros i p var; induction p; simpl; case_decide; simpl; try_rewrite; try ring. -inversion H; ring. -Qed. - -Lemma poly_mul_compat : forall pl pr var, eval var (poly_mul pl pr) = andb (eval var pl) (eval var pr). -Proof. -intros pl; induction pl; intros pr var; simpl. -- apply poly_mul_cst_compat. -- case_decide; simpl. - + rewrite IHpl1; ring_simplify. - replace (eval var pr && list_nth p var false && eval var pl2) - with (list_nth p var false && (eval var pl2 && eval var pr)) by ring. - now rewrite <- IHpl2; inversion H; simpl; ring. - + rewrite poly_add_compat, poly_mul_mon_compat, IHpl1, IHpl2; ring. -Qed. - -#[local] -Hint Extern 5 => -match goal with -| [ |- (Pos.max ?x ?y <= ?z)%positive ] => - apply Pos.max_case_strong; intros; lia -| [ |- (?z <= Pos.max ?x ?y)%positive ] => - apply Pos.max_case_strong; intros; lia -| [ |- (Pos.max ?x ?y < ?z)%positive ] => - apply Pos.max_case_strong; intros; lia -| [ |- (?z < Pos.max ?x ?y)%positive ] => - apply Pos.max_case_strong; intros; lia -| _ => lia -end : core. -#[local] -Hint Resolve Pos.le_max_r Pos.le_max_l : core. - -#[local] -Hint Constructors valid linear : core. - -(* Compatibility of validity w.r.t algebraic operations *) - -Lemma poly_add_valid_compat : forall kl kr pl pr, valid kl pl -> valid kr pr -> - valid (Pos.max kl kr) (poly_add pl pr). -Proof. -intros kl kr pl pr Hl Hr; revert kr pr Hr; induction Hl; intros kr pr Hr; simpl. -{ eapply valid_le_compat; [clear k|apply Pos.le_max_r]. - now induction Hr; auto. } -{ assert (Hle : (Pos.max (Pos.succ i) kr <= Pos.max k kr)%positive) by auto. - apply (valid_le_compat (Pos.max (Pos.succ i) kr)); [|assumption]. - clear - IHHl1 IHHl2 Hl2 Hr H0; induction Hr. - - constructor; auto. - now rewrite <- (Pos.max_id i); intuition. - - destruct (Pos.compare_spec i i0); subst; try case_decide; repeat (constructor; intuition). - + apply (valid_le_compat (Pos.max i0 i0)); [now auto|]; rewrite Pos.max_id; auto. - + apply (valid_le_compat (Pos.max i0 i0)); [now auto|]; rewrite Pos.max_id; lia. - + apply (valid_le_compat (Pos.max (Pos.succ i0) (Pos.succ i0))); [now auto|]; rewrite Pos.max_id; lia. - + apply (valid_le_compat (Pos.max (Pos.succ i) i0)); intuition. - + apply (valid_le_compat (Pos.max i (Pos.succ i0))); intuition. -} -Qed. - -Lemma poly_mul_cst_valid_compat : forall k v p, valid k p -> valid k (poly_mul_cst v p). -Proof. -intros k v p H; induction H; simpl; [now auto|]. -case_decide; [|now auto]. -eapply (valid_le_compat i); [now auto|lia]. -Qed. - -Lemma poly_mul_mon_null_compat : forall i p, null (poly_mul_mon i p) -> null p. -Proof. -intros i p; induction p; simpl; case_decide; simpl; inversion 1; intuition. -Qed. - -Lemma poly_mul_mon_valid_compat : forall k i p, - valid k p -> valid (Pos.max (Pos.succ i) k) (poly_mul_mon i p). -Proof. -intros k i p H; induction H; simpl poly_mul_mon; case_decide; intuition. -+ apply (valid_le_compat (Pos.succ i)); auto; constructor; intuition. - - match goal with [ H : null ?p |- _ ] => solve[inversion H] end. -+ apply (valid_le_compat k); auto; constructor; intuition. - - assert (X := poly_mul_mon_null_compat); intuition eauto. - - enough (Pos.max (Pos.succ i) i0 = i0) as <-; intuition. - - enough (Pos.max (Pos.succ i) (Pos.succ i0) = Pos.succ i0) as <-; intuition. -Qed. - -Lemma poly_mul_valid_compat : forall kl kr pl pr, valid kl pl -> valid kr pr -> - valid (Pos.max kl kr) (poly_mul pl pr). -Proof. -intros kl kr pl pr Hl Hr; revert kr pr Hr. -induction Hl; intros kr pr Hr; simpl. -+ apply poly_mul_cst_valid_compat; auto. - apply (valid_le_compat kr); now auto. -+ apply (valid_le_compat (Pos.max (Pos.max i kr) (Pos.max (Pos.succ i) (Pos.max (Pos.succ i) kr)))). - - case_decide. - { apply (valid_le_compat (Pos.max i kr)); auto. } - { apply poly_add_valid_compat; auto. - now apply poly_mul_mon_valid_compat; intuition. } - - repeat apply Pos.max_case_strong; lia. -Qed. - -(* Compatibility of linearity wrt to linear operations *) - -Lemma poly_add_linear_compat : forall kl kr pl pr, linear kl pl -> linear kr pr -> - linear (Pos.max kl kr) (poly_add pl pr). -Proof. -intros kl kr pl pr Hl; revert kr pr; induction Hl; intros kr pr Hr; simpl. -+ apply (linear_le_compat kr); [|apply Pos.max_case_strong; lia]. - now induction Hr; constructor; auto. -+ apply (linear_le_compat (Pos.max kr (Pos.succ i))); [|now auto]. - induction Hr; simpl. - - constructor; auto. - replace i with (Pos.max i i) by (apply Pos.max_id); intuition. - - destruct (Pos.compare_spec i i0); subst; try case_decide; repeat (constructor; intuition). - { apply (linear_le_compat (Pos.max i0 i0)); [now auto|]; rewrite Pos.max_id; auto. } - { apply (linear_le_compat (Pos.max i0 i0)); [now auto|]; rewrite Pos.max_id; auto. } - { apply (linear_le_compat (Pos.max i0 i0)); [now auto|]; rewrite Pos.max_id; auto. } - { apply (linear_le_compat (Pos.max i0 (Pos.succ i))); intuition. } - { apply (linear_le_compat (Pos.max i (Pos.succ i0))); intuition. } -Qed. - -End Algebra. - -Section Reduce. - -(* A stronger version of the next lemma *) - -Lemma reduce_aux_eval_compat : forall k p var, valid (Pos.succ k) p -> - (list_nth k var false && eval var (reduce_aux k p) = list_nth k var false && eval var p). -Proof. -intros k p var; revert k; induction p; intros k Hv; simpl; auto. -inversion Hv; case_decide; subst. -+ rewrite poly_add_compat; ring_simplify. - specialize (IHp1 k); specialize (IHp2 k). - destruct (list_nth k var false); ring_simplify; [|now auto]. - rewrite <- (andb_true_l (eval var p1)), <- (andb_true_l (eval var p3)). - rewrite <- IHp2; auto; rewrite <- IHp1; [ring|]. - apply (valid_le_compat k); [now auto|lia]. -+ remember (list_nth k var false) as b; destruct b; ring_simplify; [|now auto]. - case_decide; simpl. - - rewrite <- (IHp2 p2); [inversion H|now auto]; simpl. - replace (eval var p1) with (list_nth k var false && eval var p1) by (rewrite <- Heqb; ring); rewrite <- (IHp1 k). - { rewrite <- Heqb; ring. } - { apply (valid_le_compat p2); [auto|lia]. } - - rewrite (IHp2 p2); [|now auto]. - replace (eval var p1) with (list_nth k var false && eval var p1) by (rewrite <- Heqb; ring). - rewrite <- (IHp1 k); [rewrite <- Heqb; ring|]. - apply (valid_le_compat p2); [auto|lia]. -Qed. - -(* Reduction preserves evaluation by boolean assignations *) - -Lemma reduce_eval_compat : forall k p var, valid k p -> - eval var (reduce p) = eval var p. -Proof. -intros k p var H; induction H; simpl; auto. -case_decide; try_rewrite; simpl. -+ rewrite <- reduce_aux_eval_compat; auto; inversion H3; simpl; ring. -+ repeat rewrite reduce_aux_eval_compat; try_rewrite; now auto. -Qed. - -Lemma reduce_aux_le_compat : forall k l p, valid k p -> (k <= l)%positive -> - reduce_aux l p = reduce_aux k p. -Proof. -intros k l p; revert k l; induction p; intros k l H Hle; simpl; auto. -inversion H; subst; repeat case_decide; subst; try lia. -+ apply IHp1; [|now auto]; eapply valid_le_compat; [eauto|lia]. -+ f_equal; apply IHp1; auto. - now eapply valid_le_compat; [eauto|lia]. -Qed. - -(* Reduce projects valid polynomials into linear ones *) - -Lemma linear_reduce_aux : forall i p, valid (Pos.succ i) p -> linear i (reduce_aux i p). -Proof. -intros i p; revert i; induction p; intros i Hp; simpl. -+ constructor. -+ inversion Hp; subst; case_decide; subst. - - rewrite <- (Pos.max_id i) at 1; apply poly_add_linear_compat. - { apply IHp1; eapply valid_le_compat; [eassumption|lia]. } - { intuition. } - - case_decide. - { apply IHp1; eapply valid_le_compat; [eauto|lia]. } - { constructor; try lia; auto. - erewrite (reduce_aux_le_compat p2); [|assumption|lia]. - apply IHp1; eapply valid_le_compat; [eauto|]; lia. } -Qed. - -Lemma linear_reduce : forall k p, valid k p -> linear k (reduce p). -Proof. -intros k p H; induction H; simpl. -+ now constructor. -+ case_decide. - - eapply linear_le_compat; [eauto|lia]. - - constructor; auto. - apply linear_reduce_aux; auto. -Qed. - -End Reduce. diff --git a/stdlib/theories/btauto/Btauto.v b/stdlib/theories/btauto/Btauto.v deleted file mode 100644 index 16d92e1cf18c..000000000000 --- a/stdlib/theories/btauto/Btauto.v +++ /dev/null @@ -1,3 +0,0 @@ -Require Import Algebra Reflect. - -Declare ML Module "rocq-runtime.plugins.btauto". diff --git a/stdlib/theories/btauto/Reflect.v b/stdlib/theories/btauto/Reflect.v deleted file mode 100644 index 8f19c0c833ad..000000000000 --- a/stdlib/theories/btauto/Reflect.v +++ /dev/null @@ -1,410 +0,0 @@ -Require Import Bool DecidableClass Algebra Ring PArith Lia. - -Section Bool. - -(* Boolean formulas and their evaluations *) - -Inductive formula := -| formula_var : positive -> formula -| formula_btm : formula -| formula_top : formula -| formula_cnj : formula -> formula -> formula -| formula_dsj : formula -> formula -> formula -| formula_neg : formula -> formula -| formula_xor : formula -> formula -> formula -| formula_ifb : formula -> formula -> formula -> formula. - -Fixpoint formula_eval var f := match f with -| formula_var x => list_nth x var false -| formula_btm => false -| formula_top => true -| formula_cnj fl fr => (formula_eval var fl) && (formula_eval var fr) -| formula_dsj fl fr => (formula_eval var fl) || (formula_eval var fr) -| formula_neg f => negb (formula_eval var f) -| formula_xor fl fr => xorb (formula_eval var fl) (formula_eval var fr) -| formula_ifb fc fl fr => - if formula_eval var fc then formula_eval var fl else formula_eval var fr -end. - -End Bool. - -(* Translation of formulas into polynomials *) - -Section Translation. - -(* This is straightforward. *) - -Fixpoint poly_of_formula f := match f with -| formula_var x => Poly (Cst false) x (Cst true) -| formula_btm => Cst false -| formula_top => Cst true -| formula_cnj fl fr => - let pl := poly_of_formula fl in - let pr := poly_of_formula fr in - poly_mul pl pr -| formula_dsj fl fr => - let pl := poly_of_formula fl in - let pr := poly_of_formula fr in - poly_add (poly_add pl pr) (poly_mul pl pr) -| formula_neg f => poly_add (Cst true) (poly_of_formula f) -| formula_xor fl fr => poly_add (poly_of_formula fl) (poly_of_formula fr) -| formula_ifb fc fl fr => - let pc := poly_of_formula fc in - let pl := poly_of_formula fl in - let pr := poly_of_formula fr in - poly_add pr (poly_add (poly_mul pc pl) (poly_mul pc pr)) -end. - -Opaque poly_add. - -(* Compatibility of translation wrt evaluation *) - -Lemma poly_of_formula_eval_compat : forall var f, - eval var (poly_of_formula f) = formula_eval var f. -Proof. -intros var f; induction f; simpl poly_of_formula; simpl formula_eval; auto. -- now simpl; match goal with [ |- ?t = ?u ] => destruct u; reflexivity end. -- rewrite poly_mul_compat, IHf1, IHf2; ring. -- repeat rewrite poly_add_compat. - rewrite poly_mul_compat; try_rewrite. - now match goal with [ |- ?t = ?x || ?y ] => destruct x; destruct y; reflexivity end. -- rewrite poly_add_compat; try_rewrite. - now match goal with [ |- ?t = negb ?x ] => destruct x; reflexivity end. -- rewrite poly_add_compat; congruence. -- rewrite ?poly_add_compat, ?poly_mul_compat; try_rewrite. - match goal with - [ |- ?t = if ?b1 then ?b2 else ?b3 ] => destruct b1; destruct b2; destruct b3; reflexivity - end. -Qed. - -#[local] -Hint Extern 5 => change 0 with (min 0 0) : core. -Local Hint Resolve poly_add_valid_compat poly_mul_valid_compat : core. -Local Hint Constructors valid : core. -#[local] -Hint Extern 5 => lia : core. - -(* Compatibility with validity *) - -Lemma poly_of_formula_valid_compat : forall f, exists n, valid n (poly_of_formula f). -Proof. -intros f; induction f; simpl. -+ exists (Pos.succ p); constructor; intuition; inversion H. -+ exists 1%positive; auto. -+ exists 1%positive; auto. -+ destruct IHf1 as [n1 Hn1]; destruct IHf2 as [n2 Hn2]; exists (Pos.max n1 n2); auto. -+ destruct IHf1 as [n1 Hn1]; destruct IHf2 as [n2 Hn2]; exists (Pos.max (Pos.max n1 n2) (Pos.max n1 n2)); auto. -+ destruct IHf as [n Hn]; exists (Pos.max 1 n); auto. -+ destruct IHf1 as [n1 Hn1]; destruct IHf2 as [n2 Hn2]; exists (Pos.max n1 n2); auto. -+ destruct IHf1 as [n1 Hn1]; destruct IHf2 as [n2 Hn2]; destruct IHf3 as [n3 Hn3]; eexists; eauto. -Qed. - -(* The soundness lemma ; alas not complete! *) - -Lemma poly_of_formula_sound : forall fl fr var, - poly_of_formula fl = poly_of_formula fr -> formula_eval var fl = formula_eval var fr. -Proof. -intros fl fr var Heq. -repeat rewrite <- poly_of_formula_eval_compat. -rewrite Heq; reflexivity. -Qed. - -End Translation. - -Section Completeness. - -(* Lemma reduce_poly_of_formula_simpl : forall fl fr var, - simpl_eval (var_of_list var) (reduce (poly_of_formula fl)) = simpl_eval (var_of_list var) (reduce (poly_of_formula fr)) -> - formula_eval var fl = formula_eval var fr. -Proof. -intros fl fr var Hrw. -do 2 rewrite <- poly_of_formula_eval_compat. -destruct (poly_of_formula_valid_compat fl) as [nl Hl]. -destruct (poly_of_formula_valid_compat fr) as [nr Hr]. -rewrite <- (reduce_eval_compat nl (poly_of_formula fl)); [|assumption]. -rewrite <- (reduce_eval_compat nr (poly_of_formula fr)); [|assumption]. -do 2 rewrite <- eval_simpl_eval_compat; assumption. -Qed. *) - -(* Soundness of the method ; immediate *) - -Lemma reduce_poly_of_formula_sound : forall fl fr var, - reduce (poly_of_formula fl) = reduce (poly_of_formula fr) -> - formula_eval var fl = formula_eval var fr. -Proof. -intros fl fr var Heq. -repeat rewrite <- poly_of_formula_eval_compat. -destruct (poly_of_formula_valid_compat fl) as [nl Hl]. -destruct (poly_of_formula_valid_compat fr) as [nr Hr]. -rewrite <- (reduce_eval_compat nl (poly_of_formula fl)); auto. -rewrite <- (reduce_eval_compat nr (poly_of_formula fr)); auto. -rewrite Heq; reflexivity. -Qed. - -Definition make_last {A} n (x def : A) := - Pos.peano_rect (fun _ => list A) - (cons x nil) - (fun _ F => cons def F) n. - -(* Replace the nth element of a list *) - -Fixpoint list_replace l n b := -match l with -| nil => make_last n b false -| cons a l => - Pos.peano_rect _ - (cons b l) (fun n _ => cons a (list_replace l n b)) n -end. - -(** Extract a non-null witness from a polynomial *) - -Existing Instance Decidable_null. - -Fixpoint boolean_witness p := -match p with -| Cst c => nil -| Poly p i q => - if decide (null p) then - let var := boolean_witness q in - list_replace var i true - else - let var := boolean_witness p in - list_replace var i false -end. - -Lemma list_nth_base : forall A (def : A) l, - list_nth 1 l def = match l with nil => def | cons x _ => x end. -Proof. -intros A def l; unfold list_nth. -rewrite Pos.peano_rect_base; reflexivity. -Qed. - -Lemma list_nth_succ : forall A n (def : A) l, - list_nth (Pos.succ n) l def = - match l with nil => def | cons _ l => list_nth n l def end. -Proof. -intros A def l; unfold list_nth. -rewrite Pos.peano_rect_succ; reflexivity. -Qed. - -Lemma list_nth_nil : forall A n (def : A), - list_nth n nil def = def. -Proof. -intros A n def; induction n using Pos.peano_rect. -+ rewrite list_nth_base; reflexivity. -+ rewrite list_nth_succ; reflexivity. -Qed. - -Lemma make_last_nth_1 : forall A n i x def, i <> n -> - list_nth i (@make_last A n x def) def = def. -Proof. -intros A n; induction n using Pos.peano_rect; intros i x def Hd; - unfold make_last; simpl. -+ induction i using Pos.peano_case; [elim Hd; reflexivity|]. - rewrite list_nth_succ, list_nth_nil; reflexivity. -+ unfold make_last; rewrite Pos.peano_rect_succ; fold (make_last n x def). - induction i using Pos.peano_case. - - rewrite list_nth_base; reflexivity. - - rewrite list_nth_succ; apply IHn; lia. -Qed. - -Lemma make_last_nth_2 : forall A n x def, list_nth n (@make_last A n x def) def = x. -Proof. -intros A n; induction n using Pos.peano_rect; intros x def; simpl. -+ reflexivity. -+ unfold make_last; rewrite Pos.peano_rect_succ; fold (make_last n x def). - rewrite list_nth_succ; auto. -Qed. - -Lemma list_replace_nth_1 : forall var i j x, i <> j -> - list_nth i (list_replace var j x) false = list_nth i var false. -Proof. -intros var; induction var; intros i j x Hd; simpl. -+ rewrite make_last_nth_1, list_nth_nil; auto. -+ induction j using Pos.peano_rect. - - rewrite Pos.peano_rect_base. - induction i using Pos.peano_rect; [now elim Hd; auto|]. - rewrite 2list_nth_succ; reflexivity. - - rewrite Pos.peano_rect_succ. - induction i using Pos.peano_rect. - { rewrite 2list_nth_base; reflexivity. } - { rewrite 2list_nth_succ; apply IHvar; lia. } -Qed. - -Lemma list_replace_nth_2 : forall var i x, list_nth i (list_replace var i x) false = x. -Proof. -intros var; induction var; intros i x; simpl. -+ now apply make_last_nth_2. -+ induction i using Pos.peano_rect. - - rewrite Pos.peano_rect_base, list_nth_base; reflexivity. - - rewrite Pos.peano_rect_succ, list_nth_succ; auto. -Qed. - -(* The witness is correct only if the polynomial is linear *) - -Lemma boolean_witness_nonzero : forall k p, linear k p -> ~ null p -> - eval (boolean_witness p) p = true. -Proof. -intros k p Hl Hp; induction Hl; simpl. -- destruct c; [reflexivity|elim Hp; now constructor]. -- case_decide. - + rewrite eval_null_zero; [|assumption]; rewrite list_replace_nth_2; simpl. - erewrite eval_suffix_compat; [now eauto| |now apply linear_valid_incl; eauto]. - now intros j Hd; apply list_replace_nth_1; lia. - + rewrite list_replace_nth_2, xorb_false_r. - erewrite eval_suffix_compat; [now eauto| |now apply linear_valid_incl; eauto]. - now intros j Hd; apply list_replace_nth_1; lia. -Qed. - -(* This should be better when using the [vm_compute] tactic instead of plain reflexivity. *) - -Lemma reduce_poly_of_formula_sound_alt : forall var fl fr, - reduce (poly_add (poly_of_formula fl) (poly_of_formula fr)) = Cst false -> - formula_eval var fl = formula_eval var fr. -Proof. -intros var fl fr Heq. -repeat rewrite <- poly_of_formula_eval_compat. -destruct (poly_of_formula_valid_compat fl) as [nl Hl]. -destruct (poly_of_formula_valid_compat fr) as [nr Hr]. -rewrite <- (reduce_eval_compat nl (poly_of_formula fl)); auto. -rewrite <- (reduce_eval_compat nr (poly_of_formula fr)); auto. -rewrite <- xorb_false_l; change false with (eval var (Cst false)). -rewrite <- poly_add_compat, <- Heq. -repeat rewrite poly_add_compat. -rewrite (reduce_eval_compat nl); [|assumption]. -rewrite (reduce_eval_compat (Pos.max nl nr)); [|apply poly_add_valid_compat; assumption]. -rewrite (reduce_eval_compat nr); [|assumption]. -rewrite poly_add_compat; ring. -Qed. - -(* The completeness lemma *) - -(* Lemma reduce_poly_of_formula_complete : forall fl fr, - reduce (poly_of_formula fl) <> reduce (poly_of_formula fr) -> - {var | formula_eval var fl <> formula_eval var fr}. -Proof. -intros fl fr H. -pose (p := poly_add (reduce (poly_of_formula fl)) (poly_opp (reduce (poly_of_formula fr)))). -pose (var := boolean_witness p). -exists var. - intros Hc; apply (f_equal Z_of_bool) in Hc. - assert (Hfl : linear 0 (reduce (poly_of_formula fl))). - now destruct (poly_of_formula_valid_compat fl) as [n Hn]; apply (linear_le_compat n); [|now auto]; apply linear_reduce; auto. - assert (Hfr : linear 0 (reduce (poly_of_formula fr))). - now destruct (poly_of_formula_valid_compat fr) as [n Hn]; apply (linear_le_compat n); [|now auto]; apply linear_reduce; auto. - repeat rewrite <- poly_of_formula_eval_compat in Hc. - define (decide (null p)) b Hb; destruct b; tac_decide. - now elim H; apply (null_sub_implies_eq 0 0); fold p; auto; - apply linear_valid_incl; auto. - elim (boolean_witness_nonzero 0 p); auto. - unfold p; rewrite <- (min_id 0); apply poly_add_linear_compat; try apply poly_opp_linear_compat; now auto. - unfold p at 2; rewrite poly_add_compat, poly_opp_compat. - destruct (poly_of_formula_valid_compat fl) as [nl Hnl]. - destruct (poly_of_formula_valid_compat fr) as [nr Hnr]. - repeat erewrite reduce_eval_compat; eauto. - fold var; rewrite Hc; ring. -Defined. *) - -End Completeness. - -(* Reification tactics *) - -(* For reflexivity purposes, that would better be transparent *) - -Global Transparent decide poly_add. - -(* Ltac append_var x l k := -match l with -| nil => constr: (k, cons x l) -| cons x _ => constr: (k, l) -| cons ?y ?l => - let ans := append_var x l (S k) in - match ans with (?k, ?l) => constr: (k, cons y l) end -end. - -Ltac build_formula t l := -match t with -| true => constr: (formula_top, l) -| false => constr: (formula_btm, l) -| ?fl && ?fr => - match build_formula fl l with (?tl, ?l) => - match build_formula fr l with (?tr, ?l) => - constr: (formula_cnj tl tr, l) - end - end -| ?fl || ?fr => - match build_formula fl l with (?tl, ?l) => - match build_formula fr l with (?tr, ?l) => - constr: (formula_dsj tl tr, l) - end - end -| negb ?f => - match build_formula f l with (?t, ?l) => - constr: (formula_neg t, l) - end -| _ => - let ans := append_var t l 0 in - match ans with (?k, ?l) => constr: (formula_var k, l) end -end. - -(* Extract a counterexample from a polynomial and display it *) - -Ltac counterexample p l := - let var := constr: (boolean_witness p) in - let var := eval vm_compute in var in - let rec print l vl := - match l with - | nil => idtac - | cons ?x ?l => - match vl with - | nil => - idtac x ":=" "false"; print l (@nil bool) - | cons ?v ?vl => - idtac x ":=" v; print l vl - end - end - in - idtac "Counter-example:"; print l var. - -Ltac btauto_reify := -lazymatch goal with -| [ |- @eq bool ?t ?u ] => - lazymatch build_formula t (@nil bool) with - | (?fl, ?l) => - lazymatch build_formula u l with - | (?fr, ?l) => - change (formula_eval l fl = formula_eval l fr) - end - end -| _ => fail "Cannot recognize a boolean equality" -end. - -(* The long-awaited tactic *) - -Ltac btauto := -lazymatch goal with -| [ |- @eq bool ?t ?u ] => - lazymatch build_formula t (@nil bool) with - | (?fl, ?l) => - lazymatch build_formula u l with - | (?fr, ?l) => - change (formula_eval l fl = formula_eval l fr); - apply reduce_poly_of_formula_sound_alt; - vm_compute; (reflexivity || fail "Not a tautology") - end - end -| _ => fail "Cannot recognize a boolean equality" -end. *) - -Register formula_var as plugins.btauto.f_var. -Register formula_btm as plugins.btauto.f_btm. -Register formula_top as plugins.btauto.f_top. -Register formula_cnj as plugins.btauto.f_cnj. -Register formula_dsj as plugins.btauto.f_dsj. -Register formula_neg as plugins.btauto.f_neg. -Register formula_xor as plugins.btauto.f_xor. -Register formula_ifb as plugins.btauto.f_ifb. - -Register formula_eval as plugins.btauto.eval. -Register boolean_witness as plugins.btauto.witness. -Register reduce_poly_of_formula_sound_alt as plugins.btauto.soundness. diff --git a/stdlib/theories/derive/Derive.v b/stdlib/theories/derive/Derive.v deleted file mode 100644 index 8ea29138e07d..000000000000 --- a/stdlib/theories/derive/Derive.v +++ /dev/null @@ -1 +0,0 @@ -From Corelib Require Export Derive. diff --git a/stdlib/theories/dune b/stdlib/theories/dune deleted file mode 100644 index 1085fad5a1b0..000000000000 --- a/stdlib/theories/dune +++ /dev/null @@ -1,14 +0,0 @@ -(include_subdirs qualified) -(coq.theory - (name Stdlib) - (package rocq-stdlib)) - -(env - (dev - (coq - (flags :standard -w +default)))) - -(rule - (targets All.v) - (deps (source_tree .)) - (action (with-stdout-to %{targets} (run ../tools/gen_all.exe)))) diff --git a/stdlib/theories/extraction/ExtrHaskellBasic.v b/stdlib/theories/extraction/ExtrHaskellBasic.v deleted file mode 100644 index 6be05ec8d6d8..000000000000 --- a/stdlib/theories/extraction/ExtrHaskellBasic.v +++ /dev/null @@ -1 +0,0 @@ -From Corelib Require Export ExtrHaskellBasic. diff --git a/stdlib/theories/extraction/ExtrHaskellNatInt.v b/stdlib/theories/extraction/ExtrHaskellNatInt.v deleted file mode 100644 index 7ab7f613d1d4..000000000000 --- a/stdlib/theories/extraction/ExtrHaskellNatInt.v +++ /dev/null @@ -1,15 +0,0 @@ -(** Extraction of [nat] into Haskell's [Int] *) - -Require Stdlib.extraction.Extraction. - -Require Import Arith. -Require Import ExtrHaskellNatNum. - -(** - * Disclaimer: trying to obtain efficient certified programs - * by extracting [nat] into [Int] is definitively *not* a good idea. - * See comments in [ExtrOcamlNatInt.v]. - *) - -Extract Inductive nat => "Prelude.Int" [ "0" "Prelude.succ" ] - "(\fO fS n -> if n Prelude.== 0 then fO () else fS (n Prelude.- 1))". diff --git a/stdlib/theories/extraction/ExtrHaskellNatInteger.v b/stdlib/theories/extraction/ExtrHaskellNatInteger.v deleted file mode 100644 index 4162d0ad0cff..000000000000 --- a/stdlib/theories/extraction/ExtrHaskellNatInteger.v +++ /dev/null @@ -1,15 +0,0 @@ -(** Extraction of [nat] into Haskell's [Integer] *) - -Require Stdlib.extraction.Extraction. - -Require Import Arith. -Require Import ExtrHaskellNatNum. - -(** - * Disclaimer: trying to obtain efficient certified programs - * by extracting [nat] into [Integer] isn't necessarily a good idea. - * See comments in [ExtrOcamlNatInt.v]. -*) - -Extract Inductive nat => "Prelude.Integer" [ "0" "Prelude.succ" ] - "(\fO fS n -> if n Prelude.== 0 then fO () else fS (n Prelude.- 1))". diff --git a/stdlib/theories/extraction/ExtrHaskellNatNum.v b/stdlib/theories/extraction/ExtrHaskellNatNum.v deleted file mode 100644 index f6d3c98257b3..000000000000 --- a/stdlib/theories/extraction/ExtrHaskellNatNum.v +++ /dev/null @@ -1,37 +0,0 @@ -(** - * Efficient (but uncertified) extraction of usual [nat] functions - * into equivalent versions in Haskell's Prelude that are defined - * for any [Num] typeclass instances. Useful in combination with - * [Extract Inductive nat] that maps [nat] onto a Haskell type that - * implements [Num]. - *) - -Require Stdlib.extraction.Extraction. - -Require Import Arith. -Require Import EqNat. - -Extract Inlined Constant Nat.add => "(Prelude.+)". -Extract Inlined Constant Nat.mul => "(Prelude.*)". -Extract Inlined Constant Nat.max => "Prelude.max". -Extract Inlined Constant Nat.min => "Prelude.min". -Extract Inlined Constant Init.Nat.add => "(Prelude.+)". -Extract Inlined Constant Init.Nat.mul => "(Prelude.*)". -Extract Inlined Constant Init.Nat.max => "Prelude.max". -Extract Inlined Constant Init.Nat.min => "Prelude.min". -Extract Inlined Constant Compare_dec.lt_dec => "(Prelude.<)". -Extract Inlined Constant Compare_dec.leb => "(Prelude.<=)". -Extract Inlined Constant Compare_dec.le_lt_dec => "(Prelude.<=)". -Extract Inlined Constant Nat.eqb => "(Prelude.==)". -Extract Inlined Constant EqNat.eq_nat_decide => "(Prelude.==)". -Extract Inlined Constant Peano_dec.eq_nat_dec => "(Prelude.==)". - -Extract Constant Nat.pred => "(\n -> Prelude.max 0 (Prelude.pred n))". -Extract Constant Nat.sub => "(\n m -> Prelude.max 0 (n Prelude.- m))". -Extract Constant Init.Nat.pred => "(\n -> Prelude.max 0 (Prelude.pred n))". -Extract Constant Init.Nat.sub => "(\n m -> Prelude.max 0 (n Prelude.- m))". - -Extract Constant Nat.div => "(\n m -> if m Prelude.== 0 then 0 else Prelude.div n m)". -Extract Constant Nat.modulo => "(\n m -> if m Prelude.== 0 then n else Prelude.mod n m)". -Extract Constant Init.Nat.div => "(\n m -> if m Prelude.== 0 then 0 else Prelude.div n m)". -Extract Constant Init.Nat.modulo => "(\n m -> if m Prelude.== 0 then n else Prelude.mod n m)". diff --git a/stdlib/theories/extraction/ExtrHaskellString.v b/stdlib/theories/extraction/ExtrHaskellString.v deleted file mode 100644 index f3f22645a526..000000000000 --- a/stdlib/theories/extraction/ExtrHaskellString.v +++ /dev/null @@ -1,64 +0,0 @@ -(** - * Special handling of ascii and strings for extraction to Haskell. - *) - -Require Stdlib.extraction.Extraction. - -Require Import Ascii. -Require Import String. -Require Import Stdlib.Strings.Byte. - -Require Export ExtrHaskellBasic. - -(** - * At the moment, Coq's extraction has no way to add extra import - * statements to the extracted Haskell code. You will have to - * manually add: - * - * import qualified Data.Bits - * import qualified Data.Char - *) - -Extract Inductive ascii => "Prelude.Char" - [ "(\b0 b1 b2 b3 b4 b5 b6 b7 -> Data.Char.chr ( - (if b0 then Data.Bits.shiftL 1 0 else 0) Prelude.+ - (if b1 then Data.Bits.shiftL 1 1 else 0) Prelude.+ - (if b2 then Data.Bits.shiftL 1 2 else 0) Prelude.+ - (if b3 then Data.Bits.shiftL 1 3 else 0) Prelude.+ - (if b4 then Data.Bits.shiftL 1 4 else 0) Prelude.+ - (if b5 then Data.Bits.shiftL 1 5 else 0) Prelude.+ - (if b6 then Data.Bits.shiftL 1 6 else 0) Prelude.+ - (if b7 then Data.Bits.shiftL 1 7 else 0)))" ] - "(\f a -> f (Data.Bits.testBit (Data.Char.ord a) 0) - (Data.Bits.testBit (Data.Char.ord a) 1) - (Data.Bits.testBit (Data.Char.ord a) 2) - (Data.Bits.testBit (Data.Char.ord a) 3) - (Data.Bits.testBit (Data.Char.ord a) 4) - (Data.Bits.testBit (Data.Char.ord a) 5) - (Data.Bits.testBit (Data.Char.ord a) 6) - (Data.Bits.testBit (Data.Char.ord a) 7))". -Extract Inlined Constant Ascii.ascii_dec => "((Prelude.==) :: Prelude.Char -> Prelude.Char -> Prelude.Bool)". -Extract Inlined Constant Ascii.eqb => "((Prelude.==) :: Prelude.Char -> Prelude.Char -> Prelude.Bool)". - -Extract Inductive string => "Prelude.String" [ "([])" "(:)" ]. -Extract Inlined Constant String.string_dec => "((Prelude.==) :: Prelude.String -> Prelude.String -> Prelude.Bool)". -Extract Inlined Constant String.eqb => "((Prelude.==) :: Prelude.String -> Prelude.String -> Prelude.Bool)". - -(* python -c 'print(" ".join(r""" "%s" """.strip() % (r"'"'\''"'" if chr(i) == "'"'"'" else repr(""" "" """.strip()) if chr(i) == """ " """.strip() else repr(chr(i))) for i in range(256)))' # " to satisfy Coq's comment parser *) -Extract Inductive byte => "Prelude.Char" -["'\x00'" "'\x01'" "'\x02'" "'\x03'" "'\x04'" "'\x05'" "'\x06'" "'\x07'" "'\x08'" "'\t'" "'\n'" "'\x0b'" "'\x0c'" "'\r'" "'\x0e'" "'\x0f'" "'\x10'" "'\x11'" "'\x12'" "'\x13'" "'\x14'" "'\x15'" "'\x16'" "'\x17'" "'\x18'" "'\x19'" "'\x1a'" "'\x1b'" "'\x1c'" "'\x1d'" "'\x1e'" "'\x1f'" "' '" "'!'" "'""'" "'#'" "'$'" "'%'" "'&'" "'\''" "'('" "')'" "'*'" "'+'" "','" "'-'" "'.'" "'/'" "'0'" "'1'" "'2'" "'3'" "'4'" "'5'" "'6'" "'7'" "'8'" "'9'" "':'" "';'" "'<'" "'='" "'>'" "'?'" "'@'" "'A'" "'B'" "'C'" "'D'" "'E'" "'F'" "'G'" "'H'" "'I'" "'J'" "'K'" "'L'" "'M'" "'N'" "'O'" "'P'" "'Q'" "'R'" "'S'" "'T'" "'U'" "'V'" "'W'" "'X'" "'Y'" "'Z'" "'['" "'\\'" "']'" "'^'" "'_'" "'`'" "'a'" "'b'" "'c'" "'d'" "'e'" "'f'" "'g'" "'h'" "'i'" "'j'" "'k'" "'l'" "'m'" "'n'" "'o'" "'p'" "'q'" "'r'" "'s'" "'t'" "'u'" "'v'" "'w'" "'x'" "'y'" "'z'" "'{'" "'|'" "'}'" "'~'" "'\x7f'" "'\x80'" "'\x81'" "'\x82'" "'\x83'" "'\x84'" "'\x85'" "'\x86'" "'\x87'" "'\x88'" "'\x89'" "'\x8a'" "'\x8b'" "'\x8c'" "'\x8d'" "'\x8e'" "'\x8f'" "'\x90'" "'\x91'" "'\x92'" "'\x93'" "'\x94'" "'\x95'" "'\x96'" "'\x97'" "'\x98'" "'\x99'" "'\x9a'" "'\x9b'" "'\x9c'" "'\x9d'" "'\x9e'" "'\x9f'" "'\xa0'" "'\xa1'" "'\xa2'" "'\xa3'" "'\xa4'" "'\xa5'" "'\xa6'" "'\xa7'" "'\xa8'" "'\xa9'" "'\xaa'" "'\xab'" "'\xac'" "'\xad'" "'\xae'" "'\xaf'" "'\xb0'" "'\xb1'" "'\xb2'" "'\xb3'" "'\xb4'" "'\xb5'" "'\xb6'" "'\xb7'" "'\xb8'" "'\xb9'" "'\xba'" "'\xbb'" "'\xbc'" "'\xbd'" "'\xbe'" "'\xbf'" "'\xc0'" "'\xc1'" "'\xc2'" "'\xc3'" "'\xc4'" "'\xc5'" "'\xc6'" "'\xc7'" "'\xc8'" "'\xc9'" "'\xca'" "'\xcb'" "'\xcc'" "'\xcd'" "'\xce'" "'\xcf'" "'\xd0'" "'\xd1'" "'\xd2'" "'\xd3'" "'\xd4'" "'\xd5'" "'\xd6'" "'\xd7'" "'\xd8'" "'\xd9'" "'\xda'" "'\xdb'" "'\xdc'" "'\xdd'" "'\xde'" "'\xdf'" "'\xe0'" "'\xe1'" "'\xe2'" "'\xe3'" "'\xe4'" "'\xe5'" "'\xe6'" "'\xe7'" "'\xe8'" "'\xe9'" "'\xea'" "'\xeb'" "'\xec'" "'\xed'" "'\xee'" "'\xef'" "'\xf0'" "'\xf1'" "'\xf2'" "'\xf3'" "'\xf4'" "'\xf5'" "'\xf6'" "'\xf7'" "'\xf8'" "'\xf9'" "'\xfa'" "'\xfb'" "'\xfc'" "'\xfd'" "'\xfe'" "'\xff'"]. - -Extract Inlined Constant Byte.eqb => "((Prelude.==) :: Prelude.Char -> Prelude.Char -> Prelude.Bool)". -Extract Inlined Constant Byte.byte_eq_dec => "((Prelude.==) :: Prelude.Char -> Prelude.Char -> Prelude.Bool)". -Extract Inlined Constant Ascii.ascii_of_byte => "(\x -> x)". -Extract Inlined Constant Ascii.byte_of_ascii => "(\x -> x)". - -(* -Require Import ExtrHaskellBasic. -Definition test := "ceci est un test"%string. -Definition test2 := List.map (option_map Byte.to_nat) (List.map Byte.of_nat (List.seq 0 256)). -Definition test3 := List.map ascii_of_nat (List.seq 0 256). - -Extraction Language Haskell. -Recursive Extraction test Ascii.zero Ascii.one test2 test3 byte_rect. -*) diff --git a/stdlib/theories/extraction/ExtrHaskellZInt.v b/stdlib/theories/extraction/ExtrHaskellZInt.v deleted file mode 100644 index e6196e93db60..000000000000 --- a/stdlib/theories/extraction/ExtrHaskellZInt.v +++ /dev/null @@ -1,26 +0,0 @@ -(** Extraction of [Z] into Haskell's [Int] *) - -Require Stdlib.extraction.Extraction. - -Require Import ZArith. -Require Import ExtrHaskellZNum. - -(** - * Disclaimer: trying to obtain efficient certified programs - * by extracting [Z] into [Int] is definitively *not* a good idea. - * See comments in [ExtrOcamlNatInt.v]. - *) - -Extract Inductive positive => "Prelude.Int" [ - "(\x -> 2 Prelude.* x Prelude.+ 1)" - "(\x -> 2 Prelude.* x)" - "1" ] - "(\fI fO fH n -> if n Prelude.== 1 then fH () else - if Prelude.odd n - then fI (n `Prelude.div` 2) - else fO (n `Prelude.div` 2))". - -Extract Inductive Z => "Prelude.Int" [ "0" "(\x -> x)" "Prelude.negate" ] - "(\fO fP fN n -> if n Prelude.== 0 then fO () else - if n Prelude.> 0 then fP n else - fN (Prelude.negate n))". diff --git a/stdlib/theories/extraction/ExtrHaskellZInteger.v b/stdlib/theories/extraction/ExtrHaskellZInteger.v deleted file mode 100644 index 66105044af4f..000000000000 --- a/stdlib/theories/extraction/ExtrHaskellZInteger.v +++ /dev/null @@ -1,25 +0,0 @@ -(** Extraction of [Z] into Haskell's [Integer] *) - -Require Stdlib.extraction.Extraction. - -Require Import ZArith. -Require Import ExtrHaskellZNum. - -(** Disclaimer: trying to obtain efficient certified programs - by extracting [Z] into [Integer] isn't necessarily a good idea. - See comments in [ExtrOcamlNatInt.v]. -*) - -Extract Inductive positive => "Prelude.Integer" [ - "(\x -> 2 Prelude.* x Prelude.+ 1)" - "(\x -> 2 Prelude.* x)" - "1" ] - "(\fI fO fH n -> if n Prelude.== 1 then fH () else - if Prelude.odd n - then fI (n `Prelude.div` 2) - else fO (n `Prelude.div` 2))". - -Extract Inductive Z => "Prelude.Integer" [ "0" "(\x -> x)" "Prelude.negate" ] - "(\fO fP fN n -> if n Prelude.== 0 then fO () else - if n Prelude.> 0 then fP n else - fN (Prelude.negate n))". diff --git a/stdlib/theories/extraction/ExtrHaskellZNum.v b/stdlib/theories/extraction/ExtrHaskellZNum.v deleted file mode 100644 index 8ed33bf09bc7..000000000000 --- a/stdlib/theories/extraction/ExtrHaskellZNum.v +++ /dev/null @@ -1,23 +0,0 @@ -(** - * Efficient (but uncertified) extraction of usual [Z] functions - * into equivalent versions in Haskell's Prelude that are defined - * for any [Num] typeclass instances. Useful in combination with - * [Extract Inductive Z] that maps [Z] onto a Haskell type that - * implements [Num]. - *) - -Require Stdlib.extraction.Extraction. - -Require Import ZArith. -Require Import EqNat. - -Extract Inlined Constant Z.add => "(Prelude.+)". -Extract Inlined Constant Z.sub => "(Prelude.-)". -Extract Inlined Constant Z.mul => "(Prelude.*)". -Extract Inlined Constant Z.max => "Prelude.max". -Extract Inlined Constant Z.min => "Prelude.min". -Extract Inlined Constant Z_ge_lt_dec => "(Prelude.>=)". -Extract Inlined Constant Z_gt_le_dec => "(Prelude.>)". - -Extract Constant Z.div => "(\n m -> if m Prelude.== 0 then 0 else Prelude.div n m)". -Extract Constant Z.modulo => "(\n m -> if m Prelude.== 0 then n else Prelude.mod n m)". diff --git a/stdlib/theories/extraction/ExtrOCamlFloats.v b/stdlib/theories/extraction/ExtrOCamlFloats.v deleted file mode 100644 index 2461f3131ffd..000000000000 --- a/stdlib/theories/extraction/ExtrOCamlFloats.v +++ /dev/null @@ -1,62 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* bool [ true false ]. -Extract Inductive prod => "( * )" [ "" ]. - -Extract Inductive FloatClass.float_class => - "Float64.float_class" - [ "PNormal" "NNormal" "PSubn" "NSubn" "PZero" "NZero" "PInf" "NInf" "NaN" ]. -Extract Inductive PrimFloat.float_comparison => - "Float64.float_comparison" - [ "FEq" "FLt" "FGt" "FNotComparable" ]. - -(** Primitive types and operators. *) - -Extract Constant PrimFloat.float => "Float64.t". -Extraction Inline PrimFloat.float. -(* Otherwise, the name conflicts with the primitive OCaml type [float] *) - -Extract Constant PrimFloat.classify => "Float64.classify". -Extract Constant PrimFloat.abs => "Float64.abs". -Extract Constant PrimFloat.sqrt => "Float64.sqrt". -Extract Constant PrimFloat.opp => "Float64.opp". -Extract Constant PrimFloat.eqb => "Float64.eq". -Extract Constant PrimFloat.ltb => "Float64.lt". -Extract Constant PrimFloat.leb => "Float64.le". -Extract Constant PrimFloat.compare => "Float64.compare". -Extract Constant PrimFloat.Leibniz.eqb => "Float64.equal". -Extract Constant PrimFloat.mul => "Float64.mul". -Extract Constant PrimFloat.add => "Float64.add". -Extract Constant PrimFloat.sub => "Float64.sub". -Extract Constant PrimFloat.div => "Float64.div". -Extract Constant PrimFloat.of_uint63 => "Float64.of_uint63". -Extract Constant PrimFloat.normfr_mantissa => "Float64.normfr_mantissa". -Extract Constant PrimFloat.frshiftexp => "Float64.frshiftexp". -Extract Constant PrimFloat.ldshiftexp => "Float64.ldshiftexp". -Extract Constant PrimFloat.next_up => "Float64.next_up". -Extract Constant PrimFloat.next_down => "Float64.next_down". diff --git a/stdlib/theories/extraction/ExtrOCamlInt63.v b/stdlib/theories/extraction/ExtrOCamlInt63.v deleted file mode 100644 index 7e3c808172e0..000000000000 --- a/stdlib/theories/extraction/ExtrOCamlInt63.v +++ /dev/null @@ -1,62 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* bool [ true false ]. -Extract Inductive prod => "( * )" [ "" ]. -Extract Inductive DoubleType.carry => "Uint63.carry" [ "Uint63.C0" "Uint63.C1" ]. - -(** Primitive types and operators. *) -Extract Constant Uint63.int => "Uint63.t". -Extraction Inline Uint63.int. -(* Otherwise, the name conflicts with the primitive OCaml type [int] *) - -Extract Constant Uint63.lsl => "Uint63.l_sl". -Extract Constant Uint63.lsr => "Uint63.l_sr". -Extract Constant Sint63.asr => "Uint63.a_sr". -Extract Constant Uint63.land => "Uint63.l_and". -Extract Constant Uint63.lor => "Uint63.l_or". -Extract Constant Uint63.lxor => "Uint63.l_xor". - -Extract Constant Uint63.add => "Uint63.add". -Extract Constant Uint63.sub => "Uint63.sub". -Extract Constant Uint63.mul => "Uint63.mul". -Extract Constant Uint63.mulc => "Uint63.mulc". -Extract Constant Uint63.div => "Uint63.div". -Extract Constant Uint63.mod => "Uint63.rem". -Extract Constant Sint63.div => "Uint63.divs". -Extract Constant Sint63.rem => "Uint63.rems". - - -Extract Constant Uint63.eqb => "Uint63.equal". -Extract Constant Uint63.ltb => "Uint63.lt". -Extract Constant Uint63.leb => "Uint63.le". -Extract Constant Sint63.ltb => "Uint63.lts". -Extract Constant Sint63.leb => "Uint63.les". - -Extract Constant Uint63.addc => "Uint63.addc". -Extract Constant Uint63.addcarryc => "Uint63.addcarryc". -Extract Constant Uint63.subc => "Uint63.subc". -Extract Constant Uint63.subcarryc => "Uint63.subcarryc". - -Extract Constant Uint63.diveucl => "Uint63.diveucl". -Extract Constant Uint63.diveucl_21 => "Uint63.div21". -Extract Constant Uint63.addmuldiv => "Uint63.addmuldiv". - -Extract Constant Uint63.compare => "(fun x y -> let c = Uint63.compare x y in if c = 0 then Eq else if c < 0 then Lt else Gt)". -Extract Constant Sint63.compare => "(fun x y -> let c = Uint63.compares x y in if c = 0 then Eq else if c < 0 then Lt else Gt)". - -Extract Constant Uint63.head0 => "Uint63.head0". -Extract Constant Uint63.tail0 => "Uint63.tail0". diff --git a/stdlib/theories/extraction/ExtrOCamlPArray.v b/stdlib/theories/extraction/ExtrOCamlPArray.v deleted file mode 100644 index e1c2380557c1..000000000000 --- a/stdlib/theories/extraction/ExtrOCamlPArray.v +++ /dev/null @@ -1,25 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* "'a Parray.t". -Extraction Inline PrimArray.array. -(* Otherwise, the name conflicts with the primitive OCaml type [array] *) - -Extract Constant PrimArray.make => "Parray.make". -Extract Constant PrimArray.get => "Parray.get". -Extract Constant PrimArray.default => "Parray.default". -Extract Constant PrimArray.set => "Parray.set". -Extract Constant PrimArray.length => "Parray.length". -Extract Constant PrimArray.copy => "Parray.copy". diff --git a/stdlib/theories/extraction/ExtrOCamlPString.v b/stdlib/theories/extraction/ExtrOCamlPString.v deleted file mode 100644 index db2b7d50e306..000000000000 --- a/stdlib/theories/extraction/ExtrOCamlPString.v +++ /dev/null @@ -1,37 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* "Pstring.t". - -Extract Constant PrimString.max_length => "Pstring.max_length". -Extract Constant PrimString.make => "Pstring.make". -Extract Constant PrimString.length => "Pstring.length". -Extract Constant PrimString.get => "Pstring.get". -Extract Constant PrimString.sub => "Pstring.sub". -Extract Constant PrimString.cat => "Pstring.cat". -Extract Constant PrimString.compare => "(fun x y -> let c = Pstring.compare x y in if c = 0 then Eq else if c < 0 then Lt else Gt)". diff --git a/stdlib/theories/extraction/ExtrOcamlBasic.v b/stdlib/theories/extraction/ExtrOcamlBasic.v deleted file mode 100644 index 049be2045547..000000000000 --- a/stdlib/theories/extraction/ExtrOcamlBasic.v +++ /dev/null @@ -1 +0,0 @@ -From Corelib Require Export ExtrOcamlBasic. diff --git a/stdlib/theories/extraction/ExtrOcamlChar.v b/stdlib/theories/extraction/ExtrOcamlChar.v deleted file mode 100644 index 4552df7a0457..000000000000 --- a/stdlib/theories/extraction/ExtrOcamlChar.v +++ /dev/null @@ -1,50 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* char -[ -"(* If this appears, you're using Ascii internals. Please don't *) - (fun (b0,b1,b2,b3,b4,b5,b6,b7) -> - let f b i = if b then 1 lsl i else 0 in - Char.chr (f b0 0 + f b1 1 + f b2 2 + f b3 3 + f b4 4 + f b5 5 + f b6 6 + f b7 7))" -] -"(* If this appears, you're using Ascii internals. Please don't *) - (fun f c -> - let n = Char.code c in - let h i = (n land (1 lsl i)) <> 0 in - f (h 0) (h 1) (h 2) (h 3) (h 4) (h 5) (h 6) (h 7))". - -Extract Constant zero => "'\000'". -Extract Constant one => "'\001'". -Extract Constant shift => - "fun b c -> Char.chr (((Char.code c) lsl 1) land 255 + if b then 1 else 0)". - -Extract Inlined Constant ascii_dec => "(=)". -Extract Inlined Constant Ascii.eqb => "(=)". -Extract Constant Ascii.compare => - "fun c1 c2 -> - let cmp = Char.compare c1 c2 in - if cmp < 0 then Lt else if cmp = 0 then Eq else Gt". - -(* python -c 'print(" ".join(r""" "%s" """.strip() % (r"'"'\''"'" if chr(i) == "'"'"'" else repr(""" "" """.strip()) if chr(i) == """ " """.strip() else repr(chr(i))) for i in range(256)))' # " to satisfy Coq's comment parser *) -Extract Inductive byte => char -["'\x00'" "'\x01'" "'\x02'" "'\x03'" "'\x04'" "'\x05'" "'\x06'" "'\x07'" "'\x08'" "'\t'" "'\n'" "'\x0b'" "'\x0c'" "'\r'" "'\x0e'" "'\x0f'" "'\x10'" "'\x11'" "'\x12'" "'\x13'" "'\x14'" "'\x15'" "'\x16'" "'\x17'" "'\x18'" "'\x19'" "'\x1a'" "'\x1b'" "'\x1c'" "'\x1d'" "'\x1e'" "'\x1f'" "' '" "'!'" "'""'" "'#'" "'$'" "'%'" "'&'" "'\''" "'('" "')'" "'*'" "'+'" "','" "'-'" "'.'" "'/'" "'0'" "'1'" "'2'" "'3'" "'4'" "'5'" "'6'" "'7'" "'8'" "'9'" "':'" "';'" "'<'" "'='" "'>'" "'?'" "'@'" "'A'" "'B'" "'C'" "'D'" "'E'" "'F'" "'G'" "'H'" "'I'" "'J'" "'K'" "'L'" "'M'" "'N'" "'O'" "'P'" "'Q'" "'R'" "'S'" "'T'" "'U'" "'V'" "'W'" "'X'" "'Y'" "'Z'" "'['" "'\\'" "']'" "'^'" "'_'" "'`'" "'a'" "'b'" "'c'" "'d'" "'e'" "'f'" "'g'" "'h'" "'i'" "'j'" "'k'" "'l'" "'m'" "'n'" "'o'" "'p'" "'q'" "'r'" "'s'" "'t'" "'u'" "'v'" "'w'" "'x'" "'y'" "'z'" "'{'" "'|'" "'}'" "'~'" "'\x7f'" "'\x80'" "'\x81'" "'\x82'" "'\x83'" "'\x84'" "'\x85'" "'\x86'" "'\x87'" "'\x88'" "'\x89'" "'\x8a'" "'\x8b'" "'\x8c'" "'\x8d'" "'\x8e'" "'\x8f'" "'\x90'" "'\x91'" "'\x92'" "'\x93'" "'\x94'" "'\x95'" "'\x96'" "'\x97'" "'\x98'" "'\x99'" "'\x9a'" "'\x9b'" "'\x9c'" "'\x9d'" "'\x9e'" "'\x9f'" "'\xa0'" "'\xa1'" "'\xa2'" "'\xa3'" "'\xa4'" "'\xa5'" "'\xa6'" "'\xa7'" "'\xa8'" "'\xa9'" "'\xaa'" "'\xab'" "'\xac'" "'\xad'" "'\xae'" "'\xaf'" "'\xb0'" "'\xb1'" "'\xb2'" "'\xb3'" "'\xb4'" "'\xb5'" "'\xb6'" "'\xb7'" "'\xb8'" "'\xb9'" "'\xba'" "'\xbb'" "'\xbc'" "'\xbd'" "'\xbe'" "'\xbf'" "'\xc0'" "'\xc1'" "'\xc2'" "'\xc3'" "'\xc4'" "'\xc5'" "'\xc6'" "'\xc7'" "'\xc8'" "'\xc9'" "'\xca'" "'\xcb'" "'\xcc'" "'\xcd'" "'\xce'" "'\xcf'" "'\xd0'" "'\xd1'" "'\xd2'" "'\xd3'" "'\xd4'" "'\xd5'" "'\xd6'" "'\xd7'" "'\xd8'" "'\xd9'" "'\xda'" "'\xdb'" "'\xdc'" "'\xdd'" "'\xde'" "'\xdf'" "'\xe0'" "'\xe1'" "'\xe2'" "'\xe3'" "'\xe4'" "'\xe5'" "'\xe6'" "'\xe7'" "'\xe8'" "'\xe9'" "'\xea'" "'\xeb'" "'\xec'" "'\xed'" "'\xee'" "'\xef'" "'\xf0'" "'\xf1'" "'\xf2'" "'\xf3'" "'\xf4'" "'\xf5'" "'\xf6'" "'\xf7'" "'\xf8'" "'\xf9'" "'\xfa'" "'\xfb'" "'\xfc'" "'\xfd'" "'\xfe'" "'\xff'"]. - -Extract Inlined Constant Byte.eqb => "(=)". -Extract Inlined Constant Byte.byte_eq_dec => "(=)". -Extract Inlined Constant Ascii.ascii_of_byte => "(fun x -> x)". -Extract Inlined Constant Ascii.byte_of_ascii => "(fun x -> x)". diff --git a/stdlib/theories/extraction/ExtrOcamlIntConv.v b/stdlib/theories/extraction/ExtrOcamlIntConv.v deleted file mode 100644 index 49e585170fe3..000000000000 --- a/stdlib/theories/extraction/ExtrOcamlIntConv.v +++ /dev/null @@ -1,101 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* int. -Parameter int_opp : int -> int. -Parameter int_twice : int -> int. - -Extract Inlined Constant int => int. -Extract Inlined Constant int_zero => "0". -Extract Inlined Constant int_succ => "succ". -Extract Inlined Constant int_opp => "-". -Extract Inlined Constant int_twice => "2 *". - -Definition int_of_nat : nat -> int := - (fix loop acc n := - match n with - | O => acc - | S n => loop (int_succ acc) n - end) int_zero. - -Fixpoint int_of_pos p := - match p with - | xH => int_succ int_zero - | xO p => int_twice (int_of_pos p) - | xI p => int_succ (int_twice (int_of_pos p)) - end. - -Definition int_of_z z := - match z with - | Z0 => int_zero - | Zpos p => int_of_pos p - | Zneg p => int_opp (int_of_pos p) - end. - -Definition int_of_n n := - match n with - | N0 => int_zero - | Npos p => int_of_pos p - end. - -(** NB: as for [pred] or [minus], [nat_of_int], [n_of_int] and - [pos_of_int] are total and return zero (resp. one) for - non-positive inputs. *) - -Parameter int_natlike_rec : forall A, A -> (A->A) -> int -> A. -Extract Constant int_natlike_rec => -"fun fO fS -> - let rec loop acc i = if i <= 0 then acc else loop (fS acc) (i-1) - in loop fO". - -Definition nat_of_int : int -> nat := int_natlike_rec _ O S. - -Parameter int_poslike_rec : forall A, A -> (A->A) -> (A->A) -> int -> A. -Extract Constant int_poslike_rec => -"fun f1 f2x f2x1 -> - let rec loop i = if i <= 1 then f1 else - if i land 1 = 0 then f2x (loop (i lsr 1)) else f2x1 (loop (i lsr 1)) - in loop". - -Definition pos_of_int : int -> positive := int_poslike_rec _ xH xO xI. - -Parameter int_zlike_case : forall A, A -> (int->A) -> (int->A) -> int -> A. -Extract Constant int_zlike_case => -"fun f0 fpos fneg i -> - if i = 0 then f0 else if i>0 then fpos i else fneg (-i)". - -Definition z_of_int : int -> Z := - int_zlike_case _ Z0 (fun i => Zpos (pos_of_int i)) - (fun i => Zneg (pos_of_int i)). - -Definition n_of_int : int -> N := - int_zlike_case _ N0 (fun i => Npos (pos_of_int i)) (fun _ => N0). - -(** Warning: [z_of_int] is currently wrong for Ocaml's [min_int], - since [min_int] has no positive opposite ([-min_int = min_int]). -*) - -(* -Extraction "/tmp/test.ml" - nat_of_int int_of_nat - pos_of_int int_of_pos - z_of_int int_of_z - n_of_int int_of_n. -*) diff --git a/stdlib/theories/extraction/ExtrOcamlNatBigInt.v b/stdlib/theories/extraction/ExtrOcamlNatBigInt.v deleted file mode 100644 index 0901e1be18cf..000000000000 --- a/stdlib/theories/extraction/ExtrOcamlNatBigInt.v +++ /dev/null @@ -1,79 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* "Big_int_Z.big_int" - [ "Big_int_Z.zero_big_int" "Big_int_Z.succ_big_int" ] - "(fun fO fS n -> if Big_int_Z.sign_big_int n <= 0 then fO () - else fS (Big_int_Z.pred_big_int n))". - -(** Efficient (but uncertified) versions for usual [nat] functions *) - -Extract Constant plus => "Big_int_Z.add_big_int". -Extract Constant mult => "Big_int_Z.mult_big_int". -Extract Constant pred => - "(fun n -> Big_int_Z.max_big_int Big_int_Z.zero_big_int - (Big_int_Z.pred_big_int n))". -Extract Constant minus => - "(fun n m -> Big_int_Z.max_big_int Big_int_Z.zero_big_int - (Big_int_Z.sub_big_int n m))". -Extract Constant max => "Big_int_Z.max_big_int". -Extract Constant min => "Big_int_Z.min_big_int". -(*Extract Constant nat_beq => "Big.eq".*) -Extract Constant Nat.eqb => "Big_int_Z.eq_big_int". -Extract Constant EqNat.eq_nat_decide => "Big_int_Z.eq_big_int". - -Extract Constant Peano_dec.eq_nat_dec => "Big_int_Z.eq_big_int". - -Extract Constant Nat.compare => - "(fun x y -> let s = Big_int_Z.compare_big_int x y in - if s = 0 then Eq else if s < 0 then Lt else Gt)". - -Extract Constant Compare_dec.leb => "Big_int_Z.le_big_int". -Extract Constant Compare_dec.le_lt_dec => "Big_int_Z.le_big_int". -Extract Constant Compare_dec.lt_eq_lt_dec => - "(fun x y -> let s = Big_int_Z.compare_big_int x y in - if s = 0 then (Some false) else if s < 0 then (Some true) else None)". - -Extract Constant Nat.Even_or_Odd => - "(fun n -> Big_int_Z.sign_big_int - (Big_int_Z.mod_big_int n (Big_int_Z.big_int_of_int 2)) = 0)". -Extract Constant Nat.div2 => "(fun n -> Big_int_Z.div_big_int n (Big_int_Z.big_int_of_int 2))". - -Extract Inductive Euclid.diveucl => "(Big_int_Z.big_int * Big_int_Z.big_int)" [""]. -Extract Constant Euclid.eucl_dev => "(fun n m -> Big_int_Z.quomod_big_int m n)". -Extract Constant Euclid.quotient => "(fun n m -> Big_int_Z.div_big_int m n)". -Extract Constant Euclid.modulo => "(fun n m -> Big_int_Z.mod_big_int m n)". - -(* -Require Import Euclid. -Definition test n m (H:m>0) := - let (q,r,_,_) := eucl_dev m H n in - nat_compare n (q*m+r). - -Extraction "/tmp/test.ml" test fact pred minus max min Div2.div2. -*) diff --git a/stdlib/theories/extraction/ExtrOcamlNatInt.v b/stdlib/theories/extraction/ExtrOcamlNatInt.v deleted file mode 100644 index e8ca9b405ae4..000000000000 --- a/stdlib/theories/extraction/ExtrOcamlNatInt.v +++ /dev/null @@ -1,84 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* int [ "0" "Stdlib.Int.succ" ] - "(fun fO fS n -> if n=0 then fO () else fS (n-1))". - -(** Efficient (but uncertified) versions for usual [nat] functions *) - -Extract Constant plus => "(+)". -Extract Constant pred => "fun n -> Stdlib.max 0 (n-1)". -Extract Constant minus => "fun n m -> Stdlib.max 0 (n-m)". -Extract Constant mult => "( * )". -Extract Inlined Constant max => "Stdlib.max". -Extract Inlined Constant min => "Stdlib.min". -(*Extract Inlined Constant nat_beq => "(=)".*) -Extract Inlined Constant Nat.eqb => "(=)". -Extract Inlined Constant EqNat.eq_nat_decide => "(=)". - -Extract Inlined Constant Peano_dec.eq_nat_dec => "(=)". - -Extract Constant Nat.compare => - "fun n m -> if n=m then Eq else if n "(<=)". -Extract Inlined Constant Compare_dec.le_lt_dec => "(<=)". -Extract Inlined Constant Compare_dec.lt_dec => "(<)". -Extract Constant Compare_dec.lt_eq_lt_dec => - "fun n m -> if n>m then None else Some (n "fun n -> n mod 2 = 0". -Extract Constant Nat.div2 => "fun n -> n/2". - -Extract Inductive Euclid.diveucl => "(int * int)" [ "" ]. -Extract Constant Euclid.eucl_dev => "fun n m -> (m/n, m mod n)". -Extract Constant Euclid.quotient => "fun n m -> m/n". -Extract Constant Euclid.modulo => "fun n m -> m mod n". - -(* -Definition test n m (H:m>0) := - let (q,r,_,_) := eucl_dev m H n in - nat_compare n (q*m+r). - -Recursive Extraction test fact. -*) diff --git a/stdlib/theories/extraction/ExtrOcamlNativeString.v b/stdlib/theories/extraction/ExtrOcamlNativeString.v deleted file mode 100644 index 045d1bc592a8..000000000000 --- a/stdlib/theories/extraction/ExtrOcamlNativeString.v +++ /dev/null @@ -1,85 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* char -["'\x00'" "'\x01'" "'\x02'" "'\x03'" "'\x04'" "'\x05'" "'\x06'" "'\x07'" "'\x08'" "'\t'" "'\n'" "'\x0b'" "'\x0c'" "'\r'" "'\x0e'" "'\x0f'" "'\x10'" "'\x11'" "'\x12'" "'\x13'" "'\x14'" "'\x15'" "'\x16'" "'\x17'" "'\x18'" "'\x19'" "'\x1a'" "'\x1b'" "'\x1c'" "'\x1d'" "'\x1e'" "'\x1f'" "' '" "'!'" "'""'" "'#'" "'$'" "'%'" "'&'" "'\''" "'('" "')'" "'*'" "'+'" "','" "'-'" "'.'" "'/'" "'0'" "'1'" "'2'" "'3'" "'4'" "'5'" "'6'" "'7'" "'8'" "'9'" "':'" "';'" "'<'" "'='" "'>'" "'?'" "'@'" "'A'" "'B'" "'C'" "'D'" "'E'" "'F'" "'G'" "'H'" "'I'" "'J'" "'K'" "'L'" "'M'" "'N'" "'O'" "'P'" "'Q'" "'R'" "'S'" "'T'" "'U'" "'V'" "'W'" "'X'" "'Y'" "'Z'" "'['" "'\\'" "']'" "'^'" "'_'" "'`'" "'a'" "'b'" "'c'" "'d'" "'e'" "'f'" "'g'" "'h'" "'i'" "'j'" "'k'" "'l'" "'m'" "'n'" "'o'" "'p'" "'q'" "'r'" "'s'" "'t'" "'u'" "'v'" "'w'" "'x'" "'y'" "'z'" "'{'" "'|'" "'}'" "'~'" "'\x7f'" "'\x80'" "'\x81'" "'\x82'" "'\x83'" "'\x84'" "'\x85'" "'\x86'" "'\x87'" "'\x88'" "'\x89'" "'\x8a'" "'\x8b'" "'\x8c'" "'\x8d'" "'\x8e'" "'\x8f'" "'\x90'" "'\x91'" "'\x92'" "'\x93'" "'\x94'" "'\x95'" "'\x96'" "'\x97'" "'\x98'" "'\x99'" "'\x9a'" "'\x9b'" "'\x9c'" "'\x9d'" "'\x9e'" "'\x9f'" "'\xa0'" "'\xa1'" "'\xa2'" "'\xa3'" "'\xa4'" "'\xa5'" "'\xa6'" "'\xa7'" "'\xa8'" "'\xa9'" "'\xaa'" "'\xab'" "'\xac'" "'\xad'" "'\xae'" "'\xaf'" "'\xb0'" "'\xb1'" "'\xb2'" "'\xb3'" "'\xb4'" "'\xb5'" "'\xb6'" "'\xb7'" "'\xb8'" "'\xb9'" "'\xba'" "'\xbb'" "'\xbc'" "'\xbd'" "'\xbe'" "'\xbf'" "'\xc0'" "'\xc1'" "'\xc2'" "'\xc3'" "'\xc4'" "'\xc5'" "'\xc6'" "'\xc7'" "'\xc8'" "'\xc9'" "'\xca'" "'\xcb'" "'\xcc'" "'\xcd'" "'\xce'" "'\xcf'" "'\xd0'" "'\xd1'" "'\xd2'" "'\xd3'" "'\xd4'" "'\xd5'" "'\xd6'" "'\xd7'" "'\xd8'" "'\xd9'" "'\xda'" "'\xdb'" "'\xdc'" "'\xdd'" "'\xde'" "'\xdf'" "'\xe0'" "'\xe1'" "'\xe2'" "'\xe3'" "'\xe4'" "'\xe5'" "'\xe6'" "'\xe7'" "'\xe8'" "'\xe9'" "'\xea'" "'\xeb'" "'\xec'" "'\xed'" "'\xee'" "'\xef'" "'\xf0'" "'\xf1'" "'\xf2'" "'\xf3'" "'\xf4'" "'\xf5'" "'\xf6'" "'\xf7'" "'\xf8'" "'\xf9'" "'\xfa'" "'\xfb'" "'\xfc'" "'\xfd'" "'\xfe'" "'\xff'"]. - -Extract Inlined Constant Byte.eqb => "(=)". -Extract Inlined Constant Byte.byte_eq_dec => "(=)". -Extract Inlined Constant Ascii.ascii_of_byte => "(fun x -> x)". -Extract Inlined Constant Ascii.byte_of_ascii => "(fun x -> x)". - -(* This differs from ExtrOcamlString.v: the latter extracts "string" - to "char list", and we extract "string" to "string" *) - -Extract Inductive string => "string" -[ -(* EmptyString *) -"(* If this appears, you're using String internals. Please don't *) - """" -" -(* String *) -"(* If this appears, you're using String internals. Please don't *) - (fun (c, s) -> String.make 1 c ^ s) -" -] -"(* If this appears, you're using String internals. Please don't *) - (fun f0 f1 s -> - let l = String.length s in - if l = 0 then f0 () else f1 (String.get s 0) (String.sub s 1 (l-1))) -". - -Extract Inlined Constant String.string_dec => "(=)". -Extract Inlined Constant String.eqb => "(=)". -Extract Inlined Constant String.append => "(^)". -Extract Inlined Constant String.concat => "String.concat". -Extract Inlined Constant String.prefix => - "(fun s1 s2 -> - let l1 = String.length s1 and l2 = String.length s2 in - l1 <= l2 && String.sub s2 0 l1 = s1)". -Extract Inlined Constant String.string_of_list_ascii => - "(fun l -> - let a = Array.of_list l in - String.init (Array.length a) (fun i -> a.(i)))". -Extract Inlined Constant String.list_ascii_of_string => - "(fun s -> List.init (String.length s) (fun i -> s.[i]))". -Extract Inlined Constant String.string_of_list_byte => - "(fun l -> - let a = Array.of_list l in - String.init (Array.length a) (fun i -> a.(i)))". -Extract Inlined Constant String.list_byte_of_string => - "(fun s -> List.init (String.length s) (fun i -> s.[i]))". - -(* Other operations in module String (at the time of this writing): - String.length - String.get - String.substring - String.index - String.findex - They all use type "nat". If we know that "nat" extracts - to O | S of nat, we can provide OCaml implementations - for these functions that work directly on OCaml's strings. - However "nat" could be extracted to other OCaml types... -*) - -(* -Definition test := "ceci est un test"%string. - -Recursive Extraction test Ascii.zero Ascii.one. -*) diff --git a/stdlib/theories/extraction/ExtrOcamlString.v b/stdlib/theories/extraction/ExtrOcamlString.v deleted file mode 100644 index ea095426e90b..000000000000 --- a/stdlib/theories/extraction/ExtrOcamlString.v +++ /dev/null @@ -1,18 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* "char list" [ "[]" "(::)" ]. diff --git a/stdlib/theories/extraction/ExtrOcamlZBigInt.v b/stdlib/theories/extraction/ExtrOcamlZBigInt.v deleted file mode 100644 index 1c40786377ab..000000000000 --- a/stdlib/theories/extraction/ExtrOcamlZBigInt.v +++ /dev/null @@ -1,153 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* "Big_int_Z.big_int" - [ "(fun x -> Big_int_Z.succ_big_int (Big_int_Z.mult_int_big_int 2 x))" - "Big_int_Z.mult_int_big_int 2" "Big_int_Z.unit_big_int" ] - "(fun f2p1 f2p f1 p -> - if Big_int_Z.le_big_int p Big_int_Z.unit_big_int then f1 () else - let (q,r) = Big_int_Z.quomod_big_int p (Big_int_Z.big_int_of_int 2) in - if Big_int_Z.eq_big_int r Big_int_Z.zero_big_int then f2p q else f2p1 q)". - -Extract Inductive Z => "Big_int_Z.big_int" - [ "Big_int_Z.zero_big_int" "" "Big_int_Z.minus_big_int" ] - "(fun fO fp fn z -> let s = Big_int_Z.sign_big_int z in - if s = 0 then fO () else if s > 0 then fp z - else fn (Big_int_Z.minus_big_int z))". - -Extract Inductive N => "Big_int_Z.big_int" - [ "Big_int_Z.zero_big_int" "" ] - "(fun fO fp n -> if Big_int_Z.sign_big_int n <= 0 then fO () else fp n)". - -(** Nota: the "" above is used as an identity function "(fun p->p)" *) - -(** Efficient (but uncertified) versions for usual functions *) - -Extract Constant Pos.add => "Big_int_Z.add_big_int". -Extract Constant Pos.succ => "Big_int_Z.succ_big_int". -Extract Constant Pos.pred => - "(fun n -> Big_int_Z.max_big_int Big_int_Z.unit_big_int - (Big_int_Z.pred_big_int n))". -Extract Constant Pos.sub => - "(fun n m -> Big_int_Z.max_big_int - Big_int_Z.unit_big_int (Big_int_Z.sub_big_int n m))". -Extract Constant Pos.mul => "Big_int_Z.mult_big_int". -Extract Constant Pos.min => "Big_int_Z.min_big_int". -Extract Constant Pos.max => "Big_int_Z.max_big_int". -Extract Constant Pos.compare => - "(fun x y -> let s = Big_int_Z.compare_big_int x y in - if s = 0 then Eq else if s < 0 then Lt else Gt)". -Extract Constant Pos.compare_cont => - "(fun c x y -> let s = Big_int_Z.compare_big_int x y in - if s = 0 then c else if s < 0 then Lt else Gt)". - -Extract Constant N.add => "Big_int_Z.add_big_int". -Extract Constant N.succ => "Big_int_Z.succ_big_int". -Extract Constant N.pred => - "(fun n -> Big_int_Z.max_big_int Big_int_Z.zero_big_int - (Big_int_Z.pred_big_int n))". -Extract Constant N.sub => - "(fun n m -> Big_int_Z.max_big_int Big_int_Z.zero_big_int - (Big_int_Z.sub_big_int n m))". -Extract Constant N.mul => "Big_int_Z.mult_big_int". -Extract Constant N.min => "Big_int_Z.min_big_int". -Extract Constant N.max => "Big_int_Z.max_big_int". -Extract Constant N.div_eucl => - "Big_int_Z.(fun x y -> - if eq_big_int zero_big_int y then (zero_big_int, x) else - quomod_big_int x y)". -Extract Constant N.div => - "(fun a b -> if Big_int_Z.eq_big_int b Big_int_Z.zero_big_int - then Big_int_Z.zero_big_int else Big_int_Z.div_big_int a b)". -Extract Constant N.modulo => - "(fun a b -> if Big_int_Z.eq_big_int b Big_int_Z.zero_big_int - then a else Big_int_Z.mod_big_int a b)". -Extract Constant Z.eqb => "Big_int_Z.eq_big_int". -Extract Constant Z.eq_dec => "Big_int_Z.eq_big_int". -Extract Constant N.compare => - "(fun x y -> let s = Big_int_Z.compare_big_int x y in - if s = 0 then Eq else if s < 0 then Lt else Gt)". - -(* In Zarith, the second operand of a shift is an [int]. - The conversion to [int] may throw an [Overflow]. - Bigger shifts involve enormous numbers that don't fit in memory anyway. *) -Extract Constant N.shiftl => "Big_int_Z.(fun x y -> shift_left_big_int x (int_of_big_int y))". -Extract Constant N.shiftr => "Big_int_Z.(fun x y -> shift_right_big_int x (int_of_big_int y))". - -Extract Constant Z.add => "Big_int_Z.add_big_int". -Extract Constant Z.succ => "Big_int_Z.succ_big_int". -Extract Constant Z.pred => "Big_int_Z.pred_big_int". -Extract Constant Z.sub => "Big_int_Z.sub_big_int". -Extract Constant Z.mul => "Big_int_Z.mult_big_int". -Extract Constant Z.opp => "Big_int_Z.minus_big_int". -Extract Constant Z.abs => "Big_int_Z.abs_big_int". -Extract Constant Z.min => "Big_int_Z.min_big_int". -Extract Constant Z.max => "Big_int_Z.max_big_int". -Extract Constant Z.compare => - "(fun x y -> let s = Big_int_Z.compare_big_int x y in - if s = 0 then Eq else if s < 0 then Lt else Gt)". - -Extract Constant Z.eqb => "Big_int_Z.eq_big_int". -Extract Constant Z.eq_dec => "Big_int_Z.eq_big_int". -Extract Constant Z.to_N => "Big_int_Z.(fun p -> if sign_big_int p < 0 then zero_big_int else p)". -Extract Constant Z.of_N => "(fun p -> p)". -Extract Constant Z.abs_N => "Big_int_Z.abs_big_int". - -Extract Constant Z.div_eucl => "Big_int_Z.(fun x y -> - match sign_big_int y with - | 0 -> (zero_big_int, x) - | 1 -> quomod_big_int x y - | _ -> let (q, r) = quomod_big_int (add_int_big_int (-1) x) y in - (add_int_big_int (-1) q, add_big_int (add_int_big_int 1 y) r))". -Extract Constant Z.div => "Big_int_Z.(fun x y -> - match sign_big_int y with - | 0 -> zero_big_int - | 1 -> div_big_int x y - | _ -> add_int_big_int (-1) (div_big_int (add_int_big_int (-1) x) y))". -Extract Constant Z.modulo => "Big_int_Z.(fun x y -> - match sign_big_int y with - | 0 -> x - | 1 -> mod_big_int x y - | _ -> add_big_int y (add_int_big_int 1 (mod_big_int (add_int_big_int (-1) x) y)))". - -Extract Constant Z.shiftl => "Big_int_Z.(fun x y -> - let y = int_of_big_int y in - if y < 0 then shift_right_big_int x (-y) - else shift_left_big_int x y)". -Extract Constant Z.shiftr => "Big_int_Z.(fun x y -> - let y = int_of_big_int y in - if y < 0 then shift_left_big_int x (-y) - else shift_right_big_int x y)". - -(** Test: -Require Import ZArith NArith. - -Extraction "/tmp/test.ml" - Pos.add Pos.pred Pos.sub Pos.mul Pos.compare N.pred N.sub N.div N.modulo N.compare - Z.add Z.mul Z.compare Z.of_N Z.abs_N Z.div Z.modulo. -*) diff --git a/stdlib/theories/extraction/ExtrOcamlZInt.v b/stdlib/theories/extraction/ExtrOcamlZInt.v deleted file mode 100644 index 4c66ec65886a..000000000000 --- a/stdlib/theories/extraction/ExtrOcamlZInt.v +++ /dev/null @@ -1,85 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* int -[ "(fun p->1+2*p)" "(fun p->2*p)" "1" ] -"(fun f2p1 f2p f1 p -> - if p<=1 then f1 () else if p mod 2 = 0 then f2p (p/2) else f2p1 (p/2))". - -Extract Inductive Z => int [ "0" "" "(~-)" ] -"(fun f0 fp fn z -> if z=0 then f0 () else if z>0 then fp z else fn (-z))". - -Extract Inductive N => int [ "0" "" ] -"(fun f0 fp n -> if n=0 then f0 () else fp n)". - -(** Nota: the "" above is used as an identity function "(fun p->p)" *) - -(** Efficient (but uncertified) versions for usual functions *) - -Extract Constant Pos.add => "(+)". -Extract Constant Pos.succ => "Stdlib.Int.succ". -(* Stdlib.Int.max only available in >= 4.13 *) -Extract Constant Pos.pred => "fun n -> Stdlib.max 1 (n-1)". -Extract Constant Pos.sub => "fun n m -> Stdlib.max 1 (n-m)". -Extract Constant Pos.mul => "( * )". -Extract Constant Pos.min => "Stdlib.min". -Extract Constant Pos.max => "Stdlib.max". -Extract Constant Pos.compare => - "fun x y -> if x=y then Eq else if x - "fun c x y -> if x=y then c else if x "(+)". -Extract Constant N.succ => "Stdlib.Int.succ". -Extract Constant N.pred => "fun n -> Stdlib.Int.max 0 (n-1)". -Extract Constant N.sub => "fun n m -> Stdlib.Int.max 0 (n-m)". -Extract Constant N.mul => "( * )". -(* Stdlib.Int.max only available in >= 4.13 *) -Extract Constant N.min => "Stdlib.min". -Extract Constant N.max => "Stdlib.max". -Extract Constant N.div => "fun a b -> if b=0 then 0 else a/b". -Extract Constant N.modulo => "fun a b -> if b=0 then a else a mod b". -Extract Constant N.compare => - "fun x y -> if x=y then Eq else if x "(+)". -Extract Constant Z.succ => "Stdlib.Int.succ". -Extract Constant Z.pred => "Stdlib.Int.pred". -Extract Constant Z.sub => "(-)". -Extract Constant Z.mul => "( * )". -Extract Constant Z.opp => "(~-)". -Extract Constant Z.abs => "Stdlib.Int.abs". -(* Stdlib.Int.max only available in >= 4.13 *) -Extract Constant Z.min => "Stdlib.min". -Extract Constant Z.max => "Stdlib.max". -Extract Constant Z.compare => - "fun x y -> if x=y then Eq else if x "fun p -> p". -Extract Constant Z.abs_N => "Stdlib.Int.abs". - -(** Z.div and Z.modulo are quite complex to define in terms of (/) and (mod). - For the moment we don't even try *) diff --git a/stdlib/theories/extraction/Extraction.v b/stdlib/theories/extraction/Extraction.v deleted file mode 100644 index 99afe3f47564..000000000000 --- a/stdlib/theories/extraction/Extraction.v +++ /dev/null @@ -1 +0,0 @@ -From Corelib Require Export Extraction. diff --git a/stdlib/theories/funind/FunInd.v b/stdlib/theories/funind/FunInd.v deleted file mode 100644 index 01ccd90cec9e..000000000000 --- a/stdlib/theories/funind/FunInd.v +++ /dev/null @@ -1,12 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* A) -> A -> A := - fun (fl : A -> A) (def : A) => - match n with - | O => def - | S m => fl (iter m fl def) - end. -End Iter. - -Theorem le_lt_SS x y : x <= y -> x < S (S y). -Proof. - intros. now apply Nat.lt_succ_r, Nat.le_le_succ_r. -Qed. - -Theorem Splus_lt x y : y < S (x + y). -Proof. - apply Nat.lt_succ_r. apply Nat.le_add_l. -Qed. - -Theorem SSplus_lt x y : x < S (S (x + y)). -Proof. - apply le_lt_SS, Nat.le_add_r. -Qed. - -Inductive max_type (m n:nat) : Set := - cmt : forall v, m <= v -> n <= v -> max_type m n. - -Definition max m n : max_type m n. -Proof. - destruct (Compare_dec.le_gt_dec m n) as [h|h]. - - exists n; [exact h | apply le_n]. - - exists m; [apply le_n | apply Nat.lt_le_incl; exact h]. -Defined. - -Definition Acc_intro_generator_function := fun A R => @Acc_intro_generator A R 100. diff --git a/stdlib/theories/micromega/DeclConstant.v b/stdlib/theories/micromega/DeclConstant.v deleted file mode 100644 index cf88f918ffbe..000000000000 --- a/stdlib/theories/micromega/DeclConstant.v +++ /dev/null @@ -1,82 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* T2) (A : T1) : - DeclaredConstant F -> - GT A -> GT (F A). -Defined. - -#[global] -Instance GT_APP2 {T1 T2 T3: Type} (F : T1 -> T2 -> T3) - {A1 : T1} {A2 : T2} {DC:DeclaredConstant F} : - GT A1 -> GT A2 -> GT (F A1 A2). -Defined. - -Require Import QArith_base. - -#[global] -Instance DO : DeclaredConstant O := {}. -#[global] -Instance DS : DeclaredConstant S := {}. -#[global] -Instance DxH: DeclaredConstant xH := {}. -#[global] -Instance DxI: DeclaredConstant xI := {}. -#[global] -Instance DxO: DeclaredConstant xO := {}. -#[global] -Instance DZO: DeclaredConstant Z0 := {}. -#[global] -Instance DZpos: DeclaredConstant Zpos := {}. -#[global] -Instance DZneg: DeclaredConstant Zneg := {}. -#[global] -Instance DZpow_pos : DeclaredConstant Z.pow_pos := {}. -#[global] -Instance DZpow : DeclaredConstant Z.pow := {}. - -#[global] -Instance DQ : DeclaredConstant Qmake := {}. diff --git a/stdlib/theories/micromega/Env.v b/stdlib/theories/micromega/Env.v deleted file mode 100644 index 29b3ad6ecca5..000000000000 --- a/stdlib/theories/micromega/Env.v +++ /dev/null @@ -1,101 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* D. - - Definition jump (j:positive) (e:Env) := fun x => e (x+j). - - Definition nth (n:positive) (e:Env) := e n. - - Definition hd (e:Env) := nth 1 e. - - Definition tail (e:Env) := jump 1 e. - - Lemma jump_add i j l x : jump (i + j) l x = jump i (jump j l) x. - Proof. - unfold jump. f_equal. apply Pos.add_assoc. - Qed. - - Lemma jump_simpl p l x : - jump p l x = - match p with - | xH => tail l x - | xO p => jump p (jump p l) x - | xI p => jump p (jump p (tail l)) x - end. - Proof. - destruct p; unfold tail; rewrite <- ?jump_add; f_equal; - now rewrite Pos.add_diag. - Qed. - - Lemma jump_tl j l x : tail (jump j l) x = jump j (tail l) x. - Proof. - unfold tail. rewrite <- !jump_add. f_equal. apply Pos.add_comm. - Qed. - - Lemma jump_succ j l x : jump (Pos.succ j) l x = jump 1 (jump j l) x. - Proof. - rewrite <- jump_add. f_equal. symmetry. apply Pos.add_1_l. - Qed. - - Lemma jump_pred_double i l x : - jump (Pos.pred_double i) (tail l) x = jump i (jump i l) x. - Proof. - unfold tail. rewrite <- !jump_add. f_equal. - now rewrite Pos.add_1_r, Pos.succ_pred_double, Pos.add_diag. - Qed. - - Lemma nth_spec p l : - nth p l = - match p with - | xH => hd l - | xO p => nth p (jump p l) - | xI p => nth p (jump p (tail l)) - end. - Proof. - unfold hd, nth, tail, jump. - destruct p; f_equal; now rewrite Pos.add_diag. - Qed. - - Lemma nth_jump p l : nth p (tail l) = hd (jump p l). - Proof. - unfold hd, nth, tail, jump. f_equal. apply Pos.add_comm. - Qed. - - Lemma nth_pred_double p l : - nth (Pos.pred_double p) (tail l) = nth p (jump p l). - Proof. - unfold nth, tail, jump. f_equal. - now rewrite Pos.add_1_r, Pos.succ_pred_double, Pos.add_diag. - Qed. - -End S. - -Ltac jump_simpl := - repeat - match goal with - | |- context [jump xH] => rewrite (jump_simpl xH) - | |- context [jump (xO ?p)] => rewrite (jump_simpl (xO p)) - | |- context [jump (xI ?p)] => rewrite (jump_simpl (xI p)) - end. diff --git a/stdlib/theories/micromega/EnvRing.v b/stdlib/theories/micromega/EnvRing.v deleted file mode 100644 index 11164346d7cf..000000000000 --- a/stdlib/theories/micromega/EnvRing.v +++ /dev/null @@ -1,1115 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* PExpr -| PEX : positive -> PExpr -| PEadd : PExpr -> PExpr -> PExpr -| PEsub : PExpr -> PExpr -> PExpr -| PEmul : PExpr -> PExpr -> PExpr -| PEopp : PExpr -> PExpr -| PEpow : PExpr -> N -> PExpr. -Arguments PExpr : clear implicits. - -Register PEc as micromega.PExpr.PEc. -Register PEX as micromega.PExpr.PEX. -Register PEadd as micromega.PExpr.PEadd. -Register PEsub as micromega.PExpr.PEsub. -Register PEmul as micromega.PExpr.PEmul. -Register PEopp as micromega.PExpr.PEopp. -Register PEpow as micromega.PExpr.PEpow. - - (* Definition of multivariable polynomials with coefficients in C : - Type [Pol] represents [X1 ... Xn]. - The representation is Horner's where a [n] variable polynomial - (C[X1..Xn]) is seen as a polynomial on [X1] which coefficients - are polynomials with [n-1] variables (C[X2..Xn]). - There are several optimisations to make the repr compacter: - - [Pc c] is the constant polynomial of value c - == c*X1^0*..*Xn^0 - - [Pinj j Q] is a polynomial constant w.r.t the [j] first variables. - variable indices are shifted of j in Q. - == X1^0 *..* Xj^0 * Q{X1 <- Xj+1;..; Xn-j <- Xn} - - [PX P i Q] is an optimised Horner form of P*X^i + Q - with P not the null polynomial - == P * X1^i + Q{X1 <- X2; ..; Xn-1 <- Xn} - - In addition: - - polynomials of the form (PX (PX P i (Pc 0)) j Q) are forbidden - since they can be represented by the simpler form (PX P (i+j) Q) - - (Pinj i (Pinj j P)) is (Pinj (i+j) P) - - (Pinj i (Pc c)) is (Pc c) - *) - -#[universes(template)] -Inductive Pol {C} : Type := -| Pc : C -> Pol -| Pinj : positive -> Pol -> Pol -| PX : Pol -> positive -> Pol -> Pol. -Arguments Pol : clear implicits. - -Register Pc as micromega.Pol.Pc. -Register Pinj as micromega.Pol.Pinj. -Register PX as micromega.Pol.PX. - -Section MakeRingPol. - - (* Ring elements *) - Variable R:Type. - Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R->R). - Variable req : R -> R -> Prop. - - (* Ring properties *) - Variable Rsth : Equivalence req. - Variable Reqe : ring_eq_ext radd rmul ropp req. - Variable ARth : almost_ring_theory rO rI radd rmul rsub ropp req. - - (* Coefficients *) - Variable C: Type. - Variable (cO cI: C) (cadd cmul csub : C->C->C) (copp : C->C). - Variable ceqb : C->C->bool. - Variable phi : C -> R. - Variable CRmorph : ring_morph rO rI radd rmul rsub ropp req - cO cI cadd cmul csub copp ceqb phi. - - (* Power coefficients *) - Variable Cpow : Type. - Variable Cp_phi : N -> Cpow. - Variable rpow : R -> Cpow -> R. - Variable pow_th : power_theory rI rmul req Cp_phi rpow. - - (* R notations *) - Notation "0" := rO. Notation "1" := rI. - Infix "+" := radd. Infix "*" := rmul. - Infix "-" := rsub. Notation "- x" := (ropp x). - Infix "==" := req. - Infix "^" := (pow_pos rmul). - - (* C notations *) - Infix "+!" := cadd. Infix "*!" := cmul. - Infix "-! " := csub. Notation "-! x" := (copp x). - Infix "?=!" := ceqb. Notation "[ x ]" := (phi x). - - (* Useful tactics *) - Add Morphism radd with signature (req ==> req ==> req) as radd_ext. - Proof. exact (Radd_ext Reqe). Qed. - - Add Morphism rmul with signature (req ==> req ==> req) as rmul_ext. - Proof. exact (Rmul_ext Reqe). Qed. - - Add Morphism ropp with signature (req ==> req) as ropp_ext. - Proof. exact (Ropp_ext Reqe). Qed. - - Add Morphism rsub with signature (req ==> req ==> req) as rsub_ext. - Proof. exact (ARsub_ext Rsth Reqe ARth). Qed. - - Ltac rsimpl := gen_srewrite Rsth Reqe ARth. - - Ltac add_push := gen_add_push radd Rsth Reqe ARth. - Ltac mul_push := gen_mul_push rmul Rsth Reqe ARth. - - Ltac add_permut_rec t := - match t with - | ?x + ?y => add_permut_rec y || add_permut_rec x - | _ => add_push t; apply (Radd_ext Reqe); [|reflexivity] - end. - - Ltac add_permut := - repeat (reflexivity || - match goal with |- ?t == _ => add_permut_rec t end). - - Ltac mul_permut_rec t := - match t with - | ?x * ?y => mul_permut_rec y || mul_permut_rec x - | _ => mul_push t; apply (Rmul_ext Reqe); [|reflexivity] - end. - - Ltac mul_permut := - repeat (reflexivity || - match goal with |- ?t == _ => mul_permut_rec t end). - - - Notation PExpr := (PExpr C). - Notation Pol := (Pol C). - - Implicit Types pe : PExpr. - Implicit Types P : Pol. - - Definition P0 := Pc cO. - Definition P1 := Pc cI. - - Fixpoint Peq (P P' : Pol) {struct P'} : bool := - match P, P' with - | Pc c, Pc c' => c ?=! c' - | Pinj j Q, Pinj j' Q' => - match j ?= j' with - | Eq => Peq Q Q' - | _ => false - end - | PX P i Q, PX P' i' Q' => - match i ?= i' with - | Eq => if Peq P P' then Peq Q Q' else false - | _ => false - end - | _, _ => false - end. - - Infix "?==" := Peq. - - Definition mkPinj j P := - match P with - | Pc _ => P - | Pinj j' Q => Pinj (j + j') Q - | _ => Pinj j P - end. - - Definition mkPinj_pred j P := - match j with - | xH => P - | xO j => Pinj (Pos.pred_double j) P - | xI j => Pinj (xO j) P - end. - - Definition mkPX P i Q := - match P with - | Pc c => if c ?=! cO then mkPinj xH Q else PX P i Q - | Pinj _ _ => PX P i Q - | PX P' i' Q' => if Q' ?== P0 then PX P' (i' + i) Q else PX P i Q - end. - - Definition mkXi i := PX P1 i P0. - - Definition mkX := mkXi 1. - - (** Opposite of addition *) - - Fixpoint Popp (P:Pol) : Pol := - match P with - | Pc c => Pc (-! c) - | Pinj j Q => Pinj j (Popp Q) - | PX P i Q => PX (Popp P) i (Popp Q) - end. - - Notation "-- P" := (Popp P). - - (** Addition et subtraction *) - - Fixpoint PaddC (P:Pol) (c:C) : Pol := - match P with - | Pc c1 => Pc (c1 +! c) - | Pinj j Q => Pinj j (PaddC Q c) - | PX P i Q => PX P i (PaddC Q c) - end. - - Fixpoint PsubC (P:Pol) (c:C) : Pol := - match P with - | Pc c1 => Pc (c1 -! c) - | Pinj j Q => Pinj j (PsubC Q c) - | PX P i Q => PX P i (PsubC Q c) - end. - - Section PopI. - - Variable Pop : Pol -> Pol -> Pol. - Variable Q : Pol. - - Fixpoint PaddI (j:positive) (P:Pol) : Pol := - match P with - | Pc c => mkPinj j (PaddC Q c) - | Pinj j' Q' => - match Z.pos_sub j' j with - | Zpos k => mkPinj j (Pop (Pinj k Q') Q) - | Z0 => mkPinj j (Pop Q' Q) - | Zneg k => mkPinj j' (PaddI k Q') - end - | PX P i Q' => - match j with - | xH => PX P i (Pop Q' Q) - | xO j => PX P i (PaddI (Pos.pred_double j) Q') - | xI j => PX P i (PaddI (xO j) Q') - end - end. - - Fixpoint PsubI (j:positive) (P:Pol) : Pol := - match P with - | Pc c => mkPinj j (PaddC (--Q) c) - | Pinj j' Q' => - match Z.pos_sub j' j with - | Zpos k => mkPinj j (Pop (Pinj k Q') Q) - | Z0 => mkPinj j (Pop Q' Q) - | Zneg k => mkPinj j' (PsubI k Q') - end - | PX P i Q' => - match j with - | xH => PX P i (Pop Q' Q) - | xO j => PX P i (PsubI (Pos.pred_double j) Q') - | xI j => PX P i (PsubI (xO j) Q') - end - end. - - Variable P' : Pol. - - Fixpoint PaddX (i':positive) (P:Pol) : Pol := - match P with - | Pc c => PX P' i' P - | Pinj j Q' => - match j with - | xH => PX P' i' Q' - | xO j => PX P' i' (Pinj (Pos.pred_double j) Q') - | xI j => PX P' i' (Pinj (xO j) Q') - end - | PX P i Q' => - match Z.pos_sub i i' with - | Zpos k => mkPX (Pop (PX P k P0) P') i' Q' - | Z0 => mkPX (Pop P P') i Q' - | Zneg k => mkPX (PaddX k P) i Q' - end - end. - - Fixpoint PsubX (i':positive) (P:Pol) : Pol := - match P with - | Pc c => PX (--P') i' P - | Pinj j Q' => - match j with - | xH => PX (--P') i' Q' - | xO j => PX (--P') i' (Pinj (Pos.pred_double j) Q') - | xI j => PX (--P') i' (Pinj (xO j) Q') - end - | PX P i Q' => - match Z.pos_sub i i' with - | Zpos k => mkPX (Pop (PX P k P0) P') i' Q' - | Z0 => mkPX (Pop P P') i Q' - | Zneg k => mkPX (PsubX k P) i Q' - end - end. - - - End PopI. - - Fixpoint Padd (P P': Pol) {struct P'} : Pol := - match P' with - | Pc c' => PaddC P c' - | Pinj j' Q' => PaddI Padd Q' j' P - | PX P' i' Q' => - match P with - | Pc c => PX P' i' (PaddC Q' c) - | Pinj j Q => - match j with - | xH => PX P' i' (Padd Q Q') - | xO j => PX P' i' (Padd (Pinj (Pos.pred_double j) Q) Q') - | xI j => PX P' i' (Padd (Pinj (xO j) Q) Q') - end - | PX P i Q => - match Z.pos_sub i i' with - | Zpos k => mkPX (Padd (PX P k P0) P') i' (Padd Q Q') - | Z0 => mkPX (Padd P P') i (Padd Q Q') - | Zneg k => mkPX (PaddX Padd P' k P) i (Padd Q Q') - end - end - end. - Infix "++" := Padd. - - Fixpoint Psub (P P': Pol) {struct P'} : Pol := - match P' with - | Pc c' => PsubC P c' - | Pinj j' Q' => PsubI Psub Q' j' P - | PX P' i' Q' => - match P with - | Pc c => PX (--P') i' (*(--(PsubC Q' c))*) (PaddC (--Q') c) - | Pinj j Q => - match j with - | xH => PX (--P') i' (Psub Q Q') - | xO j => PX (--P') i' (Psub (Pinj (Pos.pred_double j) Q) Q') - | xI j => PX (--P') i' (Psub (Pinj (xO j) Q) Q') - end - | PX P i Q => - match Z.pos_sub i i' with - | Zpos k => mkPX (Psub (PX P k P0) P') i' (Psub Q Q') - | Z0 => mkPX (Psub P P') i (Psub Q Q') - | Zneg k => mkPX (PsubX Psub P' k P) i (Psub Q Q') - end - end - end. - Infix "--" := Psub. - - (** Multiplication *) - - Fixpoint PmulC_aux (P:Pol) (c:C) : Pol := - match P with - | Pc c' => Pc (c' *! c) - | Pinj j Q => mkPinj j (PmulC_aux Q c) - | PX P i Q => mkPX (PmulC_aux P c) i (PmulC_aux Q c) - end. - - Definition PmulC P c := - if c ?=! cO then P0 else - if c ?=! cI then P else PmulC_aux P c. - - Section PmulI. - Variable Pmul : Pol -> Pol -> Pol. - Variable Q : Pol. - Fixpoint PmulI (j:positive) (P:Pol) : Pol := - match P with - | Pc c => mkPinj j (PmulC Q c) - | Pinj j' Q' => - match Z.pos_sub j' j with - | Zpos k => mkPinj j (Pmul (Pinj k Q') Q) - | Z0 => mkPinj j (Pmul Q' Q) - | Zneg k => mkPinj j' (PmulI k Q') - end - | PX P' i' Q' => - match j with - | xH => mkPX (PmulI xH P') i' (Pmul Q' Q) - | xO j' => mkPX (PmulI j P') i' (PmulI (Pos.pred_double j') Q') - | xI j' => mkPX (PmulI j P') i' (PmulI (xO j') Q') - end - end. - - End PmulI. - - Fixpoint Pmul (P P'' : Pol) {struct P''} : Pol := - match P'' with - | Pc c => PmulC P c - | Pinj j' Q' => PmulI Pmul Q' j' P - | PX P' i' Q' => - match P with - | Pc c => PmulC P'' c - | Pinj j Q => - let QQ' := - match j with - | xH => Pmul Q Q' - | xO j => Pmul (Pinj (Pos.pred_double j) Q) Q' - | xI j => Pmul (Pinj (xO j) Q) Q' - end in - mkPX (Pmul P P') i' QQ' - | PX P i Q=> - let QQ' := Pmul Q Q' in - let PQ' := PmulI Pmul Q' xH P in - let QP' := Pmul (mkPinj xH Q) P' in - let PP' := Pmul P P' in - (mkPX (mkPX PP' i P0 ++ QP') i' P0) ++ mkPX PQ' i QQ' - end - end. - - Infix "**" := Pmul. - - Fixpoint Psquare (P:Pol) : Pol := - match P with - | Pc c => Pc (c *! c) - | Pinj j Q => Pinj j (Psquare Q) - | PX P i Q => - let twoPQ := Pmul P (mkPinj xH (PmulC Q (cI +! cI))) in - let Q2 := Psquare Q in - let P2 := Psquare P in - mkPX (mkPX P2 i P0 ++ twoPQ) i Q2 - end. - - (** Monomial **) - - (** A monomial is X1^k1...Xi^ki. Its representation - is a simplified version of the polynomial representation: - - - [mon0] correspond to the polynom [P1]. - - [(zmon j M)] corresponds to [(Pinj j ...)], - i.e. skip j variable indices. - - [(vmon i M)] is X^i*M with X the current variable, - its corresponds to (PX P1 i ...)] - *) - - Inductive Mon: Set := - | mon0: Mon - | zmon: positive -> Mon -> Mon - | vmon: positive -> Mon -> Mon. - - Definition mkZmon j M := - match M with mon0 => mon0 | _ => zmon j M end. - - Definition zmon_pred j M := - match j with xH => M | _ => mkZmon (Pos.pred j) M end. - - Definition mkVmon i M := - match M with - | mon0 => vmon i mon0 - | zmon j m => vmon i (zmon_pred j m) - | vmon i' m => vmon (i+i') m - end. - - Fixpoint MFactor (P: Pol) (M: Mon) : Pol * Pol := - match P, M with - _, mon0 => (Pc cO, P) - | Pc _, _ => (P, Pc cO) - | Pinj j1 P1, zmon j2 M1 => - match (j1 ?= j2) with - Eq => let (R,S) := MFactor P1 M1 in - (mkPinj j1 R, mkPinj j1 S) - | Lt => let (R,S) := MFactor P1 (zmon (j2 - j1) M1) in - (mkPinj j1 R, mkPinj j1 S) - | Gt => (P, Pc cO) - end - | Pinj _ _, vmon _ _ => (P, Pc cO) - | PX P1 i Q1, zmon j M1 => - let M2 := zmon_pred j M1 in - let (R1, S1) := MFactor P1 M in - let (R2, S2) := MFactor Q1 M2 in - (mkPX R1 i R2, mkPX S1 i S2) - | PX P1 i Q1, vmon j M1 => - match (i ?= j) with - Eq => let (R1,S1) := MFactor P1 (mkZmon xH M1) in - (mkPX R1 i Q1, S1) - | Lt => let (R1,S1) := MFactor P1 (vmon (j - i) M1) in - (mkPX R1 i Q1, S1) - | Gt => let (R1,S1) := MFactor P1 (mkZmon xH M1) in - (mkPX R1 i Q1, mkPX S1 (i-j) (Pc cO)) - end - end. - - Definition POneSubst (P1: Pol) (M1: Mon) (P2: Pol): option Pol := - let (Q1,R1) := MFactor P1 M1 in - match R1 with - (Pc c) => if c ?=! cO then None - else Some (Padd Q1 (Pmul P2 R1)) - | _ => Some (Padd Q1 (Pmul P2 R1)) - end. - - Fixpoint PNSubst1 (P1: Pol) (M1: Mon) (P2: Pol) (n: nat) : Pol := - match POneSubst P1 M1 P2 with - Some P3 => match n with S n1 => PNSubst1 P3 M1 P2 n1 | _ => P3 end - | _ => P1 - end. - - Definition PNSubst (P1: Pol) (M1: Mon) (P2: Pol) (n: nat): option Pol := - match POneSubst P1 M1 P2 with - Some P3 => match n with S n1 => Some (PNSubst1 P3 M1 P2 n1) | _ => None end - | _ => None - end. - - Fixpoint PSubstL1 (P1: Pol) (LM1: list (Mon * Pol)) (n: nat) : Pol := - match LM1 with - cons (M1,P2) LM2 => PSubstL1 (PNSubst1 P1 M1 P2 n) LM2 n - | _ => P1 - end. - - Fixpoint PSubstL (P1: Pol) (LM1: list (Mon * Pol)) (n: nat) : option Pol := - match LM1 with - cons (M1,P2) LM2 => - match PNSubst P1 M1 P2 n with - Some P3 => Some (PSubstL1 P3 LM2 n) - | None => PSubstL P1 LM2 n - end - | _ => None - end. - - Fixpoint PNSubstL (P1: Pol) (LM1: list (Mon * Pol)) (m n: nat) : Pol := - match PSubstL P1 LM1 n with - Some P3 => match m with S m1 => PNSubstL P3 LM1 m1 n | _ => P3 end - | _ => P1 - end. - - (** Evaluation of a polynomial towards R *) - - Fixpoint Pphi(l:Env R) (P:Pol) : R := - match P with - | Pc c => [c] - | Pinj j Q => Pphi (jump j l) Q - | PX P i Q => Pphi l P * (hd l) ^ i + Pphi (tail l) Q - end. - - Reserved Notation "P @ l " (at level 10, no associativity). - Notation "P @ l " := (Pphi l P). - - (** Evaluation of a monomial towards R *) - - Fixpoint Mphi(l:Env R) (M: Mon) : R := - match M with - | mon0 => rI - | zmon j M1 => Mphi (jump j l) M1 - | vmon i M1 => Mphi (tail l) M1 * (hd l) ^ i - end. - - Notation "M @@ l" := (Mphi l M) (at level 10, no associativity). - - (** Proofs *) - - Ltac destr_pos_sub := - match goal with |- context [Z.pos_sub ?x ?y] => - generalize (Z.pos_sub_discr x y); destruct (Z.pos_sub x y) - end. - - Lemma Peq_ok P P' : (P ?== P') = true -> forall l, P@l == P'@ l. - Proof. - revert P';induction P as [|p P IHP|P2 IHP1 p P3 IHP2]; - intro P';destruct P' as [|p0 P'|P'1 p0 P'2];simpl; intros H l; try easy. - - now apply (morph_eq CRmorph). - - destruct (Pos.compare_spec p p0); [ subst | easy | easy ]. - now rewrite IHP. - - specialize (IHP1 P'1); specialize (IHP2 P'2). - destruct (Pos.compare_spec p p0); [ subst | easy | easy ]. - destruct (P2 ?== P'1); [|easy]. - rewrite H in *. - now rewrite IHP1, IHP2. - Qed. - - Lemma Peq_spec P P' : - BoolSpec (forall l, P@l == P'@l) True (P ?== P'). - Proof. - generalize (Peq_ok P P'). destruct (P ?== P'); auto. - Qed. - - Lemma Pphi0 l : P0@l == 0. - Proof. - simpl;apply (morph0 CRmorph). - Qed. - - Lemma Pphi1 l : P1@l == 1. - Proof. - simpl;apply (morph1 CRmorph). - Qed. - -Lemma env_morph p e1 e2 : - (forall x, e1 x = e2 x) -> p @ e1 = p @ e2. -Proof. - revert e1 e2. induction p as [|? ? IHp|? IHp1 ? ? IHp2]; simpl. - - reflexivity. - - intros e1 e2 EQ. apply IHp. intros. apply EQ. - - intros e1 e2 EQ. f_equal; [f_equal|]. - + now apply IHp1. - + f_equal. apply EQ. - + apply IHp2. intros; apply EQ. -Qed. - -Lemma Pjump_add P i j l : - P @ (jump (i + j) l) = P @ (jump j (jump i l)). -Proof. - apply env_morph. intros. rewrite <- jump_add. f_equal. - apply Pos.add_comm. -Qed. - -Lemma Pjump_xO_tail P p l : - P @ (jump (xO p) (tail l)) = P @ (jump (xI p) l). -Proof. - apply env_morph. intros. now jump_simpl. -Qed. - -Lemma Pjump_pred_double P p l : - P @ (jump (Pos.pred_double p) (tail l)) = P @ (jump (xO p) l). -Proof. - apply env_morph. intros. - rewrite jump_pred_double. now jump_simpl. -Qed. - - Lemma mkPinj_ok j l P : (mkPinj j P)@l == P@(jump j l). - Proof. - destruct P;simpl;rsimpl. - now rewrite Pjump_add. - Qed. - - Lemma pow_pos_add x i j : x^(j + i) == x^i * x^j. - Proof. - rewrite Pos.add_comm. - apply (pow_pos_add Rsth (Rmul_ext Reqe) (ARmul_assoc ARth)). - Qed. - - Lemma ceqb_spec c c' : BoolSpec ([c] == [c']) True (c ?=! c'). - Proof. - generalize (morph_eq CRmorph c c'). - destruct (c ?=! c'); auto. - Qed. - - Lemma mkPX_ok l P i Q : - (mkPX P i Q)@l == P@l * (hd l)^i + Q@(tail l). - Proof. - unfold mkPX. destruct P. - - case ceqb_spec; intros H; simpl; try reflexivity. - rewrite H, (morph0 CRmorph), mkPinj_ok; rsimpl. - - reflexivity. - - case Peq_spec; intros H; simpl; try reflexivity. - rewrite H, Pphi0, Pos.add_comm, pow_pos_add; rsimpl. - Qed. - - Hint Rewrite - Pphi0 - Pphi1 - mkPinj_ok - mkPX_ok - (morph0 CRmorph) - (morph1 CRmorph) - (morph0 CRmorph) - (morph_add CRmorph) - (morph_mul CRmorph) - (morph_sub CRmorph) - (morph_opp CRmorph) - : Esimpl. - - (* Quicker than autorewrite with Esimpl :-) *) - Ltac Esimpl := try rewrite_db Esimpl; rsimpl; simpl. - - Lemma PaddC_ok c P l : (PaddC P c)@l == P@l + [c]. - Proof. - revert l;induction P as [| |? ? ? ? IHP2];simpl;intros;Esimpl;trivial. - rewrite IHP2;rsimpl. - Qed. - - Lemma PsubC_ok c P l : (PsubC P c)@l == P@l - [c]. - Proof. - revert l;induction P as [|? ? IHP|? ? ? ? IHP2];simpl;intros. - - Esimpl. - - rewrite IHP;rsimpl. - - rewrite IHP2;rsimpl. - Qed. - - Lemma PmulC_aux_ok c P l : (PmulC_aux P c)@l == P@l * [c]. - Proof. - revert l;induction P as [| |? IHP1 ? ? IHP2];simpl;intros;Esimpl;trivial. - rewrite IHP1, IHP2;rsimpl. add_permut. mul_permut. - Qed. - - Lemma PmulC_ok c P l : (PmulC P c)@l == P@l * [c]. - Proof. - unfold PmulC. - case ceqb_spec; intros H. - - rewrite H; Esimpl. - - case ceqb_spec; intros H'. - + rewrite H'; Esimpl. - + apply PmulC_aux_ok. - Qed. - - Lemma Popp_ok P l : (--P)@l == - P@l. - Proof. - revert l;induction P as [|? ? IHP|? IHP1 ? ? IHP2];simpl;intros. - - Esimpl. - - apply IHP. - - rewrite IHP1, IHP2;rsimpl. - Qed. - - Hint Rewrite PaddC_ok PsubC_ok PmulC_ok Popp_ok : Esimpl. - - Lemma PaddX_ok P' P k l : - (forall P l, (P++P')@l == P@l + P'@l) -> - (PaddX Padd P' k P) @ l == P@l + P'@l * (hd l)^k. - Proof. - intros IHP'. - revert k l. induction P as [|p|? IHP1];simpl;intros. - - add_permut. - - destruct p; simpl; - rewrite ?Pjump_xO_tail, ?Pjump_pred_double; add_permut. - - destr_pos_sub; intros ->;Esimpl. - + rewrite IHP';rsimpl. add_permut. - + rewrite IHP', pow_pos_add;simpl;Esimpl. add_permut. - + rewrite IHP1, pow_pos_add;rsimpl. add_permut. - Qed. - - Lemma Padd_ok P' P l : (P ++ P')@l == P@l + P'@l. - Proof. - revert P l; induction P' as [|p P' IHP'|? IHP'1 ? ? IHP'2];simpl;intros P l;Esimpl. - - revert p l; induction P as [|? P IHP|? IHP1 p ? IHP2];simpl;intros p0 l. - + Esimpl; add_permut. - + destr_pos_sub; intros ->;Esimpl. - * now rewrite IHP'. - * rewrite IHP';Esimpl. now rewrite Pjump_add. - * rewrite IHP. now rewrite Pjump_add. - + destruct p0;simpl. - * rewrite IHP2;simpl. rsimpl. rewrite Pjump_xO_tail. Esimpl. - * rewrite IHP2;simpl. rewrite Pjump_pred_double. rsimpl. - * rewrite IHP'. rsimpl. - - destruct P as [|p0|];simpl. - + Esimpl. add_permut. - + destruct p0;simpl;Esimpl; rewrite IHP'2; simpl. - * rewrite Pjump_xO_tail. rsimpl. add_permut. - * rewrite Pjump_pred_double. rsimpl. add_permut. - * rsimpl. unfold tail. add_permut. - + destr_pos_sub; intros ->; Esimpl. - * rewrite IHP'1, IHP'2;rsimpl. add_permut. - * rewrite IHP'1, IHP'2;simpl;Esimpl. - rewrite pow_pos_add;rsimpl. add_permut. - * rewrite PaddX_ok by trivial; rsimpl. - rewrite IHP'2, pow_pos_add; rsimpl. add_permut. - Qed. - - Lemma PsubX_ok P' P k l : - (forall P l, (P--P')@l == P@l - P'@l) -> - (PsubX Psub P' k P) @ l == P@l - P'@l * (hd l)^k. - Proof. - intros IHP'. - revert k l. induction P as [|p|? IHP1];simpl;intros. - - rewrite Popp_ok;rsimpl; add_permut. - - destruct p; simpl; - rewrite Popp_ok;rsimpl; - rewrite ?Pjump_xO_tail, ?Pjump_pred_double; add_permut. - - destr_pos_sub; intros ->; Esimpl. - + rewrite IHP';rsimpl. add_permut. - + rewrite IHP', pow_pos_add;simpl;Esimpl. add_permut. - + rewrite IHP1, pow_pos_add;rsimpl. add_permut. - Qed. - - Lemma Psub_ok P' P l : (P -- P')@l == P@l - P'@l. - Proof. - revert P l; induction P' as [|p P' IHP'|? IHP'1 ? ? IHP'2];simpl;intros P l;Esimpl. - - revert p l; induction P as [|? ? IHP|? IHP1 ? ? IHP2];simpl;intros p0 l. - + Esimpl; add_permut. - + destr_pos_sub; intros ->;Esimpl. - * rewrite IHP';rsimpl. - * rewrite IHP';Esimpl. now rewrite Pjump_add. - * rewrite IHP. now rewrite Pjump_add. - + destruct p0;simpl. - * rewrite IHP2;simpl. rsimpl. rewrite Pjump_xO_tail. Esimpl. - * rewrite IHP2;simpl. rewrite Pjump_pred_double. rsimpl. - * rewrite IHP'. rsimpl. - - destruct P as [|p0|];simpl. - + Esimpl; add_permut. - + destruct p0;simpl;Esimpl; rewrite IHP'2; simpl. - * rewrite Pjump_xO_tail. rsimpl. add_permut. - * rewrite Pjump_pred_double. rsimpl. add_permut. - * rsimpl. unfold tail. add_permut. - + destr_pos_sub; intros ->; Esimpl. - * rewrite IHP'1, IHP'2;rsimpl. add_permut. - * rewrite IHP'1, IHP'2;simpl;Esimpl. - rewrite pow_pos_add;rsimpl. add_permut. - * rewrite PsubX_ok by trivial;rsimpl. - rewrite IHP'2, pow_pos_add;rsimpl. add_permut. - Qed. - - Lemma PmulI_ok P' : - (forall P l, (Pmul P P') @ l == P @ l * P' @ l) -> - forall P p l, (PmulI Pmul P' p P) @ l == P @ l * P' @ (jump p l). - Proof. - intros IHP' P. - induction P as [|? ? IHP|? IHP1 ? ? IHP2];simpl;intros p0 l. - - Esimpl; mul_permut. - - destr_pos_sub; intros ->;Esimpl. - + now rewrite IHP'. - + now rewrite IHP', Pjump_add. - + now rewrite IHP, Pjump_add. - - destruct p0;Esimpl; rewrite ?IHP1, ?IHP2; rsimpl. - + rewrite Pjump_xO_tail. f_equiv. mul_permut. - + rewrite Pjump_pred_double. f_equiv. mul_permut. - + rewrite IHP'. f_equiv. mul_permut. - Qed. - - Lemma Pmul_ok P P' l : (P**P')@l == P@l * P'@l. - Proof. - revert P l;induction P' as [| |? IHP'1 ? ? IHP'2];simpl;intros P l. - - apply PmulC_ok. - - apply PmulI_ok;trivial. - - destruct P as [|p0|]. - + rewrite (ARmul_comm ARth). Esimpl. - + Esimpl. rewrite IHP'1;Esimpl. f_equiv. - destruct p0;rewrite IHP'2;Esimpl. - * now rewrite Pjump_xO_tail. - * rewrite Pjump_pred_double; Esimpl. - + rewrite Padd_ok, !mkPX_ok, Padd_ok, !mkPX_ok, - !IHP'1, !IHP'2, PmulI_ok; trivial. simpl. Esimpl. - unfold tail. - add_permut; f_equiv; mul_permut. - Qed. - - Lemma Psquare_ok P l : (Psquare P)@l == P@l * P@l. - Proof. - revert l;induction P as [|? ? IHP|P2 IHP1 p ? IHP2];simpl;intros l;Esimpl. - - apply IHP. - - rewrite Padd_ok, Pmul_ok;Esimpl. - rewrite IHP1, IHP2. - mul_push ((hd l)^p). now mul_push (P2@l). - Qed. - - Lemma Mphi_morph M e1 e2 : - (forall x, e1 x = e2 x) -> M @@ e1 = M @@ e2. - Proof. - revert e1 e2; induction M as [|? ? IHM|? ? IHM]; simpl; intros e1 e2 EQ; trivial. - - apply IHM. intros; apply EQ. - - f_equal. - * apply IHM. intros; apply EQ. - * f_equal. apply EQ. - Qed. - -Lemma Mjump_xO_tail M p l : - M @@ (jump (xO p) (tail l)) = M @@ (jump (xI p) l). -Proof. - apply Mphi_morph. intros. now jump_simpl. -Qed. - -Lemma Mjump_pred_double M p l : - M @@ (jump (Pos.pred_double p) (tail l)) = M @@ (jump (xO p) l). -Proof. - apply Mphi_morph. intros. - rewrite jump_pred_double. now jump_simpl. -Qed. - -Lemma Mjump_add M i j l : - M @@ (jump (i + j) l) = M @@ (jump j (jump i l)). -Proof. - apply Mphi_morph. intros. now rewrite <- jump_add, Pos.add_comm. -Qed. - - Lemma mkZmon_ok M j l : - (mkZmon j M) @@ l == (zmon j M) @@ l. - Proof. - destruct M; simpl; rsimpl. - Qed. - - Lemma zmon_pred_ok M j l : - (zmon_pred j M) @@ (tail l) == (zmon j M) @@ l. - Proof. - destruct j; simpl; rewrite ?mkZmon_ok; simpl; rsimpl. - - now rewrite Mjump_xO_tail. - - rewrite Mjump_pred_double; rsimpl. - Qed. - - Lemma mkVmon_ok M i l : - (mkVmon i M)@@l == M@@l * (hd l)^i. - Proof. - destruct M;simpl;intros;rsimpl. - - rewrite zmon_pred_ok;simpl;rsimpl. - - rewrite pow_pos_add;rsimpl. - Qed. - - Ltac destr_mfactor R S := match goal with - | H : context [MFactor ?P _] |- context [MFactor ?P ?M] => - specialize (H M); destruct MFactor as (R,S) - end. - - Lemma Mphi_ok P M l : - let (Q,R) := MFactor P M in - P@l == Q@l + M@@l * R@l. - Proof. - revert M l; induction P as [|? ? IHP|? IHP1 ? ? IHP2]; - intros M; destruct M; intros l; simpl; auto; Esimpl. - - case Pos.compare_spec; intros He; simpl. - * destr_mfactor R1 S1. now rewrite IHP, He, !mkPinj_ok. - * destr_mfactor R1 S1. rewrite IHP; simpl. - now rewrite !mkPinj_ok, <- Mjump_add, Pos.add_comm, Pos.sub_add. - * Esimpl. - - destr_mfactor R1 S1. destr_mfactor R2 S2. - rewrite IHP1, IHP2, !mkPX_ok, zmon_pred_ok; simpl; rsimpl. - add_permut. - - case Pos.compare_spec; intros He; simpl; destr_mfactor R1 S1; - rewrite ?He, IHP1, mkPX_ok, ?mkZmon_ok; simpl; rsimpl; - unfold tail; add_permut; mul_permut. - * rewrite <- pow_pos_add, Pos.add_comm, Pos.sub_add by trivial; rsimpl. - * rewrite mkPX_ok. simpl. Esimpl. mul_permut. - rewrite <- pow_pos_add, Pos.sub_add by trivial; rsimpl. - Qed. - - Lemma POneSubst_ok P1 M1 P2 P3 l : - POneSubst P1 M1 P2 = Some P3 -> M1@@l == P2@l -> - P1@l == P3@l. - Proof. - unfold POneSubst. - assert (H := Mphi_ok P1). destr_mfactor R1 S1. rewrite H; clear H. - intros EQ EQ'. replace P3 with (R1 ++ P2 ** S1). - - rewrite EQ', Padd_ok, Pmul_ok; rsimpl. - - revert EQ. destruct S1; try now injection 1. - case ceqb_spec; now inversion 2. - Qed. - - Lemma PNSubst1_ok n P1 M1 P2 l : - M1@@l == P2@l -> P1@l == (PNSubst1 P1 M1 P2 n)@l. - Proof. - revert P1. induction n as [|n IHn]; simpl; intros P1; - generalize (POneSubst_ok P1 M1 P2); destruct POneSubst; - intros; rewrite <- ?IHn; auto; reflexivity. - Qed. - - Lemma PNSubst_ok n P1 M1 P2 l P3 : - PNSubst P1 M1 P2 n = Some P3 -> M1@@l == P2@l -> P1@l == P3@l. - Proof. - unfold PNSubst. - assert (H := POneSubst_ok P1 M1 P2); destruct POneSubst; try discriminate. - destruct n; inversion_clear 1. - intros. rewrite <- PNSubst1_ok; auto. - Qed. - - Fixpoint MPcond (LM1: list (Mon * Pol)) (l: Env R) : Prop := - match LM1 with - | cons (M1,P2) LM2 => (M1@@l == P2@l) /\ MPcond LM2 l - | _ => True - end. - - Lemma PSubstL1_ok n LM1 P1 l : - MPcond LM1 l -> P1@l == (PSubstL1 P1 LM1 n)@l. - Proof. - revert P1; induction LM1 as [|(M2,P2) LM2 IH]; simpl; intros. - - reflexivity. - - rewrite <- IH by intuition. now apply PNSubst1_ok. - Qed. - - Lemma PSubstL_ok n LM1 P1 P2 l : - PSubstL P1 LM1 n = Some P2 -> MPcond LM1 l -> P1@l == P2@l. - Proof. - revert P1. induction LM1 as [|(M2,P2') LM2 IH]; simpl; intros P3 H **. - - discriminate. - - assert (H':=PNSubst_ok n P3 M2 P2'). destruct PNSubst. - * injection H as [= <-]. rewrite <- PSubstL1_ok; intuition. - * now apply IH. - Qed. - - Lemma PNSubstL_ok m n LM1 P1 l : - MPcond LM1 l -> P1@l == (PNSubstL P1 LM1 m n)@l. - Proof. - revert LM1 P1. induction m as [|m IHm]; simpl; intros LM1 P2 **; - assert (H' := PSubstL_ok n LM1 P2); destruct PSubstL; - auto; try reflexivity. - rewrite <- IHm; auto. - Qed. - - (** evaluation of polynomial expressions towards R *) - Definition mk_X j := mkPinj_pred j mkX. - - (** evaluation of polynomial expressions towards R *) - - Fixpoint PEeval (l:Env R) (pe:PExpr) : R := - match pe with - | PEc c => phi c - | PEX j => nth j l - | PEadd pe1 pe2 => (PEeval l pe1) + (PEeval l pe2) - | PEsub pe1 pe2 => (PEeval l pe1) - (PEeval l pe2) - | PEmul pe1 pe2 => (PEeval l pe1) * (PEeval l pe2) - | PEopp pe1 => - (PEeval l pe1) - | PEpow pe1 n => rpow (PEeval l pe1) (Cp_phi n) - end. - - (** Correctness proofs *) - - Lemma mkX_ok p l : nth p l == (mk_X p) @ l. - Proof. - destruct p;simpl;intros;Esimpl;trivial. - rewrite nth_spec ; auto. - unfold hd. - now rewrite <- nth_pred_double, nth_jump. - Qed. - - Hint Rewrite Padd_ok Psub_ok : Esimpl. - -Section POWER. - Variable subst_l : Pol -> Pol. - Fixpoint Ppow_pos (res P:Pol) (p:positive) : Pol := - match p with - | xH => subst_l (res ** P) - | xO p => Ppow_pos (Ppow_pos res P p) P p - | xI p => subst_l ((Ppow_pos (Ppow_pos res P p) P p) ** P) - end. - - Definition Ppow_N P n := - match n with - | N0 => P1 - | Npos p => Ppow_pos P1 P p - end. - - Lemma Ppow_pos_ok l : - (forall P, subst_l P@l == P@l) -> - forall res P p, (Ppow_pos res P p)@l == res@l * (pow_pos Pmul P p)@l. - Proof. - intros subst_l_ok res P p. revert res. - induction p as [p IHp|p IHp|];simpl;intros; rewrite ?subst_l_ok, ?Pmul_ok, ?IHp; - mul_permut. - Qed. - - Lemma Ppow_N_ok l : - (forall P, subst_l P@l == P@l) -> - forall P n, (Ppow_N P n)@l == (pow_N P1 Pmul P n)@l. - Proof. - intros ? P n;destruct n;simpl. - - reflexivity. - - rewrite Ppow_pos_ok by trivial. Esimpl. - Qed. - - End POWER. - - (** Normalization and rewriting *) - - Section NORM_SUBST_REC. - Variable n : nat. - Variable lmp:list (Mon*Pol). - Let subst_l P := PNSubstL P lmp n n. - Let Pmul_subst P1 P2 := subst_l (Pmul P1 P2). - Let Ppow_subst := Ppow_N subst_l. - - Fixpoint norm_aux (pe:PExpr) : Pol := - match pe with - | PEc c => Pc c - | PEX j => mk_X j - | PEadd (PEopp pe1) pe2 => Psub (norm_aux pe2) (norm_aux pe1) - | PEadd pe1 (PEopp pe2) => - Psub (norm_aux pe1) (norm_aux pe2) - | PEadd pe1 pe2 => Padd (norm_aux pe1) (norm_aux pe2) - | PEsub pe1 pe2 => Psub (norm_aux pe1) (norm_aux pe2) - | PEmul pe1 pe2 => Pmul (norm_aux pe1) (norm_aux pe2) - | PEopp pe1 => Popp (norm_aux pe1) - | PEpow pe1 n => Ppow_N (fun p => p) (norm_aux pe1) n - end. - - Definition norm_subst pe := subst_l (norm_aux pe). - - (** Internally, [norm_aux] is expanded in a large number of cases. - To speed-up proofs, we use an alternative definition. *) - - Definition get_PEopp pe := - match pe with - | PEopp pe' => Some pe' - | _ => None - end. - - Lemma norm_aux_PEadd pe1 pe2 : - norm_aux (PEadd pe1 pe2) = - match get_PEopp pe1, get_PEopp pe2 with - | Some pe1', _ => (norm_aux pe2) -- (norm_aux pe1') - | None, Some pe2' => (norm_aux pe1) -- (norm_aux pe2') - | None, None => (norm_aux pe1) ++ (norm_aux pe2) - end. - Proof. - simpl (norm_aux (PEadd _ _)). - destruct pe1; [ | | | | | reflexivity | ]; - destruct pe2; simpl get_PEopp; reflexivity. - Qed. - - Lemma norm_aux_PEopp pe : - match get_PEopp pe with - | Some pe' => norm_aux pe = -- (norm_aux pe') - | None => True - end. - Proof. - now destruct pe. - Qed. - - Lemma norm_aux_spec l pe : - PEeval l pe == (norm_aux pe)@l. - Proof. - intros. - induction pe as [| |pe1 IHpe1 pe2 IHpe2|? IHpe1 ? IHpe2|? IHpe1 ? IHpe2|? IHpe|? IHpe n0]. - - reflexivity. - - apply mkX_ok. - - simpl PEeval. rewrite IHpe1, IHpe2. - assert (H1 := norm_aux_PEopp pe1). - assert (H2 := norm_aux_PEopp pe2). - rewrite norm_aux_PEadd. - do 2 destruct get_PEopp; rewrite ?H1, ?H2; Esimpl; add_permut. - - simpl. rewrite IHpe1, IHpe2. Esimpl. - - simpl. rewrite IHpe1, IHpe2. now rewrite Pmul_ok. - - simpl. rewrite IHpe. Esimpl. - - simpl. rewrite Ppow_N_ok by reflexivity. - rewrite (rpow_pow_N pow_th). destruct n0 as [|p]; simpl; Esimpl. - induction p as [p IHp|p IHp|];simpl; now rewrite ?IHp, ?IHpe, ?Pms_ok, ?Pmul_ok. - Qed. - - End NORM_SUBST_REC. - -End MakeRingPol. diff --git a/stdlib/theories/micromega/Fourier.v b/stdlib/theories/micromega/Fourier.v deleted file mode 100644 index 0153de1dabdd..000000000000 --- a/stdlib/theories/micromega/Fourier.v +++ /dev/null @@ -1,5 +0,0 @@ -Require Import Lra. -Require Export Fourier_util. - -#[deprecated(since = "8.9.0", note = "Use lra instead.")] -Ltac fourier := lra. diff --git a/stdlib/theories/micromega/Fourier_util.v b/stdlib/theories/micromega/Fourier_util.v deleted file mode 100644 index b40b66b5279e..000000000000 --- a/stdlib/theories/micromega/Fourier_util.v +++ /dev/null @@ -1,34 +0,0 @@ -Require Export Rbase. -Require Import Lra. - -Local Open Scope R_scope. - -Lemma Rlt_mult_inv_pos : forall x y:R, 0 < x -> 0 < y -> 0 < x * / y. -Proof. -intros x y H H0; try assumption. -replace 0 with (x * 0). -- apply Rmult_lt_compat_l; auto with real. -- ring. -Qed. - -Lemma Rlt_zero_pos_plus1 : forall x:R, 0 < x -> 0 < 1 + x. -Proof. -intros x H; try assumption. -rewrite Rplus_comm. -apply Rplus_lt_0_compat; [assumption | exact Rlt_0_1]. -Qed. - -Lemma Rle_zero_pos_plus1 : forall x:R, 0 <= x -> 0 <= 1 + x. -Proof. - intros; lra. -Qed. - -Lemma Rle_mult_inv_pos : forall x y:R, 0 <= x -> 0 < y -> 0 <= x * / y. -Proof. -intros x y H H0; try assumption. -case H; intros. -- red; left. - apply Rlt_mult_inv_pos; auto with real. -- rewrite <- H1. - red; right; ring. -Qed. diff --git a/stdlib/theories/micromega/Lia.v b/stdlib/theories/micromega/Lia.v deleted file mode 100644 index a0389e2da618..000000000000 --- a/stdlib/theories/micromega/Lia.v +++ /dev/null @@ -1,34 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* - ((xsos_Q rchecker) || (xpsatz_Q d rchecker)) - | _ => fail "Unsupported domain" - end in tac. - -Tactic Notation "psatz" constr(dom) int_or_var(n) := xpsatz dom n. -Tactic Notation "psatz" constr(dom) := xpsatz dom ltac:(-1). - -(* Local Variables: *) -(* coding: utf-8 *) -(* End: *) diff --git a/stdlib/theories/micromega/Lra.v b/stdlib/theories/micromega/Lra.v deleted file mode 100644 index 4a27d90f5971..000000000000 --- a/stdlib/theories/micromega/Lra.v +++ /dev/null @@ -1,58 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* - (xsos_R rchecker) || (xpsatz_R d rchecker) - | _ => fail "Unsupported domain" - end in tac. - -Tactic Notation "psatz" constr(dom) int_or_var(n) := xpsatz dom n. -Tactic Notation "psatz" constr(dom) := xpsatz dom ltac:(-1). - -(* Local Variables: *) -(* coding: utf-8 *) -(* End: *) diff --git a/stdlib/theories/micromega/MExtraction.v b/stdlib/theories/micromega/MExtraction.v deleted file mode 100644 index e7dafde42ebd..000000000000 --- a/stdlib/theories/micromega/MExtraction.v +++ /dev/null @@ -1,67 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* "( * )" [ "(,)" ]. -Extract Inductive list => list [ "[]" "(::)" ]. -Extract Inductive bool => bool [ true false ]. -Extract Inductive sumbool => bool [ true false ]. -Extract Inductive option => option [ Some None ]. -Extract Inductive sumor => option [ Some None ]. -(** Then, in a ternary alternative { }+{ }+{ }, - - leftmost choice (Inleft Left) is (Some true), - - middle choice (Inleft Right) is (Some false), - - rightmost choice (Inright) is (None) *) - - -(** To preserve its laziness, andb is normally expanded. - Let's rather use the ocaml && *) -Extract Inlined Constant andb => "(&&)". - -Import Reals.Rdefinitions. - -Extract Constant R => "int". -Extract Constant R0 => "0". -Extract Constant R1 => "1". -Extract Constant Rplus => "( + )". -Extract Constant Rmult => "( * )". -Extract Constant Ropp => "fun x -> - x". -Extract Constant Rinv => "fun x -> 1 / x". - -(** In order to avoid annoying build dependencies the actual - extraction is only performed as a test in the test suite. *) -(* -Extraction "micromega.ml" - Tauto.mapX Tauto.foldA Tauto.collect_annot Tauto.ids_of_formula Tauto.map_bformula - Tauto.abst_form - ZMicromega.cnfZ ZMicromega.Zeval_const QMicromega.cnfQ - List.map simpl_cone (*map_cone indexes*) - denorm QArith_base.Qpower vm_add - normZ normQ normQ n_of_Z N.of_nat ZTautoChecker ZWeakChecker QTautoChecker RTautoChecker find. -*) -(* Local Variables: *) -(* coding: utf-8 *) -(* End: *) diff --git a/stdlib/theories/micromega/OrderedRing.v b/stdlib/theories/micromega/OrderedRing.v deleted file mode 100644 index 15eaf7124ebf..000000000000 --- a/stdlib/theories/micromega/OrderedRing.v +++ /dev/null @@ -1,473 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* R -> R) (ropp : R -> R). -Variable req rle rlt : R -> R -> Prop. -Notation "0" := rO. -Notation "1" := rI. -Notation "x + y" := (rplus x y). -Notation "x * y " := (rtimes x y). -Notation "x - y " := (rminus x y). -Notation "- x" := (ropp x). -Notation "x == y" := (req x y). -Notation "x ~= y" := (~ req x y). -Notation "x <= y" := (rle x y). -Notation "x < y" := (rlt x y). - -Record SOR : Prop := mk_SOR_theory { - SORsetoid : Setoid_Theory R req; - SORplus_wd : forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 + y1 == x2 + y2; - SORtimes_wd : forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 * y1 == x2 * y2; - SORopp_wd : forall x1 x2, x1 == x2 -> -x1 == -x2; - SORle_wd : forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> (x1 <= y1 <-> x2 <= y2); - SORlt_wd : forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> (x1 < y1 <-> x2 < y2); - SORrt : ring_theory rO rI rplus rtimes rminus ropp req; - SORle_refl : forall n : R, n <= n; - SORle_antisymm : forall n m : R, n <= m -> m <= n -> n == m; - SORle_trans : forall n m p : R, n <= m -> m <= p -> n <= p; - SORlt_le_neq : forall n m : R, n < m <-> n <= m /\ n ~= m; - SORlt_trichotomy : forall n m : R, n < m \/ n == m \/ m < n; - SORplus_le_mono_l : forall n m p : R, n <= m -> p + n <= p + m; - SORtimes_pos_pos : forall n m : R, 0 < n -> 0 < m -> 0 < n * m; - SORneq_0_1 : 0 ~= 1 -}. - -(* We cannot use Relation_Definitions.order.ord_antisym and -Relations_1.Antisymmetric because they refer to Leibniz equality *) - -End DEFINITIONS. - -Section STRICT_ORDERED_RING. - -Variable R : Type. -Variable (rO rI : R) (rplus rtimes rminus: R -> R -> R) (ropp : R -> R). -Variable req rle rlt : R -> R -> Prop. - -Variable sor : SOR rO rI rplus rtimes rminus ropp req rle rlt. - -Notation "0" := rO. -Notation "1" := rI. -Notation "x + y" := (rplus x y). -Notation "x * y " := (rtimes x y). -Notation "x - y " := (rminus x y). -Notation "- x" := (ropp x). -Notation "x == y" := (req x y). -Notation "x ~= y" := (~ req x y). -Notation "x <= y" := (rle x y). -Notation "x < y" := (rlt x y). - - -Add Relation R req - reflexivity proved by (@Equivalence_Reflexive _ _ (SORsetoid sor)) - symmetry proved by (@Equivalence_Symmetric _ _ (SORsetoid sor)) - transitivity proved by (@Equivalence_Transitive _ _ (SORsetoid sor)) -as sor_setoid. - - -Add Morphism rplus with signature req ==> req ==> req as rplus_morph. -Proof. -exact (SORplus_wd sor). -Qed. -Add Morphism rtimes with signature req ==> req ==> req as rtimes_morph. -Proof. -exact (SORtimes_wd sor). -Qed. -Add Morphism ropp with signature req ==> req as ropp_morph. -Proof. -exact (SORopp_wd sor). -Qed. -Add Morphism rle with signature req ==> req ==> iff as rle_morph. -Proof. -exact (SORle_wd sor). -Qed. -Add Morphism rlt with signature req ==> req ==> iff as rlt_morph. -Proof. -exact (SORlt_wd sor). -Qed. - -Add Ring SOR : (SORrt sor). - -Add Morphism rminus with signature req ==> req ==> req as rminus_morph. -Proof. -intros x1 x2 H1 y1 y2 H2. -rewrite ((Rsub_def (SORrt sor)) x1 y1). -rewrite ((Rsub_def (SORrt sor)) x2 y2). -rewrite H1; now rewrite H2. -Qed. - -Theorem Rneq_symm : forall n m : R, n ~= m -> m ~= n. -Proof. -intros n m H1 H2; rewrite H2 in H1; now apply H1. -Qed. - -(* Properties of plus, minus and opp *) - -Theorem Rplus_0_l : forall n : R, 0 + n == n. -Proof. -intro; ring. -Qed. - -Theorem Rplus_0_r : forall n : R, n + 0 == n. -Proof. -intro; ring. -Qed. - -Theorem Rtimes_0_r : forall n : R, n * 0 == 0. -Proof. -intro; ring. -Qed. - -Theorem Rplus_comm : forall n m : R, n + m == m + n. -Proof. -intros; ring. -Qed. - -Theorem Rtimes_0_l : forall n : R, 0 * n == 0. -Proof. -intro; ring. -Qed. - -Theorem Rtimes_comm : forall n m : R, n * m == m * n. -Proof. -intros; ring. -Qed. - -Theorem Rminus_eq_0 : forall n m : R, n - m == 0 <-> n == m. -Proof. -intros n m. -split; intro H. -- setoid_replace n with ((n - m) + m) by ring. rewrite H. - now rewrite Rplus_0_l. -- rewrite H; ring. -Qed. - -Theorem Rplus_cancel_l : forall n m p : R, p + n == p + m <-> n == m. -Proof. -intros n m p; split; intro H. -- setoid_replace n with (- p + (p + n)) by ring. - setoid_replace m with (- p + (p + m)) by ring. now rewrite H. -- now rewrite H. -Qed. - -(* Relations *) - -Theorem Rle_refl : forall n : R, n <= n. -Proof (SORle_refl sor). - -Theorem Rle_antisymm : forall n m : R, n <= m -> m <= n -> n == m. -Proof (SORle_antisymm sor). - -Theorem Rle_trans : forall n m p : R, n <= m -> m <= p -> n <= p. -Proof (SORle_trans sor). - -Theorem Rlt_trichotomy : forall n m : R, n < m \/ n == m \/ m < n. -Proof (SORlt_trichotomy sor). - -Theorem Rlt_le_neq : forall n m : R, n < m <-> n <= m /\ n ~= m. -Proof (SORlt_le_neq sor). - -Theorem Rneq_0_1 : 0 ~= 1. -Proof (SORneq_0_1 sor). - -Theorem Req_em : forall n m : R, n == m \/ n ~= m. -Proof. -intros n m. destruct (Rlt_trichotomy n m) as [H | [H | H]]; try rewrite Rlt_le_neq in H. -- right; now destruct H. -- now left. -- right; apply Rneq_symm; now destruct H. -Qed. - -Theorem Req_dne : forall n m : R, ~ ~ n == m <-> n == m. -Proof. -intros n m; destruct (Req_em n m) as [H | H]. -- split; auto. -- split. - + intro H1; false_hyp H H1. - + auto. -Qed. - -Theorem Rle_lt_eq : forall n m : R, n <= m <-> n < m \/ n == m. -Proof. -intros n m; rewrite Rlt_le_neq. -split; [intro H | intros [[H1 H2] | H]]. -- destruct (Req_em n m) as [H1 | H1]. - + now right. - + left; now split. -- assumption. -- rewrite H; apply Rle_refl. -Qed. - -Ltac le_less := rewrite Rle_lt_eq; left; try assumption. -Ltac le_equal := rewrite Rle_lt_eq; right; try reflexivity; try assumption. -Ltac le_elim H := rewrite Rle_lt_eq in H; destruct H as [H | H]. - -Theorem Rlt_trans : forall n m p : R, n < m -> m < p -> n < p. -Proof. -intros n m p; repeat rewrite Rlt_le_neq; intros [H1 H2] [H3 H4]; split. -- now apply Rle_trans with m. -- intro H. rewrite H in H1. pose proof (Rle_antisymm H3 H1). now apply H4. -Qed. - -Theorem Rle_lt_trans : forall n m p : R, n <= m -> m < p -> n < p. -Proof. -intros n m p H1 H2; le_elim H1. -- now apply (Rlt_trans (m := m)). - now rewrite H1. -Qed. - -Theorem Rlt_le_trans : forall n m p : R, n < m -> m <= p -> n < p. -Proof. -intros n m p H1 H2; le_elim H2. -- now apply (Rlt_trans (m := m)). - now rewrite <- H2. -Qed. - -Theorem Rle_gt_cases : forall n m : R, n <= m \/ m < n. -Proof. -intros n m; destruct (Rlt_trichotomy n m) as [H | [H | H]]. -- left; now le_less. - left; now le_equal. - now right. -Qed. - -Theorem Rlt_neq : forall n m : R, n < m -> n ~= m. -Proof. -intros n m; rewrite Rlt_le_neq; now intros [_ H]. -Qed. - -Theorem Rle_ngt : forall n m : R, n <= m <-> ~ m < n. -Proof. -intros n m; split. -- intros H H1; assert (H2 : n < n) by now apply Rle_lt_trans with m. now apply (Rlt_neq H2). -- intro H. destruct (Rle_gt_cases n m) as [H1 | H1]. - + assumption. - + false_hyp H1 H. -Qed. - -Theorem Rlt_nge : forall n m : R, n < m <-> ~ m <= n. -Proof. -intros n m; split. -- intros H H1; assert (H2 : n < n) by now apply Rlt_le_trans with m. now apply (Rlt_neq H2). -- intro H. destruct (Rle_gt_cases m n) as [H1 | H1]. - + false_hyp H1 H. - + assumption. -Qed. - -(* Plus, minus and order *) - -Theorem Rplus_le_mono_l : forall n m p : R, n <= m <-> p + n <= p + m. -Proof. -intros n m p; split. -- apply (SORplus_le_mono_l sor). -- intro H. apply ((SORplus_le_mono_l sor) (p + n) (p + m) (- p)) in H. - setoid_replace (- p + (p + n)) with n in H by ring. - setoid_replace (- p + (p + m)) with m in H by ring. assumption. -Qed. - -Theorem Rplus_le_mono_r : forall n m p : R, n <= m <-> n + p <= m + p. -Proof. -intros n m p; rewrite (Rplus_comm n p); rewrite (Rplus_comm m p). -apply Rplus_le_mono_l. -Qed. - -Theorem Rplus_lt_mono_l : forall n m p : R, n < m <-> p + n < p + m. -Proof. -intros n m p; do 2 rewrite Rlt_le_neq. rewrite Rplus_cancel_l. -now rewrite <- Rplus_le_mono_l. -Qed. - -Theorem Rplus_lt_mono_r : forall n m p : R, n < m <-> n + p < m + p. -Proof. -intros n m p. -rewrite (Rplus_comm n p); rewrite (Rplus_comm m p); apply Rplus_lt_mono_l. -Qed. - -Theorem Rplus_lt_mono : forall n m p q : R, n < m -> p < q -> n + p < m + q. -Proof. -intros n m p q H1 H2. -apply Rlt_trans with (m + p); [now apply -> Rplus_lt_mono_r | now apply -> Rplus_lt_mono_l]. -Qed. - -Theorem Rplus_le_mono : forall n m p q : R, n <= m -> p <= q -> n + p <= m + q. -Proof. -intros n m p q H1 H2. -apply Rle_trans with (m + p); [now apply -> Rplus_le_mono_r | now apply -> Rplus_le_mono_l]. -Qed. - -Theorem Rplus_lt_le_mono : forall n m p q : R, n < m -> p <= q -> n + p < m + q. -Proof. -intros n m p q H1 H2. -apply Rlt_le_trans with (m + p); [now apply -> Rplus_lt_mono_r | now apply -> Rplus_le_mono_l]. -Qed. - -Theorem Rplus_le_lt_mono : forall n m p q : R, n <= m -> p < q -> n + p < m + q. -Proof. -intros n m p q H1 H2. -apply Rle_lt_trans with (m + p); [now apply -> Rplus_le_mono_r | now apply -> Rplus_lt_mono_l]. -Qed. - -Theorem Rplus_pos_pos : forall n m : R, 0 < n -> 0 < m -> 0 < n + m. -Proof. -intros n m H1 H2. rewrite <- (Rplus_0_l 0). now apply Rplus_lt_mono. -Qed. - -Theorem Rplus_pos_nonneg : forall n m : R, 0 < n -> 0 <= m -> 0 < n + m. -Proof. -intros n m H1 H2. rewrite <- (Rplus_0_l 0). now apply Rplus_lt_le_mono. -Qed. - -Theorem Rplus_nonneg_pos : forall n m : R, 0 <= n -> 0 < m -> 0 < n + m. -Proof. -intros n m H1 H2. rewrite <- (Rplus_0_l 0). now apply Rplus_le_lt_mono. -Qed. - -Theorem Rplus_nonneg_nonneg : forall n m : R, 0 <= n -> 0 <= m -> 0 <= n + m. -Proof. -intros n m H1 H2. rewrite <- (Rplus_0_l 0). now apply Rplus_le_mono. -Qed. - -Theorem Rle_le_minus : forall n m : R, n <= m <-> 0 <= m - n. -Proof. -intros n m. rewrite (@Rplus_le_mono_r n m (- n)). -setoid_replace (n + - n) with 0 by ring. -now setoid_replace (m + - n) with (m - n) by ring. -Qed. - -Theorem Rlt_lt_minus : forall n m : R, n < m <-> 0 < m - n. -Proof. -intros n m. rewrite (@Rplus_lt_mono_r n m (- n)). -setoid_replace (n + - n) with 0 by ring. -now setoid_replace (m + - n) with (m - n) by ring. -Qed. - -Theorem Ropp_lt_mono : forall n m : R, n < m <-> - m < - n. -Proof. -intros n m. split; intro H. -- apply -> (@Rplus_lt_mono_l n m (- n - m)) in H. - setoid_replace (- n - m + n) with (- m) in H by ring. - now setoid_replace (- n - m + m) with (- n) in H by ring. -- apply -> (@Rplus_lt_mono_l (- m) (- n) (n + m)) in H. - setoid_replace (n + m + - m) with n in H by ring. - now setoid_replace (n + m + - n) with m in H by ring. -Qed. - -Theorem Ropp_pos_neg : forall n : R, 0 < - n <-> n < 0. -Proof. -intro n; rewrite (Ropp_lt_mono n 0). now setoid_replace (- 0) with 0 by ring. -Qed. - -(* Times and order *) - -Theorem Rtimes_pos_pos : forall n m : R, 0 < n -> 0 < m -> 0 < n * m. -Proof (SORtimes_pos_pos sor). - -Theorem Rtimes_nonneg_nonneg : forall n m : R, 0 <= n -> 0 <= m -> 0 <= n * m. -Proof. -intros n m H1 H2. -le_elim H1. -- le_elim H2. - + le_less; now apply Rtimes_pos_pos. - + rewrite <- H2; rewrite Rtimes_0_r; le_equal. -- rewrite <- H1; rewrite Rtimes_0_l; le_equal. -Qed. - -Theorem Rtimes_pos_neg : forall n m : R, 0 < n -> m < 0 -> n * m < 0. -Proof. -intros n m H1 H2. apply -> Ropp_pos_neg. -setoid_replace (- (n * m)) with (n * (- m)) by ring. -apply Rtimes_pos_pos. -- assumption. -- now apply <- Ropp_pos_neg. -Qed. - -Theorem Rtimes_neg_neg : forall n m : R, n < 0 -> m < 0 -> 0 < n * m. -Proof. -intros n m H1 H2. -setoid_replace (n * m) with ((- n) * (- m)) by ring. -apply Rtimes_pos_pos; now apply <- Ropp_pos_neg. -Qed. - -Theorem Rtimes_square_nonneg : forall n : R, 0 <= n * n. -Proof. -intro n; destruct (Rlt_trichotomy 0 n) as [H | [H | H]]. -- le_less; now apply Rtimes_pos_pos. -- rewrite <- H, Rtimes_0_l; le_equal. -- le_less; now apply Rtimes_neg_neg. -Qed. - -Theorem Rtimes_neq_0 : forall n m : R, n ~= 0 /\ m ~= 0 -> n * m ~= 0. -Proof. -intros n m [H1 H2]. -destruct (Rlt_trichotomy n 0) as [H3 | [H3 | H3]]; -destruct (Rlt_trichotomy m 0) as [H4 | [H4 | H4]]; -try (false_hyp H3 H1); try (false_hyp H4 H2). -- apply Rneq_symm. apply Rlt_neq. now apply Rtimes_neg_neg. -- apply Rlt_neq. rewrite Rtimes_comm. now apply Rtimes_pos_neg. -- apply Rlt_neq. now apply Rtimes_pos_neg. -- apply Rneq_symm. apply Rlt_neq. now apply Rtimes_pos_pos. -Qed. - -(* The following theorems are used to build a morphism from Z to R and -prove its properties in ZCoeff.v. They are not used in RingMicromega.v. *) - -(* Surprisingly, multiplication is needed to prove the following theorem *) - -Theorem Ropp_neg_pos : forall n : R, - n < 0 <-> 0 < n. -Proof. -intro n; setoid_replace n with (- - n) by ring. rewrite Ropp_pos_neg. -now setoid_replace (- - n) with n by ring. -Qed. - -Theorem Rlt_0_1 : 0 < 1. -Proof. -apply <- Rlt_le_neq. split. -- setoid_replace 1 with (1 * 1) by ring. apply Rtimes_square_nonneg. -- apply Rneq_0_1. -Qed. - -Theorem Rlt_succ_r : forall n : R, n < 1 + n. -Proof. -intro n. rewrite <- (Rplus_0_l n); setoid_replace (1 + (0 + n)) with (1 + n) by ring. -apply -> Rplus_lt_mono_r. apply Rlt_0_1. -Qed. - -Theorem Rlt_lt_succ : forall n m : R, n < m -> n < 1 + m. -Proof. - intros n m H; apply Rlt_trans with m. - - assumption. - - apply Rlt_succ_r. -Qed. - -(*Theorem Rtimes_lt_mono_pos_l : forall n m p : R, 0 < p -> n < m -> p * n < p * m. -Proof. -intros n m p H1 H2. apply <- Rlt_lt_minus. -setoid_replace (p * m - p * n) with (p * (m - n)) by ring. -apply Rtimes_pos_pos. assumption. now apply -> Rlt_lt_minus. -Qed.*) - -End STRICT_ORDERED_RING. diff --git a/stdlib/theories/micromega/Psatz.v b/stdlib/theories/micromega/Psatz.v deleted file mode 100644 index 324ab2c4983b..000000000000 --- a/stdlib/theories/micromega/Psatz.v +++ /dev/null @@ -1,63 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* (xsos_Z Lia.zchecker) || (xpsatz_Z d Lia.zchecker) - | R => (xsos_R Lra.rchecker) || (xpsatz_R d Lra.rchecker) - | Q => (xsos_Q Lqa.rchecker) || (xpsatz_Q d Lqa.rchecker) - | _ => fail "Unsupported domain" - end in tac. - -Tactic Notation "psatz" constr(dom) int_or_var(n) := xpsatz dom n. -Tactic Notation "psatz" constr(dom) := xpsatz dom ltac:(-1). - -Ltac psatzl dom := - let tac := lazymatch dom with - | Z => Lia.lia - | Q => Lqa.lra - | R => Lra.lra - | _ => fail "Unsupported domain" - end in tac. - -Ltac lra := - first [ psatzl R | psatzl Q ]. - -Ltac nra := - first [ Lra.nra | Lqa.nra ]. - -(* Local Variables: *) -(* coding: utf-8 *) -(* End: *) diff --git a/stdlib/theories/micromega/QMicromega.v b/stdlib/theories/micromega/QMicromega.v deleted file mode 100644 index a5d940c07da0..000000000000 --- a/stdlib/theories/micromega/QMicromega.v +++ /dev/null @@ -1,273 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* x) (fun x => x) (pow_N 1 Qmult). -Proof. - constructor. - - constructor ; intros ; try reflexivity. - apply Qeq_bool_eq; auto. - - constructor. - reflexivity. - - intros x y. - apply Qeq_bool_neq ; auto. - - apply Qle_bool_imp_le. -Qed. - - -(*Definition Zeval_expr := eval_pexpr 0 Z.add Z.mul Z.sub Z.opp (fun x => x) (fun x => Z.of_N x) (Z.pow).*) -Require Import EnvRing. - -Fixpoint Qeval_expr (env: PolEnv Q) (e: PExpr Q) : Q := - match e with - | PEc c => c - | PEX j => env j - | PEadd pe1 pe2 => (Qeval_expr env pe1) + (Qeval_expr env pe2) - | PEsub pe1 pe2 => (Qeval_expr env pe1) - (Qeval_expr env pe2) - | PEmul pe1 pe2 => (Qeval_expr env pe1) * (Qeval_expr env pe2) - | PEopp pe1 => - (Qeval_expr env pe1) - | PEpow pe1 n => Qpower (Qeval_expr env pe1) (Z.of_N n) - end. - -Lemma Qeval_expr_simpl : forall env e, - Qeval_expr env e = - match e with - | PEc c => c - | PEX j => env j - | PEadd pe1 pe2 => (Qeval_expr env pe1) + (Qeval_expr env pe2) - | PEsub pe1 pe2 => (Qeval_expr env pe1) - (Qeval_expr env pe2) - | PEmul pe1 pe2 => (Qeval_expr env pe1) * (Qeval_expr env pe2) - | PEopp pe1 => - (Qeval_expr env pe1) - | PEpow pe1 n => Qpower (Qeval_expr env pe1) (Z.of_N n) - end. -Proof. - destruct e ; reflexivity. -Qed. - -Definition Qeval_expr' := eval_pexpr Qplus Qmult Qminus Qopp (fun x => x) (fun x => x) (pow_N 1 Qmult). - -Lemma QNpower : forall r n, r ^ Z.of_N n = pow_N 1 Qmult r n. -Proof. - destruct n ; reflexivity. -Qed. - - -Lemma Qeval_expr_compat : forall env e, Qeval_expr env e = Qeval_expr' env e. -Proof. - induction e ; simpl ; subst ; try congruence. - - reflexivity. - - rewrite IHe. - apply QNpower. -Qed. - -Definition Qeval_pop2 (o : Op2) : Q -> Q -> Prop := -match o with -| OpEq => Qeq -| OpNEq => fun x y => ~ x == y -| OpLe => Qle -| OpGe => fun x y => Qle y x -| OpLt => Qlt -| OpGt => fun x y => Qlt y x -end. - - -Definition Qlt_bool (x y : Q) := - (Qnum x * QDen y Q -> bool := - match o with - | OpEq => Qeq_bool - | OpNEq => fun x y => negb (Qeq_bool x y) - | OpLe => Qle_bool - | OpGe => fun x y => Qle_bool y x - | OpLt => Qlt_bool - | OpGt => fun x y => Qlt_bool y x - end. - -Lemma Qlt_bool_iff : forall q1 q2, - Qlt_bool q1 q2 = true <-> q1 < q2. -Proof. - unfold Qlt_bool. - unfold Qlt. intros. - apply Z.ltb_lt. -Qed. - -Lemma pop2_bop2 : - forall (op : Op2) (q1 q2 : Q), is_true (Qeval_bop2 op q1 q2) <-> Qeval_pop2 op q1 q2. -Proof. - unfold is_true. - destruct op ; simpl; intros. - - apply Qeq_bool_iff. - - rewrite <- Qeq_bool_iff. - rewrite negb_true_iff. - destruct (Qeq_bool q1 q2) ; intuition congruence. - - apply Qle_bool_iff. - - apply Qle_bool_iff. - - apply Qlt_bool_iff. - - apply Qlt_bool_iff. -Qed. - -Definition Qeval_op2 (k:Tauto.kind) : Op2 -> Q -> Q -> Tauto.rtyp k:= - if k as k0 return (Op2 -> Q -> Q -> Tauto.rtyp k0) - then Qeval_pop2 else Qeval_bop2. - - -Lemma Qeval_op2_hold : forall k op q1 q2, - Tauto.hold k (Qeval_op2 k op q1 q2) <-> Qeval_pop2 op q1 q2. -Proof. - destruct k. - - simpl ; tauto. - - simpl. apply pop2_bop2. -Qed. - -Definition Qeval_formula (e:PolEnv Q) (k: Tauto.kind) (ff : Formula Q) := - let (lhs,o,rhs) := ff in Qeval_op2 k o (Qeval_expr e lhs) (Qeval_expr e rhs). - -Definition Qeval_formula' := - eval_formula Qplus Qmult Qminus Qopp Qeq Qle Qlt (fun x => x) (fun x => x) (pow_N 1 Qmult). - - Lemma Qeval_formula_compat : forall env b f, Tauto.hold b (Qeval_formula env b f) <-> Qeval_formula' env f. -Proof. - intros. - unfold Qeval_formula. - destruct f. - repeat rewrite Qeval_expr_compat. - unfold Qeval_formula'. - unfold Qeval_expr'. - simpl. - rewrite Qeval_op2_hold. - split ; destruct Fop ; simpl; auto. -Qed. - - -Definition Qeval_nformula := - eval_nformula 0 Qplus Qmult Qeq Qle Qlt (fun x => x) . - -Definition Qeval_op1 (o : Op1) : Q -> Prop := -match o with -| Equal => fun x : Q => x == 0 -| NonEqual => fun x : Q => ~ x == 0 -| Strict => fun x : Q => 0 < x -| NonStrict => fun x : Q => 0 <= x -end. - - -Lemma Qeval_nformula_dec : forall env d, (Qeval_nformula env d) \/ ~ (Qeval_nformula env d). -Proof. - exact (fun env d =>eval_nformula_dec Qsor (fun x => x) env d). -Qed. - -Definition QWitness := Psatz Q. - -Register QWitness as micromega.QWitness.type. - - -Definition QWeakChecker := check_normalised_formulas 0 1 Qplus Qmult Qeq_bool Qle_bool. - -Require Import List. - -Lemma QWeakChecker_sound : forall (l : list (NFormula Q)) (cm : QWitness), - QWeakChecker l cm = true -> - forall env, make_impl (Qeval_nformula env) l False. -Proof. - intros l cm H. - intro. - unfold Qeval_nformula. - apply (checker_nf_sound Qsor QSORaddon l cm). - unfold QWeakChecker in H. - exact H. -Qed. - -Require Import Stdlib.micromega.Tauto. - -Definition Qnormalise := @cnf_normalise Q 0 1 Qplus Qmult Qminus Qopp Qeq_bool Qle_bool. - -Definition Qnegate := @cnf_negate Q 0 1 Qplus Qmult Qminus Qopp Qeq_bool Qle_bool. - -Definition qunsat := check_inconsistent 0 Qeq_bool Qle_bool. - -Definition qdeduce := nformula_plus_nformula 0 Qplus Qeq_bool. - -Definition normQ := norm 0 1 Qplus Qmult Qminus Qopp Qeq_bool. -Declare Equivalent Keys normQ RingMicromega.norm. - -Definition cnfQ (Annot:Type) (TX: Tauto.kind -> Type) (AF: Type) (k: Tauto.kind) (f: TFormula (Formula Q) Annot TX AF k) := - rxcnf qunsat qdeduce (Qnormalise Annot) (Qnegate Annot) true f. - -Definition QTautoChecker (f : BFormula (Formula Q) Tauto.isProp) (w: list QWitness) : bool := - @tauto_checker (Formula Q) (NFormula Q) unit - qunsat qdeduce - (Qnormalise unit) - (Qnegate unit) QWitness (fun cl => QWeakChecker (List.map fst cl)) f w. - - - -Lemma QTautoChecker_sound : forall f w, QTautoChecker f w = true -> forall env, eval_bf (Qeval_formula env) f. -Proof. - intros f w. - unfold QTautoChecker. - apply tauto_checker_sound with (eval:= Qeval_formula) (eval':= Qeval_nformula). - - apply Qeval_nformula_dec. - - intros until env. - unfold eval_nformula. unfold RingMicromega.eval_nformula. - destruct t. - apply (check_inconsistent_sound Qsor QSORaddon) ; auto. - - unfold qdeduce. intros. revert H. apply (nformula_plus_nformula_correct Qsor QSORaddon);auto. - - intros. - rewrite Qeval_formula_compat. - eapply (cnf_normalise_correct Qsor QSORaddon) ; eauto. - - intros. rewrite Tauto.hold_eNOT. rewrite Qeval_formula_compat. - now eapply (cnf_negate_correct Qsor QSORaddon);eauto. - - intros t w0. - unfold eval_tt. - intros. - rewrite make_impl_map with (eval := Qeval_nformula env). - + eapply QWeakChecker_sound; eauto. - + tauto. -Qed. diff --git a/stdlib/theories/micromega/RMicromega.v b/stdlib/theories/micromega/RMicromega.v deleted file mode 100644 index d989b6355d1f..000000000000 --- a/stdlib/theories/micromega/RMicromega.v +++ /dev/null @@ -1,571 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* Q2R x = Q2R y. -Proof. - intros. - now apply Qeq_eqR, Qeq_bool_eq. -Qed. - -Lemma Qeq_false : forall x y, Qeq_bool x y = false -> Q2R x <> Q2R y. -Proof. - intros. - apply Qeq_bool_neq in H. - contradict H. - now apply eqR_Qeq. -Qed. - -Lemma Qle_true : forall x y : Q, Qle_bool x y = true -> Q2R x <= Q2R y. -Proof. - intros. - now apply Qle_Rle, Qle_bool_imp_le. -Qed. - -Lemma Q2R_0 : Q2R 0 = 0. -Proof. - apply Rmult_0_l. -Qed. - -Lemma Q2R_1 : Q2R 1 = 1. -Proof. - compute. apply Rinv_1. -Qed. - -Lemma Q2R_inv_ext : forall x, - Q2R (/ x) = (if Qeq_bool x 0 then 0 else / Q2R x). -Proof. - intros. - case_eq (Qeq_bool x 0). - - intros. - apply Qeq_bool_eq in H. - destruct x ; simpl. - unfold Qeq in H. - simpl in H. - rewrite Zmult_1_r in H. - rewrite H. - apply Rmult_0_l. - - intros. - now apply Q2R_inv, Qeq_bool_neq. -Qed. - -Lemma QSORaddon : - @SORaddon R - R0 R1 Rplus Rmult Rminus Ropp (@eq R) Rle (* ring elements *) - Q 0%Q 1%Q Qplus Qmult Qminus Qopp (* coefficients *) - Qeq_bool Qle_bool - Q2R nat N.to_nat pow. -Proof. - constructor. - - constructor ; intros ; try reflexivity. - + apply Q2R_0. - + apply Q2R_1. - + apply Q2R_plus. - + apply Q2R_minus. - + apply Q2R_mult. - + apply Q2R_opp. - + apply Qeq_true ; auto. - - apply R_power_theory. - - apply Qeq_false. - - apply Qle_true. -Qed. - -(* Syntactic ring coefficients. *) - -Inductive Rcst := - | C0 - | C1 - | CQ (r : Q) - | CZ (r : Z) - | CPlus (r1 r2 : Rcst) - | CMinus (r1 r2 : Rcst) - | CMult (r1 r2 : Rcst) - | CPow (r1 : Rcst) (z:Z+nat) - | CInv (r : Rcst) - | COpp (r : Rcst). - -Register Rcst as micromega.Rcst.type. -Register C0 as micromega.Rcst.C0. -Register C1 as micromega.Rcst.C1. -Register CQ as micromega.Rcst.CQ. -Register CZ as micromega.Rcst.CZ. -Register CPlus as micromega.Rcst.CPlus. -Register CMinus as micromega.Rcst.CMinus. -Register CMult as micromega.Rcst.CMult. -Register CPow as micromega.Rcst.CPow. -Register CInv as micromega.Rcst.CInv. -Register COpp as micromega.Rcst.COpp. - -Definition z_of_exp (z : Z + nat) := - match z with - | inl z => z - | inr n => Z.of_nat n - end. - -Fixpoint Q_of_Rcst (r : Rcst) : Q := - match r with - | C0 => 0 # 1 - | C1 => 1 # 1 - | CZ z => z # 1 - | CQ q => q - | CPlus r1 r2 => Qplus (Q_of_Rcst r1) (Q_of_Rcst r2) - | CMinus r1 r2 => Qminus (Q_of_Rcst r1) (Q_of_Rcst r2) - | CMult r1 r2 => Qmult (Q_of_Rcst r1) (Q_of_Rcst r2) - | CPow r1 z => Qpower (Q_of_Rcst r1) (z_of_exp z) - | CInv r => Qinv (Q_of_Rcst r) - | COpp r => Qopp (Q_of_Rcst r) - end. - - -Definition is_neg (z: Z+nat) := - match z with - | inl (Zneg _) => true - | _ => false - end. - -Lemma is_neg_true : forall z, is_neg z = true -> (z_of_exp z < 0)%Z. -Proof. - destruct z ; simpl ; try congruence. - destruct z ; try congruence. - intros. - reflexivity. -Qed. - -Lemma is_neg_false : forall z, is_neg z = false -> (z_of_exp z >= 0)%Z. -Proof. - destruct z ; simpl ; try congruence. - - destruct z ; try congruence. - + compute. congruence. - + compute. congruence. - - generalize (Znat.Nat2Z.is_nonneg n). auto using Z.le_ge. -Qed. - -Definition CInvR0 (r : Rcst) := Qeq_bool (Q_of_Rcst r) (0 # 1). - -Definition CPowR0 (z : Z) (r : Rcst) := - Z.ltb z Z0 && Qeq_bool (Q_of_Rcst r) (0 # 1). - -Fixpoint R_of_Rcst (r : Rcst) : R := - match r with - | C0 => R0 - | C1 => R1 - | CZ z => IZR z - | CQ q => Q2R q - | CPlus r1 r2 => (R_of_Rcst r1) + (R_of_Rcst r2) - | CMinus r1 r2 => (R_of_Rcst r1) - (R_of_Rcst r2) - | CMult r1 r2 => (R_of_Rcst r1) * (R_of_Rcst r2) - | CPow r1 z => - match z with - | inl z => - if CPowR0 z r1 - then R0 - else powerRZ (R_of_Rcst r1) z - | inr n => pow (R_of_Rcst r1) n - end - | CInv r => - if CInvR0 r then R0 - else Rinv (R_of_Rcst r) - | COpp r => - (R_of_Rcst r) - end. - -Add Morphism Q2R with signature Qeq ==> @eq R as Q2R_m. - exact Qeq_eqR. -Qed. - -Lemma Q2R_pow_pos : forall q p, - Q2R (pow_pos Qmult q p) = pow_pos Rmult (Q2R q) p. -Proof. - induction p ; simpl;auto; - rewrite <- IHp; - repeat rewrite Q2R_mult; - reflexivity. -Qed. - -Lemma Q2R_pow_N : forall q n, - Q2R (pow_N 1%Q Qmult q n) = pow_N 1 Rmult (Q2R q) n. -Proof. - destruct n ; simpl. - - apply Q2R_1. - - apply Q2R_pow_pos. -Qed. - -Lemma Qmult_integral : forall q r, q * r == 0 -> q == 0 \/ r == 0. -Proof. - intros. - destruct (Qeq_dec q 0)%Q. - - left ; apply q0. - - apply Qmult_integral_l in H ; tauto. -Qed. - -Lemma Qpower_positive_eq_zero : forall q p, - Qpower_positive q p == 0 -> q == 0. -Proof. - unfold Qpower_positive. - induction p ; simpl; intros; - repeat match goal with - | H : _ * _ == 0 |- _ => - apply Qmult_integral in H; destruct H - end; tauto. -Qed. - -Lemma Qpower_positive_zero : forall p, - Qpower_positive 0 p == 0%Q. -Proof. - induction p ; simpl; - try rewrite IHp ; reflexivity. -Qed. - - -Lemma Q2RpowerRZ : - forall q z - (DEF : not (q == 0)%Q \/ (z >= Z0)%Z), - Q2R (q ^ z) = powerRZ (Q2R q) z. -Proof. - intros. - destruct Qpower_theory. - destruct R_power_theory. - unfold Qpower, powerRZ. - destruct z. - - apply Q2R_1. - - - change (Qpower_positive q p) - with (Qpower q (Zpos p)). - rewrite <- N2Z.inj_pos. - rewrite <- positive_N_nat. - rewrite rpow_pow_N. - rewrite rpow_pow_N0. - apply Q2R_pow_N. - - - rewrite Q2R_inv. - + unfold Qpower_positive. - rewrite <- positive_N_nat. - rewrite rpow_pow_N0. - unfold pow_N. - rewrite Q2R_pow_pos. - auto. - + intro. - apply Qpower_positive_eq_zero in H. - destruct DEF ; auto with arith. -Qed. - -Lemma Qpower0 : forall z, (z <> 0)%Z -> (0 ^ z == 0)%Q. -Proof. - unfold Qpower. - destruct z;intros. - - congruence. - - apply Qpower_positive_zero. - - rewrite Qpower_positive_zero. - reflexivity. -Qed. - - -Lemma Q_of_RcstR : forall c, Q2R (Q_of_Rcst c) = R_of_Rcst c. -Proof. - induction c ; simpl ; try (rewrite <- IHc1 ; rewrite <- IHc2). - - apply Q2R_0. - - apply Q2R_1. - - reflexivity. - - unfold Q2R. simpl. rewrite Rinv_1. reflexivity. - - apply Q2R_plus. - - apply Q2R_minus. - - apply Q2R_mult. - - destruct z. - 1:destruct (CPowR0 z c) eqn:C; unfold CPowR0 in C. - + - rewrite andb_true_iff in C. - destruct C as (C1 & C2). - rewrite Z.ltb_lt in C1. - apply Qeq_bool_eq in C2. - rewrite C2. - simpl. - assert (z <> 0%Z). - { intro ; subst. apply Z.lt_irrefl in C1. auto. } - rewrite Qpower0 by auto. - apply Q2R_0. - + rewrite Q2RpowerRZ. - * rewrite IHc. - reflexivity. - * rewrite andb_false_iff in C. - destruct C. - -- simpl. apply Z.ltb_ge in H. - auto using Z.le_ge. - -- left ; apply Qeq_bool_neq; auto. - + simpl. - rewrite <- IHc. - destruct Qpower_theory. - rewrite <- nat_N_Z. - rewrite rpow_pow_N. - destruct R_power_theory. - rewrite <- (Nnat.Nat2N.id n) at 2. - rewrite rpow_pow_N0. - apply Q2R_pow_N. - - rewrite <- IHc. - unfold CInvR0. - apply Q2R_inv_ext. - - rewrite <- IHc. - apply Q2R_opp. -Qed. - -Require Import EnvRing. - -Definition INZ (n:N) : R := - match n with - | N0 => IZR 0%Z - | Npos p => IZR (Zpos p) - end. - -Definition Reval_expr := eval_pexpr Rplus Rmult Rminus Ropp R_of_Rcst N.to_nat pow. - - -Definition Reval_pop2 (o:Op2) : R -> R -> Prop := - match o with - | OpEq => @eq R - | OpNEq => fun x y => ~ x = y - | OpLe => Rle - | OpGe => Rge - | OpLt => Rlt - | OpGt => Rgt - end. - -Definition sumboolb {A B : Prop} (x : @sumbool A B) : bool := - if x then true else false. - - -Definition Reval_bop2 (o : Op2) : R -> R -> bool := - match o with - | OpEq => fun x y => sumboolb (Req_dec_T x y) - | OpNEq => fun x y => negb (sumboolb (Req_dec_T x y)) - | OpLe => fun x y => (sumboolb (Rle_lt_dec x y)) - | OpGe => fun x y => (sumboolb (Rge_gt_dec x y)) - | OpLt => fun x y => (sumboolb (Rlt_le_dec x y)) - | OpGt => fun x y => (sumboolb (Rgt_dec x y)) - end. - -Lemma pop2_bop2 : - forall (op : Op2) (r1 r2 : R), is_true (Reval_bop2 op r1 r2) <-> Reval_pop2 op r1 r2. -Proof. - unfold is_true. - destruct op ; simpl; intros; - match goal with - | |- context[sumboolb (?F ?X ?Y)] => - destruct (F X Y) ; simpl; intuition try congruence - end. - - apply Rlt_not_le in r. tauto. - - apply Rgt_not_ge in r. tauto. - - apply Rlt_not_le in H. tauto. -Qed. - -Definition Reval_op2 (k: Tauto.kind) : Op2 -> R -> R -> Tauto.rtyp k:= - if k as k0 return (Op2 -> R -> R -> Tauto.rtyp k0) - then Reval_pop2 else Reval_bop2. - -Lemma Reval_op2_hold : forall b op q1 q2, - Tauto.hold b (Reval_op2 b op q1 q2) <-> Reval_pop2 op q1 q2. -Proof. - destruct b. - - simpl ; tauto. - - simpl. apply pop2_bop2. -Qed. - -Definition Reval_formula (e: PolEnv R) (k: Tauto.kind) (ff : Formula Rcst) := - let (lhs,o,rhs) := ff in Reval_op2 k o (Reval_expr e lhs) (Reval_expr e rhs). - - -Definition Reval_formula' := - eval_sformula Rplus Rmult Rminus Ropp (@eq R) Rle Rlt N.to_nat pow R_of_Rcst. - -Lemma Reval_pop2_eval_op2 : forall o e1 e2, - Reval_pop2 o e1 e2 <-> - eval_op2 eq Rle Rlt o e1 e2. -Proof. - destruct o ; simpl ; try tauto. - split. - - apply Rge_le. - - apply Rle_ge. -Qed. - -Lemma Reval_formula_compat : forall env b f, Tauto.hold b (Reval_formula env b f) <-> Reval_formula' env f. -Proof. - intros. - unfold Reval_formula. - destruct f. - unfold Reval_formula'. - simpl. - rewrite Reval_op2_hold. - apply Reval_pop2_eval_op2. -Qed. - -Definition QReval_expr := eval_pexpr Rplus Rmult Rminus Ropp Q2R N.to_nat pow. - -Definition QReval_formula (e: PolEnv R) (k: Tauto.kind) (ff : Formula Q) := - let (lhs,o,rhs) := ff in Reval_op2 k o (QReval_expr e lhs) (QReval_expr e rhs). - - -Definition QReval_formula' := - eval_formula Rplus Rmult Rminus Ropp (@eq R) Rle Rlt Q2R N.to_nat pow. - -Lemma QReval_formula_compat : forall env b f, Tauto.hold b (QReval_formula env b f) <-> QReval_formula' env f. -Proof. - intros. - unfold QReval_formula. - destruct f. - unfold QReval_formula'. - rewrite Reval_op2_hold. - apply Reval_pop2_eval_op2. -Qed. - -Definition Qeval_nformula := - eval_nformula 0 Rplus Rmult (@eq R) Rle Rlt Q2R. - - -Lemma Reval_nformula_dec : forall env d, (Qeval_nformula env d) \/ ~ (Qeval_nformula env d). -Proof. - exact (fun env d =>eval_nformula_dec Rsor Q2R env d). -Qed. - -Definition RWitness := Psatz Q. - -Definition RWeakChecker := check_normalised_formulas 0%Q 1%Q Qplus Qmult Qeq_bool Qle_bool. - -Require Import List. - -Lemma RWeakChecker_sound : forall (l : list (NFormula Q)) (cm : RWitness), - RWeakChecker l cm = true -> - forall env, make_impl (Qeval_nformula env) l False. -Proof. - intros l cm H. - intro. - unfold Qeval_nformula. - apply (checker_nf_sound Rsor QSORaddon l cm). - unfold RWeakChecker in H. - exact H. -Qed. - -Require Import Stdlib.micromega.Tauto. - -Definition Rnormalise := @cnf_normalise Q 0%Q 1%Q Qplus Qmult Qminus Qopp Qeq_bool Qle_bool. -Definition Rnegate := @cnf_negate Q 0%Q 1%Q Qplus Qmult Qminus Qopp Qeq_bool Qle_bool. - -Definition runsat := check_inconsistent 0%Q Qeq_bool Qle_bool. - -Definition rdeduce := nformula_plus_nformula 0%Q Qplus Qeq_bool. - -Definition RTautoChecker (f : BFormula (Formula Rcst) Tauto.isProp) (w: list RWitness) : bool := - @tauto_checker (Formula Q) (NFormula Q) - unit runsat rdeduce - (Rnormalise unit) (Rnegate unit) - RWitness (fun cl => RWeakChecker (List.map fst cl)) (map_bformula (map_Formula Q_of_Rcst) f) w. - -Lemma RTautoChecker_sound : forall f w, RTautoChecker f w = true -> forall env, eval_bf (Reval_formula env) f. -Proof. - intros f w. - unfold RTautoChecker. - intros TC env. - apply tauto_checker_sound with (eval:=QReval_formula) (eval':= Qeval_nformula) (env := env) in TC. - - change (eval_f e_rtyp (QReval_formula env)) - with - (eval_bf (QReval_formula env)) in TC. - rewrite eval_bf_map in TC. - unfold eval_bf in TC. - rewrite eval_f_morph with (ev':= Reval_formula env) in TC ; auto. - intros. - apply Tauto.hold_eiff. - rewrite QReval_formula_compat. - unfold QReval_formula'. - rewrite <- eval_formulaSC with (phiS := R_of_Rcst). - + rewrite Reval_formula_compat. - tauto. - + intro. rewrite Q_of_RcstR. reflexivity. - - - apply Reval_nformula_dec. - - destruct t. - apply (check_inconsistent_sound Rsor QSORaddon) ; auto. - - unfold rdeduce. - intros. revert H. - eapply (nformula_plus_nformula_correct Rsor QSORaddon); eauto. - - - intros. - rewrite QReval_formula_compat. - eapply (cnf_normalise_correct Rsor QSORaddon) ; eauto. - - intros. rewrite Tauto.hold_eNOT. rewrite QReval_formula_compat. - now eapply (cnf_negate_correct Rsor QSORaddon); eauto. - - intros t w0. - unfold eval_tt. - intros. - rewrite make_impl_map with (eval := Qeval_nformula env0). - + eapply RWeakChecker_sound; eauto. - + tauto. -Qed. - - - -(* Local Variables: *) -(* coding: utf-8 *) -(* End: *) - -#[deprecated(since="9.0")] -Notation to_nat := N.to_nat. diff --git a/stdlib/theories/micromega/Refl.v b/stdlib/theories/micromega/Refl.v deleted file mode 100644 index 12ad23a869ae..000000000000 --- a/stdlib/theories/micromega/Refl.v +++ /dev/null @@ -1,152 +0,0 @@ -(* -*- coding: utf-8 -*- *) -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* ' '/\': basic properties *) - -Fixpoint make_impl (A : Type) (eval : A -> Prop) (l : list A) (goal : Prop) {struct l} : Prop := - match l with - | nil => goal - | cons e l => (eval e) -> (make_impl eval l goal) - end. - -Theorem make_impl_true : - forall (A : Type) (eval : A -> Prop) (l : list A), make_impl eval l True. -Proof. -intros A eval l; induction l as [| a l IH]; simpl. -- trivial. -- intro; apply IH. -Qed. - - -Theorem make_impl_map : - forall (A B: Type) (eval : A -> Prop) (eval' : A*B -> Prop) (l : list (A*B)) r - (EVAL : forall x, eval' x <-> eval (fst x)), - make_impl eval' l r <-> make_impl eval (List.map fst l) r. -Proof. -intros A B eval eval' l; induction l as [| a l IH]; simpl. -- tauto. -- intros r EVAL. - rewrite EVAL. - rewrite IH. - + tauto. - + auto. -Qed. - -Fixpoint make_conj (A : Type) (eval : A -> Prop) (l : list A) {struct l} : Prop := - match l with - | nil => True - | cons e nil => (eval e) - | cons e l2 => ((eval e) /\ (make_conj eval l2)) - end. - -Theorem make_conj_cons : forall (A : Type) (eval : A -> Prop) (a : A) (l : list A), - make_conj eval (a :: l) <-> eval a /\ make_conj eval l. -Proof. -intros A eval a l; destruct l; simpl; tauto. -Qed. - - -Lemma make_conj_impl : forall (A : Type) (eval : A -> Prop) (l : list A) (g : Prop), - (make_conj eval l -> g) <-> make_impl eval l g. -Proof. - intros A eval l; induction l as [|? l IHl]. - - simpl. - tauto. - - simpl. - intros g. - destruct l. - + simpl. - tauto. - + generalize (IHl g). - tauto. -Qed. - -Lemma make_conj_in : forall (A : Type) (eval : A -> Prop) (l : list A), - make_conj eval l -> (forall p, In p l -> eval p). -Proof. - intros A eval l; induction l as [|? l IHl]. - - simpl. - tauto. - - simpl. - intros H ? H0. - destruct l. - + simpl in H0. - destruct H0. - * subst; auto. - * tauto. - + destruct H. - destruct H0. - * subst;auto. - * apply IHl; auto. -Qed. - -Lemma make_conj_app : forall A eval l1 l2, @make_conj A eval (l1 ++ l2) <-> @make_conj A eval l1 /\ @make_conj A eval l2. -Proof. - intros A eval l1; induction l1 as [|a l1 IHl1]. - - simpl. - tauto. - - intros l2. - change ((a::l1) ++ l2) with (a :: (l1 ++ l2)). - rewrite make_conj_cons. - rewrite IHl1. - rewrite make_conj_cons. - tauto. -Qed. - -Infix "+++" := rev_append (right associativity, at level 60) : list_scope. - -Lemma make_conj_rapp : forall A eval l1 l2, @make_conj A eval (l1 +++ l2) <-> @make_conj A eval (l1++l2). -Proof. - intros A eval l1; induction l1 as [|? ? IHl1]. - - simpl. tauto. - - intros. - simpl rev_append at 1. - rewrite IHl1. - rewrite make_conj_app. - rewrite make_conj_cons. - simpl app. - rewrite make_conj_cons. - rewrite make_conj_app. - tauto. -Qed. - -Lemma not_make_conj_cons : forall (A:Type) (t:A) a eval (no_middle_eval : (eval t) \/ ~ (eval t)), - ~ make_conj eval (t ::a) <-> ~ (eval t) \/ (~ make_conj eval a). -Proof. - intros. - rewrite make_conj_cons. - tauto. -Qed. - -Lemma not_make_conj_app : forall (A:Type) (t:list A) a eval - (no_middle_eval : forall d, eval d \/ ~ eval d) , - ~ make_conj eval (t ++ a) <-> (~ make_conj eval t) \/ (~ make_conj eval a). -Proof. - intros A t; induction t as [|a t IHt]. - - simpl. - tauto. - - intros a0 **. - simpl ((a::t)++a0). - rewrite !not_make_conj_cons by auto. - rewrite IHt by auto. - tauto. -Qed. diff --git a/stdlib/theories/micromega/RingMicromega.v b/stdlib/theories/micromega/RingMicromega.v deleted file mode 100644 index 81bffebb5bc0..000000000000 --- a/stdlib/theories/micromega/RingMicromega.v +++ /dev/null @@ -1,1108 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* R -> R. -Variable ropp : R -> R. -Variables req rle rlt : R -> R -> Prop. - -Variable sor : SOR rO rI rplus rtimes rminus ropp req rle rlt. - -Notation "0" := rO. -Notation "1" := rI. -Notation "x + y" := (rplus x y). -Notation "x * y " := (rtimes x y). -Notation "x - y " := (rminus x y). -Notation "- x" := (ropp x). -Notation "x == y" := (req x y). -Notation "x ~= y" := (~ req x y). -Notation "x <= y" := (rle x y). -Notation "x < y" := (rlt x y). - -(* Assume we have a type of coefficients C and a morphism from C to R *) - -Variable C : Type. -Variables cO cI : C. -Variables cplus ctimes cminus: C -> C -> C. -Variable copp : C -> C. -Variables ceqb cleb : C -> C -> bool. -Variable phi : C -> R. - -(* Power coefficients *) -Variable E : Type. (* the type of exponents *) -Variable pow_phi : N -> E. -Variable rpow : R -> E -> R. - -Notation "[ x ]" := (phi x). -Notation "x [=] y" := (ceqb x y). -Notation "x [<=] y" := (cleb x y). - -(* Let's collect all hypotheses in addition to the ordered ring axioms into -one structure *) - -Record SORaddon := mk_SOR_addon { - SORrm : ring_morph 0 1 rplus rtimes rminus ropp req cO cI cplus ctimes cminus copp ceqb phi; - SORpower : power_theory rI rtimes req pow_phi rpow; - SORcneqb_morph : forall x y : C, x [=] y = false -> [x] ~= [y]; - SORcleb_morph : forall x y : C, x [<=] y = true -> [x] <= [y] -}. - -Variable addon : SORaddon. - -Add Relation R req - reflexivity proved by (@Equivalence_Reflexive _ _ (SORsetoid sor)) - symmetry proved by (@Equivalence_Symmetric _ _ (SORsetoid sor)) - transitivity proved by (@Equivalence_Transitive _ _ (SORsetoid sor)) -as micomega_sor_setoid. - -Add Morphism rplus with signature req ==> req ==> req as rplus_morph. -Proof. -exact (SORplus_wd sor). -Qed. -Add Morphism rtimes with signature req ==> req ==> req as rtimes_morph. -Proof. -exact (SORtimes_wd sor). -Qed. -Add Morphism ropp with signature req ==> req as ropp_morph. -Proof. -exact (SORopp_wd sor). -Qed. -Add Morphism rle with signature req ==> req ==> iff as rle_morph. -Proof. - exact (SORle_wd sor). -Qed. -Add Morphism rlt with signature req ==> req ==> iff as rlt_morph. -Proof. - exact (SORlt_wd sor). -Qed. - -Add Morphism rminus with signature req ==> req ==> req as rminus_morph. -Proof. - exact (rminus_morph sor). (* We already proved that minus is a morphism in OrderedRing.v *) -Qed. - -Definition cneqb (x y : C) := negb (ceqb x y). -Definition cltb (x y : C) := (cleb x y) && (cneqb x y). - -Notation "x [~=] y" := (cneqb x y). -Notation "x [<] y" := (cltb x y). - -Ltac le_less := rewrite (Rle_lt_eq sor); left; try assumption. -Ltac le_equal := rewrite (Rle_lt_eq sor); right; try reflexivity; try assumption. -Ltac le_elim H := rewrite (Rle_lt_eq sor) in H; destruct H as [H | H]. - -Lemma cleb_sound : forall x y : C, x [<=] y = true -> [x] <= [y]. -Proof. - exact (SORcleb_morph addon). -Qed. - -Lemma cneqb_sound : forall x y : C, x [~=] y = true -> [x] ~= [y]. -Proof. -intros x y H1. apply (SORcneqb_morph addon). unfold cneqb, negb in H1. -destruct (ceqb x y); now try discriminate. -Qed. - - -Lemma cltb_sound : forall x y : C, x [<] y = true -> [x] < [y]. -Proof. -intros x y H. unfold cltb in H. apply andb_prop in H. destruct H as [H1 H2]. -apply cleb_sound in H1. apply cneqb_sound in H2. apply <- (Rlt_le_neq sor). now split. -Qed. - -(* Begin Micromega *) - -Definition PolC := Pol C. (* polynomials in generalized Horner form, defined in Ring_polynom or EnvRing *) -Definition PolEnv := Env R. (* For interpreting PolC *) -Definition eval_pol : PolEnv -> PolC -> R := - Pphi rplus rtimes phi. - -Inductive Op1 : Set := (* relations with 0 *) -| Equal (* == 0 *) -| NonEqual (* ~= 0 *) -| Strict (* > 0 *) -| NonStrict (* >= 0 *). - -Definition NFormula := (PolC * Op1)%type. (* normalized formula *) - -Definition eval_op1 (o : Op1) : R -> Prop := -match o with -| Equal => fun x => x == 0 -| NonEqual => fun x : R => x ~= 0 -| Strict => fun x : R => 0 < x -| NonStrict => fun x : R => 0 <= x -end. - -Definition eval_nformula (env : PolEnv) (f : NFormula) : Prop := -let (p, op) := f in eval_op1 op (eval_pol env p). - - -(** Rule of "signs" for addition and multiplication. - An arbitrary result is coded buy None. *) - -Definition OpMult (o o' : Op1) : option Op1 := -match o with -| Equal => Some Equal -| NonStrict => - match o' with - | Equal => Some Equal - | NonEqual => None - | Strict => Some NonStrict - | NonStrict => Some NonStrict - end -| Strict => match o' with - | NonEqual => None - | _ => Some o' - end -| NonEqual => match o' with - | Equal => Some Equal - | NonEqual => Some NonEqual - | _ => None - end -end. - -Definition OpAdd (o o': Op1) : option Op1 := - match o with - | Equal => Some o' - | NonStrict => - match o' with - | Strict => Some Strict - | NonEqual => None - | _ => Some NonStrict - end - | Strict => match o' with - | NonEqual => None - | _ => Some Strict - end - | NonEqual => match o' with - | Equal => Some NonEqual - | _ => None - end - end. - - -Lemma OpMult_sound : - forall (o o' om: Op1) (x y : R), - eval_op1 o x -> eval_op1 o' y -> OpMult o o' = Some om -> eval_op1 om (x * y). -Proof. -unfold eval_op1; intros o; destruct o; simpl; intros o' om x y H1 H2 H3. -- (* x == 0 *) - inversion H3. rewrite H1. now rewrite (Rtimes_0_l sor). -- (* x ~= 0 *) - destruct o' ; inversion H3. - + (* y == 0 *) - rewrite H2. now rewrite (Rtimes_0_r sor). - + (* y ~= 0 *) - apply (Rtimes_neq_0 sor) ; auto. -- (* 0 < x *) - destruct o' ; inversion H3. - + (* y == 0 *) - rewrite H2; now rewrite (Rtimes_0_r sor). - + (* 0 < y *) - now apply (Rtimes_pos_pos sor). - + (* 0 <= y *) - apply (Rtimes_nonneg_nonneg sor); [le_less | assumption]. -- (* 0 <= x *) - destruct o' ; inversion H3. - + (* y == 0 *) - rewrite H2; now rewrite (Rtimes_0_r sor). - + (* 0 < y *) - apply (Rtimes_nonneg_nonneg sor); [assumption | le_less ]. - + (* 0 <= y *) - now apply (Rtimes_nonneg_nonneg sor). -Qed. - -Lemma OpAdd_sound : - forall (o o' oa : Op1) (e e' : R), - eval_op1 o e -> eval_op1 o' e' -> OpAdd o o' = Some oa -> eval_op1 oa (e + e'). -Proof. -unfold eval_op1; intros o; destruct o; simpl; intros o' oa e e' H1 H2 Hoa. -- (* e == 0 *) - inversion Hoa as [H0]. rewrite <- H0. - destruct o' ; rewrite H1 ; now rewrite (Rplus_0_l sor). -- (* e ~= 0 *) - destruct o'. - + (* e' == 0 *) - inversion Hoa. - rewrite H2. now rewrite (Rplus_0_r sor). - + (* e' ~= 0 *) - discriminate. - + (* 0 < e' *) - discriminate. - + (* 0 <= e' *) - discriminate. -- (* 0 < e *) - destruct o'. - + (* e' == 0 *) - inversion Hoa. - rewrite H2. now rewrite (Rplus_0_r sor). - + (* e' ~= 0 *) - discriminate. - + (* 0 < e' *) - inversion Hoa. - now apply (Rplus_pos_pos sor). - + (* 0 <= e' *) - inversion Hoa. - now apply (Rplus_pos_nonneg sor). -- (* 0 <= e *) - destruct o'. - + (* e' == 0 *) - inversion Hoa. - now rewrite H2, (Rplus_0_r sor). - + (* e' ~= 0 *) - discriminate. - (* 0 < e' *) - + inversion Hoa. - now apply (Rplus_nonneg_pos sor). - + (* 0 <= e' *) - inversion Hoa. - now apply (Rplus_nonneg_nonneg sor). -Qed. - -Inductive Psatz : Type := -| PsatzLet: Psatz -> Psatz -> Psatz -| PsatzIn : nat -> Psatz -| PsatzSquare : PolC -> Psatz -| PsatzMulC : PolC -> Psatz -> Psatz -| PsatzMulE : Psatz -> Psatz -> Psatz -| PsatzAdd : Psatz -> Psatz -> Psatz -| PsatzC : C -> Psatz -| PsatzZ : Psatz. - -Register PsatzLet as micromega.Psatz.PsatzLet. -Register PsatzIn as micromega.Psatz.PsatzIn. -Register PsatzSquare as micromega.Psatz.PsatzSquare. -Register PsatzMulC as micromega.Psatz.PsatzMulC. -Register PsatzMulE as micromega.Psatz.PsatzMulE. -Register PsatzAdd as micromega.Psatz.PsatzAdd. -Register PsatzC as micromega.Psatz.PsatzC. -Register PsatzZ as micromega.Psatz.PsatzZ. - - -(** Given a list [l] of NFormula and an extended polynomial expression - [e], if [eval_Psatz l e] succeeds (= Some f) then [f] is a - logic consequence of the conjunction of the formulae in l. - Moreover, the polynomial expression is obtained by replacing the (PsatzIn n) - by the nth polynomial expression in [l] and the sign is computed by the "rule of sign" *) - -(* Might be defined elsewhere *) -Definition map_option (A B:Type) (f : A -> option B) (o : option A) : option B := - match o with - | None => None - | Some x => f x - end. - -Arguments map_option [A B] f o. - -Definition map_option2 (A B C : Type) (f : A -> B -> option C) - (o: option A) (o': option B) : option C := - match o , o' with - | None , _ => None - | _ , None => None - | Some x , Some x' => f x x' - end. - -Arguments map_option2 [A B C] f o o'. - -Definition Rops_wd := mk_reqe (*rplus rtimes ropp req*) - (SORplus_wd sor) - (SORtimes_wd sor) - (SORopp_wd sor). - -Definition pexpr_times_nformula (e: PolC) (f : NFormula) : option NFormula := - let (ef,o) := f in - match o with - | Equal => Some (Pmul cO cI cplus ctimes ceqb e ef , Equal) - | _ => None - end. - -Definition nformula_times_nformula (f1 f2 : NFormula) : option NFormula := - let (e1,o1) := f1 in - let (e2,o2) := f2 in - map_option (fun x => (Some (Pmul cO cI cplus ctimes ceqb e1 e2,x))) (OpMult o1 o2). - - Definition nformula_plus_nformula (f1 f2 : NFormula) : option NFormula := - let (e1,o1) := f1 in - let (e2,o2) := f2 in - map_option (fun x => (Some (Padd cO cplus ceqb e1 e2,x))) (OpAdd o1 o2). - - -Fixpoint eval_Psatz (l : list NFormula) (e : Psatz) {struct e} : option NFormula := - match e with - | PsatzLet p1 p2 => match eval_Psatz l p1 with - | None => None - | Some f => eval_Psatz (f::l) p2 - end - | PsatzIn n => Some (nth n l (Pc cO, Equal)) - | PsatzSquare e => Some (Psquare cO cI cplus ctimes ceqb e , NonStrict) - | PsatzMulC re e => map_option (pexpr_times_nformula re) (eval_Psatz l e) - | PsatzMulE f1 f2 => map_option2 nformula_times_nformula (eval_Psatz l f1) (eval_Psatz l f2) - | PsatzAdd f1 f2 => map_option2 nformula_plus_nformula (eval_Psatz l f1) (eval_Psatz l f2) - | PsatzC c => if cltb cO c then Some (Pc c, Strict) else None -(* This could be 0, or <> 0 -- but these cases are useless *) - | PsatzZ => Some (Pc cO, Equal) (* Just to make life easier *) - end. - - -Lemma pexpr_times_nformula_correct : forall (env: PolEnv) (e: PolC) (f f' : NFormula), - eval_nformula env f -> pexpr_times_nformula e f = Some f' -> - eval_nformula env f'. -Proof. - unfold pexpr_times_nformula. - intros env e f; destruct f as [? o]. - intros f' H H0. destruct o ; inversion H0 ; try discriminate. - simpl in *. unfold eval_pol in *. - rewrite (Pmul_ok (SORsetoid sor) Rops_wd - (Rth_ARth (SORsetoid sor) Rops_wd (SORrt sor)) (SORrm addon)). - rewrite H. apply (Rtimes_0_r sor). -Qed. - -Lemma nformula_times_nformula_correct : forall (env:PolEnv) - (f1 f2 f : NFormula), - eval_nformula env f1 -> eval_nformula env f2 -> - nformula_times_nformula f1 f2 = Some f -> - eval_nformula env f. -Proof. - unfold nformula_times_nformula. - intros env f1 f2; destruct f1 as [? o]; destruct f2 as [? o0]. - case_eq (OpMult o o0) ; simpl ; try discriminate. - intros o1 H ? H0 H1 H2. inversion H2 ; simpl. - unfold eval_pol. - destruct o1; simpl; - rewrite (Pmul_ok (SORsetoid sor) Rops_wd - (Rth_ARth (SORsetoid sor) Rops_wd (SORrt sor)) (SORrm addon)); - apply OpMult_sound with (3:= H);assumption. -Qed. - -Lemma nformula_plus_nformula_correct : forall (env:PolEnv) - (f1 f2 f : NFormula), - eval_nformula env f1 -> eval_nformula env f2 -> - nformula_plus_nformula f1 f2 = Some f -> - eval_nformula env f. -Proof. - unfold nformula_plus_nformula. - intros env f1 f2; destruct f1 as [? o] ; destruct f2 as [? o0]. - case_eq (OpAdd o o0) ; simpl ; try discriminate. - intros o1 H ? H0 H1 H2. inversion H2 ; simpl. - unfold eval_pol. - destruct o1; simpl; - rewrite (Padd_ok (SORsetoid sor) Rops_wd - (Rth_ARth (SORsetoid sor) Rops_wd (SORrt sor)) (SORrm addon)); - apply OpAdd_sound with (3:= H);assumption. -Qed. - -Lemma eval_Psatz_Sound : - forall (l : list NFormula) (env : PolEnv), - (forall (f : NFormula), In f l -> eval_nformula env f) -> - forall (e : Psatz) (f : NFormula), eval_Psatz l e = Some f -> - eval_nformula env f. -Proof. - intros l env H e. - revert l H. - induction e as [e1 IHe1 e2 IHe2 | n|?|? e IHe|e1 IHe1 e2 IHe2|e1 IHe1 e2 IHe2|c|]; - simpl ; intros l IN f. - - (* PsatzLet *) - destruct (eval_Psatz l e1) as [f'|] eqn:EP; [|discriminate]. - apply IHe2. intros f2 [EQ |IN']. - + subst. - eapply IHe1; eauto. - + eauto. - - (* PsatzIn *) - simpl ; intros H0. - destruct (nth_in_or_default n l (Pc cO, Equal)) as [Hin|Heq]. - + (* index is in bounds *) - apply IN. congruence. - + (* index is out-of-bounds *) - inversion H0. - rewrite Heq. simpl. - now apply (morph0 (SORrm addon)). - - (* PsatzSquare *) - intros H0. inversion H0. - simpl. unfold eval_pol. - rewrite (Psquare_ok (SORsetoid sor) Rops_wd - (Rth_ARth (SORsetoid sor) Rops_wd (SORrt sor)) (SORrm addon)); - now apply (Rtimes_square_nonneg sor). - - (* PsatzMulC *) - case_eq (eval_Psatz l e) ; simpl ; intros ? H0; [intros H1|]. - + apply IHe in H0. - * apply pexpr_times_nformula_correct with (1:=H0) (2:= H1). - * apply IN. - + discriminate. - - (* PsatzMulC *) - simpl. - case_eq (eval_Psatz l e1) ; simpl ; try discriminate. - case_eq (eval_Psatz l e2) ; simpl ; try discriminate. - intros n H0 n0 H1. - apply IHe1 in H1; auto. apply IHe2 in H0; auto. - apply (nformula_times_nformula_correct env n0 n); auto. - - (* PsatzAdd *) - simpl. - case_eq (eval_Psatz l e1) ; simpl ; try discriminate. - case_eq (eval_Psatz l e2) ; simpl ; try discriminate. - intros n H0 n0 H1. - apply IHe1 in H1; auto. apply IHe2 in H0; auto. - apply (nformula_plus_nformula_correct env n0 n) ; assumption. - - (* PsatzC *) - simpl. - case_eq (cO [<] c). - + intros H0 H1. inversion H1. simpl. - rewrite <- (morph0 (SORrm addon)). now apply cltb_sound. - + discriminate. - - (* PsatzZ *) - simpl. intros H0. inversion H0. - simpl. apply (morph0 (SORrm addon)). -Qed. - -Fixpoint ge_bool (n m : nat) : bool := - match n with - | O => match m with - | O => true - | S _ => false - end - | S n => match m with - | O => true - | S m => ge_bool n m - end - end. - -Lemma ge_bool_cases : forall n m, - (if ge_bool n m then n >= m else n < m)%nat. -Proof. - intros n; induction n as [|n IHn]; - intros m; destruct m as [|m]; simpl; auto using Nat.le_add_r, Nat.le_0_l. - specialize (IHn m). destruct (ge_bool); auto using le_n_S. -Qed. - - -Fixpoint xhyps_of_psatz (base:nat) (acc : list nat) (prf : Psatz) : list nat := - match prf with - | PsatzC _ | PsatzZ | PsatzSquare _ => acc - | PsatzMulC _ prf => xhyps_of_psatz base acc prf - | PsatzAdd e1 e2 | PsatzMulE e1 e2 => xhyps_of_psatz base (xhyps_of_psatz base acc e2) e1 - | PsatzIn n => if ge_bool n base then (n::acc) else acc - | PsatzLet e1 e2 => xhyps_of_psatz base (xhyps_of_psatz (S base) acc e2) e1 - end. - -Fixpoint nhyps_of_psatz (base:nat) (prf : Psatz) : list nat := - match prf with - | PsatzC _ | PsatzZ | PsatzSquare _ => nil - | PsatzMulC _ prf => nhyps_of_psatz base prf - | PsatzAdd e1 e2 | PsatzMulE e1 e2 => nhyps_of_psatz base e1 ++ nhyps_of_psatz base e2 - | PsatzIn n => if ge_bool n base then (n::nil) else nil - | PsatzLet e1 e2 => nhyps_of_psatz base e1 ++ nhyps_of_psatz (S base) e2 - end. - - -Fixpoint extract_hyps (l: list NFormula) (ln : list nat) : list NFormula := - match ln with - | nil => nil - | n::ln => nth n l (Pc cO, Equal) :: extract_hyps l ln - end. - -Lemma extract_hyps_app : forall l ln1 ln2, - extract_hyps l (ln1 ++ ln2) = (extract_hyps l ln1) ++ (extract_hyps l ln2). -Proof. - intros l ln1; induction ln1 as [|? ln1 IHln1]. - - reflexivity. - - simpl. - intros. - rewrite IHln1. reflexivity. -Qed. - -Ltac inv H := inversion H ; try subst ; clear H. - - - -(* roughly speaking, normalise_pexpr_correct is a proof of - forall env p, eval_pexpr env p == eval_pol env (normalise_pexpr p) *) - -(*****) -Definition paddC := PaddC cplus. -Definition psubC := PsubC cminus. - -Definition PsubC_ok : forall c P env, eval_pol env (psubC P c) == eval_pol env P - [c] := - let Rops_wd := mk_reqe (*rplus rtimes ropp req*) - (SORplus_wd sor) - (SORtimes_wd sor) - (SORopp_wd sor) in - PsubC_ok (SORsetoid sor) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd (SORrt sor)) - (SORrm addon). - -Definition PaddC_ok : forall c P env, eval_pol env (paddC P c) == eval_pol env P + [c] := - let Rops_wd := mk_reqe (*rplus rtimes ropp req*) - (SORplus_wd sor) - (SORtimes_wd sor) - (SORopp_wd sor) in - PaddC_ok (SORsetoid sor) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd (SORrt sor)) - (SORrm addon). - - -(* Check that a formula f is inconsistent by normalizing and comparing the -resulting constant with 0 *) - -Definition check_inconsistent (f : NFormula) : bool := -let (e, op) := f in - match e with - | Pc c => - match op with - | Equal => cneqb c cO - | NonStrict => c [<] cO - | Strict => c [<=] cO - | NonEqual => c [=] cO - end - | _ => false (* not a constant *) - end. - -Lemma check_inconsistent_sound : - forall (p : PolC) (op : Op1), - check_inconsistent (p, op) = true -> forall env, ~ eval_op1 op (eval_pol env p). -Proof. -intros p op H1 env. unfold check_inconsistent in H1. -destruct op; simpl ; -(*****) -destruct p ; simpl; try discriminate H1; -try rewrite <- (morph0 (SORrm addon)); trivial. -- now apply cneqb_sound. -- apply (morph_eq (SORrm addon)) in H1. congruence. -- apply cleb_sound in H1. now apply -> (Rle_ngt sor). -- apply cltb_sound in H1. now apply -> (Rlt_nge sor). -Qed. - - -Definition check_normalised_formulas : list NFormula -> Psatz -> bool := - fun l cm => - match eval_Psatz l cm with - | None => false - | Some f => check_inconsistent f - end. - -Lemma checker_nf_sound : - forall (l : list NFormula) (cm : Psatz), - check_normalised_formulas l cm = true -> - forall env : PolEnv, make_impl (eval_nformula env) l False. -Proof. -intros l cm H env. -unfold check_normalised_formulas in H. -revert H. -case_eq (eval_Psatz l cm) ; [|discriminate]. -intros nf. intros H H0. -rewrite <- make_conj_impl. intro H1. -assert (H1' := make_conj_in _ _ H1). -assert (Hnf := @eval_Psatz_Sound _ _ H1' _ _ H). -destruct nf. -apply (@check_inconsistent_sound _ _ H0 env Hnf). -Qed. - -(** Normalisation of formulae **) - -Inductive Op2 : Set := (* binary relations *) -| OpEq -| OpNEq -| OpLe -| OpGe -| OpLt -| OpGt. - -Register OpEq as micromega.Op2.OpEq. -Register OpNEq as micromega.Op2.OpNEq. -Register OpLe as micromega.Op2.OpLe. -Register OpGe as micromega.Op2.OpGe. -Register OpLt as micromega.Op2.OpLt. -Register OpGt as micromega.Op2.OpGt. - -Definition eval_op2 (o : Op2) : R -> R -> Prop := -match o with -| OpEq => req -| OpNEq => fun x y : R => x ~= y -| OpLe => rle -| OpGe => fun x y : R => y <= x -| OpLt => fun x y : R => x < y -| OpGt => fun x y : R => y < x -end. - -Definition eval_pexpr : PolEnv -> PExpr C -> R := - PEeval rplus rtimes rminus ropp phi pow_phi rpow. - -#[universes(template)] -Record Formula (T:Type) : Type := Build_Formula{ - Flhs : PExpr T; - Fop : Op2; - Frhs : PExpr T -}. - -Register Formula as micromega.Formula.type. -Register Build_Formula as micromega.Formula.Build_Formula. - -Definition eval_formula (env : PolEnv) (f : Formula C) : Prop := - let (lhs, op, rhs) := f in - (eval_op2 op) (eval_pexpr env lhs) (eval_pexpr env rhs). - - -(* We normalize Formulas by moving terms to one side *) - -Definition norm := norm_aux cO cI cplus ctimes cminus copp ceqb. - -Definition psub := Psub cO cplus cminus copp ceqb. - -Definition padd := Padd cO cplus ceqb. - -Definition pmul := Pmul cO cI cplus ctimes ceqb. - -Definition popp := Popp copp. - -Definition normalise (f : Formula C) : NFormula := -let (lhs, op, rhs) := f in - let lhs := norm lhs in - let rhs := norm rhs in - match op with - | OpEq => (psub lhs rhs, Equal) - | OpNEq => (psub lhs rhs, NonEqual) - | OpLe => (psub rhs lhs, NonStrict) - | OpGe => (psub lhs rhs, NonStrict) - | OpGt => (psub lhs rhs, Strict) - | OpLt => (psub rhs lhs, Strict) - end. - -Definition negate (f : Formula C) : NFormula := -let (lhs, op, rhs) := f in - let lhs := norm lhs in - let rhs := norm rhs in - match op with - | OpEq => (psub rhs lhs, NonEqual) - | OpNEq => (psub rhs lhs, Equal) - | OpLe => (psub lhs rhs, Strict) (* e <= e' == ~ e > e' *) - | OpGe => (psub rhs lhs, Strict) - | OpGt => (psub rhs lhs, NonStrict) - | OpLt => (psub lhs rhs, NonStrict) - end. - -Lemma eval_pol_sub : forall env lhs rhs, eval_pol env (psub lhs rhs) == eval_pol env lhs - eval_pol env rhs. -Proof. - intros. - apply (Psub_ok (SORsetoid sor) Rops_wd - (Rth_ARth (SORsetoid sor) Rops_wd (SORrt sor)) (SORrm addon)). -Qed. - -Lemma eval_pol_add : forall env lhs rhs, eval_pol env (padd lhs rhs) == eval_pol env lhs + eval_pol env rhs. -Proof. - intros. - apply (Padd_ok (SORsetoid sor) Rops_wd - (Rth_ARth (SORsetoid sor) Rops_wd (SORrt sor)) (SORrm addon)). -Qed. - -Lemma eval_pol_mul : forall env lhs rhs, eval_pol env (pmul lhs rhs) == eval_pol env lhs * eval_pol env rhs. -Proof. - intros. - apply (Pmul_ok sor.(SORsetoid) Rops_wd - (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm)). -Qed. - -Lemma eval_pol_opp : forall env e, eval_pol env (popp e) == - eval_pol env e. -Proof. - intros. - apply (Popp_ok (SORsetoid sor) Rops_wd - (Rth_ARth (SORsetoid sor) Rops_wd (SORrt sor)) (SORrm addon)). -Qed. - - -Lemma eval_pol_norm : forall env lhs, eval_pexpr env lhs == eval_pol env (norm lhs). -Proof. - intros. - apply (norm_aux_spec (SORsetoid sor) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd (SORrt sor)) (SORrm addon) (SORpower addon) ). -Qed. - - -Theorem normalise_sound : - forall (env : PolEnv) (f : Formula C), - eval_formula env f <-> eval_nformula env (normalise f). -Proof. -intros env f; destruct f as [lhs op rhs]; simpl in *. -destruct op; simpl in *; rewrite eval_pol_sub ; rewrite <- eval_pol_norm ; rewrite <- eval_pol_norm. -- symmetry. - now apply (Rminus_eq_0 sor). -- rewrite (Rminus_eq_0 sor). - tauto. -- now apply (Rle_le_minus sor). -- now apply (Rle_le_minus sor). -- now apply (Rlt_lt_minus sor). -- now apply (Rlt_lt_minus sor). -Qed. - -Theorem negate_correct : - forall (env : PolEnv) (f : Formula C), - eval_formula env f <-> ~ (eval_nformula env (negate f)). -Proof. -intros env f; destruct f as [lhs op rhs]; simpl. -destruct op; simpl in *; rewrite eval_pol_sub ; rewrite <- eval_pol_norm ; rewrite <- eval_pol_norm. -- symmetry. rewrite (Rminus_eq_0 sor). -split; intro H; [symmetry; now apply -> (Req_dne sor) | symmetry in H; now apply <- (Req_dne sor)]. -- rewrite (Rminus_eq_0 sor). split; intro; now apply (Rneq_symm sor). -- rewrite <- (Rlt_lt_minus sor). now rewrite <- (Rle_ngt sor). -- rewrite <- (Rlt_lt_minus sor). now rewrite <- (Rle_ngt sor). -- rewrite <- (Rle_le_minus sor). now rewrite <- (Rlt_nge sor). -- rewrite <- (Rle_le_minus sor). now rewrite <- (Rlt_nge sor). -Qed. - -(** Another normalisation - this is used for cnf conversion **) - -Definition xnormalise (f:NFormula) : list (NFormula) := - let (e,o) := f in - match o with - | Equal => (e , Strict) :: (popp e, Strict) :: nil - | NonEqual => (e , Equal) :: nil - | Strict => (popp e, NonStrict) :: nil - | NonStrict => (popp e, Strict) :: nil - end. - -Definition xnegate (t:NFormula) : list (NFormula) := - let (e,o) := t in - match o with - | Equal => (e,Equal) :: nil - | NonEqual => (e,Strict)::(popp e,Strict)::nil - | Strict => (e,Strict) :: nil - | NonStrict => (e,NonStrict) :: nil - end. - - -Import Stdlib.micromega.Tauto. - -Definition cnf_of_list {T : Type} (l:list NFormula) (tg : T) : cnf NFormula T := - List.fold_right (fun x acc => - if check_inconsistent x then acc else ((x,tg)::nil)::acc) - (cnf_tt _ _) l. - -Add Ring SORRing : (SORrt sor). - -Lemma cnf_of_list_correct : - forall (T : Type) env l tg, - eval_cnf (Annot:=T) eval_nformula env (cnf_of_list l tg) <-> - make_conj (fun x : NFormula => eval_nformula env x -> False) l. -Proof. - unfold cnf_of_list. - intros T env l tg. - set (F := (fun (x : NFormula) (acc : list (list (NFormula * T))) => - if check_inconsistent x then acc else ((x, tg) :: nil) :: acc)). - set (G := ((fun x : NFormula => eval_nformula env x -> False))). - induction l as [|a l IHl]. - - compute. - tauto. - - rewrite make_conj_cons. - simpl. - unfold F at 1. - destruct (check_inconsistent a) eqn:EQ. - + rewrite IHl. - unfold G. - destruct a. - specialize (check_inconsistent_sound _ _ EQ env). - simpl. - tauto. - + - rewrite <- eval_cnf_cons_iff. - simpl. - unfold eval_tt. simpl. - rewrite IHl. - unfold G at 2. - tauto. -Qed. - -Definition cnf_normalise {T: Type} (t: Formula C) (tg: T) : cnf NFormula T := - let f := normalise t in - if check_inconsistent f then cnf_ff _ _ - else cnf_of_list (xnormalise f) tg. - -Definition cnf_negate {T: Type} (t: Formula C) (tg: T) : cnf NFormula T := - let f := normalise t in - if check_inconsistent f then cnf_tt _ _ - else cnf_of_list (xnegate f) tg. - -Lemma eq0_cnf : forall x, - (0 < x -> False) /\ (0 < - x -> False) <-> x == 0. -Proof. - intros x; split ; intros H. - + apply (SORle_antisymm sor). - * now rewrite (Rle_ngt sor). - * rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). - setoid_replace (0 - x) with (-x) by ring. - tauto. - + split; intro H0. - * rewrite (SORlt_le_neq sor) in H0. - apply (proj2 H0). - now rewrite H. - * rewrite (SORlt_le_neq sor) in H0. - apply (proj2 H0). - rewrite H. ring. -Qed. - -Lemma xnormalise_correct : forall env f, - (make_conj (fun x => eval_nformula env x -> False) (xnormalise f)) <-> eval_nformula env f. -Proof. - intros env f. - destruct f as [e o]; destruct o eqn:Op; cbn - [psub]; - repeat rewrite eval_pol_sub; fold eval_pol; repeat rewrite eval_pol_Pc; - repeat rewrite eval_pol_opp; - generalize (eval_pol env e) as x; intro x. - - apply eq0_cnf. - - unfold not. tauto. - - symmetry. rewrite (Rlt_nge sor). - rewrite (Rle_le_minus sor). - setoid_replace (0 - x) with (-x) by ring. - tauto. - - rewrite (Rle_ngt sor). - symmetry. - rewrite (Rlt_lt_minus sor). - setoid_replace (0 - x) with (-x) by ring. - tauto. -Qed. - - -Lemma xnegate_correct : forall env f, - (make_conj (fun x => eval_nformula env x -> False) (xnegate f)) <-> ~ eval_nformula env f. -Proof. - intros env f. - destruct f as [e o]; destruct o eqn:Op; cbn - [psub]; - repeat rewrite eval_pol_sub; fold eval_pol; repeat rewrite eval_pol_Pc; - repeat rewrite eval_pol_opp; - generalize (eval_pol env e) as x; intro. - - tauto. - - rewrite eq0_cnf. - rewrite (Req_dne sor). - tauto. - - tauto. - - tauto. -Qed. - - -Lemma cnf_normalise_correct : forall (T : Type) env t tg, eval_cnf (Annot:=T) eval_nformula env (cnf_normalise t tg) <-> eval_formula env t. -Proof. - intros T env t tg. - unfold cnf_normalise. - rewrite normalise_sound. - generalize (normalise t) as f;intro f. - destruct (check_inconsistent f) eqn:U. - - destruct f as [e op]. - assert (US := check_inconsistent_sound _ _ U env). - rewrite eval_cnf_ff. - tauto. - - intros. rewrite cnf_of_list_correct. - now apply xnormalise_correct. -Qed. - -Lemma cnf_negate_correct : forall (T : Type) env t (tg:T), eval_cnf eval_nformula env (cnf_negate t tg) <-> ~ eval_formula env t. -Proof. - intros T env t tg. - rewrite normalise_sound. - unfold cnf_negate. - generalize (normalise t) as f;intro f. - destruct (check_inconsistent f) eqn:U. - - - destruct f as [e o]. - assert (US := check_inconsistent_sound _ _ U env). - rewrite eval_cnf_tt. - tauto. - - rewrite cnf_of_list_correct. - apply xnegate_correct. -Qed. - -Lemma eval_nformula_dec : forall env d, (eval_nformula env d) \/ ~ (eval_nformula env d). -Proof. - intros env d. - destruct d as [p o]; simpl. - generalize (eval_pol env p); intros r. - destruct o ; simpl. - - apply (Req_em sor r 0). - - destruct (Req_em sor r 0) ; tauto. - - rewrite <- (Rle_ngt sor r 0). generalize (Rle_gt_cases sor r 0). tauto. - - rewrite <- (Rlt_nge sor r 0). generalize (Rle_gt_cases sor 0 r). tauto. -Qed. - -(** Reverse transformation *) - -Fixpoint xdenorm (jmp : positive) (p: Pol C) : PExpr C := - match p with - | Pc c => PEc c - | Pinj j p => xdenorm (Pos.add j jmp ) p - | PX p j q => PEadd - (PEmul (xdenorm jmp p) (PEpow (PEX jmp) (Npos j))) - (xdenorm (Pos.succ jmp) q) - end. - -Lemma xdenorm_correct : forall p i env, - eval_pol (jump i env) p == eval_pexpr env (xdenorm (Pos.succ i) p). -Proof. - unfold eval_pol. - intros p; induction p as [|? p IHp|p2 IHp1 ? p3 IHp2]. - - simpl. reflexivity. - - (* Pinj *) - simpl. - intros. - rewrite Pos.add_succ_r. - rewrite <- IHp. - symmetry. - rewrite Pos.add_comm. - rewrite Pjump_add. reflexivity. - - (* PX *) - simpl. - intros. - rewrite <- IHp1, <- IHp2. - unfold Env.tail , Env.hd. - rewrite <- Pjump_add. - rewrite Pos.add_1_r. - unfold Env.nth. - unfold jump at 2. - rewrite <- Pos.add_1_l. - rewrite (rpow_pow_N (SORpower addon)). - unfold pow_N. ring. -Qed. - -Definition denorm := xdenorm xH. - -Lemma denorm_correct : forall p env, eval_pol env p == eval_pexpr env (denorm p). -Proof. - unfold denorm. - intros p; induction p as [| |? IHp1 ? ? IHp2]. - - reflexivity. - - simpl. - rewrite Pos.add_1_r. - apply xdenorm_correct. - - simpl. - intros. - rewrite IHp1. - unfold Env.tail. - rewrite xdenorm_correct. - change (Pos.succ xH) with 2%positive. - rewrite (rpow_pow_N (SORpower addon)). - simpl. reflexivity. -Qed. - - -(** Sometimes it is convenient to make a distinction between "syntactic" coefficients and "real" -coefficients that are used to actually compute *) - - - -Variable S : Type. - -Variable C_of_S : S -> C. - -Variable phiS : S -> R. - -Variable phi_C_of_S : forall c, phiS c = phi (C_of_S c). - -Fixpoint map_PExpr (e : PExpr S) : PExpr C := - match e with - | PEc c => PEc (C_of_S c) - | PEX p => PEX p - | PEadd e1 e2 => PEadd (map_PExpr e1) (map_PExpr e2) - | PEsub e1 e2 => PEsub (map_PExpr e1) (map_PExpr e2) - | PEmul e1 e2 => PEmul (map_PExpr e1) (map_PExpr e2) - | PEopp e => PEopp (map_PExpr e) - | PEpow e n => PEpow (map_PExpr e) n - end. - -Definition map_Formula (f : Formula S) : Formula C := - let (l,o,r) := f in - Build_Formula (map_PExpr l) o (map_PExpr r). - - -Definition eval_sexpr : PolEnv -> PExpr S -> R := - PEeval rplus rtimes rminus ropp phiS pow_phi rpow. - -Definition eval_sformula (env : PolEnv) (f : Formula S) : Prop := - let (lhs, op, rhs) := f in - (eval_op2 op) (eval_sexpr env lhs) (eval_sexpr env rhs). - -Lemma eval_pexprSC : forall env s, eval_sexpr env s = eval_pexpr env (map_PExpr s). -Proof. - unfold eval_pexpr, eval_sexpr. - intros env s; - induction s as [| |? IHs1 ? IHs2|? IHs1 ? IHs2|? IHs1 ? IHs2|? IHs|? IHs ?]; - simpl ; try (rewrite IHs1 ; rewrite IHs2) ; try reflexivity. - - apply phi_C_of_S. - - rewrite IHs. reflexivity. - - rewrite IHs. reflexivity. -Qed. - -(** equality might be (too) strong *) -Lemma eval_formulaSC : forall env f, eval_sformula env f = eval_formula env (map_Formula f). -Proof. - intros env f; destruct f. - simpl. - repeat rewrite eval_pexprSC. - reflexivity. -Qed. - - - - -(** Some syntactic simplifications of expressions *) - - -Definition simpl_cone (e:Psatz) : Psatz := - match e with - | PsatzSquare t => - match t with - | Pc c => if ceqb cO c then PsatzZ else PsatzC (ctimes c c) - | _ => PsatzSquare t - end - | PsatzMulE t1 t2 => - match t1 , t2 with - | PsatzZ , _ => PsatzZ - | _ , PsatzZ => PsatzZ - | PsatzC c , PsatzC c' => PsatzC (ctimes c c') - | PsatzC p1 , PsatzMulE (PsatzC p2) x => PsatzMulE (PsatzC (ctimes p1 p2)) x - | PsatzC p1 , PsatzMulE x (PsatzC p2) => PsatzMulE (PsatzC (ctimes p1 p2)) x - | PsatzMulE (PsatzC p2) x , PsatzC p1 => PsatzMulE (PsatzC (ctimes p1 p2)) x - | PsatzMulE x (PsatzC p2) , PsatzC p1 => PsatzMulE (PsatzC (ctimes p1 p2)) x - | PsatzC x , PsatzAdd y z => PsatzAdd (PsatzMulE (PsatzC x) y) (PsatzMulE (PsatzC x) z) - | PsatzC c , _ => if ceqb cI c then t2 else PsatzMulE t1 t2 - | _ , PsatzC c => if ceqb cI c then t1 else PsatzMulE t1 t2 - | _ , _ => e - end - | PsatzAdd t1 t2 => - match t1 , t2 with - | PsatzZ , x => x - | x , PsatzZ => x - | x , y => PsatzAdd x y - end - | _ => e - end. - - - - -End Micromega. - -(* Local Variables: *) -(* coding: utf-8 *) -(* End: *) diff --git a/stdlib/theories/micromega/Tauto.v b/stdlib/theories/micromega/Tauto.v deleted file mode 100644 index 5f06d09f2a7a..000000000000 --- a/stdlib/theories/micromega/Tauto.v +++ /dev/null @@ -1,2085 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* Trace A -> Trace A -| merge : Trace A -> Trace A -> Trace A -. - -Section S. - Context {TA : Type}. (* type of interpreted atoms *) - Context {TX : kind -> Type}. (* type of uninterpreted terms (Prop) *) - Context {AA : Type}. (* type of annotations for atoms *) - Context {AF : Type}. (* type of formulae identifiers *) - - Inductive GFormula : kind -> Type := - | TT : forall (k: kind), GFormula k - | FF : forall (k: kind), GFormula k - | X : forall (k: kind), TX k -> GFormula k - | A : forall (k: kind), TA -> AA -> GFormula k - | AND : forall (k: kind), GFormula k -> GFormula k -> GFormula k - | OR : forall (k: kind), GFormula k -> GFormula k -> GFormula k - | NOT : forall (k: kind), GFormula k -> GFormula k - | IMPL : forall (k: kind), GFormula k -> option AF -> GFormula k -> GFormula k - | IFF : forall (k: kind), GFormula k -> GFormula k -> GFormula k - | EQ : GFormula isBool -> GFormula isBool -> GFormula isProp. - - Register TT as micromega.GFormula.TT. - Register FF as micromega.GFormula.FF. - Register X as micromega.GFormula.X. - Register A as micromega.GFormula.A. - Register AND as micromega.GFormula.AND. - Register OR as micromega.GFormula.OR. - Register NOT as micromega.GFormula.NOT. - Register IMPL as micromega.GFormula.IMPL. - Register IFF as micromega.GFormula.IFF. - Register EQ as micromega.GFormula.EQ. - - - Section MAPX. - Variable F : forall k, TX k -> TX k. - - Fixpoint mapX (k:kind) (f : GFormula k) : GFormula k := - match f with - | TT k => TT k - | FF k => FF k - | X x => X (F x) - | A k a an => A k a an - | AND f1 f2 => AND (mapX f1) (mapX f2) - | OR f1 f2 => OR (mapX f1) (mapX f2) - | NOT f => NOT (mapX f) - | IMPL f1 o f2 => IMPL (mapX f1) o (mapX f2) - | IFF f1 f2 => IFF (mapX f1) (mapX f2) - | EQ f1 f2 => EQ (mapX f1) (mapX f2) - end. - - End MAPX. - - Section FOLDANNOT. - Variable ACC : Type. - Variable F : ACC -> AA -> ACC. - - Fixpoint foldA (k: kind) (f : GFormula k) (acc : ACC) : ACC := - match f with - | TT _ => acc - | FF _ => acc - | X x => acc - | A _ a an => F acc an - | AND f1 f2 - | OR f1 f2 - | IFF f1 f2 - | IMPL f1 _ f2 | EQ f1 f2 => foldA f1 (foldA f2 acc) - | NOT f => foldA f acc - end. - - End FOLDANNOT. - - - Definition cons_id (id : option AF) (l : list AF) := - match id with - | None => l - | Some id => id :: l - end. - - Fixpoint ids_of_formula (k: kind) (f:GFormula k) := - match f with - | IMPL f id f' => cons_id id (ids_of_formula f') - | _ => nil - end. - - Fixpoint collect_annot (k: kind) (f : GFormula k) : list AA := - match f with - | TT _ | FF _ | X _ => nil - | A _ _ a => a ::nil - | AND f1 f2 - | OR f1 f2 - | IFF f1 f2 | EQ f1 f2 - | IMPL f1 _ f2 => collect_annot f1 ++ collect_annot f2 - | NOT f => collect_annot f - end. - - Definition rtyp (k: kind) : Type := if k then Prop else bool. - - Variable ex : forall (k: kind), TX k -> rtyp k. (* [ex] will be the identity *) - - Section EVAL. - - Variable ea : forall (k: kind), TA -> rtyp k. - - Definition eTT (k: kind) : rtyp k := - if k as k' return rtyp k' then True else true. - - Definition eFF (k: kind) : rtyp k := - if k as k' return rtyp k' then False else false. - - Definition eAND (k: kind) : rtyp k -> rtyp k -> rtyp k := - if k as k' return rtyp k' -> rtyp k' -> rtyp k' - then and else andb. - - Definition eOR (k: kind) : rtyp k -> rtyp k -> rtyp k := - if k as k' return rtyp k' -> rtyp k' -> rtyp k' - then or else orb. - - Definition eIMPL (k: kind) : rtyp k -> rtyp k -> rtyp k := - if k as k' return rtyp k' -> rtyp k' -> rtyp k' - then (fun x y => x -> y) else implb. - - Definition eIFF (k: kind) : rtyp k -> rtyp k -> rtyp k := - if k as k' return rtyp k' -> rtyp k' -> rtyp k' - then iff else eqb. - - Definition eNOT (k: kind) : rtyp k -> rtyp k := - if k as k' return rtyp k' -> rtyp k' - then not else negb. - - Fixpoint eval_f (k: kind) (f:GFormula k) {struct f}: rtyp k := - match f in GFormula k' return rtyp k' with - | TT tk => eTT tk - | FF tk => eFF tk - | A k a _ => ea k a - | X p => ex p - | @AND k e1 e2 => eAND k (eval_f e1) (eval_f e2) - | @OR k e1 e2 => eOR k (eval_f e1) (eval_f e2) - | @NOT k e => eNOT k (eval_f e) - | @IMPL k f1 _ f2 => eIMPL k (eval_f f1) (eval_f f2) - | @IFF k f1 f2 => eIFF k (eval_f f1) (eval_f f2) - | EQ f1 f2 => (eval_f f1) = (eval_f f2) - end. - - Lemma eval_f_rew : forall k (f:GFormula k), - eval_f f = - match f in GFormula k' return rtyp k' with - | TT tk => eTT tk - | FF tk => eFF tk - | A k a _ => ea k a - | X p => ex p - | @AND k e1 e2 => eAND k (eval_f e1) (eval_f e2) - | @OR k e1 e2 => eOR k (eval_f e1) (eval_f e2) - | @NOT k e => eNOT k (eval_f e) - | @IMPL k f1 _ f2 => eIMPL k (eval_f f1) (eval_f f2) - | @IFF k f1 f2 => eIFF k (eval_f f1) (eval_f f2) - | EQ f1 f2 => (eval_f f1) = (eval_f f2) - end. - Proof. - intros k f; destruct f ; reflexivity. - Qed. - - End EVAL. - - - Definition hold (k: kind) : rtyp k -> Prop := - if k as k0 return (rtyp k0 -> Prop) then fun x => x else is_true. - - Definition eiff (k: kind) : rtyp k -> rtyp k -> Prop := - if k as k' return rtyp k' -> rtyp k' -> Prop then iff else @eq bool. - - Lemma eiff_refl (k: kind) (x : rtyp k) : - eiff k x x. - Proof. - destruct k ; simpl; tauto. - Qed. - - Lemma eiff_sym k (x y : rtyp k) : eiff k x y -> eiff k y x. - Proof. - destruct k ; simpl; intros ; intuition. - Qed. - - Lemma eiff_trans k (x y z : rtyp k) : eiff k x y -> eiff k y z -> eiff k x z. - Proof. - destruct k ; simpl; intros ; intuition congruence. - Qed. - - Lemma hold_eiff (k: kind) (x y : rtyp k) : - (hold k x <-> hold k y) <-> eiff k x y. - Proof. - destruct k ; simpl. - - tauto. - - unfold is_true. - destruct x,y ; intuition congruence. - Qed. - - Instance eiff_eq (k: kind) : Equivalence (eiff k). - Proof. - constructor. - - exact (eiff_refl k). - - exact (eiff_sym k). - - exact (eiff_trans k). - Qed. - - Add Parametric Morphism (k: kind) : (@eAND k) with signature eiff k ==> eiff k ==> eiff k as eAnd_morph. - Proof. - intros. - destruct k ; simpl in *; intuition congruence. - Qed. - - Add Parametric Morphism (k: kind) : (@eOR k) with signature eiff k ==> eiff k ==> eiff k as eOR_morph. - Proof. - intros. - destruct k ; simpl in *; intuition congruence. - Qed. - - Add Parametric Morphism (k: kind) : (@eIMPL k) with signature eiff k ==> eiff k ==> eiff k as eIMPL_morph. - Proof. - intros. - destruct k ; simpl in *; intuition congruence. - Qed. - - Add Parametric Morphism (k: kind) : (@eIFF k) with signature eiff k ==> eiff k ==> eiff k as eIFF_morph. - Proof. - intros. - destruct k ; simpl in *; intuition congruence. - Qed. - - Add Parametric Morphism (k: kind) : (@eNOT k) with signature eiff k ==> eiff k as eNOT_morph. - Proof. - intros. - destruct k ; simpl in *; intuition congruence. - Qed. - - Lemma eval_f_morph : - forall (ev ev' : forall (k: kind), TA -> rtyp k), - (forall k a, eiff k (ev k a) (ev' k a)) -> - forall (k: kind)(f : GFormula k), - (eiff k (eval_f ev f) (eval_f ev' f)). - Proof. - intros ev ev' H k f; - induction f as [| | | |? ? IHf1 ? IHf2|? ? IHf1 ? IHf2|? ? IHf - |? ? IHf1 ? ? IHf2|? ? IHf1 ? IHf2|]; - simpl. - - reflexivity. - - reflexivity. - - reflexivity. - - apply H. - - rewrite IHf1. rewrite IHf2. reflexivity. - - rewrite IHf1. rewrite IHf2. reflexivity. - - rewrite IHf. reflexivity. - - rewrite IHf1. rewrite IHf2. reflexivity. - - rewrite IHf1. rewrite IHf2. reflexivity. - - simpl in *. intuition congruence. - Qed. - -End S. - - - -(** Typical boolean formulae *) -Definition eKind (k: kind) := if k then Prop else bool. -Register eKind as micromega.eKind. - -Definition BFormula (A : Type) := @GFormula A eKind unit unit. - -Register BFormula as micromega.BFormula.type. - -Section MAPATOMS. - Context {TA TA':Type}. - Context {TX : kind -> Type}. - Context {AA : Type}. - Context {AF : Type}. - - - Fixpoint map_bformula (k: kind)(fct : TA -> TA') (f : @GFormula TA TX AA AF k) : @GFormula TA' TX AA AF k:= - match f with - | TT k => TT k - | FF k => FF k - | X k p => X k p - | A k a t => A k (fct a) t - | AND f1 f2 => AND (map_bformula fct f1) (map_bformula fct f2) - | OR f1 f2 => OR (map_bformula fct f1) (map_bformula fct f2) - | NOT f => NOT (map_bformula fct f) - | IMPL f1 a f2 => IMPL (map_bformula fct f1) a (map_bformula fct f2) - | IFF f1 f2 => IFF (map_bformula fct f1) (map_bformula fct f2) - | EQ f1 f2 => EQ (map_bformula fct f1) (map_bformula fct f2) - end. - -End MAPATOMS. - -Lemma map_simpl : forall A B f l, @map A B f l = match l with - | nil => nil - | a :: l=> (f a) :: (@map A B f l) - end. -Proof. - intros A B f l; destruct l ; reflexivity. -Qed. - - -Section S. - (** A cnf tracking annotations of atoms. *) - - (** Type parameters *) - Variable Env : Type. - Variable Term : Type. - Variable Term' : Type. - Variable Annot : Type. - - Local Notation Trace := (Trace Annot). - - Variable unsat : Term' -> bool. (* see [unsat_prop] *) - Variable deduce : Term' -> Term' -> option Term'. (* see [deduce_prop] *) - - Local Notation null := (@null Annot). - Local Notation push := (@push Annot). - Local Notation merge := (@merge Annot). - - Definition clause := list (Term' * Annot). - Definition cnf := list clause. - - Variable normalise : Term -> Annot -> cnf. - Variable negate : Term -> Annot -> cnf. - - - Definition cnf_tt : cnf := @nil clause. - Definition cnf_ff : cnf := cons (@nil (Term' * Annot)) nil. - - (** Our cnf is optimised and detects contradictions on the fly. *) - - Fixpoint add_term (t: Term' * Annot) (cl : clause) : option clause := - match cl with - | nil => - match deduce (fst t) (fst t) with - | None => Some (t ::nil) - | Some u => if unsat u then None else Some (t::nil) - end - | t'::cl => - match deduce (fst t) (fst t') with - | None => - match add_term t cl with - | None => None - | Some cl' => Some (t' :: cl') - end - | Some u => - if unsat u then None else - match add_term t cl with - | None => None - | Some cl' => Some (t' :: cl') - end - end - end. - - Fixpoint or_clause (cl1 cl2 : clause) : option clause := - match cl1 with - | nil => Some cl2 - | t::cl => match add_term t cl2 with - | None => None - | Some cl' => or_clause cl cl' - end - end. - - Definition xor_clause_cnf (t:clause) (f:cnf) : cnf := - List.fold_left (fun acc e => - match or_clause t e with - | None => acc - | Some cl => cl :: acc - end) f nil . - - Definition or_clause_cnf (t: clause) (f:cnf) : cnf := - match t with - | nil => f - | _ => xor_clause_cnf t f - end. - - - Fixpoint or_cnf (f : cnf) (f' : cnf) {struct f}: cnf := - match f with - | nil => cnf_tt - | e :: rst => (or_cnf rst f') +++ (or_clause_cnf e f') - end. - - - Definition and_cnf (f1 : cnf) (f2 : cnf) : cnf := - f1 +++ f2. - - (** TX is Prop in Coq and EConstr.constr in Ocaml. - AF is unit in Coq and Names.Id.t in Ocaml - *) - Definition TFormula (TX: kind -> Type) (AF: Type) := @GFormula Term TX Annot AF. - - - Definition is_cnf_tt (c : cnf) : bool := - match c with - | nil => true - | _ => false - end. - - Definition is_cnf_ff (c : cnf) : bool := - match c with - | nil::nil => true - | _ => false - end. - - Definition and_cnf_opt (f1 : cnf) (f2 : cnf) : cnf := - if is_cnf_ff f1 || is_cnf_ff f2 - then cnf_ff - else - if is_cnf_tt f2 - then f1 - else and_cnf f1 f2. - - - Definition or_cnf_opt (f1 : cnf) (f2 : cnf) : cnf := - if is_cnf_tt f1 || is_cnf_tt f2 - then cnf_tt - else if is_cnf_ff f2 - then f1 else or_cnf f1 f2. - - Section REC. - Context {TX : kind -> Type}. - Context {AF : Type}. - - Variable REC : forall (pol : bool) (k: kind) (f : TFormula TX AF k), cnf. - - Definition mk_and (k: kind) (pol:bool) (f1 f2 : TFormula TX AF k):= - (if pol then and_cnf_opt else or_cnf_opt) (REC pol f1) (REC pol f2). - - Definition mk_or (k: kind) (pol:bool) (f1 f2 : TFormula TX AF k):= - (if pol then or_cnf_opt else and_cnf_opt) (REC pol f1) (REC pol f2). - - Definition mk_impl (k: kind) (pol:bool) (f1 f2 : TFormula TX AF k):= - (if pol then or_cnf_opt else and_cnf_opt) (REC (negb pol) f1) (REC pol f2). - - - Definition mk_iff (k: kind) (pol:bool) (f1 f2: TFormula TX AF k):= - or_cnf_opt (and_cnf_opt (REC (negb pol) f1) (REC false f2)) - (and_cnf_opt (REC pol f1) (REC true f2)). - - - End REC. - - Definition is_bool {TX : kind -> Type} {AF: Type} (k: kind) (f : TFormula TX AF k) := - match f with - | TT _ => Some true - | FF _ => Some false - | _ => None - end. - - Lemma is_bool_inv : forall {TX : kind -> Type} {AF: Type} (k: kind) (f : TFormula TX AF k) res, - is_bool f = Some res -> f = if res then TT _ else FF _. - Proof. - intros TX AF k f res H. - destruct f ; inversion H; reflexivity. - Qed. - - - Fixpoint xcnf {TX : kind -> Type} {AF: Type} (pol : bool) (k: kind) (f : TFormula TX AF k) {struct f}: cnf := - match f with - | TT _ => if pol then cnf_tt else cnf_ff - | FF _ => if pol then cnf_ff else cnf_tt - | X _ p => if pol then cnf_ff else cnf_ff (* This is not complete - cannot negate any proposition *) - | A _ x t => if pol then normalise x t else negate x t - | NOT e => xcnf (negb pol) e - | AND e1 e2 => mk_and xcnf pol e1 e2 - | OR e1 e2 => mk_or xcnf pol e1 e2 - | IMPL e1 _ e2 => mk_impl xcnf pol e1 e2 - | IFF e1 e2 => match is_bool e2 with - | Some isb => xcnf (if isb then pol else negb pol) e1 - | None => mk_iff xcnf pol e1 e2 - end - | EQ e1 e2 => - match is_bool e2 with - | Some isb => xcnf (if isb then pol else negb pol) e1 - | None => mk_iff xcnf pol e1 e2 - end - end. - - Section CNFAnnot. - - (** Records annotations used to optimise the cnf. - Those need to be kept when pruning the formula. - For efficiency, this is a separate function. - *) - - Fixpoint radd_term (t : Term' * Annot) (cl : clause) : clause + Trace := - match cl with - | nil => (* if t is unsat, the clause is empty BUT t is needed. *) - match deduce (fst t) (fst t) with - | Some u => if unsat u then inr (push (snd t) null) else inl (t::nil) - | None => inl (t::nil) - end - | t'::cl => (* if t /\ t' is unsat, the clause is empty BUT t & t' are needed *) - match deduce (fst t) (fst t') with - | Some u => if unsat u then inr (push (snd t) (push (snd t') null)) - else match radd_term t cl with - | inl cl' => inl (t'::cl') - | inr l => inr l - end - | None => match radd_term t cl with - | inl cl' => inl (t'::cl') - | inr l => inr l - end - end - end. - - Fixpoint ror_clause cl1 cl2 := - match cl1 with - | nil => inl cl2 - | t::cl => match radd_term t cl2 with - | inl cl' => ror_clause cl cl' - | inr l => inr l - end - end. - - Definition xror_clause_cnf t f := - List.fold_left (fun '(acc,tg) e => - match ror_clause t e with - | inl cl => (cl :: acc,tg) - | inr l => (acc,merge tg l) - end) f (nil, null). - - Definition ror_clause_cnf t f := - match t with - | nil => (f, null) - | _ => xror_clause_cnf t f - end. - - - Fixpoint ror_cnf (f f':list clause) := - match f with - | nil => (cnf_tt, null) - | e :: rst => - let (rst_f',t) := ror_cnf rst f' in - let (e_f', t') := ror_clause_cnf e f' in - (rst_f' +++ e_f', merge t t') - end. - - Definition annot_of_clause (l : clause) : list Annot := - List.map snd l. - - Definition annot_of_cnf (f : cnf) : list Annot := - List.fold_left (fun acc e => annot_of_clause e +++ acc ) f nil. - - - Definition ror_cnf_opt f1 f2 := - if is_cnf_tt f1 - then (cnf_tt, null) - else if is_cnf_tt f2 - then (cnf_tt, null) - else if is_cnf_ff f2 - then (f1, null) - else ror_cnf f1 f2. - - - Definition ocons {A : Type} (o : option A) (l : list A) : list A := - match o with - | None => l - | Some e => e ::l - end. - - Definition ratom (c : cnf) (a : Annot) : cnf * Trace := - if is_cnf_ff c || is_cnf_tt c - then (c,push a null) - else (c,null). (* t is embedded in c *) - - Section REC. - Context {TX : kind -> Type} {AF : Type}. - - Variable RXCNF : forall (polarity: bool) (k: kind) (f: TFormula TX AF k) , cnf * Trace. - - Definition rxcnf_and (polarity:bool) (k: kind) (e1 e2 : TFormula TX AF k) := - let '(e1,t1) := RXCNF polarity e1 in - let '(e2,t2) := RXCNF polarity e2 in - if polarity - then (and_cnf_opt e1 e2, merge t1 t2) - else let (f',t') := ror_cnf_opt e1 e2 in - (f', merge t1 (merge t2 t')). - - Definition rxcnf_or (polarity:bool) (k: kind) (e1 e2 : TFormula TX AF k) := - let '(e1,t1) := RXCNF polarity e1 in - let '(e2,t2) := RXCNF polarity e2 in - if polarity - then let (f',t') := ror_cnf_opt e1 e2 in - (f', merge t1 (merge t2 t')) - else (and_cnf_opt e1 e2, merge t1 t2). - - Definition rxcnf_impl (polarity:bool) (k: kind) (e1 e2 : TFormula TX AF k) := - let '(e1 , t1) := (RXCNF (negb polarity) e1) in - if polarity - then - if is_cnf_tt e1 - then (e1,t1) - else if is_cnf_ff e1 - then - RXCNF polarity e2 - else (* compute disjunction *) - let '(e2 , t2) := (RXCNF polarity e2) in - let (f',t') := ror_cnf_opt e1 e2 in - (f', merge t1 (merge t2 t')) (* record the hypothesis *) - else - let '(e2 , t2) := (RXCNF polarity e2) in - (and_cnf_opt e1 e2, merge t1 t2). - - Definition rxcnf_iff (polarity:bool) (k: kind) (e1 e2 : TFormula TX AF k) := - let '(c1,t1) := RXCNF (negb polarity) e1 in - let '(c2,t2) := RXCNF false e2 in - let '(c3,t3) := RXCNF polarity e1 in - let '(c4,t4) := RXCNF true e2 in - let (f',t') := ror_cnf_opt (and_cnf_opt c1 c2) (and_cnf_opt c3 c4) in - (f', merge t1 (merge t2 (merge t3 (merge t4 t')))) - . - - End REC. - - Fixpoint rxcnf {TX : kind -> Type} {AF: Type}(polarity : bool) (k: kind) (f : TFormula TX AF k) : cnf * Trace := - - match f with - | TT _ => if polarity then (cnf_tt, null) else (cnf_ff, null) - | FF _ => if polarity then (cnf_ff, null) else (cnf_tt, null) - | X b p => if polarity then (cnf_ff, null) else (cnf_ff, null) - | A _ x t => ratom (if polarity then normalise x t else negate x t) t - | NOT e => rxcnf (negb polarity) e - | AND e1 e2 => rxcnf_and rxcnf polarity e1 e2 - | OR e1 e2 => rxcnf_or rxcnf polarity e1 e2 - | IMPL e1 a e2 => rxcnf_impl rxcnf polarity e1 e2 - | IFF e1 e2 => rxcnf_iff rxcnf polarity e1 e2 - | EQ e1 e2 => rxcnf_iff rxcnf polarity e1 e2 - end. - - Section Abstraction. - Variable TX : kind -> Type. - Variable AF : Type. - - Class to_constrT : Type := - { - mkTT : forall (k: kind), TX k; - mkFF : forall (k: kind), TX k; - mkA : forall (k: kind), Term -> Annot -> TX k; - mkAND : forall (k: kind), TX k -> TX k -> TX k; - mkOR : forall (k: kind), TX k -> TX k -> TX k; - mkIMPL : forall (k: kind), TX k -> TX k -> TX k; - mkIFF : forall (k: kind), TX k -> TX k -> TX k; - mkNOT : forall (k: kind), TX k -> TX k; - mkEQ : TX isBool -> TX isBool -> TX isProp - - }. - - Context {to_constr : to_constrT}. - - Fixpoint aformula (k: kind) (f : TFormula TX AF k) : TX k := - match f with - | TT b => mkTT b - | FF b => mkFF b - | X b p => p - | A b x t => mkA b x t - | AND f1 f2 => mkAND (aformula f1) (aformula f2) - | OR f1 f2 => mkOR (aformula f1) (aformula f2) - | IMPL f1 o f2 => mkIMPL (aformula f1) (aformula f2) - | IFF f1 f2 => mkIFF (aformula f1) (aformula f2) - | NOT f => mkNOT (aformula f) - | EQ f1 f2 => mkEQ (aformula f1) (aformula f2) - end. - - - Definition is_X (k: kind) (f : TFormula TX AF k) : option (TX k) := - match f with - | X _ p => Some p - | _ => None - end. - - Lemma is_X_inv : forall (k: kind) (f: TFormula TX AF k) x, - is_X f = Some x -> f = X k x. - Proof. - intros k f; destruct f ; simpl ; try congruence. - Qed. - - Variable needA : Annot -> bool. - - Definition abs_and (k: kind) (f1 f2 : TFormula TX AF k) - (c : forall (k: kind), TFormula TX AF k -> TFormula TX AF k -> TFormula TX AF k) := - match is_X f1 , is_X f2 with - | Some _ , _ | _ , Some _ => X k (aformula (c k f1 f2)) - | _ , _ => c k f1 f2 - end. - - Definition abs_or (k: kind) (f1 f2 : TFormula TX AF k) - (c : forall (k: kind), TFormula TX AF k -> TFormula TX AF k -> TFormula TX AF k) := - match is_X f1 , is_X f2 with - | Some _ , Some _ => X k (aformula (c k f1 f2)) - | _ , _ => c k f1 f2 - end. - - Definition abs_not (k: kind) (f1 : TFormula TX AF k) - (c : forall (k: kind), TFormula TX AF k -> TFormula TX AF k) := - match is_X f1 with - | Some _ => X k (aformula (c k f1 )) - | _ => c k f1 - end. - - - Definition mk_arrow (o : option AF) (k: kind) (f1 f2: TFormula TX AF k) := - match o with - | None => IMPL f1 None f2 - | Some _ => if is_X f1 then f2 else IMPL f1 o f2 - end. - - Fixpoint abst_simpl (k: kind) (f : TFormula TX AF k) : TFormula TX AF k:= - match f with - | TT k => TT k - | FF k => FF k - | X k p => X k p - | A k x t => if needA t then A k x t else X k (mkA k x t) - | AND f1 f2 => AND (abst_simpl f1) (abst_simpl f2) - | OR f1 f2 => OR (abst_simpl f1) (abst_simpl f2) - | IMPL f1 o f2 => IMPL (abst_simpl f1) o (abst_simpl f2) - | NOT f => NOT (abst_simpl f) - | IFF f1 f2 => IFF (abst_simpl f1) (abst_simpl f2) - | EQ f1 f2 => EQ (abst_simpl f1) (abst_simpl f2) - end. - - Section REC. - Variable REC : forall (pol : bool) (k: kind) (f : TFormula TX AF k), TFormula TX AF k. - - Definition abst_and (pol : bool) (k: kind) (f1 f2:TFormula TX AF k) : TFormula TX AF k:= - (if pol then abs_and else abs_or) k (REC pol f1) (REC pol f2) AND. - - Definition abst_or (pol : bool) (k: kind) (f1 f2:TFormula TX AF k) : TFormula TX AF k:= - (if pol then abs_or else abs_and) k (REC pol f1) (REC pol f2) OR. - - Definition abst_impl (pol : bool) (o :option AF) (k: kind) (f1 f2:TFormula TX AF k) : TFormula TX AF k:= - (if pol then abs_or else abs_and) k (REC (negb pol) f1) (REC pol f2) (mk_arrow o). - - Definition or_is_X (k: kind) (f1 f2: TFormula TX AF k) : bool := - match is_X f1 , is_X f2 with - | Some _ , _ - | _ , Some _ => true - | _ , _ => false - end. - - Definition abs_iff (k: kind) (nf1 ff2 f1 tf2 : TFormula TX AF k) (r: kind) (def : TFormula TX AF r) : TFormula TX AF r := - if andb (or_is_X nf1 ff2) (or_is_X f1 tf2) - then X r (aformula def) - else def. - - - Definition abst_iff (pol : bool) (k: kind) (f1 f2: TFormula TX AF k) : TFormula TX AF k := - abs_iff (REC (negb pol) f1) (REC false f2) (REC pol f1) (REC true f2) (IFF (abst_simpl f1) (abst_simpl f2)). - - Definition abst_eq (pol : bool) (f1 f2: TFormula TX AF isBool) : TFormula TX AF isProp := - abs_iff (REC (negb pol) f1) (REC false f2) (REC pol f1) (REC true f2) (EQ (abst_simpl f1) (abst_simpl f2)). - - End REC. - - Fixpoint abst_form (pol : bool) (k: kind) (f : TFormula TX AF k) : TFormula TX AF k:= - match f with - | TT k => if pol then TT k else X k (mkTT k) - | FF k => if pol then X k (mkFF k) else FF k - | X k p => X k p - | A k x t => if needA t then A k x t else X k (mkA k x t) - | AND f1 f2 => abst_and abst_form pol f1 f2 - | OR f1 f2 => abst_or abst_form pol f1 f2 - | IMPL f1 o f2 => abst_impl abst_form pol o f1 f2 - | NOT f => abs_not (abst_form (negb pol) f) NOT - | IFF f1 f2 => abst_iff abst_form pol f1 f2 - | EQ f1 f2 => abst_eq abst_form pol f1 f2 - end. - - Lemma if_same : forall {A: Type} (b: bool) (t:A), - (if b then t else t) = t. - Proof. - intros A b; destruct b ; reflexivity. - Qed. - - Lemma is_cnf_tt_cnf_ff : - is_cnf_tt cnf_ff = false. - Proof. - reflexivity. - Qed. - - Lemma is_cnf_ff_cnf_ff : - is_cnf_ff cnf_ff = true. - Proof. - reflexivity. - Qed. - - - Lemma is_cnf_tt_inv : forall f1, - is_cnf_tt f1 = true -> f1 = cnf_tt. - Proof. - unfold cnf_tt. - intros f1; destruct f1 ; simpl ; try congruence. - Qed. - - Lemma is_cnf_ff_inv : forall f1, - is_cnf_ff f1 = true -> f1 = cnf_ff. - Proof. - unfold cnf_ff. - intros f1 ; destruct f1 as [|c f1] ; simpl ; try congruence. - destruct c ; simpl ; try congruence. - destruct f1 ; try congruence. - reflexivity. - Qed. - - - Lemma if_cnf_tt : forall f, (if is_cnf_tt f then cnf_tt else f) = f. - Proof. - intros f. - destruct (is_cnf_tt f) eqn:EQ. - - apply is_cnf_tt_inv in EQ;auto. - - reflexivity. - Qed. - - Lemma or_cnf_opt_cnf_ff : forall f, - or_cnf_opt cnf_ff f = f. - Proof. - intros f. - unfold or_cnf_opt. - rewrite is_cnf_tt_cnf_ff. - simpl. - destruct (is_cnf_tt f) eqn:EQ. - - apply is_cnf_tt_inv in EQ. - congruence. - - destruct (is_cnf_ff f) eqn:EQ1. - + apply is_cnf_ff_inv in EQ1. - congruence. - + reflexivity. - Qed. - - Lemma abs_and_pol : forall (k: kind) (f1 f2: TFormula TX AF k) pol, - and_cnf_opt (xcnf pol f1) (xcnf pol f2) = - xcnf pol (abs_and f1 f2 (if pol then AND else OR)). - Proof. - unfold abs_and; intros k f1 f2 pol. - destruct (is_X f1) eqn:EQ1. - - apply is_X_inv in EQ1. - subst. - simpl. - rewrite if_same. reflexivity. - - destruct (is_X f2) eqn:EQ2. - + apply is_X_inv in EQ2. - subst. - simpl. - rewrite if_same. - unfold and_cnf_opt. - rewrite orb_comm. reflexivity. - + destruct pol ; simpl; auto. - Qed. - - Lemma abs_or_pol : forall (k: kind) (f1 f2:TFormula TX AF k) pol, - or_cnf_opt (xcnf pol f1) (xcnf pol f2) = - xcnf pol (abs_or f1 f2 (if pol then OR else AND)). - Proof. - unfold abs_or; intros k f1 f2 pol. - destruct (is_X f1) eqn:EQ1. - - apply is_X_inv in EQ1. - subst. - destruct (is_X f2) eqn:EQ2. - + apply is_X_inv in EQ2. - subst. - simpl. - rewrite if_same. - reflexivity. - + simpl. - rewrite if_same. - destruct pol ; simpl; auto. - - destruct pol ; simpl ; auto. - Qed. - - Variable needA_all : forall a, needA a = true. - - Lemma xcnf_true_mk_arrow_l : forall b o t (f:TFormula TX AF b), - xcnf true (mk_arrow o (X b t) f) = xcnf true f. - Proof. - intros b o; destruct o ; simpl; auto. - intros. rewrite or_cnf_opt_cnf_ff. reflexivity. - Qed. - - Lemma or_cnf_opt_cnf_ff_r : forall f, - or_cnf_opt f cnf_ff = f. - Proof. - unfold or_cnf_opt. - intros. - rewrite is_cnf_tt_cnf_ff. - rewrite orb_comm. - simpl. - apply if_cnf_tt. - Qed. - - Lemma xcnf_true_mk_arrow_r : forall b o t (f:TFormula TX AF b), - xcnf true (mk_arrow o f (X b t)) = xcnf false f. - Proof. - intros b o; destruct o ; simpl; auto. - - intros t f. - destruct (is_X f) eqn:EQ. - + apply is_X_inv in EQ. subst. reflexivity. - + simpl. - apply or_cnf_opt_cnf_ff_r. - - intros. - apply or_cnf_opt_cnf_ff_r. - Qed. - - Lemma and_cnf_opt_cnf_ff_r : forall f, - and_cnf_opt f cnf_ff = cnf_ff. - Proof. - intros. - unfold and_cnf_opt. - rewrite is_cnf_ff_cnf_ff. - rewrite orb_comm. reflexivity. - Qed. - - Lemma and_cnf_opt_cnf_ff : forall f, - and_cnf_opt cnf_ff f = cnf_ff. - Proof. - intros. - unfold and_cnf_opt. - rewrite is_cnf_ff_cnf_ff. - reflexivity. - Qed. - - - Lemma and_cnf_opt_cnf_tt : forall f, - and_cnf_opt f cnf_tt = f. - Proof. - intros f. - unfold and_cnf_opt. - simpl. rewrite orb_comm. - simpl. - destruct (is_cnf_ff f) eqn:EQ ; auto. - apply is_cnf_ff_inv in EQ. - auto. - Qed. - - Lemma is_bool_abst_simpl : forall b (f:TFormula TX AF b), - is_bool (abst_simpl f) = is_bool f. - Proof. - intros b f; induction f ; simpl ; auto. - rewrite needA_all. - reflexivity. - Qed. - - Lemma abst_simpl_correct : forall b (f:TFormula TX AF b) pol, - xcnf pol f = xcnf pol (abst_simpl f). - Proof. - intros b f; - induction f as [| | | |? ? IHf1 f2 IHf2|? ? IHf1 f2 IHf2 - |? ? IHf|? ? IHf1 ? f2 IHf2|? ? IHf1 f2 IHf2|f1 IHf1 f2 IHf2]; - simpl;intros; - unfold mk_and,mk_or,mk_impl, mk_iff; - rewrite <- ?IHf; - try (rewrite <- !IHf1; rewrite <- !IHf2); - try reflexivity. - - rewrite needA_all. - reflexivity. - - rewrite is_bool_abst_simpl. - destruct (is_bool f2); auto. - - rewrite is_bool_abst_simpl. - destruct (is_bool f2); auto. - Qed. - - Ltac is_X t := - match goal with - | |-context[is_X ?X] => - let f := fresh "EQ" in - destruct (is_X X) as [t|] eqn:f ; - [apply is_X_inv in f|] - end. - - Ltac cnf_simpl := - repeat match goal with - | |- context[and_cnf_opt cnf_ff _ ] => rewrite and_cnf_opt_cnf_ff - | |- context[and_cnf_opt _ cnf_ff] => rewrite and_cnf_opt_cnf_ff_r - | |- context[and_cnf_opt _ cnf_tt] => rewrite and_cnf_opt_cnf_tt - | |- context[or_cnf_opt cnf_ff _] => rewrite or_cnf_opt_cnf_ff - | |- context[or_cnf_opt _ cnf_ff] => rewrite or_cnf_opt_cnf_ff_r - end. - - Lemma or_is_X_inv : forall (k: kind) (f1 f2 : TFormula TX AF k), - or_is_X f1 f2 = true -> - exists k1, is_X f1 = Some k1 \/ is_X f2 = Some k1. - Proof. - unfold or_is_X. - intros k f1 f2. - is_X t; is_X t0. - - exists t ; intuition. - - exists t ; intuition. - - exists t0 ; intuition. - - congruence. - Qed. - - Lemma mk_iff_is_bool : forall (k: kind) (f1 f2:TFormula TX AF k) pol, - match is_bool f2 with - | Some isb => xcnf (if isb then pol else negb pol) f1 - | None => mk_iff xcnf pol f1 f2 - end = mk_iff xcnf pol f1 f2. - Proof. - intros k f1 f2 pol. - destruct (is_bool f2) as [b|] eqn:EQ; auto. - apply is_bool_inv in EQ. - subst. - unfold mk_iff. - destruct b ; simpl; cnf_simpl; reflexivity. - Qed. - - Lemma abst_iff_correct : forall - (k: kind) - (f1 f2 : GFormula k) - (IHf1 : forall pol : bool, xcnf pol f1 = xcnf pol (abst_form pol f1)) - (IHf2 : forall pol : bool, xcnf pol f2 = xcnf pol (abst_form pol f2)) - (pol : bool), - xcnf pol (IFF f1 f2) = xcnf pol (abst_iff abst_form pol f1 f2). - Proof. - intros k f1 f2 IHf1 IHf2 pol; simpl. - assert (D1 :mk_iff xcnf pol f1 f2 = mk_iff xcnf pol (abst_simpl f1) (abst_simpl f2)). - { - simpl. - unfold mk_iff. - rewrite <- !abst_simpl_correct. - reflexivity. - } - rewrite mk_iff_is_bool. - unfold abst_iff,abs_iff. - destruct ( or_is_X (abst_form (negb pol) f1) (abst_form false f2) && - or_is_X (abst_form pol f1) (abst_form true f2) - ) eqn:EQ1. - + simpl. - rewrite andb_true_iff in EQ1. - destruct EQ1 as (EQ1 & EQ2). - apply or_is_X_inv in EQ1. - apply or_is_X_inv in EQ2. - destruct EQ1 as (b1 & EQ1). - destruct EQ2 as (b2 & EQ2). - rewrite if_same. - unfold mk_iff. - rewrite !IHf1. - rewrite !IHf2. - destruct EQ1 as [EQ1 | EQ1] ; apply is_X_inv in EQ1; - destruct EQ2 as [EQ2 | EQ2] ; apply is_X_inv in EQ2; - rewrite EQ1; rewrite EQ2; simpl; - repeat rewrite if_same ; cnf_simpl; auto. - + simpl. - rewrite mk_iff_is_bool. - unfold mk_iff. - rewrite <- ! abst_simpl_correct. - reflexivity. - Qed. - - Lemma abst_eq_correct : forall - (f1 f2 : GFormula isBool) - (IHf1 : forall pol : bool, xcnf pol f1 = xcnf pol (abst_form pol f1)) - (IHf2 : forall pol : bool, xcnf pol f2 = xcnf pol (abst_form pol f2)) - (pol : bool), - xcnf pol (EQ f1 f2) = xcnf pol (abst_form pol (EQ f1 f2)). - Proof. - intros f1 f2 IHf1 IHf2 pol. - change (xcnf pol (IFF f1 f2) = xcnf pol (abst_form pol (EQ f1 f2))). - rewrite abst_iff_correct by assumption. - simpl. unfold abst_iff, abst_eq. - unfold abs_iff. - destruct (or_is_X (abst_form (negb pol) f1) (abst_form false f2) && - or_is_X (abst_form pol f1) (abst_form true f2) - ) ; auto. - Qed. - - - Lemma abst_form_correct : forall b (f:TFormula TX AF b) pol, - xcnf pol f = xcnf pol (abst_form pol f). - Proof. - intros b f; - induction f as [| | | |? ? IHf1 ? IHf2|? ? IHf1 ? IHf2|? f IHf - |? f1 IHf1 o f2 IHf2|? IHf1 ? IHf2|]; - intros pol. - - simpl. destruct pol ; reflexivity. - - simpl. destruct pol ; reflexivity. - - simpl. reflexivity. - - simpl. rewrite needA_all. - reflexivity. - - simpl. unfold mk_and. - specialize (IHf1 pol). - specialize (IHf2 pol). - rewrite IHf1. - rewrite IHf2. - destruct pol. - + apply abs_and_pol; auto. - + apply abs_or_pol. - - simpl. unfold mk_or. - specialize (IHf1 pol). - specialize (IHf2 pol). - rewrite IHf1. - rewrite IHf2. - destruct pol. - + apply abs_or_pol; auto. - + apply abs_and_pol; auto. - - simpl. - unfold abs_not. - specialize (IHf (negb pol)). - destruct (is_X (abst_form (negb pol) f)) eqn:EQ1. - + apply is_X_inv in EQ1. - rewrite EQ1 in *. - simpl in *. - destruct pol ; auto. - + simpl. congruence. - - simpl. unfold mk_impl. - specialize (IHf1 (negb pol)). - specialize (IHf2 pol). - destruct pol. - + - simpl in *. - unfold abs_or. - destruct (is_X (abst_form false f1)) eqn:EQ1; - destruct (is_X (abst_form true f2)) eqn:EQ2 ; simpl. - * apply is_X_inv in EQ1. - apply is_X_inv in EQ2. - rewrite EQ1 in *. - rewrite EQ2 in *. - rewrite IHf1. rewrite IHf2. - simpl. reflexivity. - * apply is_X_inv in EQ1. - rewrite EQ1 in *. - rewrite IHf1. - simpl. - rewrite xcnf_true_mk_arrow_l. - rewrite or_cnf_opt_cnf_ff. - congruence. - * apply is_X_inv in EQ2. - rewrite EQ2 in *. - rewrite IHf2. - simpl. - rewrite xcnf_true_mk_arrow_r. - rewrite or_cnf_opt_cnf_ff_r. - congruence. - * destruct o ; simpl ; try congruence. - rewrite EQ1. - simpl. congruence. - + simpl in *. - unfold abs_and. - destruct (is_X (abst_form true f1)) eqn:EQ1; - destruct (is_X (abst_form false f2)) eqn:EQ2 ; simpl. - * apply is_X_inv in EQ1. - apply is_X_inv in EQ2. - rewrite EQ1 in *. - rewrite EQ2 in *. - rewrite IHf1. rewrite IHf2. - simpl. reflexivity. - * apply is_X_inv in EQ1. - rewrite EQ1 in *. - rewrite IHf1. - simpl. reflexivity. - * apply is_X_inv in EQ2. - rewrite EQ2 in *. - rewrite IHf2. - simpl. unfold and_cnf_opt. - rewrite orb_comm. reflexivity. - * destruct o; simpl. - -- rewrite EQ1. simpl. - congruence. - -- congruence. - - apply abst_iff_correct; auto. - - apply abst_eq_correct; auto. - Qed. - - End Abstraction. - - - End CNFAnnot. - - - Lemma radd_term_term : forall a' a cl, radd_term a a' = inl cl -> add_term a a' = Some cl. - Proof. - intros a'; induction a' as [|a a' IHa']; simpl. - - intros a cl H. - destruct (deduce (fst a) (fst a)) as [t|]. - + destruct (unsat t). - * congruence. - * inversion H. reflexivity. - + inversion H ;reflexivity. - - intros a0 cl H. - destruct (deduce (fst a0) (fst a)) as [t|]. - + destruct (unsat t). - * congruence. - * destruct (radd_term a0 a') eqn:RADD; try congruence. - inversion H. subst. - apply IHa' in RADD. - rewrite RADD. - reflexivity. - + destruct (radd_term a0 a') eqn:RADD; try congruence. - inversion H. subst. - apply IHa' in RADD. - rewrite RADD. - reflexivity. - Qed. - - Lemma radd_term_term' : forall a' a cl, add_term a a' = Some cl -> radd_term a a' = inl cl. - Proof. - intros a'; induction a' as [|a a' IHa']; simpl. - - intros a cl H. - destruct (deduce (fst a) (fst a)) as [t|]. - + destruct (unsat t). - * congruence. - * inversion H. reflexivity. - + inversion H ;reflexivity. - - intros a0 cl H. - destruct (deduce (fst a0) (fst a)) as [t|]. - + destruct (unsat t). - * congruence. - * destruct (add_term a0 a') eqn:RADD; try congruence. - inversion H. subst. - apply IHa' in RADD. - rewrite RADD. - reflexivity. - + destruct (add_term a0 a') eqn:RADD; try congruence. - inversion H. subst. - apply IHa' in RADD. - rewrite RADD. - reflexivity. - Qed. - - Lemma xror_clause_clause : forall a f, - fst (xror_clause_cnf a f) = xor_clause_cnf a f. - Proof. - unfold xror_clause_cnf. - unfold xor_clause_cnf. - assert (ACC: fst (@nil clause, null) = nil) by reflexivity. - intros a f. - set (F1:= (fun '(acc, tg) (e : clause) => - match ror_clause a e with - | inl cl => (cl :: acc, tg) - | inr l => (acc, merge tg l) - end)). - set (F2:= (fun (acc : list clause) (e : clause) => - match or_clause a e with - | Some cl => cl :: acc - | None => acc - end)). - revert ACC. - generalize (@nil clause, null). - generalize (@nil clause). - induction f as [|a0 f IHf]; simpl ; auto. - intros ? p ?. - apply IHf. - unfold F1 , F2. - destruct p ; simpl in * ; subst. - clear. - revert a0. - induction a as [|a a0 IHa]; simpl; auto. - intros a1. - destruct (radd_term a a1) eqn:RADD. - - apply radd_term_term in RADD. - rewrite RADD. - auto. - - destruct (add_term a a1) eqn:RADD'. - + apply radd_term_term' in RADD'. - congruence. - + reflexivity. - Qed. - - Lemma ror_clause_clause : forall a f, - fst (ror_clause_cnf a f) = or_clause_cnf a f. - Proof. - unfold ror_clause_cnf,or_clause_cnf. - intros a; destruct a ; auto. - apply xror_clause_clause. - Qed. - - Lemma ror_cnf_cnf : forall f1 f2, fst (ror_cnf f1 f2) = or_cnf f1 f2. - Proof. - intros f1; induction f1 as [|a f1 IHf1] ; simpl ; auto. - intros f2. - specialize (IHf1 f2). - destruct(ror_cnf f1 f2). - rewrite <- ror_clause_clause. - destruct(ror_clause_cnf a f2). - simpl. - rewrite <- IHf1. - reflexivity. - Qed. - - Lemma ror_opt_cnf_cnf : forall f1 f2, fst (ror_cnf_opt f1 f2) = or_cnf_opt f1 f2. - Proof. - unfold ror_cnf_opt, or_cnf_opt. - intros f1 f2. - destruct (is_cnf_tt f1). - - simpl ; auto. - - simpl. destruct (is_cnf_tt f2) ; simpl ; auto. - destruct (is_cnf_ff f2) eqn:EQ. - + reflexivity. - + apply ror_cnf_cnf. - Qed. - - Lemma ratom_cnf : forall f a, - fst (ratom f a) = f. - Proof. - unfold ratom. - intros f a. - destruct (is_cnf_ff f || is_cnf_tt f); auto. - Qed. - - Lemma rxcnf_and_xcnf : forall {TX : kind -> Type} {AF:Type} (k: kind) (f1 f2:TFormula TX AF k) - (IHf1 : forall pol : bool, fst (rxcnf pol f1) = xcnf pol f1) - (IHf2 : forall pol : bool, fst (rxcnf pol f2) = xcnf pol f2), - forall pol : bool, fst (rxcnf_and rxcnf pol f1 f2) = mk_and xcnf pol f1 f2. - Proof. - intros TX AF k f1 f2 IHf1 IHf2 pol. - unfold mk_and, rxcnf_and. - specialize (IHf1 pol). - specialize (IHf2 pol). - destruct (rxcnf pol f1). - destruct (rxcnf pol f2). - simpl in *. - subst. destruct pol ; auto. - rewrite <- ror_opt_cnf_cnf. - destruct (ror_cnf_opt (xcnf false f1) (xcnf false f2)). - reflexivity. - Qed. - - Lemma rxcnf_or_xcnf : - forall {TX : kind -> Type} {AF:Type} (k: kind) (f1 f2:TFormula TX AF k) - (IHf1 : forall pol : bool, fst (rxcnf pol f1) = xcnf pol f1) - (IHf2 : forall pol : bool, fst (rxcnf pol f2) = xcnf pol f2), - forall pol : bool, fst (rxcnf_or rxcnf pol f1 f2) = mk_or xcnf pol f1 f2. - Proof. - intros TX AF k f1 f2 IHf1 IHf2 pol. - unfold rxcnf_or, mk_or. - specialize (IHf1 pol). - specialize (IHf2 pol). - destruct (rxcnf pol f1). - destruct (rxcnf pol f2). - simpl in *. - subst. destruct pol ; auto. - rewrite <- ror_opt_cnf_cnf. - destruct (ror_cnf_opt (xcnf true f1) (xcnf true f2)). - reflexivity. - Qed. - - - Lemma rxcnf_impl_xcnf : - forall {TX : kind -> Type} {AF:Type} (k: kind) (f1 f2:TFormula TX AF k) - (IHf1 : forall pol : bool, fst (rxcnf pol f1) = xcnf pol f1) - (IHf2 : forall pol : bool, fst (rxcnf pol f2) = xcnf pol f2), - forall pol : bool, fst (rxcnf_impl rxcnf pol f1 f2) = mk_impl xcnf pol f1 f2. - Proof. - intros TX AF k f1 f2 IHf1 IHf2 pol. - unfold rxcnf_impl, mk_impl, mk_or. - specialize (IHf1 (negb pol)). - specialize (IHf2 pol). - rewrite <- IHf1. - rewrite <- IHf2. - destruct (rxcnf (negb pol) f1). - destruct (rxcnf pol f2). - simpl in *. - subst. - destruct pol;auto. - generalize (is_cnf_tt_inv (xcnf (negb true) f1)). - destruct (is_cnf_tt (xcnf (negb true) f1)). - + intros H. - rewrite H by auto. - reflexivity. - + - generalize (is_cnf_ff_inv (xcnf (negb true) f1)). - destruct (is_cnf_ff (xcnf (negb true) f1)). - * intros H. - rewrite H by auto. - unfold or_cnf_opt. - simpl. - destruct (is_cnf_tt (xcnf true f2)) eqn:EQ;auto. - -- apply is_cnf_tt_inv in EQ; auto. - -- destruct (is_cnf_ff (xcnf true f2)) eqn:EQ1. - ++ apply is_cnf_ff_inv in EQ1. congruence. - ++ reflexivity. - * - rewrite <- ror_opt_cnf_cnf. - destruct (ror_cnf_opt (xcnf (negb true) f1) (xcnf true f2)). - intros. - reflexivity. - Qed. - - Lemma rxcnf_iff_xcnf : - forall {TX : kind -> Type} {AF:Type} (k: kind) (f1 f2:TFormula TX AF k) - (IHf1 : forall pol : bool, fst (rxcnf pol f1) = xcnf pol f1) - (IHf2 : forall pol : bool, fst (rxcnf pol f2) = xcnf pol f2), - forall pol : bool, fst (rxcnf_iff rxcnf pol f1 f2) = mk_iff xcnf pol f1 f2. - Proof. - intros TX AF k f1 f2 IHf1 IHf2 pol. - unfold rxcnf_iff. - unfold mk_iff. - rewrite <- (IHf1 (negb pol)). - rewrite <- (IHf1 pol). - rewrite <- (IHf2 false). - rewrite <- (IHf2 true). - destruct (rxcnf (negb pol) f1) as [c ?]. - destruct (rxcnf false f2) as [c0 ?]. - destruct (rxcnf pol f1) as [c1 ?]. - destruct (rxcnf true f2) as [c2 ?]. - destruct (ror_cnf_opt (and_cnf_opt c c0) (and_cnf_opt c1 c2)) as [c3 l3] eqn:EQ. - simpl. - change c3 with (fst (c3,l3)). - rewrite <- EQ. rewrite ror_opt_cnf_cnf. - reflexivity. - Qed. - - Lemma rxcnf_xcnf : forall {TX : kind -> Type} {AF:Type} (k: kind) (f:TFormula TX AF k) pol, - fst (rxcnf pol f) = xcnf pol f. - Proof. - intros TX AF k f; induction f ; simpl ; auto; intros pol. - - destruct pol; simpl ; auto. - - destruct pol; simpl ; auto. - - destruct pol ; simpl ; auto. - - intros. rewrite ratom_cnf. reflexivity. - - apply rxcnf_and_xcnf; auto. - - apply rxcnf_or_xcnf; auto. - - apply rxcnf_impl_xcnf; auto. - - intros. - rewrite mk_iff_is_bool. - apply rxcnf_iff_xcnf; auto. - - intros. - rewrite mk_iff_is_bool. - apply rxcnf_iff_xcnf; auto. - Qed. - - - Variable eval' : Env -> Term' -> Prop. - - Variable no_middle_eval' : forall env d, (eval' env d) \/ ~ (eval' env d). - - Variable unsat_prop : forall t, unsat t = true -> - forall env, eval' env t -> False. - - Variable deduce_prop : forall t t' u, - deduce t t' = Some u -> forall env, - eval' env t -> eval' env t' -> eval' env u. - - Definition eval_tt (env : Env) (tt : Term' * Annot) := eval' env (fst tt). - - Definition eval_clause (env : Env) (cl : clause) := ~ make_conj (eval_tt env) cl. - - Definition eval_cnf (env : Env) (f:cnf) := make_conj (eval_clause env) f. - - Lemma eval_cnf_app : forall env x y, eval_cnf env (x+++y) <-> eval_cnf env x /\ eval_cnf env y. - Proof. - unfold eval_cnf. - intros. - rewrite make_conj_rapp. - rewrite make_conj_app ; auto. - tauto. - Qed. - - Lemma eval_cnf_ff : forall env, eval_cnf env cnf_ff <-> False. - Proof using. - clear. - unfold cnf_ff, eval_cnf,eval_clause. - simpl. tauto. - Qed. - - Lemma eval_cnf_tt : forall env, eval_cnf env cnf_tt <-> True. - Proof using. - clear. - unfold cnf_tt, eval_cnf,eval_clause. - simpl. tauto. - Qed. - - Lemma eval_cnf_and_opt : forall env x y, eval_cnf env (and_cnf_opt x y) <-> eval_cnf env (and_cnf x y). - Proof. - unfold and_cnf_opt. - intros env x y. - destruct (is_cnf_ff x) eqn:F1. - { apply is_cnf_ff_inv in F1. - simpl. subst. - unfold and_cnf. - rewrite eval_cnf_app. - rewrite eval_cnf_ff. - tauto. - } - simpl. - destruct (is_cnf_ff y) eqn:F2. - { apply is_cnf_ff_inv in F2. - simpl. subst. - unfold and_cnf. - rewrite eval_cnf_app. - rewrite eval_cnf_ff. - tauto. - } - destruct (is_cnf_tt y) eqn:F3. - { - apply is_cnf_tt_inv in F3. - subst. - unfold and_cnf. - rewrite eval_cnf_app. - rewrite eval_cnf_tt. - tauto. - } - tauto. - Qed. - - Definition eval_opt_clause (env : Env) (cl: option clause) := - match cl with - | None => True - | Some cl => eval_clause env cl - end. - - Lemma add_term_correct : forall env t cl , eval_opt_clause env (add_term t cl) <-> eval_clause env (t::cl). - Proof. - intros env t cl; induction cl as [|a cl IHcl]. - - (* BC *) - simpl. - case_eq (deduce (fst t) (fst t)) ; try tauto. - intros t0 H. - generalize (@deduce_prop _ _ _ H env). - case_eq (unsat t0) ; try tauto. - { intros H0 ?. - generalize (@unsat_prop _ H0 env). - unfold eval_clause. - rewrite make_conj_cons. - simpl; intros. - tauto. - } - - (* IC *) - simpl. - case_eq (deduce (fst t) (fst a)); - intros t0; [intros H|]. - + generalize (@deduce_prop _ _ _ H env). - case_eq (unsat t0); intros H0 H1. - { - generalize (@unsat_prop _ H0 env). - simpl. - unfold eval_clause. - repeat rewrite make_conj_cons. - tauto. - } - destruct (add_term t cl) ; simpl in * ; try tauto. - { - intros. - unfold eval_clause in *. - repeat rewrite make_conj_cons in *. - tauto. - } - { - unfold eval_clause in *. - repeat rewrite make_conj_cons in *. - tauto. - } - + destruct (add_term t cl) ; simpl in *; - unfold eval_clause in * ; - repeat rewrite make_conj_cons in *; tauto. - Qed. - - - Lemma no_middle_eval_tt : forall env a, - eval_tt env a \/ ~ eval_tt env a. - Proof. - unfold eval_tt. - auto. - Qed. - - #[local] - Hint Resolve no_middle_eval_tt : tauto. - - Lemma or_clause_correct : forall cl cl' env, eval_opt_clause env (or_clause cl cl') <-> eval_clause env cl \/ eval_clause env cl'. - Proof. - intros cl; induction cl as [|a cl IHcl]. - - simpl. unfold eval_clause at 2. simpl. tauto. - - intros cl' env. - simpl. - assert (HH := add_term_correct env a cl'). - assert (eval_tt env a \/ ~ eval_tt env a) by (apply no_middle_eval'). - destruct (add_term a cl'); simpl in *. - + - rewrite IHcl. - unfold eval_clause in *. - rewrite !make_conj_cons in *. - tauto. - + unfold eval_clause in *. - repeat rewrite make_conj_cons in *. - tauto. - Qed. - - - Lemma or_clause_cnf_correct : forall env t f, eval_cnf env (or_clause_cnf t f) <-> (eval_clause env t) \/ (eval_cnf env f). - Proof. - unfold eval_cnf. - unfold or_clause_cnf. - intros env t. - set (F := (fun (acc : list clause) (e : clause) => - match or_clause t e with - | Some cl => cl :: acc - | None => acc - end)). - intro f. - assert ( make_conj (eval_clause env) (fold_left F f nil) <-> (eval_clause env t \/ make_conj (eval_clause env) f) /\ make_conj (eval_clause env) nil) as H. - { - generalize (@nil clause) as acc. - induction f as [|a f IHf]. - - simpl. - intros ; tauto. - - intros. - simpl fold_left. - rewrite IHf. - rewrite make_conj_cons. - unfold F in *; clear F. - generalize (or_clause_correct t a env). - destruct (or_clause t a). - + - rewrite make_conj_cons. - simpl. tauto. - + simpl. tauto. - } - destruct t ; auto. - - unfold eval_clause ; simpl. tauto. - - unfold xor_clause_cnf. - unfold F in H. - rewrite H. - unfold make_conj at 2. tauto. - Qed. - - - Lemma eval_cnf_cons : forall env a f, (~ make_conj (eval_tt env) a /\ eval_cnf env f) <-> eval_cnf env (a::f). - Proof. - intros. - unfold eval_cnf in *. - rewrite make_conj_cons ; eauto. - unfold eval_clause at 2. - tauto. - Qed. - - Lemma eval_cnf_cons_iff : forall env a f, ((~ make_conj (eval_tt env) a) /\ eval_cnf env f) <-> eval_cnf env (a::f). - Proof using. - intros; clear. - unfold eval_cnf in *. - rewrite make_conj_cons ; eauto. - unfold eval_clause. - tauto. - Qed. - - - Lemma or_cnf_correct : forall env f f', eval_cnf env (or_cnf f f') <-> (eval_cnf env f) \/ (eval_cnf env f'). - Proof. - intros env f; induction f as [|a f IHf]. - - unfold eval_cnf. - simpl. - tauto. - (**) - - intros. - simpl. - rewrite eval_cnf_app. - rewrite <- eval_cnf_cons_iff. - rewrite IHf. - rewrite or_clause_cnf_correct. - unfold eval_clause. - tauto. - Qed. - - Lemma or_cnf_opt_correct : forall env f f', eval_cnf env (or_cnf_opt f f') <-> eval_cnf env (or_cnf f f'). - Proof. - unfold or_cnf_opt. - intros env f f'. - destruct (is_cnf_tt f) eqn:TF. - { simpl. - apply is_cnf_tt_inv in TF. - subst. - rewrite or_cnf_correct. - rewrite eval_cnf_tt. - tauto. - } - destruct (is_cnf_tt f') eqn:TF'. - { simpl. - apply is_cnf_tt_inv in TF'. - subst. - rewrite or_cnf_correct. - rewrite eval_cnf_tt. - tauto. - } - { simpl. - destruct (is_cnf_ff f') eqn:EQ. - - apply is_cnf_ff_inv in EQ. - subst. - rewrite or_cnf_correct. - rewrite eval_cnf_ff. - tauto. - - tauto. - } - Qed. - - Variable eval : Env -> forall (k: kind), Term -> rtyp k. - - Variable normalise_correct : forall env b t tg, eval_cnf env (normalise t tg) -> hold b (eval env b t). - - Variable negate_correct : forall env b t tg, eval_cnf env (negate t tg) -> hold b (eNOT b (eval env b t)). - - Definition e_rtyp (k: kind) (x : rtyp k) : rtyp k := x. - - Lemma hold_eTT : forall k, hold k (eTT k). - Proof. - intros k; destruct k ; simpl; auto. - Qed. - - #[local] - Hint Resolve hold_eTT : tauto. - - Lemma hold_eFF : forall k, - hold k (eNOT k (eFF k)). - Proof. - intros k; destruct k ; simpl;auto. - Qed. - - #[local] - Hint Resolve hold_eFF : tauto. - - Lemma hold_eAND : forall k r1 r2, - hold k (eAND k r1 r2) <-> (hold k r1 /\ hold k r2). - Proof. - intros k; destruct k ; simpl. - - intros. apply iff_refl. - - apply andb_true_iff. - Qed. - - Lemma hold_eOR : forall k r1 r2, - hold k (eOR k r1 r2) <-> (hold k r1 \/ hold k r2). - Proof. - intros k; destruct k ; simpl. - - intros. apply iff_refl. - - apply orb_true_iff. - Qed. - - Lemma hold_eNOT : forall k e, - hold k (eNOT k e) <-> not (hold k e). - Proof. - intros k; destruct k ; simpl. - - intros. apply iff_refl. - - intros e. unfold is_true. - rewrite negb_true_iff. - destruct e ; intuition congruence. - Qed. - - Lemma hold_eIMPL : forall k e1 e2, - hold k (eIMPL k e1 e2) <-> (hold k e1 -> hold k e2). - Proof. - intros k; destruct k ; simpl. - - intros. apply iff_refl. - - intros e1 e2. - unfold is_true. - destruct e1,e2 ; simpl ; intuition congruence. - Qed. - - Lemma hold_eIFF : forall k e1 e2, - hold k (eIFF k e1 e2) <-> (hold k e1 <-> hold k e2). - Proof. - intros k; destruct k ; simpl. - - intros. apply iff_refl. - - intros e1 e2. - unfold is_true. - rewrite eqb_true_iff. - destruct e1,e2 ; simpl ; intuition congruence. - Qed. - - - - Lemma xcnf_impl : - forall - (k: kind) - (f1 : GFormula k) - (o : option unit) - (f2 : GFormula k) - (IHf1 : forall (pol : bool) (env : Env), - eval_cnf env (xcnf pol f1) -> - hold k (eval_f e_rtyp (eval env) (if pol then f1 else NOT f1))) - (IHf2 : forall (pol : bool) (env : Env), - eval_cnf env (xcnf pol f2) -> - hold k (eval_f e_rtyp (eval env) (if pol then f2 else NOT f2))), - forall (pol : bool) (env : Env), - eval_cnf env (xcnf pol (IMPL f1 o f2)) -> - hold k (eval_f e_rtyp (eval env) (if pol then IMPL f1 o f2 else NOT (IMPL f1 o f2))). - Proof. - simpl; intros k f1 o f2 IHf1 IHf2 pol env H. unfold mk_impl in H. - destruct pol. - + simpl. - rewrite hold_eIMPL. - intro. - rewrite or_cnf_opt_correct in H. - rewrite or_cnf_correct in H. - destruct H as [H | H]. - * generalize (IHf1 _ _ H). - simpl in *. - rewrite hold_eNOT. - tauto. - * generalize (IHf2 _ _ H). - auto. - + (* pol = false *) - rewrite eval_cnf_and_opt in H. - unfold and_cnf in H. - simpl in H. - rewrite eval_cnf_app in H. - destruct H as [H0 H1]. - generalize (IHf1 _ _ H0). - generalize (IHf2 _ _ H1). - simpl. - rewrite ! hold_eNOT. - rewrite ! hold_eIMPL. - tauto. - Qed. - - Lemma hold_eIFF_IMPL : forall k e1 e2, - hold k (eIFF k e1 e2) <-> (hold k (eAND k (eIMPL k e1 e2) (eIMPL k e2 e1))). - Proof. - intros. - rewrite hold_eIFF. - rewrite hold_eAND. - rewrite! hold_eIMPL. - tauto. - Qed. - - Lemma hold_eEQ : forall e1 e2, - hold isBool (eIFF isBool e1 e2) <-> e1 = e2. - Proof. - simpl. - intros e1 e2; destruct e1,e2 ; simpl ; intuition congruence. - Qed. - - - Lemma xcnf_iff : forall - (k : kind) - (f1 f2 : @GFormula Term rtyp Annot unit k) - (IHf1 : forall (pol : bool) (env : Env), - eval_cnf env (xcnf pol f1) -> - hold k (eval_f e_rtyp (eval env) (if pol then f1 else NOT f1))) - (IHf2 : forall (pol : bool) (env : Env), - eval_cnf env (xcnf pol f2) -> - hold k (eval_f e_rtyp (eval env) (if pol then f2 else NOT f2))), - forall (pol : bool) (env : Env), - eval_cnf env (xcnf pol (IFF f1 f2)) -> - hold k (eval_f e_rtyp (eval env) (if pol then IFF f1 f2 else NOT (IFF f1 f2))). - Proof. - simpl. - intros k f1 f2 IHf1 IHf2 pol env H. - rewrite mk_iff_is_bool in H. - unfold mk_iff in H. - destruct pol; - rewrite or_cnf_opt_correct in H; - rewrite or_cnf_correct in H; - rewrite! eval_cnf_and_opt in H; - unfold and_cnf in H; - rewrite! eval_cnf_app in H; - generalize (IHf1 false env); - generalize (IHf1 true env); - generalize (IHf2 false env); - generalize (IHf2 true env); - simpl. - - - rewrite hold_eIFF_IMPL. - rewrite hold_eAND. - rewrite! hold_eIMPL. - rewrite! hold_eNOT. - tauto. - - rewrite! hold_eNOT. - rewrite hold_eIFF_IMPL. - rewrite hold_eAND. - rewrite! hold_eIMPL. - tauto. - Qed. - - Lemma xcnf_correct : forall (k: kind) (f : @GFormula Term rtyp Annot unit k) pol env, - eval_cnf env (xcnf pol f) -> hold k (eval_f e_rtyp (eval env) (if pol then f else NOT f)). - Proof. - intros k f; - induction f as [| | | |? ? IHf1 ? IHf2|? ? IHf1 ? IHf2|? ? IHf - |? ? IHf1 ? ? IHf2|? ? IHf1 f2 IHf2|f1 IHf1 f2 IHf2]; - intros pol env H. - - (* TT *) - unfold eval_cnf. - simpl. - destruct pol ; intros; simpl; auto with tauto. - rewrite eval_cnf_ff in H. tauto. - - (* FF *) - destruct pol ; simpl in *; intros; auto with tauto. - + rewrite eval_cnf_ff in H. tauto. - - (* P *) - simpl. - destruct pol ; intros ;simpl. - + rewrite eval_cnf_ff in H. tauto. - + rewrite eval_cnf_ff in H. tauto. - - (* A *) - simpl. - destruct pol ; simpl. - + intros. - eapply normalise_correct ; eauto. - + (* A 2 *) - intros. - eapply negate_correct ; eauto. - - (* AND *) - destruct pol ; simpl in H. - + (* pol = true *) - intros. - rewrite eval_cnf_and_opt in H. - unfold and_cnf in H. - rewrite eval_cnf_app in H. - destruct H as [H H0]. - apply hold_eAND; split. - * apply (IHf1 _ _ H). - * apply (IHf2 _ _ H0). - + (* pol = false *) - intros. - apply hold_eNOT. - rewrite hold_eAND. - rewrite or_cnf_opt_correct in H. - rewrite or_cnf_correct in H. - destruct H as [H | H]. - * generalize (IHf1 false env H). - simpl. - rewrite hold_eNOT. - tauto. - * generalize (IHf2 false env H). - simpl. - rewrite hold_eNOT. - tauto. - - (* OR *) - simpl in H. - destruct pol. - + (* pol = true *) - intros. unfold mk_or in H. - rewrite or_cnf_opt_correct in H. - rewrite or_cnf_correct in H. - destruct H as [H | H]. - * generalize (IHf1 _ env H). - simpl. - rewrite hold_eOR. - tauto. - * generalize (IHf2 _ env H). - simpl. - rewrite hold_eOR. - tauto. - + (* pol = true *) - intros. unfold mk_or in H. - rewrite eval_cnf_and_opt in H. - unfold and_cnf. - rewrite eval_cnf_app in H. - destruct H as [H0 H1]. - simpl. - generalize (IHf1 _ _ H0). - generalize (IHf2 _ _ H1). - simpl. - rewrite ! hold_eNOT. - rewrite ! hold_eOR. - tauto. - - (**) - simpl. - destruct pol ; simpl. - + intros. - apply (IHf false) ; auto. - + intros. - generalize (IHf _ _ H). - rewrite ! hold_eNOT. - tauto. - - (* IMPL *) - apply xcnf_impl; auto. - - apply xcnf_iff ; auto. - - simpl in H. - destruct (is_bool f2) as [b|] eqn:EQ. - + apply is_bool_inv in EQ. - destruct b; subst; intros; - apply IHf1 in H; - destruct pol ; simpl in * ; auto. - * unfold is_true in H. - rewrite negb_true_iff in H. - congruence. - * - unfold is_true in H. - rewrite negb_true_iff in H. - congruence. - * unfold is_true in H. - congruence. - + intros. - rewrite <- mk_iff_is_bool in H. - apply xcnf_iff in H; auto. - simpl in H. - destruct pol ; simpl in *. - * rewrite <- hold_eEQ. - simpl; auto. - * rewrite <- hold_eEQ. - simpl; auto. - unfold is_true in *. - rewrite negb_true_iff in H. - congruence. - Qed. - - Variable Witness : Type. - Variable checker : list (Term'*Annot) -> Witness -> bool. - - Variable checker_sound : forall t w, checker t w = true -> forall env, make_impl (eval_tt env) t False. - - Fixpoint cnf_checker (f : cnf) (l : list Witness) {struct f}: bool := - match f with - | nil => true - | e::f => match l with - | nil => false - | c::l => match checker e c with - | true => cnf_checker f l - | _ => false - end - end - end. - - Lemma cnf_checker_sound : forall t w, cnf_checker t w = true -> forall env, eval_cnf env t. - Proof. - unfold eval_cnf. - intros t; induction t as [|a t IHt]. - - (* bc *) - simpl. - auto. - - (* ic *) - simpl. - intros w; destruct w as [|w ?]. - + intros ; discriminate. - + case_eq (checker a w) ; intros H H0 env ** ; try discriminate. - generalize (@checker_sound _ _ H env). - generalize (IHt _ H0 env) ; intros H1 H2. - destruct t. - * red ; intro. - rewrite <- make_conj_impl in H2. - tauto. - * rewrite <- make_conj_impl in H2. - tauto. - Qed. - - Definition tauto_checker (f:@GFormula Term rtyp Annot unit isProp) (w:list Witness) : bool := - cnf_checker (xcnf true f) w. - - Lemma tauto_checker_sound : forall t w, tauto_checker t w = true -> forall env, eval_f e_rtyp (eval env) t. - Proof. - unfold tauto_checker. - intros t w H env. - change (eval_f e_rtyp (eval env) t) with (eval_f e_rtyp (eval env) (if true then t else TT isProp)). - apply (xcnf_correct t true). - eapply cnf_checker_sound ; eauto. - Qed. - - Definition eval_bf {A : Type} (ea : forall (k: kind), A -> rtyp k) (k: kind) (f: BFormula A k) := eval_f e_rtyp ea f. - - Lemma eval_bf_map : forall T U (fct: T-> U) env (k: kind) (f:BFormula T k) , - eval_bf env (map_bformula fct f) = eval_bf (fun b x => env b (fct x)) f. - Proof. - intros T U fct env k f; - induction f as [| | | |? ? IHf1 ? IHf2|? ? IHf1 ? IHf2|? ? IHf - |? ? IHf1 ? ? IHf2|? ? IHf1 ? IHf2|? IHf1 ? IHf2]; - simpl ; try (rewrite IHf1 ; rewrite IHf2) ; auto. - rewrite <- IHf. auto. - Qed. - - -End S. - - -(* Local Variables: *) -(* coding: utf-8 *) -(* End: *) diff --git a/stdlib/theories/micromega/VarMap.v b/stdlib/theories/micromega/VarMap.v deleted file mode 100644 index cb525b8a2b1e..000000000000 --- a/stdlib/theories/micromega/VarMap.v +++ /dev/null @@ -1,84 +0,0 @@ -(* -*- coding: utf-8 -*- *) -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* t -| Branch : t -> A -> t -> t . -Arguments t : clear implicits. - -Register Branch as micromega.VarMap.Branch. -Register Elt as micromega.VarMap.Elt. -Register Empty as micromega.VarMap.Empty. -Register t as micromega.VarMap.type. - -Section MakeVarMap. - - Variable A : Type. - Variable default : A. - - Notation t := (t A). - - Fixpoint find (vm : t) (p:positive) {struct vm} : A := - match vm with - | Empty => default - | Elt i => i - | Branch l e r => match p with - | xH => e - | xO p => find l p - | xI p => find r p - end - end. - - Fixpoint singleton (x:positive) (v : A) : t := - match x with - | xH => Elt v - | xO p => Branch (singleton p v) default Empty - | xI p => Branch Empty default (singleton p v) - end. - - Fixpoint vm_add (x: positive) (v : A) (m : t) {struct m} : t := - match m with - | Empty => singleton x v - | Elt vl => - match x with - | xH => Elt v - | xO p => Branch (singleton p v) vl Empty - | xI p => Branch Empty vl (singleton p v) - end - | Branch l o r => - match x with - | xH => Branch l v r - | xI p => Branch l o (vm_add p v r) - | xO p => Branch (vm_add p v l) o r - end - end. - -End MakeVarMap. - -(* TODO #14736 for compatibility only, should be removed after deprecation *) diff --git a/stdlib/theories/micromega/ZArith_hints.v b/stdlib/theories/micromega/ZArith_hints.v deleted file mode 100644 index 878b433bd6bb..000000000000 --- a/stdlib/theories/micromega/ZArith_hints.v +++ /dev/null @@ -1,65 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* nat) => abstract lia: zarith. -#[global] -Hint Extern 10 (_ <= _) => abstract lia: zarith. -#[global] -Hint Extern 10 (_ < _) => abstract lia: zarith. -#[global] -Hint Extern 10 (_ >= _) => abstract lia: zarith. -#[global] -Hint Extern 10 (_ > _) => abstract lia: zarith. - -#[global] -Hint Extern 10 (_ <> _ :>nat) => abstract lia: zarith. -#[global] -Hint Extern 10 (~ _ <= _) => abstract lia: zarith. -#[global] -Hint Extern 10 (~ _ < _) => abstract lia: zarith. -#[global] -Hint Extern 10 (~ _ >= _) => abstract lia: zarith. -#[global] -Hint Extern 10 (~ _ > _) => abstract lia: zarith. - -#[global] -Hint Extern 10 (_ = _ :>Z) => abstract lia: zarith. -#[global] -Hint Extern 10 (_ <= _)%Z => abstract lia: zarith. -#[global] -Hint Extern 10 (_ < _)%Z => abstract lia: zarith. -#[global] -Hint Extern 10 (_ >= _)%Z => abstract lia: zarith. -#[global] -Hint Extern 10 (_ > _)%Z => abstract lia: zarith. - -#[global] -Hint Extern 10 (_ <> _ :>Z) => abstract lia: zarith. -#[global] -Hint Extern 10 (~ (_ <= _)%Z) => abstract lia: zarith. -#[global] -Hint Extern 10 (~ (_ < _)%Z) => abstract lia: zarith. -#[global] -Hint Extern 10 (~ (_ >= _)%Z) => abstract lia: zarith. -#[global] -Hint Extern 10 (~ (_ > _)%Z) => abstract lia: zarith. - -#[global] -Hint Extern 10 False => abstract lia: zarith. diff --git a/stdlib/theories/micromega/ZCoeff.v b/stdlib/theories/micromega/ZCoeff.v deleted file mode 100644 index c0ef8af73ca3..000000000000 --- a/stdlib/theories/micromega/ZCoeff.v +++ /dev/null @@ -1,174 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* R -> R. -Variable ropp : R -> R. -Variables req rle rlt : R -> R -> Prop. - -Variable sor : SOR rO rI rplus rtimes rminus ropp req rle rlt. - -Notation "0" := rO. -Notation "1" := rI. -Notation "x + y" := (rplus x y). -Notation "x * y " := (rtimes x y). -Notation "x - y " := (rminus x y). -Notation "- x" := (ropp x). -Notation "x == y" := (req x y). -Notation "x ~= y" := (~ req x y). -Notation "x <= y" := (rle x y). -Notation "x < y" := (rlt x y). - -Lemma req_refl : forall x, req x x. -Proof. - destruct (SORsetoid sor) as (Equivalence_Reflexive,_,_). - apply Equivalence_Reflexive. -Qed. - -Lemma req_sym : forall x y, req x y -> req y x. -Proof. - destruct (SORsetoid sor) as (_,Equivalence_Symmetric,_). - apply Equivalence_Symmetric. -Qed. - -Lemma req_trans : forall x y z, req x y -> req y z -> req x z. -Proof. - destruct (SORsetoid sor) as (_,_,Equivalence_Transitive). - apply Equivalence_Transitive. -Qed. - - -Add Relation R req - reflexivity proved by (@Equivalence_Reflexive _ _ (SORsetoid sor)) - symmetry proved by (@Equivalence_Symmetric _ _ (SORsetoid sor)) - transitivity proved by (@Equivalence_Transitive _ _ (SORsetoid sor)) -as sor_setoid. - -Add Morphism rplus with signature req ==> req ==> req as rplus_morph. -Proof. -exact (SORplus_wd sor). -Qed. -Add Morphism rtimes with signature req ==> req ==> req as rtimes_morph. -Proof. -exact (SORtimes_wd sor). -Qed. -Add Morphism ropp with signature req ==> req as ropp_morph. -Proof. -exact (SORopp_wd sor). -Qed. -Add Morphism rle with signature req ==> req ==> iff as rle_morph. -Proof. -exact (SORle_wd sor). -Qed. -Add Morphism rlt with signature req ==> req ==> iff as rlt_morph. -Proof. -exact (SORlt_wd sor). -Qed. -Add Morphism rminus with signature req ==> req ==> req as rminus_morph. -Proof. - exact (rminus_morph sor). -Qed. - -Ltac le_less := rewrite (Rle_lt_eq sor); left; try assumption. -Ltac le_equal := rewrite (Rle_lt_eq sor); right; try reflexivity; try assumption. - -Definition gen_order_phi_Z : Z -> R := gen_phiZ 0 1 rplus rtimes ropp. -Declare Equivalent Keys gen_order_phi_Z gen_phiZ. - -Notation phi_pos := (gen_phiPOS 1 rplus rtimes). -Notation phi_pos1 := (gen_phiPOS1 1 rplus rtimes). - -Notation "[ x ]" := (gen_order_phi_Z x). - -Lemma ring_ops_wd : ring_eq_ext rplus rtimes ropp req. -Proof. -constructor. -- exact rplus_morph. -- exact rtimes_morph. -- exact ropp_morph. -Qed. - -Lemma Zring_morph : - ring_morph 0 1 rplus rtimes rminus ropp req - 0%Z 1%Z Z.add Z.mul Z.sub Z.opp - Z.eqb gen_order_phi_Z. -Proof. -exact (gen_phiZ_morph (SORsetoid sor) ring_ops_wd (SORrt sor)). -Qed. - -Lemma phi_pos1_pos : forall x : positive, 0 < phi_pos1 x. -Proof. -intros x; induction x as [x IH | x IH |]; simpl; -try apply (Rplus_pos_pos sor); try apply (Rtimes_pos_pos sor); try apply (Rplus_pos_pos sor); -try apply (Rlt_0_1 sor); assumption. -Qed. - -Lemma phi_pos1_succ : forall x : positive, phi_pos1 (Pos.succ x) == 1 + phi_pos1 x. -Proof. -exact (ARgen_phiPOS_Psucc (SORsetoid sor) ring_ops_wd - (Rth_ARth (SORsetoid sor) ring_ops_wd (SORrt sor))). -Qed. - -Lemma clt_pos_morph : forall x y : positive, (x < y)%positive -> phi_pos1 x < phi_pos1 y. -Proof. -intros x y H. pattern y; apply Pos.lt_ind with x. -- rewrite phi_pos1_succ; apply (Rlt_succ_r sor). -- clear y H; intros y _ H. rewrite phi_pos1_succ. now apply (Rlt_lt_succ sor). -- assumption. -Qed. - -Lemma clt_morph : forall x y : Z, (x < y)%Z -> [x] < [y]. -Proof. -intros x y H. -do 2 rewrite (same_genZ (SORsetoid sor) ring_ops_wd (SORrt sor)); -destruct x; destruct y; simpl in *; try discriminate. -- apply phi_pos1_pos. -- now apply clt_pos_morph. -- apply <- (Ropp_neg_pos sor); apply phi_pos1_pos. -- apply (Rlt_trans sor) with 0. - + apply <- (Ropp_neg_pos sor); apply phi_pos1_pos. - + apply phi_pos1_pos. -- apply -> (Ropp_lt_mono sor); apply clt_pos_morph. - red. now rewrite Pos.compare_antisym. -Qed. - -Lemma Zcleb_morph : forall x y : Z, Z.leb x y = true -> [x] <= [y]. -Proof. -unfold Z.leb; intros x y H. -case_eq (x ?= y)%Z; intro H1; rewrite H1 in H. -- le_equal. apply (morph_eq Zring_morph). apply Z.eqb_eq; auto using Z.compare_eq. -- le_less. now apply clt_morph. -- discriminate. -Qed. - -Lemma Zcneqb_morph : forall x y : Z, Z.eqb x y = false -> [x] ~= [y]. -Proof. -intros x y []%Z.eqb_neq%Z.lt_gt_cases. -- apply (Rlt_neq sor). now apply clt_morph. -- apply (Rneq_symm sor). apply (Rlt_neq sor). now apply clt_morph. -Qed. - -End InitialMorphism. diff --git a/stdlib/theories/micromega/ZMicromega.v b/stdlib/theories/micromega/ZMicromega.v deleted file mode 100644 index 6b4b60a68f1c..000000000000 --- a/stdlib/theories/micromega/ZMicromega.v +++ /dev/null @@ -1,1811 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* destruct (andb_prop _ _ id); clear id - | [ id : (_ || _)%bool = true |- _ ] => destruct (orb_prop _ _ id); clear id - end. - -Ltac inv H := inversion H ; try subst ; clear H. - -Lemma eq_le_iff : forall x, 0 = x <-> (0 <= x /\ x <= 0). -Proof. - intros. - split ; intros H. - - subst. - split; reflexivity. - - destruct H. - apply Z.le_antisymm; auto. -Qed. - -Lemma lt_le_iff x : 0 < x <-> 0 <= x - 1. -Proof. rewrite <-Z.lt_succ_r, Z.sub_1_r, Z.succ_pred; reflexivity. Qed. - -Lemma le_0_iff x y : x <= y <-> 0 <= y - x. -Proof. symmetry. apply Z.le_0_sub. Qed. - -Lemma le_neg x : ((0 <= x) -> False) <-> 0 < -x. -Proof. setoid_rewrite Z.nle_gt. rewrite Z.opp_pos_neg. reflexivity. Qed. - -Lemma eq_cnf x : (0 <= x - 1 -> False) /\ (0 <= -1 - x -> False) <-> x = 0. -Proof. - rewrite (Z.sub_opp_l 1). - setoid_rewrite <-lt_le_iff. - rewrite Z.opp_pos_neg. - setoid_rewrite Z.nlt_ge. - split; intros. - { apply Z.le_antisymm; try apply H. } - { subst x. split; reflexivity. } -Qed. - - - - -Require Import EnvRing. - -Lemma Zsor : SOR 0 1 Z.add Z.mul Z.sub Z.opp (@eq Z) Z.le Z.lt. -Proof. - constructor ; intros ; subst; try reflexivity. - - apply InitialRing.Zsth. - - apply InitialRing.Zth. - - auto using Z.le_antisymm. - - eauto using Z.le_trans. - - apply Z.le_neq. - - apply Z.lt_trichotomy. - - apply Z.add_le_mono_l; assumption. - - apply Z.mul_pos_pos ; auto. - - discriminate. -Qed. - -Lemma ZSORaddon : - SORaddon 0 1 Z.add Z.mul Z.sub Z.opp (@eq Z) Z.le (* ring elements *) - 0%Z 1%Z Z.add Z.mul Z.sub Z.opp (* coefficients *) - Z.eqb Z.leb - (fun x => x) (fun x => x) (pow_N 1 Z.mul). -Proof. - constructor. - - constructor ; intros ; try reflexivity. - apply Z.eqb_eq ; auto. - - constructor. - reflexivity. - - intros x y. - rewrite <-Z.eqb_eq. congruence. - - apply Z.leb_le. -Qed. - -Fixpoint Zeval_expr (env : PolEnv Z) (e: PExpr Z) : Z := - match e with - | PEc c => c - | PEX x => env x - | PEadd e1 e2 => Zeval_expr env e1 + Zeval_expr env e2 - | PEmul e1 e2 => Zeval_expr env e1 * Zeval_expr env e2 - | PEpow e1 n => Z.pow (Zeval_expr env e1) (Z.of_N n) - | PEsub e1 e2 => (Zeval_expr env e1) - (Zeval_expr env e2) - | PEopp e => Z.opp (Zeval_expr env e) - end. - -Strategy expand [ Zeval_expr ]. - -Definition eval_expr := eval_pexpr Z.add Z.mul Z.sub Z.opp (fun x => x) (fun x => x) (pow_N 1 Z.mul). - -Fixpoint Zeval_const (e: PExpr Z) : option Z := - match e with - | PEc c => Some c - | PEX x => None - | PEadd e1 e2 => map_option2 (fun x y => Some (x + y)) - (Zeval_const e1) (Zeval_const e2) - | PEmul e1 e2 => map_option2 (fun x y => Some (x * y)) - (Zeval_const e1) (Zeval_const e2) - | PEpow e1 n => map_option (fun x => Some (Z.pow x (Z.of_N n))) - (Zeval_const e1) - | PEsub e1 e2 => map_option2 (fun x y => Some (x - y)) - (Zeval_const e1) (Zeval_const e2) - | PEopp e => map_option (fun x => Some (Z.opp x)) (Zeval_const e) - end. - -Lemma ZNpower : forall r n, r ^ Z.of_N n = pow_N 1 Z.mul r n. -Proof. - intros r n; destruct n as [|p]. - - reflexivity. - - simpl. - unfold Z.pow_pos. - rewrite <-Z.mul_1_l. - generalize 1. - induction p as [p IHp|p IHp|]; simpl; intros ; - rewrite ?IHp, ?Z.mul_assoc; auto using Z.mul_comm, f_equal2. -Qed. - -Lemma Zeval_expr_compat : forall env e, Zeval_expr env e = eval_expr env e. -Proof. - intros env e; induction e ; simpl ; try congruence. - - reflexivity. - - rewrite ZNpower. congruence. -Qed. - -Definition Zeval_pop2 (o : Op2) : Z -> Z -> Prop := -match o with -| OpEq => @eq Z -| OpNEq => fun x y => ~ x = y -| OpLe => Z.le -| OpGe => Z.ge -| OpLt => Z.lt -| OpGt => Z.gt -end. - - -Definition Zeval_bop2 (o : Op2) : Z -> Z -> bool := -match o with -| OpEq => Z.eqb -| OpNEq => fun x y => negb (Z.eqb x y) -| OpLe => Z.leb -| OpGe => Z.geb -| OpLt => Z.ltb -| OpGt => Z.gtb -end. - -Lemma pop2_bop2 : - forall (op : Op2) (q1 q2 : Z), is_true (Zeval_bop2 op q1 q2) <-> Zeval_pop2 op q1 q2. -Proof. - unfold is_true. - intro op; destruct op ; simpl; intros q1 q2. - - apply Z.eqb_eq. - - rewrite <- Z.eqb_eq. - rewrite negb_true_iff. - destruct (q1 =? q2) ; intuition congruence. - - apply Z.leb_le. - - rewrite Z.geb_le. rewrite Z.ge_le_iff. tauto. - - apply Z.ltb_lt. - - rewrite <- Z.gtb_gt; tauto. -Qed. - -Definition Zeval_op2 (k: Tauto.kind) : Op2 -> Z -> Z -> Tauto.rtyp k:= - if k as k0 return (Op2 -> Z -> Z -> Tauto.rtyp k0) - then Zeval_pop2 else Zeval_bop2. - - -Lemma Zeval_op2_hold : forall k op q1 q2, - Tauto.hold k (Zeval_op2 k op q1 q2) <-> Zeval_pop2 op q1 q2. -Proof. - intro k; destruct k. - - simpl ; tauto. - - simpl. apply pop2_bop2. -Qed. - - -Definition Zeval_formula (env : PolEnv Z) (k: Tauto.kind) (f : Formula Z):= - let (lhs, op, rhs) := f in - (Zeval_op2 k op) (Zeval_expr env lhs) (Zeval_expr env rhs). - -Definition Zeval_formula' := - eval_formula Z.add Z.mul Z.sub Z.opp (@eq Z) Z.le Z.lt (fun x => x) (fun x => x) (pow_N 1 Z.mul). - -Lemma Zeval_formula_compat : forall env k f, Tauto.hold k (Zeval_formula env k f) <-> Zeval_formula env Tauto.isProp f. -Proof. - intros env k; destruct k ; simpl. - - tauto. - - intros f; destruct f ; simpl. - rewrite <- (Zeval_op2_hold Tauto.isBool). - simpl. tauto. -Qed. - -Lemma Zeval_formula_compat' : forall env f, Zeval_formula env Tauto.isProp f <-> Zeval_formula' env f. -Proof. - intros env f. - unfold Zeval_formula. - destruct f as [Flhs Fop Frhs]. - repeat rewrite Zeval_expr_compat. - unfold Zeval_formula' ; simpl. - unfold eval_expr. - generalize (eval_pexpr Z.add Z.mul Z.sub Z.opp (fun x : Z => x) - (fun x : N => x) (pow_N 1 Z.mul) env Flhs). - generalize ((eval_pexpr Z.add Z.mul Z.sub Z.opp (fun x : Z => x) - (fun x : N => x) (pow_N 1 Z.mul) env Frhs)). - destruct Fop ; simpl; intros; - intuition auto using Z.le_ge, Z.ge_le, Z.lt_gt, Z.gt_lt. -Qed. - - -Definition eval_nformula := - eval_nformula 0 Z.add Z.mul (@eq Z) Z.le Z.lt (fun x => x) . - -Definition Zeval_op1 (o : Op1) : Z -> Prop := -match o with -| Equal => fun x : Z => x = 0 -| NonEqual => fun x : Z => x <> 0 -| Strict => fun x : Z => 0 < x -| NonStrict => fun x : Z => 0 <= x -end. - - -Lemma Zeval_nformula_dec : forall env d, (eval_nformula env d) \/ ~ (eval_nformula env d). -Proof. - intros. - apply (eval_nformula_dec Zsor). -Qed. - -Definition ZWitness := Psatz Z. - -Definition ZWeakChecker := check_normalised_formulas 0 1 Z.add Z.mul Z.eqb Z.leb. - -Lemma ZWeakChecker_sound : forall (l : list (NFormula Z)) (cm : ZWitness), - ZWeakChecker l cm = true -> - forall env, make_impl (eval_nformula env) l False. -Proof. - intros l cm H. - intro. - unfold eval_nformula. - apply (checker_nf_sound Zsor ZSORaddon l cm). - unfold ZWeakChecker in H. - exact H. -Qed. - -Definition psub := psub Z0 Z.add Z.sub Z.opp Z.eqb. -Declare Equivalent Keys psub RingMicromega.psub. - -Definition popp := popp Z.opp. -Declare Equivalent Keys popp RingMicromega.popp. - -Definition padd := padd Z0 Z.add Z.eqb. -Declare Equivalent Keys padd RingMicromega.padd. - -Definition pmul := pmul 0 1 Z.add Z.mul Z.eqb. - -Definition normZ := norm 0 1 Z.add Z.mul Z.sub Z.opp Z.eqb. -Declare Equivalent Keys normZ RingMicromega.norm. - -Definition eval_pol := eval_pol Z.add Z.mul (fun x => x). -Declare Equivalent Keys eval_pol RingMicromega.eval_pol. - -Lemma eval_pol_sub : forall env lhs rhs, eval_pol env (psub lhs rhs) = eval_pol env lhs - eval_pol env rhs. -Proof. - intros. - apply (eval_pol_sub Zsor ZSORaddon). -Qed. - -Lemma eval_pol_add : forall env lhs rhs, eval_pol env (padd lhs rhs) = eval_pol env lhs + eval_pol env rhs. -Proof. - intros. - apply (eval_pol_add Zsor ZSORaddon). -Qed. - -Lemma eval_pol_mul : forall env lhs rhs, eval_pol env (pmul lhs rhs) = eval_pol env lhs * eval_pol env rhs. -Proof. - intros. - apply (eval_pol_mul Zsor ZSORaddon). -Qed. - - -Lemma eval_pol_norm : forall env e, eval_expr env e = eval_pol env (normZ e) . -Proof. - intros. - apply (eval_pol_norm Zsor ZSORaddon). -Qed. - -Definition Zunsat := check_inconsistent 0 Z.eqb Z.leb. - -Definition Zdeduce := nformula_plus_nformula 0 Z.add Z.eqb. - -Lemma Zunsat_sound : forall f, - Zunsat f = true -> forall env, eval_nformula env f -> False. -Proof. - unfold Zunsat. - intros f H env ?. - destruct f. - eapply check_inconsistent_sound with (1 := Zsor) (2 := ZSORaddon) in H; eauto. -Qed. - -Definition xnnormalise (t : Formula Z) : NFormula Z := - let (lhs,o,rhs) := t in - let lhs := normZ lhs in - let rhs := normZ rhs in - match o with - | OpEq => (psub rhs lhs, Equal) - | OpNEq => (psub rhs lhs, NonEqual) - | OpGt => (psub lhs rhs, Strict) - | OpLt => (psub rhs lhs, Strict) - | OpGe => (psub lhs rhs, NonStrict) - | OpLe => (psub rhs lhs, NonStrict) - end. - -Lemma xnnormalise_correct : - forall env f, - eval_nformula env (xnnormalise f) <-> Zeval_formula env Tauto.isProp f. -Proof. - intros env f. - rewrite Zeval_formula_compat'. - unfold xnnormalise. - destruct f as [lhs o rhs]. - destruct o eqn:O ; cbn ; rewrite ?eval_pol_sub; - rewrite <- !eval_pol_norm ; simpl in *; - unfold eval_expr; - generalize ( eval_pexpr Z.add Z.mul Z.sub Z.opp (fun x : Z => x) - (fun x : N => x) (pow_N 1 Z.mul) env lhs); - generalize (eval_pexpr Z.add Z.mul Z.sub Z.opp (fun x : Z => x) - (fun x : N => x) (pow_N 1 Z.mul) env rhs); intros z z0. - - split ; intros. - + assert (z0 + (z - z0) = z0 + 0) as H0 by congruence. - rewrite Z.add_0_r in H0. - rewrite <- H0. - rewrite Z.add_sub_assoc, Z.add_comm, <-Z.add_sub_assoc, Z.sub_diag; apply Z.add_0_r. - + subst. - apply Z.sub_diag. - - split ; intros H H0. - + subst. apply H. apply Z.sub_diag. - + apply H. - assert (z0 + (z - z0) = z0 + 0) as H1 by congruence. - rewrite Z.add_0_r in H1. - rewrite <- H1. - rewrite Z.add_sub_assoc, Z.add_comm, <-Z.add_sub_assoc, Z.sub_diag; apply Z.add_0_r. - - symmetry. apply le_0_iff. - - symmetry. apply le_0_iff. - - apply Z.lt_0_sub. - - apply Z.lt_0_sub. -Qed. - -Definition xnormalise (f: NFormula Z) : list (NFormula Z) := - let (e,o) := f in - match o with - | Equal => (psub e (Pc 1),NonStrict) :: (psub (Pc (-1)) e, NonStrict) :: nil - | NonStrict => ((psub (Pc (-1)) e,NonStrict)::nil) - | Strict => ((psub (Pc 0)) e, NonStrict)::nil - | NonEqual => (e, Equal)::nil - end. - -Lemma eval_pol_Pc : forall env z, - eval_pol env (Pc z) = z. -Proof. - reflexivity. -Qed. - -Lemma xnormalise_correct : forall env f, - (make_conj (fun x => eval_nformula env x -> False) (xnormalise f)) <-> eval_nformula env f. -Proof. - intros env f. - destruct f as [e o]; destruct o eqn:Op; cbn - [psub]; - repeat rewrite eval_pol_sub; fold eval_pol; repeat rewrite eval_pol_Pc; - generalize (eval_pol env e) as x; intro. - - apply eq_cnf. - - unfold not. tauto. - - rewrite le_neg. rewrite (Z.sub_0_l x), Z.opp_involutive; reflexivity. - - rewrite le_neg, lt_le_iff. - rewrite Z.sub_opp_l, Z.sub_sub_distr. reflexivity. -Qed. - - - -Require Import Stdlib.micromega.Tauto BinNums. - -Definition cnf_of_list {T: Type} (tg : T) (l : list (NFormula Z)) := - List.fold_right (fun x acc => - if Zunsat x then acc else ((x,tg)::nil)::acc) - (cnf_tt _ _) l. - -Lemma cnf_of_list_correct : - forall {T : Type} (tg:T) (f : list (NFormula Z)) env, - eval_cnf eval_nformula env (cnf_of_list tg f) <-> - make_conj (fun x : NFormula Z => eval_nformula env x -> False) f. -Proof. - unfold cnf_of_list. - intros T tg f env. - set (F := (fun (x : NFormula Z) (acc : list (list (NFormula Z * T))) => - if Zunsat x then acc else ((x, tg) :: nil) :: acc)). - set (E := ((fun x : NFormula Z => eval_nformula env x -> False))). - induction f as [|a f IHf]. - - compute. - tauto. - - rewrite make_conj_cons. - simpl. - unfold F at 1. - destruct (Zunsat a) eqn:EQ. - + rewrite IHf. - unfold E at 1. - specialize (Zunsat_sound _ EQ env). - tauto. - + - rewrite <- eval_cnf_cons_iff. - rewrite IHf. - simpl. - unfold E at 2. - unfold eval_tt. simpl. - tauto. -Qed. - -Definition normalise {T : Type} (t:Formula Z) (tg:T) : cnf (NFormula Z) T := - let f := xnnormalise t in - if Zunsat f then cnf_ff _ _ - else cnf_of_list tg (xnormalise f). - -Lemma normalise_correct : forall (T: Type) env t (tg:T), eval_cnf eval_nformula env (normalise t tg) <-> Zeval_formula env Tauto.isProp t. -Proof. - intros T env t tg. - rewrite <- xnnormalise_correct. - unfold normalise. - generalize (xnnormalise t) as f;intro f. - destruct (Zunsat f) eqn:U. - - assert (US := Zunsat_sound _ U env). - rewrite eval_cnf_ff. - tauto. - - rewrite cnf_of_list_correct. - apply xnormalise_correct. -Qed. - - -Definition xnegate (f:NFormula Z) : list (NFormula Z) := - let (e,o) := f in - match o with - | Equal => (e,Equal) :: nil - | NonEqual => (psub e (Pc 1),NonStrict) :: (psub (Pc (-1)) e, NonStrict) :: nil - | NonStrict => (e,NonStrict)::nil - | Strict => (psub e (Pc 1),NonStrict)::nil - end. - -Definition negate {T : Type} (t:Formula Z) (tg:T) : cnf (NFormula Z) T := - let f := xnnormalise t in - if Zunsat f then cnf_tt _ _ - else cnf_of_list tg (xnegate f). - -Lemma xnegate_correct : forall env f, - (make_conj (fun x => eval_nformula env x -> False) (xnegate f)) <-> ~ eval_nformula env f. -Proof. - intros env f. - destruct f as [e o]; destruct o eqn:Op; cbn - [psub]; - repeat rewrite eval_pol_sub; fold eval_pol; repeat rewrite eval_pol_Pc; - generalize (eval_pol env e) as x; intro x. - - tauto. - - rewrite eq_cnf. - destruct (Z.eq_decidable x 0);tauto. - - rewrite lt_le_iff. - tauto. - - tauto. -Qed. - -Lemma negate_correct : forall T env t (tg:T), eval_cnf eval_nformula env (negate t tg) <-> ~ Zeval_formula env Tauto.isProp t. -Proof. - intros T env t tg. - rewrite <- xnnormalise_correct. - unfold negate. - generalize (xnnormalise t) as f;intro f. - destruct (Zunsat f) eqn:U. - - assert (US := Zunsat_sound _ U env). - rewrite eval_cnf_tt. - tauto. - - rewrite cnf_of_list_correct. - apply xnegate_correct. -Qed. - -Definition cnfZ (Annot: Type) (TX : Tauto.kind -> Type) (AF : Type) (k: Tauto.kind) (f : TFormula (Formula Z) Annot TX AF k) := - rxcnf Zunsat Zdeduce normalise negate true f. - -Definition ZweakTautoChecker (w: list ZWitness) (f : BFormula (Formula Z) Tauto.isProp) : bool := - @tauto_checker (Formula Z) (NFormula Z) unit Zunsat Zdeduce normalise negate ZWitness (fun cl => ZWeakChecker (List.map fst cl)) f w. - -(* To get a complete checker, the proof format has to be enriched *) - -Require Import Zdiv. -Local Open Scope Z_scope. - -Definition ceiling (a b:Z) : Z := - let (q,r) := Z.div_eucl a b in - match r with - | Z0 => q - | _ => q + 1 - end. - - -Require Import Znumtheory. - -Lemma Zdivide_ceiling : forall a b, (b | a) -> ceiling a b = Z.div a b. -Proof. - unfold ceiling. - intros a b H. - apply Zdivide_mod in H. - case_eq (Z.div_eucl a b). - intros z z0 H0. - change z with (fst (z,z0)). - rewrite <- H0. - change (fst (Z.div_eucl a b)) with (Z.div a b). - change z0 with (snd (z,z0)). - rewrite <- H0. - change (snd (Z.div_eucl a b)) with (Z.modulo a b). - rewrite H. - reflexivity. -Qed. - -Lemma narrow_interval_lower_bound a b x : - a > 0 -> a * x >= b -> x >= ceiling b a. -Proof. - rewrite !Z.ge_le_iff. - unfold ceiling. - intros Ha H. - generalize (Z_div_mod b a Ha). - destruct (Z.div_eucl b a) as (q,r). intros (->,(H1,H2)). - destruct r as [|r|r]. - - rewrite Z.add_0_r in H. - apply Z.mul_le_mono_pos_l in H; auto with zarith. - - assert (0 < Z.pos r) by easy. - rewrite Z.add_1_r, Z.le_succ_l. - apply Z.mul_lt_mono_pos_l with a. - + auto using Z.gt_lt. - + eapply Z.lt_le_trans. 2: eassumption. - now apply Z.lt_add_pos_r. - - now elim H1. -Qed. - -(** NB: narrow_interval_upper_bound is Zdiv.Zdiv_le_lower_bound *) - -Require Import QArith. - -Inductive ZArithProof := -| DoneProof -| RatProof : ZWitness -> ZArithProof -> ZArithProof -| CutProof : ZWitness -> ZArithProof -> ZArithProof -| SplitProof : PolC Z -> ZArithProof -> ZArithProof -> ZArithProof -| EnumProof : ZWitness -> ZWitness -> list ZArithProof -> ZArithProof -| ExProof : positive -> ZArithProof -> ZArithProof -(*ExProof x : exists z t, x = z - t /\ z >= 0 /\ t >= 0 *) -. - - -Register ZArithProof as micromega.ZArithProof.type. -Register DoneProof as micromega.ZArithProof.DoneProof. -Register RatProof as micromega.ZArithProof.RatProof. -Register CutProof as micromega.ZArithProof.CutProof. -Register SplitProof as micromega.ZArithProof.SplitProof. -Register EnumProof as micromega.ZArithProof.EnumProof. -Register ExProof as micromega.ZArithProof.ExProof. - - - -(* In order to compute the 'cut', we need to express a polynomial P as a * Q + b. - - b is the constant - - a is the gcd of the other coefficient. -*) -Require Import Znumtheory. - -Definition isZ0 (x:Z) := - match x with - | Z0 => true - | _ => false - end. - -Lemma isZ0_0 : forall x, isZ0 x = true <-> x = 0. -Proof. - intros x; destruct x ; simpl ; intuition congruence. -Qed. - -Lemma isZ0_n0 : forall x, isZ0 x = false <-> x <> 0. -Proof. - intros x; destruct x ; simpl ; intuition congruence. -Qed. - -Definition ZgcdM (x y : Z) := Z.max (Z.gcd x y) 1. - - -Fixpoint Zgcd_pol (p : PolC Z) : (Z * Z) := - match p with - | Pc c => (0,c) - | Pinj _ p => Zgcd_pol p - | PX p _ q => - let (g1,c1) := Zgcd_pol p in - let (g2,c2) := Zgcd_pol q in - (ZgcdM (ZgcdM g1 c1) g2 , c2) - end. - -(*Eval compute in (Zgcd_pol ((PX (Pc (-2)) 1 (Pc 4)))).*) - - -Fixpoint Zdiv_pol (p:PolC Z) (x:Z) : PolC Z := - match p with - | Pc c => Pc (Z.div c x) - | Pinj j p => Pinj j (Zdiv_pol p x) - | PX p j q => PX (Zdiv_pol p x) j (Zdiv_pol q x) - end. - -Inductive Zdivide_pol (x:Z): PolC Z -> Prop := -| Zdiv_Pc : forall c, (x | c) -> Zdivide_pol x (Pc c) -| Zdiv_Pinj : forall p, Zdivide_pol x p -> forall j, Zdivide_pol x (Pinj j p) -| Zdiv_PX : forall p q, Zdivide_pol x p -> Zdivide_pol x q -> forall j, Zdivide_pol x (PX p j q). - - -Lemma Zdiv_pol_correct : forall a p, 0 < a -> Zdivide_pol a p -> - forall env, eval_pol env p = a * eval_pol env (Zdiv_pol p a). -Proof. - intros a p H H0. - induction H0 as [? ?|? ? IHZdivide_pol j|? ? ? IHZdivide_pol1 ? IHZdivide_pol2 j]. - - (* Pc *) - simpl. - intros. - apply Zdivide_Zdiv_eq ; auto. - - (* Pinj *) - simpl. - intros. - apply IHZdivide_pol. - - (* PX *) - simpl. - intros. - rewrite IHZdivide_pol1. - rewrite IHZdivide_pol2. - ring. -Qed. - -Lemma Zgcd_pol_ge : forall p, fst (Zgcd_pol p) >= 0. -Proof. - intros p; induction p as [c|p p1 IHp1|p1 IHp1 ? p3 IHp3]. 1-2: easy. - simpl. - case_eq (Zgcd_pol p1). - case_eq (Zgcd_pol p3). - intros. - simpl. - unfold ZgcdM. - apply Z.le_ge; transitivity 1. - - easy. - - apply Z.le_max_r. -Qed. - -Lemma Zdivide_pol_Zdivide : forall p x y, Zdivide_pol x p -> (y | x) -> Zdivide_pol y p. -Proof. - intros p x y H H0. - induction H. - - constructor. - apply Z.divide_trans with (1:= H0) ; assumption. - - constructor. auto. - - constructor ; auto. -Qed. - -Lemma Zdivide_pol_one : forall p, Zdivide_pol 1 p. -Proof. - intros p; induction p as [c| |]; constructor ; auto. - exists c. ring. -Qed. - -Lemma Zgcd_minus : forall a b c, (a | c - b ) -> (Z.gcd a b | c). -Proof. - intros a b c (q,Hq). - destruct (Zgcd_is_gcd a b) as [(a',Ha) (b',Hb) _]. - set (g:=Z.gcd a b) in *; clearbody g. - exists (q * a' + b'). - symmetry in Hq. rewrite <- Z.add_move_r in Hq. - rewrite <- Hq, Hb, Ha. ring. -Qed. - -Lemma Zdivide_pol_sub : forall p a b, - 0 < Z.gcd a b -> - Zdivide_pol a (PsubC Z.sub p b) -> - Zdivide_pol (Z.gcd a b) p. -Proof. - intros p; induction p as [c|? p IHp|p ? ? ? IHp2]. - - simpl. - intros a b H H0. inversion H0. - constructor. - apply Zgcd_minus ; auto. - - intros ? ? H H0. - constructor. - simpl in H0. inversion H0 ; subst; clear H0. - apply IHp ; auto. - - simpl. intros a b H H0. - inv H0. - constructor. - + apply Zdivide_pol_Zdivide with (1:= (ltac:(assumption) : Zdivide_pol a p)). - destruct (Zgcd_is_gcd a b) ; assumption. - + apply IHp2 ; assumption. -Qed. - -Lemma Zdivide_pol_sub_0 : forall p a, - Zdivide_pol a (PsubC Z.sub p 0) -> - Zdivide_pol a p. -Proof. - intros p; induction p as [c|? p IHp|? IHp1 ? ? IHp2]. - - simpl. - intros ? H. inversion H. - constructor. rewrite Z.sub_0_r in *. assumption. - - intros ? H. - constructor. - simpl in H. inversion H ; subst; clear H. - apply IHp ; auto. - - simpl. intros ? H. - inv H. - constructor. - + auto. - + apply IHp2 ; assumption. -Qed. - - -Lemma Zgcd_pol_div : forall p g c, - Zgcd_pol p = (g, c) -> Zdivide_pol g (PsubC Z.sub p c). -Proof. - intros p; induction p as [c|? ? IHp|p1 IHp1 ? p3 IHp2]; simpl. - - (* Pc *) - intros ? ? H. inv H. - constructor. - exists 0. now ring. - - (* Pinj *) - intros. - constructor. apply IHp ; auto. - - (* PX *) - intros g c. - case_eq (Zgcd_pol p1) ; case_eq (Zgcd_pol p3) ; intros z z0 H z1 z2 H0 H1. - inv H1. - unfold ZgcdM at 1. - destruct (Z.max_spec (Z.gcd (ZgcdM z1 z2) z) 1) as [HH1 | HH1]; cycle 1; - destruct HH1 as [HH1 HH1'] ; rewrite HH1'. - + constructor. - * apply (Zdivide_pol_Zdivide _ (ZgcdM z1 z2)). - -- unfold ZgcdM. - destruct (Z.max_spec (Z.gcd z1 z2) 1) as [HH2 | HH2]; cycle 1. - ++ destruct HH2 as [H1 H2]. - rewrite H2. - apply Zdivide_pol_sub ; auto. - apply Z.lt_le_trans with 1. - ** reflexivity. - ** trivial. - ++ destruct HH2 as [H1 H2]. rewrite H2. - apply Zdivide_pol_one. - -- unfold ZgcdM in HH1. unfold ZgcdM. - destruct (Z.max_spec (Z.gcd z1 z2) 1) as [HH2 | HH2]; cycle 1. - ++ destruct HH2 as [H1 H2]. rewrite H2 in *. - destruct (Zgcd_is_gcd (Z.gcd z1 z2) z); auto. - ++ destruct HH2 as [H1 H2]. rewrite H2. - destruct (Zgcd_is_gcd 1 z); auto. - * apply (Zdivide_pol_Zdivide _ z). - -- apply (IHp2 _ _ H); auto. - -- destruct (Zgcd_is_gcd (ZgcdM z1 z2) z); auto. - + constructor. - * apply Zdivide_pol_one. - * apply Zdivide_pol_one. -Qed. - - - - -Lemma Zgcd_pol_correct_lt : forall p env g c, Zgcd_pol p = (g,c) -> 0 < g -> eval_pol env p = g * (eval_pol env (Zdiv_pol (PsubC Z.sub p c) g)) + c. -Proof. - intros. - rewrite <- Zdiv_pol_correct ; auto. - - rewrite (RingMicromega.PsubC_ok Zsor ZSORaddon). - unfold eval_pol. ring. - (**) - - apply Zgcd_pol_div ; auto. -Qed. - - - -Definition makeCuttingPlane (p : PolC Z) : PolC Z * Z := - let (g,c) := Zgcd_pol p in - if Z.gtb g Z0 - then (Zdiv_pol (PsubC Z.sub p c) g , Z.opp (ceiling (Z.opp c) g)) - else (p,Z0). - - -Definition genCuttingPlane (f : NFormula Z) : option (PolC Z * Z * Op1) := - let (e,op) := f in - match op with - | Equal => let (g,c) := Zgcd_pol e in - if andb (Z.gtb g Z0) (andb (negb (Z.eqb c Z0)) (negb (Z.eqb (Z.gcd g c) g))) - then None (* inconsistent *) - else (* Could be optimised Zgcd_pol is recomputed *) - let (p,c) := makeCuttingPlane e in - Some (p,c,Equal) - | NonEqual => Some (e,Z0,op) - | Strict => let (p,c) := makeCuttingPlane (PsubC Z.sub e 1) in - Some (p,c,NonStrict) - | NonStrict => let (p,c) := makeCuttingPlane e in - Some (p,c,NonStrict) - end. - -Definition nformula_of_cutting_plane (t : PolC Z * Z * Op1) : NFormula Z := - let (e_z, o) := t in - let (e,z) := e_z in - (padd e (Pc z) , o). - -Definition is_pol_Z0 (p : PolC Z) : bool := - match p with - | Pc Z0 => true - | _ => false - end. - -Lemma is_pol_Z0_eval_pol : forall p, is_pol_Z0 p = true -> forall env, eval_pol env p = 0. -Proof. - unfold is_pol_Z0. - intros p; destruct p as [z| |]; try discriminate. - destruct z ; try discriminate. - reflexivity. -Qed. - - -Definition eval_Psatz : list (NFormula Z) -> ZWitness -> option (NFormula Z) := - eval_Psatz 0 1 Z.add Z.mul Z.eqb Z.leb. - - -Definition valid_cut_sign (op:Op1) := - match op with - | Equal => true - | NonStrict => true - | _ => false - end. - - -Definition bound_var (v : positive) : Formula Z := - Build_Formula (PEX v) OpGe (PEc 0). - -Definition mk_eq_pos (x : positive) (y:positive) (t : positive) : Formula Z := - Build_Formula (PEX x) OpEq (PEsub (PEX y) (PEX t)). - - -Fixpoint vars (jmp : positive) (p : Pol Z) : list positive := - match p with - | Pc c => nil - | Pinj j p => vars (Pos.add j jmp) p - | PX p j q => jmp::(vars jmp p)++vars (Pos.succ jmp) q - end. - -Fixpoint max_var (jmp : positive) (p : Pol Z) : positive := - match p with - | Pc _ => jmp - | Pinj j p => max_var (Pos.add j jmp) p - | PX p j q => Pos.max (max_var jmp p) (max_var (Pos.succ jmp) q) - end. - -Lemma pos_le_add : forall y x, - (x <= y + x)%positive. -Proof. - intros y x. - assert ((Z.pos x) <= Z.pos (x + y))%Z as H. - - rewrite <- (Z.add_0_r (Zpos x)). - rewrite <- Pos2Z.add_pos_pos. - apply Z.add_le_mono_l. - compute. congruence. - - rewrite Pos.add_comm in H. - apply H. -Qed. - - -Lemma max_var_le : forall p v, - (v <= max_var v p)%positive. -Proof. - intros p; induction p as [?|p ? IHp|? IHp1 ? ? IHp2]; simpl. - - intros. - apply Pos.le_refl. - - intros v. - specialize (IHp (p+v)%positive). - eapply Pos.le_trans ; eauto. - assert (xH + v <= p + v)%positive. - { apply Pos.add_le_mono. - - apply Pos.le_1_l. - - apply Pos.le_refl. - } - eapply Pos.le_trans ; eauto. - apply pos_le_add. - - intros v. - apply Pos.max_case_strong;intros ; auto. - specialize (IHp2 (Pos.succ v)%positive). - eapply Pos.le_trans ; eauto. -Qed. - -Lemma max_var_correct : forall p j v, - In v (vars j p) -> Pos.le v (max_var j p). -Proof. - intros p; induction p; simpl. - - tauto. - - auto. - - intros j v H. - rewrite in_app_iff in H. - destruct H as [H |[ H | H]]. - + subst. - apply Pos.max_case_strong;intros ; auto. - * apply max_var_le. - * eapply Pos.le_trans ; eauto. - apply max_var_le. - + apply Pos.max_case_strong;intros ; auto. - eapply Pos.le_trans ; eauto. - + apply Pos.max_case_strong;intros ; auto. - eapply Pos.le_trans ; eauto. -Qed. - -Definition max_var_nformulae (l : list (NFormula Z)) := - List.fold_left (fun acc f => Pos.max acc (max_var xH (fst f))) l xH. - -Section MaxVar. - - Definition F (acc : positive) (f : Pol Z * Op1) := Pos.max acc (max_var 1 (fst f)). - - Lemma max_var_nformulae_mono_aux : - forall l v acc, - (v <= acc -> - v <= fold_left F l acc)%positive. - Proof. - intros l; induction l as [|a l IHl] ; simpl ; [easy|]. - intros. - apply IHl. - unfold F. - apply Pos.max_case_strong;intros ; auto. - eapply Pos.le_trans ; eauto. - Qed. - - Lemma max_var_nformulae_mono_aux' : - forall l acc acc', - (acc <= acc' -> - fold_left F l acc <= fold_left F l acc')%positive. - Proof. - intros l; induction l as [|a l IHl]; simpl ; [easy|]. - intros. - apply IHl. - unfold F. - apply Pos.max_le_compat_r; auto. - Qed. - - - - - Lemma max_var_nformulae_correct_aux : forall l p o v, - In (p,o) l -> In v (vars xH p) -> Pos.le v (fold_left F l 1)%positive. - Proof. - intros l p o v H H0. - generalize 1%positive as acc. - revert p o v H H0. - induction l as [|a l IHl]. - - simpl. tauto. - - simpl. - intros p o v H H0 ?. - destruct H ; subst. - + unfold F at 2. - simpl. - apply max_var_correct in H0. - apply max_var_nformulae_mono_aux. - apply Pos.max_case_strong;intros ; auto. - eapply Pos.le_trans ; eauto. - + eapply IHl ; eauto. - Qed. - -End MaxVar. - -Lemma max_var_nformalae_correct : forall l p o v, - In (p,o) l -> In v (vars xH p) -> Pos.le v (max_var_nformulae l)%positive. -Proof. - intros l p o v. - apply max_var_nformulae_correct_aux. -Qed. - - -Fixpoint max_var_psatz (w : Psatz Z) : positive := - match w with - | PsatzIn _ n => xH - | PsatzSquare p => max_var xH (Psquare 0 1 Z.add Z.mul Z.eqb p) - | PsatzMulC p w => Pos.max (max_var xH p) (max_var_psatz w) - | PsatzMulE w1 w2 => Pos.max (max_var_psatz w1) (max_var_psatz w2) - | PsatzAdd w1 w2 => Pos.max (max_var_psatz w1) (max_var_psatz w2) - | _ => xH - end. - -Fixpoint max_var_prf (w : ZArithProof) : positive := - match w with - | DoneProof => xH - | RatProof w pf | CutProof w pf => Pos.max (max_var_psatz w) (max_var_prf pf) - | SplitProof p pf1 pf2 => Pos.max (max_var xH p) (Pos.max (max_var_prf pf1) (max_var_prf pf1)) - | EnumProof w1 w2 l => List.fold_left - (fun acc prf => Pos.max acc (max_var_prf prf)) l - (Pos.max (max_var_psatz w1) (max_var_psatz w2)) - | ExProof _ pf => max_var_prf pf - end. - - -Fixpoint ZChecker (l:list (NFormula Z)) (pf : ZArithProof) {struct pf} : bool := - match pf with - | DoneProof => false - | RatProof w pf => - match eval_Psatz l w with - | None => false - | Some f => - if Zunsat f then true - else ZChecker (f::l) pf - end - | CutProof w pf => - match eval_Psatz l w with - | None => false - | Some f => - match genCuttingPlane f with - | None => true - | Some cp => ZChecker (nformula_of_cutting_plane cp::l) pf - end - end - | SplitProof p pf1 pf2 => - match genCuttingPlane (p,NonStrict) , genCuttingPlane (popp p, NonStrict) with - | None , _ | _ , None => false - | Some cp1 , Some cp2 => - ZChecker (nformula_of_cutting_plane cp1::l) pf1 - && - ZChecker (nformula_of_cutting_plane cp2::l) pf2 - end - | ExProof x prf => - let fr := max_var_nformulae l in - if Pos.leb x fr then - let z := Pos.succ fr in - let t := Pos.succ z in - let nfx := xnnormalise (mk_eq_pos x z t) in - let posz := xnnormalise (bound_var z) in - let post := xnnormalise (bound_var t) in - ZChecker (nfx::posz::post::l) prf - else false - | EnumProof w1 w2 pf => - match eval_Psatz l w1 , eval_Psatz l w2 with - | Some f1 , Some f2 => - match genCuttingPlane f1 , genCuttingPlane f2 with - |Some (e1,z1,op1) , Some (e2,z2,op2) => - if (valid_cut_sign op1 && valid_cut_sign op2 && is_pol_Z0 (padd e1 e2)) - then - (fix label (pfs:list ZArithProof) := - fun lb ub => - match pfs with - | nil => if Z.gtb lb ub then true else false - | pf::rsr => andb (ZChecker ((psub e1 (Pc lb), Equal) :: l) pf) (label rsr (Z.add lb 1%Z) ub) - end) pf (Z.opp z1) z2 - else false - | _ , _ => true - end - | _ , _ => false - end -end. - - - -Fixpoint bdepth (pf : ZArithProof) : nat := - match pf with - | DoneProof => O - | RatProof _ p => S (bdepth p) - | CutProof _ p => S (bdepth p) - | SplitProof _ p1 p2 => S (Nat.max (bdepth p1) (bdepth p2)) - | EnumProof _ _ l => S (List.fold_right (fun pf x => Nat.max (bdepth pf) x) O l) - | ExProof _ p => S (bdepth p) - end. - -Require Import PeanoNat Wf_nat. - -Lemma in_bdepth : forall l a b y, In y l -> ltof ZArithProof bdepth y (EnumProof a b l). -Proof. - intros l; induction l as [|a l IHl]. - - (* nil *) - simpl. - tauto. - - (* cons *) - simpl. - intros a0 b y H. - destruct H as [H|H]. - + subst. - unfold ltof. - simpl. - generalize ( (fold_right - (fun (pf : ZArithProof) (x : nat) => Nat.max (bdepth pf) x) 0%nat l)). - intros. - generalize (bdepth y) ; intros. - rewrite Nat.lt_succ_r. apply Nat.le_max_l. - + generalize (IHl a0 b y H). - unfold ltof. - simpl. - generalize ( (fold_right (fun (pf : ZArithProof) (x : nat) => Nat.max (bdepth pf) x) 0%nat - l)). - intros. - eapply Nat.lt_le_trans. - * eassumption. - * rewrite <- Nat.succ_le_mono. - apply Nat.le_max_r. -Qed. - -Lemma ltof_bdepth_split_l : - forall p pf1 pf2, - ltof ZArithProof bdepth pf1 (SplitProof p pf1 pf2). -Proof. - intros. - unfold ltof. simpl. - rewrite Nat.lt_succ_r. - apply Nat.le_max_l. -Qed. - -Lemma ltof_bdepth_split_r : - forall p pf1 pf2, - ltof ZArithProof bdepth pf2 (SplitProof p pf1 pf2). -Proof. - intros. - unfold ltof. simpl. - rewrite Nat.lt_succ_r. - apply Nat.le_max_r. -Qed. - - -Lemma eval_Psatz_sound : forall env w l f', - make_conj (eval_nformula env) l -> - eval_Psatz l w = Some f' -> eval_nformula env f'. -Proof. - intros env w l f' H H0. - apply (fun H => eval_Psatz_Sound Zsor ZSORaddon l _ H w) ; auto. - apply make_conj_in ; auto. -Qed. - -Lemma makeCuttingPlane_ns_sound : forall env e e' c, - eval_nformula env (e, NonStrict) -> - makeCuttingPlane e = (e',c) -> - eval_nformula env (nformula_of_cutting_plane (e', c, NonStrict)). -Proof. - unfold nformula_of_cutting_plane. - unfold eval_nformula. unfold RingMicromega.eval_nformula. - unfold eval_op1. - intros env e e' c H H0. - rewrite (RingMicromega.eval_pol_add Zsor ZSORaddon). - simpl. - (**) - unfold makeCuttingPlane in H0. - revert H0. - case_eq (Zgcd_pol e) ; intros g c0. - case Z.gtb_spec. - - intros H0 H1 H2. - inv H2. - change (RingMicromega.eval_pol Z.add Z.mul (fun x : Z => x)) with eval_pol in *. - apply (Zgcd_pol_correct_lt _ env) in H1. 2: auto using Z.gt_lt. - apply Z.le_add_le_sub_l, Z.ge_le; rewrite Z.add_0_r. - apply (narrow_interval_lower_bound g (- c0) (eval_pol env (Zdiv_pol (PsubC Z.sub e c0) g))); auto using Z.lt_gt. - apply Z.le_ge. - rewrite <- Z.sub_0_l. - apply Z.le_sub_le_add_r. - rewrite <- H1. - assumption. - (* g <= 0 *) - - intros H0 H1 H2. inv H2. auto with zarith. -Qed. - -Lemma cutting_plane_sound : forall env f p, - eval_nformula env f -> - genCuttingPlane f = Some p -> - eval_nformula env (nformula_of_cutting_plane p). -Proof. - unfold genCuttingPlane. - intros env f; destruct f as [e op]. - destruct op. - - (* Equal *) - intros p; destruct p as [[e' z] op]. - case_eq (Zgcd_pol e) ; intros g c. - case_eq (Z.gtb g 0 && (negb (Z.eqb c 0) && negb (Z.eqb (Z.gcd g c) g))) ; [discriminate|]. - case_eq (makeCuttingPlane e). - intros ? ? H H0 H1 H2 H3. - inv H3. - unfold makeCuttingPlane in H. - rewrite H1 in H. - revert H. - change (eval_pol env e = 0) in H2. - case_eq (Z.gtb g 0). - + intros H H3. - rewrite Z.gtb_lt in H. - rewrite Zgcd_pol_correct_lt with (1:= H1) in H2. 2: auto using Z.gt_lt. - unfold nformula_of_cutting_plane. - change (eval_pol env (padd e' (Pc z)) = 0). - inv H3. - rewrite eval_pol_add. - set (x:=eval_pol env (Zdiv_pol (PsubC Z.sub e c) g)) in *; clearbody x. - simpl. - rewrite andb_false_iff in H0. - destruct H0 as [H0|H0]. - * rewrite <-Z.gtb_lt in H ; congruence. - * rewrite andb_false_iff in H0. - destruct H0 as [H0|H0]. - -- rewrite negb_false_iff in H0. - apply Z.eqb_eq in H0. - subst. simpl. - rewrite Z.add_0_r, Z.mul_eq_0 in H2. - intuition subst; easy. - -- rewrite negb_false_iff in H0. - apply Z.eqb_eq in H0. - rewrite Zdivide_ceiling; cycle 1. - { apply Z.divide_opp_r. rewrite <-H0. apply Z.gcd_divide_r. } - apply Z.sub_move_0_r. - apply Z.div_unique_exact. - ++ now intros ->. - ++ now rewrite Z.add_move_0_r in H2. - + intros H H3. - unfold nformula_of_cutting_plane. - inv H3. - change (eval_pol env (padd e' (Pc 0)) = 0). - rewrite eval_pol_add. - simpl. - now rewrite Z.add_0_r. - - (* NonEqual *) - intros ? H H0. - inv H0. - unfold eval_nformula in *. - unfold RingMicromega.eval_nformula in *. - unfold nformula_of_cutting_plane. - unfold eval_op1 in *. - rewrite (RingMicromega.eval_pol_add Zsor ZSORaddon). - simpl. now rewrite Z.add_0_r. - - (* Strict *) - intros p; destruct p as [[e' z] op]. - case_eq (makeCuttingPlane (PsubC Z.sub e 1)). - intros ? ? H H0 H1. - inv H1. - apply (makeCuttingPlane_ns_sound env) with (2:= H). - simpl in *. - rewrite (RingMicromega.PsubC_ok Zsor ZSORaddon). - now apply Z.lt_le_pred. - - (* NonStrict *) - intros p; destruct p as [[e' z] op]. - case_eq (makeCuttingPlane e). - intros ? ? H H0 H1. - inv H1. - apply (makeCuttingPlane_ns_sound env) with (2:= H). - assumption. -Qed. - -Lemma genCuttingPlaneNone : forall env f, - genCuttingPlane f = None -> - eval_nformula env f -> False. -Proof. - unfold genCuttingPlane. - intros env f; destruct f as [p o]. - destruct o. - - case_eq (Zgcd_pol p) ; intros g c. - case_eq (Z.gtb g 0 && (negb (Z.eqb c 0) && negb (Z.eqb (Z.gcd g c) g))). - + intros H H0 H1 H2. - flatten_bool. - match goal with [ H' : (g >? 0) = true |- ?G ] => rename H' into H3 end. - match goal with [ H' : negb (Z.eqb c 0) = true |- ?G ] => rename H' into H end. - match goal with [ H' : negb (Z.eqb (Z.gcd g c) g) = true |- ?G ] => rename H' into H5 end. - rewrite negb_true_iff in H5. - apply Z.eqb_neq in H5. - rewrite Z.gtb_lt in H3. - rewrite negb_true_iff in H. - apply Z.eqb_neq in H. - change (eval_pol env p = 0) in H2. - rewrite Zgcd_pol_correct_lt with (1:= H0) in H2. 2: auto using Z.gt_lt. - set (x:=eval_pol env (Zdiv_pol (PsubC Z.sub p c) g)) in *; clearbody x. - contradict H5. - apply Zis_gcd_gcd. - * apply Z.lt_le_incl; assumption. - * constructor; auto with zarith. - exists (-x). - rewrite Z.mul_opp_l, Z.mul_comm. - now apply Z.add_move_0_l. - (**) - + destruct (makeCuttingPlane p); discriminate. - - discriminate. - - destruct (makeCuttingPlane (PsubC Z.sub p 1)) ; discriminate. - - destruct (makeCuttingPlane p) ; discriminate. -Qed. - -Lemma eval_nformula_mk_eq_pos : forall env x z t, - env x = env z - env t -> - eval_nformula env (xnnormalise (mk_eq_pos x z t)). -Proof. - intros. - rewrite xnnormalise_correct. - simpl. auto. -Qed. - -Lemma eval_nformula_bound_var : forall env x, - env x >= 0 -> - eval_nformula env (xnnormalise (bound_var x)). -Proof. - intros. - rewrite xnnormalise_correct. - simpl. auto. -Qed. - - -Definition agree_env (fr : positive) (env env' : positive -> Z) : Prop := - forall x, Pos.le x fr -> env x = env' x. - -Lemma agree_env_subset : forall v1 v2 env env', - agree_env v1 env env' -> - Pos.le v2 v1 -> - agree_env v2 env env'. -Proof. - unfold agree_env. - intros v1 v2 env env' H ? ? ?. - apply H. - eapply Pos.le_trans ; eauto. -Qed. - - -Lemma agree_env_jump : forall fr j env env', - agree_env (fr + j) env env' -> - agree_env fr (Env.jump j env) (Env.jump j env'). -Proof. - intros fr j env env' H. - unfold agree_env ; intro. - intros. - unfold Env.jump. - apply H. - apply Pos.add_le_mono_r; auto. -Qed. - - -Lemma agree_env_tail : forall fr env env', - agree_env (Pos.succ fr) env env' -> - agree_env fr (Env.tail env) (Env.tail env'). -Proof. - intros fr env env' H. - unfold Env.tail. - apply agree_env_jump. - rewrite <- Pos.add_1_r in H. - apply H. -Qed. - - -Lemma max_var_acc : forall p i j, - (max_var (i + j) p = max_var i p + j)%positive. -Proof. - intros p; induction p as [|? ? IHp|? IHp1 ? ? IHp2]; simpl. - - reflexivity. - - intros. - rewrite ! IHp. - rewrite Pos.add_assoc. - reflexivity. - - intros. - rewrite !Pplus_one_succ_l. - rewrite ! IHp1. - rewrite ! IHp2. - rewrite ! Pos.add_assoc. - rewrite <- Pos.add_max_distr_r. - reflexivity. -Qed. - - - -Lemma agree_env_eval_nformula : - forall env env' e - (AGREE : agree_env (max_var xH (fst e)) env env'), - eval_nformula env e <-> eval_nformula env' e. -Proof. - intros env env' e; destruct e as [p o]. - simpl; intros AGREE. - assert ((RingMicromega.eval_pol Z.add Z.mul (fun x : Z => x) env p) - = - (RingMicromega.eval_pol Z.add Z.mul (fun x : Z => x) env' p)) as H. - { - revert env env' AGREE. - generalize xH. - induction p as [?|p ? IHp|? IHp1 ? ? IHp2]; simpl. - - reflexivity. - - intros p1 **. - apply (IHp p1). - apply agree_env_jump. - eapply agree_env_subset; eauto. - rewrite (Pos.add_comm p). - rewrite max_var_acc. - apply Pos.le_refl. - - intros p ? ? AGREE. - f_equal;[f_equal|]. - + apply (IHp1 p). - eapply agree_env_subset; eauto. - apply Pos.le_max_l. - - + f_equal. - unfold Env.hd. - unfold Env.nth. - apply AGREE. - apply Pos.le_1_l. - - - + apply (IHp2 p). - apply agree_env_tail. - eapply agree_env_subset; eauto. - rewrite !Pplus_one_succ_r. - rewrite max_var_acc. - apply Pos.le_max_r. - } - - rewrite H. tauto. -Qed. - -Lemma agree_env_eval_nformulae : - forall env env' l - (AGREE : agree_env (max_var_nformulae l) env env'), - make_conj (eval_nformula env) l <-> - make_conj (eval_nformula env') l. -Proof. - intros env env' l; induction l as [|a l IHl]. - - simpl. tauto. - - intros. - rewrite ! make_conj_cons. - assert (eval_nformula env a <-> eval_nformula env' a) as H. - { - apply agree_env_eval_nformula. - eapply agree_env_subset ; eauto. - unfold max_var_nformulae. - simpl. - rewrite Pos.max_1_l. - apply max_var_nformulae_mono_aux. - apply Pos.le_refl. - } - rewrite H. - apply and_iff_compat_l. - apply IHl. - eapply agree_env_subset ; eauto. - unfold max_var_nformulae. - simpl. - apply max_var_nformulae_mono_aux'. - apply Pos.le_1_l. -Qed. - - -Lemma eq_true_iff_eq : - forall b1 b2 : bool, (b1 = true <-> b2 = true) <-> b1 = b2. -Proof. - intros b1 b2; destruct b1,b2 ; intuition congruence. -Qed. - -Lemma eval_nformula_split : forall env p, - eval_nformula env (p,NonStrict) \/ eval_nformula env (popp p,NonStrict). -Proof. - unfold popp. - simpl. intros. rewrite (eval_pol_opp Zsor ZSORaddon). - rewrite Z.opp_nonneg_nonpos. - apply Z.le_ge_cases. -Qed. - - - - -Lemma ZChecker_sound : forall w l, - ZChecker l w = true -> forall env, make_impl (eval_nformula env) l False. -Proof. - intros w; induction w as [w H] using (well_founded_ind (well_founded_ltof _ bdepth)). - destruct w as [ | w pf | w pf | p pf1 pf2 | w1 w2 pf | x pf]. - - (* DoneProof *) - simpl. discriminate. - - (* RatProof *) - simpl. - intros l. case_eq (eval_Psatz l w) ; [| discriminate]. - intros f Hf. - case_eq (Zunsat f). - + intros H0 ? ?. - apply (checker_nf_sound Zsor ZSORaddon l w). - unfold check_normalised_formulas. unfold eval_Psatz in Hf. rewrite Hf. - unfold Zunsat in H0. assumption. - + intros H0 H1 env. - assert (make_impl (eval_nformula env) (f::l) False) as H2. - { apply H with (2:= H1). - unfold ltof. - simpl. - auto with arith. - } - destruct f. - rewrite <- make_conj_impl in H2. - rewrite make_conj_cons in H2. - rewrite <- make_conj_impl. - intro. - apply H2. - split ; auto. - apply eval_Psatz_sound with (2:= Hf) ; assumption. - - (* CutProof *) - simpl. - intros l. - case_eq (eval_Psatz l w) ; [ | discriminate]. - intros f' Hlc. - case_eq (genCuttingPlane f'). - + intros p H0 H1 env. - assert (make_impl (eval_nformula env) (nformula_of_cutting_plane p::l) False) as H2. - { eapply (H pf) ; auto. - unfold ltof. - simpl. - auto with arith. - } - rewrite <- make_conj_impl in H2. - rewrite make_conj_cons in H2. - rewrite <- make_conj_impl. - intro. - apply H2. - split ; auto. - apply (eval_Psatz_sound env) in Hlc. - * apply cutting_plane_sound with (1:= Hlc) (2:= H0). - * auto. - + (* genCuttingPlane = None *) - intros H0 H1 env. - rewrite <- make_conj_impl. - intros H2. - apply eval_Psatz_sound with (2:= Hlc) in H2. - apply genCuttingPlaneNone with (2:= H2) ; auto. - - (* SplitProof *) - intros l. - cbn - [genCuttingPlane]. - case_eq (genCuttingPlane (p, NonStrict)) ; [| discriminate]. - case_eq (genCuttingPlane (popp p, NonStrict)) ; [| discriminate]. - intros cp1 GCP1 cp2 GCP2 ZC1 env. - flatten_bool. - match goal with [ H' : ZChecker _ pf1 = true |- _ ] => rename H' into H0 end. - match goal with [ H' : ZChecker _ pf2 = true |- _ ] => rename H' into H1 end. - destruct (eval_nformula_split env p). - + apply (fun H' ck => H _ H' _ ck env) in H0. - * rewrite <- make_conj_impl in *. - intro ; apply H0. - rewrite make_conj_cons. split; auto. - apply (cutting_plane_sound _ (p,NonStrict)) ; auto. - * apply ltof_bdepth_split_l. - + apply (fun H' ck => H _ H' _ ck env) in H1. - * rewrite <- make_conj_impl in *. - intro ; apply H1. - rewrite make_conj_cons. split; auto. - apply (cutting_plane_sound _ (popp p,NonStrict)) ; auto. - * apply ltof_bdepth_split_r. - - (* EnumProof *) - intros l. - simpl. - case_eq (eval_Psatz l w1) ; [ | discriminate]. - case_eq (eval_Psatz l w2) ; [ | discriminate]. - intros f1 Hf1 f2 Hf2. - case_eq (genCuttingPlane f2). - + intros p; destruct p as [ [p1 z1] op1]. - case_eq (genCuttingPlane f1). - * intros p; destruct p as [ [p2 z2] op2]. - case_eq (valid_cut_sign op1 && valid_cut_sign op2 && is_pol_Z0 (padd p1 p2)). - -- intros Hcond. - flatten_bool. - match goal with [ H1 : is_pol_Z0 (padd p1 p2) = true |- _ ] => rename H1 into HZ0 end. - match goal with [ H2 : valid_cut_sign op1 = true |- _ ] => rename H2 into Hop1 end. - match goal with [ H3 : valid_cut_sign op2 = true |- _ ] => rename H3 into Hop2 end. - intros HCutL HCutR Hfix env. - (* get the bounds of the enum *) - rewrite <- make_conj_impl. - intro H0. - assert (-z1 <= eval_pol env p1 <= z2) as H1. { - split. - - apply (eval_Psatz_sound env) in Hf2 ; auto. - apply cutting_plane_sound with (1:= Hf2) in HCutR. - unfold nformula_of_cutting_plane in HCutR. - unfold eval_nformula in HCutR. - unfold RingMicromega.eval_nformula in HCutR. - change (RingMicromega.eval_pol Z.add Z.mul (fun x : Z => x)) with eval_pol in HCutR. - unfold eval_op1 in HCutR. - destruct op1 ; simpl in Hop1 ; try discriminate; - rewrite eval_pol_add in HCutR; simpl in HCutR. - + rewrite Z.add_move_0_l in HCutR; rewrite HCutR, Z.opp_involutive; reflexivity. - + now apply Z.le_sub_le_add_r in HCutR. - (**) - - apply (fun H => is_pol_Z0_eval_pol _ H env) in HZ0. - rewrite eval_pol_add, Z.add_move_r, Z.sub_0_l in HZ0. - rewrite HZ0. - apply (eval_Psatz_sound env) in Hf1 ; auto. - apply cutting_plane_sound with (1:= Hf1) in HCutL. - unfold nformula_of_cutting_plane in HCutL. - unfold eval_nformula in HCutL. - unfold RingMicromega.eval_nformula in HCutL. - change (RingMicromega.eval_pol Z.add Z.mul (fun x : Z => x)) with eval_pol in HCutL. - unfold eval_op1 in HCutL. - rewrite eval_pol_add in HCutL. simpl in HCutL. - destruct op2 ; simpl in Hop2 ; try discriminate. - + rewrite Z.add_move_r, Z.sub_0_l in HCutL. - now rewrite HCutL, Z.opp_involutive. - + now rewrite <- Z.le_sub_le_add_l in HCutL. - } - revert Hfix. - match goal with - | |- context[?F pf (-z1) z2 = true] => set (FF := F) - end. - intros Hfix. - assert (HH :forall x, -z1 <= x <= z2 -> exists pr, - (In pr pf /\ - ZChecker ((PsubC Z.sub p1 x,Equal) :: l) pr = true)%Z). { - clear HZ0 Hop1 Hop2 HCutL HCutR H0 H1. - revert Hfix. - generalize (-z1). clear z1. intro z1. - revert z1 z2. - induction pf as [|a pf IHpf];simpl ;intros z1 z2 Hfix x **. - - revert Hfix. - now case (Z.gtb_spec); [ | easy ]; intros LT; elim (Zorder.Zlt_not_le _ _ LT); transitivity x. - - flatten_bool. - match goal with [ H' : _ <= x <= _ |- _ ] => rename H' into H0 end. - match goal with [ H' : FF pf (z1 + 1) z2 = true |- _ ] => rename H' into H2 end. - destruct (ZArith_dec.Z_le_lt_eq_dec _ _ (proj1 H0)) as [ LT | -> ]. - 2: exists a; auto. - rewrite <- Z.le_succ_l in LT. - assert (LE: (Z.succ z1 <= x <= z2)%Z) by intuition. - elim IHpf with (2:=H2) (3:= LE). - + intros x0 ?. - exists x0 ; split;tauto. - + intros until 1. - apply H ; auto. - cbv [ltof] in *. - cbn [bdepth] in *. - eauto using Nat.lt_le_trans, le_n_S, Nat.le_max_r. - } - (*/asser *) - destruct (HH _ H1) as [pr [Hin Hcheker]]. - assert (make_impl (eval_nformula env) ((PsubC Z.sub p1 (eval_pol env p1),Equal) :: l) False) as H2. { - eapply (H pr) ;auto. - apply in_bdepth ; auto. - } - rewrite <- make_conj_impl in H2. - apply H2. - rewrite make_conj_cons. - split ;auto. - unfold eval_nformula. - unfold RingMicromega.eval_nformula. - simpl. - rewrite (RingMicromega.PsubC_ok Zsor ZSORaddon). - unfold eval_pol. ring. - -- discriminate. - * (* No cutting plane *) - intros H0 H1 H2 env. - rewrite <- make_conj_impl. - intros H3. - apply eval_Psatz_sound with (2:= Hf1) in H3. - apply genCuttingPlaneNone with (2:= H3) ; auto. - + (* No Cutting plane (bis) *) - intros H0 H1 env. - rewrite <- make_conj_impl. - intros H2. - apply eval_Psatz_sound with (2:= Hf2) in H2. - apply genCuttingPlaneNone with (2:= H2) ; auto. - - intros l. - unfold ZChecker. - fold ZChecker. - set (fr := (max_var_nformulae l)%positive). - set (z1 := (Pos.succ fr)) in *. - set (t1 := (Pos.succ z1)) in *. - destruct (x <=? fr)%positive eqn:LE ; [|congruence]. - intros H0 env. - set (env':= fun v => if Pos.eqb v z1 - then if Z.leb (env x) 0 then 0 else env x - else if Pos.eqb v t1 - then if Z.leb (env x) 0 then -(env x) else 0 - else env v). - apply (fun H' ck => H _ H' _ ck env') in H0. - + rewrite <- make_conj_impl in *. - intro H1. - rewrite !make_conj_cons in H0. - apply H0 ; repeat split. - * - apply eval_nformula_mk_eq_pos. - unfold env'. - rewrite! Pos.eqb_refl. - replace (x=?z1)%positive with false. - 1:replace (x=?t1)%positive with false. - 1:replace (t1=?z1)%positive with false. - 1:destruct (env x <=? 0); ring. - { unfold t1. - symmetry; apply not_true_iff_false; rewrite Pos.eqb_eq; symmetry; apply Pos.succ_discr. - } - { - unfold t1, z1. - symmetry; apply not_true_iff_false; rewrite Pos.eqb_eq; intros ->. - apply Pos.leb_le, Pos.lt_succ_r in LE; rewrite <-?Pos.succ_lt_mono in *. - pose proof Pos.lt_not_add_l fr 1; rewrite Pos.add_1_r in *; contradiction. - } - { - unfold z1. - symmetry; apply not_true_iff_false; rewrite Pos.eqb_eq; intros ->. - apply Pos.leb_le, Pos.lt_succ_r in LE; rewrite <-?Pos.succ_lt_mono in *. - case (Pos.lt_irrefl _ LE). - } - * - apply eval_nformula_bound_var. - unfold env'. - rewrite! Pos.eqb_refl. - destruct (env x <=? 0) eqn:EQ. - -- compute. congruence. - -- rewrite Z.leb_gt in EQ. - apply Z.ge_le_iff, Z.lt_le_incl; trivial. - * - apply eval_nformula_bound_var. - unfold env'. - rewrite! Pos.eqb_refl. - replace (t1 =? z1)%positive with false. - -- destruct (env x <=? 0) eqn:EQ. - ++ rewrite Z.leb_le in EQ. - apply Z.ge_le_iff. rewrite Z.opp_le_mono, Z.opp_involutive; trivial. - ++ compute; congruence. - -- unfold t1. - clear. - symmetry; apply not_true_iff_false; rewrite Pos.eqb_eq; symmetry; apply Pos.succ_discr. - * - rewrite (agree_env_eval_nformulae _ env') in H1;auto. - unfold agree_env; intros x0 H2. - unfold env'. - replace (x0 =? z1)%positive with false. - 1:replace (x0 =? t1)%positive with false. - 1:reflexivity. - { - unfold t1, z1. - symmetry; apply not_true_iff_false; rewrite Pos.eqb_eq; intros ->. - apply Pos.lt_succ_r in H2; rewrite <-?Pos.succ_lt_mono in *. - pose proof Pos.lt_not_add_l (max_var_nformulae l) 1; rewrite Pos.add_1_r in *; contradiction. - } - { - unfold z1, fr in *. - symmetry; apply not_true_iff_false; rewrite Pos.eqb_eq; intros ->. - apply Pos.lt_succ_r in H2; rewrite <-?Pos.succ_lt_mono in *. - case (Pos.lt_irrefl _ H2). - } - + unfold ltof. - simpl. - apply Nat.lt_succ_diag_r. -Qed. - -Definition ZTautoChecker (f : BFormula (Formula Z) Tauto.isProp) (w: list ZArithProof): bool := - @tauto_checker (Formula Z) (NFormula Z) unit Zunsat Zdeduce normalise negate ZArithProof (fun cl => ZChecker (List.map fst cl)) f w. - -Lemma ZTautoChecker_sound : forall f w, ZTautoChecker f w = true -> forall env, eval_bf (Zeval_formula env) f. -Proof. - intros f w. - unfold ZTautoChecker. - apply (tauto_checker_sound _ _ _ _ eval_nformula). - - apply Zeval_nformula_dec. - - intros t ? env. - unfold eval_nformula. unfold RingMicromega.eval_nformula. - destruct t. - apply (check_inconsistent_sound Zsor ZSORaddon) ; auto. - - unfold Zdeduce. intros ? ? ? H **. revert H. - apply (nformula_plus_nformula_correct Zsor ZSORaddon); auto. - - - intros ? ? ? ? H. - rewrite normalise_correct in H. - rewrite Zeval_formula_compat; auto. - - - intros ? ? ? ? H. - rewrite negate_correct in H ; auto. - rewrite Tauto.hold_eNOT. - rewrite Zeval_formula_compat; auto. - - intros t w0. - unfold eval_tt. - intros H env. - rewrite (make_impl_map (eval_nformula env)). - + eapply ZChecker_sound; eauto. - + tauto. -Qed. -Fixpoint xhyps_of_pt (base:nat) (acc : list nat) (pt:ZArithProof) : list nat := - match pt with - | DoneProof => acc - | RatProof c pt => xhyps_of_pt (S base ) (xhyps_of_psatz base acc c) pt - | CutProof c pt => xhyps_of_pt (S base ) (xhyps_of_psatz base acc c) pt - | SplitProof p pt1 pt2 => xhyps_of_pt (S base) (xhyps_of_pt (S base) acc pt1) pt2 - | EnumProof c1 c2 l => - let acc := xhyps_of_psatz base (xhyps_of_psatz base acc c2) c1 in - List.fold_left (xhyps_of_pt (S base)) l acc - | ExProof _ pt => xhyps_of_pt (S (S (S base ))) acc pt - end. - -Definition hyps_of_pt (pt : ZArithProof) : list nat := xhyps_of_pt 0 nil pt. - -Open Scope Z_scope. - -(** To ease bindings from ml code **) -Definition make_impl := Refl.make_impl. -Definition make_conj := Refl.make_conj. - -Require VarMap. - -(*Definition varmap_type := VarMap.t Z. *) -Definition env := PolEnv Z. -Definition node := @VarMap.Branch Z. -Definition empty := @VarMap.Empty Z. -Definition leaf := @VarMap.Elt Z. - -Definition coneMember := ZWitness. - -Definition eval := eval_formula. - -#[deprecated(note="Use [prod positive nat]", since="9.0")] -Definition prod_pos_nat := prod positive nat. - -#[deprecated(use=Z.to_N, since="9.0")] -Notation n_of_Z := Z.to_N (only parsing). diff --git a/stdlib/theories/micromega/Zify.v b/stdlib/theories/micromega/Zify.v deleted file mode 100644 index 8d0413296594..000000000000 --- a/stdlib/theories/micromega/Zify.v +++ /dev/null @@ -1,38 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* zify_internal_to_euclidean_division_equations - | false => idtac - end. - - -Ltac zify := intros; - zify_pre_hook ; - zify_elim_let ; - zify_op ; - (zify_iter_specs) ; - zify_saturate; - zify_to_euclidean_division_equations ; - zify_post_hook. diff --git a/stdlib/theories/micromega/ZifyBool.v b/stdlib/theories/micromega/ZifyBool.v deleted file mode 100644 index d31ecf5eda57..000000000000 --- a/stdlib/theories/micromega/ZifyBool.v +++ /dev/null @@ -1,208 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* - destruct C as [C|C]; rewrite C in * - end. - -Ltac Zify.zify_post_hook ::= elim_bool_cstr. diff --git a/stdlib/theories/micromega/ZifyClasses.v b/stdlib/theories/micromega/ZifyClasses.v deleted file mode 100644 index eace54be574d..000000000000 --- a/stdlib/theories/micromega/ZifyClasses.v +++ /dev/null @@ -1,286 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* S -> S]. - Another limitation is that our injection theorems e.g. [TBOpInj], - are using Leibniz equality; the payoff is that there is no need for morphisms... - *) - -(** An injection [InjTyp S T] declares an injection - from source type S to target type T. -*) -Class InjTyp (S : Type) (T : Type) := - mkinj { - (* [inj] is the injection function *) - inj : S -> T; - pred : T -> Prop; - (* [cstr] states that [pred] holds for any injected element. - [cstr (inj x)] is introduced in the goal for any leaf - term of the form [inj x] - *) - cstr : forall x, pred (inj x) - }. - -(** [BinOp Op] declares a source operator [Op: S1 -> S2 -> S3]. - *) -Class BinOp {S1 S2 S3 T1 T2 T3:Type} (Op : S1 -> S2 -> S3) {I1 : InjTyp S1 T1} {I2 : InjTyp S2 T2} {I3 : InjTyp S3 T3} := - mkbop { - (* [TBOp] is the target operator after injection of operands. *) - TBOp : T1 -> T2 -> T3; - (* [TBOpInj] states the correctness of the injection. *) - TBOpInj : forall (n:S1) (m:S2), inj (Op n m) = TBOp (inj n) (inj m) - }. - -(** [Unop Op] declares a source operator [Op : S1 -> S2]. *) -Class UnOp {S1 S2 T1 T2:Type} (Op : S1 -> S2) {I1 : InjTyp S1 T1} {I2 : InjTyp S2 T2} := - mkuop { - (* [TUOp] is the target operator after injection of operands. *) - TUOp : T1 -> T2; - (* [TUOpInj] states the correctness of the injection. *) - TUOpInj : forall (x:S1), inj (Op x) = TUOp (inj x) - }. - -(** [CstOp Op] declares a source constant [Op : S]. *) -Class CstOp {S T:Type} (Op : S) {I : InjTyp S T} := - mkcst { - (* [TCst] is the target constant. *) - TCst : T; - (* [TCstInj] states the correctness of the injection. *) - TCstInj : inj Op = TCst - }. - -(** In the framework, [Prop] is mapped to [Prop] and the injection is phrased in - terms of [=] instead of [<->]. -*) - -(** [BinRel R] declares the injection of a binary relation. *) -Class BinRel {S:Type} {T:Type} (R : S -> S -> Prop) {I : InjTyp S T} := - mkbrel { - TR : T -> T -> Prop; - TRInj : forall n m : S, R n m <-> TR (@inj _ _ I n) (inj m) - }. - -(** [PropOp Op] declares morphisms for [<->]. - This will be used to deal with e.g. [and], [or],... *) - -Class PropOp (Op : Prop -> Prop -> Prop) := - mkprop { - op_iff : forall (p1 p2 q1 q2:Prop), (p1 <-> q1) -> (p2 <-> q2) -> (Op p1 p2 <-> Op q1 q2) - }. - -Class PropUOp (Op : Prop -> Prop) := - mkuprop { - uop_iff : forall (p1 q1 :Prop), (p1 <-> q1) -> (Op p1 <-> Op q1) - }. - - - -(** Once the term is injected, terms can be replaced by their specification. - NB1: The Ltac code is currently limited to (Op: Z -> Z -> Z) - NB2: This is not sufficient to cope with [Z.div] or [Z.mod] - *) -Class BinOpSpec {T1 T2 T3: Type} (Op : T1 -> T2 -> T3) := - mkbspec { - BPred : T1 -> T2 -> T3 -> Prop; - BSpec : forall x y, BPred x y (Op x y) - }. - -Class UnOpSpec {T1 T2: Type} (Op : T1 -> T2) := - mkuspec { - UPred : T1 -> T2 -> Prop; - USpec : forall x, UPred x (Op x) - }. - -(** After injections, e.g. nat -> Z, - the fact that Z.of_nat x * Z.of_nat y is positive is lost. - This information can be recovered using instance of the [Saturate] class. -*) -Class Saturate {T: Type} (Op : T -> T -> T) := - mksat { - (** Given [Op x y], - - [PArg1] is the pre-condition of x - - [PArg2] is the pre-condition of y - - [PRes] is the pos-condition of (Op x y) *) - PArg1 : T -> Prop; - PArg2 : T -> Prop; - PRes : T -> T -> T -> Prop; - (** [SatOk] states the correctness of the reasoning *) - SatOk : forall x y, PArg1 x -> PArg2 y -> PRes x y (Op x y) - }. -(* )Arguments PRes {_ _} _. *) - -(* The [ZifyInst.saturate] iterates over all the instances - and for every pattern of the form - [H1 : PArg1 ?x , H2 : PArg2 ?y , T : context[Op ?x ?y] |- _ ] - [H1 : PArg1 ?x , H2 : PArg2 ?y |- context[Op ?x ?y] ] - asserts (SatOK x y H1 H2) *) - -(** The rest of the file is for internal use by the ML tactic. - There are data-structures and lemmas used to inductively construct - the injected terms. *) - -(** The data-structures [injterm] and [injected_prop] - are used to store source and target expressions together - with a correctness proof. *) - -Record injterm {S T: Type} (I : S -> T) := - mkinjterm { source : S ; target : T ; inj_ok : I source = target}. - -Record injprop := - mkinjprop { - source_prop : Prop ; target_prop : Prop ; - injprop_ok : source_prop <-> target_prop}. - - -(** Lemmas for building rewrite rules. *) - -Definition PropOp_iff (Op : Prop -> Prop -> Prop) := - forall (p1 p2 q1 q2:Prop), (p1 <-> q1) -> (p2 <-> q2) -> (Op p1 p2 <-> Op q1 q2). - -Definition PropUOp_iff (Op : Prop -> Prop) := - forall (p1 q1 :Prop), (p1 <-> q1) -> (Op p1 <-> Op q1). - -Lemma mkapp2 (S1 S2 S3 T1 T2 T3 : Type) (Op : S1 -> S2 -> S3) - (I1 : S1 -> T1) (I2 : S2 -> T2) (I3 : S3 -> T3) - (TBOP : T1 -> T2 -> T3) - (TBOPINJ : forall n m, I3 (Op n m) = TBOP (I1 n) (I2 m)) - (s1 : S1) (t1 : T1) (P1: I1 s1 = t1) - (s2 : S2) (t2 : T2) (P2: I2 s2 = t2): I3 (Op s1 s2) = TBOP t1 t2. -Proof. - subst. apply TBOPINJ. -Qed. - -Lemma mkapp (S1 S2 T1 T2 : Type) (OP : S1 -> S2) - (I1 : S1 -> T1) - (I2 : S2 -> T2) - (TUOP : T1 -> T2) - (TUOPINJ : forall n, I2 (OP n) = TUOP (I1 n)) - (s1: S1) (t1: T1) (P1: I1 s1 = t1): I2 (OP s1) = TUOP t1. -Proof. - subst. apply TUOPINJ. -Qed. - -Lemma mkrel (S T : Type) (R : S -> S -> Prop) - (I : S -> T) - (TR : T -> T -> Prop) - (TRINJ : forall n m : S, R n m <-> TR (I n) (I m)) - (s1 : S) (t1 : T) (P1 : I s1 = t1) - (s2 : S) (t2 : T) (P2 : I s2 = t2): - R s1 s2 <-> TR t1 t2. -Proof. - subst. - apply TRINJ. -Qed. - -(** Hardcoded support and lemma for propositional logic *) - -Lemma and_morph : forall (s1 s2 t1 t2:Prop), s1 <-> t1 -> s2 <-> t2 -> ((s1 /\ s2) <-> (t1 /\ t2)). -Proof. - intros. tauto. -Qed. - -Lemma or_morph : forall (s1 s2 t1 t2:Prop), s1 <-> t1 -> s2 <-> t2 -> ((s1 \/ s2) <-> (t1 \/ t2)). -Proof. - intros. tauto. -Qed. - -Lemma impl_morph : forall (s1 s2 t1 t2:Prop), s1 <-> t1 -> s2 <-> t2 -> ((s1 -> s2) <-> (t1 -> t2)). -Proof. - intros. tauto. -Qed. - -Lemma iff_morph : forall (s1 s2 t1 t2:Prop), s1 <-> t1 -> s2 <-> t2 -> ((s1 <-> s2) <-> (t1 <-> t2)). -Proof. - intros. tauto. -Qed. - -Lemma not_morph : forall (s1 t1:Prop), s1 <-> t1 -> (not s1) <-> (not t1). -Proof. - intros. tauto. -Qed. - -Lemma eq_iff : forall (P Q : Prop), P = Q -> (P <-> Q). -Proof. - intros P Q H. - rewrite H. - apply iff_refl. -Defined. - -Lemma rew_iff (P Q : Prop) (IFF : P <-> Q) : P -> Q. -Proof. - exact (fun H => proj1 IFF H). -Qed. - -Lemma rew_iff_rev (P Q : Prop) (IFF : P <-> Q) : Q -> P. -Proof. - exact (fun H => proj2 IFF H). -Qed. - - - -(** Registering constants for use by the plugin *) -Register eq_iff as ZifyClasses.eq_iff. -Register target_prop as ZifyClasses.target_prop. -Register mkrel as ZifyClasses.mkrel. -Register target as ZifyClasses.target. -Register mkapp2 as ZifyClasses.mkapp2. -Register mkapp as ZifyClasses.mkapp. -Register op_iff as ZifyClasses.op_iff. -Register uop_iff as ZifyClasses.uop_iff. -Register TR as ZifyClasses.TR. -Register TBOp as ZifyClasses.TBOp. -Register TUOp as ZifyClasses.TUOp. -Register TCst as ZifyClasses.TCst. -Register injprop_ok as ZifyClasses.injprop_ok. -Register inj_ok as ZifyClasses.inj_ok. -Register source as ZifyClasses.source. -Register source_prop as ZifyClasses.source_prop. -Register inj as ZifyClasses.inj. -Register TRInj as ZifyClasses.TRInj. -Register TUOpInj as ZifyClasses.TUOpInj. -Register not as ZifyClasses.not. -Register mkinjterm as ZifyClasses.mkinjterm. -Register eq_refl as ZifyClasses.eq_refl. -Register eq as ZifyClasses.eq. -Register mkinjprop as ZifyClasses.mkinjprop. -Register iff_refl as ZifyClasses.iff_refl. -Register rew_iff as ZifyClasses.rew_iff. -Register rew_iff_rev as ZifyClasses.rew_iff_rev. -Register source_prop as ZifyClasses.source_prop. -Register injprop_ok as ZifyClasses.injprop_ok. -Register iff as ZifyClasses.iff. - -Register InjTyp as ZifyClasses.InjTyp. -Register BinOp as ZifyClasses.BinOp. -Register UnOp as ZifyClasses.UnOp. -Register CstOp as ZifyClasses.CstOp. -Register BinRel as ZifyClasses.BinRel. -Register PropOp as ZifyClasses.PropOp. -Register PropUOp as ZifyClasses.PropUOp. -Register BinOpSpec as ZifyClasses.BinOpSpec. -Register UnOpSpec as ZifyClasses.UnOpSpec. -Register Saturate as ZifyClasses.Saturate. - - -(** Propositional logic *) -Register and as ZifyClasses.and. -Register and_morph as ZifyClasses.and_morph. -Register or as ZifyClasses.or. -Register or_morph as ZifyClasses.or_morph. -Register iff as ZifyClasses.iff. -Register iff_morph as ZifyClasses.iff_morph. -Register impl_morph as ZifyClasses.impl_morph. -Register not as ZifyClasses.not. -Register not_morph as ZifyClasses.not_morph. -Register True as ZifyClasses.True. -Register I as ZifyClasses.I. diff --git a/stdlib/theories/micromega/ZifyComparison.v b/stdlib/theories/micromega/ZifyComparison.v deleted file mode 100644 index 15cb83fa619b..000000000000 --- a/stdlib/theories/micromega/ZifyComparison.v +++ /dev/null @@ -1,89 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* -1 - | Eq => 0 - | Gt => 1 - end. - -Lemma Z_of_comparison_bound : forall x, -1 <= Z_of_comparison x <= 1. -Proof. - destruct x ; simpl; compute; intuition congruence. -Qed. - -#[global] -Instance Inj_comparison_Z : InjTyp comparison Z := - { inj := Z_of_comparison ; pred :=(fun x => -1 <= x <= 1) ; cstr := Z_of_comparison_bound}. -Add Zify InjTyp Inj_comparison_Z. - -Definition ZcompareZ (x y : Z) := - Z_of_comparison (Z.compare x y). - -#[global] -Program Instance BinOp_Zcompare : BinOp Z.compare := - { TBOp := ZcompareZ }. -Add Zify BinOp BinOp_Zcompare. - -#[global] -Instance Op_eq_comparison : BinRel (@eq comparison) := - {TR := @eq Z ; TRInj := ltac:(intros [] []; simpl ; intuition congruence) }. -Add Zify BinRel Op_eq_comparison. - -#[global] -Instance Op_Eq : CstOp Eq := - { TCst := 0 ; TCstInj := eq_refl }. -Add Zify CstOp Op_Eq. - -#[global] -Instance Op_Lt : CstOp Lt := - { TCst := -1 ; TCstInj := eq_refl }. -Add Zify CstOp Op_Lt. - -#[global] -Instance Op_Gt : CstOp Gt := - { TCst := 1 ; TCstInj := eq_refl }. -Add Zify CstOp Op_Gt. - - -Lemma Zcompare_spec : forall x y, - (x = y -> ZcompareZ x y = 0) - /\ - (x > y -> ZcompareZ x y = 1) - /\ - (x < y -> ZcompareZ x y = -1). -Proof. - unfold ZcompareZ. - intros. - destruct (x ?= y) eqn:C; simpl. - - rewrite Z.compare_eq_iff in C. - lia. - - rewrite Z.compare_lt_iff in C. - lia. - - rewrite Z.compare_gt_iff in C. - lia. -Qed. - -#[global] -Instance ZcompareSpec : BinOpSpec ZcompareZ := - {| BPred := fun x y r => (x = y -> r = 0) - /\ - (x > y -> r = 1) - /\ - (x < y -> r = -1) - ; BSpec := Zcompare_spec|}. -Add Zify BinOpSpec ZcompareSpec. diff --git a/stdlib/theories/micromega/ZifyInst.v b/stdlib/theories/micromega/ZifyInst.v deleted file mode 100644 index 8f892ed2eeef..000000000000 --- a/stdlib/theories/micromega/ZifyInst.v +++ /dev/null @@ -1,650 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* unfold X, inj - end ; reflexivity). - - -#[global] -Instance Inj_Z_Z : InjTyp Z Z := - mkinj _ _ (fun x => x) (fun x => True ) (fun _ => I). -Add Zify InjTyp Inj_Z_Z. - -(** Support for nat *) - -#[global] -Instance Inj_nat_Z : InjTyp nat Z := - mkinj _ _ Z.of_nat (fun x => 0 <= x ) Nat2Z.is_nonneg. -Add Zify InjTyp Inj_nat_Z. - -(* zify_nat_rel *) -#[global] -Instance Op_ge : BinRel ge := - { TR := Z.ge; TRInj := Nat2Z.inj_ge }. -Add Zify BinRel Op_ge. - -#[global] -Instance Op_lt : BinRel lt := - { TR := Z.lt; TRInj := Nat2Z.inj_lt }. -Add Zify BinRel Op_lt. - -#[global] -Instance Op_Nat_lt : BinRel Nat.lt := Op_lt. -Add Zify BinRel Op_Nat_lt. - -#[global] -Instance Op_gt : BinRel gt := - { TR := Z.gt; TRInj := Nat2Z.inj_gt }. -Add Zify BinRel Op_gt. - -#[global] -Instance Op_le : BinRel le := - { TR := Z.le; TRInj := Nat2Z.inj_le }. -Add Zify BinRel Op_le. - -#[global] -Instance Op_Nat_le : BinRel Nat.le := Op_le. -Add Zify BinRel Op_Nat_le. - -#[global] -Instance Op_eq_nat : BinRel (@eq nat) := - { TR := @eq Z ; TRInj x y := iff_sym (Nat2Z.inj_iff x y) }. -Add Zify BinRel Op_eq_nat. - -#[global] -Instance Op_Nat_eq : BinRel (Nat.eq) := Op_eq_nat. -Add Zify BinRel Op_Nat_eq. - -(* zify_nat_op *) -#[global] -Instance Op_plus : BinOp Nat.add := - { TBOp := Z.add; TBOpInj := Nat2Z.inj_add }. -Add Zify BinOp Op_plus. - -#[global] -Instance Op_sub : BinOp Nat.sub := - { TBOp n m := Z.max 0 (n - m) ; TBOpInj := Nat2Z.inj_sub_max }. -Add Zify BinOp Op_sub. - -#[global] -Instance Op_mul : BinOp Nat.mul := - { TBOp := Z.mul ; TBOpInj := Nat2Z.inj_mul }. -Add Zify BinOp Op_mul. - -#[global] -Instance Op_min : BinOp Nat.min := - { TBOp := Z.min ; TBOpInj := Nat2Z.inj_min }. -Add Zify BinOp Op_min. - -#[global] -Instance Op_max : BinOp Nat.max := - { TBOp := Z.max ; TBOpInj := Nat2Z.inj_max }. -Add Zify BinOp Op_max. - -#[global] -Instance Op_pred : UnOp Nat.pred := - { TUOp n := Z.max 0 (n - 1) ; TUOpInj := Nat2Z.inj_pred_max }. -Add Zify UnOp Op_pred. - -#[global] -Instance Op_S : UnOp S := - { TUOp x := Z.add x 1 ; TUOpInj := Nat2Z.inj_succ }. -Add Zify UnOp Op_S. - -#[global] -Instance Op_O : CstOp O := - { TCst := Z0 ; TCstInj := eq_refl (Z.of_nat 0) }. -Add Zify CstOp Op_O. - -#[global] -Instance Op_Z_abs_nat : UnOp Z.abs_nat := - { TUOp := Z.abs ; TUOpInj := Zabs2Nat.id_abs }. -Add Zify UnOp Op_Z_abs_nat. - -#[global] -Instance Op_nat_div2 : UnOp Nat.div2 := - { TUOp x := x / 2 ; - TUOpInj x := ltac:(now rewrite Nat2Z.inj_div2, Z.div2_div) }. -Add Zify UnOp Op_nat_div2. - -#[global] -Instance Op_nat_double : UnOp Nat.double := - {| TUOp := Z.mul 2 ; TUOpInj := Nat2Z.inj_double |}. -Add Zify UnOp Op_nat_double. - -(** Support for positive *) - -#[global] -Instance Inj_pos_Z : InjTyp positive Z := - { inj := Zpos ; pred x := 0 < x ; cstr := Pos2Z.pos_is_pos }. -Add Zify InjTyp Inj_pos_Z. - -#[global] -Instance Op_pos_to_nat : UnOp Pos.to_nat := - {TUOp x := x ; TUOpInj := positive_nat_Z}. -Add Zify UnOp Op_pos_to_nat. - -#[global] -Instance Inj_N_Z : InjTyp N Z := - mkinj _ _ Z.of_N (fun x => 0 <= x ) N2Z.is_nonneg. -Add Zify InjTyp Inj_N_Z. - - -#[global] -Instance Op_N_to_nat : UnOp N.to_nat := - { TUOp x := x ; TUOpInj := N_nat_Z }. -Add Zify UnOp Op_N_to_nat. - -(* zify_positive_rel *) - -#[global] -Instance Op_pos_ge : BinRel Pos.ge := - { TR := Z.ge; TRInj x y := iff_refl (Z.pos x >= Z.pos y) }. -Add Zify BinRel Op_pos_ge. - -#[global] -Instance Op_pos_lt : BinRel Pos.lt := - { TR := Z.lt; TRInj x y := iff_refl (Z.pos x < Z.pos y) }. -Add Zify BinRel Op_pos_lt. - -#[global] -Instance Op_pos_gt : BinRel Pos.gt := - { TR := Z.gt; TRInj x y := iff_refl (Z.pos x > Z.pos y) }. -Add Zify BinRel Op_pos_gt. - -#[global] -Instance Op_pos_le : BinRel Pos.le := - { TR := Z.le; TRInj x y := iff_refl (Z.pos x <= Z.pos y) }. -Add Zify BinRel Op_pos_le. - -Lemma eq_pos_inj x y : x = y <-> Z.pos x = Z.pos y. -Proof. - apply (iff_sym (Pos2Z.inj_iff x y)). -Qed. - -#[global] -Instance Op_eq_pos : BinRel (@eq positive) := - { TR := @eq Z ; TRInj := eq_pos_inj }. -Add Zify BinRel Op_eq_pos. - -(* zify_positive_op *) - -#[global] -Instance Op_Z_of_N : UnOp Z.of_N := - { TUOp x := x ; TUOpInj x := eq_refl (Z.of_N x) }. -Add Zify UnOp Op_Z_of_N. - -#[global] -Instance Op_Z_to_N : UnOp Z.to_N := - { TUOp x := Z.max 0 x ; TUOpInj x := ltac:(now destruct x) }. -Add Zify UnOp Op_Z_to_N. - -#[global] -Instance Op_Z_neg : UnOp Z.neg := - { TUOp := Z.opp ; TUOpInj x := eq_refl (Zneg x) }. -Add Zify UnOp Op_Z_neg. - -#[global] -Instance Op_Z_pos : UnOp Z.pos := - { TUOp x := x ; TUOpInj x := eq_refl (Z.pos x) }. -Add Zify UnOp Op_Z_pos. - -#[global] -Instance Op_pos_succ : UnOp Pos.succ := - { TUOp x := x + 1 ; TUOpInj := Pos2Z.inj_succ }. -Add Zify UnOp Op_pos_succ. - -#[global] -Instance Op_pos_pred_double : UnOp Pos.pred_double := -{ TUOp x := 2 * x - 1 ; TUOpInj _ := eq_refl }. -Add Zify UnOp Op_pos_pred_double. - -#[global] -Instance Op_pos_pred : UnOp Pos.pred := - { TUOp x := Z.max 1 (x - 1) ; - TUOpInj x := ltac:(rewrite <- Pos.sub_1_r; apply Pos2Z.inj_sub_max) }. -Add Zify UnOp Op_pos_pred. - -#[global] -Instance Op_pos_predN : UnOp Pos.pred_N := - { TUOp x := x - 1 ; - TUOpInj x := ltac: (now destruct x; rewrite N.pos_pred_spec) }. -Add Zify UnOp Op_pos_predN. - -#[global] -Instance Op_pos_of_succ_nat : UnOp Pos.of_succ_nat := - { TUOp x := x + 1 ; TUOpInj := Zpos_P_of_succ_nat }. -Add Zify UnOp Op_pos_of_succ_nat. - -#[global] -Instance Op_pos_of_nat : UnOp Pos.of_nat := - { TUOp x := Z.max 1 x ; - TUOpInj x := ltac: (now destruct x; - [|rewrite <- Pos.of_nat_succ, <- (Nat2Z.inj_max 1)]) }. -Add Zify UnOp Op_pos_of_nat. - -#[global] -Instance Op_pos_add : BinOp Pos.add := - { TBOp := Z.add ; TBOpInj _ _ := eq_refl }. -Add Zify BinOp Op_pos_add. - -#[global] -Instance Op_pos_add_carry : BinOp Pos.add_carry := - { TBOp x y := x + y + 1 ; - TBOpInj := ltac:(now intros; rewrite Pos.add_carry_spec, Pos2Z.inj_succ) }. -Add Zify BinOp Op_pos_add_carry. - -#[global] -Instance Op_pos_sub : BinOp Pos.sub := - { TBOp n m := Z.max 1 (n - m) ; TBOpInj := Pos2Z.inj_sub_max }. -Add Zify BinOp Op_pos_sub. - -#[global] -Instance Op_pos_mul : BinOp Pos.mul := - { TBOp := Z.mul ; TBOpInj _ _ := eq_refl }. -Add Zify BinOp Op_pos_mul. - -#[global] -Instance Op_pos_min : BinOp Pos.min := - { TBOp := Z.min ; TBOpInj := Pos2Z.inj_min }. -Add Zify BinOp Op_pos_min. - -#[global] -Instance Op_pos_max : BinOp Pos.max := - { TBOp := Z.max ; TBOpInj := Pos2Z.inj_max }. -Add Zify BinOp Op_pos_max. - -#[global] -Instance Op_pos_pow : BinOp Pos.pow := - { TBOp := Z.pow ; TBOpInj := Pos2Z.inj_pow }. -Add Zify BinOp Op_pos_pow. - -#[global] -Instance Op_pos_square : UnOp Pos.square := - { TUOp := Z.square ; TUOpInj := Pos2Z.inj_square }. -Add Zify UnOp Op_pos_square. - -#[global] -Instance Op_Pos_Nsucc_double : UnOp Pos.Nsucc_double := - { TUOp x := 2 * x + 1 ; TUOpInj x := ltac:(now destruct x) }. -Add Zify UnOp Op_Pos_Nsucc_double. - -#[global] -Instance Op_Pos_Ndouble : UnOp Pos.Ndouble := - { TUOp x := 2 * x ; TUOpInj x := ltac:(now destruct x) }. -Add Zify UnOp Op_Pos_Ndouble. - -#[global] -Instance Op_xO : UnOp xO := - { TUOp x := 2 * x ; TUOpInj _ := eq_refl }. -Add Zify UnOp Op_xO. - -#[global] -Instance Op_xI : UnOp xI := - { TUOp x := 2 * x + 1 ; TUOpInj _ := eq_refl }. -Add Zify UnOp Op_xI. - -#[global] -Instance Op_xH : CstOp xH := - { TCst := 1%Z ; TCstInj := eq_refl }. -Add Zify CstOp Op_xH. - -#[global] -Instance Op_Z_of_nat : UnOp Z.of_nat:= - { TUOp x := x ; TUOpInj x := eq_refl (Z.of_nat x) }. -Add Zify UnOp Op_Z_of_nat. - -(* zify_N_rel *) -#[global] -Instance Op_N_ge : BinRel N.ge := - { TR := Z.ge ; TRInj := N2Z.inj_ge }. -Add Zify BinRel Op_N_ge. - -#[global] -Instance Op_N_lt : BinRel N.lt := - { TR := Z.lt ; TRInj := N2Z.inj_lt }. -Add Zify BinRel Op_N_lt. - -#[global] -Instance Op_N_gt : BinRel N.gt := - { TR := Z.gt ; TRInj := N2Z.inj_gt }. -Add Zify BinRel Op_N_gt. - -#[global] -Instance Op_N_le : BinRel N.le := - { TR := Z.le ; TRInj := N2Z.inj_le }. -Add Zify BinRel Op_N_le. - -#[global] -Instance Op_eq_N : BinRel (@eq N) := - { TR := @eq Z ; TRInj x y := iff_sym (N2Z.inj_iff x y) }. -Add Zify BinRel Op_eq_N. - -(* zify_N_op *) -#[global] -Instance Op_N_N0 : CstOp N0 := - { TCst := Z0 ; TCstInj := eq_refl }. -Add Zify CstOp Op_N_N0. - -#[global] -Instance Op_N_Npos : UnOp Npos := - { TUOp x := x ; TUOpInj _ := eq_refl }. -Add Zify UnOp Op_N_Npos. - -#[global] -Instance Op_N_of_nat : UnOp N.of_nat := - { TUOp x := x ; TUOpInj := nat_N_Z }. -Add Zify UnOp Op_N_of_nat. - -#[global] -Instance Op_Z_abs_N : UnOp Z.abs_N := - { TUOp := Z.abs ; TUOpInj := N2Z.inj_abs_N }. -Add Zify UnOp Op_Z_abs_N. - -#[global] -Instance Op_N_pos : UnOp N.pos := - { TUOp x := x ; TUOpInj _ := eq_refl }. -Add Zify UnOp Op_N_pos. - -#[global] -Instance Op_N_add : BinOp N.add := - { TBOp := Z.add ; TBOpInj := N2Z.inj_add }. -Add Zify BinOp Op_N_add. - -#[global] -Instance Op_N_min : BinOp N.min := - { TBOp := Z.min ; TBOpInj := N2Z.inj_min }. -Add Zify BinOp Op_N_min. - -#[global] -Instance Op_N_max : BinOp N.max := - { TBOp := Z.max ; TBOpInj := N2Z.inj_max }. -Add Zify BinOp Op_N_max. - -#[global] -Instance Op_N_mul : BinOp N.mul := - { TBOp := Z.mul ; TBOpInj := N2Z.inj_mul }. -Add Zify BinOp Op_N_mul. - -#[global] -Instance Op_N_sub : BinOp N.sub := - { TBOp x y := Z.max 0 (x - y) ; TBOpInj := N2Z.inj_sub_max }. -Add Zify BinOp Op_N_sub. - -#[global] -Instance Op_N_div : BinOp N.div := - { TBOp := Z.div ; TBOpInj := N2Z.inj_div }. -Add Zify BinOp Op_N_div. - -#[global] -Instance Op_N_mod : BinOp N.modulo := - { TBOp := Z.rem ; TBOpInj := N2Z.inj_rem }. -Add Zify BinOp Op_N_mod. - -#[global] -Instance Op_N_pred : UnOp N.pred := - { TUOp x := Z.max 0 (x - 1) ; - TUOpInj x := ltac:(rewrite N.pred_sub; apply N2Z.inj_sub_max) }. -Add Zify UnOp Op_N_pred. - -#[global] -Instance Op_N_succ : UnOp N.succ := - { TUOp x := x + 1 ; TUOpInj := N2Z.inj_succ }. -Add Zify UnOp Op_N_succ. - -#[global] -Instance Op_N_succ_double : UnOp N.succ_double := - { TUOp x := 2 * x + 1 ; TUOpInj x := ltac:(now destruct x) }. -Add Zify UnOp Op_N_succ_double. - -#[global] -Instance Op_N_double : UnOp N.double := - { TUOp x := 2 * x ; TUOpInj x := ltac:(now destruct x) }. -Add Zify UnOp Op_N_double. - -#[global] -Instance Op_N_succ_pos : UnOp N.succ_pos := - { TUOp x := x + 1 ; - TUOpInj x := ltac:(now destruct x; simpl; [| rewrite Pplus_one_succ_r]) }. -Add Zify UnOp Op_N_succ_pos. - -#[global] -Instance Op_N_div2 : UnOp N.div2 := - { TUOp x := x / 2 ; - TUOpInj x := ltac:(now rewrite N2Z.inj_div2, Z.div2_div) }. -Add Zify UnOp Op_N_div2. - -#[global] -Instance Op_N_pow : BinOp N.pow := - { TBOp := Z.pow ; TBOpInj := N2Z.inj_pow }. -Add Zify BinOp Op_N_pow. - -#[global] -Instance Op_N_square : UnOp N.square := - { TUOp x := x * x ; - TUOpInj x := ltac:(now rewrite N.square_spec, N2Z.inj_mul) }. -Add Zify UnOp Op_N_square. - -(** Support for Z - injected to itself *) - -(* zify_Z_rel *) -#[global] -Instance Op_Z_ge : BinRel Z.ge := - { TR := Z.ge ; TRInj x y := iff_refl (x>= y) }. -Add Zify BinRel Op_Z_ge. - -#[global] -Instance Op_Z_lt : BinRel Z.lt := - { TR := Z.lt ; TRInj x y := iff_refl (x < y) }. -Add Zify BinRel Op_Z_lt. - -#[global] -Instance Op_Z_gt : BinRel Z.gt := - { TR := Z.gt ;TRInj x y := iff_refl (x > y) }. -Add Zify BinRel Op_Z_gt. - -#[global] -Instance Op_Z_le : BinRel Z.le := - { TR := Z.le ;TRInj x y := iff_refl (x <= y) }. -Add Zify BinRel Op_Z_le. - -#[global] -Instance Op_eqZ : BinRel (@eq Z) := - { TR := @eq Z ; TRInj x y := iff_refl (x = y) }. -Add Zify BinRel Op_eqZ. - -#[global] -Instance Op_Z_Z0 : CstOp Z0 := - { TCst := Z0 ; TCstInj := eq_refl }. -Add Zify CstOp Op_Z_Z0. - -#[global] -Instance Op_Z_add : BinOp Z.add := - { TBOp := Z.add ; TBOpInj _ _ := eq_refl }. -Add Zify BinOp Op_Z_add. - -#[global] -Instance Op_Z_min : BinOp Z.min := - { TBOp := Z.min ; TBOpInj _ _ := eq_refl }. -Add Zify BinOp Op_Z_min. - -#[global] -Instance Op_Z_max : BinOp Z.max := - { TBOp := Z.max ; TBOpInj _ _ := eq_refl }. -Add Zify BinOp Op_Z_max. - -#[global] -Instance Op_Z_mul : BinOp Z.mul := - { TBOp := Z.mul ; TBOpInj _ _ := eq_refl }. -Add Zify BinOp Op_Z_mul. - -#[global] -Instance Op_Z_sub : BinOp Z.sub := - { TBOp := Z.sub ; TBOpInj _ _ := eq_refl }. -Add Zify BinOp Op_Z_sub. - -#[global] -Instance Op_Z_div : BinOp Z.div := - { TBOp := Z.div ; TBOpInj _ _ := eq_refl }. -Add Zify BinOp Op_Z_div. - -#[global] -Instance Op_Z_mod : BinOp Z.modulo := - { TBOp := Z.modulo ; TBOpInj _ _ := eq_refl }. -Add Zify BinOp Op_Z_mod. - -#[global] -Instance Op_Z_rem : BinOp Z.rem := - { TBOp := Z.rem ; TBOpInj _ _ := eq_refl }. -Add Zify BinOp Op_Z_rem. - -#[global] -Instance Op_Z_quot : BinOp Z.quot := - { TBOp := Z.quot ; TBOpInj _ _ := eq_refl }. -Add Zify BinOp Op_Z_quot. - -#[global] -Instance Op_Z_succ : UnOp Z.succ := - { TUOp x := x + 1 ; TUOpInj _ := eq_refl }. -Add Zify UnOp Op_Z_succ. - -#[global] -Instance Op_Z_pred : UnOp Z.pred := - { TUOp x := x - 1 ; TUOpInj _ := eq_refl }. -Add Zify UnOp Op_Z_pred. - -#[global] -Instance Op_Z_opp : UnOp Z.opp := - { TUOp := Z.opp ; TUOpInj _ := eq_refl }. -Add Zify UnOp Op_Z_opp. - -#[global] -Instance Op_Z_abs : UnOp Z.abs := - { TUOp := Z.abs ; TUOpInj _ := eq_refl }. -Add Zify UnOp Op_Z_abs. - -#[global] -Instance Op_Z_sgn : UnOp Z.sgn := - { TUOp := Z.sgn ; TUOpInj _ := eq_refl }. -Add Zify UnOp Op_Z_sgn. - -#[global] -Instance Op_Z_pow : BinOp Z.pow := - { TBOp := Z.pow ; TBOpInj _ _ := eq_refl }. -Add Zify BinOp Op_Z_pow. - -#[global] -Instance Op_Z_pow_pos : BinOp Z.pow_pos := - { TBOp := Z.pow ; TBOpInj _ _ := eq_refl }. -Add Zify BinOp Op_Z_pow_pos. - -#[global] -Instance Op_Z_double : UnOp Z.double := - { TUOp := Z.mul 2 ; TUOpInj := Z.double_spec }. -Add Zify UnOp Op_Z_double. - -#[global] -Instance Op_Z_pred_double : UnOp Z.pred_double := - { TUOp x := 2 * x - 1 ; TUOpInj := Z.pred_double_spec }. -Add Zify UnOp Op_Z_pred_double. - -#[global] -Instance Op_Z_succ_double : UnOp Z.succ_double := - { TUOp x := 2 * x + 1 ; TUOpInj := Z.succ_double_spec }. -Add Zify UnOp Op_Z_succ_double. - -#[global] -Instance Op_Z_square : UnOp Z.square := - { TUOp x := x * x ; TUOpInj := Z.square_spec }. -Add Zify UnOp Op_Z_square. - -#[global] -Instance Op_Z_div2 : UnOp Z.div2 := - { TUOp x := x / 2 ; TUOpInj := Z.div2_div }. -Add Zify UnOp Op_Z_div2. - -#[global] -Instance Op_Z_quot2 : UnOp Z.quot2 := - { TUOp x := Z.quot x 2 ; TUOpInj := Zeven.Zquot2_quot }. -Add Zify UnOp Op_Z_quot2. - -Lemma of_nat_to_nat_eq x : Z.of_nat (Z.to_nat x) = Z.max 0 x. -Proof. - destruct x; simpl. - - reflexivity. - - now rewrite positive_nat_Z. - - reflexivity. -Qed. - -#[global] -Instance Op_Z_to_nat : UnOp Z.to_nat := - { TUOp x := Z.max 0 x ; TUOpInj := of_nat_to_nat_eq }. -Add Zify UnOp Op_Z_to_nat. - -#[global] -Instance Op_Z_to_pos : UnOp Z.to_pos := - { TUOp x := Z.max 1 x ; - TUOpInj x := ltac:(now simpl; destruct x; - [| rewrite <- Pos2Z.inj_max; rewrite Pos.max_1_l |]) }. -Add Zify UnOp Op_Z_to_pos. - -(** Specification of derived operators over Z *) - -#[global] -Instance ZmaxSpec : BinOpSpec Z.max := - { BPred n m r := n < m /\ r = m \/ m <= n /\ r = n ; BSpec := Z.max_spec }. -Add Zify BinOpSpec ZmaxSpec. - -#[global] -Instance ZminSpec : BinOpSpec Z.min := - { BPred n m r := n < m /\ r = n \/ m <= n /\ r = m ; BSpec := Z.min_spec }. -Add Zify BinOpSpec ZminSpec. - -#[global] -Instance ZsgnSpec : UnOpSpec Z.sgn := - { UPred n r := 0 < n /\ r = 1 \/ 0 = n /\ r = 0 \/ n < 0 /\ r = - 1 ; - USpec := Z.sgn_spec }. -Add Zify UnOpSpec ZsgnSpec. - -#[global] -Instance ZabsSpec : UnOpSpec Z.abs := - { UPred n r := 0 <= n /\ r = n \/ n < 0 /\ r = - n ; USpec := Z.abs_spec }. -Add Zify UnOpSpec ZabsSpec. - -(** Saturate positivity constraints *) - -#[global] -Instance SatPowPos : Saturate Z.pow := - { PArg1 x := 0 < x; - PArg2 y := 0 <= y; - PRes _ _ r := 0 < r; - SatOk := fun x y => Z.pow_pos_nonneg x y}. -Add Zify Saturate SatPowPos. - -#[global] -Instance SatPowNonneg : Saturate Z.pow := - { PArg1 x := 0 <= x; - PArg2 y := True; - PRes _ _ r := 0 <= r; - SatOk a b Ha _ := @Z.pow_nonneg a b Ha }. -Add Zify Saturate SatPowNonneg. - -(* TODO #14736 for compatibility only, should be removed after deprecation *) diff --git a/stdlib/theories/micromega/ZifyN.v b/stdlib/theories/micromega/ZifyN.v deleted file mode 100644 index e78bb14c13ec..000000000000 --- a/stdlib/theories/micromega/ZifyN.v +++ /dev/null @@ -1,58 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* 0 <= x; - PArg2 := fun y => 0 <= y; - PRes := fun _ _ r => 0 <= r; - SatOk := Z_div_nonneg_nonneg - |}. -Add Zify Saturate SatDiv. - -#[global] -Instance SatMod : Saturate Z.modulo := - {| - PArg1 := fun x => 0 <= x; - PArg2 := fun y => 0 <= y; - PRes := fun _ _ r => 0 <= r; - SatOk := Z_mod_nonneg_nonneg - |}. -Add Zify Saturate SatMod. diff --git a/stdlib/theories/micromega/ZifyNat.v b/stdlib/theories/micromega/ZifyNat.v deleted file mode 100644 index fc8017a99773..000000000000 --- a/stdlib/theories/micromega/ZifyNat.v +++ /dev/null @@ -1,58 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* 0 <= x; - PArg2 := fun y => 0 <= y; - PRes := fun _ _ r => 0 <= r; - SatOk := Z_div_nonneg_nonneg - |}. -Add Zify Saturate SatDiv. - -#[global] -Instance SatMod : Saturate Z.modulo := - {| - PArg1 := fun x => 0 <= x; - PArg2 := fun y => 0 <= y; - PRes := fun _ _ r => 0 <= r; - SatOk := Z_mod_nonneg_nonneg - |}. -Add Zify Saturate SatMod. diff --git a/stdlib/theories/micromega/ZifyPow.v b/stdlib/theories/micromega/ZifyPow.v deleted file mode 100644 index d208696c0f67..000000000000 --- a/stdlib/theories/micromega/ZifyPow.v +++ /dev/null @@ -1 +0,0 @@ -Require Export ZifyInst. diff --git a/stdlib/theories/micromega/ZifySint63.v b/stdlib/theories/micromega/ZifySint63.v deleted file mode 100644 index fcab4a88dfaf..000000000000 --- a/stdlib/theories/micromega/ZifySint63.v +++ /dev/null @@ -1,205 +0,0 @@ -Require Import ZArith. -Require Import Sint63. -Require Import ZifyBool. -Import ZifyClasses. - -Lemma to_Z_bounded (x : int) : - (-4611686018427387904 <= to_Z x <= 4611686018427387903)%Z. -Proof. now apply to_Z_bounded. Qed. - -#[global] -Instance Inj_int_Z : InjTyp int Z := - mkinj _ _ to_Z (fun x => -4611686018427387904 <= x <= 4611686018427387903)%Z - to_Z_bounded. -Add Zify InjTyp Inj_int_Z. - -#[global] -Instance Op_max_int : CstOp max_int := - { TCst := 4611686018427387903 ; TCstInj := eq_refl }. -Add Zify CstOp Op_max_int. - -#[global] -Instance Op_min_int : CstOp min_int := - { TCst := -4611686018427387904 ; TCstInj := eq_refl }. -Add Zify CstOp Op_min_int. - -#[global] -Instance Op_digits : CstOp digits := - { TCst := 63 ; TCstInj := eq_refl }. -Add Zify CstOp Op_digits. - -#[global] -Instance Op_size : CstOp size := - { TCst := 63 ; TCstInj := eq_refl }. -Add Zify CstOp Op_size. - -#[global] -Instance Op_wB : CstOp wB := - { TCst := 2^63 ; TCstInj := eq_refl }. -Add Zify CstOp Op_wB. - -Lemma ltb_lt : forall n m, - (n (to_Z n = to_Z m)%sint63. -Proof. - split; intro H. - - rewrite H; reflexivity. - - now apply to_Z_inj. -Qed. - -#[global] -Instance Op_eq : BinRel (@eq int) := - {| TR := @eq Z; TRInj := eq_int_inj |}. -Add Zify BinRel Op_eq. - -Notation cmodwB x := - ((x + 4611686018427387904) mod 9223372036854775808 - 4611686018427387904)%Z. - -#[global] -Instance Op_add : BinOp add := - {| TBOp := fun x y => cmodwB (x + y); TBOpInj := add_spec |}%Z. -Add Zify BinOp Op_add. - -#[global] -Instance Op_sub : BinOp sub := - {| TBOp := fun x y => cmodwB (x - y); TBOpInj := sub_spec |}%Z. -Add Zify BinOp Op_sub. - -#[global] -Instance Op_opp : UnOp Uint63.opp := - {| TUOp := fun x => cmodwB (- x); TUOpInj := (sub_spec 0) |}%Z. -Add Zify UnOp Op_opp. - -#[global] -Instance Op_succ : UnOp succ := - {| TUOp := fun x => cmodwB (x + 1); TUOpInj := succ_spec |}%Z. -Add Zify UnOp Op_succ. - -#[global] -Instance Op_pred : UnOp Uint63.pred := - {| TUOp := fun x => cmodwB (x - 1); TUOpInj := pred_spec |}%Z. -Add Zify UnOp Op_pred. - -#[global] -Instance Op_mul : BinOp mul := - {| TBOp := fun x y => cmodwB (x * y); TBOpInj := mul_spec |}%Z. -Add Zify BinOp Op_mul. - -#[global] -Instance Op_mod : BinOp PrimInt63.mods := - {| TBOp := Z.rem ; TBOpInj := mod_spec |}. -Add Zify BinOp Op_mod. - -#[global] -Instance Op_asr : BinOp asr := - {| TBOp := fun x y => x / 2^ y ; TBOpInj := asr_spec |}%Z. -Add Zify BinOp Op_asr. - -Definition quots (x d : Z) : Z := - if ((x =? -4611686018427387904)%Z && (d =? -1)%Z)%bool then - -4611686018427387904 - else - Z.quot x d. - -Lemma div_quots (x y : int) : to_Z (x / y) = quots (to_Z x) (to_Z y). -Proof. - unfold quots; destruct andb eqn: eq_min_m1. - - rewrite Bool.andb_true_iff, !Z.eqb_eq in eq_min_m1. - change (-4611686018427387904)%Z with (to_Z min_int) in eq_min_m1. - change (-1)%Z with (to_Z (-1)) in eq_min_m1. - destruct eq_min_m1 as [to_Z_x_min to_Z_y_m1]. - now rewrite (to_Z_inj _ _ to_Z_x_min), (to_Z_inj _ _ to_Z_y_m1). - - apply div_spec. - now rewrite Bool.andb_false_iff, !Z.eqb_neq in eq_min_m1. -Qed. - -#[global] -Instance Op_div : BinOp div := - {| TBOp := quots ; TBOpInj := div_quots |}. -Add Zify BinOp Op_div. - -Lemma quots_spec (x y : Z) : - ((x = -4611686018427387904 /\ y = -1 /\ quots x y = -4611686018427387904) - \/ ((x <> -4611686018427387904 \/ y <> -1) /\ quots x y = Z.quot x y))%Z. -Proof. - unfold quots; case andb eqn: eq_min_m1. - - now left; rewrite Bool.andb_true_iff, !Z.eqb_eq in eq_min_m1. - - now right; rewrite Bool.andb_false_iff, !Z.eqb_neq in eq_min_m1. -Qed. - -#[global] -Instance quotsSpec : BinOpSpec quots := - {| BPred := fun x d r : Z => - ((x = -4611686018427387904 /\ d = -1 /\ r = -4611686018427387904) - \/ ((x <> -4611686018427387904 \/ d <> -1) /\ r = Z.quot x d))%Z; - BSpec := quots_spec |}. -Add Zify BinOpSpec quotsSpec. - -#[global] -Instance Op_of_Z : UnOp of_Z := - { TUOp := fun x => cmodwB x; TUOpInj := of_Z_spec }. -Add Zify UnOp Op_of_Z. - -#[global] -Instance Op_to_Z : UnOp to_Z := - { TUOp := fun x => x ; TUOpInj := fun x : int => eq_refl }. -Add Zify UnOp Op_to_Z. - -Lemma is_zeroE : forall n : int, is_zero n = (to_Z n =? 0)%Z. -Proof. - intro n; apply Bool.eq_true_iff_eq. - rewrite is_zero_spec, Z.eqb_eq; split. - - now intro eqn0; rewrite eqn0. - - now change 0%Z with (to_Z 0); apply to_Z_inj. -Qed. - -#[global] -Instance Op_is_zero : UnOp is_zero := - { TUOp := (Z.eqb 0) ; TUOpInj := is_zeroE }. -Add Zify UnOp Op_is_zero. - -#[global] -Instance Op_abs : UnOp abs := - { TUOp := fun x => cmodwB (Z.abs x) ; TUOpInj := abs_spec }. -Add Zify UnOp Op_abs. - -Ltac Zify.zify_convert_to_euclidean_division_equations_flag ::= constr:(true). diff --git a/stdlib/theories/micromega/ZifyUint63.v b/stdlib/theories/micromega/ZifyUint63.v deleted file mode 100644 index b753377d4740..000000000000 --- a/stdlib/theories/micromega/ZifyUint63.v +++ /dev/null @@ -1,209 +0,0 @@ -Require Import ZArith. -Require Import Uint63. -Require Import ZifyBool. -Import ZifyClasses. - -Lemma to_Z_bounded : forall x, (0 <= to_Z x < 9223372036854775808)%Z. -Proof. apply to_Z_bounded. Qed. - -#[global] -Instance Inj_int_Z : InjTyp int Z := - mkinj _ _ to_Z (fun x => 0 <= x < 9223372036854775808)%Z to_Z_bounded. -Add Zify InjTyp Inj_int_Z. - -#[global] -Instance Op_max_int : CstOp max_int := - { TCst := 9223372036854775807 ; TCstInj := eq_refl }. -Add Zify CstOp Op_max_int. - -#[global] -Instance Op_digits : CstOp digits := - { TCst := 63 ; TCstInj := eq_refl }. -Add Zify CstOp Op_digits. - -#[global] -Instance Op_size : CstOp size := - { TCst := 63 ; TCstInj := eq_refl }. -Add Zify CstOp Op_size. - -#[global] -Instance Op_wB : CstOp wB := - { TCst := 2^63 ; TCstInj := eq_refl }. -Add Zify CstOp Op_wB. - -Lemma ltb_lt : forall n m, - (n (Ļ† n = Ļ† m)%uint63. -Proof. - split; intro H. - - rewrite H ; reflexivity. - - apply to_Z_inj; auto. -Qed. - -#[global] -Instance Op_eq : BinRel (@eq int) := - {| TR := @eq Z; TRInj := eq_int_inj |}. -Add Zify BinRel Op_eq. - -#[global] -Instance Op_add : BinOp add := - {| TBOp := fun x y => (x + y) mod 9223372036854775808%Z; TBOpInj := add_spec |}%Z. -Add Zify BinOp Op_add. - -#[global] -Instance Op_sub : BinOp sub := - {| TBOp := fun x y => (x - y) mod 9223372036854775808%Z; TBOpInj := sub_spec |}%Z. -Add Zify BinOp Op_sub. - -#[global] -Instance Op_opp : UnOp Uint63.opp := - {| TUOp := (fun x => (- x) mod 9223372036854775808)%Z; TUOpInj := (sub_spec 0) |}%Z. -Add Zify UnOp Op_opp. - -#[global] -Instance Op_oppcarry : UnOp oppcarry := - {| TUOp := (fun x => 2^63 - x - 1)%Z; TUOpInj := oppcarry_spec |}%Z. -Add Zify UnOp Op_oppcarry. - -#[global] -Instance Op_succ : UnOp succ := - {| TUOp := (fun x => (x + 1) mod 2^63)%Z; TUOpInj := succ_spec |}%Z. -Add Zify UnOp Op_succ. - -#[global] -Instance Op_pred : UnOp Uint63.pred := - {| TUOp := (fun x => (x - 1) mod 2^63)%Z; TUOpInj := pred_spec |}%Z. -Add Zify UnOp Op_pred. - -#[global] -Instance Op_mul : BinOp mul := - {| TBOp := fun x y => (x * y) mod 9223372036854775808%Z; TBOpInj := mul_spec |}%Z. -Add Zify BinOp Op_mul. - -#[global] -Instance Op_gcd : BinOp gcd:= - {| TBOp := (fun x y => Zgcd_alt.Zgcdn (2 * 63)%nat y x) ; TBOpInj := to_Z_gcd |}. -Add Zify BinOp Op_gcd. - -#[global] -Instance Op_mod : BinOp Uint63.mod := - {| TBOp := Z.modulo ; TBOpInj := mod_spec |}. -Add Zify BinOp Op_mod. - -#[global] -Instance Op_subcarry : BinOp subcarry := - {| TBOp := (fun x y => (x - y - 1) mod 2^63)%Z ; TBOpInj := subcarry_spec |}. -Add Zify BinOp Op_subcarry. - -#[global] -Instance Op_addcarry : BinOp addcarry := - {| TBOp := (fun x y => (x + y + 1) mod 2^63)%Z ; TBOpInj := addcarry_spec |}. -Add Zify BinOp Op_addcarry. - -#[global] -Instance Op_lsr : BinOp lsr := - {| TBOp := (fun x y => x / 2^ y)%Z ; TBOpInj := lsr_spec |}. -Add Zify BinOp Op_lsr. - -#[global] -Instance Op_lsl : BinOp lsl := - {| TBOp := (fun x y => (x * 2^ y) mod 2^ 63)%Z ; TBOpInj := lsl_spec |}. -Add Zify BinOp Op_lsl. - -#[global] -Instance Op_lor : BinOp Uint63.lor := - {| TBOp := Z.lor ; TBOpInj := lor_spec' |}. -Add Zify BinOp Op_lor. - -#[global] -Instance Op_land : BinOp Uint63.land := - {| TBOp := Z.land ; TBOpInj := land_spec' |}. -Add Zify BinOp Op_land. - -#[global] -Instance Op_lxor : BinOp Uint63.lxor := - {| TBOp := Z.lxor ; TBOpInj := lxor_spec' |}. -Add Zify BinOp Op_lxor. - -#[global] -Instance Op_div : BinOp div := - {| TBOp := Z.div ; TBOpInj := div_spec |}. -Add Zify BinOp Op_div. - -#[global] -Instance Op_bit : BinOp bit := - {| TBOp := Z.testbit ; TBOpInj := bitE |}. -Add Zify BinOp Op_bit. - -#[global] -Instance Op_of_Z : UnOp of_Z := - { TUOp := (fun x => x mod 9223372036854775808)%Z; TUOpInj := of_Z_spec }. -Add Zify UnOp Op_of_Z. - -#[global] -Instance Op_to_Z : UnOp to_Z := - { TUOp := fun x => x ; TUOpInj := fun x : int => eq_refl }. -Add Zify UnOp Op_to_Z. - -#[global] -Instance Op_is_zero : UnOp is_zero := - { TUOp := (Z.eqb 0) ; TUOpInj := is_zeroE }. -Add Zify UnOp Op_is_zero. - -Lemma is_evenE : forall x, - is_even x = Z.even Ļ† (x)%uint63. -Proof. - intros. - generalize (is_even_spec x). - rewrite Z_evenE. - destruct (is_even x). - - symmetry. apply Z.eqb_eq. auto. - - symmetry. apply Z.eqb_neq. congruence. -Qed. - -#[global] -Instance Op_is_even : UnOp is_even := - { TUOp := Z.even ; TUOpInj := is_evenE }. -Add Zify UnOp Op_is_even. - - -Ltac Zify.zify_convert_to_euclidean_division_equations_flag ::= constr:(true). diff --git a/stdlib/theories/micromega/Ztac.v b/stdlib/theories/micromega/Ztac.v deleted file mode 100644 index b8d73b4b6e52..000000000000 --- a/stdlib/theories/micromega/Ztac.v +++ /dev/null @@ -1,146 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* x <= y /\ y <= x. -Proof. split; apply Z.eq_le_incl; auto 1 using eq_sym. Qed. - -#[deprecated(use=Z.lt_trichotomy, since="9.0")] -Lemma elim_concl_eq : - forall x y, (x < y \/ y < x -> False) -> x = y. -Proof. intros; pose proof Z.lt_trichotomy x y; intuition idtac. Qed. - -#[deprecated(use=Z.nlt_ge, since="9.0")] -Lemma elim_concl_le : - forall x y, (y < x -> False) -> x <= y. -Proof. intros *. apply Z.nlt_ge. Qed. - -#[deprecated(use=Z.nle_gt, since="9.0")] -Lemma elim_concl_lt : - forall x y, (y <= x -> False) -> x < y. -Proof. intros *. apply Z.nle_gt. Qed. - -#[deprecated(use=Z.le_succ_l, since="9.0")] -Lemma Zlt_le_add_1 : forall n m : Z, n < m -> n + 1 <= m. -Proof. apply Z.le_succ_l. Qed. - -#[deprecated(since="9.0")] -Local Lemma Private_Zle_minus_le_0 n m : m <= n -> 0 <= n - m. -Proof. - apply Z.le_0_sub. -Qed. - -#[deprecated(since="9.0")] -Ltac normZ := - repeat - match goal with - | H : _ < _ |- _ => apply Zlt_le_add_1 in H - | H : ?Y <= _ |- _ => - lazymatch Y with - | 0 => fail - | _ => apply Private_Zle_minus_le_0 in H - end - | H : _ >= _ |- _ => apply Z.ge_le in H - | H : _ > _ |- _ => apply Z.gt_lt in H - | H : _ = _ |- _ => apply eq_incl in H ; destruct H - | |- @eq Z _ _ => apply elim_concl_eq ; let H := fresh "HZ" in intros [H|H] - | |- _ <= _ => apply elim_concl_le ; intros - | |- _ < _ => apply elim_concl_lt ; intros - | |- _ >= _ => apply Z.le_ge - end. - -Inductive proof_deprecated := -| Hyp_deprecated (e : Z) (prf : 0 <= e) -| Add_deprecated (p1 p2: proof_deprecated) -| Mul_deprecated (p1 p2: proof_deprecated) -| Cst_deprecated (c : Z) -. - -#[deprecated(since="9.0")] -Notation proof := proof_deprecated (only parsing). -#[deprecated(since="9.0")] -Notation Hyp := Hyp_deprecated (only parsing). -#[deprecated(since="9.0")] -Notation Add := Add_deprecated (only parsing). -#[deprecated(since="9.0")] -Notation Mul := Mul_deprecated (only parsing). -#[deprecated(since="9.0")] -Notation Cst := Cst_deprecated (only parsing). - -#[deprecated(use=Z.add_nonneg_nonneg, since="9.0")] -Lemma add_le : forall e1 e2, 0 <= e1 -> 0 <= e2 -> 0 <= e1+e2. -Proof. apply Z.add_nonneg_nonneg. Qed. - -#[deprecated(use=Z.mul_nonneg_nonneg, since="9.0")] -Lemma mul_le : forall e1 e2, 0 <= e1 -> 0 <= e2 -> 0 <= e1*e2. -Proof. apply Z.mul_nonneg_nonneg. Qed. - -#[deprecated(since="9.0")] -Local Definition Private_Z_le_dec x y : {x <= y} + {~ x <= y}. -Proof. - unfold Z.le; case Z.compare; (now left) || (right; tauto). -Defined. - -#[deprecated(since="9.0")] -Fixpoint eval_proof (p : proof) : { e : Z | 0 <= e} := - match p with - | Hyp e prf => exist _ e prf - | Add p1 p2 => let (e1,p1) := eval_proof p1 in - let (e2,p2) := eval_proof p2 in - exist _ _ (add_le _ _ p1 p2) - | Mul p1 p2 => let (e1,p1) := eval_proof p1 in - let (e2,p2) := eval_proof p2 in - exist _ _ (mul_le _ _ p1 p2) - | Cst c => match Private_Z_le_dec 0 c with - | left prf => exist _ _ prf - | _ => exist _ _ Z.le_0_1 - end - end. - -#[deprecated(since="9.0")] -Ltac lia_step p := - let H := fresh in - let prf := (eval cbn - [Z.le Z.mul Z.opp Z.sub Z.add] in (eval_proof p)) in - match prf with - | @exist _ _ _ ?P => pose proof P as H - end ; ring_simplify in H. - -#[deprecated(since="9.0")] -Ltac lia_contr := - match goal with - | H : 0 <= - (Zpos _) |- _ => - rewrite <- Z.leb_le in H; - compute in H ; discriminate - | H : 0 <= (Zneg _) |- _ => - rewrite <- Z.leb_le in H; - compute in H ; discriminate - end. - -#[deprecated(since="9.0")] -Ltac lia p := - lia_step p ; lia_contr. - -#[deprecated(since="9.0")] -Ltac slia H1 H2 := - normZ ; lia (Add (Hyp _ H1) (Hyp _ H2)). - -Arguments Hyp {_} prf. diff --git a/stdlib/theories/nsatz/Nsatz.v b/stdlib/theories/nsatz/Nsatz.v deleted file mode 100644 index f9fd671f2fc2..000000000000 --- a/stdlib/theories/nsatz/Nsatz.v +++ /dev/null @@ -1,93 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* - lazymatch isZcst z with - | true => open_constr:(PEc z) - | false => open_constr:(tt) - end - | _ => open_constr:(tt) - end. - -Lemma R_one_zero: 1%R <> 0%R. -discrR. -Qed. - -#[global] -Instance Rcri: (Cring (Rr:=Rri)). -red. exact Rmult_comm. Defined. - -#[global] -Instance Rdi : (Integral_domain (Rcr:=Rcri)). -constructor. -- exact Rmult_integral. -- exact R_one_zero. -Defined. diff --git a/stdlib/theories/nsatz/NsatzTactic.v b/stdlib/theories/nsatz/NsatzTactic.v deleted file mode 100644 index ebf01357bd67..000000000000 --- a/stdlib/theories/nsatz/NsatzTactic.v +++ /dev/null @@ -1,514 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* x == y. -intros x y H; setoid_replace x with ((x - y) + y); simpl; - [setoid_rewrite H | idtac]; simpl. -- cring. -- cring. -Qed. - -Lemma psos_r1: forall x y, x == y -> x - y == 0. -intros x y H; simpl; setoid_rewrite H; simpl; cring. -Qed. - -Lemma nsatzR_diff: forall x y:R, not (x == y) -> not (x - y == 0). -intros. -intro; apply H. -simpl; setoid_replace x with ((x - y) + y). -- simpl. - setoid_rewrite H0. - simpl; cring. -- simpl. simpl; cring. -Qed. - -(* adpatation du code de Benjamin aux setoides *) -Export Ring_polynom. -Export InitialRing. - -Definition PolZ := Pol Z. -Definition PEZ := PExpr Z. - -Definition P0Z : PolZ := P0 (C:=Z) 0%Z. - -Definition PolZadd : PolZ -> PolZ -> PolZ := - @Padd Z 0%Z Z.add Z.eqb. - -Definition PolZmul : PolZ -> PolZ -> PolZ := - @Pmul Z 0%Z 1%Z Z.add Z.mul Z.eqb. - -Definition PolZeq := @Peq Z Z.eqb. - -Definition norm := - @norm_aux Z 0%Z 1%Z Z.add Z.mul Z.sub Z.opp Z.eqb. - -Fixpoint mult_l (la : list PEZ) (lp: list PolZ) : PolZ := - match la, lp with - | a::la, p::lp => PolZadd (PolZmul (norm a) p) (mult_l la lp) - | _, _ => P0Z - end. - -Fixpoint compute_list (lla: list (list PEZ)) (lp:list PolZ) := - match lla with - | List.nil => lp - | la::lla => compute_list lla ((mult_l la lp)::lp) - end. - -Definition check (lpe:list PEZ) (qe:PEZ) (certif: list (list PEZ) * list PEZ) := - let (lla, lq) := certif in - let lp := List.map norm lpe in - PolZeq (norm qe) (mult_l lq (compute_list lla lp)). - - -(* Correction *) -Definition PhiR : list R -> PolZ -> R := - (Pphi ring0 add mul - (InitialRing.gen_phiZ ring0 ring1 add mul opp)). - -Definition PEevalR : list R -> PEZ -> R := - PEeval ring0 ring1 add mul sub opp - (gen_phiZ ring0 ring1 add mul opp) - N.to_nat pow. - -Lemma P0Z_correct : forall l, PhiR l P0Z = 0. -Proof. trivial. Qed. - -Lemma Rext: ring_eq_ext add mul opp _==_. -Proof. -constructor; solve_proper. -Qed. - -Lemma Rset : Setoid_Theory R _==_. -apply ring_setoid. -Qed. - -Definition Rtheory:ring_theory ring0 ring1 add mul sub opp _==_. -apply mk_rt. -- apply ring_add_0_l. -- apply ring_add_comm. -- apply ring_add_assoc. -- apply ring_mul_1_l. -- apply cring_mul_comm. -- apply ring_mul_assoc. -- apply ring_distr_l. -- apply ring_sub_def. -- apply ring_opp_def. -Defined. - -Lemma PolZadd_correct : forall P' P l, - PhiR l (PolZadd P P') == ((PhiR l P) + (PhiR l P')). -Proof. -unfold PolZadd, PhiR. intros. simpl. - refine (Padd_ok Rset Rext (Rth_ARth Rset Rext Rtheory) - (gen_phiZ_morph Rset Rext Rtheory) _ _ _). -Qed. - -Lemma PolZmul_correct : forall P P' l, - PhiR l (PolZmul P P') == ((PhiR l P) * (PhiR l P')). -Proof. -unfold PolZmul, PhiR. intros. - refine (Pmul_ok Rset Rext (Rth_ARth Rset Rext Rtheory) - (gen_phiZ_morph Rset Rext Rtheory) _ _ _). -Qed. - -Lemma R_power_theory - : Ring_theory.power_theory ring1 mul _==_ N.to_nat pow. -apply Ring_theory.mkpow_th. unfold pow. intros. rewrite Nnat.N2Nat.id. -reflexivity. Qed. - -Lemma norm_correct : - forall (l : list R) (pe : PEZ), PEevalR l pe == PhiR l (norm pe). -Proof. - intros;apply (norm_aux_spec Rset Rext (Rth_ARth Rset Rext Rtheory) - (gen_phiZ_morph Rset Rext Rtheory) R_power_theory). -Qed. - -Lemma PolZeq_correct : forall P P' l, - PolZeq P P' = true -> - PhiR l P == PhiR l P'. -Proof. - intros;apply - (Peq_ok Rset Rext (gen_phiZ_morph Rset Rext Rtheory));trivial. -Qed. - -Fixpoint Cond0 (A:Type) (Interp:A->R) (l:list A) : Prop := - match l with - | List.nil => True - | a::l => Interp a == 0 /\ Cond0 A Interp l - end. - -Lemma mult_l_correct : forall l la lp, - Cond0 PolZ (PhiR l) lp -> - PhiR l (mult_l la lp) == 0. -Proof. - induction la;simpl;intros. - - cring. - - destruct lp;trivial. - + simpl. cring. - + simpl in H;destruct H. - rewrite PolZadd_correct. - simpl. rewrite PolZmul_correct. simpl. rewrite H. - rewrite IHla. - * cring. - * trivial. -Qed. - -Lemma compute_list_correct : forall l lla lp, - Cond0 PolZ (PhiR l) lp -> - Cond0 PolZ (PhiR l) (compute_list lla lp). -Proof. - induction lla;simpl;intros;trivial. - apply IHlla;simpl;split;trivial. - apply mult_l_correct;trivial. -Qed. - -Lemma check_correct : - forall l lpe qe certif, - check lpe qe certif = true -> - Cond0 PEZ (PEevalR l) lpe -> - PEevalR l qe == 0. -Proof. - unfold check;intros l lpe qe (lla, lq) H2 H1. - apply PolZeq_correct with (l:=l) in H2. - rewrite norm_correct, H2. - apply mult_l_correct. - apply compute_list_correct. - clear H2 lq lla qe;induction lpe;simpl;trivial. - simpl in H1;destruct H1. - rewrite <- norm_correct;auto. -Qed. - -(* fin *) - -Definition R2:= 1 + 1. - -Fixpoint IPR p {struct p}: R := - match p with - xH => ring1 - | xO xH => 1+1 - | xO p1 => R2*(IPR p1) - | xI xH => 1+(1+1) - | xI p1 => 1+(R2*(IPR p1)) - end. - -Definition IZR1 z := - match z with Z0 => 0 - | Zpos p => IPR p - | Zneg p => -(IPR p) - end. - -Fixpoint interpret3 t fv {struct t}: R := - match t with - | (PEadd t1 t2) => - let v1 := interpret3 t1 fv in - let v2 := interpret3 t2 fv in (v1 + v2) - | (PEmul t1 t2) => - let v1 := interpret3 t1 fv in - let v2 := interpret3 t2 fv in (v1 * v2) - | (PEsub t1 t2) => - let v1 := interpret3 t1 fv in - let v2 := interpret3 t2 fv in (v1 - v2) - | (PEopp t1) => - let v1 := interpret3 t1 fv in (-v1) - | (PEpow t1 t2) => - let v1 := interpret3 t1 fv in pow v1 (N.to_nat t2) - | (PEc t1) => (IZR1 t1) - | PEO => 0 - | PEI => 1 - | (PEX _ n) => List.nth (pred (Pos.to_nat n)) fv 0 - end. - - -End nsatz1. - -Ltac equality_to_goal H x y:= - (* eliminate trivial hypotheses, but it takes time!: - let h := fresh "nH" in - (assert (h:equality x y); - [solve [cring] | clear H; clear h]) - || *) try (generalize (@psos_r1 _ _ _ _ _ _ _ _ _ _ _ x y H); clear H) -. - -Ltac equalities_to_goal := - lazymatch goal with - | H: (_ ?x ?y) |- _ => equality_to_goal H x y - | H: (_ _ ?x ?y) |- _ => equality_to_goal H x y - | H: (_ _ _ ?x ?y) |- _ => equality_to_goal H x y - | H: (_ _ _ _ ?x ?y) |- _ => equality_to_goal H x y -(* extension possible :-) *) - | H: (?x == ?y) |- _ => equality_to_goal H x y - end. - -(* lp est incluse dans fv. La met en tete. *) - -Ltac parametres_en_tete fv lp := - match fv with - | (@nil _) => lp - | (@cons _ ?x ?fv1) => - let res := AddFvTail x lp in - parametres_en_tete fv1 res - end. - -Ltac append1 a l := - match l with - | (@nil _) => constr:(cons a l) - | (cons ?x ?l) => let l' := append1 a l in constr:(cons x l') - end. - -Ltac rev l := - match l with - |(@nil _) => l - | (cons ?x ?l) => let l' := rev l in append1 x l' - end. - -Ltac nsatz_call_n info nparam p rr lp kont := -(* idtac "Trying power: " rr;*) - let ll := constr:(PEc info :: PEc nparam :: PEpow p rr :: lp) in -(* idtac "calcul...";*) - nsatz_compute ll; -(* idtac "done";*) - match goal with - | |- (?c::PEpow _ ?r::?lq0)::?lci0 = _ -> _ => - intros _; - let lci := fresh "lci" in - set (lci:=lci0); - let lq := fresh "lq" in - set (lq:=lq0); - kont c rr lq lci - end. - -Ltac nsatz_call radicalmax info nparam p lp kont := - let rec try_n n := - lazymatch n with - | 0%N => fail - | _ => - (let r := eval compute in (N.sub radicalmax (N.pred n)) in - nsatz_call_n info nparam p r lp kont) || - let n' := eval compute in (N.pred n) in try_n n' - end in - try_n radicalmax. - - -Ltac lterm_goal g := - match g with - ?b1 == ?b2 => constr:(b1::b2::nil) - | ?b1 == ?b2 -> ?g => let l := lterm_goal g in constr:(b1::b2::l) - end. - -Ltac reify_goal l le lb:= - match le with - nil => idtac - | ?e::?le1 => - match lb with - ?b::?lb1 => (* idtac "b="; idtac b;*) - let x := fresh "B" in - set (x:= b) at 1; - change x with (interpret3 e l); - clear x; - reify_goal l le1 lb1 - end - end. - -Ltac get_lpol g := - match g with - (interpret3 ?p _) == _ => constr:(p::nil) - | (interpret3 ?p _) == _ -> ?g => - let l := get_lpol g in constr:(p::l) - end. - -(** We only make use of [discrR] if [nsatz] support for reals is - loaded. To do this, we redefine this tactic in Nsatz.v to make - use of real discrimination. *) -Ltac nsatz_internal_discrR := idtac. - -Ltac nsatz_generic radicalmax info lparam lvar := - let nparam := eval compute in (Z.of_nat (List.length lparam)) in - match goal with - |- ?g => let lb := lterm_goal g in - match (lazymatch lvar with - |(@nil _) => - lazymatch lparam with - |(@nil _) => - let r := list_reifyl0 lb in - r - |_ => - let reif := list_reifyl0 lb in - match reif with - |(?fv, ?le) => - let fv := parametres_en_tete fv lparam in - (* we reify a second time, with the good order - for variables *) - list_reifyl fv lb - end - end - |_ => - let fv := parametres_en_tete lvar lparam in - list_reifyl fv lb - end) with - |(?fv, ?le) => - reify_goal fv le lb ; - match goal with - |- ?g => - let lp := get_lpol g in - let lpol := eval compute in (List.rev lp) in - intros; - - let SplitPolyList kont := - match lpol with - | ?p2::?lp2 => kont p2 lp2 - | _ => idtac "polynomial not in the ideal" - end in - - SplitPolyList ltac:(fun p lp => - let p21 := fresh "p21" in - let lp21 := fresh "lp21" in - set (p21:=p) ; - set (lp21:=lp); -(* idtac "nparam:"; idtac nparam; idtac "p:"; idtac p; idtac "lp:"; idtac lp; *) - nsatz_call radicalmax info nparam p lp ltac:(fun c r lq lci => - let q := fresh "q" in - set (q := PEmul c (PEpow p21 r)); - let Hg := fresh "Hg" in - assert (Hg:check lp21 q (lci,lq) = true); - [ (vm_compute;reflexivity) || idtac "invalid nsatz certificate" - | let Hg2 := fresh "Hg" in - assert (Hg2: (interpret3 q fv) == 0); - [ (*simpl*) idtac; - generalize (@check_correct _ _ _ _ _ _ _ _ _ _ _ fv lp21 q (lci,lq) Hg); - let cc := fresh "H" in - (*simpl*) idtac; intro cc; apply cc; clear cc; - (*simpl*) idtac; - repeat (split;[assumption|idtac]); exact I - | (*simpl in Hg2;*) (*simpl*) idtac; - apply Rintegral_domain_pow with (interpret3 c fv) (N.to_nat r); - (*simpl*) idtac; - try apply integral_domain_one_zero; - try apply integral_domain_minus_one_zero; - try trivial; - try exact integral_domain_one_zero; - try exact integral_domain_minus_one_zero - || (solve [simpl; unfold R2, equality, eq_notation, addition, add_notation, - one, one_notation, multiplication, mul_notation, zero, zero_notation; - nsatz_internal_discrR || lia ]) - || ((*simpl*) idtac) || idtac "could not prove discrimination result" - ] - ] -) -) -end end end . - -Ltac nsatz_default:= - intros; - try apply (@psos_r1b _ _ _ _ _ _ _ _ _ _ _); - match goal with |- (@equality ?r _ _ _) => - repeat equalities_to_goal; - nsatz_generic 6%N 1%Z (@nil r) (@nil r) - end. - -Tactic Notation "nsatz" := nsatz_default. - -Tactic Notation "nsatz" "with" - "radicalmax" ":=" constr(radicalmax) - "strategy" ":=" constr(info) - "parameters" ":=" constr(lparam) - "variables" ":=" constr(lvar):= - intros; - try apply (@psos_r1b _ _ _ _ _ _ _ _ _ _ _); - match goal with |- (@equality ?r _ _ _) => - repeat equalities_to_goal; - nsatz_generic radicalmax info lparam lvar - end. - -(* Rational numbers *) -Require Import QArith. - -#[global] -Instance Qops: (@Ring_ops Q 0%Q 1%Q Qplus Qmult Qminus Qopp Qeq). -Defined. - -#[global] -Instance Qri : (Ring (Ro:=Qops)). -constructor. -- apply Q_Setoid. -- apply Qplus_comp. -- apply Qmult_comp. -- apply Qminus_comp. -- apply Qopp_comp. -- exact Qplus_0_l. -- exact Qplus_comm. -- apply Qplus_assoc. -- exact Qmult_1_l. -- exact Qmult_1_r. -- apply Qmult_assoc. -- apply Qmult_plus_distr_l. -- intros. apply Qmult_plus_distr_r. -- reflexivity. -- exact Qplus_opp_r. -Defined. - -Lemma Q_one_zero: not (Qeq 1%Q 0%Q). -Proof. unfold Qeq. simpl. lia. Qed. - -#[global] -Instance Qcri: (Cring (Rr:=Qri)). -red. exact Qmult_comm. Defined. - -#[global] -Instance Qdi : (Integral_domain (Rcr:=Qcri)). -constructor. -- exact Qmult_integral. -- exact Q_one_zero. -Defined. - -(* Integers *) -Lemma Z_one_zero: 1%Z <> 0%Z. -Proof. lia. Qed. - -#[global] -Instance Zcri: (Cring (Rr:=Zr)). -red. exact Z.mul_comm. Defined. - -#[global] -Instance Zdi : (Integral_domain (Rcr:=Zcri)). -constructor. -- exact Zmult_integral. -- exact Z_one_zero. -Defined. diff --git a/stdlib/theories/omega/OmegaLemmas.v b/stdlib/theories/omega/OmegaLemmas.v deleted file mode 100644 index 266c9b728096..000000000000 --- a/stdlib/theories/omega/OmegaLemmas.v +++ /dev/null @@ -1,263 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* 0 <= x -> 0 <= y. -Proof. -now intros ->. -Qed. - -Lemma OMEGA2 x y : 0 <= x -> 0 <= y -> 0 <= x + y. -Proof. -Z.order_pos. -Qed. - -Lemma OMEGA3 x y k : k > 0 -> x = y * k -> x = 0 -> y = 0. -Proof. -intros LT -> EQ. apply Z.mul_eq_0 in EQ. destruct EQ; now subst. -Qed. - -Lemma OMEGA4 x y z : x > 0 -> y > x -> z * y + x <> 0. -Proof. -Z.swap_greater. intros Hx Hxy. -rewrite Z.add_move_0_l, <- Z.mul_opp_l. -destruct (Z.lt_trichotomy (-z) 1) as [LT|[->|GT]]. -- intro. revert LT. apply Z.le_ngt, (Z.le_succ_l 0). - apply Z.mul_pos_cancel_r with y; Z.order. -- Z.nzsimpl. Z.order. -- rewrite (Z.mul_lt_mono_pos_r y), Z.mul_1_l in GT; Z.order. -Qed. - -Lemma OMEGA5 x y z : x = 0 -> y = 0 -> x + y * z = 0. -Proof. -now intros -> ->. -Qed. - -Lemma OMEGA6 x y z : 0 <= x -> y = 0 -> 0 <= x + y * z. -Proof. -intros H ->. now Z.nzsimpl. -Qed. - -Lemma OMEGA7 x y z t : - z > 0 -> t > 0 -> 0 <= x -> 0 <= y -> 0 <= x * z + y * t. -Proof. -intros. Z.swap_greater. Z.order_pos. -Qed. - -Lemma OMEGA8 x y : 0 <= x -> 0 <= y -> x = - y -> x = 0. -Proof. -intros H1 H2 H3. rewrite <- Z.opp_nonpos_nonneg in H2. Z.order. -Qed. - -Lemma OMEGA9 x y z t : y = 0 -> x = z -> y + (- x + z) * t = 0. -Proof. -intros. subst. now rewrite Z.add_opp_diag_l. -Qed. - -Lemma OMEGA10 v c1 c2 l1 l2 k1 k2 : - (v * c1 + l1) * k1 + (v * c2 + l2) * k2 = - v * (c1 * k1 + c2 * k2) + (l1 * k1 + l2 * k2). -Proof. -rewrite ?Z.mul_add_distr_r, ?Z.mul_add_distr_l, ?Z.mul_assoc. -rewrite <- !Z.add_assoc. f_equal. apply Z.add_shuffle3. -Qed. - -Lemma OMEGA11 v1 c1 l1 l2 k1 : - (v1 * c1 + l1) * k1 + l2 = v1 * (c1 * k1) + (l1 * k1 + l2). -Proof. -rewrite ?Z.mul_add_distr_r, ?Z.mul_add_distr_l, ?Z.mul_assoc. -now rewrite Z.add_assoc. -Qed. - -Lemma OMEGA12 v2 c2 l1 l2 k2 : - l1 + (v2 * c2 + l2) * k2 = v2 * (c2 * k2) + (l1 + l2 * k2). -Proof. -rewrite ?Z.mul_add_distr_r, ?Z.mul_add_distr_l, ?Z.mul_assoc. -apply Z.add_shuffle3. -Qed. - -Lemma OMEGA13 (v l1 l2 : Z) (x : positive) : - v * Zpos x + l1 + (v * Zneg x + l2) = l1 + l2. -Proof. - rewrite Z.add_shuffle1. - rewrite <- Z.mul_add_distr_l, <- Pos2Z.opp_neg, Z.add_opp_diag_r. - now Z.nzsimpl. -Qed. - -Lemma OMEGA14 (v l1 l2 : Z) (x : positive) : - v * Zneg x + l1 + (v * Zpos x + l2) = l1 + l2. -Proof. - rewrite Z.add_shuffle1. - rewrite <- Z.mul_add_distr_l, <- Pos2Z.opp_neg, Z.add_opp_diag_r. - now Z.nzsimpl. -Qed. - -Lemma OMEGA15 v c1 c2 l1 l2 k2 : - v * c1 + l1 + (v * c2 + l2) * k2 = v * (c1 + c2 * k2) + (l1 + l2 * k2). -Proof. - rewrite ?Z.mul_add_distr_r, ?Z.mul_add_distr_l, ?Z.mul_assoc. - apply Z.add_shuffle1. -Qed. - -Lemma OMEGA16 v c l k : (v * c + l) * k = v * (c * k) + l * k. -Proof. - now rewrite ?Z.mul_add_distr_r, ?Z.mul_add_distr_l, ?Z.mul_assoc. -Qed. - -Lemma OMEGA17 x y z : Zne x 0 -> y = 0 -> Zne (x + y * z) 0. -Proof. - unfold Zne, not. intros NE EQ. subst. now Z.nzsimpl. -Qed. - -Lemma OMEGA18 x y k : x = y * k -> Zne x 0 -> Zne y 0. -Proof. - unfold Zne, not. intros. subst; auto. -Qed. - -Lemma OMEGA19 x : Zne x 0 -> 0 <= x + -1 \/ 0 <= x * -1 + -1. -Proof. - unfold Zne. intros Hx. apply Z.lt_gt_cases in Hx. - destruct Hx as [LT|GT]. - - right. change (-1) with (-(1)). - rewrite Z.mul_opp_r, <- Z.opp_add_distr. Z.nzsimpl. - rewrite Z.opp_nonneg_nonpos. now apply Z.le_succ_l. - - left. now apply Z.lt_le_pred. -Qed. - -Lemma OMEGA20 x y z : Zne x 0 -> y = 0 -> Zne (x + y * z) 0. -Proof. - unfold Zne, not. intros H1 H2 H3; apply H1; rewrite H2 in H3; - simpl in H3; rewrite Z.add_0_r in H3; trivial with arith. -Qed. - -Definition fast_Zplus_comm (x y : Z) (P : Z -> Prop) - (H : P (y + x)) := eq_ind_r P H (Z.add_comm x y). - -Definition fast_Zplus_assoc_reverse (n m p : Z) (P : Z -> Prop) - (H : P (n + (m + p))) := eq_ind_r P H (Zplus_assoc_reverse n m p). - -Definition fast_Zplus_assoc (n m p : Z) (P : Z -> Prop) - (H : P (n + m + p)) := eq_ind_r P H (Z.add_assoc n m p). - -Definition fast_Zplus_permute (n m p : Z) (P : Z -> Prop) - (H : P (m + (n + p))) := eq_ind_r P H (Z.add_shuffle3 n m p). - -Definition fast_OMEGA10 (v c1 c2 l1 l2 k1 k2 : Z) (P : Z -> Prop) - (H : P (v * (c1 * k1 + c2 * k2) + (l1 * k1 + l2 * k2))) := - eq_ind_r P H (OMEGA10 v c1 c2 l1 l2 k1 k2). - -Definition fast_OMEGA11 (v1 c1 l1 l2 k1 : Z) (P : Z -> Prop) - (H : P (v1 * (c1 * k1) + (l1 * k1 + l2))) := - eq_ind_r P H (OMEGA11 v1 c1 l1 l2 k1). -Definition fast_OMEGA12 (v2 c2 l1 l2 k2 : Z) (P : Z -> Prop) - (H : P (v2 * (c2 * k2) + (l1 + l2 * k2))) := - eq_ind_r P H (OMEGA12 v2 c2 l1 l2 k2). - -Definition fast_OMEGA15 (v c1 c2 l1 l2 k2 : Z) (P : Z -> Prop) - (H : P (v * (c1 + c2 * k2) + (l1 + l2 * k2))) := - eq_ind_r P H (OMEGA15 v c1 c2 l1 l2 k2). -Definition fast_OMEGA16 (v c l k : Z) (P : Z -> Prop) - (H : P (v * (c * k) + l * k)) := eq_ind_r P H (OMEGA16 v c l k). - -Definition fast_OMEGA13 (v l1 l2 : Z) (x : positive) (P : Z -> Prop) - (H : P (l1 + l2)) := eq_ind_r P H (OMEGA13 v l1 l2 x). - -Definition fast_OMEGA14 (v l1 l2 : Z) (x : positive) (P : Z -> Prop) - (H : P (l1 + l2)) := eq_ind_r P H (OMEGA14 v l1 l2 x). -Definition fast_Zred_factor0 (x : Z) (P : Z -> Prop) - (H : P (x * 1)) := eq_ind_r P H (Zred_factor0 x). - -Definition fast_Zopp_eq_mult_neg_1 (x : Z) (P : Z -> Prop) - (H : P (x * -1)) := eq_ind_r P H (Z.opp_eq_mul_m1 x). - -Definition fast_Zmult_comm (x y : Z) (P : Z -> Prop) - (H : P (y * x)) := eq_ind_r P H (Z.mul_comm x y). - -Definition fast_Zopp_plus_distr (x y : Z) (P : Z -> Prop) - (H : P (- x + - y)) := eq_ind_r P H (Z.opp_add_distr x y). - -Definition fast_Zopp_mult_distr_r (x y : Z) (P : Z -> Prop) - (H : P (x * - y)) := eq_ind_r P H (Zopp_mult_distr_r x y). - -Definition fast_Zmult_plus_distr_l (n m p : Z) (P : Z -> Prop) - (H : P (n * p + m * p)) := eq_ind_r P H (Z.mul_add_distr_r n m p). -Definition fast_Zmult_assoc_reverse (n m p : Z) (P : Z -> Prop) - (H : P (n * (m * p))) := eq_ind_r P H (Zmult_assoc_reverse n m p). - -Definition fast_Zred_factor1 (x : Z) (P : Z -> Prop) - (H : P (x * 2)) := eq_ind_r P H (Zred_factor1 x). - -Definition fast_Zred_factor2 (x y : Z) (P : Z -> Prop) - (H : P (x * (1 + y))) := eq_ind_r P H (Zred_factor2 x y). - -Definition fast_Zred_factor3 (x y : Z) (P : Z -> Prop) - (H : P (x * (1 + y))) := eq_ind_r P H (Zred_factor3 x y). - -Definition fast_Zred_factor4 (x y z : Z) (P : Z -> Prop) - (H : P (x * (y + z))) := eq_ind_r P H (Zred_factor4 x y z). - -Definition fast_Zred_factor5 (x y : Z) (P : Z -> Prop) - (H : P y) := eq_ind_r P H (Zred_factor5 x y). - -Definition fast_Zred_factor6 (x : Z) (P : Z -> Prop) - (H : P (x + 0)) := eq_ind_r P H (Zred_factor6 x). - -Theorem intro_Z : - forall n:nat, exists y : Z, Z.of_nat n = y /\ 0 <= y * 1 + 0. -Proof. - intros n; exists (Z.of_nat n); split; trivial. - rewrite Z.mul_1_r, Z.add_0_r. apply Nat2Z.is_nonneg. -Qed. diff --git a/stdlib/theories/omega/PreOmega.v b/stdlib/theories/omega/PreOmega.v deleted file mode 100644 index 26988212183d..000000000000 --- a/stdlib/theories/omega/PreOmega.v +++ /dev/null @@ -1,238 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* qā‚‚] for quotients that - are likely to be the same, which allows tactics like [nia] to - prove more goals, including those relating [Z.div]/[Z.mod] to - [Z.quot]/[Z.rem]. The [Z.euclidean_division_equations_cleanup] - tactic removes needless hypotheses, which makes tactics like [nia] - run faster. The tactic [Z.to_euclidean_division_equations] - combines the handling of both variants of division/quotient and - modulo/remainder. *) - -Module Z. - Lemma mod_0_r_ext x y : y = 0 -> x mod y = x. - Proof. intro; subst; destruct x; reflexivity. Qed. - Lemma div_0_r_ext x y : y = 0 -> x / y = 0. - Proof. intro; subst; destruct x; reflexivity. Qed. - - Lemma rem_0_r_ext x y : y = 0 -> Z.rem x y = x. - Proof. intro; subst; destruct x; reflexivity. Qed. - Lemma quot_0_r_ext x y : y = 0 -> Z.quot x y = 0. - Proof. intro; subst; destruct x; reflexivity. Qed. - - Lemma rem_bound_pos_pos x y : 0 < y -> 0 <= x -> 0 <= Z.rem x y < y. - Proof. intros; apply Z.rem_bound_pos; assumption. Qed. - Lemma rem_bound_neg_pos x y : y < 0 -> 0 <= x -> 0 <= Z.rem x y < -y. - Proof. rewrite <- Z.rem_opp_r'; intros; apply Z.rem_bound_pos; rewrite ?Z.opp_pos_neg; assumption. Qed. - Lemma rem_bound_pos_neg x y : 0 < y -> x <= 0 -> -y < Z.rem x y <= 0. - Proof. rewrite <- (Z.opp_involutive x), Z.rem_opp_l', <- Z.opp_lt_mono, and_comm, !Z.opp_nonpos_nonneg; apply rem_bound_pos_pos. Qed. - Lemma rem_bound_neg_neg x y : y < 0 -> x <= 0 -> y < Z.rem x y <= 0. - Proof. rewrite <- (Z.opp_involutive x), <- (Z.opp_involutive y), Z.rem_opp_l', <- Z.opp_lt_mono, and_comm, !Z.opp_nonpos_nonneg, Z.opp_involutive; apply rem_bound_neg_pos. Qed. - - (* Make the direction of [Z.divide] line up with the rest of the Euclidean equation facts *) - Local Lemma divide_alt x y : Z.divide x y -> exists z, y = x * z. - Proof. intros [z H]; exists z; subst; apply Z.mul_comm. Qed. - - Ltac div_mod_to_equations_generalize x y := - pose proof (Z.div_mod x y); - pose proof (Z.mod_pos_bound x y); - pose proof (Z.mod_neg_bound x y); - pose proof (div_0_r_ext x y); - pose proof (mod_0_r_ext x y); - let q := fresh "q" in - let r := fresh "r" in - set (q := x / y) in *; - set (r := x mod y) in *; - clearbody q r. - Ltac quot_rem_to_equations_generalize x y := - pose proof (Z.quot_rem' x y); - pose proof (rem_bound_pos_pos x y); - pose proof (rem_bound_pos_neg x y); - pose proof (rem_bound_neg_pos x y); - pose proof (rem_bound_neg_neg x y); - pose proof (quot_0_r_ext x y); - pose proof (rem_0_r_ext x y); - let q := fresh "q" in - let r := fresh "r" in - set (q := Z.quot x y) in *; - set (r := Z.rem x y) in *; - clearbody q r. - - Ltac div_mod_to_equations_step := - match goal with - | [ |- context[?x / ?y] ] => div_mod_to_equations_generalize x y - | [ |- context[?x mod ?y] ] => div_mod_to_equations_generalize x y - | [ H : context[?x / ?y] |- _ ] => div_mod_to_equations_generalize x y - | [ H : context[?x mod ?y] |- _ ] => div_mod_to_equations_generalize x y - end. - Ltac quot_rem_to_equations_step := - match goal with - | [ |- context[Z.quot ?x ?y] ] => quot_rem_to_equations_generalize x y - | [ |- context[Z.rem ?x ?y] ] => quot_rem_to_equations_generalize x y - | [ H : context[Z.quot ?x ?y] |- _ ] => quot_rem_to_equations_generalize x y - | [ H : context[Z.rem ?x ?y] |- _ ] => quot_rem_to_equations_generalize x y - end. - Ltac divide_to_equations_step := - match goal with | [ H : Z.divide _ _ |- _ ] => apply divide_alt in H; destruct H end. - Ltac div_mod_to_equations' := repeat div_mod_to_equations_step. - Ltac quot_rem_to_equations' := repeat quot_rem_to_equations_step. - Ltac divide_to_equations' := repeat divide_to_equations_step. - Ltac euclidean_division_equations_cleanup := - repeat - (repeat match goal with - | [ H : 0 <= ?x < _ |- _ ] => destruct H - end; - repeat match goal with - | [ H : ?x <> ?x -> _ |- _ ] => clear H - | [ H : ?x < ?x -> _ |- _ ] => clear H - | [ H : ?T -> _, H' : ~?T |- _ ] => clear H - | [ H : ~?T -> _, H' : ?T |- _ ] => clear H - | [ H : ?A -> ?x <> ?x -> _ |- _ ] => clear H - | [ H : ?A -> ?x < ?x -> _ |- _ ] => clear H - | [ H : ?A -> ?B -> _, H' : ~?B |- _ ] => clear H - | [ H : ?A -> ~?B -> _, H' : ?B |- _ ] => clear H - | [ H : 0 < ?x -> _, H' : ?x < 0 |- _ ] => clear H - | [ H : ?x < 0 -> _, H' : 0 < ?x |- _ ] => clear H - | [ H : ?A -> 0 < ?x -> _, H' : ?x < 0 |- _ ] => clear H - | [ H : ?A -> ?x < 0 -> _, H' : 0 < ?x |- _ ] => clear H - | [ H : 0 <= ?x -> _, H' : ?x < 0 |- _ ] => clear H - | [ H : ?x <= 0 -> _, H' : 0 < ?x |- _ ] => clear H - | [ H : ?A -> 0 <= ?x -> _, H' : ?x < 0 |- _ ] => clear H - | [ H : ?A -> ?x <= 0 -> _, H' : 0 < ?x |- _ ] => clear H - | [ H : 0 < ?x -> _, H' : ?x <= 0 |- _ ] => clear H - | [ H : ?x < 0 -> _, H' : 0 <= ?x |- _ ] => clear H - | [ H : ?A -> 0 < ?x -> _, H' : ?x <= 0 |- _ ] => clear H - | [ H : ?A -> ?x < 0 -> _, H' : 0 <= ?x |- _ ] => clear H - | [ H : ?x < ?y -> _, H' : ?x = ?y |- _ ] => clear H - | [ H : ?x < ?y -> _, H' : ?y = ?x |- _ ] => clear H - | [ H : ?A -> ?x < ?y -> _, H' : ?x = ?y |- _ ] => clear H - | [ H : ?A -> ?x < ?y -> _, H' : ?y = ?x |- _ ] => clear H - | [ H : ?x = ?y -> _, H' : ?x < ?y |- _ ] => clear H - | [ H : ?x = ?y -> _, H' : ?y < ?x |- _ ] => clear H - | [ H : ?A -> ?x = ?y -> _, H' : ?x < ?y |- _ ] => clear H - | [ H : ?A -> ?x = ?y -> _, H' : ?y < ?x |- _ ] => clear H - end; - repeat match goal with - | [ H : ?x = ?x -> ?Q |- _ ] => specialize (H eq_refl) - | [ H : ?T -> ?Q, H' : ?T |- _ ] => specialize (H H') - | [ H : ?A -> ?x = ?x -> ?Q |- _ ] => specialize (fun a => H a eq_refl) - | [ H : ?A -> ?B -> ?Q, H' : ?B |- _ ] => specialize (fun a => H a H') - | [ H : 0 <= ?x -> ?Q, H' : ?x <= 0 |- _ ] => specialize (fun pf => H (@Z.eq_le_incl 0 x (eq_sym pf))) - | [ H : ?A -> 0 <= ?x -> ?Q, H' : ?x <= 0 |- _ ] => specialize (fun a pf => H a (@Z.eq_le_incl 0 x (eq_sym pf))) - | [ H : ?x <= 0 -> ?Q, H' : 0 <= ?x |- _ ] => specialize (fun pf => H (@Z.eq_le_incl 0 x pf)) - | [ H : ?A -> ?x <= 0 -> ?Q, H' : 0 <= ?x |- _ ] => specialize (fun a pf => H a (@Z.eq_le_incl x 0 pf)) - end). - (** poses [x = y \/ x <> y] unless that is redundant or contradictory *) - Ltac euclidean_division_equations_pose_eq_fact x y := - assert_fails constr_eq x y; - lazymatch goal with - | [ H : x = y |- _ ] => fail - | [ H : y = x |- _ ] => fail - | [ H : x = y \/ x <> y |- _ ] => fail - | [ H : y = x \/ y <> x |- _ ] => fail - | [ H : x < y |- _ ] => fail - | [ H : y < x |- _ ] => fail - | [ H : x <> y |- _ ] => fail - | [ H : y <> x |- _ ] => fail - | _ => pose proof (Z.eq_decidable x y : x = y \/ x <> y) - end. - - Ltac euclidean_division_equations_find_duplicate_quotients_step := - let pose_eq_fact x y := euclidean_division_equations_pose_eq_fact x y in - match goal with - | [ H : context[?x = ?y * ?q1], H' : context[?x = ?y * ?q2] |- _ ] => pose_eq_fact q1 q2 - | [ H : context[?x = ?y * ?q1 + _], H' : context[?x = ?y * ?q2] |- _ ] => pose_eq_fact q1 q2 - | [ H : context[?x = ?y * ?q1 + _], H' : context[?x = ?y * ?q2 + _] |- _ ] => pose_eq_fact q1 q2 - | [ H : context[?y * ?q2 + _ = ?y * ?q1 + _] |- _ ] => pose_eq_fact q1 q2 - | [ H : context[?x * ?y = ?y * ?q1 + _] |- _ ] => pose_eq_fact x q1 - | [ H : context[?y * ?x = ?y * ?q1 + _] |- _ ] => pose_eq_fact x q1 - end. - Ltac euclidean_division_equations_find_duplicate_quotients := - repeat euclidean_division_equations_find_duplicate_quotients_step. - Ltac div_mod_to_equations := div_mod_to_equations'; euclidean_division_equations_cleanup. - Ltac quot_rem_to_equations := quot_rem_to_equations'; euclidean_division_equations_cleanup. - Ltac divide_to_equations := divide_to_equations'; euclidean_division_equations_cleanup. - Module euclidean_division_equations_flags. - #[local] Set Primitive Projections. - Record t := - { find_duplicate_quotients : bool }. - Ltac default_find_duplicate_quotients := constr:(true). - Ltac default := - let find_duplicate_quotients_value := default_find_duplicate_quotients in - constr:({| find_duplicate_quotients := find_duplicate_quotients_value - |}). - Module Import DefaultHelpers. - Ltac try_unify_args x y := - tryif first [ has_evar x | has_evar y ] - then (tryif unify x y - then idtac - else (lazymatch x with - | ?f ?x - => lazymatch y with - | ?g ?y - => try_unify_args f g; try_unify_args x y - | ?y => fail 0 "Z.euclidean_division_equations_flags: try_unify_args: cannot unify application" x "with non-application" y - end - | ?x - => (tryif has_evar x - then fail 0 "Z.euclidean_division_equations_flags: try_unify_args: cannot unify evar-containing non-application" x "with" y - else (tryif has_evar y - then fail 0 "Z.euclidean_division_equations_flags: try_unify_args: cannot unify non-application" x "with evar-containing" y - else fail 100 "Z.euclidean_division_equations_flags: try_unify_args: Impossible inconsistent state of has_evar in try_unify_args" x y)) - end)) - else idtac. - End DefaultHelpers. - - Ltac flags_with orig_flags proj value := - let flags := open_constr:(match True return t with _ => ltac:(econstructor) end) in - let __unif := constr:(eq_refl : proj flags = value) in - let __force := lazymatch goal with _ => try_unify_args flags orig_flags end in - flags. - - Ltac default_with proj value := flags_with default proj value. - - Ltac guard_with proj flags tac := - lazymatch (eval cbv in (proj flags)) with - | true => tac - | false => idtac - | ?v => let ctrue := constr:(true) in - let cfalse := constr:(false) in - fail 0 "Invalid flag value for" proj "in" flags "(got" v "expected" ctrue "or" cfalse ")" - end. - End euclidean_division_equations_flags. - Import euclidean_division_equations_flags (find_duplicate_quotients). - Ltac to_euclidean_division_equations_with flags := - divide_to_equations'; div_mod_to_equations'; quot_rem_to_equations'; - euclidean_division_equations_cleanup; - euclidean_division_equations_flags.guard_with find_duplicate_quotients flags euclidean_division_equations_find_duplicate_quotients. - Ltac to_euclidean_division_equations := - to_euclidean_division_equations_with euclidean_division_equations_flags.default. -End Z. - -Require Import ZifyClasses ZifyInst. -Require Zify. - -Ltac Zify.zify_internal_to_euclidean_division_equations ::= Z.to_euclidean_division_equations. - -Ltac zify := Zify.zify. - -(* TODO #14736 for compatibility only, should be removed after deprecation *) diff --git a/stdlib/theories/rtauto/Bintree.v b/stdlib/theories/rtauto/Bintree.v deleted file mode 100644 index 92f2ad8865c1..000000000000 --- a/stdlib/theories/rtauto/Bintree.v +++ /dev/null @@ -1,387 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* (p ?= q) = Gt. -Proof. -intros. rewrite <- Pos.compare_succ_succ. -now apply Pos.lt_gt, Pos.lt_lt_succ, Pos.gt_lt. -Qed. - -Lemma Psucc_Gt : forall p, - (Pos.succ p ?= p) = Gt. -Proof. -intros. apply Pos.lt_gt, Pos.lt_succ_diag_r. -Qed. - -Fixpoint Lget (A:Set) (n:nat) (l:list A) {struct l}:option A := -match l with nil => None -| x::q => -match n with O => Some x -| S m => Lget A m q -end end . - -Arguments Lget [A] n l. - -Lemma map_app : forall (A B:Set) (f:A -> B) l m, -List.map f (l ++ m) = List.map f l ++ List.map f m. -induction l. -- reflexivity. -- simpl. - intro m ; apply f_equal;apply IHl. -Qed. - -Lemma length_map : forall (A B:Set) (f:A -> B) l, -length (List.map f l) = length l. -induction l. -- reflexivity. -- simpl; apply f_equal;apply IHl. -Qed. - -Lemma Lget_map : forall (A B:Set) (f:A -> B) i l, -Lget i (List.map f l) = -match Lget i l with Some a => -Some (f a) | None => None end. -induction i;intros [ | x l ] ;trivial. -simpl;auto. -Qed. - -Lemma Lget_app : forall (A:Set) (a:A) l i, -Lget i (l ++ a :: nil) = if Nat.eqb i (length l) then Some a else Lget i l. -Proof. -induction l;simpl Lget;simpl length. -- intros [ | i];simpl;reflexivity. -- intros [ | i];simpl. - + reflexivity. - + auto. -Qed. - -Lemma Lget_app_Some : forall (A:Set) l delta i (a: A), -Lget i l = Some a -> -Lget i (l ++ delta) = Some a. -induction l;destruct i;simpl;try congruence;auto. -Qed. - -Inductive Poption {A} : Type:= - PSome : A -> Poption -| PNone : Poption. -Arguments Poption : clear implicits. - -Inductive Tree {A} : Type := - Tempty : Tree - | Branch0 : Tree -> Tree -> Tree - | Branch1 : A -> Tree -> Tree -> Tree. -Arguments Tree : clear implicits. - -Section Store. - -Variable A:Type. - -Notation Poption := (Poption A). -Notation Tree := (Tree A). - - -Fixpoint Tget (p:positive) (T:Tree) {struct p} : Poption := - match T with - Tempty => PNone - | Branch0 T1 T2 => - match p with - xI pp => Tget pp T2 - | xO pp => Tget pp T1 - | xH => PNone - end - | Branch1 a T1 T2 => - match p with - xI pp => Tget pp T2 - | xO pp => Tget pp T1 - | xH => PSome a - end -end. - -Fixpoint Tadd (p:positive) (a:A) (T:Tree) {struct p}: Tree := - match T with - | Tempty => - match p with - | xI pp => Branch0 Tempty (Tadd pp a Tempty) - | xO pp => Branch0 (Tadd pp a Tempty) Tempty - | xH => Branch1 a Tempty Tempty - end - | Branch0 T1 T2 => - match p with - | xI pp => Branch0 T1 (Tadd pp a T2) - | xO pp => Branch0 (Tadd pp a T1) T2 - | xH => Branch1 a T1 T2 - end - | Branch1 b T1 T2 => - match p with - | xI pp => Branch1 b T1 (Tadd pp a T2) - | xO pp => Branch1 b (Tadd pp a T1) T2 - | xH => Branch1 a T1 T2 - end - end. - -Definition mkBranch0 (T1 T2:Tree) := - match T1,T2 with - Tempty ,Tempty => Tempty - | _,_ => Branch0 T1 T2 - end. - -Fixpoint Tremove (p:positive) (T:Tree) {struct p}: Tree := - match T with - | Tempty => Tempty - | Branch0 T1 T2 => - match p with - | xI pp => mkBranch0 T1 (Tremove pp T2) - | xO pp => mkBranch0 (Tremove pp T1) T2 - | xH => T - end - | Branch1 b T1 T2 => - match p with - | xI pp => Branch1 b T1 (Tremove pp T2) - | xO pp => Branch1 b (Tremove pp T1) T2 - | xH => mkBranch0 T1 T2 - end - end. - - -Theorem Tget_Tempty: forall (p : positive), Tget p (Tempty) = PNone. -destruct p;reflexivity. -Qed. - -Theorem Tget_Tadd: forall i j a T, - Tget i (Tadd j a T) = - match (i ?= j) with - Eq => PSome a - | Lt => Tget i T - | Gt => Tget i T - end. -Proof. -intros i j. -case_eq (i ?= j). -- intro H;rewrite (Pos.compare_eq _ _ H);intros a;clear i H. - induction j;destruct T;simpl;try (apply IHj);congruence. -- unfold Pos.compare. - generalize i;clear i;induction j;destruct T;simpl in H|-*; - destruct i;simpl;try rewrite (IHj _ H);try (destruct i;simpl;congruence);reflexivity|| congruence. -- unfold Pos.compare. - generalize i;clear i;induction j;destruct T;simpl in H|-*; - destruct i;simpl;try rewrite (IHj _ H);try (destruct i;simpl;congruence);reflexivity|| congruence. -Qed. - -Record Store : Type := -mkStore {index:positive;contents:Tree}. - -Definition empty := mkStore xH Tempty. - -Definition push a S := -mkStore (Pos.succ (index S)) (Tadd (index S) a (contents S)). - -Definition get i S := Tget i (contents S). - -Lemma get_empty : forall i, get i empty = PNone. -intro i; case i; unfold empty,get; simpl;reflexivity. -Qed. - -Inductive Full : Store -> Type:= - F_empty : Full empty - | F_push : forall a S, Full S -> Full (push a S). - -Theorem get_Full_Gt : forall S, Full S -> - forall i, (i ?= index S) = Gt -> get i S = PNone. -Proof. -intros S W;induction W. -- unfold empty,index,get,contents;intros;apply Tget_Tempty. -- unfold index,get,push. simpl @contents. - intros i e;rewrite Tget_Tadd. - rewrite (Gt_Psucc _ _ e). - unfold get in IHW. - apply IHW;apply Gt_Psucc;assumption. -Qed. - -Theorem get_Full_Eq : forall S, Full S -> get (index S) S = PNone. -intros [index0 contents0] F. -case F. -- unfold empty,index,get,contents;intros;apply Tget_Tempty. -- unfold push,index,get;simpl @contents. - intros a S. - rewrite Tget_Tadd. - rewrite Psucc_Gt. - intro W. - change (get (Pos.succ (index S)) S =PNone). - apply get_Full_Gt; auto. - apply Psucc_Gt. -Qed. - -Theorem get_push_Full : - forall i a S, Full S -> - get i (push a S) = - match (i ?= index S) with - Eq => PSome a - | Lt => get i S - | Gt => PNone -end. -Proof. -intros i a S F. -case_eq (i ?= index S). -- intro e;rewrite (Pos.compare_eq _ _ e). - destruct S;unfold get,push,index;simpl @contents;rewrite Tget_Tadd. - rewrite Pos.compare_refl;reflexivity. -- intros;destruct S;unfold get,push,index;simpl @contents;rewrite Tget_Tadd. - simpl @index in H;rewrite H;reflexivity. -- intro H;generalize H;clear H. - unfold get,push;simpl. - rewrite Tget_Tadd;intro e;rewrite e. - change (get i S=PNone). - apply get_Full_Gt;auto. -Qed. - -Lemma Full_push_compat : forall i a S, Full S -> -forall x, get i S = PSome x -> - get i (push a S) = PSome x. -Proof. -intros i a S F x H. -case_eq (i ?= index S);intro test. -- rewrite (Pos.compare_eq _ _ test) in H. - rewrite (get_Full_Eq _ F) in H;congruence. -- rewrite <- H. - rewrite (get_push_Full i a). - + rewrite test;reflexivity. - + assumption. -- rewrite (get_Full_Gt _ F) in H;congruence. -Qed. - -Lemma Full_index_one_empty : forall S, Full S -> index S = 1 -> S=empty. -intros [ind cont] F one; inversion F. -- reflexivity. -- simpl @index in one;assert (h:=Pos.succ_not_1 (index S)). - congruence. -Qed. - -Lemma push_not_empty: forall a S, (push a S) <> empty. -intros a [ind cont];unfold push,empty. -intros [= H%Pos.succ_not_1]. assumption. -Qed. - -Fixpoint In (x:A) (S:Store) (F:Full S) {struct F}: Prop := -match F with -F_empty => False -| F_push a SS FF => x=a \/ In x SS FF -end. - -Lemma get_In : forall (x:A) (S:Store) (F:Full S) i , -get i S = PSome x -> In x S F. -induction F. -- intro i;rewrite get_empty; congruence. -- intro i;rewrite get_push_Full;trivial. - case_eq (i ?= index S);simpl. - + left;congruence. - + right;eauto. - + congruence. -Qed. - -End Store. - -Arguments PNone {A}. -Arguments PSome [A] _. - -Arguments Tempty {A}. -Arguments Branch0 [A] _ _. -Arguments Branch1 [A] _ _ _. - -Arguments Tget [A] p T. -Arguments Tadd [A] p a T. - -Arguments Tget_Tempty [A] p. -Arguments Tget_Tadd [A] i j a T. - -Arguments mkStore [A] index contents. -Arguments index [A] s. -Arguments contents [A] s. - -Arguments empty {A}. -Arguments get [A] i S. -Arguments push [A] a S. - -Arguments get_empty [A] i. -Arguments get_push_Full [A] i a S _. - -Arguments Full [A] _. -Arguments F_empty {A}. -Arguments F_push [A] a S _. -Arguments In [A] x S F. - -Register empty as plugins.rtauto.empty. -Register push as plugins.rtauto.push. - -Section Map. - -Variables A B:Set. - -Variable f: A -> B. - -Fixpoint Tmap (T: Tree A) : Tree B := -match T with -Tempty => Tempty -| Branch0 t1 t2 => Branch0 (Tmap t1) (Tmap t2) -| Branch1 a t1 t2 => Branch1 (f a) (Tmap t1) (Tmap t2) -end. - -Lemma Tget_Tmap: forall T i, -Tget i (Tmap T)= match Tget i T with PNone => PNone -| PSome a => PSome (f a) end. -induction T;intro i;case i;simpl;auto. -Defined. - -Lemma Tmap_Tadd: forall i a T, -Tmap (Tadd i a T) = Tadd i (f a) (Tmap T). -induction i;intros a T;case T;simpl;intros;try (rewrite IHi);simpl;reflexivity. -Defined. - -Definition map (S:Store A) : Store B := -mkStore (index S) (Tmap (contents S)). - -Lemma get_map: forall i S, -get i (map S)= match get i S with PNone => PNone -| PSome a => PSome (f a) end. -destruct S;unfold get,map,contents,index;apply Tget_Tmap. -Defined. - -Lemma map_push: forall a S, -map (push a S) = push (f a) (map S). -intros a S. -case S. -unfold push,map,contents,index. -intros;rewrite Tmap_Tadd;reflexivity. -Defined. - -Theorem Full_map : forall S, Full S -> Full (map S). -intros S F. -induction F. -- exact F_empty. -- rewrite map_push;constructor 2;assumption. -Defined. - -End Map. - -Arguments Tmap [A B] f T. -Arguments map [A B] f S. -Arguments Full_map [A B f] S _. - -Notation "hyps \ A" := (push A hyps) (at level 72,left associativity). - -(* TODO #14736 for compatibility only, should be removed after deprecation *) -Require Arith.EqNat. diff --git a/stdlib/theories/rtauto/Rtauto.v b/stdlib/theories/rtauto/Rtauto.v deleted file mode 100644 index 60d1ec1efb99..000000000000 --- a/stdlib/theories/rtauto/Rtauto.v +++ /dev/null @@ -1,410 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* form -| Arrow : form -> form -> form -| Bot -| Conjunct : form -> form -> form -| Disjunct : form -> form -> form. - -Notation "[ n ]":=(Atom n). -Notation "A =>> B":= (Arrow A B) (at level 59, right associativity). -Notation "#" := Bot. -Notation "A //\\ B" := (Conjunct A B) (at level 57, left associativity). -Notation "A \\// B" := (Disjunct A B) (at level 58, left associativity). - -Definition ctx := Store form. - -Fixpoint pos_eq (m n:positive) {struct m} :bool := -match m with - xI mm => match n with xI nn => pos_eq mm nn | _ => false end -| xO mm => match n with xO nn => pos_eq mm nn | _ => false end -| xH => match n with xH => true | _ => false end -end. - -Theorem pos_eq_refl : forall m n, pos_eq m n = true -> m = n. -induction m;simpl;destruct n;congruence || -(intro e;apply f_equal;auto). -Qed. - -Fixpoint form_eq (p q:form) {struct p} :bool := -match p with - Atom m => match q with Atom n => pos_eq m n | _ => false end -| Arrow p1 p2 => -match q with - Arrow q1 q2 => form_eq p1 q1 && form_eq p2 q2 -| _ => false end -| Bot => match q with Bot => true | _ => false end -| Conjunct p1 p2 => -match q with - Conjunct q1 q2 => form_eq p1 q1 && form_eq p2 q2 -| _ => false -end -| Disjunct p1 p2 => -match q with - Disjunct q1 q2 => form_eq p1 q1 && form_eq p2 q2 -| _ => false -end -end. - -Theorem form_eq_refl: forall p q, form_eq p q = true -> p = q. -induction p;destruct q;simpl;clean. -- intro h;generalize (pos_eq_refl _ _ h);congruence. -- case_eq (form_eq p1 q1);clean. - intros e1 e2;generalize (IHp1 _ e1) (IHp2 _ e2);congruence. -- case_eq (form_eq p1 q1);clean. - intros e1 e2;generalize (IHp1 _ e1) (IHp2 _ e2);congruence. -- case_eq (form_eq p1 q1);clean. - intros e1 e2;generalize (IHp1 _ e1) (IHp2 _ e2);congruence. -Qed. - -Arguments form_eq_refl [p q] _. - -Section with_env. - -Variable env:Store Prop. - -Fixpoint interp_form (f:form): Prop := -match f with -[n]=> match get n env with PNone => True | PSome P => P end -| A =>> B => (interp_form A) -> (interp_form B) -| # => False -| A //\\ B => (interp_form A) /\ (interp_form B) -| A \\// B => (interp_form A) \/ (interp_form B) -end. - -Notation "[[ A ]]" := (interp_form A). - -Fixpoint interp_ctx (hyps:ctx) (F:Full hyps) (G:Prop) {struct F} : Prop := -match F with - F_empty => G -| F_push H hyps0 F0 => interp_ctx hyps0 F0 ([[H]] -> G) -end. - -Ltac wipe := intros;simpl;constructor. - -Lemma compose0 : -forall hyps F (A:Prop), - A -> - (interp_ctx hyps F A). -induction F;intros A H;simpl;auto. -Qed. - -Lemma compose1 : -forall hyps F (A B:Prop), - (A -> B) -> - (interp_ctx hyps F A) -> - (interp_ctx hyps F B). -induction F;intros A B H;simpl;auto. -apply IHF;auto. -Qed. - -Theorem compose2 : -forall hyps F (A B C:Prop), - (A -> B -> C) -> - (interp_ctx hyps F A) -> - (interp_ctx hyps F B) -> - (interp_ctx hyps F C). -induction F;intros A B C H;simpl;auto. -apply IHF;auto. -Qed. - -Theorem compose3 : -forall hyps F (A B C D:Prop), - (A -> B -> C -> D) -> - (interp_ctx hyps F A) -> - (interp_ctx hyps F B) -> - (interp_ctx hyps F C) -> - (interp_ctx hyps F D). -induction F;intros A B C D H;simpl;auto. -apply IHF;auto. -Qed. - -Lemma weaken : forall hyps F f G, - (interp_ctx hyps F G) -> - (interp_ctx (hyps\f) (F_push f hyps F) G). -induction F;simpl;intros;auto. -apply compose1 with ([[a]]-> G);auto. -Qed. - -Theorem project_In : forall hyps F g, -In g hyps F -> -interp_ctx hyps F [[g]]. -induction F;simpl. -- contradiction. -- intros g H;destruct H. - + subst;apply compose0;simpl;trivial. - + apply compose1 with [[g]];auto. -Qed. - -Theorem project : forall hyps F p g, -get p hyps = PSome g-> -interp_ctx hyps F [[g]]. -intros hyps F p g e; apply project_In. -apply get_In with p;assumption. -Qed. - -Arguments project [hyps] F [p g] _. - -Inductive proof:Set := - Ax : positive -> proof -| I_Arrow : proof -> proof -| E_Arrow : positive -> positive -> proof -> proof -| D_Arrow : positive -> proof -> proof -> proof -| E_False : positive -> proof -| I_And: proof -> proof -> proof -| E_And: positive -> proof -> proof -| D_And: positive -> proof -> proof -| I_Or_l: proof -> proof -| I_Or_r: proof -> proof -| E_Or: positive -> proof -> proof -> proof -| D_Or: positive -> proof -> proof -| Cut: form -> proof -> proof -> proof. - -Notation "hyps \ A" := (push A hyps) (at level 72,left associativity). - -Fixpoint check_proof (hyps:ctx) (gl:form) (P:proof) {struct P}: bool := - match P with - Ax i => - match get i hyps with - PSome F => form_eq F gl - | _ => false - end -| I_Arrow p => - match gl with - A =>> B => check_proof (hyps \ A) B p - | _ => false - end -| E_Arrow i j p => - match get i hyps,get j hyps with - PSome A,PSome (B =>>C) => - form_eq A B && check_proof (hyps \ C) (gl) p - | _,_ => false - end -| D_Arrow i p1 p2 => - match get i hyps with - PSome ((A =>>B)=>>C) => - (check_proof ( hyps \ B =>> C \ A) B p1) && (check_proof (hyps \ C) gl p2) - | _ => false - end -| E_False i => - match get i hyps with - PSome # => true - | _ => false - end -| I_And p1 p2 => - match gl with - A //\\ B => - check_proof hyps A p1 && check_proof hyps B p2 - | _ => false - end -| E_And i p => - match get i hyps with - PSome (A //\\ B) => check_proof (hyps \ A \ B) gl p - | _=> false - end -| D_And i p => - match get i hyps with - PSome (A //\\ B =>> C) => check_proof (hyps \ A=>>B=>>C) gl p - | _=> false - end -| I_Or_l p => - match gl with - (A \\// B) => check_proof hyps A p - | _ => false - end -| I_Or_r p => - match gl with - (A \\// B) => check_proof hyps B p - | _ => false - end -| E_Or i p1 p2 => - match get i hyps with - PSome (A \\// B) => - check_proof (hyps \ A) gl p1 && check_proof (hyps \ B) gl p2 - | _=> false - end -| D_Or i p => - match get i hyps with - PSome (A \\// B =>> C) => - (check_proof (hyps \ A=>>C \ B=>>C) gl p) - | _=> false - end -| Cut A p1 p2 => - check_proof hyps A p1 && check_proof (hyps \ A) gl p2 -end. - -Theorem interp_proof: -forall p hyps F gl, -check_proof hyps gl p = true -> interp_ctx hyps F [[gl]]. - -induction p; intros hyps F gl. - -- (* Axiom *) - simpl;case_eq (get p hyps);clean. - intros f nth_f e;rewrite <- (form_eq_refl e). - apply project with p;trivial. - -- (* Arrow_Intro *) - destruct gl; clean. - simpl; intros. - change (interp_ctx (hyps\gl1) (F_push gl1 hyps F) [[gl2]]). - apply IHp; try constructor; trivial. - -- (* Arrow_Elim *) - simpl check_proof; case_eq (get p hyps); clean. - intros f ef; case_eq (get p0 hyps); clean. - intros f0 ef0; destruct f0; clean. - case_eq (form_eq f f0_1); clean. - simpl; intros e check_p1. - generalize (project F ef) (project F ef0) - (IHp (hyps \ f0_2) (F_push f0_2 hyps F) gl check_p1); - clear check_p1 IHp p p0 p1 ef ef0. - simpl. - apply compose3. - rewrite (form_eq_refl e). - auto. - -- (* Arrow_Destruct *) - simpl; case_eq (get p1 hyps); clean. - intros f ef; destruct f; clean. - destruct f1; clean. - case_eq (check_proof (hyps \ f1_2 =>> f2 \ f1_1) f1_2 p2); clean. - intros check_p1 check_p2. - generalize (project F ef) - (IHp1 (hyps \ f1_2 =>> f2 \ f1_1) - (F_push f1_1 (hyps \ f1_2 =>> f2) - (F_push (f1_2 =>> f2) hyps F)) f1_2 check_p1) - (IHp2 (hyps \ f2) (F_push f2 hyps F) gl check_p2). - simpl; apply compose3; auto. - -- (* False_Elim *) - simpl; case_eq (get p hyps); clean. - intros f ef; destruct f; clean. - intros _; generalize (project F ef). - apply compose1; apply False_ind. - -- (* And_Intro *) - simpl; destruct gl; clean. - case_eq (check_proof hyps gl1 p1); clean. - intros Hp1 Hp2;generalize (IHp1 hyps F gl1 Hp1) (IHp2 hyps F gl2 Hp2). - apply compose2 ; simpl; auto. - -- (* And_Elim *) - simpl; case_eq (get p hyps); clean. - intros f ef; destruct f; clean. - intro check_p; - generalize (project F ef) - (IHp (hyps \ f1 \ f2) (F_push f2 (hyps \ f1) (F_push f1 hyps F)) gl check_p). - simpl; apply compose2; intros [h1 h2]; auto. - -- (* And_Destruct*) - simpl; case_eq (get p hyps); clean. - intros f ef; destruct f; clean. - destruct f1; clean. - intro H; - generalize (project F ef) - (IHp (hyps \ f1_1 =>> f1_2 =>> f2) - (F_push (f1_1 =>> f1_2 =>> f2) hyps F) gl H); - clear H; simpl. - apply compose2; auto. - -- (* Or_Intro_left *) - destruct gl; clean. - intro Hp; generalize (IHp hyps F gl1 Hp). - apply compose1; simpl; auto. - -- (* Or_Intro_right *) - destruct gl; clean. - intro Hp; generalize (IHp hyps F gl2 Hp). - apply compose1; simpl; auto. - -- (* Or_elim *) - simpl; case_eq (get p1 hyps); clean. - intros f ef; destruct f; clean. - case_eq (check_proof (hyps \ f1) gl p2); clean. - intros check_p1 check_p2; - generalize (project F ef) - (IHp1 (hyps \ f1) (F_push f1 hyps F) gl check_p1) - (IHp2 (hyps \ f2) (F_push f2 hyps F) gl check_p2); - simpl; apply compose3; simpl; intro h; destruct h; auto. - -- (* Or_Destruct *) - simpl; case_eq (get p hyps); clean. - intros f ef; destruct f; clean. - destruct f1; clean. - intro check_p0; - generalize (project F ef) - (IHp (hyps \ f1_1 =>> f2 \ f1_2 =>> f2) - (F_push (f1_2 =>> f2) (hyps \ f1_1 =>> f2) - (F_push (f1_1 =>> f2) hyps F)) gl check_p0); - simpl. - apply compose2; auto. - -- (* Cut *) - simpl; case_eq (check_proof hyps f p1); clean. - intros check_p1 check_p2; - generalize (IHp1 hyps F f check_p1) - (IHp2 (hyps\f) (F_push f hyps F) gl check_p2); - simpl; apply compose2; auto. -Qed. - -Theorem Reflect: forall gl prf, if check_proof empty gl prf then [[gl]] else True. -intros gl prf;case_eq (check_proof empty gl prf);intro check_prf. -- change (interp_ctx empty F_empty [[gl]]) ; - apply interp_proof with prf;assumption. -- trivial. -Qed. - -End with_env. - -(* -(* A small example *) -Parameters A B C D:Prop. -Theorem toto:A /\ (B \/ C) -> (A /\ B) \/ (A /\ C). -exact (Reflect (empty \ A \ B \ C) -([1] //\\ ([2] \\// [3]) =>> [1] //\\ [2] \\// [1] //\\ [3]) -(I_Arrow (E_And 1 (E_Or 3 - (I_Or_l (I_And (Ax 2) (Ax 4))) - (I_Or_r (I_And (Ax 2) (Ax 4))))))). -Qed. -Print toto. -*) - -Register Reflect as plugins.rtauto.Reflect. - -Register Atom as plugins.rtauto.Atom. -Register Arrow as plugins.rtauto.Arrow. -Register Bot as plugins.rtauto.Bot. -Register Conjunct as plugins.rtauto.Conjunct. -Register Disjunct as plugins.rtauto.Disjunct. - -Register Ax as plugins.rtauto.Ax. -Register I_Arrow as plugins.rtauto.I_Arrow. -Register E_Arrow as plugins.rtauto.E_Arrow. -Register D_Arrow as plugins.rtauto.D_Arrow. -Register E_False as plugins.rtauto.E_False. -Register I_And as plugins.rtauto.I_And. -Register E_And as plugins.rtauto.E_And. -Register D_And as plugins.rtauto.D_And. -Register I_Or_l as plugins.rtauto.I_Or_l. -Register I_Or_r as plugins.rtauto.I_Or_r. -Register E_Or as plugins.rtauto.E_Or. -Register D_Or as plugins.rtauto.D_Or. diff --git a/stdlib/theories/setoid_ring/Algebra_syntax.v b/stdlib/theories/setoid_ring/Algebra_syntax.v deleted file mode 100644 index cee778935e9b..000000000000 --- a/stdlib/theories/setoid_ring/Algebra_syntax.v +++ /dev/null @@ -1,33 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* A -> A. -Notation "_+_" := addition. -Notation "x + y" := (addition x y). -Class Multiplication {A B : Type} := multiplication : A -> B -> B. -Notation "_*_" := multiplication. -Notation "x * y" := (multiplication x y). -Class Subtraction (A : Type) := subtraction : A -> A -> A. -Notation "_-_" := subtraction. -Notation "x - y" := (subtraction x y). -Class Opposite (A : Type) := opposite : A -> A. -Notation "-_" := opposite. -Notation "- x" := (opposite(x)). -Class Equality {A : Type}:= equality : A -> A -> Prop. -Notation "_==_" := equality. -Notation "x == y" := (equality x y) (at level 70, no associativity). -Class Bracket (A B: Type):= bracket : A -> B. -Notation "[ x ]" := (bracket(x)). -Class Power {A B: Type} := power : A -> B -> A. -Notation "x ^ y" := (power x y). diff --git a/stdlib/theories/setoid_ring/ArithRing.v b/stdlib/theories/setoid_ring/ArithRing.v deleted file mode 100644 index 65316f75a559..000000000000 --- a/stdlib/theories/setoid_ring/ArithRing.v +++ /dev/null @@ -1,80 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* constr:(N.of_nat t) - | _ => constr:(InitialRing.NotConstant) - end. - -Ltac Ss_to_add f acc := - match f with - | S ?f1 => Ss_to_add f1 (S acc) - | _ => constr:((acc + f)%nat) - end. - -(* For internal use only *) -Local Definition protected_to_nat := N.to_nat. - -Ltac natprering := - match goal with - |- context C [S ?p] => - match p with - O => fail 1 (* avoid replacing 1 with 1+0 ! *) - | p => match isnatcst p with - | true => fail 1 - | false => let v := Ss_to_add p (S 0) in - fold v; natprering - end - end - | _ => change N.to_nat with protected_to_nat - end. - -Ltac natpostring := - match goal with - | |- context [N.to_nat ?x] => - let v := eval cbv in (N.to_nat x) in - change (N.to_nat x) with v; - natpostring - | _ => change protected_to_nat with N.to_nat - end. - -Add Ring natr : natSRth - (morphism nat_morph_N, constants [natcst], - preprocess [natprering], postprocess [natpostring]). diff --git a/stdlib/theories/setoid_ring/BinList.v b/stdlib/theories/setoid_ring/BinList.v deleted file mode 100644 index 9cb6e7cf0a33..000000000000 --- a/stdlib/theories/setoid_ring/BinList.v +++ /dev/null @@ -1,82 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* tl l - | xO p => jump p (jump p l) - | xI p => jump p (jump p (tl l)) - end. - - Fixpoint nth (p:positive) (l:list A) {struct p} : A:= - match p with - | xH => hd default l - | xO p => nth p (jump p l) - | xI p => nth p (jump p (tl l)) - end. - - Lemma jump_tl : forall j l, tl (jump j l) = jump j (tl l). - Proof. - intro j;induction j as [j IHj|j IHj|];simpl;intros; now rewrite ?IHj. - Qed. - - Lemma jump_succ : forall j l, - jump (Pos.succ j) l = jump 1 (jump j l). - Proof. - intro j;induction j as [j IHj|j IHj|];simpl;intros. - - rewrite !IHj; simpl; now rewrite !jump_tl. - - now rewrite !jump_tl. - - trivial. - Qed. - - Lemma jump_add : forall i j l, - jump (i + j) l = jump i (jump j l). - Proof. - intro i; induction i as [|i IHi] using Pos.peano_ind; intros. - - now rewrite Pos.add_1_l, jump_succ. - - now rewrite Pos.add_succ_l, !jump_succ, IHi. - Qed. - - Lemma jump_pred_double : forall i l, - jump (Pos.pred_double i) (tl l) = jump i (jump i l). - Proof. - intro i;induction i as [i IHi|i IHi|];intros;simpl. - - now rewrite !jump_tl. - - now rewrite IHi, <- 2 jump_tl, IHi. - - trivial. - Qed. - - Lemma nth_jump : forall p l, nth p (tl l) = hd default (jump p l). - Proof. - intro p;induction p as [p IHp|p IHp|];simpl;intros. - - now rewrite <-jump_tl, IHp. - - now rewrite <-jump_tl, IHp. - - trivial. - Qed. - - Lemma nth_pred_double : - forall p l, nth (Pos.pred_double p) (tl l) = nth p (jump p l). - Proof. - intro p;induction p as [p IHp|p IHp|];simpl;intros. - - now rewrite !jump_tl. - - now rewrite jump_pred_double, <- !jump_tl, IHp. - - trivial. - Qed. - -End MakeBinList. diff --git a/stdlib/theories/setoid_ring/Cring.v b/stdlib/theories/setoid_ring/Cring.v deleted file mode 100644 index 15a79bcdcda0..000000000000 --- a/stdlib/theories/setoid_ring/Cring.v +++ /dev/null @@ -1,278 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* idtac - | ?e1::?e2::_ => - match goal with - |- (?op ?u1 ?u2) => - change (op - (@Ring_polynom.PEeval - _ zero one _+_ _*_ _-_ -_ Z Ncring_initial.gen_phiZ N (fun n:N => n) - (@Ring_theory.pow_N _ 1 multiplication) lvar e1) - (@Ring_polynom.PEeval - _ zero one _+_ _*_ _-_ -_ Z Ncring_initial.gen_phiZ N (fun n:N => n) - (@Ring_theory.pow_N _ 1 multiplication) lvar e2)) - end - end. - -Section cring. -Context {R:Type}`{Rr:Cring R}. - -Lemma cring_eq_ext: ring_eq_ext _+_ _*_ -_ _==_. -Proof. -intros. apply mk_reqe; solve_proper. -Defined. - -Lemma cring_almost_ring_theory: - almost_ring_theory (R:=R) zero one _+_ _*_ _-_ -_ _==_. -intros. apply mk_art ;intros. -- rewrite ring_add_0_l; reflexivity. -- rewrite ring_add_comm; reflexivity. -- rewrite ring_add_assoc; reflexivity. -- rewrite ring_mul_1_l; reflexivity. -- apply ring_mul_0_l. -- rewrite cring_mul_comm; reflexivity. -- rewrite ring_mul_assoc; reflexivity. -- rewrite ring_distr_l; reflexivity. -- rewrite ring_opp_mul_l; reflexivity. -- apply ring_opp_add. -- rewrite ring_sub_def ; reflexivity. -Defined. - -Lemma cring_morph: - ring_morph zero one _+_ _*_ _-_ -_ _==_ - 0%Z 1%Z Z.add Z.mul Z.sub Z.opp Z.eqb - Ncring_initial.gen_phiZ. -intros. apply mkmorph ; intros; simpl; try reflexivity. -- rewrite Ncring_initial.gen_phiZ_add; reflexivity. -- rewrite ring_sub_def. unfold Z.sub. rewrite Ncring_initial.gen_phiZ_add. - rewrite Ncring_initial.gen_phiZ_opp; reflexivity. -- rewrite Ncring_initial.gen_phiZ_mul; reflexivity. -- rewrite Ncring_initial.gen_phiZ_opp; reflexivity. -- apply Z.eqb_eq in H. rewrite H. reflexivity. -Defined. - -Lemma cring_power_theory : - @Ring_theory.power_theory R one _*_ _==_ N (fun n:N => n) - (@Ring_theory.pow_N _ 1 multiplication). -intros; apply Ring_theory.mkpow_th. reflexivity. Defined. - -Lemma cring_div_theory: - div_theory _==_ Z.add Z.mul Ncring_initial.gen_phiZ Z.quotrem. -intros. apply InitialRing.Ztriv_div_th. unfold Setoid_Theory. -simpl. apply ring_setoid. Defined. - -End cring. - -Ltac cring_gen := - match goal with - |- ?g => - let lterm := lterm_goal g in - let reif := list_reifyl0 lterm in - match reif with - | (?fv, ?lexpr) => - (*idtac "variables:";idtac fv; - idtac "terms:"; idtac lterm; - idtac "reifications:"; idtac lexpr; *) - reify_goal fv lexpr lterm; - match goal with - |- ?g => - generalize - (@Ring_polynom.ring_correct _ 0 1 _+_ _*_ _-_ -_ _==_ - ring_setoid - cring_eq_ext - cring_almost_ring_theory - Z 0%Z 1%Z Z.add Z.mul Z.sub Z.opp Z.eqb - Ncring_initial.gen_phiZ - cring_morph - N - (fun n:N => n) - (@Ring_theory.pow_N _ 1 multiplication) - cring_power_theory - Z.quotrem - cring_div_theory - O fv nil); - let rc := fresh "rc"in - intro rc; apply rc - end - end - end. - -Ltac cring_compute:= vm_compute; reflexivity. - -Ltac cring:= - intros; - cring_gen; - cring_compute. - -#[global] -Instance Zcri: (Cring (Rr:=Zr)). -red. exact Z.mul_comm. Defined. - -(* Cring_simplify *) - -Ltac cring_simplify_aux lterm fv lexpr hyp := - match lterm with - | ?t0::?lterm => - match lexpr with - | ?e::?le => - let t := constr:(@Ring_polynom.norm_subst - Z 0%Z 1%Z Z.add Z.mul Z.sub Z.opp Z.eqb Z.quotrem O nil e) in - let te := - constr:(@Ring_polynom.Pphi_dev - _ 0 1 _+_ _*_ _-_ -_ - Z 0%Z 1%Z Z.eqb - Ncring_initial.gen_phiZ - get_signZ fv t) in - let eq1 := fresh "ring" in - let nft := eval vm_compute in t in - let t':= fresh "t" in - pose (t' := nft); - assert (eq1 : t = t'); - [vm_cast_no_check (eq_refl t')| - let eq2 := fresh "ring" in - assert (eq2:(@Ring_polynom.PEeval - _ zero _+_ _*_ _-_ -_ Z Ncring_initial.gen_phiZ N (fun n:N => n) - (@Ring_theory.pow_N _ 1 multiplication) fv e) == te); - [let eq3 := fresh "ring" in - generalize (@ring_rw_correct _ 0 1 _+_ _*_ _-_ -_ _==_ - ring_setoid - cring_eq_ext - cring_almost_ring_theory - Z 0%Z 1%Z Z.add Z.mul Z.sub Z.opp Z.eqb - Ncring_initial.gen_phiZ - cring_morph - N - (fun n:N => n) - (@Ring_theory.pow_N _ 1 multiplication) - cring_power_theory - Z.quotrem - cring_div_theory - get_signZ get_signZ_th - O nil fv I nil (eq_refl nil) ); - intro eq3; apply eq3; reflexivity| - match hyp with - | 1%nat => rewrite eq2 - | ?H => try rewrite eq2 in H - end]; - let P:= fresh "P" in - match hyp with - | 1%nat => - rewrite eq1; - pattern (@Ring_polynom.Pphi_dev - _ 0 1 _+_ _*_ _-_ -_ - - Z 0%Z 1%Z Z.eqb - Ncring_initial.gen_phiZ - get_signZ fv t'); - match goal with - |- (?p ?t) => set (P:=p) - end; - unfold t' in *; clear t' eq1 eq2; - unfold Pphi_dev, Pphi_avoid; simpl; - repeat (unfold mkmult1, mkmultm1, mkmult_c_pos, mkmult_c, - mkadd_mult, mkmult_c_pos, mkmult_pow, mkadd_mult, - mkpow;simpl) - | ?H => - rewrite eq1 in H; - pattern (@Ring_polynom.Pphi_dev - _ 0 1 _+_ _*_ _-_ -_ - Z 0%Z 1%Z Z.eqb - Ncring_initial.gen_phiZ - get_signZ fv t') in H; - match type of H with - | (?p ?t) => set (P:=p) in H - end; - unfold t' in *; clear t' eq1 eq2; - unfold Pphi_dev, Pphi_avoid in H; simpl in H; - repeat (unfold mkmult1, mkmultm1, mkmult_c_pos, mkmult_c, - mkadd_mult, mkmult_c_pos, mkmult_pow, mkadd_mult, - mkpow in H;simpl in H) - end; unfold P in *; clear P - ]; cring_simplify_aux lterm fv le hyp - | nil => idtac - end - | nil => idtac - end. - -Ltac set_variables fv := - match fv with - | nil => idtac - | ?t::?fv => - let v := fresh "X" in - set (v:=t) in *; set_variables fv - end. - -Ltac deset n:= - match n with - | 0%nat => idtac - | S ?n1 => - match goal with - | h:= ?v : ?t |- ?g => unfold h in *; clear h; deset n1 - end - end. - -(* a est soit un terme de l'anneau, soit une liste de termes. -J'ai pas rĆ©ussi Ć  un dĆ©composer les Vlists obtenues avec ne_constr_list - dans Tactic Notation *) - -Ltac cring_simplify_gen a hyp := - let lterm := - match a with - | _::_ => a - | _ => constr:(a::nil) - end in - let reif := list_reifyl0 lterm in - match reif with - | (?fv, ?lexpr) => idtac lterm; idtac fv; idtac lexpr; - let n := eval compute in (length fv) in - idtac n; - let lt:=fresh "lt" in - set (lt:= lterm); - let lv:=fresh "fv" in - set (lv:= fv); - (* les termes de fv sont remplacĆ©s par des variables - pour pouvoir utiliser simpl ensuite sans risquer - des simplifications indĆ©sirables *) - set_variables fv; - let lterm1 := eval unfold lt in lt in - let lv1 := eval unfold lv in lv in - idtac lterm1; idtac lv1; - cring_simplify_aux lterm1 lv1 lexpr hyp; - clear lt lv; - (* on remet les termes de fv *) - deset n - end. - -Tactic Notation "cring_simplify" constr(lterm):= - cring_simplify_gen lterm 1%nat. - -Tactic Notation "cring_simplify" constr(lterm) "in" ident(H):= - cring_simplify_gen lterm H. diff --git a/stdlib/theories/setoid_ring/Field.v b/stdlib/theories/setoid_ring/Field.v deleted file mode 100644 index be58919a279b..000000000000 --- a/stdlib/theories/setoid_ring/Field.v +++ /dev/null @@ -1,12 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* - match t with - | rO => - fun _ => constr:(@FEO C) - | rI => - fun _ => constr:(@FEI C) - | (radd ?t1 ?t2) => - fun _ => - let e1 := mkP t1 in - let e2 := mkP t2 in constr:(@FEadd C e1 e2) - | (rmul ?t1 ?t2) => - fun _ => - let e1 := mkP t1 in - let e2 := mkP t2 in constr:(@FEmul C e1 e2) - | (rsub ?t1 ?t2) => - fun _ => - let e1 := mkP t1 in - let e2 := mkP t2 in constr:(@FEsub C e1 e2) - | (ropp ?t1) => - fun _ => let e1 := mkP t1 in constr:(@FEopp C e1) - | (rdiv ?t1 ?t2) => - fun _ => - let e1 := mkP t1 in - let e2 := mkP t2 in constr:(@FEdiv C e1 e2) - | (rinv ?t1) => - fun _ => let e1 := mkP t1 in constr:(@FEinv C e1) - | (rpow ?t1 ?n) => - match CstPow n with - | InitialRing.NotConstant => - fun _ => - let p := Find_at t fv in - constr:(@FEX C p) - | ?c => fun _ => let e1 := mkP t1 in constr:(@FEpow C e1 c) - end - | _ => - fun _ => - let p := Find_at t fv in - constr:(@FEX C p) - end - | ?c => fun _ => constr:(@FEc C c) - end in - f () - in mkP t. - - (* We do not assume that Cst recognizes the rO and rI terms as constants, as *) - (* the tactic could be used to discriminate occurrences of an opaque *) - (* constant phi, with (phi 0) not convertible to 0 for instance *) -Ltac FFV Cst CstPow rO rI add mul sub opp div inv pow t fv := - let rec TFV t fv := - match Cst t with - | InitialRing.NotConstant => - match t with - | rO => fv - | rI => fv - | (add ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv) - | (mul ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv) - | (sub ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv) - | (opp ?t1) => TFV t1 fv - | (div ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv) - | (inv ?t1) => TFV t1 fv - | (pow ?t1 ?n) => - match CstPow n with - | InitialRing.NotConstant => - AddFvTail t fv - | _ => TFV t1 fv - end - | _ => AddFvTail t fv - end - | _ => fv - end - in TFV t fv. - -(* packaging the field structure *) - -(* TODO: inline PackField into field_lookup *) -Ltac PackField F req Cst_tac Pow_tac L1 L2 L3 L4 cond_ok pre post := - let FLD := - match type of L1 with - | context [req (@FEeval ?R ?rO ?rI ?radd ?rmul ?rsub ?ropp ?rdiv ?rinv - ?C ?phi ?Cpow ?Cp_phi ?rpow _ _) _ ] => - (fun proj => - proj Cst_tac Pow_tac pre post - req rO rI radd rmul rsub ropp rdiv rinv rpow C L1 L2 L3 L4 cond_ok) - | _ => fail 1 "field anomaly: bad correctness lemma (parse)" - end in - F FLD. - -Ltac get_FldPre FLD := - FLD ltac: - (fun Cst_tac Pow_tac pre post req r0 r1 radd rmul rsub ropp rdiv rinv rpow C - L1 L2 L3 L4 cond_ok => - pre). - -Ltac get_FldPost FLD := - FLD ltac: - (fun Cst_tac Pow_tac pre post req r0 r1 radd rmul rsub ropp rdiv rinv rpow C - L1 L2 L3 L4 cond_ok => - post). - -Ltac get_L1 FLD := - FLD ltac: - (fun Cst_tac Pow_tac pre post req r0 r1 radd rmul rsub ropp rdiv rinv rpow C - L1 L2 L3 L4 cond_ok => - L1). - -Ltac get_SimplifyEqLemma FLD := - FLD ltac: - (fun Cst_tac Pow_tac pre post req r0 r1 radd rmul rsub ropp rdiv rinv rpow C - L1 L2 L3 L4 cond_ok => - L2). - -Ltac get_SimplifyLemma FLD := - FLD ltac: - (fun Cst_tac Pow_tac pre post req r0 r1 radd rmul rsub ropp rdiv rinv rpow C - L1 L2 L3 L4 cond_ok => - L3). - -Ltac get_L4 FLD := - FLD ltac: - (fun Cst_tac Pow_tac pre post req r0 r1 radd rmul rsub ropp rdiv rinv rpow C - L1 L2 L3 L4 cond_ok => - L4). - -Ltac get_CondLemma FLD := - FLD ltac: - (fun Cst_tac Pow_tac pre post req r0 r1 radd rmul rsub ropp rdiv rinv rpow C - L1 L2 L3 L4 cond_ok => - cond_ok). - -Ltac get_FldEq FLD := - FLD ltac: - (fun Cst_tac Pow_tac pre post req r0 r1 radd rmul rsub ropp rdiv rinv rpow C - L1 L2 L3 L4 cond_ok => - req). - -Ltac get_FldCarrier FLD := - let req := get_FldEq FLD in - relation_carrier req. - -Ltac get_RingFV FLD := - FLD ltac: - (fun Cst_tac Pow_tac pre post req r0 r1 radd rmul rsub ropp rdiv rinv rpow C - L1 L2 L3 L4 cond_ok => - FV Cst_tac Pow_tac r0 r1 radd rmul rsub ropp rpow). - -Ltac get_FFV FLD := - FLD ltac: - (fun Cst_tac Pow_tac pre post req r0 r1 radd rmul rsub ropp rdiv rinv rpow C - L1 L2 L3 L4 cond_ok => - FFV Cst_tac Pow_tac r0 r1 radd rmul rsub ropp rdiv rinv rpow). - -Ltac get_RingMeta FLD := - FLD ltac: - (fun Cst_tac Pow_tac pre post req r0 r1 radd rmul rsub ropp rdiv rinv rpow C - L1 L2 L3 L4 cond_ok => - mkPolexpr C Cst_tac Pow_tac r0 r1 radd rmul rsub ropp rpow). - -Ltac get_Meta FLD := - FLD ltac: - (fun Cst_tac Pow_tac pre post req r0 r1 radd rmul rsub ropp rdiv rinv rpow C - L1 L2 L3 L4 cond_ok => - mkFieldexpr C Cst_tac Pow_tac r0 r1 radd rmul rsub ropp rdiv rinv rpow). - -Ltac get_Hyp_tac FLD := - FLD ltac: - (fun Cst_tac Pow_tac pre post req r0 r1 radd rmul rsub ropp rdiv rinv rpow C - L1 L2 L3 L4 cond_ok => - let mkPol := mkPolexpr C Cst_tac Pow_tac r0 r1 radd rmul rsub ropp rpow in - fun fv lH => mkHyp_tac C req ltac:(fun t => mkPol t fv) lH). - -Ltac get_FEeval FLD := - let L1 := get_L1 FLD in - match type of L1 with - | context - [(@FEeval - ?R ?r0 ?r1 ?add ?mul ?sub ?opp ?div ?inv ?C ?phi ?Cpow ?powphi ?pow _ _)] => - constr:(@FEeval R r0 r1 add mul sub opp div inv C phi Cpow powphi pow) - | _ => fail 1 "field anomaly: bad correctness lemma (get_FEeval)" - end. - -(* simplifying the non-zero condition... *) - -Ltac fold_field_cond req := - let rec fold_concl t := - match t with - ?x /\ ?y => - let fx := fold_concl x in let fy := fold_concl y in constr:(fx/\fy) - | req ?x ?y -> False => constr:(~ req x y) - | _ => t - end in - let ft := fold_concl Get_goal in - change ft. - -Ltac simpl_PCond FLD := - let req := get_FldEq FLD in - let lemma := get_CondLemma FLD in - try (apply lemma; intros ?lock ?lock_def; vm_compute; rewrite lock_def; clear lock_def lock); - protect_fv "field_cond"; - fold_field_cond req; - try exact I. - -Ltac simpl_PCond_BEURK FLD := - let req := get_FldEq FLD in - let lemma := get_CondLemma FLD in - (apply lemma; intros ?lock ?lock_def; vm_compute; rewrite lock_def; clear lock_def lock); - protect_fv "field_cond"; - fold_field_cond req. - -(* Rewriting (field_simplify) *) -Ltac Field_norm_gen f n FLD lH rl := - let mkFV := get_RingFV FLD in - let mkFFV := get_FFV FLD in - let mkFE := get_Meta FLD in - let fv0 := FV_hypo_tac mkFV ltac:(get_FldEq FLD) lH in - let lemma_tac fv kont := - let lemma := get_SimplifyLemma FLD in - (* reify equations of the context *) - let lpe := get_Hyp_tac FLD fv lH in - let vlpe := fresh "hyps" in - pose (vlpe := lpe); - let prh := proofHyp_tac lH in - (* compute the normal form of the reified hyps *) - let vlmp := fresh "hyps'" in - let vlmp_eq := fresh "hyps_eq" in - let mk_monpol := get_MonPol lemma in - compute_assertion vlmp_eq vlmp (mk_monpol vlpe); - (* partially instantiate the lemma *) - let lem := fresh "f_rw_lemma" in - (assert (lem := lemma n vlpe fv prh vlmp vlmp_eq) - || fail "type error when building the rewriting lemma"); - (* continuation will call main_tac for all reified terms *) - kont lem; - (* at the end, cleanup *) - (clear lem vlmp_eq vlmp vlpe||idtac"Field_norm_gen:cleanup failed") in - (* each instance of the lemma is simplified then passed to f *) - let main_tac H := protect_fv "field" in H; f H in - (* generate and use equations for each expression *) - ReflexiveRewriteTactic mkFFV mkFE lemma_tac main_tac fv0 rl; - try simpl_PCond FLD. - -(* This is duplicated from Ring_tac mutatis mutandi. but the simplification - lemma is computed in Field_norm_gen, while the ring infrastructure does - it in Ring_simplify_gen. *) -Ltac Field_simplify_gen f FLD lH rl := - let l := fresh "to_rewrite" in - pose (l:= rl); - generalize (eq_refl l); - unfold l at 2; - get_FldPre FLD (); - let rl := - match goal with - | [|- l = ?RL -> _ ] => RL - | _ => fail 1 "ring_simplify anomaly: bad goal after pre" - end in - let Heq := fresh "Heq" in - intros Heq;clear Heq l; - Field_norm_gen f ring_subst_niter FLD lH rl; - get_FldPost FLD (). - -Ltac Field_simplify := - Field_simplify_gen ltac:(fun H => rewrite H). - -Tactic Notation (at level 0) "field_simplify" constr_list(rl) := - let G := Get_goal in - field_lookup (PackField Field_simplify) [] rl G. - -Tactic Notation (at level 0) - "field_simplify" "[" constr_list(lH) "]" constr_list(rl) := - let G := Get_goal in - field_lookup (PackField Field_simplify) [lH] rl G. - -Tactic Notation "field_simplify" constr_list(rl) "in" hyp(H):= - let G := Get_goal in - let t := type of H in - let g := fresh "goal" in - set (g:= G); - revert H; - field_lookup (PackField Field_simplify) [] rl t; - [ intro H; unfold g | .. ]; - clear g. - -Tactic Notation "field_simplify" - "["constr_list(lH) "]" constr_list(rl) "in" hyp(H):= - let G := Get_goal in - let t := type of H in - let g := fresh "goal" in - set (g:= G); - revert H; - field_lookup (PackField Field_simplify) [lH] rl t; - [ intro H; unfold g | .. ]; - clear g. - -(* -Ltac Field_simplify_in hyp:= - Field_simplify_gen ltac:(fun H => rewrite H in hyp). - -Tactic Notation (at level 0) - "field_simplify" constr_list(rl) "in" hyp(h) := - let t := type of h in - field_lookup (Field_simplify_in h) [] rl t. - -Tactic Notation (at level 0) - "field_simplify" "[" constr_list(lH) "]" constr_list(rl) "in" hyp(h) := - let t := type of h in - field_lookup (Field_simplify_in h) [lH] rl t. -*) - -(** Generic tactic for solving equations *) - -Ltac Field_Scheme Simpl_tac n lemma FLD lH := - let req := get_FldEq FLD in - let mkFV := get_RingFV FLD in - let mkFFV := get_FFV FLD in - let mkFE := get_Meta FLD in - let Main_eq t1 t2 := - let fv := FV_hypo_tac mkFV req lH in - let fv := mkFFV t1 fv in - let fv := mkFFV t2 fv in - let lpe := get_Hyp_tac FLD fv lH in - let prh := proofHyp_tac lH in - let vlpe := fresh "list_hyp" in - let fe1 := mkFE t1 fv in - let fe2 := mkFE t2 fv in - pose (vlpe := lpe); - let nlemma := fresh "field_lemma" in - (assert (nlemma := lemma n fv vlpe fe1 fe2 prh) - || fail "field anomaly:failed to build lemma"); - ProveLemmaHyps nlemma - ltac:(fun ilemma => - apply ilemma - || fail "field anomaly: failed in applying lemma"; - [ Simpl_tac | simpl_PCond FLD]); - clear nlemma; - subst vlpe in - OnEquation req Main_eq. - -(* solve completely a field equation, leaving non-zero conditions to be - proved (field) *) - -Ltac FIELD FLD lH rl := - let Simpl := vm_compute; reflexivity || fail "not a valid field equation" in - let lemma := get_L1 FLD in - get_FldPre FLD (); - Field_Scheme Simpl Ring_tac.ring_subst_niter lemma FLD lH; - try exact I; - get_FldPost FLD(). - -Tactic Notation (at level 0) "field" := - let G := Get_goal in - field_lookup (PackField FIELD) [] G. - -Tactic Notation (at level 0) "field" "[" constr_list(lH) "]" := - let G := Get_goal in - field_lookup (PackField FIELD) [lH] G. - -(* transforms a field equation to an equivalent (simplified) ring equation, - and leaves non-zero conditions to be proved (field_simplify_eq) *) -Ltac FIELD_SIMPL FLD lH rl := - let Simpl := (protect_fv "field") in - let lemma := get_SimplifyEqLemma FLD in - get_FldPre FLD (); - Field_Scheme Simpl Ring_tac.ring_subst_niter lemma FLD lH; - get_FldPost FLD (). - -Tactic Notation (at level 0) "field_simplify_eq" := - let G := Get_goal in - field_lookup (PackField FIELD_SIMPL) [] G. - -Tactic Notation (at level 0) "field_simplify_eq" "[" constr_list(lH) "]" := - let G := Get_goal in - field_lookup (PackField FIELD_SIMPL) [lH] G. - -(* Same as FIELD_SIMPL but in hypothesis *) - -Ltac Field_simplify_eq n FLD lH := - let req := get_FldEq FLD in - let mkFV := get_RingFV FLD in - let mkFFV := get_FFV FLD in - let mkFE := get_Meta FLD in - let lemma := get_L4 FLD in - let hyp := fresh "hyp" in - intro hyp; - OnEquationHyp req hyp ltac:(fun t1 t2 => - let fv := FV_hypo_tac mkFV req lH in - let fv := mkFFV t1 fv in - let fv := mkFFV t2 fv in - let lpe := get_Hyp_tac FLD fv lH in - let prh := proofHyp_tac lH in - let fe1 := mkFE t1 fv in - let fe2 := mkFE t2 fv in - let vlpe := fresh "vlpe" in - ProveLemmaHyps (lemma n fv lpe fe1 fe2 prh) - ltac:(fun ilemma => - match type of ilemma with - | req _ _ -> _ -> ?EQ => - let tmp := fresh "tmp" in - assert (tmp : EQ); - [ apply ilemma; [ exact hyp | simpl_PCond_BEURK FLD] - | protect_fv "field" in tmp; revert tmp ]; - clear hyp - end)). - -Ltac FIELD_SIMPL_EQ FLD lH rl := - get_FldPre FLD (); - Field_simplify_eq Ring_tac.ring_subst_niter FLD lH; - get_FldPost FLD (). - -Tactic Notation (at level 0) "field_simplify_eq" "in" hyp(H) := - let t := type of H in - generalize H; - field_lookup (PackField FIELD_SIMPL_EQ) [] t; - [ try exact I - | clear H;intro H]. - - -Tactic Notation (at level 0) - "field_simplify_eq" "[" constr_list(lH) "]" "in" hyp(H) := - let t := type of H in - generalize H; - field_lookup (PackField FIELD_SIMPL_EQ) [lH] t; - [ try exact I - |clear H;intro H]. - -(* More generic tactics to build variants of field *) - -(* This tactic reifies c and pass to F: - - the FLD structure gathering all info in the field DB - - the atom list - - the expression (FExpr) - *) -Ltac gen_with_field F c := - let MetaExpr FLD _ rl := - let R := get_FldCarrier FLD in - let mkFFV := get_FFV FLD in - let mkFE := get_Meta FLD in - let csr := - match rl with - | List.cons ?r _ => r - | _ => fail 1 "anomaly: ill-formed list" - end in - let fv := mkFFV csr (@List.nil R) in - let expr := mkFE csr fv in - F FLD fv expr in - field_lookup (PackField MetaExpr) [] (c=c). - - -(* pushes the equation expr = ope(expr) in the goal, and - discharge it with field *) -Ltac prove_field_eqn ope FLD fv expr := - let res := ope expr in - let expr' := fresh "input_expr" in - pose (expr' := expr); - let res' := fresh "result" in - pose (res' := res); - let lemma := get_L1 FLD in - let lemma := - constr:(lemma O fv List.nil expr' res' I List.nil (eq_refl _)) in - let ty := type of lemma in - let lhs := match ty with - forall _, ?lhs=_ -> _ => lhs - end in - let rhs := match ty with - forall _, _=_ -> forall _, ?rhs=_ -> _ => rhs - end in - let lhs' := fresh "lhs" in let lhs_eq := fresh "lhs_eq" in - let rhs' := fresh "rhs" in let rhs_eq := fresh "rhs_eq" in - compute_assertion lhs_eq lhs' lhs; - compute_assertion rhs_eq rhs' rhs; - let H := fresh "fld_eqn" in - refine (_ (lemma lhs' lhs_eq rhs' rhs_eq _ _)); - (* main goal *) - [intro H;protect_fv "field" in H; revert H - (* ring-nf(lhs') = ring-nf(rhs') *) - | vm_compute; reflexivity || fail "field cannot prove this equality" - (* denominator condition *) - | simpl_PCond FLD]; - clear lhs_eq rhs_eq; subst lhs' rhs'. - -Ltac prove_with_field ope c := - gen_with_field ltac:(prove_field_eqn ope) c. - -(* Prove an equation x=ope(x) and rewrite with it *) -Ltac prove_rw ope x := - prove_with_field ope x; - [ let H := fresh "Heq_maple" in - intro H; rewrite H; clear H - |..]. - -(* Apply ope (FExpr->FExpr) on an expression *) -Ltac reduce_field_expr ope kont FLD fv expr := - let evfun := get_FEeval FLD in - let res := ope expr in - let c := (eval simpl_field_expr in (evfun fv res)) in - kont c. - -(* Hack to let a Ltac return a term in the context of a primitive tactic *) -Ltac return_term x := generalize (eq_refl x). -Ltac get_term := - match goal with - | |- ?x = _ -> _ => x - end. - -(* Turn an operation on field expressions (FExpr) into a reduction - on terms (in the field carrier). Because of field_lookup, - the tactic cannot return a term directly, so it is returned - via the conclusion of the goal (return_term). *) -Ltac reduce_field_ope ope c := - gen_with_field ltac:(reduce_field_expr ope return_term) c. - - -(* Adding a new field *) - -Ltac ring_of_field f := - match type of f with - | almost_field_theory _ _ _ _ _ _ _ _ _ => constr:(AF_AR f) - | field_theory _ _ _ _ _ _ _ _ _ => constr:(F_R f) - | semi_field_theory _ _ _ _ _ _ _ => constr:(SF_SR f) - end. - -Ltac coerce_to_almost_field set ext f := - match type of f with - | almost_field_theory _ _ _ _ _ _ _ _ _ => f - | field_theory _ _ _ _ _ _ _ _ _ => constr:(F2AF set ext f) - | semi_field_theory _ _ _ _ _ _ _ => constr:(SF2AF set f) - end. - -Ltac field_elements set ext fspec pspec sspec dspec rk := - let afth := coerce_to_almost_field set ext fspec in - let rspec := ring_of_field fspec in - ring_elements set ext rspec pspec sspec dspec rk - ltac:(fun arth ext_r morph p_spec s_spec d_spec f => f afth ext_r morph p_spec s_spec d_spec). - -Ltac field_lemmas set ext inv_m fspec pspec sspec dspec rk := - let get_lemma := - match pspec with None => fun x y => x | _ => fun x y => y end in - let simpl_eq_lemma := get_lemma - Field_simplify_eq_correct Field_simplify_eq_pow_correct in - let simpl_eq_in_lemma := get_lemma - Field_simplify_eq_in_correct Field_simplify_eq_pow_in_correct in - let rw_lemma := get_lemma - Field_rw_correct Field_rw_pow_correct in - field_elements set ext fspec pspec sspec dspec rk - ltac:(fun afth ext_r morph p_spec s_spec d_spec => - match morph with - | _ => - let field_ok1 := constr:(Field_correct set ext_r inv_m afth morph) in - match p_spec with - | mkhypo ?pp_spec => - let field_ok2 := constr:(field_ok1 _ _ _ pp_spec) in - match s_spec with - | mkhypo ?ss_spec => - match d_spec with - | mkhypo ?dd_spec => - let field_ok := constr:(field_ok2 _ dd_spec) in - let mk_lemma lemma := - constr:(lemma _ _ _ _ _ _ _ _ _ _ - set ext_r inv_m afth - _ _ _ _ _ _ _ _ _ morph - _ _ _ pp_spec _ ss_spec _ dd_spec) in - let field_simpl_eq_ok := mk_lemma simpl_eq_lemma in - let field_simpl_ok := mk_lemma rw_lemma in - let field_simpl_eq_in := mk_lemma simpl_eq_in_lemma in - let cond1_ok := - constr:(Pcond_simpl_gen set ext_r afth morph pp_spec dd_spec) in - let cond2_ok := - constr:(Pcond_simpl_complete set ext_r afth morph pp_spec dd_spec) in - (fun f => - f afth ext_r morph field_ok field_simpl_ok field_simpl_eq_ok field_simpl_eq_in - cond1_ok cond2_ok) - | _ => fail 4 "field: bad coefficient division specification" - end - | _ => fail 3 "field: bad sign specification" - end - | _ => fail 2 "field: bad power specification" - end - | _ => fail 1 "field internal error : field_lemmas, please report" - end). - -(** Registering for the ML plugin *) - -Register display_linear as plugins.field.display_linear. -Register display_pow_linear as plugins.field.display_pow_linear. -Register FEeval as plugins.field.FEeval. -Register PCond as plugins.field.PCond. - -Register almost_field_theory as plugins.field.almost_field_theory. -Register semi_field_theory as plugins.field.semi_field_theory. -Register field_theory as plugins.field.field_theory. - -Register AF_AR as plugins.field.AF_AR. -Register SF_SR as plugins.field.SF_SR. -Register F_R as plugins.field.F_R. diff --git a/stdlib/theories/setoid_ring/Field_theory.v b/stdlib/theories/setoid_ring/Field_theory.v deleted file mode 100644 index df708bc2a149..000000000000 --- a/stdlib/theories/setoid_ring/Field_theory.v +++ /dev/null @@ -1,1830 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* R->R) (ropp : R->R). -Variable (rdiv : R->R->R) (rinv : R->R). -Variable req : R -> R -> Prop. - -Notation "0" := rO : R_scope. -Notation "1" := rI : R_scope. -Infix "+" := radd : R_scope. -Infix "-" := rsub : R_scope. -Infix "*" := rmul : R_scope. -Infix "/" := rdiv : R_scope. -Notation "- x" := (ropp x) : R_scope. -Notation "/ x" := (rinv x) : R_scope. -Infix "==" := req (at level 70, no associativity) : R_scope. - -(* Equality properties *) -Variable Rsth : Equivalence req. -Variable Reqe : ring_eq_ext radd rmul ropp req. -Variable SRinv_ext : forall p q, p == q -> / p == / q. - -(* Field properties *) -Record almost_field_theory : Prop := mk_afield { - AF_AR : almost_ring_theory rO rI radd rmul rsub ropp req; - AF_1_neq_0 : ~ 1 == 0; - AFdiv_def : forall p q, p / q == p * / q; - AFinv_l : forall p, ~ p == 0 -> / p * p == 1 -}. - -Section AlmostField. - -Variable AFth : almost_field_theory. -Let ARth := (AF_AR AFth). -Let rI_neq_rO := (AF_1_neq_0 AFth). -Let rdiv_def := (AFdiv_def AFth). -Let rinv_l := (AFinv_l AFth). - -Add Morphism radd with signature (req ==> req ==> req) as radd_ext. -Proof. exact (Radd_ext Reqe). Qed. -Add Morphism rmul with signature (req ==> req ==> req) as rmul_ext. -Proof. exact (Rmul_ext Reqe). Qed. -Add Morphism ropp with signature (req ==> req) as ropp_ext. -Proof. exact (Ropp_ext Reqe). Qed. -Add Morphism rsub with signature (req ==> req ==> req) as rsub_ext. -Proof. exact (ARsub_ext Rsth Reqe ARth). Qed. -Add Morphism rinv with signature (req ==> req) as rinv_ext. -Proof. exact SRinv_ext. Qed. - -Let eq_trans := Setoid.Seq_trans _ _ Rsth. -Let eq_sym := Setoid.Seq_sym _ _ Rsth. -Let eq_refl := Setoid.Seq_refl _ _ Rsth. - -Let radd_0_l := ARadd_0_l ARth. -Let radd_comm := ARadd_comm ARth. -Let radd_assoc := ARadd_assoc ARth. -Let rmul_1_l := ARmul_1_l ARth. -Let rmul_0_l := ARmul_0_l ARth. -Let rmul_comm := ARmul_comm ARth. -Let rmul_assoc := ARmul_assoc ARth. -Let rdistr_l := ARdistr_l ARth. -Let ropp_mul_l := ARopp_mul_l ARth. -Let ropp_add := ARopp_add ARth. -Let rsub_def := ARsub_def ARth. - -Let radd_0_r := ARadd_0_r Rsth ARth. -Let rmul_0_r := ARmul_0_r Rsth ARth. -Let rmul_1_r := ARmul_1_r Rsth ARth. -Let ropp_0 := ARopp_zero Rsth Reqe ARth. -Let rdistr_r := ARdistr_r Rsth Reqe ARth. - -(* Coefficients : C *) - -Variable C: Type. -Declare Scope C_scope. -Bind Scope C_scope with C. -Delimit Scope C_scope with coef. - -Variable (cO cI: C) (cadd cmul csub : C->C->C) (copp : C->C). -Variable ceqb : C->C->bool. -Variable phi : C -> R. - -Variable CRmorph : ring_morph rO rI radd rmul rsub ropp req - cO cI cadd cmul csub copp ceqb phi. - -Notation "0" := cO : C_scope. -Notation "1" := cI : C_scope. -Infix "+" := cadd : C_scope. -Infix "-" := csub : C_scope. -Infix "*" := cmul : C_scope. -Notation "- x" := (copp x) : C_scope. -Infix "=?" := ceqb : C_scope. -Notation "[ x ]" := (phi x) (at level 0). - -Let phi_0 := (morph0 CRmorph). -Let phi_1 := (morph1 CRmorph). - -Lemma ceqb_spec c c' : BoolSpec ([c] == [c']) True (c =? c')%coef. -Proof. -generalize ((morph_eq CRmorph) c c'). -destruct (c =? c')%coef; auto. -Qed. - -(* Power coefficients : Cpow *) - -Variable Cpow : Type. -Variable Cp_phi : N -> Cpow. -Variable rpow : R -> Cpow -> R. -Variable pow_th : power_theory rI rmul req Cp_phi rpow. -(* sign function *) -Variable get_sign : C -> option C. -Variable get_sign_spec : sign_theory copp ceqb get_sign. - -Variable cdiv:C -> C -> C*C. -Variable cdiv_th : div_theory req cadd cmul phi cdiv. - -Let rpow_pow := (rpow_pow_N pow_th). - -(* Polynomial expressions : (PExpr C) *) - -Declare Scope PE_scope. -Bind Scope PE_scope with PExpr. -Delimit Scope PE_scope with poly. - -Notation NPEeval := (PEeval rO rI radd rmul rsub ropp phi Cp_phi rpow). -Notation "P @ l" := (NPEeval l P) (at level 10, no associativity). - -Arguments PEc _ _%_coef. - -Notation "0" := (PEc 0) : PE_scope. -Notation "1" := (PEc 1) : PE_scope. -Infix "+" := PEadd : PE_scope. -Infix "-" := PEsub : PE_scope. -Infix "*" := PEmul : PE_scope. -Notation "- e" := (PEopp e) : PE_scope. -Infix "^" := PEpow : PE_scope. - -Definition NPEequiv e e' := forall l, e@l == e'@l. -Infix "===" := NPEequiv (at level 70, no associativity) : PE_scope. - -Instance NPEequiv_eq : Equivalence NPEequiv. -Proof. - split; red; unfold NPEequiv; intros; [reflexivity|symmetry|etransitivity]; - eauto. -Qed. - -Instance NPEeval_ext : Proper (eq ==> NPEequiv ==> req) NPEeval. -Proof. - intros l l' <- e e' He. now rewrite (He l). -Qed. - -Notation Nnorm := - (norm_subst cO cI cadd cmul csub copp ceqb cdiv). -Notation NPphi_dev := - (Pphi_dev rO rI radd rmul rsub ropp cO cI ceqb phi get_sign). -Notation NPphi_pow := - (Pphi_pow rO rI radd rmul rsub ropp cO cI ceqb phi Cp_phi rpow get_sign). - -(* add abstract semi-ring to help with some proofs *) -Add Ring Rring : (ARth_SRth ARth). - -(* additional ring properties *) - -Lemma rsub_0_l r : 0 - r == - r. -Proof. -rewrite rsub_def; ring. -Qed. - -Lemma rsub_0_r r : r - 0 == r. -Proof. -rewrite rsub_def, ropp_0; ring. -Qed. - -(*************************************************************************** - - Properties of division - - ***************************************************************************) - -Theorem rdiv_simpl p q : ~ q == 0 -> q * (p / q) == p. -Proof. -intros. -rewrite rdiv_def. -transitivity (/ q * q * p); [ ring | ]. -now rewrite rinv_l. -Qed. - -Instance rdiv_ext: Proper (req ==> req ==> req) rdiv. -Proof. -intros p1 p2 Ep q1 q2 Eq. now rewrite !rdiv_def, Ep, Eq. -Qed. - -Lemma rmul_reg_l p q1 q2 : - ~ p == 0 -> p * q1 == p * q2 -> q1 == q2. -Proof. -intros H EQ. -assert (H' : p * (q1 / p) == p * (q2 / p)). -{ now rewrite !rdiv_def, !rmul_assoc, EQ. } -now rewrite !rdiv_simpl in H'. -Qed. - -Theorem field_is_integral_domain r1 r2 : - ~ r1 == 0 -> ~ r2 == 0 -> ~ r1 * r2 == 0. -Proof. -intros H1 H2. contradict H2. -transitivity (/r1 * r1 * r2). -- now rewrite rinv_l. -- now rewrite <- rmul_assoc, H2. -Qed. - -Theorem ropp_neq_0 r : - ~ -(1) == 0 -> ~ r == 0 -> ~ -r == 0. -Proof. -intros. -setoid_replace (- r) with (- (1) * r). -- apply field_is_integral_domain; trivial. -- now rewrite <- ropp_mul_l, rmul_1_l. -Qed. - -Theorem rdiv_r_r r : ~ r == 0 -> r / r == 1. -Proof. -intros. rewrite rdiv_def, rmul_comm. now apply rinv_l. -Qed. - -Theorem rdiv1 r : r == r / 1. -Proof. -transitivity (1 * (r / 1)). -- symmetry; apply rdiv_simpl. apply rI_neq_rO. -- apply rmul_1_l. -Qed. - -Theorem rdiv2 a b c d : - ~ b == 0 -> - ~ d == 0 -> - a / b + c / d == (a * d + c * b) / (b * d). -Proof. -intros H H0. -assert (~ b * d == 0) by now apply field_is_integral_domain. -apply rmul_reg_l with (b * d); trivial. -rewrite rdiv_simpl; trivial. -rewrite rdistr_r. -apply radd_ext. -- now rewrite <- rmul_assoc, (rmul_comm d), rmul_assoc, rdiv_simpl. -- now rewrite (rmul_comm c), <- rmul_assoc, rdiv_simpl. -Qed. - - -Theorem rdiv2b a b c d e : - ~ (b*e) == 0 -> - ~ (d*e) == 0 -> - a / (b*e) + c / (d*e) == (a * d + c * b) / (b * (d * e)). -Proof. -intros H H0. -assert (~ b == 0) by (contradict H; rewrite H; ring). -assert (~ e == 0) by (contradict H; rewrite H; ring). -assert (~ d == 0) by (contradict H0; rewrite H0; ring). -assert (~ b * (d * e) == 0) - by (repeat apply field_is_integral_domain; trivial). -apply rmul_reg_l with (b * (d * e)); trivial. -rewrite rdiv_simpl; trivial. -rewrite rdistr_r. -apply radd_ext. -- transitivity ((b * e) * (a / (b * e)) * d); - [ ring | now rewrite rdiv_simpl ]. -- transitivity ((d * e) * (c / (d * e)) * b); - [ ring | now rewrite rdiv_simpl ]. -Qed. - -Theorem rdiv5 a b : - (a / b) == - a / b. -Proof. -now rewrite !rdiv_def, ropp_mul_l. -Qed. - -Theorem rdiv3b a b c d e : - ~ (b * e) == 0 -> - ~ (d * e) == 0 -> - a / (b*e) - c / (d*e) == (a * d - c * b) / (b * (d * e)). -Proof. -intros H H0. -rewrite !rsub_def, rdiv5, ropp_mul_l. -now apply rdiv2b. -Qed. - -Theorem rdiv6 a b : - ~ a == 0 -> ~ b == 0 -> / (a / b) == b / a. -Proof. -intros H H0. -assert (Hk : ~ a / b == 0). -{ contradict H. - transitivity (b * (a / b)). - - now rewrite rdiv_simpl. - - rewrite H. apply rmul_0_r. } -apply rmul_reg_l with (a / b); trivial. -rewrite (rmul_comm (a / b)), rinv_l; trivial. -rewrite !rdiv_def. -transitivity (/ a * a * (/ b * b)); [ | ring ]. -now rewrite !rinv_l, rmul_1_l. -Qed. - -Theorem rdiv4 a b c d : - ~ b == 0 -> - ~ d == 0 -> - (a / b) * (c / d) == (a * c) / (b * d). -Proof. -intros H H0. -assert (~ b * d == 0) by now apply field_is_integral_domain. -apply rmul_reg_l with (b * d); trivial. -rewrite rdiv_simpl; trivial. -transitivity (b * (a / b) * (d * (c / d))); [ ring | ]. -rewrite !rdiv_simpl; trivial. -Qed. - -Theorem rdiv4b a b c d e f : - ~ b * e == 0 -> - ~ d * f == 0 -> - ((a * f) / (b * e)) * ((c * e) / (d * f)) == (a * c) / (b * d). -Proof. -intros H H0. -assert (~ b == 0) by (contradict H; rewrite H; ring). -assert (~ e == 0) by (contradict H; rewrite H; ring). -assert (~ d == 0) by (contradict H0; rewrite H0; ring). -assert (~ f == 0) by (contradict H0; rewrite H0; ring). -assert (~ b*d == 0) by now apply field_is_integral_domain. -assert (~ e*f == 0) by now apply field_is_integral_domain. -rewrite rdiv4; trivial. -transitivity ((e * f) * (a * c) / ((e * f) * (b * d))). -- apply rdiv_ext; ring. -- rewrite <- rdiv4, rdiv_r_r; trivial. -Qed. - -Theorem rdiv7 a b c d : - ~ b == 0 -> - ~ c == 0 -> - ~ d == 0 -> - (a / b) / (c / d) == (a * d) / (b * c). -Proof. -intros. -rewrite (rdiv_def (a / b)). -rewrite rdiv6; trivial. -apply rdiv4; trivial. -Qed. - -Theorem rdiv7b a b c d e f : - ~ b * f == 0 -> - ~ c * e == 0 -> - ~ d * f == 0 -> - ((a * e) / (b * f)) / ((c * e) / (d * f)) == (a * d) / (b * c). -Proof. -intros Hbf Hce Hdf. -assert (~ c==0) by (contradict Hce; rewrite Hce; ring). -assert (~ e==0) by (contradict Hce; rewrite Hce; ring). -assert (~ b==0) by (contradict Hbf; rewrite Hbf; ring). -assert (~ f==0) by (contradict Hbf; rewrite Hbf; ring). -assert (~ b*c==0) by now apply field_is_integral_domain. -assert (~ e*f==0) by now apply field_is_integral_domain. -rewrite rdiv7; trivial. -transitivity ((e * f) * (a * d) / ((e * f) * (b * c))). -- apply rdiv_ext; ring. -- now rewrite <- rdiv4, rdiv_r_r. -Qed. - -Theorem rinv_nz a : ~ a == 0 -> ~ /a == 0. -Proof. -intros H H0. apply rI_neq_rO. -rewrite <- (rdiv_r_r H), rdiv_def, H0. apply rmul_0_r. -Qed. - -Theorem rdiv8 a b : ~ b == 0 -> a == 0 -> a / b == 0. -Proof. -intros H H0. -now rewrite rdiv_def, H0, rmul_0_l. -Qed. - -Theorem cross_product_eq a b c d : - ~ b == 0 -> ~ d == 0 -> a * d == c * b -> a / b == c / d. -Proof. -intros H H0 H1. -transitivity (a / b * (d / d)). -- now rewrite rdiv_r_r, rmul_1_r. -- now rewrite rdiv4, H1, (rmul_comm b d), <- rdiv4, rdiv_r_r. -Qed. - -(* Results about [pow_pos] and [pow_N] *) - -Instance pow_ext : Proper (req ==> eq ==> req) (pow_pos rmul). -Proof. -intros x y H p p' <-. -induction p as [p IH| p IH|];simpl; trivial; now rewrite !IH, ?H. -Qed. - -Instance pow_N_ext : Proper (req ==> eq ==> req) (pow_N rI rmul). -Proof. -intros x y H n n' <-. destruct n; simpl; trivial. now apply pow_ext. -Qed. - -Lemma pow_pos_0 p : pow_pos rmul 0 p == 0. -Proof. -induction p as [p IHp|p IHp|];simpl;trivial; now rewrite !IHp. -Qed. - -Lemma pow_pos_1 p : pow_pos rmul 1 p == 1. -Proof. -induction p as [p IHp|p IHp|];simpl;trivial; ring [IHp]. -Qed. - -Lemma pow_pos_cst c p : pow_pos rmul [c] p == [pow_pos cmul c p]. -Proof. -induction p as [p IHp|p IHp|];simpl;trivial; now rewrite !(morph_mul CRmorph), !IHp. -Qed. - -Lemma pow_pos_mul_l x y p : - pow_pos rmul (x * y) p == pow_pos rmul x p * pow_pos rmul y p. -Proof. -induction p as [p IHp|p IHp|];simpl;trivial; ring [IHp]. -Qed. - -Lemma pow_pos_add_r x p1 p2 : - pow_pos rmul x (p1+p2) == pow_pos rmul x p1 * pow_pos rmul x p2. -Proof. - exact (Ring_theory.pow_pos_add Rsth rmul_ext rmul_assoc x p1 p2). -Qed. - -Lemma pow_pos_mul_r x p1 p2 : - pow_pos rmul x (p1*p2) == pow_pos rmul (pow_pos rmul x p1) p2. -Proof. -induction p1 as [p1 IHp1|p1 IHp1|];simpl;intros; rewrite ?pow_pos_mul_l, ?pow_pos_add_r; - simpl; trivial; ring [IHp1]. -Qed. - -Lemma pow_pos_nz x p : ~x==0 -> ~pow_pos rmul x p == 0. -Proof. - intros Hx. induction p;simpl;trivial; - repeat (apply field_is_integral_domain; trivial). -Qed. - -Lemma pow_pos_div a b p : ~ b == 0 -> - pow_pos rmul (a / b) p == pow_pos rmul a p / pow_pos rmul b p. -Proof. - intros H. - induction p as [p IHp|p IHp|]; simpl; trivial. - - rewrite IHp. - assert (nz := pow_pos_nz p H). - rewrite !rdiv4; trivial. - apply field_is_integral_domain; trivial. - - rewrite IHp. - assert (nz := pow_pos_nz p H). - rewrite !rdiv4; trivial. -Qed. - -(* === is a morphism *) - -Instance PEadd_ext : Proper (NPEequiv ==> NPEequiv ==> NPEequiv) (@PEadd C). -Proof. intros ? ? E ? ? E' l. simpl. now rewrite E, E'. Qed. -Instance PEsub_ext : Proper (NPEequiv ==> NPEequiv ==> NPEequiv) (@PEsub C). -Proof. intros ? ? E ? ? E' l. simpl. now rewrite E, E'. Qed. -Instance PEmul_ext : Proper (NPEequiv ==> NPEequiv ==> NPEequiv) (@PEmul C). -Proof. intros ? ? E ? ? E' l. simpl. now rewrite E, E'. Qed. -Instance PEopp_ext : Proper (NPEequiv ==> NPEequiv) (@PEopp C). -Proof. intros ? ? E l. simpl. now rewrite E. Qed. -Instance PEpow_ext : Proper (NPEequiv ==> eq ==> NPEequiv) (@PEpow C). -Proof. - intros ? ? E ? ? <- l. simpl. rewrite !rpow_pow. apply pow_N_ext; trivial. -Qed. - -Lemma PE_1_l (e : PExpr C) : (1 * e === e)%poly. -Proof. - intros l. simpl. rewrite phi_1. apply rmul_1_l. -Qed. - -Lemma PE_1_r (e : PExpr C) : (e * 1 === e)%poly. -Proof. - intros l. simpl. rewrite phi_1. apply rmul_1_r. -Qed. - -Lemma PEpow_0_r (e : PExpr C) : (e ^ 0 === 1)%poly. -Proof. - intros l. simpl. now rewrite !rpow_pow. -Qed. - -Lemma PEpow_1_r (e : PExpr C) : (e ^ 1 === e)%poly. -Proof. - intros l. simpl. now rewrite !rpow_pow. -Qed. - -Lemma PEpow_1_l n : (1 ^ n === 1)%poly. -Proof. - intros l. simpl. rewrite rpow_pow. destruct n; simpl. - - now rewrite phi_1. - - now rewrite phi_1, pow_pos_1. -Qed. - -Lemma PEpow_add_r (e : PExpr C) n n' : - (e ^ (n+n') === e ^ n * e ^ n')%poly. -Proof. - intros l. simpl. rewrite !rpow_pow. - destruct n; simpl. - - rewrite rmul_1_l. trivial. - - destruct n'; simpl. - + rewrite rmul_1_r. trivial. - + apply pow_pos_add_r. -Qed. - -Lemma PEpow_mul_l (e e' : PExpr C) n : - ((e * e') ^ n === e ^ n * e' ^ n)%poly. -Proof. - intros l. simpl. rewrite !rpow_pow. destruct n; simpl; trivial. - - symmetry; apply rmul_1_l. - - apply pow_pos_mul_l. -Qed. - -Lemma PEpow_mul_r (e : PExpr C) n n' : - (e ^ (n * n') === (e ^ n) ^ n')%poly. -Proof. - intros l. simpl. rewrite !rpow_pow. - destruct n, n'; simpl; trivial. - - now rewrite pow_pos_1. - - apply pow_pos_mul_r. -Qed. - -Lemma PEpow_nz l e n : ~ e @ l == 0 -> ~ (e^n) @ l == 0. -Proof. - intros. simpl. rewrite rpow_pow. destruct n; simpl. - - apply rI_neq_rO. - - now apply pow_pos_nz. -Qed. - - -(*************************************************************************** - - Some equality test - - ***************************************************************************) - -Local Notation "a &&& b" := (if a then b else false) - (at level 40, left associativity). - -(* equality test *) -Fixpoint PExpr_eq (e e' : PExpr C) {struct e} : bool := - match e, e' with - | PEc c, PEc c' => ceqb c c' - | PEX _ p, PEX _ p' => Pos.eqb p p' - | e1 + e2, e1' + e2' => PExpr_eq e1 e1' &&& PExpr_eq e2 e2' - | e1 - e2, e1' - e2' => PExpr_eq e1 e1' &&& PExpr_eq e2 e2' - | e1 * e2, e1' * e2' => PExpr_eq e1 e1' &&& PExpr_eq e2 e2' - | - e, - e' => PExpr_eq e e' - | e ^ n, e' ^ n' => N.eqb n n' &&& PExpr_eq e e' - | _, _ => false - end%poly. - -Lemma if_true (a b : bool) : a &&& b = true -> a = true /\ b = true. -Proof. - destruct a, b; split; trivial. -Qed. - -Theorem PExpr_eq_semi_ok e e' : - PExpr_eq e e' = true -> (e === e')%poly. -Proof. -revert e'; induction e as [| |?|?|? IHe1 ? IHe2|? IHe1 ? IHe2|? IHe1 ? IHe2|? IHe|? IHe ?]; - intro e'; destruct e'; simpl; try discriminate. -- intros H l. now apply (morph_eq CRmorph). -- case Pos.eqb_spec; intros; now subst. -- intros H; destruct (if_true _ _ H). now rewrite IHe1, IHe2. -- intros H; destruct (if_true _ _ H). now rewrite IHe1, IHe2. -- intros H; destruct (if_true _ _ H). now rewrite IHe1, IHe2. -- intros H. now rewrite IHe. -- intros H. destruct (if_true _ _ H) as [H0 H1]. - apply N.eqb_eq in H0. now rewrite IHe, H0. -Qed. - -Lemma PExpr_eq_spec e e' : BoolSpec (e === e')%poly True (PExpr_eq e e'). -Proof. - assert (H := PExpr_eq_semi_ok e e'). - destruct PExpr_eq; constructor; intros; trivial. now apply H. -Qed. - -(** Smart constructors for polynomial expression, - with reduction of constants *) - -Definition NPEadd e1 e2 := - match e1, e2 with - | PEc c1, PEc c2 => PEc (c1 + c2) - | PEc c, _ => if (c =? 0)%coef then e2 else e1 + e2 - | _, PEc c => if (c =? 0)%coef then e1 else e1 + e2 - (* Peut t'on factoriser ici ??? *) - | _, _ => (e1 + e2) - end%poly. -Infix "++" := NPEadd (at level 60, right associativity). - -Theorem NPEadd_ok e1 e2 : (e1 ++ e2 === e1 + e2)%poly. -Proof. -intros l. -destruct e1, e2; simpl; try reflexivity; try (case ceqb_spec); -try intro H; try rewrite H; simpl; -try apply eq_refl; try (ring [phi_0]). -apply (morph_add CRmorph). -Qed. - -Definition NPEsub e1 e2 := - match e1, e2 with - | PEc c1, PEc c2 => PEc (c1 - c2) - | PEc c, _ => if (c =? 0)%coef then - e2 else e1 - e2 - | _, PEc c => if (c =? 0)%coef then e1 else e1 - e2 - (* Peut-on factoriser ici *) - | _, _ => e1 - e2 - end%poly. -Infix "--" := NPEsub (at level 50, left associativity). - -Theorem NPEsub_ok e1 e2: (e1 -- e2 === e1 - e2)%poly. -Proof. -intros l. -destruct e1, e2; simpl; try reflexivity; try case ceqb_spec; - try intro H; try rewrite H; simpl; - try rewrite phi_0; try reflexivity; - try (symmetry; apply rsub_0_l); try (symmetry; apply rsub_0_r). -apply (morph_sub CRmorph). -Qed. - -Definition NPEopp e1 := - match e1 with PEc c1 => PEc (- c1) | _ => - e1 end%poly. - -Theorem NPEopp_ok e : (NPEopp e === -e)%poly. -Proof. -intros l. destruct e; simpl; trivial. apply (morph_opp CRmorph). -Qed. - -Definition NPEpow x n := - match n with - | N0 => 1 - | Npos p => - if (p =? 1)%positive then x else - match x with - | PEc c => - if (c =? 1)%coef then 1 - else if (c =? 0)%coef then 0 - else PEc (pow_pos cmul c p) - | _ => x ^ n - end - end%poly. -Infix "^^" := NPEpow (at level 35, right associativity). - -Theorem NPEpow_ok e n : (e ^^ n === e ^ n)%poly. -Proof. - intros l. unfold NPEpow; destruct n. - - simpl; now rewrite rpow_pow. - - case Pos.eqb_spec; [intro; subst | intros _]. - + simpl. now rewrite rpow_pow. - + destruct e;simpl;trivial. - repeat case ceqb_spec; intros H **; rewrite ?rpow_pow, ?H; simpl. - * now rewrite phi_1, pow_pos_1. - * now rewrite phi_0, pow_pos_0. - * now rewrite pow_pos_cst. -Qed. - -Fixpoint NPEmul (x y : PExpr C) {struct x} : PExpr C := - match x, y with - | PEc c1, PEc c2 => PEc (c1 * c2) - | PEc c, _ => if (c =? 1)%coef then y else if (c =? 0)%coef then 0 else x * y - | _, PEc c => if (c =? 1)%coef then x else if (c =? 0)%coef then 0 else x * y - | e1 ^ n1, e2 ^ n2 => if (n1 =? n2)%N then (NPEmul e1 e2)^^n1 else x * y - | _, _ => x * y - end%poly. -Infix "**" := NPEmul (at level 40, left associativity). - -Theorem NPEmul_ok e1 e2 : (e1 ** e2 === e1 * e2)%poly. -Proof. -intros l. -revert e2; induction e1 as [| |?|?|? IHe1 ? IHe2|? IHe1 ? IHe2|? IHe1 ? IHe2|? IHe1|? IHe1 n]; - intro e2; destruct e2; simpl;try reflexivity; - repeat (case ceqb_spec; intro H; try rewrite H; clear H); - simpl; try reflexivity; try ring [phi_0 phi_1]. -- apply (morph_mul CRmorph). -- case N.eqb_spec; [intros <- | reflexivity]. - rewrite NPEpow_ok. simpl. - rewrite !rpow_pow. rewrite IHe1. - destruct n; simpl; [ ring | apply pow_pos_mul_l ]. -Qed. - -(* simplification *) -Fixpoint PEsimp (e : PExpr C) : PExpr C := - match e with - | e1 + e2 => (PEsimp e1) ++ (PEsimp e2) - | e1 * e2 => (PEsimp e1) ** (PEsimp e2) - | e1 - e2 => (PEsimp e1) -- (PEsimp e2) - | - e1 => NPEopp (PEsimp e1) - | e1 ^ n1 => (PEsimp e1) ^^ n1 - | _ => e - end%poly. - -Theorem PEsimp_ok e : (PEsimp e === e)%poly. -Proof. -induction e; simpl. -- reflexivity. -- reflexivity. -- intro l; trivial. -- intro l; trivial. -- rewrite NPEadd_ok. now f_equiv. -- rewrite NPEsub_ok. now f_equiv. -- rewrite NPEmul_ok. now f_equiv. -- rewrite NPEopp_ok. now f_equiv. -- rewrite NPEpow_ok. now f_equiv. -Qed. - - -(**************************************************************************** - - Datastructure - - ***************************************************************************) - -(* The input: syntax of a field expression *) - -Inductive FExpr : Type := - | FEO : FExpr - | FEI : FExpr - | FEc: C -> FExpr - | FEX: positive -> FExpr - | FEadd: FExpr -> FExpr -> FExpr - | FEsub: FExpr -> FExpr -> FExpr - | FEmul: FExpr -> FExpr -> FExpr - | FEopp: FExpr -> FExpr - | FEinv: FExpr -> FExpr - | FEdiv: FExpr -> FExpr -> FExpr - | FEpow: FExpr -> N -> FExpr . - -Fixpoint FEeval (l : list R) (pe : FExpr) {struct pe} : R := - match pe with - | FEO => rO - | FEI => rI - | FEc c => phi c - | FEX x => BinList.nth 0 x l - | FEadd x y => FEeval l x + FEeval l y - | FEsub x y => FEeval l x - FEeval l y - | FEmul x y => FEeval l x * FEeval l y - | FEopp x => - FEeval l x - | FEinv x => / FEeval l x - | FEdiv x y => FEeval l x / FEeval l y - | FEpow x n => rpow (FEeval l x) (Cp_phi n) - end. - -Strategy expand [FEeval]. - -(* The result of the normalisation *) - -Record linear : Type := mk_linear { - num : PExpr C; - denum : PExpr C; - condition : list (PExpr C) }. - -(*************************************************************************** - - Semantics and properties of side condition - - ***************************************************************************) - -Fixpoint PCond (l : list R) (le : list (PExpr C)) {struct le} : Prop := - match le with - | nil => True - | e1 :: nil => ~ req (e1 @ l) rO - | e1 :: l1 => ~ req (e1 @ l) rO /\ PCond l l1 - end. - -Theorem PCond_cons l a l1 : - PCond l (a :: l1) <-> ~ a @ l == 0 /\ PCond l l1. -Proof. -destruct l1. -- simpl. split; [split|destruct 1]; trivial. -- reflexivity. -Qed. - -Theorem PCond_cons_inv_l l a l1 : PCond l (a::l1) -> ~ a @ l == 0. -Proof. -rewrite PCond_cons. now destruct 1. -Qed. - -Theorem PCond_cons_inv_r l a l1 : PCond l (a :: l1) -> PCond l l1. -Proof. -rewrite PCond_cons. now destruct 1. -Qed. - -Theorem PCond_app l l1 l2 : - PCond l (l1 ++ l2) <-> PCond l l1 /\ PCond l l2. -Proof. -induction l1 as [|a l1 IHl1]. -- simpl. split; [split|destruct 1]; trivial. -- simpl app. rewrite !PCond_cons, IHl1. symmetry; apply and_assoc. -Qed. - - -(* An unsatisfiable condition: issued when a division by zero is detected *) -Definition absurd_PCond := cons 0%poly nil. - -Lemma absurd_PCond_bottom : forall l, ~ PCond l absurd_PCond. -Proof. -unfold absurd_PCond; simpl. -red; intros ? H. -apply H. -apply phi_0. -Qed. - -(*************************************************************************** - - Normalisation - - ***************************************************************************) - -Definition default_isIn e1 p1 e2 p2 := - if PExpr_eq e1 e2 then - match Z.pos_sub p1 p2 with - | Zpos p => Some (Npos p, 1%poly) - | Z0 => Some (N0, 1%poly) - | Zneg p => Some (N0, e2 ^^ Npos p) - end - else None. - -Fixpoint isIn e1 p1 e2 p2 {struct e2}: option (N * PExpr C) := - match e2 with - | e3 * e4 => - match isIn e1 p1 e3 p2 with - | Some (N0, e5) => Some (N0, e5 ** (e4 ^^ Npos p2)) - | Some (Npos p, e5) => - match isIn e1 p e4 p2 with - | Some (n, e6) => Some (n, e5 ** e6) - | None => Some (Npos p, e5 ** (e4 ^^ Npos p2)) - end - | None => - match isIn e1 p1 e4 p2 with - | Some (n, e5) => Some (n, (e3 ^^ Npos p2) ** e5) - | None => None - end - end - | e3 ^ N0 => None - | e3 ^ Npos p3 => isIn e1 p1 e3 (Pos.mul p3 p2) - | _ => default_isIn e1 p1 e2 p2 - end%poly. - - Definition ZtoN z := match z with Zpos p => Npos p | _ => N0 end. - Definition NtoZ n := match n with Npos p => Zpos p | _ => Z0 end. - - Lemma Z_pos_sub_gt p q : (p > q)%positive -> - Z.pos_sub p q = Zpos (p - q). - Proof. intros; now apply Z.pos_sub_gt, Pos.gt_lt. Qed. - - Ltac simpl_pos_sub := rewrite ?Z_pos_sub_gt in * by assumption. - - Lemma default_isIn_ok e1 e2 p1 p2 : - match default_isIn e1 p1 e2 p2 with - | Some(n, e3) => - let n' := ZtoN (Zpos p1 - NtoZ n) in - (e2 ^ N.pos p2 === e1 ^ n' * e3)%poly - /\ (Zpos p1 > NtoZ n)%Z - | _ => True - end. -Proof. - unfold default_isIn. - case PExpr_eq_spec; trivial. intros EQ. - rewrite Z.pos_sub_spec. - case Pos.compare_spec;intros H; split; try reflexivity. - - simpl. now rewrite PE_1_r, H, EQ. - - rewrite NPEpow_ok, EQ, <- PEpow_add_r. f_equiv. - simpl. f_equiv. now rewrite Pos.add_comm, Pos.sub_add. - - simpl. rewrite PE_1_r, EQ. f_equiv. - rewrite Z.pos_sub_gt by now apply Pos.sub_decr. simpl. f_equiv. - rewrite Pos.sub_sub_distr, Pos.add_comm; trivial. - + rewrite Pos.add_sub; trivial. - + apply Pos.sub_decr; trivial. - - simpl. now apply Z.lt_gt, Pos.sub_decr. -Qed. - -Ltac npe_simpl := rewrite ?NPEmul_ok, ?NPEpow_ok, ?PEpow_mul_l. -Ltac npe_ring := intro l; simpl; ring. - -Theorem isIn_ok e1 p1 e2 p2 : - match isIn e1 p1 e2 p2 with - | Some(n, e3) => - let n' := ZtoN (Zpos p1 - NtoZ n) in - (e2 ^ N.pos p2 === e1 ^ n' * e3)%poly - /\ (Zpos p1 > NtoZ n)%Z - | _ => True - end. -Proof. -Opaque NPEpow. -revert p1 p2. -induction e2 as [| |?|?|? IHe1 ? IHe2|? IHe1 ? IHe2|? IHe2_1 ? IHe2_2|? IHe|? IHe2 n]; intros p1 p2; - try refine (default_isIn_ok e1 _ p1 p2); simpl isIn. -- specialize (IHe2_1 p1 p2). - destruct isIn as [([|p],e)|]. - + split; [|reflexivity]. - clear IHe2_2. - destruct IHe2_1 as (IH,_). - npe_simpl. rewrite IH. npe_ring. - + specialize (IHe2_2 p p2). - destruct isIn as [([|p'],e')|]. - * destruct IHe2_1 as (IH1,GT1). - destruct IHe2_2 as (IH2,GT2). - split; cycle 1. - { rewrite Z.gt_lt_iff in *; eauto 1 using Z.lt_trans. } - npe_simpl. rewrite IH1, IH2. simpl. simpl_pos_sub. simpl. - replace (N.pos p1) with (N.pos p + N.pos (p1 - p))%N. - { rewrite PEpow_add_r; npe_ring. } - { simpl. f_equal. rewrite Pos.add_comm, Pos.sub_add. - - trivial. - - now apply Pos.gt_lt. - } - * destruct IHe2_1 as (IH1,GT1). - destruct IHe2_2 as (IH2,GT2). - assert (Z.pos p1 > Z.pos p')%Z by (rewrite Z.gt_lt_iff in *; eauto 2 using Z.lt_trans). - split; [|simpl; trivial]. - npe_simpl. rewrite IH1, IH2. simpl. simpl_pos_sub. simpl. - replace (N.pos (p1 - p')) with (N.pos (p1 - p) + N.pos (p - p'))%N. - { rewrite PEpow_add_r; npe_ring. } - { simpl. f_equal. rewrite Pos.add_sub_assoc, Pos.sub_add; trivial. - - now apply Pos.gt_lt. - - now apply Pos.gt_lt. - } - * destruct IHe2_1 as (IH,GT). split; trivial. - npe_simpl. rewrite IH. npe_ring. - + specialize (IHe2_2 p1 p2). - destruct isIn as [(n,e)|]; trivial. - destruct IHe2_2 as (IH,GT). split; trivial. - set (d := ZtoN (Z.pos p1 - NtoZ n)) in *; clearbody d. - npe_simpl. rewrite IH. npe_ring. -- destruct n as [|p]; trivial. - specialize (IHe2 p1 (p * p2)%positive). - destruct isIn as [(n,e)|]; trivial. - destruct IHe2 as (IH,GT). split; trivial. - set (d := ZtoN (Z.pos p1 - NtoZ n)) in *; clearbody d. - now rewrite <- PEpow_mul_r. -Qed. - -Record rsplit : Type := mk_rsplit { - rsplit_left : PExpr C; - rsplit_common : PExpr C; - rsplit_right : PExpr C}. - -(* Stupid name clash *) -Notation left := rsplit_left. -Notation right := rsplit_right. -Notation common := rsplit_common. - -Fixpoint split_aux e1 p e2 {struct e1}: rsplit := - match e1 with - | e3 * e4 => - let r1 := split_aux e3 p e2 in - let r2 := split_aux e4 p (right r1) in - mk_rsplit (left r1 ** left r2) - (common r1 ** common r2) - (right r2) - | e3 ^ N0 => mk_rsplit 1 1 e2 - | e3 ^ Npos p3 => split_aux e3 (Pos.mul p3 p) e2 - | _ => - match isIn e1 p e2 1 with - | Some (N0,e3) => mk_rsplit 1 (e1 ^^ Npos p) e3 - | Some (Npos q, e3) => mk_rsplit (e1 ^^ Npos q) (e1 ^^ Npos (p - q)) e3 - | None => mk_rsplit (e1 ^^ Npos p) 1 e2 - end - end%poly. - -Lemma split_aux_ok1 e1 p e2 : - (let res := match isIn e1 p e2 1 with - | Some (N0,e3) => mk_rsplit 1 (e1 ^^ Npos p) e3 - | Some (Npos q, e3) => mk_rsplit (e1 ^^ Npos q) (e1 ^^ Npos (p - q)) e3 - | None => mk_rsplit (e1 ^^ Npos p) 1 e2 - end - in - e1 ^ Npos p === left res * common res - /\ e2 === right res * common res)%poly. -Proof. - Opaque NPEpow NPEmul. - intros res. unfold res;clear res; generalize (isIn_ok e1 p e2 xH). - destruct (isIn e1 p e2 1) as [([|p'],e')|]; simpl. - - intros (H1,H2); split; npe_simpl. - + now rewrite PE_1_l. - + rewrite PEpow_1_r in H1. rewrite H1. npe_ring. - - intros (H1,H2); split; npe_simpl. - + rewrite <- PEpow_add_r. f_equiv. simpl. f_equal. - rewrite Pos.add_comm, Pos.sub_add; trivial. - now apply Z.gt_lt in H2. - + rewrite PEpow_1_r in H1. rewrite H1. simpl_pos_sub. simpl. npe_ring. - - intros _; split; npe_simpl; now rewrite PE_1_r. -Qed. - -Theorem split_aux_ok: forall e1 p e2, - (e1 ^ Npos p === left (split_aux e1 p e2) * common (split_aux e1 p e2) - /\ e2 === right (split_aux e1 p e2) * common (split_aux e1 p e2))%poly. -Proof. -intro e1;induction e1 as [| |?|?|? IHe1_1 ? IHe1_2|? IHe1_1 ? IHe1_2|e1_1 IHe1_1 ? IHe1_2|? IHe1|? IHe1 n]; - intros k e2; try refine (split_aux_ok1 _ k e2);simpl. -- destruct (IHe1_1 k e2) as (H1,H2). - destruct (IHe1_2 k (right (split_aux e1_1 k e2))) as (H3,H4). - clear IHe1_1 IHe1_2. - npe_simpl; split. - + rewrite H1, H3. npe_ring. - + rewrite H2 at 1. rewrite H4 at 1. npe_ring. -- destruct n; simpl. - + rewrite PEpow_0_r, PEpow_1_l, !PE_1_r. now split. - + rewrite <- PEpow_mul_r. simpl. apply IHe1. -Qed. - -Definition split e1 e2 := split_aux e1 xH e2. - -Theorem split_ok_l e1 e2 : - (e1 === left (split e1 e2) * common (split e1 e2))%poly. -Proof. -destruct (split_aux_ok e1 xH e2) as (H,_). now rewrite <- H, PEpow_1_r. -Qed. - -Theorem split_ok_r e1 e2 : - (e2 === right (split e1 e2) * common (split e1 e2))%poly. -Proof. -destruct (split_aux_ok e1 xH e2) as (_,H). trivial. -Qed. - -Lemma split_nz_l l e1 e2 : - ~ e1 @ l == 0 -> ~ left (split e1 e2) @ l == 0. -Proof. - intros H. contradict H. rewrite (split_ok_l e1 e2); simpl. - now rewrite H, rmul_0_l. -Qed. - -Lemma split_nz_r l e1 e2 : - ~ e2 @ l == 0 -> ~ right (split e1 e2) @ l == 0. -Proof. - intros H. contradict H. rewrite (split_ok_r e1 e2); simpl. - now rewrite H, rmul_0_l. -Qed. - -Fixpoint Fnorm (e : FExpr) : linear := - match e with - | FEO => mk_linear 0 1 nil - | FEI => mk_linear 1 1 nil - | FEc c => mk_linear (PEc c) 1 nil - | FEX x => mk_linear (PEX C x) 1 nil - | FEadd e1 e2 => - let x := Fnorm e1 in - let y := Fnorm e2 in - let s := split (denum x) (denum y) in - mk_linear - ((num x ** right s) ++ (num y ** left s)) - (left s ** (right s ** common s)) - (condition x ++ condition y)%list - | FEsub e1 e2 => - let x := Fnorm e1 in - let y := Fnorm e2 in - let s := split (denum x) (denum y) in - mk_linear - ((num x ** right s) -- (num y ** left s)) - (left s ** (right s ** common s)) - (condition x ++ condition y)%list - | FEmul e1 e2 => - let x := Fnorm e1 in - let y := Fnorm e2 in - let s1 := split (num x) (denum y) in - let s2 := split (num y) (denum x) in - mk_linear (left s1 ** left s2) - (right s2 ** right s1) - (condition x ++ condition y)%list - | FEopp e1 => - let x := Fnorm e1 in - mk_linear (NPEopp (num x)) (denum x) (condition x) - | FEinv e1 => - let x := Fnorm e1 in - mk_linear (denum x) (num x) (num x :: condition x) - | FEdiv e1 e2 => - let x := Fnorm e1 in - let y := Fnorm e2 in - let s1 := split (num x) (num y) in - let s2 := split (denum x) (denum y) in - mk_linear (left s1 ** right s2) - (left s2 ** right s1) - (num y :: condition x ++ condition y)%list - | FEpow e1 n => - let x := Fnorm e1 in - mk_linear ((num x)^^n) ((denum x)^^n) (condition x) - end. - -(* Example *) -(* -Eval compute - in (Fnorm - (FEdiv - (FEc cI) - (FEadd (FEinv (FEX xH%positive)) (FEinv (FEX (xO xH)%positive))))). -*) - -Theorem Pcond_Fnorm l e : - PCond l (condition (Fnorm e)) -> ~ (denum (Fnorm e))@l == 0. -Proof. -induction e as [| |?|?|? IHe1 ? IHe2|? IHe1 ? IHe2|? IHe1 ? IHe2|? IHe|? IHe|? IHe1 ? IHe2|? IHe n]; - simpl condition; rewrite ?PCond_cons, ?PCond_app; - simpl denum; intros (Hc1,Hc2) || intros Hc; rewrite ?NPEmul_ok. -- simpl. rewrite phi_1; exact rI_neq_rO. -- simpl. rewrite phi_1; exact rI_neq_rO. -- simpl; intros. rewrite phi_1; exact rI_neq_rO. -- simpl; intros. rewrite phi_1; exact rI_neq_rO. -- rewrite <- split_ok_r. simpl. apply field_is_integral_domain. - + apply split_nz_l, IHe1, Hc1. - + apply IHe2, Hc2. -- rewrite <- split_ok_r. simpl. apply field_is_integral_domain. - + apply split_nz_l, IHe1, Hc1. - + apply IHe2, Hc2. -- simpl. apply field_is_integral_domain. - + apply split_nz_r, IHe1, Hc1. - + apply split_nz_r, IHe2, Hc2. -- now apply IHe. -- trivial. -- destruct Hc2 as (Hc2,_). simpl. apply field_is_integral_domain. - + apply split_nz_l, IHe1, Hc2. - + apply split_nz_r, Hc1. -- rewrite NPEpow_ok. apply PEpow_nz, IHe, Hc. -Qed. - - -(*************************************************************************** - - Main theorem - - ***************************************************************************) - -Ltac uneval := - repeat match goal with - | |- context [ ?x @ ?l * ?y @ ?l ] => change (x@l * y@l) with ((x*y)@l) - | |- context [ ?x @ ?l + ?y @ ?l ] => change (x@l + y@l) with ((x+y)@l) - end. - -Theorem Fnorm_FEeval_PEeval l fe: - PCond l (condition (Fnorm fe)) -> - FEeval l fe == (num (Fnorm fe)) @ l / (denum (Fnorm fe)) @ l. -Proof. -induction fe as [| |?|?|fe1 IHfe1 fe2 IHfe2|fe1 IHfe1 fe2 IHfe2|fe1 IHfe1 fe2 IHfe2|fe IHfe|fe IHfe|fe1 IHfe1 fe2 IHfe2|fe IHfe n]; - simpl condition; rewrite ?PCond_cons, ?PCond_app; simpl; - intros (Hc1,Hc2) || intros Hc; - try (specialize (IHfe1 Hc1);apply Pcond_Fnorm in Hc1); - try (specialize (IHfe2 Hc2);apply Pcond_Fnorm in Hc2); - try set (F1 := Fnorm fe1) in *; try set (F2 := Fnorm fe2) in *. - -- now rewrite phi_1, phi_0, rdiv_def. -- now rewrite phi_1; apply rdiv1. -- rewrite phi_1; apply rdiv1. -- rewrite phi_1; apply rdiv1. -- rewrite NPEadd_ok, !NPEmul_ok. simpl. - rewrite <- rdiv2b; uneval; rewrite <- ?split_ok_l, <- ?split_ok_r; trivial. - now f_equiv. - -- rewrite NPEsub_ok, !NPEmul_ok. simpl. - rewrite <- rdiv3b; uneval; rewrite <- ?split_ok_l, <- ?split_ok_r; trivial. - now f_equiv. - -- rewrite !NPEmul_ok. simpl. - rewrite IHfe1, IHfe2. - rewrite (split_ok_l (num F1) (denum F2) l), - (split_ok_r (num F1) (denum F2) l), - (split_ok_l (num F2) (denum F1) l), - (split_ok_r (num F2) (denum F1) l) in *. - apply rdiv4b; trivial. - -- rewrite NPEopp_ok; simpl; rewrite (IHfe Hc); apply rdiv5. - -- rewrite (IHfe Hc2); apply rdiv6; trivial; - apply Pcond_Fnorm; trivial. - -- destruct Hc2 as (Hc2,Hc3). - rewrite !NPEmul_ok. simpl. - assert (U1 := split_ok_l (num F1) (num F2) l). - assert (U2 := split_ok_r (num F1) (num F2) l). - assert (U3 := split_ok_l (denum F1) (denum F2) l). - assert (U4 := split_ok_r (denum F1) (denum F2) l). - rewrite (IHfe1 Hc2), (IHfe2 Hc3), U1, U2, U3, U4. - simpl in U2, U3, U4. apply rdiv7b; - rewrite <- ?U2, <- ?U3, <- ?U4; try apply Pcond_Fnorm; trivial. - -- rewrite !NPEpow_ok. simpl. rewrite !rpow_pow, (IHfe Hc). - destruct n; simpl. - + apply rdiv1. - + apply pow_pos_div. apply Pcond_Fnorm; trivial. -Qed. - -Theorem Fnorm_crossproduct l fe1 fe2 : - let nfe1 := Fnorm fe1 in - let nfe2 := Fnorm fe2 in - (num nfe1 * denum nfe2) @ l == (num nfe2 * denum nfe1) @ l -> - PCond l (condition nfe1 ++ condition nfe2) -> - FEeval l fe1 == FEeval l fe2. -Proof. -simpl. rewrite PCond_app. intros Hcrossprod (Hc1,Hc2). -rewrite !Fnorm_FEeval_PEeval; trivial. -apply cross_product_eq; trivial; - apply Pcond_Fnorm; trivial. -Qed. - -(* Correctness lemmas of reflexive tactics *) -Notation Ninterp_PElist := - (interp_PElist rO rI radd rmul rsub ropp req phi Cp_phi rpow). -Notation Nmk_monpol_list := - (mk_monpol_list cO cI cadd cmul csub copp ceqb cdiv). - -Theorem Fnorm_ok: - forall n l lpe fe, - Ninterp_PElist l lpe -> - Peq ceqb (Nnorm n (Nmk_monpol_list lpe) (num (Fnorm fe))) (Pc cO) = true -> - PCond l (condition (Fnorm fe)) -> FEeval l fe == 0. -Proof. -intros n l lpe fe Hlpe H H1. -rewrite (Fnorm_FEeval_PEeval l fe H1). -apply rdiv8. -- apply Pcond_Fnorm; trivial. -- transitivity (0@l); trivial. - rewrite (norm_subst_ok Rsth Reqe ARth CRmorph pow_th cdiv_th n l lpe); trivial. - change (0 @ l) with (Pphi 0 radd rmul phi l (Pc cO)). - apply (Peq_ok Rsth Reqe CRmorph); trivial. -Qed. - -Notation ring_rw_correct := - (ring_rw_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec). - -Notation ring_rw_pow_correct := - (ring_rw_pow_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec). - -Notation ring_correct := - (ring_correct Rsth Reqe ARth CRmorph pow_th cdiv_th). - -(* simplify a field expression into a fraction *) -Definition display_linear l num den := - let lnum := NPphi_dev l num in - match den with - | Pc c => if ceqb c cI then lnum else lnum / NPphi_dev l den - | _ => lnum / NPphi_dev l den - end. - -Definition display_pow_linear l num den := - let lnum := NPphi_pow l num in - match den with - | Pc c => if ceqb c cI then lnum else lnum / NPphi_pow l den - | _ => lnum / NPphi_pow l den - end. - -Theorem Field_rw_correct n lpe l : - Ninterp_PElist l lpe -> - forall lmp, Nmk_monpol_list lpe = lmp -> - forall fe nfe, Fnorm fe = nfe -> - PCond l (condition nfe) -> - FEeval l fe == - display_linear l (Nnorm n lmp (num nfe)) (Nnorm n lmp (denum nfe)). -Proof. - intros Hlpe lmp lmp_eq fe nfe eq_nfe H; subst nfe lmp. - rewrite (Fnorm_FEeval_PEeval _ _ H). - unfold display_linear. - destruct (Nnorm _ _ _) as [c | | ] eqn: HN; - try ( apply rdiv_ext; - eapply ring_rw_correct; eauto). - destruct (ceqb_spec c cI) as [H0|]. - - set (nnum := NPphi_dev _ _). - apply eq_trans with (nnum / NPphi_dev l (Pc c)). - + apply rdiv_ext; - eapply ring_rw_correct; eauto. - + rewrite Pphi_dev_ok; try eassumption. - now simpl; rewrite H0, phi_1, <- rdiv1. - - apply rdiv_ext; - eapply ring_rw_correct; eauto. -Qed. - -Theorem Field_rw_pow_correct n lpe l : - Ninterp_PElist l lpe -> - forall lmp, Nmk_monpol_list lpe = lmp -> - forall fe nfe, Fnorm fe = nfe -> - PCond l (condition nfe) -> - FEeval l fe == - display_pow_linear l (Nnorm n lmp (num nfe)) (Nnorm n lmp (denum nfe)). -Proof. - intros Hlpe lmp lmp_eq fe nfe eq_nfe H; subst nfe lmp. - rewrite (Fnorm_FEeval_PEeval _ _ H). - unfold display_pow_linear. - destruct (Nnorm _ _ _) as [c | | ] eqn: HN; - try ( apply rdiv_ext; - eapply ring_rw_pow_correct; eauto). - destruct (ceqb_spec c cI) as [H0|]. - - set (nnum := NPphi_pow _ _). - apply eq_trans with (nnum / NPphi_pow l (Pc c)). - + apply rdiv_ext; - eapply ring_rw_pow_correct; eauto. - + rewrite Pphi_pow_ok; try eassumption. - now simpl; rewrite H0, phi_1, <- rdiv1. - - apply rdiv_ext; - eapply ring_rw_pow_correct; eauto. -Qed. - -Theorem Field_correct n l lpe fe1 fe2 : - Ninterp_PElist l lpe -> - forall lmp, Nmk_monpol_list lpe = lmp -> - forall nfe1, Fnorm fe1 = nfe1 -> - forall nfe2, Fnorm fe2 = nfe2 -> - Peq ceqb (Nnorm n lmp (num nfe1 * denum nfe2)) - (Nnorm n lmp (num nfe2 * denum nfe1)) = true -> - PCond l (condition nfe1 ++ condition nfe2) -> - FEeval l fe1 == FEeval l fe2. -Proof. -intros Hlpe lmp eq_lmp nfe1 eq1 nfe2 eq2 Hnorm Hcond; subst nfe1 nfe2 lmp. -apply Fnorm_crossproduct; trivial. -eapply ring_correct; eauto. -Qed. - -(* simplify a field equation : generate the crossproduct and simplify - polynomials *) - -(** This allows rewriting modulo the simplification of PEeval on PMul *) -Declare Equivalent Keys PEeval rmul. - -Theorem Field_simplify_eq_correct : - forall n l lpe fe1 fe2, - Ninterp_PElist l lpe -> - forall lmp, Nmk_monpol_list lpe = lmp -> - forall nfe1, Fnorm fe1 = nfe1 -> - forall nfe2, Fnorm fe2 = nfe2 -> - forall den, split (denum nfe1) (denum nfe2) = den -> - NPphi_dev l (Nnorm n lmp (num nfe1 * right den)) == - NPphi_dev l (Nnorm n lmp (num nfe2 * left den)) -> - PCond l (condition nfe1 ++ condition nfe2) -> - FEeval l fe1 == FEeval l fe2. -Proof. -intros n l lpe fe1 fe2 Hlpe lmp Hlmp nfe1 eq1 nfe2 eq2 den eq3 Hcrossprod Hcond. -apply Fnorm_crossproduct; rewrite ?eq1, ?eq2; trivial. -simpl. -rewrite (split_ok_l (denum nfe1) (denum nfe2) l), eq3. -rewrite (split_ok_r (denum nfe1) (denum nfe2) l), eq3. -simpl. -rewrite !rmul_assoc. -apply rmul_ext; trivial. -rewrite (ring_rw_correct n lpe l Hlpe Logic.eq_refl (num nfe1 * right den) Logic.eq_refl), - (ring_rw_correct n lpe l Hlpe Logic.eq_refl (num nfe2 * left den) Logic.eq_refl). -rewrite Hlmp. -apply Hcrossprod. -Qed. - -Theorem Field_simplify_eq_pow_correct : - forall n l lpe fe1 fe2, - Ninterp_PElist l lpe -> - forall lmp, Nmk_monpol_list lpe = lmp -> - forall nfe1, Fnorm fe1 = nfe1 -> - forall nfe2, Fnorm fe2 = nfe2 -> - forall den, split (denum nfe1) (denum nfe2) = den -> - NPphi_pow l (Nnorm n lmp (num nfe1 * right den)) == - NPphi_pow l (Nnorm n lmp (num nfe2 * left den)) -> - PCond l (condition nfe1 ++ condition nfe2) -> - FEeval l fe1 == FEeval l fe2. -Proof. -intros n l lpe fe1 fe2 Hlpe lmp Hlmp nfe1 eq1 nfe2 eq2 den eq3 Hcrossprod Hcond. -apply Fnorm_crossproduct; rewrite ?eq1, ?eq2; trivial. -simpl. -rewrite (split_ok_l (denum nfe1) (denum nfe2) l), eq3. -rewrite (split_ok_r (denum nfe1) (denum nfe2) l), eq3. -simpl. -rewrite !rmul_assoc. -apply rmul_ext; trivial. -rewrite - (ring_rw_pow_correct n lpe l Hlpe Logic.eq_refl (num nfe1 * right den) Logic.eq_refl), - (ring_rw_pow_correct n lpe l Hlpe Logic.eq_refl (num nfe2 * left den) Logic.eq_refl). -rewrite Hlmp. -apply Hcrossprod. -Qed. - -Theorem Field_simplify_aux_ok l fe1 fe2 den : - FEeval l fe1 == FEeval l fe2 -> - split (denum (Fnorm fe1)) (denum (Fnorm fe2)) = den -> - PCond l (condition (Fnorm fe1) ++ condition (Fnorm fe2)) -> - (num (Fnorm fe1) * right den) @ l == (num (Fnorm fe2) * left den) @ l. -Proof. - rewrite PCond_app; intros Hfe Hden (Hc1,Hc2); simpl. - assert (Hc1' := Pcond_Fnorm _ _ Hc1). - assert (Hc2' := Pcond_Fnorm _ _ Hc2). - set (N1 := num (Fnorm fe1)) in *. set (N2 := num (Fnorm fe2)) in *. - set (D1 := denum (Fnorm fe1)) in *. set (D2 := denum (Fnorm fe2)) in *. - assert (~ (common den) @ l == 0). - { intro H. apply Hc1'. - rewrite (split_ok_l D1 D2 l). - rewrite Hden. simpl. ring [H]. } - apply (@rmul_reg_l ((common den) @ l)); trivial. - rewrite !(rmul_comm ((common den) @ l)), <- !rmul_assoc. - change - (N1@l * (right den * common den) @ l == - N2@l * (left den * common den) @ l). - rewrite <- Hden, <- split_ok_l, <- split_ok_r. - apply (@rmul_reg_l (/ D2@l)). { apply rinv_nz; trivial. } - rewrite (rmul_comm (/ D2 @ l)), <- !rmul_assoc. - rewrite <- rdiv_def, rdiv_r_r, rmul_1_r by trivial. - apply (@rmul_reg_l (/ (D1@l))). { apply rinv_nz; trivial. } - rewrite !(rmul_comm (/ D1@l)), <- !rmul_assoc. - rewrite <- !rdiv_def, rdiv_r_r, rmul_1_r by trivial. - rewrite (rmul_comm (/ D2@l)), <- rdiv_def. - unfold N1,N2,D1,D2; rewrite <- !Fnorm_FEeval_PEeval; trivial. -Qed. - -Theorem Field_simplify_eq_pow_in_correct : - forall n l lpe fe1 fe2, - Ninterp_PElist l lpe -> - forall lmp, Nmk_monpol_list lpe = lmp -> - forall nfe1, Fnorm fe1 = nfe1 -> - forall nfe2, Fnorm fe2 = nfe2 -> - forall den, split (denum nfe1) (denum nfe2) = den -> - forall np1, Nnorm n lmp (num nfe1 * right den) = np1 -> - forall np2, Nnorm n lmp (num nfe2 * left den) = np2 -> - FEeval l fe1 == FEeval l fe2 -> - PCond l (condition nfe1 ++ condition nfe2) -> - NPphi_pow l np1 == - NPphi_pow l np2. -Proof. - intros n l lpe fe1 fe2 ? lmp ? nfe1 ? nfe2 ? den ? np1 ? np2 ? ? ?. - subst nfe1 nfe2 lmp np1 np2. - rewrite !(Pphi_pow_ok Rsth Reqe ARth CRmorph pow_th get_sign_spec). - repeat (rewrite <- (norm_subst_ok Rsth Reqe ARth CRmorph pow_th);trivial). - simpl. apply Field_simplify_aux_ok; trivial. -Qed. - -Theorem Field_simplify_eq_in_correct : -forall n l lpe fe1 fe2, - Ninterp_PElist l lpe -> - forall lmp, Nmk_monpol_list lpe = lmp -> - forall nfe1, Fnorm fe1 = nfe1 -> - forall nfe2, Fnorm fe2 = nfe2 -> - forall den, split (denum nfe1) (denum nfe2) = den -> - forall np1, Nnorm n lmp (num nfe1 * right den) = np1 -> - forall np2, Nnorm n lmp (num nfe2 * left den) = np2 -> - FEeval l fe1 == FEeval l fe2 -> - PCond l (condition nfe1 ++ condition nfe2) -> - NPphi_dev l np1 == NPphi_dev l np2. -Proof. - intros n l lpe fe1 fe2 ? lmp ? nfe1 ? nfe2 ? den ? np1 ? np2 ? ? ?. - subst nfe1 nfe2 lmp np1 np2. - rewrite !(Pphi_dev_ok Rsth Reqe ARth CRmorph get_sign_spec). - repeat (rewrite <- (norm_subst_ok Rsth Reqe ARth CRmorph pow_th);trivial). - apply Field_simplify_aux_ok; trivial. -Qed. - - -Section Fcons_impl. - -Variable Fcons : PExpr C -> list (PExpr C) -> list (PExpr C). - -Hypothesis PCond_fcons_inv : forall l a l1, - PCond l (Fcons a l1) -> ~ a @ l == 0 /\ PCond l l1. - -Fixpoint Fapp (l m:list (PExpr C)) {struct l} : list (PExpr C) := - match l with - | nil => m - | cons a l1 => Fcons a (Fapp l1 m) - end. - -Lemma fcons_ok : forall l l1, - (forall lock, lock = PCond l -> lock (Fapp l1 nil)) -> PCond l l1. -Proof. -intros l l1 h1; assert (H := h1 (PCond l) (refl_equal _));clear h1. -induction l1 as [|a l1 IHl1]; simpl; intros. -- trivial. -- elim PCond_fcons_inv with (1 := H); intros. - destruct l1; trivial. split; trivial. apply IHl1; trivial. -Qed. - -End Fcons_impl. - -Section Fcons_simpl. - -(* Some general simpifications of the condition: eliminate duplicates, - split multiplications *) - -Fixpoint Fcons (e:PExpr C) (l:list (PExpr C)) {struct l} : list (PExpr C) := - match l with - nil => cons e nil - | cons a l1 => if PExpr_eq e a then l else cons a (Fcons e l1) - end. - -Theorem PFcons_fcons_inv: - forall l a l1, PCond l (Fcons a l1) -> ~ a @ l == 0 /\ PCond l l1. -Proof. -intros l a l1; induction l1 as [|e l1 IHl1]; simpl Fcons. -- simpl; now split. -- case PExpr_eq_spec; intros H; rewrite !PCond_cons; intros (H1,H2); - repeat split; trivial. - + now rewrite H. - + now apply IHl1. - + now apply IHl1. -Qed. - -(* equality of normal forms rather than syntactic equality *) -Fixpoint Fcons0 (e:PExpr C) (l:list (PExpr C)) {struct l} : list (PExpr C) := - match l with - nil => cons e nil - | cons a l1 => - if Peq ceqb (Nnorm O nil e) (Nnorm O nil a) then l - else cons a (Fcons0 e l1) - end. - -Theorem PFcons0_fcons_inv: - forall l a l1, PCond l (Fcons0 a l1) -> ~ a @ l == 0 /\ PCond l l1. -Proof. -intros l a l1; induction l1 as [|e l1 IHl1]; simpl Fcons0. -- simpl; now split. -- generalize (ring_correct O l nil a e). lazy zeta; simpl Peq. - case Peq; intros H; rewrite !PCond_cons; intros (H1,H2); - repeat split; trivial. - + now rewrite H. - + now apply IHl1. - + now apply IHl1. -Qed. - -(* split factorized denominators *) -Fixpoint Fcons00 (e:PExpr C) (l:list (PExpr C)) {struct e} : list (PExpr C) := - match e with - PEmul e1 e2 => Fcons00 e1 (Fcons00 e2 l) - | PEpow e1 _ => Fcons00 e1 l - | _ => Fcons0 e l - end. - -Theorem PFcons00_fcons_inv: - forall l a l1, PCond l (Fcons00 a l1) -> ~ a @ l == 0 /\ PCond l l1. -Proof. -intros l a; elim a; try (intros; apply PFcons0_fcons_inv; trivial; fail). -- intros p H p0 H0 l1 H1. - simpl in H1. - destruct (H _ H1) as (H2,H3). - destruct (H0 _ H3) as (H4,H5). split; trivial. - simpl. - apply field_is_integral_domain; trivial. -- intros ? H ? ? H0. destruct (H _ H0). split; trivial. - apply PEpow_nz; trivial. -Qed. - -Definition Pcond_simpl_gen := - fcons_ok _ PFcons00_fcons_inv. - - -(* Specific case when the equality test of coefs is complete w.r.t. the - field equality: non-zero coefs can be eliminated, and opposite can - be simplified (if -1 <> 0) *) - -Hypothesis ceqb_complete : forall c1 c2, [c1] == [c2] -> ceqb c1 c2 = true. - -Lemma ceqb_spec' c1 c2 : Bool.reflect ([c1] == [c2]) (ceqb c1 c2). -Proof. -assert (H := morph_eq CRmorph c1 c2). -assert (H' := @ceqb_complete c1 c2). -destruct (ceqb c1 c2); constructor. -- now apply H. -- intro E. specialize (H' E). discriminate. -Qed. - -Fixpoint Fcons1 (e:PExpr C) (l:list (PExpr C)) {struct e} : list (PExpr C) := - match e with - | PEmul e1 e2 => Fcons1 e1 (Fcons1 e2 l) - | PEpow e _ => Fcons1 e l - | PEopp e => if (-(1) =? 0)%coef then absurd_PCond else Fcons1 e l - | PEc c => if (c =? 0)%coef then absurd_PCond else l - | _ => Fcons0 e l - end. - -Theorem PFcons1_fcons_inv: - forall l a l1, PCond l (Fcons1 a l1) -> ~ a @ l == 0 /\ PCond l l1. -Proof. -intros l a; elim a; try (intros; apply PFcons0_fcons_inv; trivial; fail). -- simpl; intros c l1. - case ceqb_spec'; intros H H0. - + elim (@absurd_PCond_bottom l H0). - + split; trivial. rewrite <- phi_0; trivial. -- intros p H p0 H0 l1 H1. simpl in H1. - destruct (H _ H1) as (H2,H3). - destruct (H0 _ H3) as (H4,H5). - split; trivial. simpl. apply field_is_integral_domain; trivial. -- simpl; intros p H l1. - case ceqb_spec'; intros H0 H1. - + elim (@absurd_PCond_bottom l H1). - + destruct (H _ H1). - split; trivial. - apply ropp_neq_0; trivial. - rewrite (morph_opp CRmorph), phi_0, phi_1 in H0. trivial. -- intros ? H ? ? H0. destruct (H _ H0);split;trivial. apply PEpow_nz; trivial. -Qed. - -Definition Fcons2 e l := Fcons1 (PEsimp e) l. - -Theorem PFcons2_fcons_inv: - forall l a l1, PCond l (Fcons2 a l1) -> ~ a @ l == 0 /\ PCond l l1. -Proof. -unfold Fcons2; intros l a l1 H; split; - case (PFcons1_fcons_inv l (PEsimp a) l1); trivial. -intros H1 H2 H3; case H1. -transitivity (a@l); trivial. -apply PEsimp_ok. -Qed. - -Definition Pcond_simpl_complete := - fcons_ok _ PFcons2_fcons_inv. - -End Fcons_simpl. - -End AlmostField. - -Section FieldAndSemiField. - - Record field_theory : Prop := mk_field { - F_R : ring_theory rO rI radd rmul rsub ropp req; - F_1_neq_0 : ~ 1 == 0; - Fdiv_def : forall p q, p / q == p * / q; - Finv_l : forall p, ~ p == 0 -> / p * p == 1 - }. - - Definition F2AF f := - mk_afield - (Rth_ARth Rsth Reqe (F_R f)) (F_1_neq_0 f) (Fdiv_def f) (Finv_l f). - - Record semi_field_theory : Prop := mk_sfield { - SF_SR : semi_ring_theory rO rI radd rmul req; - SF_1_neq_0 : ~ 1 == 0; - SFdiv_def : forall p q, p / q == p * / q; - SFinv_l : forall p, ~ p == 0 -> / p * p == 1 - }. - -End FieldAndSemiField. - -End MakeFieldPol. - - Definition SF2AF R (rO rI:R) radd rmul rdiv rinv req Rsth - (sf:semi_field_theory rO rI radd rmul rdiv rinv req) := - mk_afield _ _ - (SRth_ARth Rsth (SF_SR sf)) - (SF_1_neq_0 sf) - (SFdiv_def sf) - (SFinv_l sf). - - -Section Complete. - Variable R : Type. - Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R). - Variable (rdiv : R -> R -> R) (rinv : R -> R). - Variable req : R -> R -> Prop. - Notation "0" := rO. Notation "1" := rI. - Notation "x + y" := (radd x y). Notation "x * y " := (rmul x y). - Notation "x - y " := (rsub x y). Notation "- x" := (ropp x). - Notation "x / y " := (rdiv x y). Notation "/ x" := (rinv x). - Notation "x == y" := (req x y) (at level 70, no associativity). - Variable Rsth : Setoid_Theory R req. - Add Parametric Relation : R req - reflexivity proved by (@Equivalence_Reflexive _ _ Rsth) - symmetry proved by (@Equivalence_Symmetric _ _ Rsth) - transitivity proved by (@Equivalence_Transitive _ _ Rsth) - as R_setoid3. - Variable Reqe : ring_eq_ext radd rmul ropp req. - Add Morphism radd with signature (req ==> req ==> req) as radd_ext3. - Proof. exact (Radd_ext Reqe). Qed. - Add Morphism rmul with signature (req ==> req ==> req) as rmul_ext3. - Proof. exact (Rmul_ext Reqe). Qed. - Add Morphism ropp with signature (req ==> req) as ropp_ext3. - Proof. exact (Ropp_ext Reqe). Qed. - -Section AlmostField. - - Variable AFth : almost_field_theory rO rI radd rmul rsub ropp rdiv rinv req. - Let ARth := (AF_AR AFth). - Let rI_neq_rO := (AF_1_neq_0 AFth). - Let rdiv_def := (AFdiv_def AFth). - Let rinv_l := (AFinv_l AFth). - -Hypothesis S_inj : forall x y, 1+x==1+y -> x==y. - -Hypothesis gen_phiPOS_not_0 : forall p, ~ gen_phiPOS1 rI radd rmul p == 0. - -Lemma add_inj_r p x y : - gen_phiPOS1 rI radd rmul p + x == gen_phiPOS1 rI radd rmul p + y -> x==y. -Proof. -elim p using Pos.peano_ind; simpl; [intros H|intros ? H ?]. -- apply S_inj; trivial. -- apply H. - apply S_inj. - rewrite !(ARadd_assoc ARth). - rewrite <- (ARgen_phiPOS_Psucc Rsth Reqe ARth); trivial. -Qed. - -Lemma gen_phiPOS_inj x y : - gen_phiPOS rI radd rmul x == gen_phiPOS rI radd rmul y -> - x = y. -Proof. -rewrite <- !(same_gen Rsth Reqe ARth). -case (Pos.compare_spec x y). -- intros. - trivial. -- intros. - elim gen_phiPOS_not_0 with (y - x)%positive. - apply add_inj_r with x. - symmetry. - rewrite (ARadd_0_r Rsth ARth). - rewrite <- (ARgen_phiPOS_add Rsth Reqe ARth). - now rewrite Pos.add_comm, Pos.sub_add. -- intros. - elim gen_phiPOS_not_0 with (x - y)%positive. - apply add_inj_r with y. - rewrite (ARadd_0_r Rsth ARth). - rewrite <- (ARgen_phiPOS_add Rsth Reqe ARth). - now rewrite Pos.add_comm, Pos.sub_add. -Qed. - - -Lemma gen_phiN_inj x y : - gen_phiN rO rI radd rmul x == gen_phiN rO rI radd rmul y -> - x = y. -Proof. -destruct x as [|p]; destruct y as [|p']; simpl; intros H; trivial. -- elim gen_phiPOS_not_0 with p'. - symmetry . - rewrite (same_gen Rsth Reqe ARth); trivial. -- elim gen_phiPOS_not_0 with p. - rewrite (same_gen Rsth Reqe ARth); trivial. -- rewrite gen_phiPOS_inj with (1 := H); trivial. -Qed. - -Lemma gen_phiN_complete x y : - gen_phiN rO rI radd rmul x == gen_phiN rO rI radd rmul y -> - N.eqb x y = true. -Proof. -intros. now apply N.eqb_eq, gen_phiN_inj. -Qed. - -End AlmostField. - -Section Field. - - Variable Fth : field_theory rO rI radd rmul rsub ropp rdiv rinv req. - Let Rth := (F_R Fth). - Let rI_neq_rO := (F_1_neq_0 Fth). - Let rdiv_def := (Fdiv_def Fth). - Let rinv_l := (Finv_l Fth). - Let AFth := F2AF Rsth Reqe Fth. - Let ARth := Rth_ARth Rsth Reqe Rth. - -Lemma ring_S_inj x y : 1+x==1+y -> x==y. -Proof. -intros. -rewrite <- (ARadd_0_l ARth x), <- (ARadd_0_l ARth y). -rewrite <- (Ropp_def Rth 1), (ARadd_comm ARth 1). -rewrite <- !(ARadd_assoc ARth). now apply (Radd_ext Reqe). -Qed. - -Hypothesis gen_phiPOS_not_0 : forall p, ~ gen_phiPOS1 rI radd rmul p == 0. - -Let gen_phiPOS_inject := - gen_phiPOS_inj AFth ring_S_inj gen_phiPOS_not_0. - -Lemma gen_phiPOS_discr_sgn x y : - ~ gen_phiPOS rI radd rmul x == - gen_phiPOS rI radd rmul y. -Proof. -red; intros. -apply gen_phiPOS_not_0 with (y + x)%positive. -rewrite (ARgen_phiPOS_add Rsth Reqe ARth). -transitivity (gen_phiPOS1 1 radd rmul y + - gen_phiPOS1 1 radd rmul y). -- apply (Radd_ext Reqe); trivial. - + reflexivity. - + rewrite (same_gen Rsth Reqe ARth). - rewrite (same_gen Rsth Reqe ARth). - trivial. -- apply (Ropp_def Rth). -Qed. - -Lemma gen_phiZ_inj x y : - gen_phiZ rO rI radd rmul ropp x == gen_phiZ rO rI radd rmul ropp y -> - x = y. -Proof. -destruct x as [|p|p]; destruct y as [|p'|p']; simpl; intros H. -- trivial. -- elim gen_phiPOS_not_0 with p'. - rewrite (same_gen Rsth Reqe ARth). - symmetry ; trivial. -- elim gen_phiPOS_not_0 with p'. - rewrite (same_gen Rsth Reqe ARth). - rewrite <- (Ropp_opp Rsth Reqe Rth (gen_phiPOS 1 radd rmul p')). - rewrite <- H. - apply (ARopp_zero Rsth Reqe ARth). -- elim gen_phiPOS_not_0 with p. - rewrite (same_gen Rsth Reqe ARth). - trivial. -- rewrite gen_phiPOS_inject with (1 := H); trivial. -- elim gen_phiPOS_discr_sgn with (1 := H). -- elim gen_phiPOS_not_0 with p. - rewrite (same_gen Rsth Reqe ARth). - rewrite <- (Ropp_opp Rsth Reqe Rth (gen_phiPOS 1 radd rmul p)). - rewrite H. - apply (ARopp_zero Rsth Reqe ARth). -- elim gen_phiPOS_discr_sgn with p' p. - symmetry ; trivial. -- replace p' with p; trivial. - apply gen_phiPOS_inject. - rewrite <- (Ropp_opp Rsth Reqe Rth (gen_phiPOS 1 radd rmul p)). - rewrite <- (Ropp_opp Rsth Reqe Rth (gen_phiPOS 1 radd rmul p')). - rewrite H; trivial. - reflexivity. -Qed. - -Lemma gen_phiZ_complete x y : - gen_phiZ rO rI radd rmul ropp x == gen_phiZ rO rI radd rmul ropp y -> - Z.eqb x y = true. -Proof. -intros. - replace y with x. -- apply Z.eqb_refl. -- apply gen_phiZ_inj; trivial. -Qed. - -End Field. - -End Complete. - -Arguments FEO {C}. -Arguments FEI {C}. diff --git a/stdlib/theories/setoid_ring/InitialRing.v b/stdlib/theories/setoid_ring/InitialRing.v deleted file mode 100644 index 61f047550c41..000000000000 --- a/stdlib/theories/setoid_ring/InitialRing.v +++ /dev/null @@ -1,944 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* R->R) (ropp : R -> R). - Variable req : R -> R -> Prop. - Notation "0" := rO. Notation "1" := rI. - Notation "x + y" := (radd x y). Notation "x * y " := (rmul x y). - Notation "x - y " := (rsub x y). Notation "- x" := (ropp x). - Notation "x == y" := (req x y). - Variable Rsth : Setoid_Theory R req. - Add Parametric Relation : R req - reflexivity proved by (@Equivalence_Reflexive _ _ Rsth) - symmetry proved by (@Equivalence_Symmetric _ _ Rsth) - transitivity proved by (@Equivalence_Transitive _ _ Rsth) - as R_setoid3. - Ltac rrefl := gen_reflexivity Rsth. - Variable Reqe : ring_eq_ext radd rmul ropp req. - Add Morphism radd with signature (req ==> req ==> req) as radd_ext3. - Proof. exact (Radd_ext Reqe). Qed. - Add Morphism rmul with signature (req ==> req ==> req) as rmul_ext3. - Proof. exact (Rmul_ext Reqe). Qed. - Add Morphism ropp with signature (req ==> req) as ropp_ext3. - Proof. exact (Ropp_ext Reqe). Qed. - - Fixpoint gen_phiPOS1 (p:positive) : R := - match p with - | xH => 1 - | xO p => (1 + 1) * (gen_phiPOS1 p) - | xI p => 1 + ((1 + 1) * (gen_phiPOS1 p)) - end. - - Fixpoint gen_phiPOS (p:positive) : R := - match p with - | xH => 1 - | xO xH => (1 + 1) - | xO p => (1 + 1) * (gen_phiPOS p) - | xI xH => 1 + (1 +1) - | xI p => 1 + ((1 + 1) * (gen_phiPOS p)) - end. - - Definition gen_phiZ1 z := - match z with - | Zpos p => gen_phiPOS1 p - | Z0 => 0 - | Zneg p => -(gen_phiPOS1 p) - end. - - Definition gen_phiZ z := - match z with - | Zpos p => gen_phiPOS p - | Z0 => 0 - | Zneg p => -(gen_phiPOS p) - end. - Notation "[ x ]" := (gen_phiZ x). - - Definition get_signZ z := - match z with - | Zneg p => Some (Zpos p) - | _ => None - end. - - Lemma get_signZ_th : sign_theory Z.opp Z.eqb get_signZ. - Proof. - constructor. - intros c;destruct c;intros ? H;try discriminate. - injection H as [= <-]. - simpl. apply Pos.eqb_refl. - Qed. - - - Section ALMOST_RING. - Variable ARth : almost_ring_theory 0 1 radd rmul rsub ropp req. - Add Morphism rsub with signature (req ==> req ==> req) as rsub_ext3. - Proof. exact (ARsub_ext Rsth Reqe ARth). Qed. - Ltac norm := gen_srewrite Rsth Reqe ARth. - Ltac add_push := gen_add_push radd Rsth Reqe ARth. - - Lemma same_gen : forall x, gen_phiPOS1 x == gen_phiPOS x. - Proof. - intros x;induction x as [x IHx|x IHx|];simpl. - - rewrite IHx;destruct x;simpl;norm. - - rewrite IHx;destruct x;simpl;norm. - - rrefl. - Qed. - - Lemma ARgen_phiPOS_Psucc : forall x, - gen_phiPOS1 (Pos.succ x) == 1 + (gen_phiPOS1 x). - Proof. - intros x;induction x as [x IHx|x IHx|];simpl;norm. - rewrite IHx;norm. - add_push 1;rrefl. - Qed. - - Lemma ARgen_phiPOS_add : forall x y, - gen_phiPOS1 (x + y) == (gen_phiPOS1 x) + (gen_phiPOS1 y). - Proof. - intros x;induction x as [x IHx|x IHx|]; - intros y;destruct y as [y|y|];simpl;norm. - - rewrite Pos.add_carry_spec. - rewrite ARgen_phiPOS_Psucc. - rewrite IHx;norm. - add_push (gen_phiPOS1 y);add_push 1;rrefl. - - rewrite IHx;norm;add_push (gen_phiPOS1 y);rrefl. - - rewrite ARgen_phiPOS_Psucc;norm;add_push 1;rrefl. - - rewrite IHx;norm;add_push(gen_phiPOS1 y); add_push 1;rrefl. - - rewrite IHx;norm;add_push(gen_phiPOS1 y);rrefl. - - add_push 1;rrefl. - - rewrite ARgen_phiPOS_Psucc;norm;add_push 1;rrefl. - Qed. - - Lemma ARgen_phiPOS_mult : - forall x y, gen_phiPOS1 (x * y) == gen_phiPOS1 x * gen_phiPOS1 y. - Proof. - intros x;induction x as [x IHx|x IHx|];intros;simpl;norm. - - rewrite ARgen_phiPOS_add;simpl;rewrite IHx;norm. - - rewrite IHx;rrefl. - Qed. - - End ALMOST_RING. - - Variable Rth : ring_theory 0 1 radd rmul rsub ropp req. - Let ARth := Rth_ARth Rsth Reqe Rth. - Add Morphism rsub with signature (req ==> req ==> req) as rsub_ext4. - Proof. exact (ARsub_ext Rsth Reqe ARth). Qed. - Ltac norm := gen_srewrite Rsth Reqe ARth. - Ltac add_push := gen_add_push radd Rsth Reqe ARth. - -(*morphisms are extensionally equal*) - Lemma same_genZ : forall x, [x] == gen_phiZ1 x. - Proof. - intros x;destruct x;simpl; try rewrite (same_gen ARth);rrefl. - Qed. - - Lemma gen_Zeqb_ok : forall x y, - Z.eqb x y = true -> [x] == [y]. - Proof. intros x y ->%Z.eqb_eq; reflexivity. Qed. - - Lemma gen_phiZ1_pos_sub : forall x y, - gen_phiZ1 (Z.pos_sub x y) == gen_phiPOS1 x + -gen_phiPOS1 y. - Proof. - intros x y. - rewrite Z.pos_sub_spec. - case Pos.compare_spec; intros H; simpl. - - rewrite H. rewrite (Ropp_def Rth);rrefl. - - rewrite <- (Pos.sub_add y x H) at 2. rewrite Pos.add_comm. - rewrite (ARgen_phiPOS_add ARth);simpl;norm. - rewrite (Ropp_def Rth);norm. - - rewrite <- (Pos.sub_add x y H) at 2. - rewrite (ARgen_phiPOS_add ARth);simpl;norm. - add_push (gen_phiPOS1 (x-y));rewrite (Ropp_def Rth); norm. - Qed. - - Lemma gen_phiZ_add : forall x y, [x + y] == [x] + [y]. - Proof. - intros x y; repeat rewrite same_genZ; generalize x y;clear x y. - intros x y;destruct x, y; simpl; norm. - - apply (ARgen_phiPOS_add ARth). - - apply gen_phiZ1_pos_sub. - - rewrite gen_phiZ1_pos_sub. apply (Radd_comm Rth). - - rewrite (ARgen_phiPOS_add ARth); norm. - Qed. - - Lemma gen_phiZ_mul : forall x y, [x * y] == [x] * [y]. - Proof. - intros x y;repeat rewrite same_genZ. - destruct x;destruct y;simpl;norm; - rewrite (ARgen_phiPOS_mult ARth);try (norm;fail). - rewrite (Ropp_opp Rsth Reqe Rth);rrefl. - Qed. - - Lemma gen_phiZ_ext : forall x y : Z, x = y -> [x] == [y]. - Proof. intros;subst;rrefl. Qed. - -(*proof that [.] satisfies morphism specifications*) - Lemma gen_phiZ_morph : - ring_morph 0 1 radd rmul rsub ropp req Z0 (Zpos xH) - Z.add Z.mul Z.sub Z.opp Z.eqb gen_phiZ. - Proof. - assert ( SRmorph : semi_morph 0 1 radd rmul req Z0 (Zpos xH) - Z.add Z.mul Z.eqb gen_phiZ). - - apply mkRmorph;simpl;try rrefl. - + apply gen_phiZ_add. - + apply gen_phiZ_mul. - + apply gen_Zeqb_ok. - - apply (Smorph_morph Rsth Reqe Rth Zth SRmorph gen_phiZ_ext). - Qed. - -End ZMORPHISM. - -(** N is a semi-ring and a setoid*) -Lemma Nsth : Setoid_Theory N (@eq N). -Proof (Eqsth N). - -Lemma Nseqe : sring_eq_ext N.add N.mul (@eq N). -Proof (Eq_s_ext N.add N.mul). - -Lemma Nth : semi_ring_theory 0%N 1%N N.add N.mul (@eq N). -Proof. - constructor. - - exact N.add_0_l. - - exact N.add_comm. - - exact N.add_assoc. - - exact N.mul_1_l. - - exact N.mul_0_l. - - exact N.mul_comm. - - exact N.mul_assoc. - - exact N.mul_add_distr_r. -Qed. - -Definition Nsub := SRsub N.add. -Definition Nopp := (@SRopp N). - -Lemma Neqe : ring_eq_ext N.add N.mul Nopp (@eq N). -Proof (SReqe_Reqe Nseqe). - -Lemma Nath : - almost_ring_theory 0%N 1%N N.add N.mul Nsub Nopp (@eq N). -Proof (SRth_ARth Nsth Nth). - -Lemma Neqb_ok : forall x y, N.eqb x y = true -> x = y. -Proof. exact (fun x y => proj1 (N.eqb_eq x y)). Qed. - -(**Same as above : definition of two, extensionally equal, generic morphisms *) -(**from N to any semi-ring*) -Section NMORPHISM. - Variable R : Type. - Variable (rO rI : R) (radd rmul: R->R->R). - Variable req : R -> R -> Prop. - Notation "0" := rO. Notation "1" := rI. - Notation "x + y" := (radd x y). Notation "x * y " := (rmul x y). - Variable Rsth : Setoid_Theory R req. - Add Parametric Relation : R req - reflexivity proved by (@Equivalence_Reflexive _ _ Rsth) - symmetry proved by (@Equivalence_Symmetric _ _ Rsth) - transitivity proved by (@Equivalence_Transitive _ _ Rsth) - as R_setoid4. - Ltac rrefl := gen_reflexivity Rsth. - Variable SReqe : sring_eq_ext radd rmul req. - Variable SRth : semi_ring_theory 0 1 radd rmul req. - Let ARth := SRth_ARth Rsth SRth. - Let Reqe := SReqe_Reqe SReqe. - Let ropp := (@SRopp R). - Let rsub := (@SRsub R radd). - Notation "x - y " := (rsub x y). Notation "- x" := (ropp x). - Notation "x == y" := (req x y). - Add Morphism radd with signature (req ==> req ==> req) as radd_ext4. - Proof. exact (Radd_ext Reqe). Qed. - Add Morphism rmul with signature (req ==> req ==> req) as rmul_ext4. - Proof. exact (Rmul_ext Reqe). Qed. - Ltac norm := gen_srewrite_sr Rsth Reqe ARth. - - Definition gen_phiN1 x := - match x with - | N0 => 0 - | Npos x => gen_phiPOS1 1 radd rmul x - end. - - Definition gen_phiN x := - match x with - | N0 => 0 - | Npos x => gen_phiPOS 1 radd rmul x - end. - Notation "[ x ]" := (gen_phiN x). - - Lemma same_genN : forall x, [x] == gen_phiN1 x. - Proof. - intros x;destruct x;simpl. - - reflexivity. - - now rewrite (same_gen Rsth Reqe ARth). - Qed. - - Lemma gen_phiN_add : forall x y, [x + y] == [x] + [y]. - Proof. - intros x y;repeat rewrite same_genN. - destruct x;destruct y;simpl;norm. - apply (ARgen_phiPOS_add Rsth Reqe ARth). - Qed. - - Lemma gen_phiN_mult : forall x y, [x * y] == [x] * [y]. - Proof. - intros x y;repeat rewrite same_genN. - destruct x;destruct y;simpl;norm. - apply (ARgen_phiPOS_mult Rsth Reqe ARth). - Qed. - - Lemma gen_phiN_sub : forall x y, [Nsub x y] == [x] - [y]. - Proof. exact gen_phiN_add. Qed. - -(*gen_phiN satisfies morphism specifications*) - Lemma gen_phiN_morph : ring_morph 0 1 radd rmul rsub ropp req - 0%N 1%N N.add N.mul Nsub Nopp N.eqb gen_phiN. - Proof. - constructor; simpl; try reflexivity. - - apply gen_phiN_add. - - apply gen_phiN_sub. - - apply gen_phiN_mult. - - intros x y EQ. apply N.eqb_eq in EQ. now subst. - Qed. - -End NMORPHISM. - -(* Words on N : initial structure for almost-rings. *) -Definition Nword := list N. -Definition NwO : Nword := nil. -Definition NwI : Nword := 1%N :: nil. - -Definition Nwcons n (w : Nword) : Nword := - match w, n with - | nil, 0%N => nil - | _, _ => n :: w - end. - -Fixpoint Nwadd (w1 w2 : Nword) {struct w1} : Nword := - match w1, w2 with - | n1::w1', n2:: w2' => (n1+n2)%N :: Nwadd w1' w2' - | nil, _ => w2 - | _, nil => w1 - end. - -Definition Nwopp (w:Nword) : Nword := Nwcons 0%N w. - -Definition Nwsub w1 w2 := Nwadd w1 (Nwopp w2). - -Fixpoint Nwscal (n : N) (w : Nword) {struct w} : Nword := - match w with - | m :: w' => (n*m)%N :: Nwscal n w' - | nil => nil - end. - -Fixpoint Nwmul (w1 w2 : Nword) {struct w1} : Nword := - match w1 with - | 0%N::w1' => Nwopp (Nwmul w1' w2) - | n1::w1' => Nwsub (Nwscal n1 w2) (Nwmul w1' w2) - | nil => nil - end. -Fixpoint Nw_is0 (w : Nword) : bool := - match w with - | nil => true - | 0%N :: w' => Nw_is0 w' - | _ => false - end. - -Fixpoint Nweq_bool (w1 w2 : Nword) {struct w1} : bool := - match w1, w2 with - | n1::w1', n2::w2' => - if N.eqb n1 n2 then Nweq_bool w1' w2' else false - | nil, _ => Nw_is0 w2 - | _, nil => Nw_is0 w1 - end. - -Section NWORDMORPHISM. - Variable R : Type. - Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R). - Variable req : R -> R -> Prop. - Notation "0" := rO. Notation "1" := rI. - Notation "x + y" := (radd x y). Notation "x * y " := (rmul x y). - Notation "x - y " := (rsub x y). Notation "- x" := (ropp x). - Notation "x == y" := (req x y). - Variable Rsth : Setoid_Theory R req. - Add Parametric Relation : R req - reflexivity proved by (@Equivalence_Reflexive _ _ Rsth) - symmetry proved by (@Equivalence_Symmetric _ _ Rsth) - transitivity proved by (@Equivalence_Transitive _ _ Rsth) - as R_setoid5. - Ltac rrefl := gen_reflexivity Rsth. - Variable Reqe : ring_eq_ext radd rmul ropp req. - Add Morphism radd with signature (req ==> req ==> req) as radd_ext5. - Proof. exact (Radd_ext Reqe). Qed. - Add Morphism rmul with signature (req ==> req ==> req) as rmul_ext5. - Proof. exact (Rmul_ext Reqe). Qed. - Add Morphism ropp with signature (req ==> req) as ropp_ext5. - Proof. exact (Ropp_ext Reqe). Qed. - - Variable ARth : almost_ring_theory 0 1 radd rmul rsub ropp req. - Add Morphism rsub with signature (req ==> req ==> req) as rsub_ext7. - Proof. exact (ARsub_ext Rsth Reqe ARth). Qed. - Ltac norm := gen_srewrite Rsth Reqe ARth. - Ltac add_push := gen_add_push radd Rsth Reqe ARth. - - Fixpoint gen_phiNword (w : Nword) : R := - match w with - | nil => 0 - | n :: nil => gen_phiN rO rI radd rmul n - | N0 :: w' => - gen_phiNword w' - | n::w' => gen_phiN rO rI radd rmul n - gen_phiNword w' - end. - - Lemma gen_phiNword0_ok : forall w, Nw_is0 w = true -> gen_phiNword w == 0. -Proof. -intros w; induction w as [|a w IHw]; simpl; intros; auto. -- reflexivity. - -- destruct a. - + destruct w. - * reflexivity. - - * rewrite IHw; trivial. - apply (ARopp_zero Rsth Reqe ARth). - - + discriminate. -Qed. - - Lemma gen_phiNword_cons : forall w n, - gen_phiNword (n::w) == gen_phiN rO rI radd rmul n - gen_phiNword w. -intros w; induction w. -- intros n; destruct n; simpl; norm. - -- intros n. - destruct n; norm. - Qed. - - Lemma gen_phiNword_Nwcons : forall w n, - gen_phiNword (Nwcons n w) == gen_phiN rO rI radd rmul n - gen_phiNword w. -intros w; destruct w; intros n0. -- destruct n0; norm. - -- unfold Nwcons. - rewrite gen_phiNword_cons. - reflexivity. - Qed. - - Lemma gen_phiNword_ok : forall w1 w2, - Nweq_bool w1 w2 = true -> gen_phiNword w1 == gen_phiNword w2. -intros w1; induction w1 as [|a w1 IHw1]; intros w2 H. -- simpl. - rewrite (gen_phiNword0_ok _ H). - reflexivity. - -- rewrite gen_phiNword_cons. - destruct w2 as [|n w2]. - + simpl in H. - destruct a; try discriminate. - rewrite (gen_phiNword0_ok _ H). - norm. - - + simpl in H. - rewrite gen_phiNword_cons. - case_eq (N.eqb a n); intros H0. - * rewrite H0 in H. - apply N.eqb_eq in H0. rewrite <- H0. - rewrite (IHw1 _ H). - reflexivity. - - * rewrite H0 in H; discriminate H. - Qed. - - -Lemma Nwadd_ok : forall x y, - gen_phiNword (Nwadd x y) == gen_phiNword x + gen_phiNword y. -intros x; induction x as [|n x IHx]; intros y. -- simpl. - norm. - -- destruct y. - + simpl Nwadd; norm. - - + simpl Nwadd. - repeat rewrite gen_phiNword_cons. - rewrite (fun sreq => gen_phiN_add Rsth sreq (ARth_SRth ARth)) by - (destruct Reqe; constructor; trivial). - - rewrite IHx. - norm. - add_push (- gen_phiNword x); reflexivity. -Qed. - -Lemma Nwopp_ok : forall x, gen_phiNword (Nwopp x) == - gen_phiNword x. -simpl. -unfold Nwopp; simpl. -intros. -rewrite gen_phiNword_Nwcons; norm. -Qed. - -Lemma Nwscal_ok : forall n x, - gen_phiNword (Nwscal n x) == gen_phiN rO rI radd rmul n * gen_phiNword x. -intros n x; induction x as [|a x IHx]; intros. -- norm. - -- simpl Nwscal. - repeat rewrite gen_phiNword_cons. - rewrite (fun sreq => gen_phiN_mult Rsth sreq (ARth_SRth ARth)) - by (destruct Reqe; constructor; trivial). - - rewrite IHx. - norm. -Qed. - -Lemma Nwmul_ok : forall x y, - gen_phiNword (Nwmul x y) == gen_phiNword x * gen_phiNword y. -intros x; induction x as [|a x IHx]; intros. -- norm. - -- destruct a. - + simpl Nwmul. - rewrite Nwopp_ok. - rewrite IHx. - rewrite gen_phiNword_cons. - norm. - - + simpl Nwmul. - unfold Nwsub. - rewrite Nwadd_ok. - rewrite Nwscal_ok. - rewrite Nwopp_ok. - rewrite IHx. - rewrite gen_phiNword_cons. - norm. -Qed. - -(* Proof that [.] satisfies morphism specifications *) - Lemma gen_phiNword_morph : - ring_morph 0 1 radd rmul rsub ropp req - NwO NwI Nwadd Nwmul Nwsub Nwopp Nweq_bool gen_phiNword. -constructor. -- reflexivity. - -- reflexivity. - -- exact Nwadd_ok. - -- intros. - unfold Nwsub. - rewrite Nwadd_ok. - rewrite Nwopp_ok. - norm. - -- exact Nwmul_ok. - -- exact Nwopp_ok. - -- exact gen_phiNword_ok. - Qed. - -End NWORDMORPHISM. - -Section GEN_DIV. - - Variables (R : Type) (rO : R) (rI : R) (radd : R -> R -> R) - (rmul : R -> R -> R) (rsub : R -> R -> R) (ropp : R -> R) - (req : R -> R -> Prop) (C : Type) (cO : C) (cI : C) - (cadd : C -> C -> C) (cmul : C -> C -> C) (csub : C -> C -> C) - (copp : C -> C) (ceqb : C -> C -> bool) (phi : C -> R). - Variable Rsth : Setoid_Theory R req. - Variable Reqe : ring_eq_ext radd rmul ropp req. - Variable ARth : almost_ring_theory rO rI radd rmul rsub ropp req. - Variable morph : ring_morph rO rI radd rmul rsub ropp req cO cI cadd cmul csub copp ceqb phi. - - (* Useful tactics *) - Add Parametric Relation : R req - reflexivity proved by (@Equivalence_Reflexive _ _ Rsth) - symmetry proved by (@Equivalence_Symmetric _ _ Rsth) - transitivity proved by (@Equivalence_Transitive _ _ Rsth) - as R_set1. - Ltac rrefl := gen_reflexivity Rsth. - Add Morphism radd with signature (req ==> req ==> req) as radd_ext. - Proof. exact (Radd_ext Reqe). Qed. - Add Morphism rmul with signature (req ==> req ==> req) as rmul_ext. - Proof. exact (Rmul_ext Reqe). Qed. - Add Morphism ropp with signature (req ==> req) as ropp_ext. - Proof. exact (Ropp_ext Reqe). Qed. - Add Morphism rsub with signature (req ==> req ==> req) as rsub_ext. - Proof. exact (ARsub_ext Rsth Reqe ARth). Qed. - Ltac rsimpl := gen_srewrite Rsth Reqe ARth. - - Definition triv_div x y := - if ceqb x y then (cI, cO) - else (cO, x). - - Ltac Esimpl :=repeat (progress ( - match goal with - | |- context [phi cO] => rewrite (morph0 morph) - | |- context [phi cI] => rewrite (morph1 morph) - | |- context [phi (cadd ?x ?y)] => rewrite ((morph_add morph) x y) - | |- context [phi (cmul ?x ?y)] => rewrite ((morph_mul morph) x y) - | |- context [phi (csub ?x ?y)] => rewrite ((morph_sub morph) x y) - | |- context [phi (copp ?x)] => rewrite ((morph_opp morph) x) - end)). - - Lemma triv_div_th : Ring_theory.div_theory req cadd cmul phi triv_div. - Proof. - constructor. - intros a b;unfold triv_div. - assert (X:= morph_eq morph a b);destruct (ceqb a b). - - Esimpl. - rewrite X; trivial. - rsimpl. - - Esimpl; rsimpl. - Qed. - - Variable zphi : Z -> R. - - Lemma Ztriv_div_th : div_theory req Z.add Z.mul zphi Z.quotrem. - Proof. - constructor. - intros a b; generalize (Z.quotrem_eq a b); case Z.quotrem; intros; subst. - rewrite Z.mul_comm; rsimpl. - Qed. - - Variable nphi : N -> R. - - Lemma Ntriv_div_th : div_theory req N.add N.mul nphi N.div_eucl. - constructor. - intros a b; generalize (N.div_eucl_spec a b); case N.div_eucl; intros; subst. - rewrite N.mul_comm; rsimpl. - Qed. - -End GEN_DIV. - - (* syntaxification of constants in an abstract ring: - the inverse of gen_phiPOS *) - Ltac inv_gen_phi_pos rI add mul t := - let rec inv_cst t := - match t with - rI => constr:(1%positive) - | (add rI rI) => constr:(2%positive) - | (add rI (add rI rI)) => constr:(3%positive) - | (mul (add rI rI) ?p) => (* 2p *) - match inv_cst p with - NotConstant => constr:(NotConstant) - | 1%positive => constr:(NotConstant) (* 2*1 is not convertible to 2 *) - | ?p => constr:(xO p) - end - | (add rI (mul (add rI rI) ?p)) => (* 1+2p *) - match inv_cst p with - NotConstant => constr:(NotConstant) - | 1%positive => constr:(NotConstant) - | ?p => constr:(xI p) - end - | _ => constr:(NotConstant) - end in - inv_cst t. - -(* The (partial) inverse of gen_phiNword *) - Ltac inv_gen_phiNword rO rI add mul opp t := - match t with - rO => constr:(NwO) - | _ => - match inv_gen_phi_pos rI add mul t with - NotConstant => constr:(NotConstant) - | ?p => constr:(Npos p::nil) - end - end. - - -(* The inverse of gen_phiN *) - Ltac inv_gen_phiN rO rI add mul t := - match t with - rO => constr:(0%N) - | _ => - match inv_gen_phi_pos rI add mul t with - NotConstant => constr:(NotConstant) - | ?p => constr:(Npos p) - end - end. - -(* The inverse of gen_phiZ *) - Ltac inv_gen_phiZ rO rI add mul opp t := - match t with - rO => constr:(0%Z) - | (opp ?p) => - match inv_gen_phi_pos rI add mul p with - NotConstant => constr:(NotConstant) - | ?p => constr:(Zneg p) - end - | _ => - match inv_gen_phi_pos rI add mul t with - NotConstant => constr:(NotConstant) - | ?p => constr:(Zpos p) - end - end. - -(* A simple tactic recognizing only 0 and 1. The inv_gen_phiX above - are only optimisations that directly returns the reified constant - instead of resorting to the constant propagation of the simplification - algorithm. *) -Ltac inv_gen_phi rO rI cO cI t := - match t with - | rO => cO - | rI => cI - end. - -(* A simple tactic recognizing no constant *) - Ltac inv_morph_nothing t := constr:(NotConstant). - -Ltac coerce_to_almost_ring set ext rspec := - match type of rspec with - | ring_theory _ _ _ _ _ _ _ => constr:(Rth_ARth set ext rspec) - | semi_ring_theory _ _ _ _ _ => constr:(SRth_ARth set rspec) - | almost_ring_theory _ _ _ _ _ _ _ => rspec - | _ => fail 1 "not a valid ring theory" - end. - -Ltac coerce_to_ring_ext ext := - match type of ext with - | ring_eq_ext _ _ _ _ => ext - | sring_eq_ext _ _ _ => constr:(SReqe_Reqe ext) - | _ => fail 1 "not a valid ring_eq_ext theory" - end. - -Ltac abstract_ring_morphism set ext rspec := - match type of rspec with - | ring_theory _ _ _ _ _ _ _ => constr:(gen_phiZ_morph set ext rspec) - | semi_ring_theory _ _ _ _ _ => constr:(gen_phiN_morph set ext rspec) - | almost_ring_theory _ _ _ _ _ _ _ => - constr:(gen_phiNword_morph set ext rspec) - | _ => fail 1 "bad ring structure" - end. - -Record hypo : Type := mkhypo { - hypo_type : Type; - hypo_proof : hypo_type - }. - -Ltac gen_ring_pow set arth pspec := - match pspec with - | None => - match type of arth with - | @almost_ring_theory ?R ?rO ?rI ?radd ?rmul ?rsub ?ropp ?req => - constr:(mkhypo (@pow_N_th R rI rmul req set)) - | _ => fail 1 "gen_ring_pow" - end - | Some ?t => constr:(t) - end. - -Ltac gen_ring_sign morph sspec := - match sspec with - | None => - match type of morph with - | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req - Z ?c0 ?c1 ?cadd ?cmul ?csub ?copp ?ceqb ?phi => - constr:(@mkhypo (sign_theory copp ceqb get_signZ) get_signZ_th) - | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req - ?C ?c0 ?c1 ?cadd ?cmul ?csub ?copp ?ceqb ?phi => - constr:(mkhypo (@get_sign_None_th C copp ceqb)) - | _ => fail 2 "ring anomaly : default_sign_spec" - end - | Some ?t => constr:(t) - end. - -Ltac default_div_spec set reqe arth morph := - match type of morph with - | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req - Z ?c0 ?c1 Z.add Z.mul ?csub ?copp ?ceq_b ?phi => - constr:(mkhypo (Ztriv_div_th set phi)) - | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req - N ?c0 ?c1 N.add N.mul ?csub ?copp ?ceq_b ?phi => - constr:(mkhypo (Ntriv_div_th set phi)) - | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req - ?C ?c0 ?c1 ?cadd ?cmul ?csub ?copp ?ceq_b ?phi => - constr:(mkhypo (triv_div_th set reqe arth morph)) - | _ => fail 1 "ring anomaly : default_sign_spec" - end. - -Ltac gen_ring_div set reqe arth morph dspec := - match dspec with - | None => default_div_spec set reqe arth morph - | Some ?t => constr:(t) - end. - -Ltac ring_elements set ext rspec pspec sspec dspec rk := - let arth := coerce_to_almost_ring set ext rspec in - let ext_r := coerce_to_ring_ext ext in - let morph := - match rk with - | Abstract => abstract_ring_morphism set ext rspec - | @Computational ?reqb_ok => - match type of arth with - | almost_ring_theory ?rO ?rI ?add ?mul ?sub ?opp _ => - constr:(IDmorph rO rI add mul sub opp set _ reqb_ok) - | _ => fail 2 "ring anomaly" - end - | @Morphism ?m => - match type of m with - | ring_morph _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ => m - | @semi_morph _ _ _ _ _ _ _ _ _ _ _ _ _ => - constr:(SRmorph_Rmorph set m) - | _ => fail 2 "ring anomaly" - end - | _ => fail 1 "ill-formed ring kind" - end in - let p_spec := gen_ring_pow set arth pspec in - let s_spec := gen_ring_sign morph sspec in - let d_spec := gen_ring_div set ext_r arth morph dspec in - fun f => f arth ext_r morph p_spec s_spec d_spec. - -(* Given a ring structure and the kind of morphism, - returns 2 lemmas (one for ring, and one for ring_simplify). *) - - Ltac ring_lemmas set ext rspec pspec sspec dspec rk := - let gen_lemma2 := - match pspec with - | None => constr:(ring_rw_correct) - | Some _ => constr:(ring_rw_pow_correct) - end in - ring_elements set ext rspec pspec sspec dspec rk - ltac:(fun arth ext_r morph p_spec s_spec d_spec => - lazymatch type of morph with - | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req - ?C ?c0 ?c1 ?cadd ?cmul ?csub ?copp ?ceq_b ?phi => - let gen_lemma2_0 := - constr:(gen_lemma2 R r0 rI radd rmul rsub ropp req set ext_r arth - C c0 c1 cadd cmul csub copp ceq_b phi morph) in - lazymatch p_spec with - | @mkhypo (power_theory _ _ _ ?Cp_phi ?rpow) ?pp_spec => - let gen_lemma2_1 := constr:(gen_lemma2_0 _ Cp_phi rpow pp_spec) in - lazymatch d_spec with - | @mkhypo (div_theory _ _ _ _ ?cdiv) ?dd_spec => - let gen_lemma2_2 := constr:(gen_lemma2_1 cdiv dd_spec) in - lazymatch s_spec with - | @mkhypo (sign_theory _ _ ?get_sign) ?ss_spec => - let lemma2 := constr:(gen_lemma2_2 get_sign ss_spec) in - let lemma1 := - constr:(ring_correct set ext_r arth morph pp_spec dd_spec) in - fun f => f arth ext_r morph lemma1 lemma2 - | _ => fail "ring: bad sign specification" - end - | _ => fail "ring: bad coefficient division specification" - end - | _ => fail "ring: bad power specification" - end - | _ => fail "ring internal error: ring_lemmas, please report" - end). - -(* Tactic for constant *) -Ltac isnatcst t := - match t with - O => constr:(true) - | S ?p => isnatcst p - | _ => constr:(false) - end. - -Ltac isPcst t := - match t with - | xI ?p => isPcst p - | xO ?p => isPcst p - | xH => constr:(true) - (* nat -> positive *) - | Pos.of_succ_nat ?n => isnatcst n - | _ => constr:(false) - end. - -Ltac isNcst t := - match t with - N0 => constr:(true) - | Npos ?p => isPcst p - | _ => constr:(false) - end. - -Ltac isZcst t := - match t with - Z0 => constr:(true) - | Zpos ?p => isPcst p - | Zneg ?p => isPcst p - (* injection nat -> Z *) - | Z.of_nat ?n => isnatcst n - (* injection N -> Z *) - | Z.of_N ?n => isNcst n - (* *) - | _ => constr:(false) - end. - -(** Registering for the ML plugin *) - -Register PExpr as plugins.ring.pexpr. -Register PEc as plugins.ring.const. -Register PEX as plugins.ring.var. -Register PEadd as plugins.ring.add. -Register PEsub as plugins.ring.sub. -Register PEmul as plugins.ring.mul. -Register PEopp as plugins.ring.opp. -Register PEpow as plugins.ring.pow. -Register PEeval as plugins.ring.eval. - -Register almost_ring_theory as plugins.ring.almost_ring_theory. -Register semi_ring_theory as plugins.ring.semi_ring_theory. -Register ring_theory as plugins.ring.ring_theory. - -Register Eqsth as plugins.ring.Eqsth. -Register Eq_ext as plugins.ring.Eq_ext. -Register Eq_s_ext as plugins.ring.Eq_s_ext. - -Register Abstract as plugins.ring.Abstract. -Register Computational as plugins.ring.Computational. -Register Morphism as plugins.ring.Morphism. - -Register IDphi as plugins.ring.IDphi. -Register gen_phiZ as plugins.ring.gen_phiZ. - -Register Pphi_dev as plugins.ring.Pphi_dev. -Register Pphi_pow as plugins.ring.Pphi_pow. - -Register mk_reqe as plugins.ring.mk_reqe. -Register mk_seqe as plugins.ring.mk_seqe. - -Register mkhypo as plugins.ring.mkhypo. -Register hypo as plugins.ring.hypo. diff --git a/stdlib/theories/setoid_ring/Integral_domain.v b/stdlib/theories/setoid_ring/Integral_domain.v deleted file mode 100644 index cec8f4385c45..000000000000 --- a/stdlib/theories/setoid_ring/Integral_domain.v +++ /dev/null @@ -1,61 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* x == 0 \/ y == 0; - integral_domain_one_zero: not (1 == 0)}. - -Section integral_domain. - -Context {R:Type}`{Rid:Integral_domain R}. - -Lemma integral_domain_minus_one_zero: ~ - (1:R) == 0. -red;intro. apply integral_domain_one_zero. -assert (0 == - (0:R)). -- cring. -- rewrite H0. rewrite <- H. cring. -Qed. - - -Definition pow (r : R) (n : nat) := Ring_theory.pow_N 1 mul r (N.of_nat n). - -Lemma pow_not_zero: forall p n, pow p n == 0 -> p == 0. - induction n. - - unfold pow; simpl. intros. absurd (1 == 0). - + simpl. apply integral_domain_one_zero. - + trivial. - - setoid_replace (pow p (S n)) with (p * (pow p n)). - + intros. - case (integral_domain_product p (pow p n) H). - * trivial. - * trivial. - + unfold pow; simpl. - clear IHn. induction n; simpl; try cring. - rewrite Ring_theory.pow_pos_succ. - * cring. - * apply ring_setoid. - * apply ring_mult_comp. - * apply ring_mul_assoc. -Qed. - -Lemma Rintegral_domain_pow: - forall c p r, ~c == 0 -> c * (pow p r) == ring0 -> p == ring0. - intros. case (integral_domain_product c (pow p r) H0). - - intros; absurd (c == ring0); auto. - - intros. apply pow_not_zero with r. trivial. -Qed. - -End integral_domain. diff --git a/stdlib/theories/setoid_ring/NArithRing.v b/stdlib/theories/setoid_ring/NArithRing.v deleted file mode 100644 index d1671bf54daf..000000000000 --- a/stdlib/theories/setoid_ring/NArithRing.v +++ /dev/null @@ -1,23 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* t - | _ => constr:(NotConstant) - end. - -Add Ring Nr : Nth (decidable Neqb_ok, constants [Ncst]). diff --git a/stdlib/theories/setoid_ring/Ncring.v b/stdlib/theories/setoid_ring/Ncring.v deleted file mode 100644 index 9199fd6d8301..000000000000 --- a/stdlib/theories/setoid_ring/Ncring.v +++ /dev/null @@ -1,324 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* T->T} - {mul:T->T->T} - {sub:T->T->T} - {opp:T->T} - {ring_eq:T->T->Prop}. - -#[global] -Instance zero_notation(T:Type)`{Ring_ops T}:Zero T:= ring0. -#[global] -Instance one_notation(T:Type)`{Ring_ops T}:One T:= ring1. -#[global] -Instance add_notation(T:Type)`{Ring_ops T}:Addition T:= add. -#[global] -Instance mul_notation(T:Type)`{Ring_ops T}:@Multiplication T T:= mul. -#[global] -Instance sub_notation(T:Type)`{Ring_ops T}:Subtraction T:= sub. -#[global] -Instance opp_notation(T:Type)`{Ring_ops T}:Opposite T:= opp. -#[global] -Instance eq_notation(T:Type)`{Ring_ops T}:@Equality T:= ring_eq. - -Class Ring `{Ro:Ring_ops}:={ - ring_setoid: Equivalence _==_; - ring_plus_comp: Proper (_==_ ==> _==_ ==>_==_) _+_; - ring_mult_comp: Proper (_==_ ==> _==_ ==>_==_) _*_; - ring_sub_comp: Proper (_==_ ==> _==_ ==>_==_) _-_; - ring_opp_comp: Proper (_==_==>_==_) -_; - ring_add_0_l : forall x, 0 + x == x; - ring_add_comm : forall x y, x + y == y + x; - ring_add_assoc : forall x y z, x + (y + z) == (x + y) + z; - ring_mul_1_l : forall x, 1 * x == x; - ring_mul_1_r : forall x, x * 1 == x; - ring_mul_assoc : forall x y z, x * (y * z) == (x * y) * z; - ring_distr_l : forall x y z, (x + y) * z == x * z + y * z; - ring_distr_r : forall x y z, z * ( x + y) == z * x + z * y; - ring_sub_def : forall x y, x - y == x + -y; - ring_opp_def : forall x, x + -x == 0 -}. -(* inutile! je sais plus pourquoi j'ai mis ca... -Instance ring_Ring_ops(R:Type)`{Ring R} - :@Ring_ops R 0 1 addition multiplication subtraction opposite equality. -*) -#[global] -Existing Instance ring_setoid. -#[global] -Existing Instance ring_plus_comp. -#[global] -Existing Instance ring_mult_comp. -#[global] -Existing Instance ring_sub_comp. -#[global] -Existing Instance ring_opp_comp. - -Section Ring_power. - -Context {R:Type}`{Ring R}. - - Fixpoint pow_pos (x:R) (i:positive) {struct i}: R := - match i with - | xH => x - | xO i => let p := pow_pos x i in p * p - | xI i => let p := pow_pos x i in x * (p * p) - end. - - Definition pow_N (x:R) (p:N) := - match p with - | N0 => 1 - | Npos p => pow_pos x p - end. - -End Ring_power. - -Definition ZN(x:Z):= - match x with - Z0 => N0 - |Zpos p | Zneg p => Npos p -end. - -#[global] -Instance power_ring {R:Type}`{Ring R} : Power:= - {power x y := pow_N x (ZN y)}. - -(** Interpretation morphisms definition*) - -Class Ring_morphism (C R:Type)`{Cr:Ring C} `{Rr:Ring R}`{Rh:Bracket C R}:= { - ring_morphism0 : [0] == 0; - ring_morphism1 : [1] == 1; - ring_morphism_add : forall x y, [x + y] == [x] + [y]; - ring_morphism_sub : forall x y, [x - y] == [x] - [y]; - ring_morphism_mul : forall x y, [x * y] == [x] * [y]; - ring_morphism_opp : forall x, [-x] == -[x]; - ring_morphism_eq : forall x y, x == y -> [x] == [y]}. - -Section Ring. - -Context {R:Type}`{Rr:Ring R}. - -(* Powers *) - -Lemma pow_pos_comm : forall x j, x * pow_pos x j == pow_pos x j * x. -Proof. - induction j; simpl. - - rewrite <- ring_mul_assoc. - rewrite <- ring_mul_assoc. - rewrite <- IHj. rewrite (ring_mul_assoc (pow_pos x j) x (pow_pos x j)). - rewrite <- IHj. rewrite <- ring_mul_assoc. reflexivity. - - rewrite <- ring_mul_assoc. rewrite <- IHj. - rewrite ring_mul_assoc. rewrite IHj. - rewrite <- ring_mul_assoc. rewrite IHj. reflexivity. - - reflexivity. -Qed. - -Lemma pow_pos_succ : forall x j, pow_pos x (Pos.succ j) == x * pow_pos x j. -Proof. -induction j; simpl. -- rewrite IHj. - rewrite <- (ring_mul_assoc x (pow_pos x j) (x * pow_pos x j)). - rewrite (ring_mul_assoc (pow_pos x j) x (pow_pos x j)). - rewrite <- pow_pos_comm. - rewrite <- ring_mul_assoc. reflexivity. -- reflexivity. -- reflexivity. -Qed. - -Lemma pow_pos_add : forall x i j, - pow_pos x (i + j) == pow_pos x i * pow_pos x j. -Proof. - intro x;induction i;intros. - - rewrite Pos.xI_succ_xO;rewrite <- Pos.add_1_r. - rewrite <- Pos.add_diag;repeat rewrite <- Pos.add_assoc. - repeat rewrite IHi. - rewrite Pos.add_comm;rewrite Pos.add_1_r; - rewrite pow_pos_succ. - simpl;repeat rewrite ring_mul_assoc. reflexivity. - - rewrite <- Pos.add_diag;repeat rewrite <- Pos.add_assoc. - repeat rewrite IHi. rewrite ring_mul_assoc. reflexivity. - - rewrite Pos.add_comm;rewrite Pos.add_1_r;rewrite pow_pos_succ. - simpl. reflexivity. -Qed. - - Definition id_phi_N (x:N) : N := x. - - Lemma pow_N_pow_N : forall x n, pow_N x (id_phi_N n) == pow_N x n. - Proof. - intros; reflexivity. - Qed. - - (** Identity is a morphism *) - (* - Instance IDmorph : Ring_morphism _ _ _ (fun x => x). - Proof. - apply (Build_Ring_morphism H6 H6 (fun x => x));intros; - try reflexivity. trivial. - Qed. -*) - (** rings are almost rings*) - Lemma ring_mul_0_l : forall x, 0 * x == 0. - Proof. - intro x. setoid_replace (0*x) with ((0+1)*x + -x). - - rewrite ring_add_0_l. rewrite ring_mul_1_l . - rewrite ring_opp_def . fold zero. reflexivity. - - rewrite ring_distr_l . rewrite ring_mul_1_l . - rewrite <- ring_add_assoc ; rewrite ring_opp_def . - rewrite ring_add_comm ; rewrite ring_add_0_l ;reflexivity. - Qed. - - Lemma ring_mul_0_r : forall x, x * 0 == 0. - Proof. - intro x; setoid_replace (x*0) with (x*(0+1) + -x). - - rewrite ring_add_0_l ; rewrite ring_mul_1_r . - rewrite ring_opp_def ; fold zero; reflexivity. - - - rewrite ring_distr_r ;rewrite ring_mul_1_r . - rewrite <- ring_add_assoc ; rewrite ring_opp_def . - rewrite ring_add_comm ; rewrite ring_add_0_l ;reflexivity. - Qed. - - Lemma ring_opp_mul_l : forall x y, -(x * y) == -x * y. - Proof. - intros x y;rewrite <- (ring_add_0_l (- x * y)). - rewrite ring_add_comm . - rewrite <- (ring_opp_def (x*y)). - rewrite ring_add_assoc . - rewrite <- ring_distr_l. - rewrite (ring_add_comm (-x));rewrite ring_opp_def . - rewrite ring_mul_0_l;rewrite ring_add_0_l ;reflexivity. - Qed. - -Lemma ring_opp_mul_r : forall x y, -(x * y) == x * -y. - Proof. - intros x y;rewrite <- (ring_add_0_l (x * - y)). - rewrite ring_add_comm . - rewrite <- (ring_opp_def (x*y)). - rewrite ring_add_assoc . - rewrite <- ring_distr_r . - rewrite (ring_add_comm (-y));rewrite ring_opp_def . - rewrite ring_mul_0_r;rewrite ring_add_0_l ;reflexivity. - Qed. - - Lemma ring_opp_add : forall x y, -(x + y) == -x + -y. - Proof. - intros x y;rewrite <- (ring_add_0_l (-(x+y))). - rewrite <- (ring_opp_def x). - rewrite <- (ring_add_0_l (x + - x + - (x + y))). - rewrite <- (ring_opp_def y). - rewrite (ring_add_comm x). - rewrite (ring_add_comm y). - rewrite <- (ring_add_assoc (-y)). - rewrite <- (ring_add_assoc (- x)). - rewrite (ring_add_assoc y). - rewrite (ring_add_comm y). - rewrite <- (ring_add_assoc (- x)). - rewrite (ring_add_assoc y). - rewrite (ring_add_comm y);rewrite ring_opp_def . - rewrite (ring_add_comm (-x) 0);rewrite ring_add_0_l . - rewrite ring_add_comm; reflexivity. - Qed. - - Lemma ring_opp_opp : forall x, - -x == x. - Proof. - intros x; rewrite <- (ring_add_0_l (- -x)). - rewrite <- (ring_opp_def x). - rewrite <- ring_add_assoc ; rewrite ring_opp_def . - rewrite (ring_add_comm x); rewrite ring_add_0_l . reflexivity. - Qed. - - Lemma ring_sub_ext : - forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 - y1 == x2 - y2. - Proof. - intros. - setoid_replace (x1 - y1) with (x1 + -y1). - - setoid_replace (x2 - y2) with (x2 + -y2). - + rewrite H;rewrite H0;reflexivity. - + rewrite ring_sub_def. reflexivity. - - rewrite ring_sub_def. reflexivity. - Qed. - - Ltac mrewrite := - repeat first - [ rewrite ring_add_0_l - | rewrite <- (ring_add_comm 0) - | rewrite ring_mul_1_l - | rewrite ring_mul_0_l - | rewrite ring_distr_l - | reflexivity - ]. - - Lemma ring_add_0_r : forall x, (x + 0) == x. - Proof. intros; mrewrite. Qed. - - - Lemma ring_add_assoc1 : forall x y z, (x + y) + z == (y + z) + x. - Proof. - intros;rewrite <- (ring_add_assoc x). - rewrite (ring_add_comm x);reflexivity. - Qed. - - Lemma ring_add_assoc2 : forall x y z, (y + x) + z == (y + z) + x. - Proof. - intros; repeat rewrite <- ring_add_assoc. - rewrite (ring_add_comm x); reflexivity. - Qed. - - Lemma ring_opp_zero : -0 == 0. - Proof. - rewrite <- (ring_mul_0_r 0). rewrite ring_opp_mul_l. - repeat rewrite ring_mul_0_r. reflexivity. - Qed. - -End Ring. - -(** Some simplification tactics*) -Ltac gen_reflexivity := reflexivity. - -Ltac gen_rewrite := - repeat first - [ reflexivity - | progress rewrite ring_opp_zero - | rewrite ring_add_0_l - | rewrite ring_add_0_r - | rewrite ring_mul_1_l - | rewrite ring_mul_1_r - | rewrite ring_mul_0_l - | rewrite ring_mul_0_r - | rewrite ring_distr_l - | rewrite ring_distr_r - | rewrite ring_add_assoc - | rewrite ring_mul_assoc - | progress rewrite ring_opp_add - | progress rewrite ring_sub_def - | progress rewrite <- ring_opp_mul_l - | progress rewrite <- ring_opp_mul_r ]. - -Ltac gen_add_push x := -repeat (match goal with - | |- context [(?y + x) + ?z] => - progress rewrite (ring_add_assoc2 x y z) - | |- context [(x + ?y) + ?z] => - progress rewrite (ring_add_assoc1 x y z) - end). diff --git a/stdlib/theories/setoid_ring/Ncring_initial.v b/stdlib/theories/setoid_ring/Ncring_initial.v deleted file mode 100644 index e662b63f3214..000000000000 --- a/stdlib/theories/setoid_ring/Ncring_initial.v +++ /dev/null @@ -1,234 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* 1 - | xO p => (1 + 1) * (gen_phiPOS1 p) - | xI p => 1 + ((1 + 1) * (gen_phiPOS1 p)) - end. - - Fixpoint gen_phiPOS (p:positive) : R := - match p with - | xH => 1 - | xO xH => (1 + 1) - | xO p => (1 + 1) * (gen_phiPOS p) - | xI xH => 1 + (1 +1) - | xI p => 1 + ((1 + 1) * (gen_phiPOS p)) - end. - - Definition gen_phiZ1 z := - match z with - | Zpos p => gen_phiPOS1 p - | Z0 => 0 - | Zneg p => -(gen_phiPOS1 p) - end. - - Definition gen_phiZ z := - match z with - | Zpos p => gen_phiPOS p - | Z0 => 0 - | Zneg p => -(gen_phiPOS p) - end. - Declare Scope ZMORPHISM. - Notation "[ x ]" := (gen_phiZ x) : ZMORPHISM. - Open Scope ZMORPHISM. - - Definition get_signZ z := - match z with - | Zneg p => Some (Zpos p) - | _ => None - end. - - Ltac norm := gen_rewrite. - Ltac add_push := Ncring.gen_add_push. -Ltac rsimpl := simpl. - - Lemma same_gen : forall x, gen_phiPOS1 x == gen_phiPOS x. - Proof. - induction x;rsimpl. - - rewrite IHx. destruct x;simpl;norm. - - rewrite IHx;destruct x;simpl;norm. - - reflexivity. - Qed. - - Lemma ARgen_phiPOS_Psucc : forall x, - gen_phiPOS1 (Pos.succ x) == 1 + (gen_phiPOS1 x). - Proof. - induction x; simpl. - - now rewrite IHx, ring_distr_r, ring_mul_1_r, ring_add_assoc. - - reflexivity. - - now rewrite ring_mul_1_r. - Qed. - - Lemma ARgen_phiPOS_add : forall x y, - gen_phiPOS1 (x + y) == (gen_phiPOS1 x) + (gen_phiPOS1 y). - Proof. - induction x;destruct y;simpl. - - rewrite Pos.add_carry_spec, ARgen_phiPOS_Psucc, IHx. - rewrite !ring_distr_r, !ring_mul_1_r, !ring_add_assoc. - now add_push 1. - - now rewrite IHx, !ring_distr_r, !ring_add_assoc. - - rewrite ARgen_phiPOS_Psucc, !ring_distr_r, !ring_mul_1_r. - now add_push 1. - - rewrite IHx, !ring_distr_r, !ring_add_assoc. - now add_push 1. - - now rewrite IHx, !ring_distr_r. - - now rewrite ring_add_comm. - - now rewrite ARgen_phiPOS_Psucc, !ring_distr_r, !ring_mul_1_r, !ring_add_assoc. - - reflexivity. - - now rewrite ring_mul_1_r. - Qed. - - Lemma ARgen_phiPOS_mult : - forall x y, gen_phiPOS1 (x * y) == gen_phiPOS1 x * gen_phiPOS1 y. - Proof. - induction x; intros; simpl. - - rewrite ARgen_phiPOS_add. simpl. - now rewrite IHx, !ring_distr_l, !ring_mul_1_l. - - now rewrite IHx, ring_mul_assoc. - - now rewrite ring_mul_1_l. - Qed. - -(*morphisms are extensionally equal*) - Lemma same_genZ : forall x, [x] == gen_phiZ1 x. - Proof. - destruct x;rsimpl; try rewrite same_gen; reflexivity. - Qed. - - Lemma gen_phiZ1_add_pos_neg : forall x y, - gen_phiZ1 (Z.pos_sub x y) - == gen_phiPOS1 x + -gen_phiPOS1 y. - Proof. - intros x y. - generalize (Z.pos_sub_discr x y). - destruct (Z.pos_sub x y) as [|p|p]; intros; subst. - - now rewrite ring_opp_def. - - rewrite ARgen_phiPOS_add; simpl. - add_push (gen_phiPOS1 p). now rewrite ring_opp_def, ring_add_0_l. - - rewrite ARgen_phiPOS_add; simpl. - now rewrite ring_opp_add, ring_add_assoc, ring_opp_def, ring_add_0_l. - Qed. - - Lemma match_compOpp : forall x (B:Type) (be bl bg:B), - match CompOpp x with Eq => be | Lt => bl | Gt => bg end - = match x with Eq => be | Lt => bg | Gt => bl end. - Proof. destruct x;simpl;intros;trivial. Qed. - - Lemma gen_phiZ_add : forall x y, [x + y] == [x] + [y]. - Proof. - intros x y; repeat rewrite same_genZ; generalize x y;clear x y. - induction x;destruct y;simpl;norm. - - apply ARgen_phiPOS_add. - - apply gen_phiZ1_add_pos_neg. - - rewrite gen_phiZ1_add_pos_neg. rewrite ring_add_comm. - reflexivity. - - rewrite ARgen_phiPOS_add. rewrite ring_opp_add. reflexivity. - Qed. - -Lemma gen_phiZ_opp : forall x, [- x] == - [x]. - Proof. - intros x. repeat rewrite same_genZ. generalize x ;clear x. - induction x;simpl;norm. - rewrite ring_opp_opp. reflexivity. - Qed. - - Lemma gen_phiZ_mul : forall x y, [x * y] == [x] * [y]. - Proof. - intros x y;repeat rewrite same_genZ. - destruct x; simpl; [now rewrite ring_mul_0_l|destruct y..]; simpl. - - now rewrite ring_mul_0_r. - - now rewrite ARgen_phiPOS_mult. - - now rewrite ARgen_phiPOS_mult, ring_opp_mul_r. - - now rewrite ring_mul_0_r. - - now rewrite ARgen_phiPOS_mult, ring_opp_mul_l. - - now rewrite ARgen_phiPOS_mult, <- ring_opp_mul_l, <- ring_opp_mul_r, ring_opp_opp. - Qed. - - Lemma gen_phiZ_ext : forall x y : Z, x = y -> [x] == [y]. - Proof. intros;subst;reflexivity. Qed. - -Declare Equivalent Keys bracket gen_phiZ. -(*proof that [.] satisfies morphism specifications*) -Global Instance gen_phiZ_morph : -(@Ring_morphism (Z:Type) R _ _ _ _ _ _ _ Zops Zr _ _ _ _ _ _ _ _ _ gen_phiZ) . (* beurk!*) - apply Build_Ring_morphism; simpl;try reflexivity. -- apply gen_phiZ_add. -- intros. rewrite ring_sub_def. - replace (x-y)%Z with (x + (-y))%Z. - + now rewrite gen_phiZ_add, gen_phiZ_opp, ring_sub_def. - + reflexivity. -- apply gen_phiZ_mul. -- apply gen_phiZ_opp. -- apply gen_phiZ_ext. -Defined. - -#[deprecated(since="9.0")] -Lemma gen_Zeqb_ok : forall x y, - Z.eqb x y = true -> [x] == [y]. -Proof. intros x y ->%Z.eqb_eq; reflexivity. Qed. - -End ZMORPHISM. - -#[global] -Instance multiplication_phi_ring{R:Type}`{Ring R} : Multiplication := - {multiplication x y := (gen_phiZ x) * y}. diff --git a/stdlib/theories/setoid_ring/Ncring_polynom.v b/stdlib/theories/setoid_ring/Ncring_polynom.v deleted file mode 100644 index 8fe524bf0da6..000000000000 --- a/stdlib/theories/setoid_ring/Ncring_polynom.v +++ /dev/null @@ -1,614 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* : non commutative polynomials on a commutative ring A *) - -Set Implicit Arguments. -Require Import Setoid. -Require Import BinList. -Require Import BinPos. -Require Import BinNat. -Require Import BinInt. -Require Export Ring_polynom. (* n'utilise que PExpr *) -Require Export Ncring. - -#[local] Create HintDb rsimpl. - -Section MakeRingPol. - -Context (C R:Type) `{Rh:Ring_morphism C R}. - -Variable phiCR_comm: forall (c:C)(x:R), x * [c] == [c] * x. - -Ltac rsimpl := repeat (gen_rewrite || rewrite phiCR_comm). -Ltac add_push := gen_add_push . - -#[local] Hint Rewrite - ring_opp_zero ring_opp_add - ring_add_0_l ring_add_0_r - ring_mul_1_l ring_mul_1_r - ring_mul_0_l ring_mul_0_r - ring_distr_l ring_distr_r - ring_add_assoc ring_mul_assoc - : rsimpl. - -(* Definition of non commutative multivariable polynomials - with coefficients in C : - *) - -Inductive Pol : Type := - | Pc : C -> Pol - | PX : Pol -> positive -> positive -> Pol -> Pol. - (* PX P i n Q represents P * X_i^n + Q *) -Definition cO:C . exact ring0. Defined. -Definition cI:C . exact ring1. Defined. - -Definition P0 := Pc 0. -Definition P1 := Pc 1. - -Variable Ceqb:C->C->bool. -#[universes(template)] -Class Equalityb (A : Type):= {equalityb : A -> A -> bool}. -Notation "x =? y" := (equalityb x y) (at level 70, no associativity). -Variable Ceqb_eq: forall x y:C, Ceqb x y = true -> (x == y). - -Instance equalityb_coef : Equalityb C := - {equalityb x y := Ceqb x y}. - -Fixpoint Peq (P P' : Pol) {struct P'} : bool := - match P, P' with - | Pc c, Pc c' => c =? c' - | PX P i n Q, PX P' i' n' Q' => - match Pos.compare i i', Pos.compare n n' with - | Eq, Eq => if Peq P P' then Peq Q Q' else false - | _,_ => false - end - | _, _ => false -end. - -Instance equalityb_pol : Equalityb Pol := - {equalityb x y := Peq x y}. - -(* Q a ses variables de queue < i *) -Definition mkPX P i n Q := - match P with - | Pc c => if c =? 0 then Q else PX P i n Q - | PX P' i' n' Q' => - match Pos.compare i i' with - | Eq => if Q' =? P0 then PX P' i (n + n') Q else PX P i n Q - | _ => PX P i n Q - end - end. - -Definition mkXi i n := PX P1 i n P0. - -Definition mkX i := mkXi i 1. - -(** Opposite of addition *) - -Fixpoint Popp (P:Pol) : Pol := - match P with - | Pc c => Pc (- c) - | PX P i n Q => PX (Popp P) i n (Popp Q) - end. - -Notation "-- P" := (Popp P)(at level 30). - -(** Addition et subtraction *) - -Fixpoint PaddCl (c:C)(P:Pol) {struct P} : Pol := - match P with - | Pc c1 => Pc (c + c1) - | PX P i n Q => PX P i n (PaddCl c Q) - end. - -(* Q quelconque *) - -Section PaddX. -Variable Padd:Pol->Pol->Pol. -Variable P:Pol. - -(* Xi^n * P + Q -les variables de tete de Q ne sont pas forcement < i -mais Q est normalisĆ© : variables de tete decroissantes *) - -Fixpoint PaddX (i n:positive)(Q:Pol){struct Q}:= - match Q with - | Pc c => mkPX P i n Q - | PX P' i' n' Q' => - match Pos.compare i i' with - | (* i > i' *) - Gt => mkPX P i n Q - | (* i < i' *) - Lt => mkPX P' i' n' (PaddX i n Q') - | (* i = i' *) - Eq => match Z.pos_sub n n' with - | (* n > n' *) - Zpos k => mkPX (PaddX i k P') i' n' Q' - | (* n = n' *) - Z0 => mkPX (Padd P P') i n Q' - | (* n < n' *) - Zneg k => mkPX (Padd P (mkPX P' i k P0)) i n Q' - end - end - end. - -End PaddX. - -Fixpoint Padd (P1 P2: Pol) {struct P1} : Pol := - match P1 with - | Pc c => PaddCl c P2 - | PX P' i' n' Q' => - PaddX Padd P' i' n' (Padd Q' P2) - end. - -Notation "P ++ P'" := (Padd P P'). - -Definition Psub(P P':Pol):= P ++ (--P'). - -Notation "P -- P'" := (Psub P P')(at level 50). - -(** Multiplication *) - -Fixpoint PmulC_aux (P:Pol) (c:C) {struct P} : Pol := - match P with - | Pc c' => Pc (c' * c) - | PX P i n Q => mkPX (PmulC_aux P c) i n (PmulC_aux Q c) - end. - -Definition PmulC P c := - if c =? 0 then P0 else - if c =? 1 then P else PmulC_aux P c. - -Fixpoint Pmul (P1 P2 : Pol) {struct P2} : Pol := - match P2 with - | Pc c => PmulC P1 c - | PX P i n Q => - PaddX Padd (Pmul P1 P) i n (Pmul P1 Q) - end. - -Notation "P ** P'" := (Pmul P P')(at level 40). - -Definition Psquare (P:Pol) : Pol := P ** P. - - -(** Evaluation of a polynomial towards R *) - -Fixpoint Pphi(l:list R) (P:Pol) {struct P} : R := - match P with - | Pc c => [c] - | PX P i n Q => - let x := nth 0 i l in - let xn := pow_pos x n in - (Pphi l P) * xn + (Pphi l Q) - end. - -Reserved Notation "P @ l " (at level 10, no associativity). -Notation "P @ l " := (Pphi l P). - -(** Proofs *) - -Ltac destr_pos_sub H := - match goal with |- context [Z.pos_sub ?x ?y] => - assert (H := Z.pos_sub_discr x y); destruct (Z.pos_sub x y) - end. - -Lemma Peq_ok : forall P P', - (P =? P') = true -> forall l, P@l == P'@ l. -Proof. - induction P;destruct P';simpl;intros ;try easy. - - now apply ring_morphism_eq, Ceqb_eq. - - specialize (IHP1 P'1). specialize (IHP2 P'2). - simpl in IHP1, IHP2. - destruct (Pos.compare_spec p p1); try discriminate; - destruct (Pos.compare_spec p0 p2); try discriminate. - destruct (Peq P2 P'1); try discriminate. - subst; now rewrite IHP1, IHP2. -Qed. - -Lemma Pphi0 : forall l, P0@l == 0. -Proof. - intros;simpl. - rewrite ring_morphism0. reflexivity. -Qed. - -Lemma Pphi1 : forall l, P1@l == 1. -Proof. - intros;simpl; rewrite ring_morphism1. reflexivity. -Qed. - -Lemma mkPX_ok : forall l P i n Q, - (mkPX P i n Q)@l == P@l * (pow_pos (nth 0 i l) n) + Q@l. -Proof. - intros l P i n Q;unfold mkPX. - destruct P;try (simpl;reflexivity). - - assert (Hh := ring_morphism_eq c 0). - simpl; case_eq (Ceqb c 0);simpl;try reflexivity. - intros. - rewrite Hh. - + rewrite ring_morphism0. now rewrite_db rsimpl. - + apply Ceqb_eq. trivial. - - destruct (Pos.compare_spec i p). - + subst. assert (Hh := @Peq_ok P3 P0). case_eq (P3=? P0). - * intro. simpl. - rewrite Hh. - -- rewrite Pos.add_comm, pow_pos_add, Pphi0. - now rewrite_db rsimpl. - -- trivial. - * intros. reflexivity. - + reflexivity. - + reflexivity. -Qed. - -Ltac Esimpl := - repeat (progress ( - match goal with - | |- context [?P@?l] => - match P with - | P0 => rewrite (Pphi0 l) - | P1 => rewrite (Pphi1 l) - | (mkPX ?P ?i ?n ?Q) => rewrite (mkPX_ok l P i n Q) - end - | |- context [[?c]] => - match c with - | 0 => rewrite ring_morphism0 - | 1 => rewrite ring_morphism1 - | ?x + ?y => rewrite ring_morphism_add - | ?x * ?y => rewrite ring_morphism_mul - | ?x - ?y => rewrite ring_morphism_sub - | - ?x => rewrite ring_morphism_opp - end - end)); - simpl; rsimpl. - -Lemma PaddCl_ok : forall c P l, (PaddCl c P)@l == [c] + P@l . -Proof. - induction P as [|????? IH2]; simpl; intros. - - now rewrite ring_morphism_add. - - now rewrite IH2, !(ring_add_comm [_]), ring_add_assoc. -Qed. - -Lemma PmulC_aux_ok : forall c P l, (PmulC_aux P c)@l == P@l * [c]. -Proof. - induction P as [|? IH1 ??? IH2]; simpl; intros. - - now rewrite ring_morphism_mul. - - rewrite mkPX_ok, IH1, IH2, !phiCR_comm. - now rewrite_db rsimpl. -Qed. - -Lemma PmulC_ok : forall c P l, (PmulC P c)@l == P@l * [c]. -Proof. - intros c P l; unfold PmulC. - assert (Hh:= ring_morphism_eq c 0);case_eq (c =? 0). - - intros. rewrite Hh. - + now rewrite Pphi0, ring_morphism0, ring_mul_0_r. - + now apply Ceqb_eq. - - assert (H1h:= ring_morphism_eq c 1);case_eq (c =? 1);intros. - + rewrite H1h. - * now rewrite ring_morphism1, ring_mul_1_r. - * now apply Ceqb_eq. - + apply PmulC_aux_ok. -Qed. - -Lemma Popp_ok : forall P l, (--P)@l == - P@l. -Proof. - induction P as [|? IH1 ??? IH2];simpl;intros. - - now rewrite ring_morphism_opp. - - rewrite IH1, IH2. - now rewrite ring_opp_add, ring_opp_mul_l. -Qed. - -Ltac Esimpl2 := - Esimpl; - repeat (progress ( - match goal with - | |- context [(PaddCl ?c ?P)@?l] => rewrite (PaddCl_ok c P l) - | |- context [(PmulC ?P ?c)@?l] => rewrite (PmulC_ok c P l) - | |- context [(--?P)@?l] => rewrite (Popp_ok P l) - end)); Esimpl. - -Lemma PaddXPX: forall P i n Q, - PaddX Padd P i n Q = - match Q with - | Pc c => mkPX P i n Q - | PX P' i' n' Q' => - match Pos.compare i i' with - | (* i > i' *) - Gt => mkPX P i n Q - | (* i < i' *) - Lt => mkPX P' i' n' (PaddX Padd P i n Q') - | (* i = i' *) - Eq => match Z.pos_sub n n' with - | (* n > n' *) - Zpos k => mkPX (PaddX Padd P i k P') i' n' Q' - | (* n = n' *) - Z0 => mkPX (Padd P P') i n Q' - | (* n < n' *) - Zneg k => mkPX (Padd P (mkPX P' i k P0)) i n Q' - end - end - end. -Proof. - induction Q; reflexivity. -Qed. - -Lemma PaddX_ok2 : forall P2, - (forall P l, (P2 ++ P) @ l == P2 @ l + P @ l) - /\ - (forall P k n l, - (PaddX Padd P2 k n P) @ l == - P2 @ l * pow_pos (nth 0 k l) n + P @ l). -Proof. - induction P2 as [|? IH1 ??? IH2];simpl;intros. - - split. - + intros. apply PaddCl_ok. - + intros P. induction P as [|? IH'1 ??? IH'2]. - * unfold PaddX. intros. now rewrite mkPX_ok. - * intros. simpl. - destruct (Pos.compare_spec k p) as [Hh|Hh|Hh]. - -- destr_pos_sub H1h; subst. - ++ rewrite mkPX_ok, PaddCl_ok. - now rewrite_db rsimpl. - ++ rewrite mkPX_ok, IH'1, Pos.add_comm, pow_pos_add. - now rewrite_db rsimpl. - ++ rewrite mkPX_ok, PaddCl_ok, mkPX_ok, Pphi0, Pos.add_comm, pow_pos_add. - now rewrite_db rsimpl. - -- rewrite mkPX_ok, IH'2. - rewrite_db rsimpl. now rewrite (ring_add_comm (_ * _)). - -- assert (H1h := ring_morphism_eq c 0);case_eq (Ceqb c 0); - intros; simpl. - ++ rewrite H1h;trivial. - ** rewrite ring_morphism0. now rewrite_db rsimpl. - ** apply Ceqb_eq; trivial. - ++ reflexivity. - - decompose [and] IH1. decompose [and] IH2. clear IH1 IH2. - split. - + intros. rewrite H0. rewrite H1. - now rewrite ring_add_assoc. - + induction P. - * unfold PaddX. intros. rewrite mkPX_ok. reflexivity. - * intros. rewrite PaddXPX. - destruct (Pos.compare_spec k p1) as [H3h|H3h|H3h]. - -- destr_pos_sub H4h; subst. - ++ rewrite mkPX_ok. simpl. rewrite H0, H1. - now rewrite_db rsimpl. - ++ rewrite mkPX_ok, IHP1. simpl. - rewrite Pos.add_comm, pow_pos_add. - now rewrite_db rsimpl. - ++ rewrite mkPX_ok. simpl. rewrite H0, H1. rewrite mkPX_ok, Pphi0. - rewrite Pos.add_comm, pow_pos_add. - now rewrite_db rsimpl. - -- rewrite mkPX_ok. simpl. rewrite IHP2. - now rewrite ring_add_comm, <- ring_add_assoc, (ring_add_comm (_ @ _)). - -- now rewrite mkPX_ok. -Qed. - -Lemma Padd_ok : forall P Q l, (P ++ Q) @ l == P @ l + Q @ l. -Proof. - intro P. elim (PaddX_ok2 P); auto. -Qed. - -Lemma PaddX_ok : forall P2 P k n l, - (PaddX Padd P2 k n P) @ l == P2 @ l * pow_pos (nth 0 k l) n + P @ l. -Proof. - intro P2. elim (PaddX_ok2 P2); auto. -Qed. - -Lemma Psub_ok : forall P' P l, (P -- P')@l == P@l - P'@l. -Proof. - unfold Psub. intros. now rewrite Padd_ok, Popp_ok, ring_sub_def. -Qed. - -Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l. -Proof. - induction P'; simpl; intros. - - rewrite PmulC_ok. reflexivity. - - rewrite PaddX_ok. rewrite IHP'1. rewrite IHP'2. - now rewrite_db rsimpl. -Qed. - -Lemma Psquare_ok : forall P l, (Psquare P)@l == P@l * P@l. -Proof. - intros. unfold Psquare. apply Pmul_ok. -Qed. - - (** Definition of polynomial expressions *) - -(* - Inductive PExpr : Type := - | PEc : C -> PExpr - | PEX : positive -> PExpr - | PEadd : PExpr -> PExpr -> PExpr - | PEsub : PExpr -> PExpr -> PExpr - | PEmul : PExpr -> PExpr -> PExpr - | PEopp : PExpr -> PExpr - | PEpow : PExpr -> N -> PExpr. -*) - -(** Specification of the power function *) -Section POWER. - Variable Cpow : Set. - Variable Cp_phi : N -> Cpow. - Variable rpow : R -> Cpow -> R. - - Record power_theory : Prop := mkpow_th { - rpow_pow_N : forall r n, (rpow r (Cp_phi n))== (pow_N r n) - }. - -End POWER. -Variable Cpow : Set. -Variable Cp_phi : N -> Cpow. -Variable rpow : R -> Cpow -> R. -Variable pow_th : power_theory Cp_phi rpow. - - (** evaluation of polynomial expressions towards R *) - -Fixpoint PEeval (l:list R) (pe:PExpr C) {struct pe} : R := - match pe with - | PEO => 0 - | PEI => 1 - | PEc c => [c] - | PEX _ j => nth 0 j l - | PEadd pe1 pe2 => (PEeval l pe1) + (PEeval l pe2) - | PEsub pe1 pe2 => (PEeval l pe1) - (PEeval l pe2) - | PEmul pe1 pe2 => (PEeval l pe1) * (PEeval l pe2) - | PEopp pe1 => - (PEeval l pe1) - | PEpow pe1 n => rpow (PEeval l pe1) (Cp_phi n) - end. - -Strategy expand [PEeval]. - -Definition mk_X j := mkX j. - -(** Correctness proofs *) - -Lemma mkX_ok : forall p l, nth 0 p l == (mk_X p) @ l. -Proof. - intros. simpl. rewrite ring_morphism0, ring_morphism1. now rewrite_db rsimpl. -Qed. - -Ltac Esimpl3 := - repeat match goal with - | |- context [(?P1 ++ ?P2)@?l] => rewrite (Padd_ok P1 P2 l) - | |- context [(?P1 -- ?P2)@?l] => rewrite (Psub_ok P1 P2 l) - end;try Esimpl2;try reflexivity;try apply ring_add_comm. - -(* Power using the chinise algorithm *) - -Section POWER2. -Variable subst_l : Pol -> Pol. -Fixpoint Ppow_pos (res P:Pol) (p:positive){struct p} : Pol := - match p with - | xH => subst_l (Pmul P res) - | xO p => Ppow_pos (Ppow_pos res P p) P p - | xI p => subst_l (Pmul P (Ppow_pos (Ppow_pos res P p) P p)) - end. - -Definition Ppow_N P n := - match n with - | N0 => P1 - | Npos p => Ppow_pos P1 P p - end. - -Fixpoint pow_pos_gen (R:Type)(m:R->R->R)(x:R) (i:positive) {struct i}: R := - match i with - | xH => x - | xO i => let p := pow_pos_gen m x i in m p p - | xI i => let p := pow_pos_gen m x i in m x (m p p) - end. - -Lemma Ppow_pos_ok : forall l, (forall P, subst_l P@l == P@l) -> - forall res P p, (Ppow_pos res P p)@l == (pow_pos_gen Pmul P p)@l * res@l. -Proof. - intros l subst_l_ok res P p. generalize res;clear res. - induction p;simpl;intros. - - rewrite subst_l_ok, !Pmul_ok, !IHp. now rewrite_db rsimpl. - - rewrite Pmul_ok, !IHp. now rewrite_db rsimpl. - - now rewrite subst_l_ok, Pmul_ok. -Qed. - -Definition pow_N_gen (R:Type)(x1:R)(m:R->R->R)(x:R) (p:N) := - match p with - | N0 => x1 - | Npos p => pow_pos_gen m x p - end. - -Lemma Ppow_N_ok : forall l, (forall P, subst_l P@l == P@l) -> - forall P n, (Ppow_N P n)@l == (pow_N_gen P1 Pmul P n)@l. -Proof. - destruct n;simpl. - - reflexivity. - - rewrite Ppow_pos_ok; trivial. - now rewrite Pphi1, ring_mul_1_r. -Qed. - -End POWER2. - - (** Normalization and rewriting *) - -Section NORM_SUBST_REC. -Let subst_l (P:Pol) := P. -Let Pmul_subst P1 P2 := subst_l (Pmul P1 P2). -Let Ppow_subst := Ppow_N subst_l. - -Fixpoint norm_aux (pe:PExpr C) : Pol := - match pe with - | PEO => Pc cO - | PEI => Pc cI - | PEc c => Pc c - | PEX _ j => mk_X j - | PEadd pe1 (PEopp pe2) => - Psub (norm_aux pe1) (norm_aux pe2) - | PEadd pe1 pe2 => Padd (norm_aux pe1) (norm_aux pe2) - | PEsub pe1 pe2 => Psub (norm_aux pe1) (norm_aux pe2) - | PEmul pe1 pe2 => Pmul (norm_aux pe1) (norm_aux pe2) - | PEopp pe1 => Popp (norm_aux pe1) - | PEpow pe1 n => Ppow_N (fun p => p) (norm_aux pe1) n - end. - -Definition norm_subst pe := subst_l (norm_aux pe). - - -Lemma norm_aux_spec : forall l pe, PEeval l pe == (norm_aux pe)@l. -Proof. - intros. - induction pe as [ | | | |pe1 IH1 pe2 IH2|pe1 IH1 pe2 IH2|pe1 IH1 pe2 IH2|pe IH|pe IH n]; simpl. - - now rewrite <- ring_morphism0. - - now rewrite <- ring_morphism1. - - reflexivity. - - rewrite ring_morphism0, ring_morphism1. now rewrite_db rsimpl. - - rewrite IH1, IH2. unfold Psub. - destruct pe2; now rewrite Padd_ok. - - rewrite IH1, IH2. unfold Psub. - now rewrite Padd_ok, Popp_ok, ring_sub_def. - - now rewrite IH1, IH2, Pmul_ok. - - now rewrite IH, Popp_ok. - - rewrite Ppow_N_ok; [|intros; reflexivity]. - rewrite rpow_pow_N; [|now apply pow_th]. - destruct n; simpl; [now rewrite ring_morphism1|]. - induction p as [p IHp|p IHp|]; simpl; [| |now apply IH]. - + now rewrite IHp, IH, !Pmul_ok. - + now rewrite Pmul_ok, IHp. -Qed. - -Lemma norm_subst_spec : forall l pe, PEeval l pe == (norm_subst pe)@l. -Proof. - intros. apply norm_aux_spec. -Qed. - -End NORM_SUBST_REC. - -Fixpoint interp_PElist (l:list R) (lpe:list (PExpr C * PExpr C)) {struct lpe} : Prop := - match lpe with - | nil => True - | (me,pe)::lpe => - match lpe with - | nil => PEeval l me == PEeval l pe - | _ => PEeval l me == PEeval l pe /\ interp_PElist l lpe - end - end. - - -Lemma norm_subst_ok : forall l pe, PEeval l pe == (norm_subst pe)@l. -Proof. - intros. apply norm_subst_spec. -Qed. - - -Lemma ring_correct : forall l pe1 pe2, - (norm_subst pe1 =? norm_subst pe2) = true -> - PEeval l pe1 == PEeval l pe2. -Proof. - simpl;intros. - do 2 (rewrite (norm_subst_ok l);trivial). - apply Peq_ok;trivial. -Qed. - -End MakeRingPol. diff --git a/stdlib/theories/setoid_ring/Ncring_tac.v b/stdlib/theories/setoid_ring/Ncring_tac.v deleted file mode 100644 index 37f8bba31d5a..000000000000 --- a/stdlib/theories/setoid_ring/Ncring_tac.v +++ /dev/null @@ -1,348 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* - let conv := - match goal with - | _ => let _ := match goal with _ => convert term t0 end in open_constr:(true) - | _ => open_constr:(false) - end - in - lazymatch conv with - | true => n - | false => reify_as_var_aux open_constr:(S n) tl term - end - | _ => - let _ := open_constr:(eq_refl : lvar = @cons _ term _) in - n - end. - -Ltac reify_as_var lvar term := reify_as_var_aux Datatypes.O lvar term. - -Ltac close_varlist lvar := - lazymatch lvar with - | @nil _ => idtac - | @cons _ _ ?tl => close_varlist tl - | _ => let _ := constr:(eq_refl : lvar = @nil _) in idtac - end. - -(* extensibility: override to add ways to reify a term. - Return [tt] for terms which aren't handled (tt doesn't have type PExpr so is unambiguous) *) -Ltac extra_reify term := open_constr:(tt). - -Ltac reify_term R ring0 ring1 add mul sub opp lvar term := - let reify_term x := reify_term R ring0 ring1 add mul sub opp lvar x in - match term with - (* int literals *) - | Z0 => open_constr:(PEc 0%Z) - | Zpos ?p => open_constr:(PEc (Zpos p)) - | Zneg ?p => open_constr:(PEc (Zneg p)) - - (* ring constants *) - | _ => - let _ := lazymatch goal with _ => convert ring0 term end in - open_constr:(PEc 0%Z) - | _ => - let _ := lazymatch goal with _ => convert ring1 term end in - open_constr:(PEc 1%Z) - - (* binary operators *) - | ?op ?t1 ?t2 => - (* quick(?) check op is of the right type? TODO try without this check *) - let _ := open_constr:(t1 : R) in - let _ := open_constr:(t2 : R) in - match tt with - | _ => - let _ := lazymatch goal with _ => convert add op end in - (* NB: don't reify before we recognize the operator in case we can't recognire it *) - let et1 := reify_term t1 in - let et2 := reify_term t2 in - open_constr:(PEadd et1 et2) - | _ => - let _ := lazymatch goal with _ => convert mul op end in - let et1 := reify_term t1 in - let et2 := reify_term t2 in - open_constr:(PEmul et1 et2) - | _ => - let _ := lazymatch goal with _ => convert sub op end in - let et1 := reify_term t1 in - let et2 := reify_term t2 in - open_constr:(PEsub et1 et2) - end - - (* unary operator (opposite) *) - | ?op ?t => - let _ := lazymatch goal with _ => convert opp op end in - let et := reify_term t in - open_constr:(PEopp et) - - (* special cases (XXX can/should we be less syntactic?) *) - | @multiplication Z _ _ ?z ?t => - let et := reify_term t in - open_constr:(PEmul (PEc z) et) - | pow_N ?t ?n => - let et := reify_term t in - open_constr:(PEpow et n) - | @power _ _ power_ring ?t ?n => - let et := reify_term t in - open_constr:(PEpow et (ZN n)) - - (* extensibility and variable case *) - | _ => - let extra := extra_reify term in - lazymatch extra with - | tt => - let n := reify_as_var lvar term in - open_constr:(PEX Z (Pos.of_succ_nat n)) - | ?v => v - end - end. - -Ltac list_reifyl_core Tring lvar lterm := - lazymatch lterm with - | @nil _ => open_constr:(@nil (PExpr Z)) - | @cons _ ?t ?tl => - lazymatch Tring with - | Ring (T:=?R) (ring0:=?ring0) (ring1:=?ring1) - (add:=?add) (mul:=?mul) (sub:=?sub) (opp:=?opp) => - let et := reify_term R ring0 ring1 add mul sub opp lvar t in - let etl := list_reifyl_core Tring lvar tl in - open_constr:(@cons (PExpr Z) et etl) - end - end. - -Ltac list_reifyl lvar lterm := - lazymatch lterm with - | @cons ?R _ _ => - let R_ring := constr:(_ :> Ring (T:=R)) in - let Tring := type of R_ring in - let lexpr := list_reifyl_core Tring lvar lterm in - let _ := lazymatch goal with _ => close_varlist lvar end in - constr:((lvar,lexpr)) - end. - -Ltac list_reifyl0 lterm := - lazymatch lterm with - | @cons ?R _ _ => - let lvar := open_constr:(_ :> list R) in - list_reifyl lvar lterm - end. - -Class ReifyL {R:Type} (lvar lterm : list R) := list_reifyl : (list R * list (PExpr Z)). -Arguments list_reifyl {R lvar lterm _}. - -Global Hint Extern 0 (ReifyL ?lvar ?lterm) => let reif := list_reifyl lvar lterm in exact reif : typeclass_instances. - -Unset Implicit Arguments. - -Ltac lterm_goal g := - match g with - | ?t1 == ?t2 => constr:(t1::t2::nil) - | ?t1 = ?t2 => constr:(t1::t2::nil) - | (_ ?t1 ?t2) => constr:(t1::t2::nil) - end. - -Lemma Private_Zeqb_ok: forall x y : Z, Z.eqb x y = true -> x == y. -Proof. intros x y ->%Z.eqb_eq. reflexivity. Qed. - -#[deprecated(use=Z.eqb_eq, since="9.0")] -Notation Zeqb_ok := Private_Zeqb_ok (only parsing). - - -Ltac reify_goal lvar lexpr lterm:= - (*idtac lvar; idtac lexpr; idtac lterm;*) - match lexpr with - nil => idtac - | ?e1::?e2::_ => - match goal with - |- (?op ?u1 ?u2) => - change (op - (@PEeval Z _ _ _ _ _ _ _ _ _ (@gen_phiZ _ _ _ _ _ _ _ _ _) N - (fun n:N => n) (@pow_N _ _ _ _ _ _ _ _ _) - lvar e1) - (@PEeval Z _ _ _ _ _ _ _ _ _ (@gen_phiZ _ _ _ _ _ _ _ _ _) N - (fun n:N => n) (@pow_N _ _ _ _ _ _ _ _ _) - lvar e2)) - end - end. - -Lemma comm: forall (R:Type)`{Ring R}(c : Z) (x : R), - x * (gen_phiZ c) == (gen_phiZ c) * x. - induction c. - - intros. simpl. gen_rewrite. - - simpl. intros. - rewrite <- same_gen. - induction p. - + simpl. gen_rewrite. rewrite IHp. reflexivity. - + simpl. gen_rewrite. rewrite IHp. reflexivity. - + simpl. gen_rewrite. - - simpl. intros. rewrite <- same_gen. - induction p. - + simpl. generalize IHp. clear IHp. - gen_rewrite. intro IHp. rewrite IHp. reflexivity. - + simpl. generalize IHp. clear IHp. - gen_rewrite. intro IHp. rewrite IHp. reflexivity. - + simpl. gen_rewrite. -Qed. - -Ltac ring_gen := - match goal with - |- ?g => - let lterm := lterm_goal g in - let reif := list_reifyl0 lterm in - match reif with - | (?fv, ?lexpr) => - (*idtac "variables:";idtac fv; - idtac "terms:"; idtac lterm; - idtac "reifications:"; idtac lexpr; *) - reify_goal fv lexpr lterm; - match goal with - |- ?g => - apply (@ring_correct Z _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ - (@gen_phiZ _ _ _ _ _ _ _ _ _) _ - (@comm _ _ _ _ _ _ _ _ _ _) Z.eqb Private_Zeqb_ok N (fun n:N => n) - (@pow_N _ _ _ _ _ _ _ _ _)); - [apply mkpow_th; reflexivity - |vm_compute; reflexivity] - end - end - end. - -Ltac non_commutative_ring:= - intros; - ring_gen. - -(* simplification *) - -Ltac ring_simplify_aux lterm fv lexpr hyp := - match lterm with - | ?t0::?lterm => - match lexpr with - | ?e::?le => (* e:PExpr Z est la rĆ©ification de t0:R *) - let t := constr:(@Ncring_polynom.norm_subst - Z 0%Z 1%Z Z.add Z.mul Z.sub Z.opp (@eq Z) Zops Z.eqb e) in - (* t:Pol Z *) - let te := - constr:(@Ncring_polynom.Pphi Z - _ 0 1 _+_ _*_ _-_ -_ _==_ _ Ncring_initial.gen_phiZ fv t) in - let eq1 := fresh "ring" in - let nft := eval vm_compute in t in - let t':= fresh "t" in - pose (t' := nft); - assert (eq1 : t = t'); - [vm_cast_no_check (eq_refl t')| - let eq2 := fresh "ring" in - assert (eq2:(@Ncring_polynom.PEeval Z - _ 0 1 _+_ _*_ _-_ -_ _==_ _ Ncring_initial.gen_phiZ N (fun n:N => n) - (@Ring_theory.pow_N _ 1 multiplication) fv e) == te); - [apply (@Ncring_polynom.norm_subst_ok - Z _ 0%Z 1%Z Z.add Z.mul Z.sub Z.opp (@eq Z) - _ _ 0 1 _+_ _*_ _-_ -_ _==_ _ _ Ncring_initial.gen_phiZ _ - (@comm _ 0 1 _+_ _*_ _-_ -_ _==_ _ _) _ Private_Zeqb_ok); - apply mkpow_th; reflexivity - | match hyp with - | 1%nat => rewrite eq2 - | ?H => try rewrite eq2 in H - end]; - let P:= fresh "P" in - match hyp with - | 1%nat => idtac "ok"; - rewrite eq1; - pattern (@Ncring_polynom.Pphi Z _ 0 1 _+_ _*_ _-_ -_ _==_ - _ Ncring_initial.gen_phiZ fv t'); - match goal with - |- (?p ?t) => set (P:=p) - end; - unfold t' in *; clear t' eq1 eq2; simpl - | ?H => - rewrite eq1 in H; - pattern (@Ncring_polynom.Pphi Z _ 0 1 _+_ _*_ _-_ -_ _==_ - _ Ncring_initial.gen_phiZ fv t') in H; - match type of H with - | (?p ?t) => set (P:=p) in H - end; - unfold t' in *; clear t' eq1 eq2; simpl in H - end; unfold P in *; clear P - ]; ring_simplify_aux lterm fv le hyp - | nil => idtac - end - | nil => idtac - end. - -Ltac set_variables fv := - match fv with - | nil => idtac - | ?t::?fv => - let v := fresh "X" in - set (v:=t) in *; set_variables fv - end. - -Ltac deset n:= - match n with - | 0%nat => idtac - | S ?n1 => - match goal with - | h:= ?v : ?t |- ?g => unfold h in *; clear h; deset n1 - end - end. - -(* a est soit un terme de l'anneau, soit une liste de termes. -J'ai pas rĆ©ussi Ć  un dĆ©composer les Vlists obtenues avec ne_constr_list - dans Tactic Notation *) - -Ltac ring_simplify_gen a hyp := - let lterm := - match a with - | _::_ => a - | _ => constr:(a::nil) - end in - let reif := list_reifyl0 lterm in - match reif with - | (?fv, ?lexpr) => idtac lterm; idtac fv; idtac lexpr; - let n := eval compute in (length fv) in - idtac n; - let lt:=fresh "lt" in - set (lt:= lterm); - let lv:=fresh "fv" in - set (lv:= fv); - (* les termes de fv sont remplacĆ©s par des variables - pour pouvoir utiliser simpl ensuite sans risquer - des simplifications indĆ©sirables *) - set_variables fv; - let lterm1 := eval unfold lt in lt in - let lv1 := eval unfold lv in lv in - idtac lterm1; idtac lv1; - ring_simplify_aux lterm1 lv1 lexpr hyp; - clear lt lv; - (* on remet les termes de fv *) - deset n - end. - -Tactic Notation "non_commutative_ring_simplify" constr(lterm):= - ring_simplify_gen lterm 1%nat. - -Tactic Notation "non_commutative_ring_simplify" constr(lterm) "in" ident(H):= - ring_simplify_gen lterm H. diff --git a/stdlib/theories/setoid_ring/RealField.v b/stdlib/theories/setoid_ring/RealField.v deleted file mode 100644 index d340075aa4d7..000000000000 --- a/stdlib/theories/setoid_ring/RealField.v +++ /dev/null @@ -1,161 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* 0. -unfold Rgt. -induction x; simpl; intros. -- apply Rlt_trans with (1 + 0). - + rewrite Rplus_comm. - apply Rlt_n_Sn. - + apply Rplus_lt_compat_l. - rewrite <- (Rmul_0_l Rset Rext RTheory 2). - rewrite Rmult_comm. - apply Rmult_lt_compat_l. - * apply Rlt_0_2. - * trivial. -- rewrite <- (Rmul_0_l Rset Rext RTheory 2). - rewrite Rmult_comm. - apply Rmult_lt_compat_l. - + apply Rlt_0_2. - + trivial. -- replace 1 with (0 + 1). - + apply Rlt_n_Sn. - + apply Rplus_0_l. -Qed. - - -Lemma Rgen_phiPOS_not_0 : - forall x, InitialRing.gen_phiPOS1 1 Rplus Rmult x <> 0. -red; intros. -specialize (Rgen_phiPOS x). -rewrite H; intro. -apply (Rlt_asym 0 0); trivial. -Qed. - -Lemma Zeq_bool_complete : forall x y, - InitialRing.gen_phiZ 0%R 1%R Rplus Rmult Ropp x = - InitialRing.gen_phiZ 0%R 1%R Rplus Rmult Ropp y -> - Z.eqb x y = true. -Proof gen_phiZ_complete Rset Rext Rfield Rgen_phiPOS_not_0. - -Lemma Rdef_pow_add : forall (x:R) (n m:nat), pow x (n + m) = pow x n * pow x m. -Proof. - intros x n; elim n; simpl; auto with real. - intros n0 H' m; rewrite H'; auto with real. -Qed. - -Lemma R_power_theory : power_theory 1%R Rmult (@eq R) N.to_nat pow. -Proof. - constructor. destruct n. - - reflexivity. - - simpl. induction p. - + rewrite Pos2Nat.inj_xI. simpl. now rewrite Nat.add_0_r, Rdef_pow_add, IHp. - + rewrite Pos2Nat.inj_xO. simpl. now rewrite Nat.add_0_r, Rdef_pow_add, IHp. - + simpl. rewrite Rmult_comm;apply Rmult_1_l. -Qed. - -Ltac Rpow_tac t := - match isnatcst t with - | false => constr:(InitialRing.NotConstant) - | _ => constr:(N.of_nat t) - end. - -Ltac IZR_tac t := - match t with - | R0 => constr:(0%Z) - | R1 => constr:(1%Z) - | IZR (Z.pow_pos 10 ?p) => - match isPcst p with - | true => constr:(Z.pow_pos 10 p) - | _ => constr:(InitialRing.NotConstant) - end - | IZR ?u => - match isZcst u with - | true => u - | _ => constr:(InitialRing.NotConstant) - end - | _ => constr:(InitialRing.NotConstant) - end. - -Add Field RField : Rfield - (completeness Zeq_bool_complete, constants [IZR_tac], power_tac R_power_theory [Rpow_tac]). diff --git a/stdlib/theories/setoid_ring/Ring.v b/stdlib/theories/setoid_ring/Ring.v deleted file mode 100644 index 67921beccb1a..000000000000 --- a/stdlib/theories/setoid_ring/Ring.v +++ /dev/null @@ -1,46 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* b) (eq(A:=bool)). -split; simpl. -- intros x; destruct x; reflexivity. -- intros x y; destruct x; destruct y; reflexivity. -- intros x y z; destruct x; destruct y; destruct z; reflexivity. -- reflexivity. -- intros x y; destruct x; destruct y; reflexivity. -- intros x y; destruct x; destruct y; reflexivity. -- intros x y z; destruct x; destruct y; destruct z; reflexivity. -- reflexivity. -- intros x; destruct x; reflexivity. -Qed. - -Definition bool_eq (b1 b2:bool) := - if b1 then b2 else negb b2. - -Lemma bool_eq_ok : forall b1 b2, bool_eq b1 b2 = true -> b1 = b2. -intros b1 b2; destruct b1; destruct b2; auto. -Qed. - -Ltac bool_cst t := - let t := eval hnf in t in - match t with - true => constr:(true) - | false => constr:(false) - | _ => constr:(NotConstant) - end. - -Add Ring bool_ring : BoolTheory (decidable bool_eq_ok, constants [bool_cst]). diff --git a/stdlib/theories/setoid_ring/Ring_base.v b/stdlib/theories/setoid_ring/Ring_base.v deleted file mode 100644 index 1dcfdbd6c2bd..000000000000 --- a/stdlib/theories/setoid_ring/Ring_base.v +++ /dev/null @@ -1,18 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* R->R) (ropp : R->R). - Variable req : R -> R -> Prop. - - (* Ring properties *) - Variable Rsth : Equivalence req. - Variable Reqe : ring_eq_ext radd rmul ropp req. - Variable ARth : almost_ring_theory rO rI radd rmul rsub ropp req. - - (* Coefficients *) - Variable C: Type. - Variable (cO cI: C) (cadd cmul csub : C->C->C) (copp : C->C). - Variable ceqb : C->C->bool. - Variable phi : C -> R. - Variable CRmorph : ring_morph rO rI radd rmul rsub ropp req - cO cI cadd cmul csub copp ceqb phi. - - (* Power coefficients *) - Variable Cpow : Type. - Variable Cp_phi : N -> Cpow. - Variable rpow : R -> Cpow -> R. - Variable pow_th : power_theory rI rmul req Cp_phi rpow. - - (* division is ok *) - Variable cdiv: C -> C -> C * C. - Variable div_th: div_theory req cadd cmul phi cdiv. - - - (* R notations *) - Notation "0" := rO. Notation "1" := rI. - Infix "+" := radd. Infix "*" := rmul. - Infix "-" := rsub. Notation "- x" := (ropp x). - Infix "==" := req. - Infix "^" := (pow_pos rmul). - - (* C notations *) - Infix "+!" := cadd. Infix "*!" := cmul. - Infix "-! " := csub. Notation "-! x" := (copp x). - Infix "?=!" := ceqb. Notation "[ x ]" := (phi x). - - (* Useful tactics *) - Add Morphism radd with signature (req ==> req ==> req) as radd_ext. - Proof. exact (Radd_ext Reqe). Qed. - - Add Morphism rmul with signature (req ==> req ==> req) as rmul_ext. - Proof. exact (Rmul_ext Reqe). Qed. - - Add Morphism ropp with signature (req ==> req) as ropp_ext. - Proof. exact (Ropp_ext Reqe). Qed. - - Add Morphism rsub with signature (req ==> req ==> req) as rsub_ext. - Proof. exact (ARsub_ext Rsth Reqe ARth). Qed. - - Ltac rsimpl := gen_srewrite Rsth Reqe ARth. - - Ltac add_push := gen_add_push radd Rsth Reqe ARth. - Ltac mul_push := gen_mul_push rmul Rsth Reqe ARth. - - Ltac add_permut_rec t := - match t with - | ?x + ?y => add_permut_rec y || add_permut_rec x - | _ => add_push t; apply (Radd_ext Reqe); [|reflexivity] - end. - - Ltac add_permut := - repeat (reflexivity || - match goal with |- ?t == _ => add_permut_rec t end). - - Ltac mul_permut_rec t := - match t with - | ?x * ?y => mul_permut_rec y || mul_permut_rec x - | _ => mul_push t; apply (Rmul_ext Reqe); [|reflexivity] - end. - - Ltac mul_permut := - repeat (reflexivity || - match goal with |- ?t == _ => mul_permut_rec t end). - - - (* Definition of multivariable polynomials with coefficients in C : - Type [Pol] represents [X1 ... Xn]. - The representation is Horner's where a [n] variable polynomial - (C[X1..Xn]) is seen as a polynomial on [X1] which coefficients - are polynomials with [n-1] variables (C[X2..Xn]). - There are several optimisations to make the repr compacter: - - [Pc c] is the constant polynomial of value c - == c*X1^0*..*Xn^0 - - [Pinj j Q] is a polynomial constant w.r.t the [j] first variables. - variable indices are shifted of j in Q. - == X1^0 *..* Xj^0 * Q{X1 <- Xj+1;..; Xn-j <- Xn} - - [PX P i Q] is an optimised Horner form of P*X^i + Q - with P not the null polynomial - == P * X1^i + Q{X1 <- X2; ..; Xn-1 <- Xn} - - In addition: - - polynomials of the form (PX (PX P i (Pc 0)) j Q) are forbidden - since they can be represented by the simpler form (PX P (i+j) Q) - - (Pinj i (Pinj j P)) is (Pinj (i+j) P) - - (Pinj i (Pc c)) is (Pc c) - *) - - Inductive Pol : Type := - | Pc : C -> Pol - | Pinj : positive -> Pol -> Pol - | PX : Pol -> positive -> Pol -> Pol. - - Definition P0 := Pc cO. - Definition P1 := Pc cI. - - Fixpoint Peq (P P' : Pol) {struct P'} : bool := - match P, P' with - | Pc c, Pc c' => c ?=! c' - | Pinj j Q, Pinj j' Q' => - match j ?= j' with - | Eq => Peq Q Q' - | _ => false - end - | PX P i Q, PX P' i' Q' => - match i ?= i' with - | Eq => if Peq P P' then Peq Q Q' else false - | _ => false - end - | _, _ => false - end. - - Infix "?==" := Peq. - - Definition mkPinj j P := - match P with - | Pc _ => P - | Pinj j' Q => Pinj (j + j') Q - | _ => Pinj j P - end. - - Definition mkPinj_pred j P:= - match j with - | xH => P - | xO j => Pinj (Pos.pred_double j) P - | xI j => Pinj (xO j) P - end. - - Definition mkPX P i Q := - match P with - | Pc c => if c ?=! cO then mkPinj xH Q else PX P i Q - | Pinj _ _ => PX P i Q - | PX P' i' Q' => if Q' ?== P0 then PX P' (i' + i) Q else PX P i Q - end. - - Definition mkXi i := PX P1 i P0. - - Definition mkX := mkXi 1. - - (** Opposite of addition *) - - Fixpoint Popp (P:Pol) : Pol := - match P with - | Pc c => Pc (-! c) - | Pinj j Q => Pinj j (Popp Q) - | PX P i Q => PX (Popp P) i (Popp Q) - end. - - Notation "-- P" := (Popp P). - - (** Addition et subtraction *) - - Fixpoint PaddC (P:Pol) (c:C) : Pol := - match P with - | Pc c1 => Pc (c1 +! c) - | Pinj j Q => Pinj j (PaddC Q c) - | PX P i Q => PX P i (PaddC Q c) - end. - - Fixpoint PsubC (P:Pol) (c:C) : Pol := - match P with - | Pc c1 => Pc (c1 -! c) - | Pinj j Q => Pinj j (PsubC Q c) - | PX P i Q => PX P i (PsubC Q c) - end. - - Section PopI. - - Variable Pop : Pol -> Pol -> Pol. - Variable Q : Pol. - - Fixpoint PaddI (j:positive) (P:Pol) : Pol := - match P with - | Pc c => mkPinj j (PaddC Q c) - | Pinj j' Q' => - match Z.pos_sub j' j with - | Zpos k => mkPinj j (Pop (Pinj k Q') Q) - | Z0 => mkPinj j (Pop Q' Q) - | Zneg k => mkPinj j' (PaddI k Q') - end - | PX P i Q' => - match j with - | xH => PX P i (Pop Q' Q) - | xO j => PX P i (PaddI (Pos.pred_double j) Q') - | xI j => PX P i (PaddI (xO j) Q') - end - end. - - Fixpoint PsubI (j:positive) (P:Pol) : Pol := - match P with - | Pc c => mkPinj j (PaddC (--Q) c) - | Pinj j' Q' => - match Z.pos_sub j' j with - | Zpos k => mkPinj j (Pop (Pinj k Q') Q) - | Z0 => mkPinj j (Pop Q' Q) - | Zneg k => mkPinj j' (PsubI k Q') - end - | PX P i Q' => - match j with - | xH => PX P i (Pop Q' Q) - | xO j => PX P i (PsubI (Pos.pred_double j) Q') - | xI j => PX P i (PsubI (xO j) Q') - end - end. - - Variable P' : Pol. - - Fixpoint PaddX (i':positive) (P:Pol) : Pol := - match P with - | Pc c => PX P' i' P - | Pinj j Q' => - match j with - | xH => PX P' i' Q' - | xO j => PX P' i' (Pinj (Pos.pred_double j) Q') - | xI j => PX P' i' (Pinj (xO j) Q') - end - | PX P i Q' => - match Z.pos_sub i i' with - | Zpos k => mkPX (Pop (PX P k P0) P') i' Q' - | Z0 => mkPX (Pop P P') i Q' - | Zneg k => mkPX (PaddX k P) i Q' - end - end. - - Fixpoint PsubX (i':positive) (P:Pol) : Pol := - match P with - | Pc c => PX (--P') i' P - | Pinj j Q' => - match j with - | xH => PX (--P') i' Q' - | xO j => PX (--P') i' (Pinj (Pos.pred_double j) Q') - | xI j => PX (--P') i' (Pinj (xO j) Q') - end - | PX P i Q' => - match Z.pos_sub i i' with - | Zpos k => mkPX (Pop (PX P k P0) P') i' Q' - | Z0 => mkPX (Pop P P') i Q' - | Zneg k => mkPX (PsubX k P) i Q' - end - end. - - - End PopI. - - Fixpoint Padd (P P': Pol) {struct P'} : Pol := - match P' with - | Pc c' => PaddC P c' - | Pinj j' Q' => PaddI Padd Q' j' P - | PX P' i' Q' => - match P with - | Pc c => PX P' i' (PaddC Q' c) - | Pinj j Q => - match j with - | xH => PX P' i' (Padd Q Q') - | xO j => PX P' i' (Padd (Pinj (Pos.pred_double j) Q) Q') - | xI j => PX P' i' (Padd (Pinj (xO j) Q) Q') - end - | PX P i Q => - match Z.pos_sub i i' with - | Zpos k => mkPX (Padd (PX P k P0) P') i' (Padd Q Q') - | Z0 => mkPX (Padd P P') i (Padd Q Q') - | Zneg k => mkPX (PaddX Padd P' k P) i (Padd Q Q') - end - end - end. - Infix "++" := Padd. - - Fixpoint Psub (P P': Pol) {struct P'} : Pol := - match P' with - | Pc c' => PsubC P c' - | Pinj j' Q' => PsubI Psub Q' j' P - | PX P' i' Q' => - match P with - | Pc c => PX (--P') i' (*(--(PsubC Q' c))*) (PaddC (--Q') c) - | Pinj j Q => - match j with - | xH => PX (--P') i' (Psub Q Q') - | xO j => PX (--P') i' (Psub (Pinj (Pos.pred_double j) Q) Q') - | xI j => PX (--P') i' (Psub (Pinj (xO j) Q) Q') - end - | PX P i Q => - match Z.pos_sub i i' with - | Zpos k => mkPX (Psub (PX P k P0) P') i' (Psub Q Q') - | Z0 => mkPX (Psub P P') i (Psub Q Q') - | Zneg k => mkPX (PsubX Psub P' k P) i (Psub Q Q') - end - end - end. - Infix "--" := Psub. - - (** Multiplication *) - - Fixpoint PmulC_aux (P:Pol) (c:C) : Pol := - match P with - | Pc c' => Pc (c' *! c) - | Pinj j Q => mkPinj j (PmulC_aux Q c) - | PX P i Q => mkPX (PmulC_aux P c) i (PmulC_aux Q c) - end. - - Definition PmulC P c := - if c ?=! cO then P0 else - if c ?=! cI then P else PmulC_aux P c. - - Section PmulI. - Variable Pmul : Pol -> Pol -> Pol. - Variable Q : Pol. - Fixpoint PmulI (j:positive) (P:Pol) : Pol := - match P with - | Pc c => mkPinj j (PmulC Q c) - | Pinj j' Q' => - match Z.pos_sub j' j with - | Zpos k => mkPinj j (Pmul (Pinj k Q') Q) - | Z0 => mkPinj j (Pmul Q' Q) - | Zneg k => mkPinj j' (PmulI k Q') - end - | PX P' i' Q' => - match j with - | xH => mkPX (PmulI xH P') i' (Pmul Q' Q) - | xO j' => mkPX (PmulI j P') i' (PmulI (Pos.pred_double j') Q') - | xI j' => mkPX (PmulI j P') i' (PmulI (xO j') Q') - end - end. - - End PmulI. - - Fixpoint Pmul (P P'' : Pol) {struct P''} : Pol := - match P'' with - | Pc c => PmulC P c - | Pinj j' Q' => PmulI Pmul Q' j' P - | PX P' i' Q' => - match P with - | Pc c => PmulC P'' c - | Pinj j Q => - let QQ' := - match j with - | xH => Pmul Q Q' - | xO j => Pmul (Pinj (Pos.pred_double j) Q) Q' - | xI j => Pmul (Pinj (xO j) Q) Q' - end in - mkPX (Pmul P P') i' QQ' - | PX P i Q=> - let QQ' := Pmul Q Q' in - let PQ' := PmulI Pmul Q' xH P in - let QP' := Pmul (mkPinj xH Q) P' in - let PP' := Pmul P P' in - (mkPX (mkPX PP' i P0 ++ QP') i' P0) ++ mkPX PQ' i QQ' - end - end. - - Infix "**" := Pmul. - - (** Monomial **) - - (** A monomial is X1^k1...Xi^ki. Its representation - is a simplified version of the polynomial representation: - - - [mon0] correspond to the polynom [P1]. - - [(zmon j M)] corresponds to [(Pinj j ...)], - i.e. skip j variable indices. - - [(vmon i M)] is X^i*M with X the current variable, - its corresponds to (PX P1 i ...)] - *) - - Inductive Mon: Set := - | mon0: Mon - | zmon: positive -> Mon -> Mon - | vmon: positive -> Mon -> Mon. - - Definition mkZmon j M := - match M with mon0 => mon0 | _ => zmon j M end. - - Definition zmon_pred j M := - match j with xH => M | _ => mkZmon (Pos.pred j) M end. - - Definition mkVmon i M := - match M with - | mon0 => vmon i mon0 - | zmon j m => vmon i (zmon_pred j m) - | vmon i' m => vmon (i+i') m - end. - - Fixpoint CFactor (P: Pol) (c: C) {struct P}: Pol * Pol := - match P with - | Pc c1 => let (q,r) := cdiv c1 c in (Pc r, Pc q) - | Pinj j1 P1 => - let (R,S) := CFactor P1 c in - (mkPinj j1 R, mkPinj j1 S) - | PX P1 i Q1 => - let (R1, S1) := CFactor P1 c in - let (R2, S2) := CFactor Q1 c in - (mkPX R1 i R2, mkPX S1 i S2) - end. - - Fixpoint MFactor (P: Pol) (c: C) (M: Mon) {struct P}: Pol * Pol := - match P, M with - _, mon0 => if (ceqb c cI) then (Pc cO, P) else CFactor P c - | Pc _, _ => (P, Pc cO) - | Pinj j1 P1, zmon j2 M1 => - match j1 ?= j2 with - Eq => let (R,S) := MFactor P1 c M1 in - (mkPinj j1 R, mkPinj j1 S) - | Lt => let (R,S) := MFactor P1 c (zmon (j2 - j1) M1) in - (mkPinj j1 R, mkPinj j1 S) - | Gt => (P, Pc cO) - end - | Pinj _ _, vmon _ _ => (P, Pc cO) - | PX P1 i Q1, zmon j M1 => - let M2 := zmon_pred j M1 in - let (R1, S1) := MFactor P1 c M in - let (R2, S2) := MFactor Q1 c M2 in - (mkPX R1 i R2, mkPX S1 i S2) - | PX P1 i Q1, vmon j M1 => - match i ?= j with - Eq => let (R1,S1) := MFactor P1 c (mkZmon xH M1) in - (mkPX R1 i Q1, S1) - | Lt => let (R1,S1) := MFactor P1 c (vmon (j - i) M1) in - (mkPX R1 i Q1, S1) - | Gt => let (R1,S1) := MFactor P1 c (mkZmon xH M1) in - (mkPX R1 i Q1, mkPX S1 (i-j) (Pc cO)) - end - end. - - Definition POneSubst (P1: Pol) (cM1: C * Mon) (P2: Pol): option Pol := - let (c,M1) := cM1 in - let (Q1,R1) := MFactor P1 c M1 in - match R1 with - (Pc c) => if c ?=! cO then None - else Some (Padd Q1 (Pmul P2 R1)) - | _ => Some (Padd Q1 (Pmul P2 R1)) - end. - - Fixpoint PNSubst1 (P1: Pol) (cM1: C * Mon) (P2: Pol) (n: nat) : Pol := - match POneSubst P1 cM1 P2 with - Some P3 => match n with S n1 => PNSubst1 P3 cM1 P2 n1 | _ => P3 end - | _ => P1 - end. - - Definition PNSubst (P1: Pol) (cM1: C * Mon) (P2: Pol) (n: nat): option Pol := - match POneSubst P1 cM1 P2 with - Some P3 => match n with S n1 => Some (PNSubst1 P3 cM1 P2 n1) | _ => None end - | _ => None - end. - - Fixpoint PSubstL1 (P1: Pol) (LM1: list ((C * Mon) * Pol)) (n: nat) : Pol := - match LM1 with - cons (M1,P2) LM2 => PSubstL1 (PNSubst1 P1 M1 P2 n) LM2 n - | _ => P1 - end. - - Fixpoint PSubstL (P1: Pol) (LM1: list ((C * Mon) * Pol)) (n: nat) : option Pol := - match LM1 with - cons (M1,P2) LM2 => - match PNSubst P1 M1 P2 n with - Some P3 => Some (PSubstL1 P3 LM2 n) - | None => PSubstL P1 LM2 n - end - | _ => None - end. - - Fixpoint PNSubstL (P1: Pol) (LM1: list ((C * Mon) * Pol)) (m n: nat) : Pol := - match PSubstL P1 LM1 n with - Some P3 => match m with S m1 => PNSubstL P3 LM1 m1 n | _ => P3 end - | _ => P1 - end. - - (** Evaluation of a polynomial towards R *) - - Local Notation hd := (List.hd 0). - - Fixpoint Pphi(l:list R) (P:Pol) : R := - match P with - | Pc c => [c] - | Pinj j Q => Pphi (jump j l) Q - | PX P i Q => Pphi l P * (hd l) ^ i + Pphi (tail l) Q - end. - - Reserved Notation "P @ l " (at level 10, no associativity). - Notation "P @ l " := (Pphi l P). - - Definition Pequiv (P Q : Pol) := forall l, P@l == Q@l. - Infix "===" := Pequiv (at level 70, no associativity). - - Instance Pequiv_eq : Equivalence Pequiv. - Proof. - unfold Pequiv; split; red; intros; [reflexivity|now symmetry|now etransitivity]. - Qed. - - Instance Pphi_ext : Proper (eq ==> Pequiv ==> req) Pphi. - Proof. - now intros l l' <- P Q H. - Qed. - - Instance Pinj_ext : Proper (eq ==> Pequiv ==> Pequiv) Pinj. - Proof. - intros i j <- P P' HP l. simpl. now rewrite HP. - Qed. - - Instance PX_ext : Proper (Pequiv ==> eq ==> Pequiv ==> Pequiv) PX. - Proof. - intros P P' HP p p' <- Q Q' HQ l. simpl. now rewrite HP, HQ. - Qed. - - (** Evaluation of a monomial towards R *) - - Fixpoint Mphi(l:list R) (M: Mon) : R := - match M with - | mon0 => rI - | zmon j M1 => Mphi (jump j l) M1 - | vmon i M1 => Mphi (tail l) M1 * (hd l) ^ i - end. - - Notation "M @@ l" := (Mphi l M) (at level 10, no associativity). - - (** Proofs *) - - Ltac destr_pos_sub := - match goal with |- context [Z.pos_sub ?x ?y] => - generalize (Z.pos_sub_discr x y); destruct (Z.pos_sub x y) - end. - - Lemma jump_add' i j (l:list R) : jump (i + j) l = jump j (jump i l). - Proof. rewrite Pos.add_comm. apply jump_add. Qed. - - Lemma Peq_ok P P' : (P ?== P') = true -> P === P'. - Proof. - unfold Pequiv. - revert P';induction P as [|p P IHP|P2 IHP1 p P3 IHP2]; - intros P';destruct P' as [|p0 P'|P'1 p0 P'2];simpl; - intros H l; try easy. - - now apply (morph_eq CRmorph). - - destruct (Pos.compare_spec p p0); [ subst | easy | easy ]. - now rewrite IHP. - - specialize (IHP1 P'1); specialize (IHP2 P'2). - destruct (Pos.compare_spec p p0); [ subst | easy | easy ]. - destruct (P2 ?== P'1); [|easy]. - rewrite H in *. - now rewrite IHP1, IHP2. - Qed. - - Lemma Peq_spec P P' : BoolSpec (P === P') True (P ?== P'). - Proof. - generalize (Peq_ok P P'). destruct (P ?== P'); auto. - Qed. - - Lemma Pphi0 l : P0@l == 0. - Proof. - simpl;apply (morph0 CRmorph). - Qed. - - Lemma Pphi1 l : P1@l == 1. - Proof. - simpl;apply (morph1 CRmorph). - Qed. - - Lemma mkPinj_ok j l P : (mkPinj j P)@l == P@(jump j l). - Proof. - destruct P;simpl;rsimpl. - now rewrite jump_add'. - Qed. - - Instance mkPinj_ext : Proper (eq ==> Pequiv ==> Pequiv) mkPinj. - Proof. - intros i j <- P Q H l. now rewrite !mkPinj_ok. - Qed. - - Lemma pow_pos_add x i j : x^(j + i) == x^i * x^j. - Proof. - rewrite Pos.add_comm. - apply (pow_pos_add Rsth (Rmul_ext Reqe) (ARmul_assoc ARth)). - Qed. - - Lemma ceqb_spec c c' : BoolSpec ([c] == [c']) True (c ?=! c'). - Proof. - generalize (morph_eq CRmorph c c'). - destruct (c ?=! c'); auto. - Qed. - - Lemma mkPX_ok l P i Q : - (mkPX P i Q)@l == P@l * (hd l)^i + Q@(tail l). - Proof. - unfold mkPX. destruct P. - - case ceqb_spec; intros H; simpl; try reflexivity. - rewrite H, (morph0 CRmorph), mkPinj_ok; rsimpl. - - reflexivity. - - case Peq_spec; intros H; simpl; try reflexivity. - rewrite H, Pphi0, Pos.add_comm, pow_pos_add; rsimpl. - Qed. - - Instance mkPX_ext : Proper (Pequiv ==> eq ==> Pequiv ==> Pequiv) mkPX. - Proof. - intros P P' HP i i' <- Q Q' HQ l. now rewrite !mkPX_ok, HP, HQ. - Qed. - - Hint Rewrite - Pphi0 - Pphi1 - mkPinj_ok - mkPX_ok - (morph0 CRmorph) - (morph1 CRmorph) - (morph0 CRmorph) - (morph_add CRmorph) - (morph_mul CRmorph) - (morph_sub CRmorph) - (morph_opp CRmorph) - : Esimpl. - - (* Quicker than autorewrite with Esimpl :-) *) - Ltac Esimpl := try rewrite_db Esimpl; rsimpl; simpl. - - Lemma PaddC_ok c P l : (PaddC P c)@l == P@l + [c]. - Proof. - revert l;induction P as [| |P2 IHP1 p P3 IHP2];simpl;intros;Esimpl;trivial. - rewrite IHP2;rsimpl. - Qed. - - Lemma PsubC_ok c P l : (PsubC P c)@l == P@l - [c]. - Proof. - revert l;induction P as [|p P IHP|P2 IHP1 p P3 IHP2];simpl;intros. - - Esimpl. - - rewrite IHP;rsimpl. - - rewrite IHP2;rsimpl. - Qed. - - Lemma PmulC_aux_ok c P l : (PmulC_aux P c)@l == P@l * [c]. - Proof. - revert l;induction P as [| |P2 IHP1 p P3 IHP2];simpl;intros;Esimpl;trivial. - rewrite IHP1, IHP2;rsimpl. add_permut. mul_permut. - Qed. - - Lemma PmulC_ok c P l : (PmulC P c)@l == P@l * [c]. - Proof. - unfold PmulC. - case ceqb_spec; intros H. - - rewrite H; Esimpl. - - case ceqb_spec; intros H'. - + rewrite H'; Esimpl. - + apply PmulC_aux_ok. - Qed. - - Lemma Popp_ok P l : (--P)@l == - P@l. - Proof. - revert l;induction P as [|p P IHP|P2 IHP1 p P3 IHP2];simpl;intros. - - Esimpl. - - apply IHP. - - rewrite IHP1, IHP2;rsimpl. - Qed. - - Hint Rewrite PaddC_ok PsubC_ok PmulC_ok Popp_ok : Esimpl. - - Lemma PaddX_ok P' P k l : - (forall P l, (P++P')@l == P@l + P'@l) -> - (PaddX Padd P' k P) @ l == P@l + P'@l * (hd l)^k. - Proof. - intros IHP'. - revert k l. induction P as [|p P IHP|P2 IHP1 p P3 IHP2];simpl;intros. - - add_permut. - - destruct p; simpl; - rewrite ?jump_pred_double; add_permut. - - destr_pos_sub; intros ->; Esimpl. - + rewrite IHP';rsimpl. add_permut. - + rewrite IHP', pow_pos_add;simpl;Esimpl. add_permut. - + rewrite IHP1, pow_pos_add;rsimpl. add_permut. - Qed. - - Lemma Padd_ok P' P l : (P ++ P')@l == P@l + P'@l. - Proof. - revert P l; induction P' as [|p P' IHP'|P'1 IHP'1 p P'2 IHP'2]; - simpl;intros P l;Esimpl. - - revert p l; induction P as [|p P IHP|P2 IHP1 p P3 IHP2];simpl;intros p0 l. - + Esimpl; add_permut. - + destr_pos_sub; intros ->;Esimpl. - * now rewrite IHP'. - * rewrite IHP';Esimpl. now rewrite jump_add'. - * rewrite IHP. now rewrite jump_add'. - + destruct p0;simpl. - * rewrite IHP2;simpl. rsimpl. - * rewrite IHP2;simpl. rewrite jump_pred_double. rsimpl. - * rewrite IHP'. rsimpl. - - destruct P as [|p0 ?|? ? ?];simpl. - + Esimpl. add_permut. - + destruct p0;simpl;Esimpl; rewrite IHP'2; simpl. - * rsimpl. add_permut. - * rewrite jump_pred_double. rsimpl. add_permut. - * rsimpl. add_permut. - + destr_pos_sub; intros ->; Esimpl. - * rewrite IHP'1, IHP'2;rsimpl. add_permut. - * rewrite IHP'1, IHP'2;simpl;Esimpl. - rewrite pow_pos_add;rsimpl. add_permut. - * rewrite PaddX_ok by trivial; rsimpl. - rewrite IHP'2, pow_pos_add; rsimpl. add_permut. - Qed. - - Lemma Psub_opp P' P : P -- P' === P ++ (--P'). - Proof. - revert P; induction P' as [|p P' IHP'|P'1 IHP'1 p P'2 IHP'2]; simpl; intros P. - - intro l; Esimpl. - - revert p; induction P; simpl; intros p0; try reflexivity. - + destr_pos_sub; intros ->; now apply mkPinj_ext. - + destruct p0; now apply PX_ext. - - destruct P as [|p0 P|P2 p0 P3]; simpl; try reflexivity. - + destruct p0; now apply PX_ext. - + destr_pos_sub; intros ->; apply mkPX_ext; auto. - let p1 := match goal with |- PsubX _ _ ?p1 _ === _ => p1 end in - revert p1. induction P2; simpl; intros; try reflexivity. - destr_pos_sub; intros ->; now apply mkPX_ext. - Qed. - - Lemma Psub_ok P' P l : (P -- P')@l == P@l - P'@l. - Proof. - rewrite Psub_opp, Padd_ok, Popp_ok. rsimpl. - Qed. - - Lemma PmulI_ok P' : - (forall P l, (Pmul P P') @ l == P @ l * P' @ l) -> - forall P p l, (PmulI Pmul P' p P) @ l == P @ l * P' @ (jump p l). - Proof. - intros IHP' P. - induction P as [|p P IHP|? IHP1 ? ? IHP2];simpl;intros p0 l. - - Esimpl; mul_permut. - - destr_pos_sub; intros ->;Esimpl. - + now rewrite IHP'. - + now rewrite IHP', jump_add'. - + now rewrite IHP, jump_add'. - - destruct p0;Esimpl; rewrite ?IHP1, ?IHP2; rsimpl. - + f_equiv. mul_permut. - + rewrite jump_pred_double. f_equiv. mul_permut. - + rewrite IHP'. f_equiv. mul_permut. - Qed. - - Lemma Pmul_ok P P' l : (P**P')@l == P@l * P'@l. - Proof. - revert P l;induction P' as [| |? IHP'1 ? ? IHP'2];simpl;intros P l. - - apply PmulC_ok. - - apply PmulI_ok;trivial. - - destruct P as [|p0|]. - + rewrite (ARmul_comm ARth). Esimpl. - + Esimpl. f_equiv. - * rewrite IHP'1; Esimpl. - * destruct p0;rewrite IHP'2;Esimpl. - rewrite jump_pred_double; Esimpl. - + rewrite Padd_ok, !mkPX_ok, Padd_ok, !mkPX_ok, - !IHP'1, !IHP'2, PmulI_ok; trivial. simpl. Esimpl. - add_permut; f_equiv; mul_permut. - Qed. - - Lemma mkZmon_ok M j l : - (mkZmon j M) @@ l == (zmon j M) @@ l. - Proof. - destruct M; simpl; rsimpl. - Qed. - - Lemma zmon_pred_ok M j l : - (zmon_pred j M) @@ (tail l) == (zmon j M) @@ l. - Proof. - destruct j; simpl; rewrite ?mkZmon_ok; simpl; rsimpl. - rewrite jump_pred_double; rsimpl. - Qed. - - Lemma mkVmon_ok M i l : - (mkVmon i M)@@l == M@@l * (hd l)^i. - Proof. - destruct M;simpl;intros;rsimpl. - - rewrite zmon_pred_ok;simpl;rsimpl. - - rewrite pow_pos_add;rsimpl. - Qed. - - Ltac destr_factor := match goal with - | H : context [CFactor ?P _] |- context [CFactor ?P ?c] => - destruct (CFactor P c); destr_factor; rewrite H; clear H - | H : context [MFactor ?P _ _] |- context [MFactor ?P ?c ?M] => - specialize (H M); destruct (MFactor P c M); destr_factor; rewrite H; clear H - | _ => idtac - end. - - Lemma Mcphi_ok P c l : - let (Q,R) := CFactor P c in - P@l == Q@l + [c] * R@l. - Proof. - revert l. - induction P as [c0 | j P IH | P1 IH1 i P2 IH2]; intros l; Esimpl. - - assert (H := (div_eucl_th div_th) c0 c). - destruct cdiv as (q,r). rewrite H; Esimpl. add_permut. - - destr_factor. Esimpl. - - destr_factor. Esimpl. add_permut. - Qed. - - Lemma Mphi_ok P (cM: C * Mon) l : - let (c,M) := cM in - let (Q,R) := MFactor P c M in - P@l == Q@l + [c] * M@@l * R@l. - Proof. - destruct cM as (c,M). revert M l. - induction P as [c0|p P ?|P2 ? ? P3 ?]; intros M; destruct M; intros l; - simpl; auto; - try (case ceqb_spec; intro He); - try (case Pos.compare_spec; intros He); - rewrite ?He; - destr_factor; simpl; Esimpl. - - assert (H := div_eucl_th div_th c0 c). - destruct cdiv as (q,r). rewrite H; Esimpl. add_permut. - - assert (H := Mcphi_ok P c). destr_factor. Esimpl. - - now rewrite <- jump_add, Pos.sub_add. - - assert (H2 := Mcphi_ok P2 c). assert (H3 := Mcphi_ok P3 c). - destr_factor. Esimpl. add_permut. - - rewrite zmon_pred_ok. simpl. add_permut. - - rewrite mkZmon_ok. simpl. add_permut. mul_permut. - - add_permut. mul_permut. - rewrite <- pow_pos_add, Pos.add_comm, Pos.sub_add by trivial; rsimpl. - - rewrite mkZmon_ok. simpl. Esimpl. add_permut. mul_permut. - rewrite <- pow_pos_add, Pos.sub_add by trivial; rsimpl. - Qed. - - Lemma POneSubst_ok P1 cM1 P2 P3 l : - POneSubst P1 cM1 P2 = Some P3 -> - [fst cM1] * (snd cM1)@@l == P2@l -> P1@l == P3@l. - Proof. - destruct cM1 as (cc,M1). - unfold POneSubst. - assert (H := Mphi_ok P1 (cc, M1) l). simpl in H. - destruct MFactor as (R1,S1); simpl. rewrite H. clear H. - intros EQ EQ'. replace P3 with (R1 ++ P2 ** S1). - - rewrite EQ', Padd_ok, Pmul_ok; rsimpl. - - revert EQ. destruct S1; try now injection 1. - case ceqb_spec; now inversion 2. - Qed. - - Lemma PNSubst1_ok n P1 cM1 P2 l : - [fst cM1] * (snd cM1)@@l == P2@l -> - P1@l == (PNSubst1 P1 cM1 P2 n)@l. - Proof. - revert P1. induction n as [|n IHn]; simpl; intros P1; - generalize (POneSubst_ok P1 cM1 P2); destruct POneSubst; - intros; rewrite <- ?IHn; auto; reflexivity. - Qed. - - Lemma PNSubst_ok n P1 cM1 P2 l P3 : - PNSubst P1 cM1 P2 n = Some P3 -> - [fst cM1] * (snd cM1)@@l == P2@l -> P1@l == P3@l. - Proof. - unfold PNSubst. - assert (H := POneSubst_ok P1 cM1 P2); destruct POneSubst; try discriminate. - destruct n; inversion_clear 1. - intros. rewrite <- PNSubst1_ok; auto. - Qed. - - Fixpoint MPcond (LM1: list (C * Mon * Pol)) (l: list R) : Prop := - match LM1 with - | (M1,P2) :: LM2 => ([fst M1] * (snd M1)@@l == P2@l) /\ MPcond LM2 l - | _ => True - end. - - Lemma PSubstL1_ok n LM1 P1 l : - MPcond LM1 l -> P1@l == (PSubstL1 P1 LM1 n)@l. - Proof. - revert P1; induction LM1 as [|(M2,P2) LM2 IH]; simpl; intros. - - reflexivity. - - rewrite <- IH by intuition; now apply PNSubst1_ok. - Qed. - - Lemma PSubstL_ok n LM1 P1 P2 l : - PSubstL P1 LM1 n = Some P2 -> MPcond LM1 l -> P1@l == P2@l. - Proof. - revert P1. induction LM1 as [|(M2,P2') LM2 IH]; simpl; intros P3 H **. - - discriminate. - - assert (H':=PNSubst_ok n P3 M2 P2'). destruct PNSubst. - * injection H as [= <-]. rewrite <- PSubstL1_ok; intuition. - * now apply IH. - Qed. - - Lemma PNSubstL_ok m n LM1 P1 l : - MPcond LM1 l -> P1@l == (PNSubstL P1 LM1 m n)@l. - Proof. - revert LM1 P1. induction m as [|m IHm]; simpl; intros LM1 P2 H; - assert (H' := PSubstL_ok n LM1 P2); destruct PSubstL; - auto; try reflexivity. - rewrite <- IHm; auto. - Qed. - - (** Definition of polynomial expressions *) - - Inductive PExpr : Type := - | PEO : PExpr - | PEI : PExpr - | PEc : C -> PExpr - | PEX : positive -> PExpr - | PEadd : PExpr -> PExpr -> PExpr - | PEsub : PExpr -> PExpr -> PExpr - | PEmul : PExpr -> PExpr -> PExpr - | PEopp : PExpr -> PExpr - | PEpow : PExpr -> N -> PExpr. - - (** evaluation of polynomial expressions towards R *) - Definition mk_X j := mkPinj_pred j mkX. - - (** evaluation of polynomial expressions towards R *) - - Fixpoint PEeval (l:list R) (pe:PExpr) {struct pe} : R := - match pe with - | PEO => rO - | PEI => rI - | PEc c => phi c - | PEX j => nth 0 j l - | PEadd pe1 pe2 => (PEeval l pe1) + (PEeval l pe2) - | PEsub pe1 pe2 => (PEeval l pe1) - (PEeval l pe2) - | PEmul pe1 pe2 => (PEeval l pe1) * (PEeval l pe2) - | PEopp pe1 => - (PEeval l pe1) - | PEpow pe1 n => rpow (PEeval l pe1) (Cp_phi n) - end. - -Strategy expand [PEeval]. - - (** Correctness proofs *) - - Lemma mkX_ok p l : nth 0 p l == (mk_X p) @ l. - Proof. - destruct p;simpl;intros;Esimpl;trivial. - - now rewrite <-jump_tl, nth_jump. - - now rewrite <- nth_jump, nth_pred_double. - Qed. - - Hint Rewrite Padd_ok Psub_ok : Esimpl. - -Section POWER. - Variable subst_l : Pol -> Pol. - Fixpoint Ppow_pos (res P:Pol) (p:positive) : Pol := - match p with - | xH => subst_l (res ** P) - | xO p => Ppow_pos (Ppow_pos res P p) P p - | xI p => subst_l ((Ppow_pos (Ppow_pos res P p) P p) ** P) - end. - - Definition Ppow_N P n := - match n with - | N0 => P1 - | Npos p => Ppow_pos P1 P p - end. - - Lemma Ppow_pos_ok l : - (forall P, subst_l P@l == P@l) -> - forall res P p, (Ppow_pos res P p)@l == res@l * (pow_pos Pmul P p)@l. - Proof. - intros subst_l_ok res P p. revert res. - induction p as [p IHp|p IHp|];simpl;intros; - rewrite ?subst_l_ok, ?Pmul_ok, ?IHp; - mul_permut. - Qed. - - Lemma Ppow_N_ok l : - (forall P, subst_l P@l == P@l) -> - forall P n, (Ppow_N P n)@l == (pow_N P1 Pmul P n)@l. - Proof. - intros ? P n; destruct n;simpl. - - reflexivity. - - rewrite Ppow_pos_ok by trivial. Esimpl. - Qed. - - End POWER. - - (** Normalization and rewriting *) - - Section NORM_SUBST_REC. - Variable n : nat. - Variable lmp:list (C*Mon*Pol). - Let subst_l P := PNSubstL P lmp n n. - Let Pmul_subst P1 P2 := subst_l (P1 ** P2). - Let Ppow_subst := Ppow_N subst_l. - - Fixpoint norm_aux (pe:PExpr) : Pol := - match pe with - | PEO => Pc cO - | PEI => Pc cI - | PEc c => Pc c - | PEX j => mk_X j - | PEadd (PEopp pe1) pe2 => (norm_aux pe2) -- (norm_aux pe1) - | PEadd pe1 (PEopp pe2) => (norm_aux pe1) -- (norm_aux pe2) - | PEadd pe1 pe2 => (norm_aux pe1) ++ (norm_aux pe2) - | PEsub pe1 pe2 => (norm_aux pe1) -- (norm_aux pe2) - | PEmul pe1 pe2 => (norm_aux pe1) ** (norm_aux pe2) - | PEopp pe1 => -- (norm_aux pe1) - | PEpow pe1 n => Ppow_N (fun p => p) (norm_aux pe1) n - end. - - Definition norm_subst pe := subst_l (norm_aux pe). - - (** Internally, [norm_aux] is expanded in a large number of cases. - To speed-up proofs, we use an alternative definition. *) - - Definition get_PEopp pe := - match pe with - | PEopp pe' => Some pe' - | _ => None - end. - - Lemma norm_aux_PEadd pe1 pe2 : - norm_aux (PEadd pe1 pe2) = - match get_PEopp pe1, get_PEopp pe2 with - | Some pe1', _ => (norm_aux pe2) -- (norm_aux pe1') - | None, Some pe2' => (norm_aux pe1) -- (norm_aux pe2') - | None, None => (norm_aux pe1) ++ (norm_aux pe2) - end. - Proof. - simpl (norm_aux (PEadd _ _)). - destruct pe1; [ | | | | | | | reflexivity | ]; - destruct pe2; simpl get_PEopp; reflexivity. - Qed. - - Lemma norm_aux_PEopp pe : - match get_PEopp pe with - | Some pe' => norm_aux pe = -- (norm_aux pe') - | None => True - end. - Proof. - now destruct pe. - Qed. - - Arguments norm_aux !pe : simpl nomatch. - - Lemma norm_aux_spec l pe : - PEeval l pe == (norm_aux pe)@l. - Proof. - intros. - induction pe as [| |c|p|pe1 IHpe1 pe2 IHpe2|? IHpe1 ? IHpe2|? IHpe1 ? IHpe2 - |? IHpe|? IHpe n0]; cbn. - - now rewrite (morph0 CRmorph). - - now rewrite (morph1 CRmorph). - - reflexivity. - - apply mkX_ok. - - rewrite IHpe1, IHpe2. - assert (H1 := norm_aux_PEopp pe1). - assert (H2 := norm_aux_PEopp pe2). - rewrite norm_aux_PEadd. - do 2 destruct get_PEopp; rewrite ?H1, ?H2; Esimpl; add_permut. - - rewrite IHpe1, IHpe2. Esimpl. - - rewrite IHpe1, IHpe2. now rewrite Pmul_ok. - - rewrite IHpe. Esimpl. - - rewrite Ppow_N_ok by reflexivity. - rewrite (rpow_pow_N pow_th). destruct n0 as [|p]; simpl; Esimpl. - induction p as [p IHp|p IHp|];simpl; - now rewrite ?IHp, ?IHpe, ?Pms_ok, ?Pmul_ok. - Qed. - - Lemma norm_subst_spec : - forall l pe, MPcond lmp l -> - PEeval l pe == (norm_subst pe)@l. - Proof. - intros;unfold norm_subst. - unfold subst_l;rewrite <- PNSubstL_ok;trivial. apply norm_aux_spec. - Qed. - - End NORM_SUBST_REC. - - Fixpoint interp_PElist (l:list R) (lpe:list (PExpr*PExpr)) {struct lpe} : Prop := - match lpe with - | nil => True - | (me,pe)::lpe => - match lpe with - | nil => PEeval l me == PEeval l pe - | _ => PEeval l me == PEeval l pe /\ interp_PElist l lpe - end - end. - - Fixpoint mon_of_pol (P:Pol) : option (C * Mon) := - match P with - | Pc c => if (c ?=! cO) then None else Some (c, mon0) - | Pinj j P => - match mon_of_pol P with - | None => None - | Some (c,m) => Some (c, mkZmon j m) - end - | PX P i Q => - if Peq Q P0 then - match mon_of_pol P with - | None => None - | Some (c,m) => Some (c, mkVmon i m) - end - else None - end. - - Fixpoint mk_monpol_list (lpe:list (PExpr * PExpr)) : list (C*Mon*Pol) := - match lpe with - | nil => nil - | (me,pe)::lpe => - match mon_of_pol (norm_subst 0 nil me) with - | None => mk_monpol_list lpe - | Some m => (m,norm_subst 0 nil pe):: mk_monpol_list lpe - end - end. - - Lemma mon_of_pol_ok : forall P m, mon_of_pol P = Some m -> - forall l, [fst m] * Mphi l (snd m) == P@l. - Proof. - intros P; induction P as [c|p P IHP|P2 IHP1 ? P3 ?];simpl;intros m H l;Esimpl. - - assert (H1 := (morph_eq CRmorph) c cO). - destruct (c ?=! cO). - + discriminate. - + inversion H;trivial;Esimpl. - - generalize H;clear H;case_eq (mon_of_pol P). - + intros (c1,P2) H0 H1; inversion H1; Esimpl. - generalize (IHP (c1, P2) H0 (jump p l)). - rewrite mkZmon_ok;simpl;auto. - + intros; discriminate. - - generalize H;clear H;change match P3 with - | Pc c => c ?=! cO - | Pinj _ _ => false - | PX _ _ _ => false - end with (P3 ?== P0). - assert (H := Peq_ok P3 P0). - destruct (P3 ?== P0). - + case_eq (mon_of_pol P2);try intros (cc, pp); intros H0 H1. - * inversion H1. - simpl. - rewrite mkVmon_ok;simpl. - rewrite H;trivial;Esimpl. - generalize (IHP1 _ H0); simpl; intros HH; rewrite HH; rsimpl. - * discriminate. - + intros;discriminate. - Qed. - - Lemma interp_PElist_ok : forall l lpe, - interp_PElist l lpe -> MPcond (mk_monpol_list lpe) l. - Proof. - intros l lpe; induction lpe as [|a lpe IHlpe];simpl. - - trivial. - - destruct a as [p p0];simpl;intros H. - assert (HH:=mon_of_pol_ok (norm_subst 0 nil p)); - destruct (mon_of_pol (norm_subst 0 nil p)). - + split. - * rewrite <- norm_subst_spec by exact I. - destruct lpe;try destruct H as [H H0];rewrite <- H; - rewrite (norm_subst_spec 0 nil); try exact I;apply HH;trivial. - * apply IHlpe. destruct lpe;simpl;trivial. destruct H as [H H0]. exact H0. - + apply IHlpe. destruct lpe;simpl;trivial. destruct H as [H H0]. exact H0. - Qed. - - Lemma norm_subst_ok : forall n l lpe pe, - interp_PElist l lpe -> - PEeval l pe == (norm_subst n (mk_monpol_list lpe) pe)@l. - Proof. - intros;apply norm_subst_spec. apply interp_PElist_ok;trivial. - Qed. - - Lemma ring_correct : forall n l lpe pe1 pe2, - interp_PElist l lpe -> - (let lmp := mk_monpol_list lpe in - norm_subst n lmp pe1 ?== norm_subst n lmp pe2) = true -> - PEeval l pe1 == PEeval l pe2. - Proof. - simpl;intros n l lpe pe1 pe2 **. - do 2 (rewrite (norm_subst_ok n l lpe);trivial). - apply Peq_ok;trivial. - Qed. - - - - (** Generic evaluation of polynomial towards R avoiding parenthesis *) - Variable get_sign : C -> option C. - Variable get_sign_spec : sign_theory copp ceqb get_sign. - - - Section EVALUATION. - - (* [mkpow x p] = x^p *) - Variable mkpow : R -> positive -> R. - (* [mkpow x p] = -(x^p) *) - Variable mkopp_pow : R -> positive -> R. - (* [mkmult_pow r x p] = r * x^p *) - Variable mkmult_pow : R -> R -> positive -> R. - - Fixpoint mkmult_rec (r:R) (lm:list (R*positive)) {struct lm}: R := - match lm with - | nil => r - | cons (x,p) t => mkmult_rec (mkmult_pow r x p) t - end. - - Definition mkmult1 lm := - match lm with - | nil => 1 - | cons (x,p) t => mkmult_rec (mkpow x p) t - end. - - Definition mkmultm1 lm := - match lm with - | nil => ropp rI - | cons (x,p) t => mkmult_rec (mkopp_pow x p) t - end. - - Definition mkmult_c_pos c lm := - if c ?=! cI then mkmult1 (rev' lm) - else mkmult_rec [c] (rev' lm). - - Definition mkmult_c c lm := - match get_sign c with - | None => mkmult_c_pos c lm - | Some c' => - if c' ?=! cI then mkmultm1 (rev' lm) - else mkmult_rec [c] (rev' lm) - end. - - Definition mkadd_mult rP c lm := - match get_sign c with - | None => rP + mkmult_c_pos c lm - | Some c' => rP - mkmult_c_pos c' lm - end. - - Definition add_pow_list (r:R) n l := - match n with - | N0 => l - | Npos p => (r,p)::l - end. - - Fixpoint add_mult_dev - (rP:R) (P:Pol) (fv:list R) (n:N) (lm:list (R*positive)) {struct P} : R := - match P with - | Pc c => - let lm := add_pow_list (hd fv) n lm in - mkadd_mult rP c lm - | Pinj j Q => - add_mult_dev rP Q (jump j fv) N0 (add_pow_list (hd fv) n lm) - | PX P i Q => - let rP := add_mult_dev rP P fv (N.add (Npos i) n) lm in - if Q ?== P0 then rP - else add_mult_dev rP Q (tail fv) N0 (add_pow_list (hd fv) n lm) - end. - - Fixpoint mult_dev (P:Pol) (fv : list R) (n:N) - (lm:list (R*positive)) {struct P} : R := - (* P@l * (hd 0 l)^n * lm *) - match P with - | Pc c => mkmult_c c (add_pow_list (hd fv) n lm) - | Pinj j Q => mult_dev Q (jump j fv) N0 (add_pow_list (hd fv) n lm) - | PX P i Q => - let rP := mult_dev P fv (N.add (Npos i) n) lm in - if Q ?== P0 then rP - else - let lmq := add_pow_list (hd fv) n lm in - add_mult_dev rP Q (tail fv) N0 lmq - end. - - Definition Pphi_avoid fv P := mult_dev P fv N0 nil. - - Fixpoint r_list_pow (l:list (R*positive)) : R := - match l with - | nil => rI - | cons (r,p) l => pow_pos rmul r p * r_list_pow l - end. - - Hypothesis mkpow_spec : forall r p, mkpow r p == pow_pos rmul r p. - Hypothesis mkopp_pow_spec : forall r p, mkopp_pow r p == - (pow_pos rmul r p). - Hypothesis mkmult_pow_spec : forall r x p, mkmult_pow r x p == r * pow_pos rmul x p. - - Lemma mkmult_rec_ok : forall lm r, mkmult_rec r lm == r * r_list_pow lm. - Proof. - intros lm; induction lm as [|a lm IHlm];intros;simpl;Esimpl. - destruct a as (x,p);Esimpl. - rewrite IHlm. rewrite mkmult_pow_spec. Esimpl. - Qed. - - Lemma mkmult1_ok : forall lm, mkmult1 lm == r_list_pow lm. - Proof. - intros lm; destruct lm as [|p lm];simpl;Esimpl. - destruct p. rewrite mkmult_rec_ok;rewrite mkpow_spec;Esimpl. - Qed. - - Lemma mkmultm1_ok : forall lm, mkmultm1 lm == - r_list_pow lm. - Proof. - intros lm; destruct lm as [|p lm];simpl;Esimpl. - destruct p;rewrite mkmult_rec_ok. rewrite mkopp_pow_spec;Esimpl. - Qed. - - Lemma r_list_pow_rev : forall l, r_list_pow (rev' l) == r_list_pow l. - Proof. - assert - (forall l lr : list (R * positive), r_list_pow (rev_append l lr) == r_list_pow lr * r_list_pow l) as H. - - intros l; induction l as [|a l IHl];intros;simpl;Esimpl. - destruct a as [r p];rewrite IHl;Esimpl. - rewrite (ARmul_comm ARth (pow_pos rmul r p)). reflexivity. - - intros;unfold rev'. rewrite H;simpl;Esimpl. - Qed. - - Lemma mkmult_c_pos_ok : forall c lm, mkmult_c_pos c lm == [c]* r_list_pow lm. - Proof. - intros c lm;unfold mkmult_c_pos;simpl. - assert (H := (morph_eq CRmorph) c cI). - rewrite <- r_list_pow_rev; destruct (c ?=! cI). - - rewrite H;trivial;Esimpl. - apply mkmult1_ok. - - apply mkmult_rec_ok. - Qed. - - Lemma mkmult_c_ok : forall c lm, mkmult_c c lm == [c] * r_list_pow lm. - Proof. - intros c lm;unfold mkmult_c;simpl. - case_eq (get_sign c);intros c0; try intros H. - - assert (H1 := (morph_eq CRmorph) c0 cI). - destruct (c0 ?=! cI). - + rewrite (morph_eq CRmorph _ _ (sign_spec get_sign_spec _ H)). Esimpl. rewrite H1;trivial. - rewrite <- r_list_pow_rev;trivial;Esimpl. - apply mkmultm1_ok. - + rewrite <- r_list_pow_rev; apply mkmult_rec_ok. - - apply mkmult_c_pos_ok. - Qed. - - Lemma mkadd_mult_ok : forall rP c lm, mkadd_mult rP c lm == rP + [c]*r_list_pow lm. - Proof. - intros rP c lm;unfold mkadd_mult. - case_eq (get_sign c);intros c0; try intros H. - - rewrite (morph_eq CRmorph _ _ (sign_spec get_sign_spec _ H));Esimpl. - rewrite mkmult_c_pos_ok;Esimpl. - - rewrite mkmult_c_pos_ok;Esimpl. - Qed. - - Lemma add_pow_list_ok : - forall r n l, r_list_pow (add_pow_list r n l) == pow_N rI rmul r n * r_list_pow l. - Proof. - intros r n; destruct n;simpl;intros;Esimpl. - Qed. - - Lemma add_mult_dev_ok : forall P rP fv n lm, - add_mult_dev rP P fv n lm == rP + P@fv*pow_N rI rmul (hd fv) n * r_list_pow lm. - Proof. - intros P; induction P as [|p P IHP|P2 IHP1 p P3 IHP2];simpl;intros rP fv n lm. - - rewrite mkadd_mult_ok. rewrite add_pow_list_ok; Esimpl. - - rewrite IHP. simpl. rewrite add_pow_list_ok; Esimpl. - - change (match P3 with - | Pc c => c ?=! cO - | Pinj _ _ => false - | PX _ _ _ => false - end) with (Peq P3 P0). - change match n with - | N0 => Npos p - | Npos q => Npos (p + q) - end with (N.add (Npos p) n);trivial. - assert (H := Peq_ok P3 P0). - destruct (P3 ?== P0). - + rewrite (H eq_refl). - rewrite IHP1. destruct n;simpl;Esimpl;rewrite pow_pos_add;Esimpl. - add_permut. mul_permut. - + rewrite IHP2. - rewrite IHP1. destruct n;simpl;Esimpl;rewrite pow_pos_add;Esimpl. - add_permut. mul_permut. - Qed. - - Lemma mult_dev_ok : forall P fv n lm, - mult_dev P fv n lm == P@fv * pow_N rI rmul (hd fv) n * r_list_pow lm. - Proof. - intros P; induction P as [|p P IHP|P2 IHP1 p P3 IHP2];simpl;intros fv n lm;Esimpl. - - rewrite mkmult_c_ok;rewrite add_pow_list_ok;Esimpl. - - rewrite IHP. simpl;rewrite add_pow_list_ok;Esimpl. - - change (match P3 with - | Pc c => c ?=! cO - | Pinj _ _ => false - | PX _ _ _ => false - end) with (Peq P3 P0). - change match n with - | N0 => Npos p - | Npos q => Npos (p + q) - end with (N.add (Npos p) n);trivial. - assert (H := Peq_ok P3 P0). - destruct (P3 ?== P0). - + rewrite (H eq_refl). - rewrite IHP1. destruct n;simpl;Esimpl;rewrite pow_pos_add;Esimpl. - mul_permut. - + rewrite add_mult_dev_ok. rewrite IHP1; rewrite add_pow_list_ok. - destruct n;simpl;Esimpl;rewrite pow_pos_add;Esimpl. - add_permut; mul_permut. - Qed. - - Lemma Pphi_avoid_ok : forall P fv, Pphi_avoid fv P == P@fv. - Proof. - unfold Pphi_avoid;intros;rewrite mult_dev_ok;simpl;Esimpl. - Qed. - - End EVALUATION. - - Definition Pphi_pow := - let mkpow x p := - match p with xH => x | _ => rpow x (Cp_phi (Npos p)) end in - let mkopp_pow x p := ropp (mkpow x p) in - let mkmult_pow r x p := rmul r (mkpow x p) in - Pphi_avoid mkpow mkopp_pow mkmult_pow. - - Lemma local_mkpow_ok r p : - match p with - | xI _ => rpow r (Cp_phi (Npos p)) - | xO _ => rpow r (Cp_phi (Npos p)) - | 1 => r - end == pow_pos rmul r p. - Proof. destruct p; now rewrite ?(rpow_pow_N pow_th). Qed. - - Lemma Pphi_pow_ok : forall P fv, Pphi_pow fv P == P@fv. - Proof. - unfold Pphi_pow;intros;apply Pphi_avoid_ok;intros; - now rewrite ?local_mkpow_ok. - Qed. - - Lemma ring_rw_pow_correct : forall n lH l, - interp_PElist l lH -> - forall lmp, mk_monpol_list lH = lmp -> - forall pe npe, norm_subst n lmp pe = npe -> - PEeval l pe == Pphi_pow l npe. - Proof. - intros n lH l H1 lmp Heq1 pe npe Heq2. - rewrite Pphi_pow_ok, <- Heq2, <- Heq1. - apply norm_subst_ok. trivial. - Qed. - - Fixpoint mkmult_pow (r x:R) (p: positive) {struct p} : R := - match p with - | xH => r*x - | xO p => mkmult_pow (mkmult_pow r x p) x p - | xI p => mkmult_pow (mkmult_pow (r*x) x p) x p - end. - - Definition mkpow x p := - match p with - | xH => x - | xO p => mkmult_pow x x (Pos.pred_double p) - | xI p => mkmult_pow x x (xO p) - end. - - Definition mkopp_pow x p := - match p with - | xH => -x - | xO p => mkmult_pow (-x) x (Pos.pred_double p) - | xI p => mkmult_pow (-x) x (xO p) - end. - - Definition Pphi_dev := Pphi_avoid mkpow mkopp_pow mkmult_pow. - - Lemma mkmult_pow_ok p r x : mkmult_pow r x p == r * x^p. - Proof. - revert r; induction p as [p IHp|p IHp|];intros;simpl;Esimpl;rewrite !IHp;Esimpl. - Qed. - - Lemma mkpow_ok p x : mkpow x p == x^p. - Proof. - destruct p;simpl;intros;Esimpl. - - rewrite !mkmult_pow_ok;Esimpl. - - rewrite mkmult_pow_ok;Esimpl. - change x with (x^1) at 1. - now rewrite <- pow_pos_add, Pos.add_1_r, Pos.succ_pred_double. - Qed. - - Lemma mkopp_pow_ok p x : mkopp_pow x p == - x^p. - Proof. - destruct p;simpl;intros;Esimpl. - - rewrite !mkmult_pow_ok;Esimpl. - - rewrite mkmult_pow_ok;Esimpl. - change x with (x^1) at 1. - now rewrite <- pow_pos_add, Pos.add_1_r, Pos.succ_pred_double. - Qed. - - Lemma Pphi_dev_ok : forall P fv, Pphi_dev fv P == P@fv. - Proof. - unfold Pphi_dev;intros;apply Pphi_avoid_ok. - - intros;apply mkpow_ok. - - intros;apply mkopp_pow_ok. - - intros;apply mkmult_pow_ok. - Qed. - - Lemma ring_rw_correct : forall n lH l, - interp_PElist l lH -> - forall lmp, mk_monpol_list lH = lmp -> - forall pe npe, norm_subst n lmp pe = npe -> - PEeval l pe == Pphi_dev l npe. - Proof. - intros n lH l H1 lmp Heq1 pe npe Heq2. - rewrite Pphi_dev_ok. rewrite <- Heq2;rewrite <- Heq1. - apply norm_subst_ok. trivial. - Qed. - -End MakeRingPol. - -Arguments PEO {C}. -Arguments PEI {C}. diff --git a/stdlib/theories/setoid_ring/Ring_tac.v b/stdlib/theories/setoid_ring/Ring_tac.v deleted file mode 100644 index 577cf7e72df4..000000000000 --- a/stdlib/theories/setoid_ring/Ring_tac.v +++ /dev/null @@ -1,470 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* _ => R - | _ => fail 1000 "Equality has no relation type" - end. - -Ltac Get_goal := match goal with [|- ?G] => G end. - -(********************************************************************) -(* Tacticals to build reflexive tactics *) - -Ltac OnEquation req := - match goal with - | |- req ?lhs ?rhs => (fun f => f lhs rhs) - | _ => (fun _ => fail "Goal is not an equation (of expected equality)" req) - end. - -Ltac OnEquationHyp req h := - match type of h with - | req ?lhs ?rhs => fun f => f lhs rhs - | _ => (fun _ => fail "Hypothesis is not an equation (of expected equality)") - end. - -(* Note: auxiliary subgoals in reverse order *) -Ltac OnMainSubgoal H ty := - match ty with - | _ -> ?ty' => - let subtac := OnMainSubgoal H ty' in - fun kont => lapply H; [clear H; intro H; subtac kont | idtac] - | _ => (fun kont => kont()) - end. - -(* A generic pattern to have reflexive tactics do some computation: - lemmas of the form [forall x', x=x' -> P(x')] are understood as: - compute the normal form of x, instantiate x' with it, prove - hypothesis x=x' with vm_compute and reflexivity, and pass the - instantiated lemma to the continuation. - *) -Ltac ProveLemmaHyp lemma := - match type of lemma with - forall x', ?x = x' -> _ => - (fun kont => - let x' := fresh "res" in - let H := fresh "res_eq" in - compute_assertion H x' x; - let lemma' := constr:(lemma x' H) in - kont lemma'; - (clear H||idtac"ProveLemmaHyp: cleanup failed"); - subst x') - | _ => (fun _ => fail "ProveLemmaHyp: lemma not of the expected form") - end. - -Ltac ProveLemmaHyps lemma := - match type of lemma with - forall x', ?x = x' -> _ => - (fun kont => - let x' := fresh "res" in - let H := fresh "res_eq" in - compute_assertion H x' x; - let lemma' := constr:(lemma x' H) in - ProveLemmaHyps lemma' kont; - (clear H||idtac"ProveLemmaHyps: cleanup failed"); - subst x') - | _ => (fun kont => kont lemma) - end. - -(* -Ltac ProveLemmaHyps lemma := (* expects a continuation *) - let try_step := ProveLemmaHyp lemma in - (fun kont => - try_step ltac:(fun lemma' => ProveLemmaHyps lemma' kont) || - kont lemma). -*) -Ltac ApplyLemmaThen lemma expr kont := - let lem := constr:(lemma expr) in - ProveLemmaHyp lem ltac:(fun lem' => - let Heq := fresh "thm" in - assert (Heq:=lem'); - OnMainSubgoal Heq ltac:(type of Heq) ltac:(fun _ => kont Heq); - (clear Heq||idtac"ApplyLemmaThen: cleanup failed")). -(* -Ltac ApplyLemmaThenAndCont lemma expr tac CONT_tac cont_arg := - let pe := - match type of (lemma expr) with - forall pe', ?pe = pe' -> _ => pe - | _ => fail 1 "ApplyLemmaThenAndCont: cannot find norm expression" - end in - let pe' := fresh "expr_nf" in - let nf_pe := fresh "pe_eq" in - compute_assertion nf_pe pe' pe; - let Heq := fresh "thm" in - (assert (Heq:=lemma pe pe' H) || fail "anomaly: failed to apply lemma"); - clear nf_pe; - OnMainSubgoal Heq ltac:(type of Heq) - ltac:(try tac Heq; clear Heq pe';CONT_tac cont_arg)). -*) -Ltac ApplyLemmaThenAndCont lemma expr tac CONT_tac := - ApplyLemmaThen lemma expr - ltac:(fun lemma' => try tac lemma'; CONT_tac()). - -(* General scheme of reflexive tactics using of correctness lemma - that involves normalisation of one expression - - [FV_tac term fv] is a tactic that adds the atomic expressions - of [term] into [fv] - - [SYN_tac term fv] reifies [term] given the list of atomic expressions - - [LEMMA_tac fv kont] computes the correctness lemma and passes it to - continuation kont - - [MAIN_tac H] process H which is the conclusion of the correctness lemma - instantiated with each reified term - - [fv] is the initial value of atomic expressions (to be completed by - the reification of the terms - - [terms] the list (a constr of type list) of terms to reify and process. - *) -Ltac ReflexiveRewriteTactic - FV_tac SYN_tac LEMMA_tac MAIN_tac fv terms := - (* extend the atom list *) - let fv := list_fold_left FV_tac fv terms in - let RW_tac lemma := - let fcons term CONT_tac := - let expr := SYN_tac term fv in - let main H := - match type of H with - | (?req _ ?rhs) => change (req term rhs) in H - end; - MAIN_tac H in - (ApplyLemmaThenAndCont lemma expr main CONT_tac) in - (* rewrite steps *) - lazy_list_fold_right fcons ltac:(fun _=>idtac) terms in - LEMMA_tac fv RW_tac. - -(********************************************************) - -Ltac FV_hypo_tac mkFV req lH := - let R := relation_carrier req in - let FV_hypo_l_tac h := - match h with @mkhypo (req ?pe _) _ => mkFV pe end in - let FV_hypo_r_tac h := - match h with @mkhypo (req _ ?pe) _ => mkFV pe end in - let fv := list_fold_right FV_hypo_l_tac (@nil R) lH in - list_fold_right FV_hypo_r_tac fv lH. - -Ltac mkHyp_tac C req Reify lH := - let mkHyp h res := - match h with - | @mkhypo (req ?r1 ?r2) _ => - let pe1 := Reify r1 in - let pe2 := Reify r2 in - constr:(cons (pe1,pe2) res) - | _ => fail 1 "hypothesis is not a ring equality" - end in - list_fold_right mkHyp (@nil (PExpr C * PExpr C)) lH. - -Ltac proofHyp_tac lH := - let get_proof h := - match h with - | @mkhypo _ ?p => p - end in - let rec bh l := - match l with - | nil => constr:(I) - | cons ?h nil => get_proof h - | cons ?h ?tl => - let l := get_proof h in - let r := bh tl in - constr:(conj l r) - end in - bh lH. - -Ltac get_MonPol lemma := - match type of lemma with - | context [(mk_monpol_list ?cO ?cI ?cadd ?cmul ?csub ?copp ?cdiv ?ceqb _)] => - constr:(mk_monpol_list cO cI cadd cmul csub copp cdiv ceqb) - | _ => fail 1 "ring/field anomaly: bad correctness lemma (get_MonPol)" - end. - -(********************************************************) - -(* Building the atom list of a ring expression *) -(* We do not assume that Cst recognizes the rO and rI terms as constants, as *) -(* the tactic could be used to discriminate occurrences of an opaque *) -(* constant phi, with (phi 0) not convertible to 0 for instance *) -Ltac FV Cst CstPow rO rI add mul sub opp pow t fv := - let rec TFV t fv := - let f := - match Cst t with - | NotConstant => - match t with - | rO => fun _ => fv - | rI => fun _ => fv - | (add ?t1 ?t2) => fun _ => TFV t2 ltac:(TFV t1 fv) - | (mul ?t1 ?t2) => fun _ => TFV t2 ltac:(TFV t1 fv) - | (sub ?t1 ?t2) => fun _ => TFV t2 ltac:(TFV t1 fv) - | (opp ?t1) => fun _ => TFV t1 fv - | (pow ?t1 ?n) => - match CstPow n with - | InitialRing.NotConstant => fun _ => AddFvTail t fv - | _ => fun _ => TFV t1 fv - end - | _ => fun _ => AddFvTail t fv - end - | _ => fun _ => fv - end in - f() - in TFV t fv. - - (* syntaxification of ring expressions *) - (* We do not assume that Cst recognizes the rO and rI terms as constants, as *) - (* the tactic could be used to discriminate occurrences of an opaque *) - (* constant phi, with (phi 0) not convertible to 0 for instance *) -Ltac mkPolexpr C Cst CstPow rO rI radd rmul rsub ropp rpow t fv := - let rec mkP t := - let f := - match Cst t with - | InitialRing.NotConstant => - match t with - | rO => - fun _ => constr:(@PEO C) - | rI => - fun _ => constr:(@PEI C) - | (radd ?t1 ?t2) => - fun _ => - let e1 := mkP t1 in - let e2 := mkP t2 in constr:(@PEadd C e1 e2) - | (rmul ?t1 ?t2) => - fun _ => - let e1 := mkP t1 in - let e2 := mkP t2 in constr:(@PEmul C e1 e2) - | (rsub ?t1 ?t2) => - fun _ => - let e1 := mkP t1 in - let e2 := mkP t2 in constr:(@PEsub C e1 e2) - | (ropp ?t1) => - fun _ => - let e1 := mkP t1 in constr:(@PEopp C e1) - | (rpow ?t1 ?n) => - match CstPow n with - | InitialRing.NotConstant => - fun _ => let p := Find_at t fv in constr:(PEX C p) - | ?c => fun _ => let e1 := mkP t1 in constr:(@PEpow C e1 c) - end - | _ => - fun _ => let p := Find_at t fv in constr:(PEX C p) - end - | ?c => fun _ => constr:(@PEc C c) - end in - f () - in mkP t. - -(* packaging the ring structure *) - -Ltac PackRing F req sth ext morph arth cst_tac pow_tac lemma1 lemma2 pre post := - let RNG := - match type of lemma1 with - | context - [@PEeval ?R ?r0 ?r1 ?add ?mul ?sub ?opp ?C ?phi ?Cpow ?powphi ?pow _ _] => - (fun proj => proj - cst_tac pow_tac pre post - R req r0 r1 add mul sub opp C Cpow powphi pow lemma1 lemma2) - | _ => fail 1 "field anomaly: bad correctness lemma (parse)" - end in - F RNG. - -Ltac get_Carrier RNG := - RNG ltac:(fun cst_tac pow_tac pre post - R req r0 r1 add mul sub opp C Cpow powphi pow lemma1 lemma2 => - R). - -Ltac get_Eq RNG := - RNG ltac:(fun cst_tac pow_tac pre post - R req r0 r1 add mul sub opp C Cpow powphi pow lemma1 lemma2 => - req). - -Ltac get_Pre RNG := - RNG ltac:(fun cst_tac pow_tac pre post - R req r0 r1 add mul sub opp C Cpow powphi pow lemma1 lemma2 => - pre). - -Ltac get_Post RNG := - RNG ltac:(fun cst_tac pow_tac pre post - R req r0 r1 add mul sub opp C Cpow powphi pow lemma1 lemma2 => - post). - -Ltac get_NormLemma RNG := - RNG ltac:(fun cst_tac pow_tac pre post - R req r0 r1 add mul sub opp C Cpow powphi pow lemma1 lemma2 => - lemma1). - -Ltac get_SimplifyLemma RNG := - RNG ltac:(fun cst_tac pow_tac pre post - R req r0 r1 add mul sub opp C Cpow powphi pow lemma1 lemma2 => - lemma2). - -Ltac get_RingFV RNG := - RNG ltac:(fun cst_tac pow_tac pre post - R req r0 r1 add mul sub opp C Cpow powphi pow lemma1 lemma2 => - FV cst_tac pow_tac r0 r1 add mul sub opp pow). - -Ltac get_RingMeta RNG := - RNG ltac:(fun cst_tac pow_tac pre post - R req r0 r1 add mul sub opp C Cpow powphi pow lemma1 lemma2 => - mkPolexpr C cst_tac pow_tac r0 r1 add mul sub opp pow). - -Ltac get_RingHypTac RNG := - RNG ltac:(fun cst_tac pow_tac pre post - R req r0 r1 add mul sub opp C Cpow powphi pow lemma1 lemma2 => - let mkPol := mkPolexpr C cst_tac pow_tac r0 r1 add mul sub opp pow in - fun fv lH => mkHyp_tac C req ltac:(fun t => mkPol t fv) lH). - -(* ring tactics *) - -Definition ring_subst_niter := (10*10*10)%nat. - -Ltac Ring RNG lemma lH := - let req := get_Eq RNG in - OnEquation req ltac:(fun lhs rhs => - let mkFV := get_RingFV RNG in - let mkPol := get_RingMeta RNG in - let mkHyp := get_RingHypTac RNG in - let fv := FV_hypo_tac mkFV ltac:(get_Eq RNG) lH in - let fv := mkFV lhs fv in - let fv := mkFV rhs fv in - check_fv fv; - let pe1 := mkPol lhs fv in - let pe2 := mkPol rhs fv in - let lpe := mkHyp fv lH in - let vlpe := fresh "hyp_list" in - let vfv := fresh "fv_list" in - pose (vlpe := lpe); - pose (vfv := fv); - (apply (lemma vfv vlpe pe1 pe2) - || fail "typing error while applying ring"); - [ ((let prh := proofHyp_tac lH in exact prh) - || idtac "can not automatically prove hypothesis :"; - [> idtac " maybe a left member of a hypothesis is not a monomial"..]) - | vm_compute; - (exact (eq_refl true) || fail "not a valid ring equation")]). - -Ltac Ring_norm_gen f RNG lemma lH rl := - let mkFV := get_RingFV RNG in - let mkPol := get_RingMeta RNG in - let mkHyp := get_RingHypTac RNG in - let mk_monpol := get_MonPol lemma in - let fv := FV_hypo_tac mkFV ltac:(get_Eq RNG) lH in - let lemma_tac fv kont := - let lpe := mkHyp fv lH in - let vlpe := fresh "list_hyp" in - let vlmp := fresh "list_hyp_norm" in - let vlmp_eq := fresh "list_hyp_norm_eq" in - let prh := proofHyp_tac lH in - pose (vlpe := lpe); - compute_assertion vlmp_eq vlmp (mk_monpol vlpe); - let H := fresh "ring_lemma" in - (assert (H := lemma vlpe fv prh vlmp vlmp_eq) - || fail "type error when build the rewriting lemma"); - clear vlmp_eq; - kont H; - (clear H||idtac"Ring_norm_gen: cleanup failed"); - subst vlpe vlmp in - let simpl_ring H := (protect_fv "ring" in H; f H) in - ReflexiveRewriteTactic mkFV mkPol lemma_tac simpl_ring fv rl. - -Ltac Ring_gen RNG lH rl := - let lemma := get_NormLemma RNG in - get_Pre RNG (); - Ring RNG (lemma ring_subst_niter) lH. - -Tactic Notation (at level 0) "ring" := - let G := Get_goal in - ring_lookup (PackRing Ring_gen) [] G. - -Tactic Notation (at level 0) "ring" "[" constr_list(lH) "]" := - let G := Get_goal in - ring_lookup (PackRing Ring_gen) [lH] G. - -(* Simplification *) -(* This code is duplicated in Field_tac. Any correction to this code should *) -(* be ported there too. *) - -Ltac Ring_simplify_gen f RNG lH rl := - let lemma := get_SimplifyLemma RNG in - let l := fresh "to_rewrite" in - pose (l:= rl); - generalize (eq_refl l); - unfold l at 2; - get_Pre RNG (); - let rl := - match goal with - | [|- l = ?RL -> _ ] => RL - | _ => fail 1 "ring_simplify anomaly: bad goal after pre" - end in - let Heq := fresh "Heq" in - intros Heq;clear Heq l; - Ring_norm_gen f RNG (lemma ring_subst_niter) lH rl; - get_Post RNG (). - -Ltac Ring_simplify := Ring_simplify_gen ltac:(fun H => rewrite H). - -Tactic Notation (at level 0) "ring_simplify" constr_list(rl) := - let G := Get_goal in - ring_lookup (PackRing Ring_simplify) [] rl G. - -Tactic Notation (at level 0) - "ring_simplify" "[" constr_list(lH) "]" constr_list(rl) := - let G := Get_goal in - ring_lookup (PackRing Ring_simplify) [lH] rl G. - -Tactic Notation "ring_simplify" constr_list(rl) "in" hyp(H):= - let G := Get_goal in - let t := type of H in - let g := fresh "goal" in - set (g:= G); - generalize H; - ring_lookup (PackRing Ring_simplify) [] rl t; - (* - Correction of bug 1859: - we want to leave H at its initial position - this is obtained by adding a copy of H (H'), - move it just after H, remove H and finally - rename H into H' - *) - let H' := fresh "H" in - intro H'; - move H' after H; - clear H;rename H' into H; - unfold g;clear g. - -Tactic Notation "ring_simplify" "["constr_list(lH)"]" constr_list(rl) "in" hyp(H):= - let G := Get_goal in - let t := type of H in - let g := fresh "goal" in - set (g:= G); - generalize H; - ring_lookup (PackRing Ring_simplify) [lH] rl t; - (* - Correction of bug 1859: - we want to leave H at its initial position - this is obtained by adding a copy of H (H'), - move it just after H, remove H and finally - rename H into H' - *) - let H' := fresh "H" in - intro H'; - move H' after H; - clear H;rename H' into H; - unfold g;clear g. diff --git a/stdlib/theories/setoid_ring/Ring_theory.v b/stdlib/theories/setoid_ring/Ring_theory.v deleted file mode 100644 index 9ca9341a7e1e..000000000000 --- a/stdlib/theories/setoid_ring/Ring_theory.v +++ /dev/null @@ -1,619 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* R -> R. - Variable req : R -> R -> Prop. - Variable Rsth : Equivalence req. - Infix "*" := rmul. - Infix "==" := req. - - Hypothesis mul_ext : Proper (req ==> req ==> req) rmul. - Hypothesis mul_assoc : forall x y z, x * (y * z) == (x * y) * z. - - Fixpoint pow_pos (x:R) (i:positive) : R := - match i with - | xH => x - | xO i => let p := pow_pos x i in p * p - | xI i => let p := pow_pos x i in x * (p * p) - end. - - Lemma pow_pos_swap x j : pow_pos x j * x == x * pow_pos x j. - Proof. - induction j as [j IHj|j IHj|]; simpl; rewrite <- ?mul_assoc. - - f_equiv. now do 2 (rewrite IHj, mul_assoc). - - now do 2 (rewrite IHj, mul_assoc). - - reflexivity. - Qed. - - Lemma pow_pos_succ x j : - pow_pos x (Pos.succ j) == x * pow_pos x j. - Proof. - induction j as [j IHj|j IHj|]; simpl; try reflexivity. - rewrite IHj, <- mul_assoc; f_equiv. - now rewrite mul_assoc, pow_pos_swap, mul_assoc. - Qed. - - Lemma pow_pos_add x i j : - pow_pos x (i + j) == pow_pos x i * pow_pos x j. - Proof. - induction i as [|i IHi] using Pos.peano_ind. - - now rewrite Pos.add_1_l, pow_pos_succ. - - now rewrite Pos.add_succ_l, !pow_pos_succ, IHi, mul_assoc. - Qed. - - Definition pow_N (x:R) (p:N) := - match p with - | N0 => rI - | Npos p => pow_pos x p - end. - - Definition id_phi_N (x:N) : N := x. - - Lemma pow_N_pow_N x n : pow_N x (id_phi_N n) == pow_N x n. - Proof. - reflexivity. - Qed. - -End Power. - -Section DEFINITIONS. - Variable R : Type. - Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R). - Variable req : R -> R -> Prop. - Notation "0" := rO. Notation "1" := rI. - Infix "==" := req. Infix "+" := radd. Infix "*" := rmul. - Infix "-" := rsub. Notation "- x" := (ropp x). - - (** Semi Ring *) - Record semi_ring_theory : Prop := mk_srt { - SRadd_0_l : forall n, 0 + n == n; - SRadd_comm : forall n m, n + m == m + n ; - SRadd_assoc : forall n m p, n + (m + p) == (n + m) + p; - SRmul_1_l : forall n, 1*n == n; - SRmul_0_l : forall n, 0*n == 0; - SRmul_comm : forall n m, n*m == m*n; - SRmul_assoc : forall n m p, n*(m*p) == (n*m)*p; - SRdistr_l : forall n m p, (n + m)*p == n*p + m*p - }. - - (** Almost Ring *) -(*Almost ring are no ring : Ropp_def is missing **) - Record almost_ring_theory : Prop := mk_art { - ARadd_0_l : forall x, 0 + x == x; - ARadd_comm : forall x y, x + y == y + x; - ARadd_assoc : forall x y z, x + (y + z) == (x + y) + z; - ARmul_1_l : forall x, 1 * x == x; - ARmul_0_l : forall x, 0 * x == 0; - ARmul_comm : forall x y, x * y == y * x; - ARmul_assoc : forall x y z, x * (y * z) == (x * y) * z; - ARdistr_l : forall x y z, (x + y) * z == (x * z) + (y * z); - ARopp_mul_l : forall x y, -(x * y) == -x * y; - ARopp_add : forall x y, -(x + y) == -x + -y; - ARsub_def : forall x y, x - y == x + -y - }. - - (** Ring *) - Record ring_theory : Prop := mk_rt { - Radd_0_l : forall x, 0 + x == x; - Radd_comm : forall x y, x + y == y + x; - Radd_assoc : forall x y z, x + (y + z) == (x + y) + z; - Rmul_1_l : forall x, 1 * x == x; - Rmul_comm : forall x y, x * y == y * x; - Rmul_assoc : forall x y z, x * (y * z) == (x * y) * z; - Rdistr_l : forall x y z, (x + y) * z == (x * z) + (y * z); - Rsub_def : forall x y, x - y == x + -y; - Ropp_def : forall x, x + (- x) == 0 - }. - - (** Equality is extensional *) - - Record sring_eq_ext : Prop := mk_seqe { - (* SRing operators are compatible with equality *) - SRadd_ext : Proper (req ==> req ==> req) radd; - SRmul_ext : Proper (req ==> req ==> req) rmul - }. - - Record ring_eq_ext : Prop := mk_reqe { - (* Ring operators are compatible with equality *) - Radd_ext : Proper (req ==> req ==> req) radd; - Rmul_ext : Proper (req ==> req ==> req) rmul; - Ropp_ext : Proper (req ==> req) ropp - }. - - (** Interpretation morphisms definition*) - Section MORPHISM. - Variable C:Type. - Variable (cO cI : C) (cadd cmul csub : C->C->C) (copp : C->C). - Variable ceqb : C->C->bool. - (* [phi] est un morphisme de [C] dans [R] *) - Variable phi : C -> R. - Infix "+!" := cadd. Infix "-!" := csub. - Infix "*!" := cmul. Notation "-! x" := (copp x). - Infix "?=!" := ceqb. Notation "[ x ]" := (phi x). - -(*for semi rings*) - Record semi_morph : Prop := mkRmorph { - Smorph0 : [cO] == 0; - Smorph1 : [cI] == 1; - Smorph_add : forall x y, [x +! y] == [x]+[y]; - Smorph_mul : forall x y, [x *! y] == [x]*[y]; - Smorph_eq : forall x y, x?=!y = true -> [x] == [y] - }. - -(* for rings*) - Record ring_morph : Prop := mkmorph { - morph0 : [cO] == 0; - morph1 : [cI] == 1; - morph_add : forall x y, [x +! y] == [x]+[y]; - morph_sub : forall x y, [x -! y] == [x]-[y]; - morph_mul : forall x y, [x *! y] == [x]*[y]; - morph_opp : forall x, [-!x] == -[x]; - morph_eq : forall x y, x?=!y = true -> [x] == [y] - }. - - Section SIGN. - Variable get_sign : C -> option C. - Record sign_theory : Prop := mksign_th { - sign_spec : forall c c', get_sign c = Some c' -> c ?=! -! c' = true - }. - End SIGN. - - Definition get_sign_None (c:C) := @None C. - - Lemma get_sign_None_th : sign_theory get_sign_None. - Proof. constructor;intros;discriminate. Qed. - - Section DIV. - Variable cdiv: C -> C -> C*C. - Record div_theory : Prop := mkdiv_th { - div_eucl_th : forall a b, let (q,r) := cdiv a b in [a] == [b *! q +! r] - }. - End DIV. - - End MORPHISM. - - (** Identity is a morphism *) - Variable Rsth : Equivalence req. - Variable reqb : R->R->bool. - Hypothesis morph_req : forall x y, (reqb x y) = true -> x == y. - Definition IDphi (x:R) := x. - Lemma IDmorph : ring_morph rO rI radd rmul rsub ropp reqb IDphi. - Proof. - now apply (mkmorph rO rI radd rmul rsub ropp reqb IDphi). - Qed. - - (** Specification of the power function *) - Section POWER. - Variable Cpow : Type. - Variable Cp_phi : N -> Cpow. - Variable rpow : R -> Cpow -> R. - - Record power_theory : Prop := mkpow_th { - rpow_pow_N : forall r n, req (rpow r (Cp_phi n)) (pow_N rI rmul r n) - }. - - End POWER. - - Definition pow_N_th := - mkpow_th id_phi_N (pow_N rI rmul) (pow_N_pow_N rI rmul Rsth). - - -End DEFINITIONS. - -Section ALMOST_RING. - Variable R : Type. - Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R). - Variable req : R -> R -> Prop. - Notation "0" := rO. Notation "1" := rI. - Infix "==" := req. Infix "+" := radd. Infix "* " := rmul. - - (** Leibniz equality leads to a setoid theory and is extensional*) - Lemma Eqsth : Equivalence (@eq R). - Proof. exact eq_equivalence. Qed. - - Lemma Eq_s_ext : sring_eq_ext radd rmul (@eq R). - Proof. constructor;solve_proper. Qed. - - Lemma Eq_ext : ring_eq_ext radd rmul ropp (@eq R). - Proof. constructor;solve_proper. Qed. - - Variable Rsth : Equivalence req. - - Section SEMI_RING. - Variable SReqe : sring_eq_ext radd rmul req. - - Add Morphism radd with signature (req ==> req ==> req) as radd_ext1. - Proof. exact (SRadd_ext SReqe). Qed. - - Add Morphism rmul with signature (req ==> req ==> req) as rmul_ext1. - Proof. exact (SRmul_ext SReqe). Qed. - - Variable SRth : semi_ring_theory 0 1 radd rmul req. - - (** Every semi ring can be seen as an almost ring, by taking : - [-x = x] and [x - y = x + y] *) - Definition SRopp (x:R) := x. Notation "- x" := (SRopp x). - - Definition SRsub x y := x + -y. Infix "-" := SRsub. - - Lemma SRopp_ext : forall x y, x == y -> -x == -y. - Proof. intros x y H; exact H. Qed. - - Lemma SReqe_Reqe : ring_eq_ext radd rmul SRopp req. - Proof. - constructor. - - exact (SRadd_ext SReqe). - - exact (SRmul_ext SReqe). - - exact SRopp_ext. - Qed. - - Lemma SRopp_mul_l : forall x y, -(x * y) == -x * y. - Proof. reflexivity. Qed. - - Lemma SRopp_add : forall x y, -(x + y) == -x + -y. - Proof. reflexivity. Qed. - - Lemma SRsub_def : forall x y, x - y == x + -y. - Proof. reflexivity. Qed. - - Lemma SRth_ARth : almost_ring_theory 0 1 radd rmul SRsub SRopp req. - Proof (mk_art 0 1 radd rmul SRsub SRopp req - (SRadd_0_l SRth) (SRadd_comm SRth) (SRadd_assoc SRth) - (SRmul_1_l SRth) (SRmul_0_l SRth) - (SRmul_comm SRth) (SRmul_assoc SRth) (SRdistr_l SRth) - SRopp_mul_l SRopp_add SRsub_def). - - (** Identity morphism for semi-ring equipped with their almost-ring structure*) - Variable reqb : R->R->bool. - - Hypothesis morph_req : forall x y, (reqb x y) = true -> x == y. - - Definition SRIDmorph : ring_morph 0 1 radd rmul SRsub SRopp req - 0 1 radd rmul SRsub SRopp reqb (@IDphi R). - Proof. - now apply mkmorph. - Qed. - - (* a semi_morph can be extended to a ring_morph for the almost_ring derived - from a semi_ring, provided the ring is a setoid (we only need - reflexivity) *) - Variable C : Type. - Variable (cO cI : C) (cadd cmul: C->C->C). - Variable (ceqb : C -> C -> bool). - Variable phi : C -> R. - Variable Smorph : semi_morph rO rI radd rmul req cO cI cadd cmul ceqb phi. - - Lemma SRmorph_Rmorph : - ring_morph rO rI radd rmul SRsub SRopp req - cO cI cadd cmul cadd (fun x => x) ceqb phi. - Proof. - case Smorph; now constructor. - Qed. - - End SEMI_RING. - Infix "-" := rsub. - Notation "- x" := (ropp x). - - Variable Reqe : ring_eq_ext radd rmul ropp req. - - Add Morphism radd with signature (req ==> req ==> req) as radd_ext2. - Proof. exact (Radd_ext Reqe). Qed. - - Add Morphism rmul with signature (req ==> req ==> req) as rmul_ext2. - Proof. exact (Rmul_ext Reqe). Qed. - - Add Morphism ropp with signature (req ==> req) as ropp_ext2. - Proof. exact (Ropp_ext Reqe). Qed. - - Section RING. - Variable Rth : ring_theory 0 1 radd rmul rsub ropp req. - - (** Rings are almost rings*) - Lemma Rmul_0_l x : 0 * x == 0. - Proof. - setoid_replace (0*x) with ((0+1)*x + -x). - - now rewrite (Radd_0_l Rth), (Rmul_1_l Rth), (Ropp_def Rth). - - - rewrite (Rdistr_l Rth), (Rmul_1_l Rth). - rewrite <- (Radd_assoc Rth), (Ropp_def Rth). - now rewrite (Radd_comm Rth), (Radd_0_l Rth). - Qed. - - Lemma Ropp_mul_l x y : -(x * y) == -x * y. - Proof. - rewrite <-(Radd_0_l Rth (- x * y)). - rewrite (Radd_comm Rth), <-(Ropp_def Rth (x*y)). - rewrite (Radd_assoc Rth), <- (Rdistr_l Rth). - rewrite (Radd_comm Rth (-x)), (Ropp_def Rth). - now rewrite Rmul_0_l, (Radd_0_l Rth). - Qed. - - Lemma Ropp_add x y : -(x + y) == -x + -y. - Proof. - rewrite <- ((Radd_0_l Rth) (-(x+y))). - rewrite <- ((Ropp_def Rth) x). - rewrite <- ((Radd_0_l Rth) (x + - x + - (x + y))). - rewrite <- ((Ropp_def Rth) y). - rewrite ((Radd_comm Rth) x). - rewrite ((Radd_comm Rth) y). - rewrite <- ((Radd_assoc Rth) (-y)). - rewrite <- ((Radd_assoc Rth) (- x)). - rewrite ((Radd_assoc Rth) y). - rewrite ((Radd_comm Rth) y). - rewrite <- ((Radd_assoc Rth) (- x)). - rewrite ((Radd_assoc Rth) y). - rewrite ((Radd_comm Rth) y), (Ropp_def Rth). - rewrite ((Radd_comm Rth) (-x) 0), (Radd_0_l Rth). - now apply (Radd_comm Rth). - Qed. - - Lemma Ropp_opp x : - -x == x. - Proof. - rewrite <- (Radd_0_l Rth (- -x)). - rewrite <- (Ropp_def Rth x). - rewrite <- (Radd_assoc Rth), (Ropp_def Rth). - rewrite ((Radd_comm Rth) x); now apply (Radd_0_l Rth). - Qed. - - Lemma Rth_ARth : almost_ring_theory 0 1 radd rmul rsub ropp req. - Proof - (mk_art 0 1 radd rmul rsub ropp req (Radd_0_l Rth) (Radd_comm Rth) (Radd_assoc Rth) - (Rmul_1_l Rth) Rmul_0_l (Rmul_comm Rth) (Rmul_assoc Rth) (Rdistr_l Rth) - Ropp_mul_l Ropp_add (Rsub_def Rth)). - - (** Every semi morphism between two rings is a morphism*) - Variable C : Type. - Variable (cO cI : C) (cadd cmul csub: C->C->C) (copp : C -> C). - Variable (ceq : C -> C -> Prop) (ceqb : C -> C -> bool). - Variable phi : C -> R. - Infix "+!" := cadd. Infix "*!" := cmul. - Infix "-!" := csub. Notation "-! x" := (copp x). - Notation "?=!" := ceqb. Notation "[ x ]" := (phi x). - Variable Csth : Equivalence ceq. - Variable Ceqe : ring_eq_ext cadd cmul copp ceq. - - Add Parametric Relation : C ceq - reflexivity proved by (@Equivalence_Reflexive _ _ Csth) - symmetry proved by (@Equivalence_Symmetric _ _ Csth) - transitivity proved by (@Equivalence_Transitive _ _ Csth) - as C_setoid. - - Add Morphism cadd with signature (ceq ==> ceq ==> ceq) as cadd_ext. - Proof. exact (Radd_ext Ceqe). Qed. - - Add Morphism cmul with signature (ceq ==> ceq ==> ceq) as cmul_ext. - Proof. exact (Rmul_ext Ceqe). Qed. - - Add Morphism copp with signature (ceq ==> ceq) as copp_ext. - Proof. exact (Ropp_ext Ceqe). Qed. - - Variable Cth : ring_theory cO cI cadd cmul csub copp ceq. - Variable Smorph : semi_morph 0 1 radd rmul req cO cI cadd cmul ceqb phi. - Variable phi_ext : forall x y, ceq x y -> [x] == [y]. - - Add Morphism phi with signature (ceq ==> req) as phi_ext1. - Proof. exact phi_ext. Qed. - - Lemma Smorph_opp x : [-!x] == -[x]. - Proof. - rewrite <- (Radd_0_l Rth [-!x]). - rewrite <- ((Ropp_def Rth) [x]). - rewrite ((Radd_comm Rth) [x]). - rewrite <- (Radd_assoc Rth). - rewrite <- (Smorph_add Smorph). - rewrite (Ropp_def Cth). - rewrite (Smorph0 Smorph). - rewrite (Radd_comm Rth (-[x])). - now apply (Radd_0_l Rth). - Qed. - - Lemma Smorph_sub x y : [x -! y] == [x] - [y]. - Proof. - rewrite (Rsub_def Cth), (Rsub_def Rth). - now rewrite (Smorph_add Smorph), Smorph_opp. - Qed. - - Lemma Smorph_morph : - ring_morph 0 1 radd rmul rsub ropp req - cO cI cadd cmul csub copp ceqb phi. - Proof - (mkmorph 0 1 radd rmul rsub ropp req cO cI cadd cmul csub copp ceqb phi - (Smorph0 Smorph) (Smorph1 Smorph) - (Smorph_add Smorph) Smorph_sub (Smorph_mul Smorph) Smorph_opp - (Smorph_eq Smorph)). - - End RING. - - (** Useful lemmas on almost ring *) - Variable ARth : almost_ring_theory 0 1 radd rmul rsub ropp req. - - Lemma ARth_SRth : semi_ring_theory 0 1 radd rmul req. -Proof. -elim ARth; intros. -constructor; trivial. -Qed. - - Instance ARsub_ext : Proper (req ==> req ==> req) rsub. - Proof. - intros x1 x2 Ex y1 y2 Ey. - now rewrite !(ARsub_def ARth), Ex, Ey. - Qed. - - Ltac mrewrite := - repeat first - [ rewrite (ARadd_0_l ARth) - | rewrite <- ((ARadd_comm ARth) 0) - | rewrite (ARmul_1_l ARth) - | rewrite <- ((ARmul_comm ARth) 1) - | rewrite (ARmul_0_l ARth) - | rewrite <- ((ARmul_comm ARth) 0) - | rewrite (ARdistr_l ARth) - | reflexivity - | match goal with - | |- context [?z * (?x + ?y)] => rewrite ((ARmul_comm ARth) z (x+y)) - end]. - - Lemma ARadd_0_r x : x + 0 == x. - Proof. mrewrite. Qed. - - Lemma ARmul_1_r x : x * 1 == x. - Proof. mrewrite. Qed. - - Lemma ARmul_0_r x : x * 0 == 0. - Proof. mrewrite. Qed. - - Lemma ARdistr_r x y z : z * (x + y) == z*x + z*y. - Proof. - mrewrite. now rewrite !(ARmul_comm ARth z). - Qed. - - Lemma ARadd_assoc1 x y z : (x + y) + z == (y + z) + x. - Proof. - now rewrite <-(ARadd_assoc ARth x), (ARadd_comm ARth x). - Qed. - - Lemma ARadd_assoc2 x y z : (y + x) + z == (y + z) + x. - Proof. - now rewrite <- !(ARadd_assoc ARth), ((ARadd_comm ARth) x). - Qed. - - Lemma ARmul_assoc1 x y z : (x * y) * z == (y * z) * x. - Proof. - now rewrite <- ((ARmul_assoc ARth) x), ((ARmul_comm ARth) x). - Qed. - - Lemma ARmul_assoc2 x y z : (y * x) * z == (y * z) * x. - Proof. - now rewrite <- !(ARmul_assoc ARth), ((ARmul_comm ARth) x). - Qed. - - Lemma ARopp_mul_r x y : - (x * y) == x * -y. - Proof. - rewrite ((ARmul_comm ARth) x y), (ARopp_mul_l ARth). - now apply (ARmul_comm ARth). - Qed. - - Lemma ARopp_zero : -0 == 0. - Proof. - now rewrite <- (ARmul_0_r 0), (ARopp_mul_l ARth), !ARmul_0_r. - Qed. - -End ALMOST_RING. - -Section AddRing. - -(* Variable R : Type. - Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R). - Variable req : R -> R -> Prop. *) - -Inductive ring_kind : Type := -| Abstract -| Computational - (R:Type) - (req : R -> R -> Prop) - (reqb : R -> R -> bool) - (_ : forall x y, (reqb x y) = true -> req x y) -| Morphism - (R : Type) - (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R) - (req : R -> R -> Prop) - (C : Type) - (cO cI : C) (cadd cmul csub : C->C->C) (copp : C->C) - (ceqb : C->C->bool) - phi - (_ : ring_morph rO rI radd rmul rsub ropp req - cO cI cadd cmul csub copp ceqb phi). - -End AddRing. - - -(** Some simplification tactics*) -Ltac gen_reflexivity Rsth := apply (Seq_refl _ _ Rsth). - -Ltac gen_srewrite Rsth Reqe ARth := - repeat first - [ gen_reflexivity Rsth - | progress rewrite (ARopp_zero Rsth Reqe ARth) - | rewrite (ARadd_0_l ARth) - | rewrite (ARadd_0_r Rsth ARth) - | rewrite (ARmul_1_l ARth) - | rewrite (ARmul_1_r Rsth ARth) - | rewrite (ARmul_0_l ARth) - | rewrite (ARmul_0_r Rsth ARth) - | rewrite (ARdistr_l ARth) - | rewrite (ARdistr_r Rsth Reqe ARth) - | rewrite (ARadd_assoc ARth) - | rewrite (ARmul_assoc ARth) - | progress rewrite (ARopp_add ARth) - | progress rewrite (ARsub_def ARth) - | progress rewrite <- (ARopp_mul_l ARth) - | progress rewrite <- (ARopp_mul_r Rsth Reqe ARth) ]. - -Ltac gen_srewrite_sr Rsth Reqe ARth := - repeat first - [ gen_reflexivity Rsth - | progress rewrite (ARopp_zero Rsth Reqe ARth) - | rewrite (ARadd_0_l ARth) - | rewrite (ARadd_0_r Rsth ARth) - | rewrite (ARmul_1_l ARth) - | rewrite (ARmul_1_r Rsth ARth) - | rewrite (ARmul_0_l ARth) - | rewrite (ARmul_0_r Rsth ARth) - | rewrite (ARdistr_l ARth) - | rewrite (ARdistr_r Rsth Reqe ARth) - | rewrite (ARadd_assoc ARth) - | rewrite (ARmul_assoc ARth) ]. - -Ltac gen_add_push add Rsth Reqe ARth x := - repeat (match goal with - | |- context [add (add ?y x) ?z] => - progress rewrite (ARadd_assoc2 Rsth Reqe ARth x y z) - | |- context [add (add x ?y) ?z] => - progress rewrite (ARadd_assoc1 Rsth ARth x y z) - | |- context [(add x ?y)] => - progress rewrite (ARadd_comm ARth x y) - end). - -Ltac gen_mul_push mul Rsth Reqe ARth x := - repeat (match goal with - | |- context [mul (mul ?y x) ?z] => - progress rewrite (ARmul_assoc2 Rsth Reqe ARth x y z) - | |- context [mul (mul x ?y) ?z] => - progress rewrite (ARmul_assoc1 Rsth ARth x y z) - | |- context [(mul x ?y)] => - progress rewrite (ARmul_comm ARth x y) - end). diff --git a/stdlib/theories/setoid_ring/Rings_Q.v b/stdlib/theories/setoid_ring/Rings_Q.v deleted file mode 100644 index d695304bb9c7..000000000000 --- a/stdlib/theories/setoid_ring/Rings_Q.v +++ /dev/null @@ -1,53 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* 0%R. -discrR. -Qed. - -#[global] -Instance Rdi : (Integral_domain (Rcr:=Rcri)). -constructor. -- exact Rmult_integral. -- exact R_one_zero. -Defined. diff --git a/stdlib/theories/setoid_ring/Rings_Z.v b/stdlib/theories/setoid_ring/Rings_Z.v deleted file mode 100644 index e1be79f51965..000000000000 --- a/stdlib/theories/setoid_ring/Rings_Z.v +++ /dev/null @@ -1,27 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* 0%Z. -Proof. discriminate. Qed. - -#[global] -Instance Zdi : (Integral_domain (Rcr:=Zcri)). -constructor. -- exact Zmult_integral. -- exact Z_one_zero. -Defined. diff --git a/stdlib/theories/setoid_ring/ZArithRing.v b/stdlib/theories/setoid_ring/ZArithRing.v deleted file mode 100644 index 9aea3ff172ca..000000000000 --- a/stdlib/theories/setoid_ring/ZArithRing.v +++ /dev/null @@ -1,59 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* t - | _ => constr:(NotConstant) - end. - -Ltac isZpow_coef t := - match t with - | Zpos ?p => isPcst p - | Z0 => constr:(true) - | _ => constr:(false) - end. - -Notation N_of_Z := Z.to_N (only parsing). - -Ltac Zpow_tac t := - match isZpow_coef t with - | true => constr:(N_of_Z t) - | _ => constr:(NotConstant) - end. - -Ltac Zpower_neg := - repeat match goal with - | [|- ?G] => - match G with - | context c [Z.pow _ (Zneg _)] => - let t := context c [Z0] in - change t - end - end. - -Local Lemma Private_proj1_eqb_eq x y : Z.eqb x y = true -> x = y. -Proof. apply Z.eqb_eq. Qed. - -Add Ring Zr : Zth - (decidable Private_proj1_eqb_eq, constants [Zcst], preprocess [Zpower_neg;unfold Z.succ], - power_tac Zpower_theory [Zpow_tac], - (* The following two options are not needed; they are the default choice - when the set of coefficient is the usual ring Z *) - div (InitialRing.Ztriv_div_th (@Eqsth Z) (@IDphi Z)), - sign get_signZ_th). diff --git a/stdlib/theories/ssr/ssrbool.v b/stdlib/theories/ssr/ssrbool.v deleted file mode 100644 index 16feddf67a3c..000000000000 --- a/stdlib/theories/ssr/ssrbool.v +++ /dev/null @@ -1 +0,0 @@ -From Corelib Require Export ssrbool. diff --git a/stdlib/theories/ssr/ssrclasses.v b/stdlib/theories/ssr/ssrclasses.v deleted file mode 100644 index 84a663d2acd3..000000000000 --- a/stdlib/theories/ssr/ssrclasses.v +++ /dev/null @@ -1 +0,0 @@ -From Corelib Require Export ssrclasses. diff --git a/stdlib/theories/ssr/ssreflect.v b/stdlib/theories/ssr/ssreflect.v deleted file mode 100644 index 52b45ed5aa2e..000000000000 --- a/stdlib/theories/ssr/ssreflect.v +++ /dev/null @@ -1 +0,0 @@ -From Corelib Require Export ssreflect. diff --git a/stdlib/theories/ssr/ssrfun.v b/stdlib/theories/ssr/ssrfun.v deleted file mode 100644 index db145d6e1faa..000000000000 --- a/stdlib/theories/ssr/ssrfun.v +++ /dev/null @@ -1 +0,0 @@ -From Corelib Require Export ssrfun. diff --git a/stdlib/theories/ssr/ssrsetoid.v b/stdlib/theories/ssr/ssrsetoid.v deleted file mode 100644 index c7fdcdc06800..000000000000 --- a/stdlib/theories/ssr/ssrsetoid.v +++ /dev/null @@ -1 +0,0 @@ -From Corelib Require Export ssrsetoid. diff --git a/stdlib/theories/ssr/ssrunder.v b/stdlib/theories/ssr/ssrunder.v deleted file mode 100644 index 8bde84a2cc4a..000000000000 --- a/stdlib/theories/ssr/ssrunder.v +++ /dev/null @@ -1 +0,0 @@ -From Corelib Require Export ssrunder. diff --git a/stdlib/theories/ssrmatching/ssrmatching.v b/stdlib/theories/ssrmatching/ssrmatching.v deleted file mode 100644 index 3fb2a3c0edd2..000000000000 --- a/stdlib/theories/ssrmatching/ssrmatching.v +++ /dev/null @@ -1 +0,0 @@ -From Corelib Require Export ssrmatching. diff --git a/stdlib/tools/dune b/stdlib/tools/dune deleted file mode 100644 index de3ef5de1317..000000000000 --- a/stdlib/tools/dune +++ /dev/null @@ -1,3 +0,0 @@ -(executable - (name gen_all) - (libraries unix)) diff --git a/stdlib/tools/gen_all.ml b/stdlib/tools/gen_all.ml deleted file mode 100644 index 8a86488d2b34..000000000000 --- a/stdlib/tools/gen_all.ml +++ /dev/null @@ -1,50 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* f - | _ -> String.concat "." [prefix; f] - -let rec traverse todo todo' = match todo, todo' with - | [], [] -> () - | [], todo :: todo' -> traverse todo todo' - | (path,logical) :: todo, todo' -> - let todo' = match (Unix.stat path).st_kind with - | exception Unix.Unix_error _ -> todo' - | S_DIR -> - let contents = try Sys.readdir path with Sys_error _ -> [||] in - (* sort to get a reproducible ordering *) - let () = Array.sort String.compare contents in - let contents = Array.to_list contents in - let contents = List.map (fun fname -> - Filename.concat path fname, logical_concat logical fname) - contents - in - (contents :: todo') - | S_REG -> - let () = - if Filename.extension path = ".v" && - logical <> "All" - then Printf.printf "From %s Require Export %s.\n" from logical - in - todo' - | _ -> todo' - in - traverse todo todo' - -let () = traverse [".", ""] [] - -let () = Printf.printf "%!" From b8b430358ac20b641eb4e0ba4727e5d9cabb73ed Mon Sep 17 00:00:00 2001 From: Pierre Roux Date: Wed, 16 Oct 2024 10:46:10 +0200 Subject: [PATCH 2/4] Adapt changelog --- .../11-standard-library/17560-nat_mul_reg.rst | 3 --- .../11-standard-library/18183-lt_list.rst | 6 ----- .../19269-adding_vectors_Forall2_lemma.rst | 4 --- .../19310-stdlib-logical-name.rst | 26 ------------------- .../19479-master+misc-addition-lists.rst | 10 ------- .../19483-UIP-None-nil.rst | 9 ------- .../11-standard-library/19515-Proper_map.rst | 4 --- .../11-standard-library/19655-fin_L_R.rst | 5 ---- .../19748-list-for-Zmod.rst | 16 ------------ .../19749-pos-iter-op-correct.rst | 4 --- .../11-standard-library/19750-n2z-bitwise.rst | 9 ------- .../11-standard-library/19752-zdiv-facts.rst | 19 -------------- .../19801-less-ZArith_base.rst | 10 ------- .../11-standard-library/19914-stdlib-all.rst | 4 --- .../19949-option-eqdec.rst | 3 --- .../11-standard-library/19975-stdlib_repo.rst | 5 ++++ 16 files changed, 5 insertions(+), 132 deletions(-) delete mode 100644 doc/changelog/11-standard-library/17560-nat_mul_reg.rst delete mode 100644 doc/changelog/11-standard-library/18183-lt_list.rst delete mode 100644 doc/changelog/11-standard-library/19269-adding_vectors_Forall2_lemma.rst delete mode 100644 doc/changelog/11-standard-library/19310-stdlib-logical-name.rst delete mode 100644 doc/changelog/11-standard-library/19479-master+misc-addition-lists.rst delete mode 100644 doc/changelog/11-standard-library/19483-UIP-None-nil.rst delete mode 100644 doc/changelog/11-standard-library/19515-Proper_map.rst delete mode 100644 doc/changelog/11-standard-library/19655-fin_L_R.rst delete mode 100644 doc/changelog/11-standard-library/19748-list-for-Zmod.rst delete mode 100644 doc/changelog/11-standard-library/19749-pos-iter-op-correct.rst delete mode 100644 doc/changelog/11-standard-library/19750-n2z-bitwise.rst delete mode 100644 doc/changelog/11-standard-library/19752-zdiv-facts.rst delete mode 100644 doc/changelog/11-standard-library/19801-less-ZArith_base.rst delete mode 100644 doc/changelog/11-standard-library/19914-stdlib-all.rst delete mode 100644 doc/changelog/11-standard-library/19949-option-eqdec.rst create mode 100644 doc/changelog/11-standard-library/19975-stdlib_repo.rst diff --git a/doc/changelog/11-standard-library/17560-nat_mul_reg.rst b/doc/changelog/11-standard-library/17560-nat_mul_reg.rst deleted file mode 100644 index 89015dd3366f..000000000000 --- a/doc/changelog/11-standard-library/17560-nat_mul_reg.rst +++ /dev/null @@ -1,3 +0,0 @@ -- **Added:** lemmas :g:`mul_reg_l` and :g:`mul_reg_r` to `NatInt` - (`#17560 `_, - by Remzi Yang). diff --git a/doc/changelog/11-standard-library/18183-lt_list.rst b/doc/changelog/11-standard-library/18183-lt_list.rst deleted file mode 100644 index 2c29727bc6e6..000000000000 --- a/doc/changelog/11-standard-library/18183-lt_list.rst +++ /dev/null @@ -1,6 +0,0 @@ -- **Added:** - well-founded list extension ``list_ext`` of a well-founded relation in ``Coq.Wellfounded.List_Extension``, including infrastructure lemmas. - It can be used for well-foundedness proofs such as ``wf_lex_exp`` in ``Coq.Wellfounded.Lexicographic_Exponentiation``. - Also added lemma ``Acc_simulation`` and ``wf_simulation`` to ``Coq.Wellfounded.Inverse_Image``, and lemma ``clos_t_clos_rt`` to ``Coq.Relations.Operators_Properties`` - (`#18183 `_, - by Andrej Dudenhefner). diff --git a/doc/changelog/11-standard-library/19269-adding_vectors_Forall2_lemma.rst b/doc/changelog/11-standard-library/19269-adding_vectors_Forall2_lemma.rst deleted file mode 100644 index 149c2b5d27c7..000000000000 --- a/doc/changelog/11-standard-library/19269-adding_vectors_Forall2_lemma.rst +++ /dev/null @@ -1,4 +0,0 @@ -- **Added:** - lemmas :g:`Forall2_cons_iff` - (`#19269 `_, - by Lucas Donati and Andrej Dudenhefner and Pierre Rousselin). diff --git a/doc/changelog/11-standard-library/19310-stdlib-logical-name.rst b/doc/changelog/11-standard-library/19310-stdlib-logical-name.rst deleted file mode 100644 index 9912d25916d0..000000000000 --- a/doc/changelog/11-standard-library/19310-stdlib-logical-name.rst +++ /dev/null @@ -1,26 +0,0 @@ -- **Changed:** - the requirement prefix of the standard library from ``Coq`` to - ``Stdlib`` and made it mandatory. As a temporary measure, for - backward compatibility with older versions, ``Coq``, or a missing - `From Stdlib`, is immediatly translated to ``Stdlib`` with a - warning. It is thus not recommended to name anything ``Coq`` or - ``Coq.*``. - The recommended transition path is to first potentially silence - the warnings, adding the lines - ``-arg -w -arg -deprecated-from-Coq``, - ``-arg -w -arg -deprecated-dirpath-Coq`` and - ``-arg -w -arg -deprecated-missing-stdlib`` - or simply the more generic - ``-arg -compat -arg 8.20`` to your ``_CoqProject``. - Then, when droping support for Coq <= 8.20, replacing requirement of - Stdlib modules by `From Stdlib Require {Import,Export,} .`. - Beware that the Stdlib still has a handful redundant names, that is - for modules `Byte`, you still have to use `From Stdlib.Strings` or - `From Stdlib.Init`, for `Tactics` use `From Stdlib.Program` or `From - Stdlib.Init`, for `Tauto` use `From Stdlib.micromega` of `From - Stdlib.Init` and for `Wf`, use `From Stdlib.Program` or `From - Stdlib.Init` - (`#19310 `_ - and `#19530 `_, - the latter starting to implement `CEP#83 `_ - by Pierre Roux). diff --git a/doc/changelog/11-standard-library/19479-master+misc-addition-lists.rst b/doc/changelog/11-standard-library/19479-master+misc-addition-lists.rst deleted file mode 100644 index cb35af7fd19d..000000000000 --- a/doc/changelog/11-standard-library/19479-master+misc-addition-lists.rst +++ /dev/null @@ -1,10 +0,0 @@ -- **Added:** - New lemmas `length_cons` and `length_nil` in the standard library of lists - (`#19479 `_, - by Hugo Herbelin). - -- **Changed:** - Lemmas of the standard library of lists that were using the letter - :g:`O` in their name to refer to zero now use instead the digit :g:`0` - (`#19479 `_, - by Hugo Herbelin). diff --git a/doc/changelog/11-standard-library/19483-UIP-None-nil.rst b/doc/changelog/11-standard-library/19483-UIP-None-nil.rst deleted file mode 100644 index 0ac4ffe25869..000000000000 --- a/doc/changelog/11-standard-library/19483-UIP-None-nil.rst +++ /dev/null @@ -1,9 +0,0 @@ -- **Added:** lemmas - :g:`UIP_None_l`, - :g:`UIP_None_r`, - :g:`UIP_None_None`, - :g:`UIP_nil_l`, - :g:`UIP_nil_r`, - :g:`UIP_nil_nil` in :g:`Logic.Eqdep_dec` - (`#19483 `_, - by Andres Erbsen). diff --git a/doc/changelog/11-standard-library/19515-Proper_map.rst b/doc/changelog/11-standard-library/19515-Proper_map.rst deleted file mode 100644 index 83e088eec837..000000000000 --- a/doc/changelog/11-standard-library/19515-Proper_map.rst +++ /dev/null @@ -1,4 +0,0 @@ -- **Added:** :g:`Proper` instance to enable :g:`setoid_rewrite` to rewrite - inside the function argument of :g:`List.map` - (`#19515 `_, - by Andres Erbsen). diff --git a/doc/changelog/11-standard-library/19655-fin_L_R.rst b/doc/changelog/11-standard-library/19655-fin_L_R.rst deleted file mode 100644 index 76d59411125a..000000000000 --- a/doc/changelog/11-standard-library/19655-fin_L_R.rst +++ /dev/null @@ -1,5 +0,0 @@ -- **Added:** - Lemmas to ``Fin``: ``case_L_R'_L``, ``case_L_R'_R``, ``case_L_R_L``, ``case_L_R_R``; - and changed corresponding ``case_L_R'`` and ``case_L_R`` into transparent definitions. - (`#19655 `_, - by Andrej Dudenhefner). diff --git a/doc/changelog/11-standard-library/19748-list-for-Zmod.rst b/doc/changelog/11-standard-library/19748-list-for-Zmod.rst deleted file mode 100644 index f8b4ed29dee5..000000000000 --- a/doc/changelog/11-standard-library/19748-list-for-Zmod.rst +++ /dev/null @@ -1,16 +0,0 @@ -- **Added:** list lemmas - :g:`length_tl`, - :g:`tl_map`, - :g:`filter_rev`, - :g:`filter_map_swap`, - :g:`filter_true`, - :g:`filter_false`, - :g:`list_prod_as_flat_map`, - :g:`skipn_seq`, - :g:`map_const`, - :g:`fst_list_prod`, - :g:`snd_list_prod`, - :g:`Injective_map_NoDup_in`, - and :g:`Permutation_map_same_l` - (`#19748 `_, - by Andres Erbsen). diff --git a/doc/changelog/11-standard-library/19749-pos-iter-op-correct.rst b/doc/changelog/11-standard-library/19749-pos-iter-op-correct.rst deleted file mode 100644 index 0ffbf4d9e77f..000000000000 --- a/doc/changelog/11-standard-library/19749-pos-iter-op-correct.rst +++ /dev/null @@ -1,4 +0,0 @@ -- **Added:** lemma :g:`BinPos.iter_op_correct`, relating :g:`Pos.iter_op` for - associative operations to the more general :g:`Pos.iter` - (`#19749 `_, - by Andres Erbsen). diff --git a/doc/changelog/11-standard-library/19750-n2z-bitwise.rst b/doc/changelog/11-standard-library/19750-n2z-bitwise.rst deleted file mode 100644 index 11c4dfd2b6d2..000000000000 --- a/doc/changelog/11-standard-library/19750-n2z-bitwise.rst +++ /dev/null @@ -1,9 +0,0 @@ -- **Added:** lemmas relating bitwise operations on :g:`N` to those on :g:`Z`: - :g:`N2Z.inj_lxor`, - :g:`N2Z.inj_land`, - :g:`N2Z.inj_lor`, - :g:`N2Z.inj_ldiff`, - :g:`N2Z.inj_shiftl`, - and :g:`N2Z.inj_shiftr` - (`#19750 `_, - by Andres Erbsen). diff --git a/doc/changelog/11-standard-library/19752-zdiv-facts.rst b/doc/changelog/11-standard-library/19752-zdiv-facts.rst deleted file mode 100644 index 60b3083ab6e9..000000000000 --- a/doc/changelog/11-standard-library/19752-zdiv-facts.rst +++ /dev/null @@ -1,19 +0,0 @@ -- **Added:** lemmas about :g:`Z.modulo`, some in a new module :g:`Zdiv_facts`. - On its own, :g:`Z.mod_id_iff` generalizes :g:`Z.mod_small`, whereas - :g:`Z.diveq_iff` and :g:`Z.mod_diveq_iff` further genralize the same concept - to known quotients other than 0. Combinations of :g:`Z.modulo` with - :g:`Z.opp` or :g:`Z.abs` are the subject of - :g:`Z.mod_opp_mod_opp`, - :g:`Z.mod_mod_opp_r`, - :g:`Z.mod_opp_r_mod`, - :g:`Z.mod_mod_abs_r`, - :g:`Z.mod_abs_r_mod`, - :g:`Z.eq_mod_opp`, - :g:`Z.eq_mod_abs`. - Lemmas :g:`cong_iff_0` and :g:`cong_iff_ex` can be used to reduce congruence - equalities to equations where only one side is headed by :g:`Z.modulo`. - Lemmas :g:`Z.gcd_mod_l` and :g:`Z.gcd_mod_r` generalize :g:`Z.gcd_mod`. - Lemma :g:`Z.mod_mod_divide` generalizes :g:`Zmod_mod`. - Lemma :g:`Z.mod_pow_l` allows pushing modulo inside exponentiation - (`#19752 `_, - by Andres Erbsen). diff --git a/doc/changelog/11-standard-library/19801-less-ZArith_base.rst b/doc/changelog/11-standard-library/19801-less-ZArith_base.rst deleted file mode 100644 index 40a5eb609a62..000000000000 --- a/doc/changelog/11-standard-library/19801-less-ZArith_base.rst +++ /dev/null @@ -1,10 +0,0 @@ -- **Deprecated:** module :g:`ZArith_Base`, module :g:`Ztac`, and :g:`Zeq_bool`. - Use :g:`ZArith` (or :g:`BinInt`), :g:`Lia`, and :g:`Z.eqb` instead. - Reducing use of the deprecated modules in stdlib **changed** the transitive - dependencies of several stdlib files; you may now need to ``Require`` or - ``Import`` :g:`ZArith` or :g:`Lia`. - The definition of :g:`Zeq_bool` was also **changed** to be an alias for - :g:`Z.eqb`; this is expected to simplify simultaneous compatibility with 8.20 - and 9.0 - (`#19801 `_, - by Andres Erbsen). diff --git a/doc/changelog/11-standard-library/19914-stdlib-all.rst b/doc/changelog/11-standard-library/19914-stdlib-all.rst deleted file mode 100644 index ef810297e924..000000000000 --- a/doc/changelog/11-standard-library/19914-stdlib-all.rst +++ /dev/null @@ -1,4 +0,0 @@ -- **Added:** - `Stdlib.All` which does `Require Export` of all other files in the stdlib - (`#19914 `_, - by GaĆ«tan Gilbert). diff --git a/doc/changelog/11-standard-library/19949-option-eqdec.rst b/doc/changelog/11-standard-library/19949-option-eqdec.rst deleted file mode 100644 index 8ac2f2c24327..000000000000 --- a/doc/changelog/11-standard-library/19949-option-eqdec.rst +++ /dev/null @@ -1,3 +0,0 @@ -- **Added:** :g:`EqDec` instance for :g:`option` - (`#19949 `_, - by Daniil Iaitskov). diff --git a/doc/changelog/11-standard-library/19975-stdlib_repo.rst b/doc/changelog/11-standard-library/19975-stdlib_repo.rst new file mode 100644 index 000000000000..c7fcef0dafe9 --- /dev/null +++ b/doc/changelog/11-standard-library/19975-stdlib_repo.rst @@ -0,0 +1,5 @@ +- **Changed:** + Stdlib moved to its own repository, look for Stdlib own changelog + for other changes there + (`#19975 `_, + by Pierre Roux). From 343b99a48debf1d4bdee71f2b4813a758560525d Mon Sep 17 00:00:00 2001 From: Pierre Roux Date: Mon, 14 Oct 2024 13:11:39 +0200 Subject: [PATCH 3/4] Adapt CI --- .gitlab-ci.yml | 2 -- dev/ci/ci-basic-overlay.sh | 7 +++++++ dev/ci/ci-stdlib.sh | 4 +++- dev/ci/ci-stdlib_doc.sh | 2 +- dev/ci/ci-stdlib_test.sh | 2 +- 5 files changed, 12 insertions(+), 5 deletions(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index ac917b26d8bc..ddef3ca83ed7 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -243,13 +243,11 @@ before_script: - if [ "$ROCQ_CI_NATIVE" = true ]; then opam install -y rocq-native; fi - opam pin add --kind=path rocq-runtime.dev . - opam pin add --kind=path rocq-core.dev . - - opam pin add --kind=path rocq-stdlib.dev stdlib/ - if [ "$ROCQ_CI_NATIVE" = true ]; then echo "Definition f x := x + x." > test_native.v; fi - if [ "$ROCQ_CI_NATIVE" = true ]; then rocq c test_native.v; fi - if [ "$ROCQ_CI_NATIVE" = true ]; then test -f .coq-native/Ntest_native.cmxs; fi - if command -v coqc; then exit 1; fi # coq-core didn't get autoinstalled - opam pin add --kind=path coq-core.dev . - - opam pin add --kind=path coq-stdlib.dev stdlib/ - opam pin add --kind=path coqide-server.dev . - opam pin add --kind=path coqide.dev . after_script: diff --git a/dev/ci/ci-basic-overlay.sh b/dev/ci/ci-basic-overlay.sh index 8a524a14c353..61c9083615ba 100644 --- a/dev/ci/ci-basic-overlay.sh +++ b/dev/ci/ci-basic-overlay.sh @@ -416,6 +416,13 @@ project verdi "https://github.com/uwplse/verdi" "master" project verdi_raft "https://github.com/uwplse/verdi-raft" "master" # Contact @palmskog on github +######################################################################## +# Stdlib +######################################################################## +project stdlib "https://github.com/coq/stdlib-test" "master" +# TODO replace temporary test repo by actual one +# Contact TODO on github + ######################################################################## # argosy ######################################################################## diff --git a/dev/ci/ci-stdlib.sh b/dev/ci/ci-stdlib.sh index bb5060ca7ef3..f6c9d66f9f35 100644 --- a/dev/ci/ci-stdlib.sh +++ b/dev/ci/ci-stdlib.sh @@ -5,9 +5,11 @@ set -e ci_dir="$(dirname "$0")" . "${ci_dir}/ci-common.sh" +git_download stdlib + if [ "$DOWNLOAD_ONLY" ]; then exit 0; fi -( cd "stdlib" +( cd "${CI_BUILD_DIR}/stdlib" dev/with-rocq-wrap.sh dune build --root . --only-packages=rocq-stdlib @install dev/with-rocq-wrap.sh dune install --root . rocq-stdlib --prefix="$CI_INSTALL_DIR" ) diff --git a/dev/ci/ci-stdlib_doc.sh b/dev/ci/ci-stdlib_doc.sh index 6ea2a7e6e569..7c9771e05a27 100644 --- a/dev/ci/ci-stdlib_doc.sh +++ b/dev/ci/ci-stdlib_doc.sh @@ -7,7 +7,7 @@ ci_dir="$(dirname "$0")" if [ "$DOWNLOAD_ONLY" ]; then exit 0; fi -( cd "stdlib" +( cd "${CI_BUILD_DIR}/stdlib" make refman-html make stdlib-html ) diff --git a/dev/ci/ci-stdlib_test.sh b/dev/ci/ci-stdlib_test.sh index cd2a32dfb98d..0da8417bd991 100644 --- a/dev/ci/ci-stdlib_test.sh +++ b/dev/ci/ci-stdlib_test.sh @@ -7,6 +7,6 @@ ci_dir="$(dirname "$0")" if [ "$DOWNLOAD_ONLY" ]; then exit 0; fi -( cd "stdlib/test-suite" +( cd "${CI_BUILD_DIR}/stdlib/test-suite" make ) From 31aea7232111dba11d7f6a07705ad36a666c0a1b Mon Sep 17 00:00:00 2001 From: Pierre Roux Date: Wed, 8 Jan 2025 13:41:42 +0100 Subject: [PATCH 4/4] Adapt bench --- dev/bench/bench.sh | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/dev/bench/bench.sh b/dev/bench/bench.sh index eb4f2c7b6465..aa29813acaa4 100755 --- a/dev/bench/bench.sh +++ b/dev/bench/bench.sh @@ -49,7 +49,7 @@ check_variable () { : "${old_coq_version:=dev}" : "${num_of_iterations:=1}" : "${timeout:=3h}" -: "${coq_opam_packages:=coq-bignums coq-hott coq-performance-tests-lite coq-engine-bench-lite coq-mathcomp-ssreflect coq-mathcomp-fingroup coq-mathcomp-algebra coq-mathcomp-solvable coq-mathcomp-field coq-mathcomp-character coq-mathcomp-odd-order coq-mathcomp-analysis coq-math-classes coq-corn coq-compcert coq-equations coq-metacoq-utils coq-metacoq-common coq-metacoq-template coq-metacoq-pcuic coq-metacoq-safechecker coq-metacoq-erasure coq-metacoq-translations coq-color coq-coqprime coq-coqutil coq-bedrock2 coq-rewriter coq-fiat-core coq-fiat-parsers coq-fiat-crypto-with-bedrock coq-unimath coq-coquelicot coq-iris-examples coq-verdi coq-verdi-raft coq-fourcolor coq-rewriter-perf-SuperFast coq-vst coq-category-theory coq-neural-net-interp-computed-lite}" +: "${coq_opam_packages:=rocq-stdlib coq-bignums coq-hott coq-performance-tests-lite coq-engine-bench-lite coq-mathcomp-ssreflect coq-mathcomp-fingroup coq-mathcomp-algebra coq-mathcomp-solvable coq-mathcomp-field coq-mathcomp-character coq-mathcomp-odd-order coq-mathcomp-analysis coq-math-classes coq-corn coq-compcert coq-equations coq-metacoq-utils coq-metacoq-common coq-metacoq-template coq-metacoq-pcuic coq-metacoq-safechecker coq-metacoq-erasure coq-metacoq-translations coq-color coq-coqprime coq-coqutil coq-bedrock2 coq-rewriter coq-fiat-core coq-fiat-parsers coq-fiat-crypto-with-bedrock coq-unimath coq-coquelicot coq-iris-examples coq-verdi coq-verdi-raft coq-fourcolor coq-rewriter-perf-SuperFast coq-vst coq-category-theory coq-neural-net-interp-computed-lite}" : "${coq_native:=}" # example: coq-hott.dev git+https://github.com/some-user/coq-hott#some-branch @@ -389,6 +389,7 @@ create_opam() { opam var --global jobs=$number_of_processors >/dev/null if [ ! -z "$BENCH_DEBUG" ]; then opam config list; fi + opam repo add -q --this-switch coq-core-dev "$OPAM_COQ_DIR/core-dev" # For rocq-stdlib opam repo add -q --this-switch coq-extra-dev "$OPAM_COQ_DIR/extra-dev" opam repo add -q --this-switch coq-released "$OPAM_COQ_DIR/released" @@ -462,7 +463,7 @@ export PROFILING=1 export COQ_PROFILE_COMPONENTS=command,parse_command,partac.perform # packages tied to the coq commit need to be pinned accordingly -core_packages='rocq-runtime coq-core rocq-core coq-stdlib coqide-server coq' +core_packages='rocq-runtime coq-core rocq-core coqide-server' for coq_opam_package in $core_packages $coq_opam_packages; do