From 7cfc4e5146be5666419451bdd516f1f3f264d24a Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Sun, 25 Jan 2015 14:42:51 +0100 Subject: Imported Upstream version 8.5~beta1+dfsg --- theories/Arith/Arith.v | 2 +- theories/Arith/Arith_base.v | 4 +- theories/Arith/Between.v | 2 +- theories/Arith/Bool_nat.v | 2 +- theories/Arith/Compare.v | 2 +- theories/Arith/Compare_dec.v | 230 ++--- theories/Arith/Div2.v | 167 ++-- theories/Arith/EqNat.v | 100 +- theories/Arith/Euclid.v | 52 +- theories/Arith/Even.v | 299 +++--- theories/Arith/Factorial.v | 29 +- theories/Arith/Gt.v | 133 ++- theories/Arith/Le.v | 122 +-- theories/Arith/Lt.v | 172 ++-- theories/Arith/Max.v | 8 +- theories/Arith/Min.v | 8 +- theories/Arith/Minus.v | 139 +-- theories/Arith/Mult.v | 201 ++-- theories/Arith/PeanoNat.v | 755 ++++++++++++++ theories/Arith/Peano_dec.v | 65 +- theories/Arith/Plus.v | 191 ++-- theories/Arith/Wf_nat.v | 93 +- theories/Arith/vo.itarget | 1 + theories/Bool/Bool.v | 12 +- theories/Bool/BoolEq.v | 2 +- theories/Bool/Bvector.v | 10 +- theories/Bool/DecBool.v | 2 +- theories/Bool/IfProp.v | 2 +- theories/Bool/Sumbool.v | 2 +- theories/Bool/Zerob.v | 2 +- theories/Classes/CEquivalence.v | 139 +++ theories/Classes/CMorphisms.v | 701 +++++++++++++ theories/Classes/CRelationClasses.v | 359 +++++++ theories/Classes/DecidableClass.v | 92 ++ theories/Classes/EquivDec.v | 13 +- theories/Classes/Equivalence.v | 38 +- theories/Classes/Init.v | 2 +- theories/Classes/Morphisms.v | 577 ++++++----- theories/Classes/Morphisms_Prop.v | 59 +- theories/Classes/Morphisms_Relations.v | 10 +- theories/Classes/RelationClasses.v | 432 ++++---- theories/Classes/RelationPairs.v | 116 +-- theories/Classes/SetoidClass.v | 2 +- theories/Classes/SetoidDec.v | 6 +- theories/Classes/SetoidTactics.v | 3 +- theories/Classes/vo.itarget | 4 + theories/FSets/FMapAVL.v | 62 +- theories/FSets/FMapFacts.v | 72 +- theories/FSets/FMapFullAVL.v | 12 +- theories/FSets/FMapList.v | 41 +- theories/FSets/FMapPositive.v | 119 ++- theories/FSets/FMapWeakList.v | 27 +- theories/FSets/FSetBridge.v | 20 +- theories/FSets/FSetCompat.v | 2 + theories/FSets/FSetDecide.v | 6 +- theories/FSets/FSetEqProperties.v | 2 +- theories/FSets/FSetInterface.v | 2 +- theories/FSets/FSetPositive.v | 95 +- theories/FSets/FSetProperties.v | 3 +- theories/Init/Datatypes.v | 25 +- theories/Init/Logic.v | 232 ++++- theories/Init/Logic_Type.v | 2 +- theories/Init/Nat.v | 297 ++++++ theories/Init/Notations.v | 13 +- theories/Init/Peano.v | 139 ++- theories/Init/Prelude.v | 6 +- theories/Init/Specif.v | 123 ++- theories/Init/Tactics.v | 4 +- theories/Init/Wf.v | 22 +- theories/Init/vo.itarget | 1 + theories/Lists/List.v | 1047 +++++++++++++++----- theories/Lists/ListDec.v | 103 ++ theories/Lists/ListSet.v | 22 +- theories/Lists/ListTactics.v | 2 +- theories/Lists/SetoidList.v | 189 +++- theories/Lists/SetoidPermutation.v | 3 +- theories/Lists/StreamMemo.v | 2 +- theories/Lists/Streams.v | 2 +- theories/Lists/vo.itarget | 1 + theories/Logic/Berardi.v | 20 +- theories/Logic/ChoiceFacts.v | 65 +- theories/Logic/Classical.v | 2 +- theories/Logic/ClassicalChoice.v | 2 +- theories/Logic/ClassicalDescription.v | 2 +- theories/Logic/ClassicalEpsilon.v | 2 +- theories/Logic/ClassicalFacts.v | 109 +- theories/Logic/ClassicalUniqueChoice.v | 6 +- theories/Logic/Classical_Pred_Set.v | 48 - theories/Logic/Classical_Pred_Type.v | 2 +- theories/Logic/Classical_Prop.v | 2 +- theories/Logic/Classical_Type.v | 14 - theories/Logic/ConstructiveEpsilon.v | 14 +- theories/Logic/Decidable.v | 11 +- theories/Logic/Description.v | 4 +- theories/Logic/Diaconescu.v | 18 +- theories/Logic/Epsilon.v | 2 +- theories/Logic/Eqdep.v | 2 +- theories/Logic/EqdepFacts.v | 153 ++- theories/Logic/Eqdep_dec.v | 124 ++- theories/Logic/ExtensionalityFacts.v | 2 +- theories/Logic/FinFun.v | 400 ++++++++ theories/Logic/FunctionalExtensionality.v | 32 +- theories/Logic/Hurkens.v | 700 ++++++++++++- theories/Logic/IndefiniteDescription.v | 4 +- theories/Logic/JMeq.v | 8 +- theories/Logic/ProofIrrelevance.v | 2 +- theories/Logic/ProofIrrelevanceFacts.v | 4 +- theories/Logic/RelationalChoice.v | 2 +- theories/Logic/SetIsType.v | 4 +- theories/Logic/WKL.v | 261 +++++ theories/Logic/WeakFan.v | 105 ++ theories/Logic/vo.itarget | 6 +- theories/MSets/MSetAVL.v | 5 +- theories/MSets/MSetDecide.v | 6 +- theories/MSets/MSetEqProperties.v | 5 +- theories/MSets/MSetGenTree.v | 24 +- theories/MSets/MSetInterface.v | 1 - theories/MSets/MSetList.v | 21 +- theories/MSets/MSetPositive.v | 62 +- theories/MSets/MSetRBT.v | 21 +- theories/MSets/MSetWeakList.v | 18 +- theories/NArith/BinNat.v | 233 ++--- theories/NArith/BinNatDef.v | 10 +- theories/NArith/NArith.v | 2 +- theories/NArith/Ndec.v | 12 +- theories/NArith/Ndigits.v | 113 ++- theories/NArith/Ndist.v | 59 +- theories/NArith/Ndiv_def.v | 2 +- theories/NArith/Ngcd_def.v | 2 +- theories/NArith/Nnat.v | 63 +- theories/NArith/Nsqrt_def.v | 2 +- theories/Numbers/BigNumPrelude.v | 2 +- theories/Numbers/BinNums.v | 4 +- theories/Numbers/Cyclic/Abstract/CyclicAxioms.v | 21 +- theories/Numbers/Cyclic/Abstract/NZCyclic.v | 8 +- theories/Numbers/Cyclic/DoubleCyclic/DoubleAdd.v | 37 +- theories/Numbers/Cyclic/DoubleCyclic/DoubleBase.v | 8 +- .../Numbers/Cyclic/DoubleCyclic/DoubleCyclic.v | 164 ++- theories/Numbers/Cyclic/DoubleCyclic/DoubleDiv.v | 44 +- theories/Numbers/Cyclic/DoubleCyclic/DoubleDivn1.v | 5 +- theories/Numbers/Cyclic/DoubleCyclic/DoubleLift.v | 2 +- theories/Numbers/Cyclic/DoubleCyclic/DoubleMul.v | 12 +- theories/Numbers/Cyclic/DoubleCyclic/DoubleSqrt.v | 20 +- theories/Numbers/Cyclic/DoubleCyclic/DoubleSub.v | 11 +- theories/Numbers/Cyclic/DoubleCyclic/DoubleType.v | 5 +- theories/Numbers/Cyclic/Int31/Cyclic31.v | 270 +++-- theories/Numbers/Cyclic/Int31/Int31.v | 15 +- theories/Numbers/Cyclic/Int31/Ring31.v | 2 +- theories/Numbers/Cyclic/ZModulo/ZModulo.v | 55 +- theories/Numbers/Integer/Abstract/ZAdd.v | 2 +- theories/Numbers/Integer/Abstract/ZAddOrder.v | 2 +- theories/Numbers/Integer/Abstract/ZAxioms.v | 2 +- theories/Numbers/Integer/Abstract/ZBase.v | 2 +- theories/Numbers/Integer/Abstract/ZBits.v | 2 +- theories/Numbers/Integer/Abstract/ZDivEucl.v | 2 +- theories/Numbers/Integer/Abstract/ZDivFloor.v | 2 +- theories/Numbers/Integer/Abstract/ZDivTrunc.v | 2 +- theories/Numbers/Integer/Abstract/ZGcd.v | 2 +- theories/Numbers/Integer/Abstract/ZLcm.v | 2 +- theories/Numbers/Integer/Abstract/ZLt.v | 2 +- theories/Numbers/Integer/Abstract/ZMaxMin.v | 2 +- theories/Numbers/Integer/Abstract/ZMul.v | 2 +- theories/Numbers/Integer/Abstract/ZMulOrder.v | 2 +- theories/Numbers/Integer/Abstract/ZParity.v | 2 +- theories/Numbers/Integer/Abstract/ZPow.v | 2 +- theories/Numbers/Integer/Abstract/ZProperties.v | 27 +- theories/Numbers/Integer/Abstract/ZSgnAbs.v | 2 +- theories/Numbers/Integer/BigZ/BigZ.v | 12 +- theories/Numbers/Integer/BigZ/ZMake.v | 4 +- theories/Numbers/Integer/Binary/ZBinary.v | 2 +- theories/Numbers/Integer/NatPairs/ZNatPairs.v | 6 +- theories/Numbers/Integer/SpecViaZ/ZSig.v | 2 +- theories/Numbers/Integer/SpecViaZ/ZSigZAxioms.v | 2 +- theories/Numbers/NaryFunctions.v | 2 +- theories/Numbers/NatInt/NZAdd.v | 2 +- theories/Numbers/NatInt/NZAddOrder.v | 2 +- theories/Numbers/NatInt/NZAxioms.v | 5 +- theories/Numbers/NatInt/NZBase.v | 7 +- theories/Numbers/NatInt/NZBits.v | 2 +- theories/Numbers/NatInt/NZDiv.v | 2 +- theories/Numbers/NatInt/NZDomain.v | 40 +- theories/Numbers/NatInt/NZGcd.v | 6 +- theories/Numbers/NatInt/NZLog.v | 2 +- theories/Numbers/NatInt/NZMul.v | 2 +- theories/Numbers/NatInt/NZMulOrder.v | 2 +- theories/Numbers/NatInt/NZOrder.v | 6 +- theories/Numbers/NatInt/NZParity.v | 4 +- theories/Numbers/NatInt/NZPow.v | 4 +- theories/Numbers/NatInt/NZProperties.v | 2 +- theories/Numbers/NatInt/NZSqrt.v | 6 +- theories/Numbers/Natural/Abstract/NAdd.v | 2 +- theories/Numbers/Natural/Abstract/NAddOrder.v | 2 +- theories/Numbers/Natural/Abstract/NAxioms.v | 2 +- theories/Numbers/Natural/Abstract/NBase.v | 2 +- theories/Numbers/Natural/Abstract/NBits.v | 2 +- theories/Numbers/Natural/Abstract/NDefOps.v | 3 +- theories/Numbers/Natural/Abstract/NDiv.v | 2 +- theories/Numbers/Natural/Abstract/NGcd.v | 2 +- theories/Numbers/Natural/Abstract/NIso.v | 2 +- theories/Numbers/Natural/Abstract/NLcm.v | 2 +- theories/Numbers/Natural/Abstract/NLog.v | 2 +- theories/Numbers/Natural/Abstract/NMaxMin.v | 2 +- theories/Numbers/Natural/Abstract/NMulOrder.v | 2 +- theories/Numbers/Natural/Abstract/NOrder.v | 2 +- theories/Numbers/Natural/Abstract/NParity.v | 2 +- theories/Numbers/Natural/Abstract/NPow.v | 2 +- theories/Numbers/Natural/Abstract/NProperties.v | 23 +- theories/Numbers/Natural/Abstract/NSqrt.v | 2 +- theories/Numbers/Natural/Abstract/NStrongRec.v | 7 +- theories/Numbers/Natural/Abstract/NSub.v | 2 +- theories/Numbers/Natural/BigN/BigN.v | 20 +- theories/Numbers/Natural/BigN/NMake.v | 150 ++- theories/Numbers/Natural/BigN/NMake_gen.ml | 24 +- theories/Numbers/Natural/BigN/Nbasic.v | 5 +- theories/Numbers/Natural/Binary/NBinary.v | 2 +- theories/Numbers/Natural/Peano/NPeano.v | 806 +-------------- theories/Numbers/Natural/SpecViaZ/NSig.v | 2 +- theories/Numbers/Natural/SpecViaZ/NSigNAxioms.v | 2 +- theories/Numbers/NumPrelude.v | 2 +- theories/Numbers/Rational/BigQ/BigQ.v | 11 +- theories/Numbers/Rational/BigQ/QMake.v | 28 +- theories/Numbers/Rational/SpecViaQ/QSig.v | 4 +- theories/PArith/BinPos.v | 46 +- theories/PArith/BinPosDef.v | 42 +- theories/PArith/PArith.v | 2 +- theories/PArith/POrderedType.v | 2 +- theories/PArith/Pnat.v | 136 +-- theories/Program/Basics.v | 2 +- theories/Program/Combinators.v | 2 +- theories/Program/Equality.v | 4 +- theories/Program/Program.v | 2 +- theories/Program/Subset.v | 14 +- theories/Program/Syntax.v | 2 +- theories/Program/Tactics.v | 2 +- theories/Program/Utils.v | 2 +- theories/Program/Wf.v | 23 +- theories/QArith/QArith.v | 2 +- theories/QArith/QArith_base.v | 6 +- theories/QArith/QOrderedType.v | 2 +- theories/QArith/Qabs.v | 2 +- theories/QArith/Qcanon.v | 24 +- theories/QArith/Qfield.v | 2 +- theories/QArith/Qminmax.v | 2 +- theories/QArith/Qpower.v | 3 +- theories/QArith/Qreals.v | 33 +- theories/QArith/Qreduction.v | 4 +- theories/QArith/Qring.v | 2 +- theories/QArith/Qround.v | 2 +- theories/Reals/Alembert.v | 113 +-- theories/Reals/AltSeries.v | 16 +- theories/Reals/ArithProp.v | 23 +- theories/Reals/Binomial.v | 9 +- theories/Reals/Cauchy_prod.v | 2 +- theories/Reals/Cos_plus.v | 3 +- theories/Reals/Cos_rel.v | 78 +- theories/Reals/DiscrR.v | 5 +- theories/Reals/Exp_prop.v | 59 +- theories/Reals/Integration.v | 2 +- theories/Reals/LegacyRfield.v | 38 - theories/Reals/MVT.v | 119 ++- theories/Reals/Machin.v | 8 +- theories/Reals/NewtonInt.v | 304 +++--- theories/Reals/PSeries_reg.v | 349 ++++++- theories/Reals/PartSum.v | 65 +- theories/Reals/RIneq.v | 145 ++- theories/Reals/RList.v | 20 +- theories/Reals/ROrderedType.v | 4 +- theories/Reals/R_Ifp.v | 2 +- theories/Reals/R_sqr.v | 58 +- theories/Reals/R_sqrt.v | 11 +- theories/Reals/Ranalysis.v | 2 +- theories/Reals/Ranalysis1.v | 122 ++- theories/Reals/Ranalysis2.v | 9 +- theories/Reals/Ranalysis3.v | 4 +- theories/Reals/Ranalysis4.v | 58 +- theories/Reals/Ranalysis5.v | 97 +- theories/Reals/Ranalysis_reg.v | 7 +- theories/Reals/Ratan.v | 27 +- theories/Reals/Raxioms.v | 2 +- theories/Reals/Rbase.v | 2 +- theories/Reals/Rbasic_fun.v | 248 +++-- theories/Reals/Rcomplete.v | 45 +- theories/Reals/Rdefinitions.v | 2 +- theories/Reals/Rderiv.v | 16 +- theories/Reals/Reals.v | 2 +- theories/Reals/Rfunctions.v | 32 +- theories/Reals/Rgeom.v | 2 +- theories/Reals/RiemannInt.v | 774 +++++++-------- theories/Reals/RiemannInt_SF.v | 350 +++---- theories/Reals/Rlimit.v | 23 +- theories/Reals/Rlogic.v | 364 +++---- theories/Reals/Rminmax.v | 2 +- theories/Reals/Rpow_def.v | 2 +- theories/Reals/Rpower.v | 165 ++- theories/Reals/Rprod.v | 3 +- theories/Reals/Rseries.v | 39 +- theories/Reals/Rsigma.v | 3 +- theories/Reals/Rsqrt_def.v | 165 ++- theories/Reals/Rtopology.v | 326 +++--- theories/Reals/Rtrigo.v | 5 +- theories/Reals/Rtrigo1.v | 33 +- theories/Reals/Rtrigo_alt.v | 50 +- theories/Reals/Rtrigo_calc.v | 2 +- theories/Reals/Rtrigo_def.v | 6 +- theories/Reals/Rtrigo_fun.v | 149 ++- theories/Reals/Rtrigo_reg.v | 18 +- theories/Reals/SeqProp.v | 64 +- theories/Reals/SeqSeries.v | 68 +- theories/Reals/SplitAbsolu.v | 4 +- theories/Reals/SplitRmult.v | 2 +- theories/Reals/Sqrt_reg.v | 47 +- theories/Reals/vo.itarget | 1 - theories/Relations/Operators_Properties.v | 33 +- theories/Relations/Relation_Definitions.v | 2 +- theories/Relations/Relation_Operators.v | 18 +- theories/Relations/Relations.v | 2 +- theories/Setoids/Setoid.v | 5 +- theories/Sets/Classical_sets.v | 4 +- theories/Sets/Constructive_sets.v | 2 +- theories/Sets/Cpo.v | 8 +- theories/Sets/Ensembles.v | 2 +- theories/Sets/Finite_sets.v | 2 +- theories/Sets/Finite_sets_facts.v | 4 +- theories/Sets/Image.v | 4 +- theories/Sets/Infinite_sets.v | 4 +- theories/Sets/Integers.v | 4 +- theories/Sets/Multiset.v | 2 +- theories/Sets/Partial_Order.v | 6 +- theories/Sets/Permut.v | 2 +- theories/Sets/Powerset.v | 2 +- theories/Sets/Powerset_Classical_facts.v | 4 +- theories/Sets/Powerset_facts.v | 2 +- theories/Sets/Relations_1.v | 2 +- theories/Sets/Relations_1_facts.v | 2 +- theories/Sets/Relations_2.v | 2 +- theories/Sets/Relations_2_facts.v | 2 +- theories/Sets/Relations_3.v | 2 +- theories/Sets/Relations_3_facts.v | 2 +- theories/Sets/Uniset.v | 2 +- theories/Sorting/Heap.v | 12 +- theories/Sorting/Mergesort.v | 2 +- theories/Sorting/PermutEq.v | 8 +- theories/Sorting/PermutSetoid.v | 6 +- theories/Sorting/Permutation.v | 462 ++++++--- theories/Sorting/Sorted.v | 6 +- theories/Sorting/Sorting.v | 2 +- theories/Strings/Ascii.v | 7 +- theories/Strings/String.v | 6 +- theories/Structures/DecidableType.v | 4 +- theories/Structures/DecidableTypeEx.v | 2 +- theories/Structures/Equalities.v | 8 +- theories/Structures/EqualitiesFacts.v | 2 +- theories/Structures/GenericMinMax.v | 10 +- theories/Structures/OrderedType.v | 14 +- theories/Structures/OrderedTypeEx.v | 4 +- theories/Structures/Orders.v | 6 +- theories/Structures/OrdersEx.v | 8 +- theories/Structures/OrdersFacts.v | 4 +- theories/Structures/OrdersLists.v | 2 +- theories/Structures/OrdersTac.v | 9 +- theories/Unicode/Utf8.v | 2 +- theories/Unicode/Utf8_core.v | 4 +- theories/Vectors/Fin.v | 174 +++- theories/Vectors/Vector.v | 2 + theories/Vectors/VectorDef.v | 136 ++- theories/Vectors/VectorEq.v | 80 ++ theories/Vectors/VectorSpec.v | 12 +- theories/Vectors/vo.itarget | 1 + theories/Wellfounded/Disjoint_Union.v | 2 +- theories/Wellfounded/Inclusion.v | 2 +- theories/Wellfounded/Inverse_Image.v | 2 +- .../Wellfounded/Lexicographic_Exponentiation.v | 269 ++--- theories/Wellfounded/Lexicographic_Product.v | 2 +- theories/Wellfounded/Transitive_Closure.v | 2 +- theories/Wellfounded/Union.v | 2 +- theories/Wellfounded/Well_Ordering.v | 2 +- theories/Wellfounded/Wellfounded.v | 2 +- theories/ZArith/BinInt.v | 365 ++++--- theories/ZArith/BinIntDef.v | 10 +- theories/ZArith/Wf_Z.v | 10 +- theories/ZArith/ZArith.v | 2 +- theories/ZArith/ZArith_base.v | 2 +- theories/ZArith/ZArith_dec.v | 2 +- theories/ZArith/ZOdiv.v | 88 -- theories/ZArith/ZOdiv_def.v | 15 - theories/ZArith/Zabs.v | 2 +- theories/ZArith/Zbool.v | 2 +- theories/ZArith/Zcompare.v | 2 +- theories/ZArith/Zcomplements.v | 42 +- theories/ZArith/Zdigits.v | 15 +- theories/ZArith/Zdiv.v | 24 +- theories/ZArith/Zeuclid.v | 2 +- theories/ZArith/Zeven.v | 8 +- theories/ZArith/Zgcd_alt.v | 6 +- theories/ZArith/Zhints.v | 2 +- theories/ZArith/Zlogarithm.v | 4 +- theories/ZArith/Zmax.v | 2 +- theories/ZArith/Zmin.v | 2 +- theories/ZArith/Zminmax.v | 2 +- theories/ZArith/Zmisc.v | 2 +- theories/ZArith/Znat.v | 32 +- theories/ZArith/Znumtheory.v | 15 +- theories/ZArith/Zorder.v | 2 +- theories/ZArith/Zpow_alt.v | 8 +- theories/ZArith/Zpow_def.v | 2 +- theories/ZArith/Zpow_facts.v | 6 +- theories/ZArith/Zpower.v | 26 +- theories/ZArith/Zquot.v | 2 +- theories/ZArith/Zsqrt_compat.v | 14 +- theories/ZArith/Zwf.v | 2 +- theories/ZArith/auxiliary.v | 2 +- theories/ZArith/vo.itarget | 2 - 412 files changed, 12236 insertions(+), 7880 deletions(-) create mode 100644 theories/Arith/PeanoNat.v create mode 100644 theories/Classes/CEquivalence.v create mode 100644 theories/Classes/CMorphisms.v create mode 100644 theories/Classes/CRelationClasses.v create mode 100644 theories/Classes/DecidableClass.v create mode 100644 theories/Init/Nat.v create mode 100644 theories/Lists/ListDec.v delete mode 100644 theories/Logic/Classical_Pred_Set.v delete mode 100644 theories/Logic/Classical_Type.v create mode 100644 theories/Logic/FinFun.v create mode 100644 theories/Logic/WKL.v create mode 100644 theories/Logic/WeakFan.v delete mode 100644 theories/Reals/LegacyRfield.v create mode 100644 theories/Vectors/VectorEq.v delete mode 100644 theories/ZArith/ZOdiv.v delete mode 100644 theories/ZArith/ZOdiv_def.v (limited to 'theories') diff --git a/theories/Arith/Arith.v b/theories/Arith/Arith.v index 1ed22762..620a4201 100644 --- a/theories/Arith/Arith.v +++ b/theories/Arith/Arith.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* n} + {n = m} + {n > m}. Proof. - intros; apply lt_eq_lt_dec; assumption. + now apply lt_eq_lt_dec. Defined. Definition le_lt_dec n m : {n <= m} + {m < n}. Proof. induction n in m |- *. - auto with arith. - destruct m. - auto with arith. - elim (IHn m); auto with arith. + - left; auto with arith. + - destruct m. + + right; auto with arith. + + elim (IHn m); [left|right]; auto with arith. Defined. Definition le_le_S_dec n m : {n <= m} + {S m <= n}. Proof. - intros; exact (le_lt_dec n m). + exact (le_lt_dec n m). Defined. Definition le_ge_dec n m : {n <= m} + {n >= m}. Proof. - intros; elim (le_lt_dec n m); auto with arith. + elim (le_lt_dec n m); auto with arith. Defined. Definition le_gt_dec n m : {n <= m} + {n > m}. Proof. - intros; exact (le_lt_dec n m). + exact (le_lt_dec n m). Defined. Definition le_lt_eq_dec n m : n <= m -> {n < m} + {n = m}. @@ -62,162 +59,121 @@ Proof. intros; absurd (m < n); auto with arith. Defined. -Theorem le_dec : forall n m, {n <= m} + {~ n <= m}. +Theorem le_dec n m : {n <= m} + {~ n <= m}. Proof. - intros n m. destruct (le_gt_dec n m). - auto with arith. - right. apply gt_not_le. assumption. + destruct (le_gt_dec n m). + - now left. + - right. now apply gt_not_le. Defined. -Theorem lt_dec : forall n m, {n < m} + {~ n < m}. +Theorem lt_dec n m : {n < m} + {~ n < m}. Proof. - intros; apply le_dec. + apply le_dec. Defined. -Theorem gt_dec : forall n m, {n > m} + {~ n > m}. +Theorem gt_dec n m : {n > m} + {~ n > m}. Proof. - intros; apply lt_dec. + apply lt_dec. Defined. -Theorem ge_dec : forall n m, {n >= m} + {~ n >= m}. +Theorem ge_dec n m : {n >= m} + {~ n >= m}. Proof. - intros; apply le_dec. + apply le_dec. Defined. (** Proofs of decidability *) -Theorem dec_le : forall n m, decidable (n <= m). +Theorem dec_le n m : decidable (n <= m). Proof. - intros n m; destruct (le_dec n m); unfold decidable; auto. + apply Nat.le_decidable. Qed. -Theorem dec_lt : forall n m, decidable (n < m). +Theorem dec_lt n m : decidable (n < m). Proof. - intros; apply dec_le. + apply Nat.lt_decidable. Qed. -Theorem dec_gt : forall n m, decidable (n > m). +Theorem dec_gt n m : decidable (n > m). Proof. - intros; apply dec_lt. + apply Nat.lt_decidable. Qed. -Theorem dec_ge : forall n m, decidable (n >= m). +Theorem dec_ge n m : decidable (n >= m). Proof. - intros; apply dec_le. + apply Nat.le_decidable. Qed. -Theorem not_eq : forall n m, n <> m -> n < m \/ m < n. +Theorem not_eq n m : n <> m -> n < m \/ m < n. Proof. - intros x y H; elim (lt_eq_lt_dec x y); - [ intros H1; elim H1; - [ auto with arith | intros H2; absurd (x = y); assumption ] - | auto with arith ]. + apply Nat.lt_gt_cases. Qed. - -Theorem not_le : forall n m, ~ n <= m -> n > m. +Theorem not_le n m : ~ n <= m -> n > m. Proof. - intros x y H; elim (le_gt_dec x y); - [ intros H1; absurd (x <= y); assumption | trivial with arith ]. + apply Nat.nle_gt. Qed. -Theorem not_gt : forall n m, ~ n > m -> n <= m. +Theorem not_gt n m : ~ n > m -> n <= m. Proof. - intros x y H; elim (le_gt_dec x y); - [ trivial with arith | intros H1; absurd (x > y); assumption ]. + apply Nat.nlt_ge. Qed. -Theorem not_ge : forall n m, ~ n >= m -> n < m. +Theorem not_ge n m : ~ n >= m -> n < m. Proof. - intros x y H; exact (not_le y x H). + apply Nat.nle_gt. Qed. -Theorem not_lt : forall n m, ~ n < m -> n >= m. +Theorem not_lt n m : ~ n < m -> n >= m. Proof. - intros x y H; exact (not_gt y x H). + apply Nat.nlt_ge. Qed. -(** A ternary comparison function in the spirit of [Z.compare]. *) +(** 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 "?=" *) -Fixpoint nat_compare n m := - match n, m with - | O, O => Eq - | O, S _ => Lt - | S _, O => Gt - | S n', S m' => nat_compare n' m' - end. +Notation nat_compare := Nat.compare (compat "8.4"). -Lemma nat_compare_S : forall n m, nat_compare (S n) (S m) = nat_compare n m. -Proof. - reflexivity. -Qed. +Notation nat_compare_spec := Nat.compare_spec (compat "8.4"). +Notation nat_compare_eq_iff := Nat.compare_eq_iff (compat "8.4"). +Notation nat_compare_S := Nat.compare_succ (compat "8.4"). -Lemma nat_compare_eq_iff : forall n m, nat_compare n m = Eq <-> n = m. +Lemma nat_compare_lt n m : n (n ?= m) = Lt. Proof. - induction n; destruct m; simpl; split; auto; try discriminate; - destruct (IHn m); auto. + symmetry. apply Nat.compare_lt_iff. Qed. -Lemma nat_compare_eq : forall n m, nat_compare n m = Eq -> n = m. +Lemma nat_compare_gt n m : n>m <-> (n ?= m) = Gt. Proof. - intros; apply -> nat_compare_eq_iff; auto. + symmetry. apply Nat.compare_gt_iff. Qed. -Lemma nat_compare_lt : forall n m, n nat_compare n m = Lt. +Lemma nat_compare_le n m : n<=m <-> (n ?= m) <> Gt. Proof. - induction n; destruct m; simpl; split; auto with arith; - try solve [inversion 1]. - destruct (IHn m); auto with arith. - destruct (IHn m); auto with arith. + symmetry. apply Nat.compare_le_iff. Qed. -Lemma nat_compare_gt : forall n m, n>m <-> nat_compare n m = Gt. +Lemma nat_compare_ge n m : n>=m <-> (n ?= m) <> Lt. Proof. - induction n; destruct m; simpl; split; auto with arith; - try solve [inversion 1]. - destruct (IHn m); auto with arith. - destruct (IHn m); auto with arith. + symmetry. apply Nat.compare_ge_iff. Qed. -Lemma nat_compare_le : forall n m, n<=m <-> nat_compare n m <> Gt. -Proof. - split. - intros LE; contradict LE. - apply lt_not_le. apply <- nat_compare_gt; auto. - intros NGT. apply not_lt. contradict NGT. - apply -> nat_compare_gt; auto. -Qed. - -Lemma nat_compare_ge : forall n m, n>=m <-> nat_compare n m <> Lt. -Proof. - split. - intros GE; contradict GE. - apply lt_not_le. apply <- nat_compare_lt; auto. - intros NLT. apply not_lt. contradict NLT. - apply -> nat_compare_lt; auto. -Qed. +(** Some projections of the above equivalences. *) -Lemma nat_compare_spec : - forall x y, CompareSpec (x=y) (x n = m. Proof. - intros. - destruct (nat_compare x y) eqn:?; constructor. - apply nat_compare_eq; auto. - apply <- nat_compare_lt; auto. - apply <- nat_compare_gt; auto. + apply Nat.compare_eq_iff. Qed. -(** Some projections of the above equivalences. *) - -Lemma nat_compare_Lt_lt : forall n m, nat_compare n m = Lt -> n n n>m. +Lemma nat_compare_Gt_gt n m : (n ?= m) = Gt -> n>m. Proof. - intros; apply <- nat_compare_gt; auto. + apply Nat.compare_gt_iff. Qed. (** A previous definition of [nat_compare] in terms of [lt_eq_lt_dec]. @@ -230,70 +186,48 @@ Definition nat_compare_alt (n m:nat) := | inright _ => Gt end. -Lemma nat_compare_equiv: forall n m, - nat_compare n m = nat_compare_alt n m. +Lemma nat_compare_equiv n m : (n ?= m) = nat_compare_alt n m. Proof. - intros; unfold nat_compare_alt; destruct lt_eq_lt_dec as [[LT|EQ]|GT]. - apply -> nat_compare_lt; auto. - apply <- nat_compare_eq_iff; auto. - apply -> nat_compare_gt; auto. + 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 "<=?" *) -(** A boolean version of [le] over [nat]. *) - -Fixpoint leb (m:nat) : nat -> bool := - match m with - | O => fun _:nat => true - | S m' => - fun n:nat => match n with - | O => false - | S n' => leb m' n' - end - end. +Notation leb := Nat.leb (compat "8.4"). -Lemma leb_correct : forall m n, m <= n -> leb m n = true. -Proof. - induction m as [| m IHm]. trivial. - destruct n. intro H. elim (le_Sn_O _ H). - intros. simpl. apply IHm. apply le_S_n. assumption. -Qed. +Notation leb_iff := Nat.leb_le (compat "8.4"). -Lemma leb_complete : forall m n, leb m n = true -> m <= n. +Lemma leb_iff_conv m n : (n <=? m) = false <-> m < n. Proof. - induction m. trivial with arith. - destruct n. intro H. discriminate H. - auto with arith. + rewrite Nat.leb_nle. apply Nat.nle_gt. Qed. -Lemma leb_iff : forall m n, leb m n = true <-> m <= n. +Lemma leb_correct m n : m <= n -> (m <=? n) = true. Proof. - split; auto using leb_correct, leb_complete. + apply Nat.leb_le. Qed. -Lemma leb_correct_conv : forall m n, m < n -> leb n m = false. +Lemma leb_complete m n : (m <=? n) = true -> m <= n. Proof. - intros. - generalize (leb_complete n m). - destruct (leb n m); auto. - intros; elim (lt_not_le m n); auto. + apply Nat.leb_le. Qed. -Lemma leb_complete_conv : forall m n, leb n m = false -> m < n. +Lemma leb_correct_conv m n : m < n -> (n <=? m) = false. Proof. - intros m n EQ. apply not_le. - intro LE. apply leb_correct in LE. rewrite LE in EQ; discriminate. + apply leb_iff_conv. Qed. -Lemma leb_iff_conv : forall m n, leb n m = false <-> m < n. +Lemma leb_complete_conv m n : (n <=? m) = false -> m < n. Proof. - split; auto using leb_complete_conv, leb_correct_conv. + apply leb_iff_conv. Qed. -Lemma leb_compare : forall n m, leb n m = true <-> nat_compare n m <> Gt. +Lemma leb_compare n m : (n <=? m) = true <-> (n ?= m) <> Gt. Proof. - split; intros. - apply -> nat_compare_le. auto using leb_complete. - apply leb_correct. apply <- nat_compare_le; auto. + rewrite Nat.compare_le_iff. apply Nat.leb_le. Qed. - diff --git a/theories/Arith/Div2.v b/theories/Arith/Div2.v index 45fddd72..1c65a192 100644 --- a/theories/Arith/Div2.v +++ b/theories/Arith/Div2.v @@ -1,15 +1,16 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 0 - | S O => 0 - | S (S n') => S (div2 n') - end. +Notation div2 := Nat.div2 (compat "8.4"). (** Since [div2] is recursively defined on [0], [1] and [(S (S n))], it is useful to prove the corresponding induction principle *) @@ -31,53 +27,48 @@ Lemma ind_0_1_SS : forall P:nat -> Prop, P 0 -> P 1 -> (forall n, P n -> P (S (S n))) -> forall n, P n. Proof. - intros P H0 H1 Hn. - cut (forall n, P n /\ P (S n)). - intros H'n n. elim (H'n n). auto with arith. - - induction n. auto with arith. - intros. elim IHn; auto with arith. + intros P H0 H1 H2. + fix 1. + destruct n as [|[|n]]. + - exact H0. + - exact H1. + - apply H2, ind_0_1_SS. Qed. (** [0 n/2 < n] *) -Lemma lt_div2 : forall n, 0 < n -> div2 n < n. -Proof. - intro n. pattern n. apply ind_0_1_SS. - (* n = 0 *) - inversion 1. - (* n=1 *) - simpl; trivial. - (* n=S S n' *) - intro n'; case (zerop n'). - intro n'_eq_0. rewrite n'_eq_0. auto with arith. - auto with arith. -Qed. +Lemma lt_div2 n : 0 < n -> div2 n < n. +Proof. apply Nat.lt_div2. Qed. Hint Resolve lt_div2: arith. (** Properties related to the parity *) -Lemma even_div2 : forall n, even n -> div2 n = div2 (S n) -with odd_div2 : forall n, odd n -> S (div2 n) = div2 (S n). +Lemma even_div2 n : even n -> div2 n = div2 (S n). Proof. - destruct n; intro H. - (* 0 *) trivial. - (* S n *) inversion_clear H. apply odd_div2 in H0 as <-. trivial. - destruct n; intro. - (* 0 *) inversion H. - (* S n *) inversion_clear H. apply even_div2 in H0 as <-. trivial. + rewrite Even.even_equiv. intros (p,->). + rewrite Nat.div2_succ_double. apply Nat.div2_double. Qed. -Lemma div2_even n : div2 n = div2 (S n) -> even n -with div2_odd n : S (div2 n) = div2 (S n) -> odd n. +Lemma odd_div2 n : odd n -> S (div2 n) = div2 (S n). Proof. -{ destruct n; intro H. - - constructor. - - constructor. apply div2_odd. rewrite H. trivial. } -{ destruct n; intro H. - - discriminate. - - constructor. apply div2_even. injection H as <-. trivial. } + rewrite Even.odd_equiv. intros (p,->). + rewrite Nat.add_1_r, Nat.div2_succ_double. + simpl. f_equal. symmetry. apply Nat.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'. + elim (n_Sn _ 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'. elim (n_Sn _ Ev'). Qed. Hint Resolve even_div2 div2_even odd_div2 div2_odd: arith. @@ -93,58 +84,52 @@ Qed. (** Properties related to the double ([2n]) *) -Definition double n := n + n. +Notation double := Nat.double (compat "8.4"). -Hint Unfold double: arith. +Hint Unfold double Nat.double: arith. -Lemma double_S : forall n, double (S n) = S (S (double n)). +Lemma double_S n : double (S n) = S (S (double n)). Proof. - intro. unfold double. simpl. auto with arith. + apply Nat.add_succ_r. Qed. -Lemma double_plus : forall n (m:nat), double (n + m) = double n + double m. +Lemma double_plus n m : double (n + m) = double n + double m. Proof. - intros m n. unfold double. - do 2 rewrite plus_assoc_reverse. rewrite (plus_permute n). - reflexivity. + apply Nat.add_shuffle1. Qed. Hint Resolve double_S: arith. -Lemma even_odd_double : - forall n, - (even n <-> n = double (div2 n)) /\ (odd n <-> n = S (double (div2 n))). +Lemma even_odd_double n : + (even n <-> n = double (div2 n)) /\ (odd n <-> n = S (double (div2 n))). Proof. - intro n. pattern n. apply ind_0_1_SS. - (* n = 0 *) - split; split; auto with arith. - intro H. inversion H. - (* n = 1 *) - split; split; auto with arith. - intro H. inversion H. inversion H1. - (* n = (S (S n')) *) - intros. destruct H as ((IH1,IH2),(IH3,IH4)). - split; split. - intro H. inversion H. inversion H1. - simpl. rewrite (double_S (div2 n0)). auto with arith. - simpl. rewrite (double_S (div2 n0)). intro H. injection H. auto with arith. - intro H. inversion H. inversion H1. - simpl. rewrite (double_S (div2 n0)). auto with arith. - simpl. rewrite (double_S (div2 n0)). intro H. injection H. auto with arith. + revert n. fix 1. destruct n as [|[|n]]. + - (* n = 0 *) + split; split; auto with arith. inversion 1. + - (* n = 1 *) + split; split; auto with arith. inversion_clear 1. inversion H0. + - (* n = (S (S n')) *) + destruct (even_odd_double n) as ((Ev,Ev'),(Od,Od')). + split; split; simpl div2; rewrite ?double_S. + + inversion_clear 1. inversion_clear H0. auto. + + injection 1. auto with arith. + + inversion_clear 1. inversion_clear H0. auto. + + injection 1. auto with arith. Qed. + (** Specializations *) -Lemma even_double : forall n, even n -> n = double (div2 n). -Proof fun n => proj1 (proj1 (even_odd_double n)). +Lemma even_double n : even n -> n = double (div2 n). +Proof proj1 (proj1 (even_odd_double n)). -Lemma double_even : forall n, n = double (div2 n) -> even n. -Proof fun n => proj2 (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 : forall n, odd n -> n = S (double (div2 n)). -Proof fun n => proj1 (proj2 (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 : forall n, n = S (double (div2 n)) -> odd n. -Proof fun n => proj2 (proj2 (even_odd_double n)). +Lemma double_odd n : n = S (double (div2 n)) -> odd n. +Proof proj2 (proj2 (even_odd_double n)). Hint Resolve even_double double_even odd_double double_odd: arith. @@ -166,22 +151,8 @@ Defined. (** Doubling before dividing by two brings back to the initial number. *) -Lemma div2_double : forall n:nat, div2 (2*n) = n. -Proof. - induction n. - simpl; auto. - simpl. - replace (n+S(n+0)) with (S (2*n)). - f_equal; auto. - simpl; auto with arith. -Qed. +Lemma div2_double n : div2 (2*n) = n. +Proof. apply Nat.div2_double. Qed. -Lemma div2_double_plus_one : forall n:nat, div2 (S (2*n)) = n. -Proof. - induction n. - simpl; auto. - simpl. - replace (n+S(n+0)) with (S (2*n)). - f_equal; auto. - simpl; auto with arith. -Qed. +Lemma div2_double_plus_one n : div2 (S (2*n)) = n. +Proof. apply Nat.div2_succ_double. Qed. diff --git a/theories/Arith/EqNat.v b/theories/Arith/EqNat.v index 597cd287..2771670e 100644 --- a/theories/Arith/EqNat.v +++ b/theories/Arith/EqNat.v @@ -1,16 +1,15 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* eq_nat n1 m1 end. -Theorem eq_nat_refl : forall n, eq_nat n n. +Theorem eq_nat_refl n : eq_nat n n. +Proof. induction n; simpl; auto. Qed. Hint Resolve eq_nat_refl: arith v62. (** [eq] restricted to [nat] and [eq_nat] are equivalent *) -Lemma eq_eq_nat : forall n m, n = m -> eq_nat n m. - induction 1; trivial with arith. +Theorem eq_nat_is_eq n m : eq_nat n m <-> n = m. +Proof. + split. + - revert m; induction n; destruct m; simpl; contradiction || auto. + - intros <-; apply eq_nat_refl. Qed. -Hint Immediate eq_eq_nat: arith v62. -Lemma eq_nat_eq : forall n m, eq_nat n m -> n = m. - induction n; induction m; simpl; contradiction || auto with arith. +Lemma eq_eq_nat n m : n = m -> eq_nat n m. +Proof. + apply eq_nat_is_eq. Qed. -Hint Immediate eq_nat_eq: arith v62. -Theorem eq_nat_is_eq : forall n m, eq_nat n m <-> n = m. +Lemma eq_nat_eq n m : eq_nat n m -> n = m. Proof. - split; auto with arith. + apply eq_nat_is_eq. Qed. +Hint Immediate eq_eq_nat eq_nat_eq: arith v62. + Theorem eq_nat_elim : forall n (P:nat -> Prop), P n -> forall m, eq_nat n m -> P m. Proof. @@ -52,63 +56,47 @@ Qed. Theorem eq_nat_decide : forall n m, {eq_nat n m} + {~ eq_nat n m}. Proof. - induction n. - destruct m as [| n]. - auto with arith. - intros; right; red; trivial with arith. - destruct m as [| n0]. - right; red; auto with arith. - intros. - simpl. - apply IHn. + induction n; destruct m; simpl. + - left; trivial. + - right; intro; trivial. + - right; intro; trivial. + - apply IHn. Defined. -(** * Boolean equality on [nat] *) +(** * Boolean equality on [nat]. -Fixpoint beq_nat n m : bool := - match n, m with - | O, O => true - | O, S _ => false - | S _, O => false - | S n1, S m1 => beq_nat n1 m1 - end. + We reuse the one already defined in module [Nat]. + In scope [nat_scope], the notation "=?" can be used. *) -Lemma beq_nat_refl : forall n, true = beq_nat n n. -Proof. - intro x; induction x; simpl; auto. -Qed. +Notation beq_nat := Nat.eqb (compat "8.4"). -Definition beq_nat_eq : forall x y, true = beq_nat x y -> x = y. -Proof. - double induction x y; simpl. - reflexivity. - intros n H1 H2. discriminate H2. - intros n H1 H2. discriminate H2. - intros n H1 z H2 H3. case (H2 _ H3). reflexivity. -Defined. +Notation beq_nat_true_iff := Nat.eqb_eq (compat "8.4"). +Notation beq_nat_false_iff := Nat.eqb_neq (compat "8.4"). -Lemma beq_nat_true : forall x y, beq_nat x y = true -> x=y. +Lemma beq_nat_refl n : true = (n =? n). Proof. - induction x; destruct y; simpl; auto; intros; discriminate. + symmetry. apply Nat.eqb_refl. Qed. -Lemma beq_nat_false : forall x y, beq_nat x y = false -> x<>y. +Lemma beq_nat_true n m : (n =? m) = true -> n=m. Proof. - induction x; destruct y; simpl; auto; intros; discriminate. + apply Nat.eqb_eq. Qed. -Lemma beq_nat_true_iff : forall x y, beq_nat x y = true <-> x=y. +Lemma beq_nat_false n m : (n =? m) = false -> n<>m. Proof. - split. apply beq_nat_true. - intros; subst; symmetry; apply beq_nat_refl. + apply Nat.eqb_neq. Qed. -Lemma beq_nat_false_iff : forall x y, beq_nat x y = false <-> x<>y. +(** TODO: is it really useful here to have a Defined ? + Otherwise we could use Nat.eqb_eq *) + +Definition beq_nat_eq : forall n m, true = (n =? m) -> n = m. Proof. - intros x y. - split. apply beq_nat_false. - generalize (beq_nat_true_iff x y). - destruct beq_nat; auto. - intros IFF NEQ. elim NEQ. apply IFF; auto. -Qed. + induction n; destruct m; simpl. + - reflexivity. + - discriminate. + - discriminate. + - intros H. case (IHn _ H). reflexivity. +Defined. diff --git a/theories/Arith/Euclid.v b/theories/Arith/Euclid.v index 8748b726..eaacab02 100644 --- a/theories/Arith/Euclid.v +++ b/theories/Arith/Euclid.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 0 -> forall m:nat, diveucl m n. Proof. - intros b H a; pattern a; apply gt_wf_rec; intros n H0. - elim (le_gt_dec b n). - intro lebn. - elim (H0 (n - b)); auto with arith. - intros q r g e. - apply divex with (S q) r; simpl; auto with arith. - elim plus_assoc. - elim e; auto with arith. - intros gtbn. - apply divex with 0 n; simpl; auto with arith. + 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); auto with arith. + apply divex with (S q) r; trivial. + simpl; rewrite <- plus_assoc, <- Heq; auto with arith. + apply divex with 0 m; simpl; trivial. Defined. Lemma quotient : @@ -36,17 +32,12 @@ Lemma quotient : n > 0 -> forall m:nat, {q : nat | exists r : nat, m = q * n + r /\ n > r}. Proof. - intros b H a; pattern a; apply gt_wf_rec; intros n H0. - elim (le_gt_dec b n). - intro lebn. - elim (H0 (n - b)); auto with arith. - intros q Hq; exists (S q). - elim Hq; intros r Hr. - exists r; simpl; elim Hr; intros. - elim plus_assoc. - elim H1; auto with arith. - intros gtbn. - exists 0; exists n; simpl; auto with arith. + 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); auto with arith; exists (S q). + destruct Hq as (r & Heq & Hgt); exists r; split; trivial. + simpl; rewrite <- plus_assoc, <- Heq; auto with arith. + exists 0; exists m; simpl; auto with arith. Defined. Lemma modulo : @@ -54,15 +45,10 @@ Lemma modulo : n > 0 -> forall m:nat, {r : nat | exists q : nat, m = q * n + r /\ n > r}. Proof. - intros b H a; pattern a; apply gt_wf_rec; intros n H0. - elim (le_gt_dec b n). - intro lebn. - elim (H0 (n - b)); auto with arith. - intros r Hr; exists r. - elim Hr; intros q Hq. - elim Hq; intros; exists (S q); simpl. - elim plus_assoc. - elim H1; auto with arith. - intros gtbn. - exists n; exists 0; simpl; auto with arith. + 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); auto with arith; exists r. + destruct Hr as (q & Heq & Hgt); exists (S q); split; trivial. + simpl; rewrite <- plus_assoc, <- Heq; auto with arith. + exists m; exists 0; simpl; auto with arith. Defined. diff --git a/theories/Arith/Even.v b/theories/Arith/Even.v index 1e175971..0f94a8ed 100644 --- a/theories/Arith/Even.v +++ b/theories/Arith/Even.v @@ -1,21 +1,27 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* Prop := | even_O : even 0 @@ -26,225 +32,150 @@ with odd : nat -> Prop := Hint Constructors even: arith. Hint Constructors odd: arith. -Lemma even_or_odd : forall n, even n \/ odd n. +(** * Equivalence with predicates [Nat.Even] and [Nat.odd] *) + +Lemma even_equiv : forall n, even n <-> Nat.Even n. +Proof. + fix 1. + destruct n as [|[|n]]; simpl. + - split; [now exists 0 | constructor]. + - split. + + inversion_clear 1. inversion_clear H0. + + now rewrite <- Nat.even_spec. + - rewrite Nat.Even_succ_succ, <- even_equiv. + split. + + inversion_clear 1. now inversion_clear H0. + + now do 2 constructor. +Qed. + +Lemma odd_equiv : forall n, odd n <-> Nat.Odd n. +Proof. + fix 1. + 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_equiv. + split. + + inversion_clear 1. now inversion_clear H0. + + now do 2 constructor. +Qed. + +(** Basic facts *) + +Lemma even_or_odd n : even n \/ odd n. Proof. induction n. - auto with arith. - elim IHn; auto with arith. + - auto with arith. + - elim IHn; auto with arith. Qed. -Lemma even_odd_dec : forall n, {even n} + {odd n}. +Lemma even_odd_dec n : {even n} + {odd n}. Proof. induction n. - auto with arith. - elim IHn; auto with arith. + - auto with arith. + - elim IHn; auto with arith. Defined. -Lemma not_even_and_odd : forall n, even n -> odd n -> False. +Lemma not_even_and_odd n : even n -> odd n -> False. Proof. induction n. - intros even_0 odd_0. inversion odd_0. - intros even_Sn odd_Sn. inversion even_Sn. inversion odd_Sn. auto with arith. + - intros Ev Od. inversion Od. + - intros Ev Od. inversion Ev. inversion Od. auto with arith. Qed. (** * Facts about [even] & [odd] wrt. [plus] *) -Lemma even_plus_split : forall n m, - (even (n + m) -> even n /\ even m \/ odd n /\ odd m) -with odd_plus_split : forall n m, +Ltac parity2bool := + rewrite ?even_equiv, ?odd_equiv, <- ?Nat.even_spec, <- ?Nat.odd_spec. + +Ltac parity_binop_spec := + rewrite ?Nat.even_add, ?Nat.odd_add, ?Nat.even_mul, ?Nat.odd_mul. + +Ltac parity_binop := + parity2bool; parity_binop_spec; unfold Nat.odd; + do 2 destruct Nat.even; simpl; tauto. + + +Lemma even_plus_split n m : + even (n + m) -> even n /\ even m \/ odd n /\ odd m. +Proof. parity_binop. Qed. + +Lemma odd_plus_split n m : odd (n + m) -> odd n /\ even m \/ even n /\ odd m. -Proof. -intros. clear even_plus_split. destruct n; simpl in *. - auto with arith. - inversion_clear H; - apply odd_plus_split in H0 as [(H0,?)|(H0,?)]; auto with arith. -intros. clear odd_plus_split. destruct n; simpl in *. - auto with arith. - inversion_clear H; - apply even_plus_split in H0 as [(H0,?)|(H0,?)]; auto with arith. -Qed. +Proof. parity_binop. Qed. -Lemma even_even_plus : forall n m, even n -> even m -> even (n + m) -with odd_plus_l : forall n m, odd n -> even m -> odd (n + m). -Proof. -intros n m [|] ?. trivial. apply even_S, odd_plus_l; trivial. -intros n m [] ?. apply odd_S, even_even_plus; trivial. -Qed. +Lemma even_even_plus n m : even n -> even m -> even (n + m). +Proof. parity_binop. Qed. -Lemma odd_plus_r : forall n m, even n -> odd m -> odd (n + m) -with odd_even_plus : forall n m, odd n -> odd m -> even (n + m). -Proof. -intros n m [|] ?. trivial. apply odd_S, odd_even_plus; trivial. -intros n m [] ?. apply even_S, odd_plus_r; trivial. -Qed. +Lemma odd_plus_l n m : odd n -> even m -> odd (n + m). +Proof. parity_binop. Qed. + +Lemma odd_plus_r n m : even n -> odd m -> odd (n + m). +Proof. parity_binop. Qed. -Lemma even_plus_aux : forall n m, +Lemma odd_even_plus n m : odd n -> odd m -> even (n + m). +Proof. parity_binop. Qed. + +Lemma even_plus_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; auto using odd_plus_split, even_plus_split. -intros [[]|[]]; auto using odd_plus_r, odd_plus_l. -intros [[]|[]]; auto using even_even_plus, odd_even_plus. -Qed. +Proof. parity_binop. Qed. -Lemma even_plus_even_inv_r : forall n m, even (n + m) -> even n -> even m. -Proof. - intros n m H; destruct (even_plus_split n m) as [[]|[]]; auto. - intro; destruct (not_even_and_odd n); auto. -Qed. +Lemma even_plus_even_inv_r n m : even (n + m) -> even n -> even m. +Proof. parity_binop. Qed. -Lemma even_plus_even_inv_l : forall n m, even (n + m) -> even m -> even n. -Proof. - intros n m H; destruct (even_plus_split n m) as [[]|[]]; auto. - intro; destruct (not_even_and_odd m); auto. -Qed. +Lemma even_plus_even_inv_l n m : even (n + m) -> even m -> even n. +Proof. parity_binop. Qed. -Lemma even_plus_odd_inv_r : forall n m, even (n + m) -> odd n -> odd m. -Proof. - intros n m H; destruct (even_plus_split n m) as [[]|[]]; auto. - intro; destruct (not_even_and_odd n); auto. -Qed. +Lemma even_plus_odd_inv_r n m : even (n + m) -> odd n -> odd m. +Proof. parity_binop. Qed. -Lemma even_plus_odd_inv_l : forall n m, even (n + m) -> odd m -> odd n. -Proof. - intros n m H; destruct (even_plus_split n m) as [[]|[]]; auto. - intro; destruct (not_even_and_odd m); auto. -Qed. -Hint Resolve even_even_plus odd_even_plus: arith. +Lemma even_plus_odd_inv_l n m : even (n + m) -> odd m -> odd n. +Proof. parity_binop. Qed. -Lemma odd_plus_even_inv_l : forall n m, odd (n + m) -> odd m -> even n. -Proof. - intros n m H; destruct (odd_plus_split n m) as [[]|[]]; auto. - intro; destruct (not_even_and_odd m); auto. -Qed. +Lemma odd_plus_even_inv_l n m : odd (n + m) -> odd m -> even n. +Proof. parity_binop. Qed. -Lemma odd_plus_even_inv_r : forall n m, odd (n + m) -> odd n -> even m. -Proof. - intros n m H; destruct (odd_plus_split n m) as [[]|[]]; auto. - intro; destruct (not_even_and_odd n); auto. -Qed. +Lemma odd_plus_even_inv_r n m : odd (n + m) -> odd n -> even m. +Proof. parity_binop. Qed. -Lemma odd_plus_odd_inv_l : forall n m, odd (n + m) -> even m -> odd n. -Proof. - intros n m H; destruct (odd_plus_split n m) as [[]|[]]; auto. - intro; destruct (not_even_and_odd m); auto. -Qed. +Lemma odd_plus_odd_inv_l n m : odd (n + m) -> even m -> odd n. +Proof. parity_binop. Qed. -Lemma odd_plus_odd_inv_r : forall n m, odd (n + m) -> even n -> odd m. -Proof. - intros n m H; destruct (odd_plus_split n m) as [[]|[]]; auto. - intro; destruct (not_even_and_odd n); auto. -Qed. -Hint Resolve odd_plus_l odd_plus_r: arith. +Lemma odd_plus_odd_inv_r n m : odd (n + m) -> even n -> odd m. +Proof. parity_binop. Qed. (** * Facts about [even] and [odd] wrt. [mult] *) -Lemma even_mult_aux : - forall n m, - (odd (n * m) <-> odd n /\ odd m) /\ (even (n * m) <-> even n \/ even m). -Proof. - intros n; elim n; simpl; auto with arith. - intros m; split; split; auto with arith. - intros H'; inversion H'. - intros H'; elim H'; auto. - intros n0 H' m; split; split; auto with arith. - intros H'0. - elim (even_plus_aux m (n0 * m)); intros H'3 H'4; case H'3; intros H'1 H'2; - case H'1; auto. - intros H'5; elim H'5; intros H'6 H'7; auto with arith. - split; auto with arith. - case (H' m). - intros H'8 H'9; case H'9. - intros H'10; case H'10; auto with arith. - intros H'11 H'12; case (not_even_and_odd m); auto with arith. - intros H'5; elim H'5; intros H'6 H'7; case (not_even_and_odd (n0 * m)); auto. - case (H' m). - intros H'8 H'9; case H'9; auto. - intros H'0; elim H'0; intros H'1 H'2; clear H'0. - elim (even_plus_aux m (n0 * m)); auto. - intros H'0 H'3. - elim H'0. - intros H'4 H'5; apply H'5; auto. - left; split; auto with arith. - case (H' m). - intros H'6 H'7; elim H'7. - intros H'8 H'9; apply H'9. - left. - inversion H'1; auto. - intros H'0. - elim (even_plus_aux m (n0 * m)); intros H'3 H'4; case H'4. - intros H'1 H'2. - elim H'1; auto. - intros H; case H; auto. - intros H'5; elim H'5; intros H'6 H'7; auto with arith. - left. - case (H' m). - intros H'8; elim H'8. - intros H'9; elim H'9; auto with arith. - intros H'0; elim H'0; intros H'1. - case (even_or_odd m); intros H'2. - apply even_even_plus; auto. - case (H' m). - intros H H0; case H0; auto. - apply odd_even_plus; auto. - inversion H'1; case (H' m); auto. - intros H1; case H1; auto. - apply even_even_plus; auto. - case (H' m). - intros H H0; case H0; auto. -Qed. +Lemma even_mult_aux n m : + (odd (n * m) <-> odd n /\ odd m) /\ (even (n * m) <-> even n \/ even m). +Proof. parity_binop. Qed. -Lemma even_mult_l : forall n m, even n -> even (n * m). -Proof. - intros n m; case (even_mult_aux n m); auto. - intros H H0; case H0; auto. -Qed. +Lemma even_mult_l n m : even n -> even (n * m). +Proof. parity_binop. Qed. -Lemma even_mult_r : forall n m, even m -> even (n * m). -Proof. - intros n m; case (even_mult_aux n m); auto. - intros H H0; case H0; auto. -Qed. -Hint Resolve even_mult_l even_mult_r: arith. +Lemma even_mult_r n m : even m -> even (n * m). +Proof. parity_binop. Qed. -Lemma even_mult_inv_r : forall n m, even (n * m) -> odd n -> even m. -Proof. - intros n m H' H'0. - case (even_mult_aux n m). - intros H'1 H'2; elim H'2. - intros H'3; elim H'3; auto. - intros H; case (not_even_and_odd n); auto. -Qed. +Lemma even_mult_inv_r n m : even (n * m) -> odd n -> even m. +Proof. parity_binop. Qed. -Lemma even_mult_inv_l : forall n m, even (n * m) -> odd m -> even n. -Proof. - intros n m H' H'0. - case (even_mult_aux n m). - intros H'1 H'2; elim H'2. - intros H'3; elim H'3; auto. - intros H; case (not_even_and_odd m); auto. -Qed. +Lemma even_mult_inv_l n m : even (n * m) -> odd m -> even n. +Proof. parity_binop. Qed. -Lemma odd_mult : forall n m, odd n -> odd m -> odd (n * m). -Proof. - intros n m; case (even_mult_aux n m); intros H; case H; auto. -Qed. -Hint Resolve even_mult_l even_mult_r odd_mult: arith. +Lemma odd_mult n m : odd n -> odd m -> odd (n * m). +Proof. parity_binop. Qed. -Lemma odd_mult_inv_l : forall n m, odd (n * m) -> odd n. -Proof. - intros n m H'. - case (even_mult_aux n m). - intros H'1 H'2; elim H'1. - intros H'3; elim H'3; auto. -Qed. +Lemma odd_mult_inv_l n m : odd (n * m) -> odd n. +Proof. parity_binop. Qed. -Lemma odd_mult_inv_r : forall n m, odd (n * m) -> odd m. -Proof. - intros n m H'. - case (even_mult_aux n m). - intros H'1 H'2; elim H'1. - intros H'3; elim H'3; auto. -Qed. +Lemma odd_mult_inv_r n m : odd (n * m) -> odd m. +Proof. parity_binop. Qed. + +Hint Resolve + even_even_plus odd_even_plus odd_plus_l odd_plus_r + even_mult_l even_mult_r even_mult_l even_mult_r odd_mult : arith. diff --git a/theories/Arith/Factorial.v b/theories/Arith/Factorial.v index 870ea4e1..7d29f23c 100644 --- a/theories/Arith/Factorial.v +++ b/theories/Arith/Factorial.v @@ -1,14 +1,12 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 0. +Lemma fact_neq_0 n : fact n <> 0. Proof. - intro. - apply not_eq_sym. - apply lt_O_neq. - apply lt_O_fact. + apply Nat.neq_0_lt_0, lt_O_fact. Qed. -Lemma fact_le : forall n m:nat, n <= m -> fact n <= fact m. +Lemma fact_le n m : n <= m -> fact n <= fact m. Proof. induction 1. - apply le_n. - assert (1 * fact n <= S m * fact m). - apply mult_le_compat. - apply lt_le_S; apply lt_O_Sn. - assumption. - simpl (1 * fact n) in H0. - rewrite <- plus_n_O in H0. - assumption. + - apply le_n. + - simpl. transitivity (fact m). trivial. apply Nat.le_add_r. Qed. diff --git a/theories/Arith/Gt.v b/theories/Arith/Gt.v index afd146e7..e406ff0d 100644 --- a/theories/Arith/Gt.v +++ b/theories/Arith/Gt.v @@ -1,154 +1,145 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* > *) -Require Import Le. -Require Import Lt. -Require Import Plus. +Require Import PeanoNat Le Lt Plus. Local Open Scope nat_scope. -Implicit Types m n p : nat. - (** * Order and successor *) -Theorem gt_Sn_O : forall n, S n > 0. -Proof. - auto with arith. -Qed. -Hint Resolve gt_Sn_O: arith v62. +Theorem gt_Sn_O n : S n > 0. +Proof Nat.lt_0_succ _. -Theorem gt_Sn_n : forall n, S n > n. -Proof. - auto with arith. -Qed. -Hint Resolve gt_Sn_n: arith v62. +Theorem gt_Sn_n n : S n > n. +Proof Nat.lt_succ_diag_r _. -Theorem gt_n_S : forall n m, n > m -> S n > S m. +Theorem gt_n_S n m : n > m -> S n > S m. Proof. - auto with arith. + apply Nat.succ_lt_mono. Qed. -Hint Resolve gt_n_S: arith v62. -Lemma gt_S_n : forall n m, S m > S n -> m > n. +Lemma gt_S_n n m : S m > S n -> m > n. Proof. - auto with arith. + apply Nat.succ_lt_mono. Qed. -Hint Immediate gt_S_n: arith v62. -Theorem gt_S : forall n m, S n > m -> n > m \/ m = n. +Theorem gt_S n m : S n > m -> n > m \/ m = n. Proof. - intros n m H; unfold gt; apply le_lt_or_eq; auto with arith. + intro. now apply Nat.lt_eq_cases, Nat.succ_le_mono. Qed. -Lemma gt_pred : forall n m, m > S n -> pred m > n. +Lemma gt_pred n m : m > S n -> pred m > n. Proof. - auto with arith. + apply Nat.lt_succ_lt_pred. Qed. -Hint Immediate gt_pred: arith v62. (** * Irreflexivity *) -Lemma gt_irrefl : forall n, ~ n > n. -Proof lt_irrefl. -Hint Resolve gt_irrefl: arith v62. +Lemma gt_irrefl n : ~ n > n. +Proof Nat.lt_irrefl _. (** * Asymmetry *) -Lemma gt_asym : forall n m, n > m -> ~ m > n. -Proof fun n m => lt_asym m n. - -Hint Resolve gt_asym: arith v62. +Lemma gt_asym n m : n > m -> ~ m > n. +Proof Nat.lt_asymm _ _. (** * Relating strict and large orders *) -Lemma le_not_gt : forall n m, n <= m -> ~ n > m. -Proof le_not_lt. -Hint Resolve le_not_gt: arith v62. - -Lemma gt_not_le : forall n m, n > m -> ~ n <= m. +Lemma le_not_gt n m : n <= m -> ~ n > m. Proof. -auto with arith. + apply Nat.le_ngt. Qed. -Hint Resolve gt_not_le: arith v62. +Lemma gt_not_le n m : n > m -> ~ n <= m. +Proof. + apply Nat.lt_nge. +Qed. -Theorem le_S_gt : forall n m, S n <= m -> m > n. +Theorem le_S_gt n m : S n <= m -> m > n. Proof. - auto with arith. + apply Nat.le_succ_l. Qed. -Hint Immediate le_S_gt: arith v62. -Lemma gt_S_le : forall n m, S m > n -> n <= m. +Lemma gt_S_le n m : S m > n -> n <= m. Proof. - intros n p; exact (lt_n_Sm_le n p). + apply Nat.succ_le_mono. Qed. -Hint Immediate gt_S_le: arith v62. -Lemma gt_le_S : forall n m, m > n -> S n <= m. +Lemma gt_le_S n m : m > n -> S n <= m. Proof. - auto with arith. + apply Nat.le_succ_l. Qed. -Hint Resolve gt_le_S: arith v62. -Lemma le_gt_S : forall n m, n <= m -> S m > n. +Lemma le_gt_S n m : n <= m -> S m > n. Proof. - auto with arith. + apply Nat.succ_le_mono. Qed. -Hint Resolve le_gt_S: arith v62. (** * Transitivity *) -Theorem le_gt_trans : forall n m p, m <= n -> m > p -> n > p. +Theorem le_gt_trans n m p : m <= n -> m > p -> n > p. Proof. - red; intros; apply lt_le_trans with m; auto with arith. + intros. now apply Nat.lt_le_trans with m. Qed. -Theorem gt_le_trans : forall n m p, n > m -> p <= m -> n > p. +Theorem gt_le_trans n m p : n > m -> p <= m -> n > p. Proof. - red; intros; apply le_lt_trans with m; auto with arith. + intros. now apply Nat.le_lt_trans with m. Qed. -Lemma gt_trans : forall n m p, n > m -> m > p -> n > p. +Lemma gt_trans n m p : n > m -> m > p -> n > p. Proof. - red; intros n m p H1 H2. - apply lt_trans with m; auto with arith. + intros. now apply Nat.lt_trans with m. Qed. -Theorem gt_trans_S : forall n m p, S n > m -> m > p -> n > p. +Theorem gt_trans_S n m p : S n > m -> m > p -> n > p. Proof. - red; intros; apply lt_le_trans with m; auto with arith. + intros. apply Nat.lt_le_trans with m; trivial. now apply Nat.succ_le_mono. Qed. -Hint Resolve gt_trans_S le_gt_trans gt_le_trans: arith v62. - (** * Comparison to 0 *) -Theorem gt_0_eq : forall n, n > 0 \/ 0 = n. +Theorem gt_0_eq n : n > 0 \/ 0 = n. Proof. - intro n; apply gt_S; auto with arith. + destruct n; [now right | left; apply Nat.lt_0_succ]. Qed. (** * Simplification and compatibility *) -Lemma plus_gt_reg_l : forall n m p, p + n > p + m -> n > m. +Lemma plus_gt_reg_l n m p : p + n > p + m -> n > m. Proof. - red; intros n m p H; apply plus_lt_reg_l with p; auto with arith. + apply Nat.add_lt_mono_l. Qed. -Lemma plus_gt_compat_l : forall n m p, n > m -> p + n > p + m. +Lemma plus_gt_compat_l n m p : n > m -> p + n > p + m. Proof. - auto with arith. + apply Nat.add_lt_mono_l. Qed. + +(** * Hints *) + +Hint Resolve gt_Sn_O gt_Sn_n gt_n_S : arith v62. +Hint Immediate gt_S_n gt_pred : arith v62. +Hint Resolve gt_irrefl gt_asym : arith v62. +Hint Resolve le_not_gt gt_not_le : arith v62. +Hint Immediate le_S_gt gt_S_le : arith v62. +Hint Resolve gt_le_S le_gt_S : arith v62. +Hint Resolve gt_trans_S le_gt_trans gt_le_trans: arith v62. Hint Resolve plus_gt_compat_l: arith v62. (* begin hide *) diff --git a/theories/Arith/Le.v b/theories/Arith/Le.v index 6a3a583c..875863e4 100644 --- a/theories/Arith/Le.v +++ b/theories/Arith/Le.v @@ -1,12 +1,16 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* Prop := | le_n : n <= n @@ -14,110 +18,58 @@ Inductive le (n:nat) : nat -> Prop := where "n <= m" := (le n m) : nat_scope. >> - *) +*) -Local Open Scope nat_scope. +Require Import PeanoNat. -Implicit Types m n p : nat. +Local Open Scope nat_scope. -(** * [le] is a pre-order *) +(** * [le] is an order on [nat] *) -(** Reflexivity *) -Theorem le_refl : forall n, n <= n. -Proof. - exact le_n. -Qed. +Notation le_refl := Nat.le_refl (compat "8.4"). +Notation le_trans := Nat.le_trans (compat "8.4"). +Notation le_antisym := Nat.le_antisymm (compat "8.4"). -(** Transitivity *) -Theorem le_trans : forall n m p, n <= m -> m <= p -> n <= p. -Proof. - induction 2; auto. -Qed. Hint Resolve le_trans: arith v62. +Hint Immediate le_antisym: arith v62. -(** * Properties of [le] w.r.t. successor, predecessor and 0 *) - -(** Comparison to 0 *) - -Theorem le_0_n : forall n, 0 <= n. -Proof. - induction n; auto. -Qed. - -Theorem le_Sn_0 : forall n, ~ S n <= 0. -Proof. - red; intros n H. - change (IsSucc 0); elim H; simpl; auto with arith. -Qed. +(** * Properties of [le] w.r.t 0 *) -Hint Resolve le_0_n le_Sn_0: arith v62. +Notation le_0_n := Nat.le_0_l (compat "8.4"). (* 0 <= n *) +Notation le_Sn_0 := Nat.nle_succ_0 (compat "8.4"). (* ~ S n <= 0 *) -Theorem le_n_0_eq : forall n, n <= 0 -> 0 = n. +Lemma le_n_0_eq n : n <= 0 -> 0 = n. Proof. - induction n; auto with arith. - intro; contradiction le_Sn_0 with n. + intros. symmetry. now apply Nat.le_0_r. Qed. -Hint Immediate le_n_0_eq: arith v62. +(** * Properties of [le] w.r.t successor *) -(** [le] and successor *) +(** See also [Nat.succ_le_mono]. *) Theorem le_n_S : forall n m, n <= m -> S n <= S m. -Proof. - induction 1; auto. -Qed. +Proof Peano.le_n_S. -Theorem le_n_Sn : forall n, n <= S n. -Proof. - auto. -Qed. +Theorem le_S_n : forall n m, S n <= S m -> n <= m. +Proof Peano.le_S_n. -Hint Resolve le_n_S le_n_Sn : arith v62. +Notation le_n_Sn := Nat.le_succ_diag_r (compat "8.4"). (* n <= S n *) +Notation le_Sn_n := Nat.nle_succ_diag_l (compat "8.4"). (* ~ S n <= n *) Theorem le_Sn_le : forall n m, S n <= m -> n <= m. -Proof. - intros n m H; apply le_trans with (S n); auto with arith. -Qed. -Hint Immediate le_Sn_le: arith v62. +Proof Nat.lt_le_incl. -Theorem le_S_n : forall n m, S n <= S m -> n <= m. -Proof. - exact Peano.le_S_n. -Qed. -Hint Immediate le_S_n: arith v62. +Hint Resolve le_0_n le_Sn_0: arith v62. +Hint Resolve le_n_S le_n_Sn le_Sn_n : arith v62. +Hint Immediate le_n_0_eq le_Sn_le le_S_n : arith v62. -Theorem le_Sn_n : forall n, ~ S n <= n. -Proof. - induction n; auto with arith. -Qed. -Hint Resolve le_Sn_n: arith v62. +(** * Properties of [le] w.r.t predecessor *) -(** [le] and predecessor *) +Notation le_pred_n := Nat.le_pred_l (compat "8.4"). (* pred n <= n *) +Notation le_pred := Nat.pred_le_mono (compat "8.4"). (* n<=m -> pred n <= pred m *) -Theorem le_pred_n : forall n, pred n <= n. -Proof. - induction n; auto with arith. -Qed. Hint Resolve le_pred_n: arith v62. -Theorem le_pred : forall n m, n <= m -> pred n <= pred m. -Proof. - exact Peano.le_pred. -Qed. - -(** * [le] is a order on [nat] *) -(** Antisymmetry *) - -Theorem le_antisym : forall n m, n <= m -> m <= n -> n = m. -Proof. - intros n m H; destruct H as [|m' H]; auto with arith. - intros H1. - absurd (S m' <= m'); auto with arith. - apply le_trans with n; auto with arith. -Qed. -Hint Immediate le_antisym: arith v62. - - (** * A different elimination principle for the order on natural numbers *) Lemma le_elim_rel : @@ -126,10 +78,10 @@ Lemma le_elim_rel : (forall p (q:nat), p <= q -> P p q -> P (S p) (S q)) -> forall n m, n <= m -> P n m. Proof. - induction n; auto with arith. - intros m Le. - elim Le; auto with arith. -Qed. + intros P H0 HS. + induction n; trivial. + intros m Le. elim Le; auto with arith. + Qed. (* begin hide *) Notation le_O_n := le_0_n (only parsing). diff --git a/theories/Arith/Lt.v b/theories/Arith/Lt.v index 3ce42a6e..b783ca33 100644 --- a/theories/Arith/Lt.v +++ b/theories/Arith/Lt.v @@ -1,190 +1,154 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* > *) -Require Import Le. -Local Open Scope nat_scope. +Require Import PeanoNat. -Implicit Types m n p : nat. +Local Open Scope nat_scope. (** * Irreflexivity *) -Theorem lt_irrefl : forall n, ~ n < n. -Proof le_Sn_n. +Notation lt_irrefl := Nat.lt_irrefl (compat "8.4"). (* ~ x < x *) + Hint Resolve lt_irrefl: arith v62. (** * Relationship between [le] and [lt] *) -Theorem lt_le_S : forall n m, n < m -> S n <= m. +Theorem lt_le_S n m : n < m -> S n <= m. Proof. - auto with arith. + apply Nat.le_succ_l. Qed. -Hint Immediate lt_le_S: arith v62. -Theorem lt_n_Sm_le : forall n m, n < S m -> n <= m. +Theorem lt_n_Sm_le n m : n < S m -> n <= m. Proof. - auto with arith. + apply Nat.lt_succ_r. Qed. -Hint Immediate lt_n_Sm_le: arith v62. -Theorem le_lt_n_Sm : forall n m, n <= m -> n < S m. +Theorem le_lt_n_Sm n m : n <= m -> n < S m. Proof. - auto with arith. + apply Nat.lt_succ_r. Qed. + +Hint Immediate lt_le_S: arith v62. +Hint Immediate lt_n_Sm_le: arith v62. Hint Immediate le_lt_n_Sm: arith v62. -Theorem le_not_lt : forall n m, n <= m -> ~ m < n. +Theorem le_not_lt n m : n <= m -> ~ m < n. Proof. - induction 1; auto with arith. + apply Nat.le_ngt. Qed. -Theorem lt_not_le : forall n m, n < m -> ~ m <= n. +Theorem lt_not_le n m : n < m -> ~ m <= n. Proof. - red; intros n m Lt Le; exact (le_not_lt m n Le Lt). + apply Nat.lt_nge. Qed. + Hint Immediate le_not_lt lt_not_le: arith v62. (** * Asymmetry *) -Theorem lt_asym : forall n m, n < m -> ~ m < n. -Proof. - induction 1; auto with arith. -Qed. +Notation lt_asym := Nat.lt_asymm (compat "8.4"). (* n ~m n < S m. +Theorem neq_0_lt n : 0 <> n -> 0 < n. Proof. - auto with arith. + intros. now apply Nat.neq_0_lt_0, Nat.neq_sym. Qed. -Hint Resolve lt_S: arith v62. -Theorem lt_n_S : forall n m, n < m -> S n < S m. +Theorem lt_0_neq n : 0 < n -> 0 <> n. Proof. - auto with arith. + intros. now apply Nat.neq_sym, Nat.neq_0_lt_0. Qed. -Hint Resolve lt_n_S: arith v62. -Theorem lt_S_n : forall n m, S n < S m -> n < m. +Hint Resolve lt_0_Sn lt_n_0 : arith v62. +Hint Immediate neq_0_lt lt_0_neq: arith v62. + +(** * Order and successor *) + +Notation lt_n_Sn := Nat.lt_succ_diag_r (compat "8.4"). (* n < S n *) +Notation lt_S := Nat.lt_lt_succ_r (compat "8.4"). (* n < m -> n < S m *) + +Theorem lt_n_S n m : n < m -> S n < S m. Proof. - auto with arith. + apply Nat.succ_lt_mono. Qed. -Hint Immediate lt_S_n: arith v62. -Theorem lt_0_Sn : forall n, 0 < S n. +Theorem lt_S_n n m : S n < S m -> n < m. Proof. - auto with arith. + apply Nat.succ_lt_mono. Qed. -Hint Resolve lt_0_Sn: arith v62. -Theorem lt_n_0 : forall n, ~ n < 0. -Proof le_Sn_0. -Hint Resolve lt_n_0: arith v62. +Hint Resolve lt_n_Sn lt_S lt_n_S : arith v62. +Hint Immediate lt_S_n : arith v62. (** * Predecessor *) -Lemma S_pred : forall n m, m < n -> n = S (pred n). +Lemma S_pred n m : m < n -> n = S (pred n). Proof. -induction 1; auto with arith. + intros. symmetry. now apply Nat.lt_succ_pred with m. Qed. -Lemma lt_pred : forall n m, S n < m -> n < pred m. +Lemma lt_pred n m : S n < m -> n < pred m. Proof. -induction 1; simpl; auto with arith. + apply Nat.lt_succ_lt_pred. Qed. -Hint Immediate lt_pred: arith v62. -Lemma lt_pred_n_n : forall n, 0 < n -> pred n < n. -destruct 1; simpl; auto with arith. +Lemma lt_pred_n_n n : 0 < n -> pred n < n. +Proof. + intros. now apply Nat.lt_pred_l, Nat.neq_0_lt_0. Qed. + +Hint Immediate lt_pred: arith v62. Hint Resolve lt_pred_n_n: arith v62. (** * Transitivity properties *) -Theorem lt_trans : forall n m p, n < m -> m < p -> n < p. -Proof. - induction 2; auto with arith. -Qed. - -Theorem lt_le_trans : forall n m p, n < m -> m <= p -> n < p. -Proof. - induction 2; auto with arith. -Qed. - -Theorem le_lt_trans : forall n m p, n <= m -> m < p -> n < p. -Proof. - induction 2; auto with arith. -Qed. +Notation lt_trans := Nat.lt_trans (compat "8.4"). +Notation lt_le_trans := Nat.lt_le_trans (compat "8.4"). +Notation le_lt_trans := Nat.le_lt_trans (compat "8.4"). Hint Resolve lt_trans lt_le_trans le_lt_trans: arith v62. (** * Large = strict or equal *) -Theorem le_lt_or_eq : forall n m, n <= m -> n < m \/ n = m. -Proof. - induction 1; auto with arith. -Qed. +Notation le_lt_or_eq_iff := Nat.lt_eq_cases (compat "8.4"). -Theorem le_lt_or_eq_iff : forall n m, n <= m <-> n < m \/ n = m. +Theorem le_lt_or_eq n m : n <= m -> n < m \/ n = m. Proof. - split. - intros; apply le_lt_or_eq; auto. - destruct 1; subst; auto with arith. + apply Nat.lt_eq_cases. Qed. -Theorem lt_le_weak : forall n m, n < m -> n <= m. -Proof. - auto with arith. -Qed. +Notation lt_le_weak := Nat.lt_le_incl (compat "8.4"). + Hint Immediate lt_le_weak: arith v62. (** * Dichotomy *) -Theorem le_or_lt : forall n m, n <= m \/ m < n. -Proof. - intros n m; pattern n, m; apply nat_double_ind; auto with arith. - induction 1; auto with arith. -Qed. - -Theorem nat_total_order : forall n m, n <> m -> n < m \/ m < n. -Proof. - intros m n diff. - elim (le_or_lt n m); [ intro H'0 | auto with arith ]. - elim (le_lt_or_eq n m); auto with arith. - intro H'; elim diff; auto with arith. -Qed. - -(** * Comparison to 0 *) +Notation le_or_lt := Nat.le_gt_cases (compat "8.4"). (* n <= m \/ m < n *) -Theorem neq_0_lt : forall n, 0 <> n -> 0 < n. +Theorem nat_total_order n m : n <> m -> n < m \/ m < n. Proof. - induction n; auto with arith. - intros; absurd (0 = 0); trivial with arith. + apply Nat.lt_gt_cases. Qed. -Hint Immediate neq_0_lt: arith v62. - -Theorem lt_0_neq : forall n, 0 < n -> 0 <> n. -Proof. - induction 1; auto with arith. -Qed. -Hint Immediate lt_0_neq: arith v62. (* begin hide *) Notation lt_O_Sn := lt_0_Sn (only parsing). @@ -192,3 +156,7 @@ Notation neq_O_lt := neq_0_lt (only parsing). Notation lt_O_neq := lt_0_neq (only parsing). Notation lt_n_O := lt_n_0 (only parsing). (* end hide *) + +(** For compatibility, we "Require" the same files as before *) + +Require Import Le. diff --git a/theories/Arith/Max.v b/theories/Arith/Max.v index 721428e5..26875373 100644 --- a/theories/Arith/Max.v +++ b/theories/Arith/Max.v @@ -1,19 +1,19 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* n - | S k, O => S k | S k, S l => k - l + | _, _ => n end -where "n - m" := (minus n m) : nat_scope. +where "n - m" := (sub n m) : nat_scope. >> *) -Require Import Lt. -Require Import Le. +Require Import PeanoNat Lt Le. Local Open Scope nat_scope. -Implicit Types m n p : nat. - (** * 0 is right neutral *) -Lemma minus_n_O : forall n, n = n - 0. +Lemma minus_n_O n : n = n - 0. Proof. - induction n; simpl; auto with arith. + symmetry. apply Nat.sub_0_r. Qed. -Hint Resolve minus_n_O: arith v62. (** * Permutation with successor *) -Lemma minus_Sn_m : forall n m, m <= n -> S (n - m) = S n - m. +Lemma minus_Sn_m n m : m <= n -> S (n - m) = S n - m. Proof. - intros n m Le; pattern m, n; apply le_elim_rel; simpl; - auto with arith. + intros. symmetry. now apply Nat.sub_succ_l. Qed. -Hint Resolve minus_Sn_m: arith v62. -Theorem pred_of_minus : forall n, pred n = n - 1. +Theorem pred_of_minus n : pred n = n - 1. Proof. - intro x; induction x; simpl; auto with arith. + symmetry. apply Nat.sub_1_r. Qed. (** * Diagonal *) -Lemma minus_diag : forall n, n - n = 0. -Proof. - induction n; simpl; auto with arith. -Qed. +Notation minus_diag := Nat.sub_diag (compat "8.4"). (* n - n = 0 *) -Lemma minus_diag_reverse : forall n, 0 = n - n. +Lemma minus_diag_reverse n : 0 = n - n. Proof. - auto using minus_diag. + symmetry. apply Nat.sub_diag. Qed. -Hint Resolve minus_diag_reverse: arith v62. Notation minus_n_n := minus_diag_reverse. (** * Simplification *) -Lemma minus_plus_simpl_l_reverse : forall n m p, n - m = p + n - (p + m). +Lemma minus_plus_simpl_l_reverse n m p : n - m = p + n - (p + m). Proof. - induction p; simpl; auto with arith. + now rewrite Nat.sub_add_distr, Nat.add_comm, Nat.add_sub. Qed. -Hint Resolve minus_plus_simpl_l_reverse: arith v62. (** * Relation with plus *) -Lemma plus_minus : forall n m p, n = m + p -> p = n - m. +Lemma plus_minus n m p : n = m + p -> p = n - m. Proof. - intros n m p; pattern m, n; apply nat_double_ind; simpl; - intros. - replace (n0 - 0) with n0; auto with arith. - absurd (0 = S (n0 + p)); auto with arith. - auto with arith. + symmetry. now apply Nat.add_sub_eq_l. Qed. -Hint Immediate plus_minus: arith v62. -Lemma minus_plus : forall n m, n + m - n = m. - symmetry ; auto with arith. +Lemma minus_plus n m : n + m - n = m. +Proof. + rewrite Nat.add_comm. apply Nat.add_sub. Qed. -Hint Resolve minus_plus: arith v62. -Lemma le_plus_minus : forall n m, n <= m -> m = n + (m - n). +Lemma le_plus_minus_r n m : n <= m -> n + (m - n) = m. Proof. - intros n m Le; pattern n, m; apply le_elim_rel; simpl; - auto with arith. + rewrite Nat.add_comm. apply Nat.sub_add. Qed. -Hint Resolve le_plus_minus: arith v62. -Lemma le_plus_minus_r : forall n m, n <= m -> n + (m - n) = m. +Lemma le_plus_minus n m : n <= m -> m = n + (m - n). Proof. - symmetry ; auto with arith. + intros. symmetry. rewrite Nat.add_comm. now apply Nat.sub_add. Qed. -Hint Resolve le_plus_minus_r: arith v62. (** * Relation with order *) -Theorem minus_le_compat_r : forall n m p : nat, n <= m -> n - p <= m - p. -Proof. - intros n m p; generalize n m; clear n m; induction p as [|p HI]. - intros n m; rewrite <- (minus_n_O n); rewrite <- (minus_n_O m); trivial. - - intros n m Hnm; apply le_elim_rel with (n:=n) (m:=m); auto with arith. - intros q r H _. simpl. auto using HI. -Qed. - -Theorem minus_le_compat_l : forall n m p : nat, n <= m -> p - m <= p - n. -Proof. - intros n m p; generalize n m; clear n m; induction p as [|p HI]. - trivial. +Notation minus_le_compat_r := + Nat.sub_le_mono_r (compat "8.4"). (* n <= m -> n - p <= m - p. *) - intros n m Hnm; apply le_elim_rel with (n:=n) (m:=m); trivial. - intros q; destruct q; auto with arith. - simpl. - apply le_trans with (m := p - 0); [apply HI | rewrite <- minus_n_O]; - auto with arith. +Notation minus_le_compat_l := + Nat.sub_le_mono_l (compat "8.4"). (* n <= m -> p - m <= p - n. *) - intros q r Hqr _. simpl. auto using HI. -Qed. +Notation le_minus := Nat.le_sub_l (compat "8.4"). (* n - m <= n *) +Notation lt_minus := Nat.sub_lt (compat "8.4"). (* m <= n -> 0 < m -> n-m < n *) -Corollary le_minus : forall n m, n - m <= n. +Lemma lt_O_minus_lt n m : 0 < n - m -> m < n. Proof. - intros n m; rewrite minus_n_O; auto using minus_le_compat_l with arith. + apply Nat.lt_add_lt_sub_r. Qed. -Lemma lt_minus : forall n m, m <= n -> 0 < m -> n - m < n. +Theorem not_le_minus_0 n m : ~ m <= n -> n - m = 0. Proof. - intros n m Le; pattern m, n; apply le_elim_rel; simpl; - auto using le_minus with arith. - intros; absurd (0 < 0); auto with arith. + intros. now apply Nat.sub_0_le, Nat.lt_le_incl, Nat.lt_nge. Qed. -Hint Resolve lt_minus: arith v62. -Lemma lt_O_minus_lt : forall n m, 0 < n - m -> m < n. -Proof. - intros n m; pattern n, m; apply nat_double_ind; simpl; - auto with arith. - intros; absurd (0 < 0); trivial with arith. -Qed. -Hint Immediate lt_O_minus_lt: arith v62. +(** * Hints *) -Theorem not_le_minus_0 : forall n m, ~ m <= n -> n - m = 0. -Proof. - intros y x; pattern y, x; apply nat_double_ind; - [ simpl; trivial with arith - | intros n H; absurd (0 <= S n); [ assumption | apply le_O_n ] - | simpl; intros n m H1 H2; apply H1; unfold not; intros H3; - apply H2; apply le_n_S; assumption ]. -Qed. +Hint Resolve minus_n_O: arith v62. +Hint Resolve minus_Sn_m: arith v62. +Hint Resolve minus_diag_reverse: arith v62. +Hint Resolve minus_plus_simpl_l_reverse: arith v62. +Hint Immediate plus_minus: arith v62. +Hint Resolve minus_plus: arith v62. +Hint Resolve le_plus_minus: arith v62. +Hint Resolve le_plus_minus_r: arith v62. +Hint Resolve lt_minus: arith v62. +Hint Immediate lt_O_minus_lt: arith v62. diff --git a/theories/Arith/Mult.v b/theories/Arith/Mult.v index 588afde3..2d82920b 100644 --- a/theories/Arith/Mult.v +++ b/theories/Arith/Mult.v @@ -1,220 +1,144 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* n = 0 \/ m = 0. +Lemma mult_is_O n m : n * m = 0 -> n = 0 \/ m = 0. Proof. - destruct n as [| n]; simpl; intros m H. - left; trivial. - right; apply plus_is_O in H; destruct H; trivial. + apply Nat.eq_mul_0. Qed. -Lemma mult_is_one : forall n m, n * m = 1 -> n = 1 /\ m = 1. +Lemma mult_is_one n m : n * m = 1 -> n = 1 /\ m = 1. Proof. - destruct n as [|n]; simpl; intros m H. - edestruct O_S; eauto. - destruct plus_is_one with (1:=H) as [[-> Hnm] | [-> Hnm]]. - simpl in H; rewrite mult_0_r in H; elim (O_S _ H). - rewrite mult_1_r in Hnm; auto. + apply Nat.eq_mul_1. Qed. (** ** Multiplication and successor *) -Lemma mult_succ_l : forall n m:nat, S n * m = n * m + m. -Proof. - intros; simpl. rewrite plus_comm. reflexivity. -Qed. - -Lemma mult_succ_r : forall n m:nat, n * S m = n * m + n. -Proof. - induction n as [| p H]; intro m; simpl. - reflexivity. - rewrite H, <- plus_n_Sm; apply f_equal; rewrite plus_assoc; reflexivity. -Qed. +Notation mult_succ_l := Nat.mul_succ_l (compat "8.4"). (* S n * m = n * m + m *) +Notation mult_succ_r := Nat.mul_succ_r (compat "8.4"). (* n * S m = n * m + n *) (** * Compatibility with orders *) -Lemma mult_O_le : forall n m, m = 0 \/ n <= m * n. +Lemma mult_O_le n m : m = 0 \/ n <= m * n. Proof. - induction m; simpl; auto with arith. + destruct m; [left|right]; simpl; trivial using Nat.le_add_r. Qed. Hint Resolve mult_O_le: arith v62. -Lemma mult_le_compat_l : forall n m p, n <= m -> p * n <= p * m. +Lemma mult_le_compat_l n m p : n <= m -> p * n <= p * m. Proof. - induction p as [| p IHp]; intros; simpl. - apply le_n. - auto using plus_le_compat. + apply Nat.mul_le_mono_nonneg_l, Nat.le_0_l. (* TODO : get rid of 0<=n hyp *) Qed. Hint Resolve mult_le_compat_l: arith. - -Lemma mult_le_compat_r : forall n m p, n <= m -> n * p <= m * p. +Lemma mult_le_compat_r n m p : n <= m -> n * p <= m * p. Proof. - intros m n p H; rewrite mult_comm, (mult_comm n); auto with arith. + apply Nat.mul_le_mono_nonneg_r, Nat.le_0_l. Qed. -Lemma mult_le_compat : - forall n m p (q:nat), n <= m -> p <= q -> n * p <= m * q. +Lemma mult_le_compat n m p q : n <= m -> p <= q -> n * p <= m * q. Proof. - intros m n p q Hmn Hpq; induction Hmn. - induction Hpq. - (* m*p<=m*p *) - apply le_n. - (* m*p<=m*m0 -> m*p<=m*(S m0) *) - rewrite <- mult_n_Sm; apply le_trans with (m * m0). - assumption. - apply le_plus_l. - (* m*p<=m0*q -> m*p<=(S m0)*q *) - simpl; apply le_trans with (m0 * q). - assumption. - apply le_plus_r. + intros. apply Nat.mul_le_mono_nonneg; trivial; apply Nat.le_0_l. Qed. -Lemma mult_S_lt_compat_l : forall n m p, m < p -> S n * m < S n * p. +Lemma mult_S_lt_compat_l n m p : m < p -> S n * m < S n * p. Proof. - induction n; intros; simpl in *. - rewrite <- 2 plus_n_O; assumption. - auto using plus_lt_compat. + apply Nat.mul_lt_mono_pos_l, Nat.lt_0_succ. Qed. Hint Resolve mult_S_lt_compat_l: arith. -Lemma mult_lt_compat_l : forall n m p, n < m -> 0 < p -> p * n < p * m. +Lemma mult_lt_compat_l n m p : n < m -> 0 < p -> p * n < p * m. Proof. - intros m n p H Hp. destruct p. elim (lt_irrefl _ Hp). - now apply mult_S_lt_compat_l. + intros. now apply Nat.mul_lt_mono_pos_l. Qed. -Lemma mult_lt_compat_r : forall n m p, n < m -> 0 < p -> n * p < m * p. +Lemma mult_lt_compat_r n m p : n < m -> 0 < p -> n * p < m * p. Proof. - intros m n p H Hp. destruct p. elim (lt_irrefl _ Hp). - rewrite (mult_comm m), (mult_comm n). now apply mult_S_lt_compat_l. + intros. now apply Nat.mul_lt_mono_pos_r. Qed. -Lemma mult_S_le_reg_l : forall n m p, S n * m <= S n * p -> m <= p. +Lemma mult_S_le_reg_l n m p : S n * m <= S n * p -> m <= p. Proof. - intros m n p H; destruct (le_or_lt n p). trivial. - assert (H1:S m * n < S m * n). - apply le_lt_trans with (m := S m * p). assumption. - apply mult_S_lt_compat_l. assumption. - elim (lt_irrefl _ H1). + apply Nat.mul_le_mono_pos_l, Nat.lt_0_succ. Qed. (** * n|->2*n and n|->2n+1 have disjoint image *) -Theorem odd_even_lem : forall p q, 2 * p + 1 <> 2 * q. +Theorem odd_even_lem p q : 2 * p + 1 <> 2 * q. Proof. - induction p; destruct q. - discriminate. - simpl; rewrite plus_comm. discriminate. - discriminate. - intro H0; destruct (IHp q). - replace (2 * q) with (2 * S q - 2). - rewrite <- H0; simpl. - repeat rewrite (fun x y => plus_comm x (S y)); simpl; auto. - simpl; rewrite (fun y => plus_comm q (S y)); destruct q; simpl; auto. + intro. apply (Nat.Even_Odd_False (2*q)). + - now exists q. + - now exists p. Qed. @@ -232,10 +156,9 @@ Fixpoint mult_acc (s:nat) m n : nat := Lemma mult_acc_aux : forall n m p, m + n * p = mult_acc m p n. Proof. - induction n as [| p IHp]; simpl; auto. - intros s m; rewrite <- plus_tail_plus; rewrite <- IHp. - rewrite <- plus_assoc_reverse; apply f_equal2; auto. - rewrite plus_comm; auto. + induction n as [| n IHn]; simpl; auto. + intros. rewrite Nat.add_assoc, IHn. f_equal. + rewrite Nat.add_comm. apply plus_tail_plus. Qed. Definition tail_mult n m := mult_acc 0 m n. diff --git a/theories/Arith/PeanoNat.v b/theories/Arith/PeanoNat.v new file mode 100644 index 00000000..799031a2 --- /dev/null +++ b/theories/Arith/PeanoNat.v @@ -0,0 +1,755 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* eq) S. +Program Instance pred_wd : Proper (eq==>eq) pred. +Program Instance add_wd : Proper (eq==>eq==>eq) plus. +Program Instance sub_wd : Proper (eq==>eq==>eq) minus. +Program Instance mul_wd : Proper (eq==>eq==>eq) mult. +Program Instance pow_wd : Proper (eq==>eq==>eq) pow. +Program Instance div_wd : Proper (eq==>eq==>eq) div. +Program Instance mod_wd : Proper (eq==>eq==>eq) modulo. +Program Instance lt_wd : Proper (eq==>eq==>iff) lt. +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 fonction *) + +Definition recursion {A} : A -> (nat -> A -> A) -> nat -> A := + nat_rect (fun _ => A). + +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' Hn. subst 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 *; induction n; simpl; auto. +Qed. + +(** ** Remaining constants not defined in Coq.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; 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 induction x. +assert (comm : forall x y, x+y = y+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; destruct m; simpl; rewrite ?IHn; split; try easy. + - now intros ->. + - now injection 1. +Qed. + +Lemma leb_le n m : (n <=? m) = true <-> n <= m. +Proof. + revert m. + induction n; 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. + +Lemma ltb_lt n m : (n n < m. +Proof. + apply leb_le. +Qed. + +(** ** Decidability of equality over [nat]. *) + +Lemma eq_dec : forall n m : nat, {n = m} + {n <> m}. +Proof. + induction n; destruct 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; 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; 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; 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; destruct m; simpl; trivial. +Qed. + +Lemma compare_succ n m : (S n ?= S m) = (n ?= m). +Proof. + reflexivity. +Qed. + + +(* BUG: Ajout d'un cas * après preuve finie (deuxième niveau +++*** ) : + * ---> Anomaly: Uncaught exception Proofview.IndexOutOfRange(_). Please report. *) + +(** ** 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. + +(** ** Power *) + +Lemma pow_neg_r a b : b<0 -> a^b = 0. 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_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; 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_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; 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 1. + destruct n as [|[|n]]; simpl. + - split; [ now exists 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 1. + destruct n as [|[|n]]; simpl. + - split; [ discriminate | intro H; elim (Odd_0 H) ]. + - split; [ now exists 0 | 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. + induction x. + - simpl; intuition. + - intros y q u H. destruct 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. + rewrite !add_succ_l, <- add_succ_r. f_equal. now rewrite <- sub_succ_l. +Qed. + +Lemma div_mod x y : y<>0 -> x = y*(x/y) + x mod y. +Proof. + intros Hy. + destruct y; [ now elim Hy | clear Hy ]. + 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. + +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. + induction k. + - (* k = 0 *) + simpl; intros p q r Hq Hr. + split. + + apply le_add_r. + + apply lt_succ_r. + rewrite mul_succ_r. + rewrite add_assoc, (add_comm p), <- add_assoc. + apply add_le_mono_l. + rewrite <- Hq. apply le_sub_l. + - (* k = S k' *) + destruct r. + + (* r = 0 *) + intros Hq _. + replace (S k + p*p + (q-0)) with (k + (S p)*(S p) + (S (S q) - S (S q))). + * apply IHk. + simpl. now rewrite add_succ_r, Hq. apply le_n. + * 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. + + (* r = S r' *) + intros Hq Hr. + replace (S k + p*p + (q-S r)) with (k + p*p + (q - r)). + * apply IHk; trivial. apply le_trans with (S r); trivial. do 2 constructor. + * simpl. rewrite <- add_succ_r. f_equal. rewrite <- sub_succ_l; trivial. +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. + induction k. + - (* k = 0 *) + intros p q r EQ LT. simpl log2_iter. cbv zeta. + split. + + rewrite add_0_l. + rewrite (add_le_mono_l _ _ (2^p)). + simpl pow in EQ. rewrite add_0_r in EQ. rewrite EQ. + rewrite add_comm. apply add_le_mono_r. apply 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. + + (* 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. + +(** ** 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 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 b a') at 2 by discriminate. + 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. + intros. apply gcd_divide. +Qed. + +Lemma gcd_divide_r : forall a b, (gcd a b | b). +Proof. + intros. apply gcd_divide. +Qed. + +Lemma gcd_greatest : forall a b c, (c|a) -> (c|b) -> (c|gcd a b). +Proof. + fix 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 b a') in H' by discriminate. + 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 *) + +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 1. + destruct 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; intros H. + - simpl. apply le_0_l. + - apply succ_le_mono in H. + apply le_trans with a; [ apply le_div2 | trivial ]. +Qed. + +Lemma double_twice : forall n, double n = 2*n. +Proof. + simpl; intros. now rewrite add_0_r. +Qed. + +Lemma testbit_0_l : forall n, testbit 0 n = false. +Proof. + now induction n. +Qed. + +Lemma testbit_odd_0 a : testbit (2*a+1) 0 = true. +Proof. + unfold testbit. rewrite odd_spec. now exists a. +Qed. + +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. + induction n; intros m. trivial. + 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. + induction n; 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. + +Lemma shiftl_spec_low : forall a n m, m + testbit (shiftl a n) m = false. +Proof. + induction n; 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. + +Lemma div2_bitwise : forall op n a b, + div2 (bitwise op (S n) a b) = bitwise op n (div2 a) (div2 b). +Proof. + intros. unfold bitwise; fold bitwise. + destruct (op (odd a) (odd b)). + now rewrite div2_succ_double. + now rewrite add_0_l, div2_double. +Qed. + +Lemma odd_bitwise : forall op n a b, + odd (bitwise op (S n) a b) = op (odd a) (odd b). +Proof. + intros. 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. + +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. + induction n; 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. + +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. + induction n; 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. + +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. + +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. + +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). + + rewrite max_l; subst; trivial. + + apply lt_le_incl in H. now rewrite max_r. + + apply lt_le_incl in H. now rewrite max_l. + - destruct (compare_spec a b). + + rewrite max_r; subst; trivial. + + apply lt_le_incl in H. now rewrite max_r. + + apply lt_le_incl in H. now rewrite max_l. +Qed. + +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). + + rewrite max_l; subst; trivial. + + apply lt_le_incl in H. now rewrite max_r. + + apply lt_le_incl in H. now rewrite max_l. + - destruct (compare_spec a b). + + rewrite max_r; subst; trivial. + + apply lt_le_incl in H. now rewrite max_r. + + apply lt_le_incl in H. now rewrite max_l. +Qed. + +Lemma div2_spec a : div2 a = shiftr a 1. +Proof. + reflexivity. +Qed. + +(** Aliases with extra dummy hypothesis, to fulfil the interface *) + +Definition testbit_odd_succ a n (_:0<=n) := testbit_odd_succ' a n. +Definition testbit_even_succ a n (_:0<=n) := testbit_even_succ' a n. +Lemma testbit_neg_r a n (H:n<0) : testbit a n = false. +Proof. inversion H. Qed. + +Definition shiftl_spec_high a n m (_:0<=m) := shiftl_specif_high a n m. +Definition shiftr_spec a n m (_:0<=m) := shiftr_specif a n m. + +(** Properties of advanced functions (pow, sqrt, log2, ...) *) + +Include NExtraProp. + +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 " y<=x -> x=y]. *) + +Section TestOrder. + Let test : forall x y, x<=y -> y<=x -> x=y. + Proof. + Nat.order. + Qed. +End TestOrder. diff --git a/theories/Arith/Peano_dec.v b/theories/Arith/Peano_dec.v index e288a43f..a7ede3fc 100644 --- a/theories/Arith/Peano_dec.v +++ b/theories/Arith/Peano_dec.v @@ -1,52 +1,61 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* m}. -Proof. - induction n; destruct m; auto. - elim (IHn m); auto. -Defined. +Notation eq_nat_dec := Nat.eq_dec (compat "8.4"). Hint Resolve O_or_S eq_nat_dec: arith. -Theorem dec_eq_nat : forall n m, decidable (n = m). - intros x y; unfold decidable; elim (eq_nat_dec x y); auto with arith. +Theorem dec_eq_nat n m : decidable (n = m). +Proof. + elim (Nat.eq_dec n m); [left|right]; trivial. Defined. -Definition UIP_nat:= Eqdep_dec.UIP_dec eq_nat_dec. +Definition UIP_nat:= Eqdep_dec.UIP_dec Nat.eq_dec. -Lemma le_unique: forall m n (h1 h2: m <= n), h1 = h2. +Import EqNotations. + +Lemma le_unique: forall m n (le_mn1 le_mn2 : m <= n), le_mn1 = le_mn2. Proof. -fix 3. -refine (fun m _ h1 => match h1 as h' in _ <= k return forall hh: m <= k, h' = hh - with le_n => _ |le_S i H => _ end). -refine (fun hh => match hh as h' in _ <= k return forall eq: m = k, - le_n m = match eq in _ = p return m <= p -> m <= m with |eq_refl => fun bli => bli end h' with - |le_n => fun eq => _ |le_S j H' => fun eq => _ end eq_refl). -rewrite (UIP_nat _ _ eq eq_refl). reflexivity. -subst m. destruct (Lt.lt_irrefl j H'). -refine (fun hh => match hh as h' in _ <= k return match k as k' return m <= k' -> Prop - with |0 => fun _ => True |S i' => fun h'' => forall H':m <= i', le_S m i' H' = h'' end h' - with |le_n => _ |le_S j H2 => fun H' => _ end H). -destruct m. exact I. intros; destruct (Lt.lt_irrefl m H'). -f_equal. apply le_unique. +intros m n. +generalize (eq_refl (S n)). +generalize n at -1. +induction (S n) as [|n0 IHn0]; try discriminate. +clear n; intros n H; injection H; clear H; intro H. +rewrite <- H; intros le_mn1 le_mn2; clear n H. +pose (def_n2 := eq_refl n0); transitivity (eq_ind _ _ le_mn2 _ def_n2). + 2: reflexivity. +generalize def_n2; revert le_mn1 le_mn2. +generalize n0 at 1 4 5 7; intros n1 le_mn1. +destruct le_mn1; intros le_mn2; destruct le_mn2. ++ now intros def_n0; rewrite (UIP_nat _ _ def_n0 eq_refl). ++ intros def_n0; generalize le_mn2; rewrite <-def_n0; intros le_mn0. + now destruct (Nat.nle_succ_diag_l _ le_mn0). ++ intros def_n0; generalize le_mn1; rewrite def_n0; intros le_mn0. + now destruct (Nat.nle_succ_diag_l _ le_mn0). ++ intros def_n0; injection def_n0; intros ->. + rewrite (UIP_nat _ _ def_n0 eq_refl); simpl. + assert (H : le_mn1 = le_mn2). + now apply IHn0. +now rewrite H. Qed. + +(** For compatibility *) +Require Import Le Lt. \ No newline at end of file diff --git a/theories/Arith/Plus.v b/theories/Arith/Plus.v index 5428ada3..3b823da6 100644 --- a/theories/Arith/Plus.v +++ b/theories/Arith/Plus.v @@ -6,176 +6,139 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(** Properties of addition. [add] is defined in [Init/Peano.v] as: +(** Properties of addition. + + This file is mostly OBSOLETE now, see module [PeanoNat.Nat] instead. + + [Nat.add] is defined in [Init/Nat.v] as: << -Fixpoint plus (n m:nat) : nat := +Fixpoint add (n m:nat) : nat := match n with | O => m | S p => S (p + m) end -where "n + m" := (plus n m) : nat_scope. +where "n + m" := (add n m) : nat_scope. >> - *) +*) -Require Import Le. -Require Import Lt. +Require Import PeanoNat. Local Open Scope nat_scope. -Implicit Types m n p q : nat. - -(** * Zero is neutral -Deprecated : Already in Init/Peano.v *) -Notation plus_0_l := plus_O_n (only parsing). -Definition plus_0_r n := eq_sym (plus_n_O n). - -(** * Commutativity *) - -Lemma plus_comm : forall n m, n + m = m + n. -Proof. - intros n m; elim n; simpl; auto with arith. - intros y H; elim (plus_n_Sm m y); auto with arith. -Qed. -Hint Immediate plus_comm: arith v62. - -(** * Associativity *) +(** * Neutrality of 0, commutativity, associativity *) -Definition plus_Snm_nSm : forall n m, S n + m = n + S m:= - plus_n_Sm. +Notation plus_0_l := Nat.add_0_l (compat "8.4"). +Notation plus_0_r := Nat.add_0_r (compat "8.4"). +Notation plus_comm := Nat.add_comm (compat "8.4"). +Notation plus_assoc := Nat.add_assoc (compat "8.4"). -Lemma plus_assoc : forall n m p, n + (m + p) = n + m + p. -Proof. - intros n m p; elim n; simpl; auto with arith. -Qed. -Hint Resolve plus_assoc: arith v62. +Notation plus_permute := Nat.add_shuffle3 (compat "8.4"). -Lemma plus_permute : forall n m p, n + (m + p) = m + (n + p). -Proof. - intros; rewrite (plus_assoc m n p); rewrite (plus_comm m n); auto with arith. -Qed. +Definition plus_Snm_nSm : forall n m, S n + m = n + S m := + Peano.plus_n_Sm. -Lemma plus_assoc_reverse : forall n m p, n + m + p = n + (m + p). +Lemma plus_assoc_reverse n m p : n + m + p = n + (m + p). Proof. - auto with arith. + symmetry. apply Nat.add_assoc. Qed. -Hint Resolve plus_assoc_reverse: arith v62. (** * Simplification *) -Lemma plus_reg_l : forall n m p, p + n = p + m -> n = m. +Lemma plus_reg_l n m p : p + n = p + m -> n = m. Proof. - intros m p n; induction n; simpl; auto with arith. + apply Nat.add_cancel_l. Qed. -Lemma plus_le_reg_l : forall n m p, p + n <= p + m -> n <= m. +Lemma plus_le_reg_l n m p : p + n <= p + m -> n <= m. Proof. - induction p; simpl; auto with arith. + apply Nat.add_le_mono_l. Qed. -Lemma plus_lt_reg_l : forall n m p, p + n < p + m -> n < m. +Lemma plus_lt_reg_l n m p : p + n < p + m -> n < m. Proof. - induction p; simpl; auto with arith. + apply Nat.add_lt_mono_l. Qed. (** * Compatibility with order *) -Lemma plus_le_compat_l : forall n m p, n <= m -> p + n <= p + m. +Lemma plus_le_compat_l n m p : n <= m -> p + n <= p + m. Proof. - induction p; simpl; auto with arith. + apply Nat.add_le_mono_l. Qed. -Hint Resolve plus_le_compat_l: arith v62. -Lemma plus_le_compat_r : forall n m p, n <= m -> n + p <= m + p. +Lemma plus_le_compat_r n m p : n <= m -> n + p <= m + p. Proof. - induction 1; simpl; auto with arith. + apply Nat.add_le_mono_r. Qed. -Hint Resolve plus_le_compat_r: arith v62. -Lemma le_plus_l : forall n m, n <= n + m. +Lemma plus_lt_compat_l n m p : n < m -> p + n < p + m. Proof. - induction n; simpl; auto with arith. + apply Nat.add_lt_mono_l. Qed. -Hint Resolve le_plus_l: arith v62. -Lemma le_plus_r : forall n m, m <= n + m. +Lemma plus_lt_compat_r n m p : n < m -> n + p < m + p. Proof. - intros n m; elim n; simpl; auto with arith. + apply Nat.add_lt_mono_r. Qed. -Hint Resolve le_plus_r: arith v62. -Theorem le_plus_trans : forall n m p, n <= m -> n <= m + p. +Lemma plus_le_compat n m p q : n <= m -> p <= q -> n + p <= m + q. Proof. - intros; apply le_trans with (m := m); auto with arith. + apply Nat.add_le_mono. Qed. -Hint Resolve le_plus_trans: arith v62. -Theorem lt_plus_trans : forall n m p, n < m -> n < m + p. +Lemma plus_le_lt_compat n m p q : n <= m -> p < q -> n + p < m + q. Proof. - intros; apply lt_le_trans with (m := m); auto with arith. + apply Nat.add_le_lt_mono. Qed. -Hint Immediate lt_plus_trans: arith v62. -Lemma plus_lt_compat_l : forall n m p, n < m -> p + n < p + m. +Lemma plus_lt_le_compat n m p q : n < m -> p <= q -> n + p < m + q. Proof. - induction p; simpl; auto with arith. + apply Nat.add_lt_le_mono. Qed. -Hint Resolve plus_lt_compat_l: arith v62. -Lemma plus_lt_compat_r : forall n m p, n < m -> n + p < m + p. +Lemma plus_lt_compat n m p q : n < m -> p < q -> n + p < m + q. Proof. - intros n m p H; rewrite (plus_comm n p); rewrite (plus_comm m p). - elim p; auto with arith. + apply Nat.add_lt_mono. Qed. -Hint Resolve plus_lt_compat_r: arith v62. -Lemma plus_le_compat : forall n m p q, n <= m -> p <= q -> n + p <= m + q. +Lemma le_plus_l n m : n <= n + m. Proof. - intros n m p q H H0. - elim H; simpl; auto with arith. + apply Nat.le_add_r. Qed. -Lemma plus_le_lt_compat : forall n m p q, n <= m -> p < q -> n + p < m + q. +Lemma le_plus_r n m : m <= n + m. Proof. - unfold lt. intros. change (S n + p <= m + q). rewrite plus_Snm_nSm. - apply plus_le_compat; assumption. + rewrite Nat.add_comm. apply Nat.le_add_r. Qed. -Lemma plus_lt_le_compat : forall n m p q, n < m -> p <= q -> n + p < m + q. +Theorem le_plus_trans n m p : n <= m -> n <= m + p. Proof. - unfold lt. intros. change (S n + p <= m + q). apply plus_le_compat; assumption. + intros. now rewrite <- Nat.le_add_r. Qed. -Lemma plus_lt_compat : forall n m p q, n < m -> p < q -> n + p < m + q. +Theorem lt_plus_trans n m p : n < m -> n < m + p. Proof. - intros. apply plus_lt_le_compat. assumption. - apply lt_le_weak. assumption. + intros. apply Nat.lt_le_trans with m. trivial. apply Nat.le_add_r. Qed. (** * Inversion lemmas *) -Lemma plus_is_O : forall n m, n + m = 0 -> n = 0 /\ m = 0. +Lemma plus_is_O n m : n + m = 0 -> n = 0 /\ m = 0. Proof. - intro m; destruct m as [| n]; auto. - intros. discriminate H. + destruct n; now split. Qed. -Definition plus_is_one : - forall m n, m + n = 1 -> {m = 0 /\ n = 1} + {m = 1 /\ n = 0}. +Definition plus_is_one m n : + m + n = 1 -> {m = 0 /\ n = 1} + {m = 1 /\ n = 0}. Proof. - intro m; destruct m as [| n]; auto. - destruct n; auto. - intros. - simpl in H. discriminate H. + destruct m as [| m]; auto. + destruct m; auto. + discriminate. Defined. (** * Derived properties *) -Lemma plus_permute_2_in_4 : forall n m p q, n + m + (p + q) = n + p + (m + q). -Proof. - intros m n p q. - rewrite <- (plus_assoc m n (p + q)). rewrite (plus_assoc n p q). - rewrite (plus_comm n p). rewrite <- (plus_assoc p n q). apply plus_assoc. -Qed. +Notation plus_permute_2_in_4 := Nat.add_shuffle1 (compat "8.4"). (** * Tail-recursive plus *) @@ -190,31 +153,37 @@ Fixpoint tail_plus n m : nat := end. Lemma plus_tail_plus : forall n m, n + m = tail_plus n m. +Proof. induction n as [| n IHn]; simpl; auto. intro m; rewrite <- IHn; simpl; auto. Qed. (** * Discrimination *) -Lemma succ_plus_discr : forall n m, n <> S (plus m n). +Lemma succ_plus_discr n m : n <> S (m+n). Proof. - intros n m; induction n as [|n IHn]. - discriminate. - intro H; apply IHn; apply eq_add_S; rewrite H; rewrite <- plus_n_Sm; - reflexivity. + apply Nat.succ_add_discr. Qed. -Lemma n_SSn : forall n, n <> S (S n). -Proof. - intro n; exact (succ_plus_discr n 1). -Qed. +Lemma n_SSn n : n <> S (S n). +Proof (succ_plus_discr n 1). -Lemma n_SSSn : forall n, n <> S (S (S n)). -Proof. - intro n; exact (succ_plus_discr n 2). -Qed. +Lemma n_SSSn n : n <> S (S (S n)). +Proof (succ_plus_discr n 2). -Lemma n_SSSSn : forall n, n <> S (S (S (S n))). -Proof. - intro n; exact (succ_plus_discr n 3). -Qed. +Lemma n_SSSSn n : n <> S (S (S (S n))). +Proof (succ_plus_discr n 3). + + +(** * Compatibility Hints *) + +Hint Immediate plus_comm : arith v62. +Hint Resolve plus_assoc plus_assoc_reverse : arith v62. +Hint Resolve plus_le_compat_l plus_le_compat_r : arith v62. +Hint Resolve le_plus_l le_plus_r le_plus_trans : arith v62. +Hint Immediate lt_plus_trans : arith v62. +Hint Resolve plus_lt_compat_l plus_lt_compat_r : arith v62. + +(** For compatibility, we "Require" the same files as before *) + +Require Import Le Lt. diff --git a/theories/Arith/Wf_nat.v b/theories/Arith/Wf_nat.v index 8cd195f8..64764830 100644 --- a/theories/Arith/Wf_nat.v +++ b/theories/Arith/Wf_nat.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* f a. Theorem well_founded_ltof : well_founded ltof. Proof. - red. - cut (forall n (a:A), f a < n -> Acc ltof a). - intros H a; apply (H (S (f a))); auto with arith. - induction n. - intros; absurd (f a < 0); auto with arith. - intros a ltSma. - apply Acc_intro. - unfold ltof; intros b ltfafb. - apply IHn. - apply lt_le_trans with (f a); auto with arith. + assert (H : forall n (a:A), f a < n -> Acc ltof a). + { induction n. + - intros; absurd (f a < 0); auto with arith. + - intros a Ha. apply Acc_intro. unfold ltof at 1. intros b Hb. + apply IHn. apply Nat.lt_le_trans with (f a); auto with arith. } + intros a. apply (H (S (f a))). auto with arith. Defined. Theorem well_founded_gtof : well_founded gtof. @@ -67,15 +63,13 @@ Theorem induction_ltof1 : forall P:A -> Set, (forall x:A, (forall y:A, ltof y x -> P y) -> P x) -> forall a:A, P a. Proof. - intros P F; cut (forall n (a:A), f a < n -> P a). - intros H a; apply (H (S (f a))); auto with arith. - induction n. - intros; absurd (f a < 0); auto with arith. - intros a ltSma. - apply F. - unfold ltof; intros b ltfafb. - apply IHn. - apply lt_le_trans with (f a); auto with arith. + intros P F. + assert (H : forall n (a:A), f a < n -> P a). + { induction n. + - intros; absurd (f a < 0); auto with arith. + - intros a Ha. apply F. unfold ltof. intros b Hb. + apply IHn. apply Nat.lt_le_trans with (f a); auto with arith. } + intros a. apply (H (S (f a))). auto with arith. Defined. Theorem induction_gtof1 : @@ -108,16 +102,12 @@ Hypothesis H_compat : forall x y:A, R x y -> f x < f y. Theorem well_founded_lt_compat : well_founded R. Proof. - red. - cut (forall n (a:A), f a < n -> Acc R a). - intros H a; apply (H (S (f a))); auto with arith. - induction n. - intros; absurd (f a < 0); auto with arith. - intros a ltSma. - apply Acc_intro. - intros b ltfafb. - apply IHn. - apply lt_le_trans with (f a); auto with arith. + assert (H : forall n (a:A), f a < n -> Acc R a). + { induction n. + - intros; absurd (f a < 0); auto with arith. + - intros a Ha. apply Acc_intro. intros b Hb. + apply IHn. apply Nat.lt_le_trans with (f a); auto with arith. } + intros a. apply (H (S (f a))). auto with arith. Defined. End Well_founded_Nat. @@ -208,6 +198,7 @@ End LT_WF_REL. Lemma well_founded_inv_rel_inv_lt_rel : forall (A:Set) (F:A -> nat -> Prop), well_founded (inv_lt_rel A F). +Proof. intros; apply (well_founded_inv_lt_rel_compat A (inv_lt_rel A F) F); trivial. Qed. @@ -230,34 +221,20 @@ Proof. intros P Pdec (n0,HPn0). assert (forall n, (exists n', n' n'<=n'') - \/(forall n', P n' -> n<=n')). - induction n. - right. - intros n' Hn'. - apply le_O_n. - destruct IHn. - left; destruct H as (n', (Hlt', HPn')). - exists n'; split. - apply lt_S; assumption. - assumption. - destruct (Pdec n). - left; exists n; split. - apply lt_n_Sn. - split; assumption. - right. - intros n' Hltn'. - destruct (le_lt_eq_dec n n') as [Hltn|Heqn]. - apply H; assumption. - assumption. - destruct H0. - rewrite Heqn; assumption. - destruct (H n0) as [(n,(Hltn,(Hmin,Huniqn)))|]; [exists n | exists n0]; - repeat split; - assumption || intros n' (HPn',Hminn'); apply le_antisym; auto. + \/ (forall n', P n' -> n<=n')). + { induction n. + - right. intros. apply Nat.le_0_l. + - destruct IHn as [(n' & IH1 & IH2)|IH]. + + left. exists n'; auto with arith. + + destruct (Pdec n) as [HP|HP]. + * left. exists n; auto with arith. + * 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 := @nat_iter (only parsing). -Notation iter_nat_plus := @nat_iter_plus (only parsing). -Notation iter_nat_invariant := @nat_iter_invariant (only parsing). +Notation iter_nat n A f x := (nat_rect (fun _ => A) x (fun _ => f) n) (only parsing). diff --git a/theories/Arith/vo.itarget b/theories/Arith/vo.itarget index 0b6564e1..0b3d31e9 100644 --- a/theories/Arith/vo.itarget +++ b/theories/Arith/vo.itarget @@ -1,3 +1,4 @@ +PeanoNat.vo Arith_base.vo Arith.vo Between.vo diff --git a/theories/Bool/Bool.v b/theories/Bool/Bool.v index 5ec8f806..cc12cf47 100644 --- a/theories/Bool/Bool.v +++ b/theories/Bool/Bool.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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]. *) + +Instance pointwise_reflexive {A} `(reflb : Reflexive B eqB) : + Reflexive (pointwise_relation A eqB) | 9. +Proof. firstorder. Qed. +Instance pointwise_symmetric {A} `(symb : Symmetric B eqB) : + Symmetric (pointwise_relation A eqB) | 9. +Proof. firstorder. Qed. +Instance pointwise_transitive {A} `(transb : Transitive B eqB) : + Transitive (pointwise_relation A eqB) | 9. +Proof. firstorder. Qed. +Instance pointwise_equivalence {A} `(eqb : Equivalence B eqB) : + Equivalence (pointwise_relation A eqB) | 9. +Proof. split; apply _. Qed. diff --git a/theories/Classes/CMorphisms.v b/theories/Classes/CMorphisms.v new file mode 100644 index 00000000..073cd5e9 --- /dev/null +++ b/theories/Classes/CMorphisms.v @@ -0,0 +1,701 @@ +(* -*- coding: utf-8 -*- *) +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* B) _ _] goal, making proof-search much + slower. A cleaner solution would be to be able to set different + priorities in different hint bases and select a particular hint + database for resolution of a type class constraint. *) + + Class ProperProxy (R : crelation A) (m : A) := + proper_proxy : R m m. + + Lemma eq_proper_proxy (x : A) : ProperProxy (@eq A) x. + Proof. firstorder. Qed. + + Lemma reflexive_proper_proxy `(Reflexive A R) (x : A) : ProperProxy R x. + Proof. firstorder. Qed. + + Lemma proper_proper_proxy x `(Proper R x) : ProperProxy R x. + Proof. firstorder. Qed. + + (** Respectful morphisms. *) + + (** The fully dependent version, not used yet. *) + + Definition respectful_hetero + (A B : Type) + (C : A -> Type) (D : B -> Type) + (R : A -> B -> Type) + (R' : forall (x : A) (y : B), C x -> D y -> Type) : + (forall x : A, C x) -> (forall x : B, D x) -> Type := + fun f g => forall x y, R x y -> R' x y (f x) (g y). + + (** The non-dependent version is an instance where we forget dependencies. *) + + Definition respectful (R : crelation A) (R' : crelation B) : crelation (A -> B) := + Eval compute in @respectful_hetero A A (fun _ => B) (fun _ => B) R (fun _ _ => R'). +End Proper. + +(** We favor the use of Leibniz equality or a declared reflexive crelation + when resolving [ProperProxy], otherwise, if the crelation is given (not an evar), + we fall back to [Proper]. *) +Hint Extern 1 (ProperProxy _ _) => + class_apply @eq_proper_proxy || class_apply @reflexive_proper_proxy : typeclass_instances. + +Hint Extern 2 (ProperProxy ?R _) => + not_evar R; class_apply @proper_proper_proxy : typeclass_instances. + +(** Notations reminiscent of the old syntax for declaring morphisms. *) +Delimit Scope signature_scope with signature. + +Module ProperNotations. + + Notation " R ++> R' " := (@respectful _ _ (R%signature) (R'%signature)) + (right associativity, at level 55) : signature_scope. + + Notation " R ==> R' " := (@respectful _ _ (R%signature) (R'%signature)) + (right associativity, at level 55) : signature_scope. + + Notation " R --> R' " := (@respectful _ _ (flip (R%signature)) (R'%signature)) + (right associativity, at level 55) : signature_scope. + +End ProperNotations. + +Arguments Proper {A}%type R%signature m. +Arguments respectful {A B}%type (R R')%signature _ _. + +Export ProperNotations. + +Local Open Scope signature_scope. + +(** [solve_proper] try to solve the goal [Proper (?==> ... ==>?) f] + by repeated introductions and setoid rewrites. It should work + fine when [f] is a combination of already known morphisms and + quantifiers. *) + +Ltac solve_respectful t := + match goal with + | |- respectful _ _ _ _ => + let H := fresh "H" in + intros ? ? H; solve_respectful ltac:(setoid_rewrite H; t) + | _ => t; reflexivity + end. + +Ltac solve_proper := unfold Proper; solve_respectful ltac:(idtac). + +(** [f_equiv] is a clone of [f_equal] that handles setoid equivalences. + For example, if we know that [f] is a morphism for [E1==>E2==>E], + then the goal [E (f x y) (f x' y')] will be transformed by [f_equiv] + into the subgoals [E1 x x'] and [E2 y y']. +*) + +Ltac f_equiv := + match goal with + | |- ?R (?f ?x) (?f' _) => + let T := type of x in + let Rx := fresh "R" in + evar (Rx : crelation T); + let H := fresh in + assert (H : (Rx==>R)%signature f f'); + unfold Rx in *; clear Rx; [ f_equiv | apply H; clear H; try reflexivity ] + | |- ?R ?f ?f' => + solve [change (Proper R f); eauto with typeclass_instances | reflexivity ] + | _ => idtac + end. + +Section Relations. + Context {A B : Type}. + + (** [forall_def] reifies the dependent product as a definition. *) + + Definition forall_def (P : A -> Type) : Type := forall x : A, P x. + + (** Dependent pointwise lifting of a crelation on the range. *) + + Definition forall_relation (P : A -> Type) + (sig : forall a, crelation (P a)) : crelation (forall x, P x) := + fun f g => forall a, sig a (f a) (g a). + + (** Non-dependent pointwise lifting *) + Definition pointwise_relation (R : crelation B) : crelation (A -> B) := + fun f g => forall a, R (f a) (g a). + + Lemma pointwise_pointwise (R : crelation B) : + relation_equivalence (pointwise_relation R) (@eq A ==> R). + Proof. intros. split. simpl_crelation. firstorder. Qed. + + (** Subcrelations induce a morphism on the identity. *) + + Global Instance subrelation_id_proper `(subrelation A RA RA') : Proper (RA ==> RA') id. + Proof. firstorder. Qed. + + (** The subrelation property goes through products as usual. *) + + Lemma subrelation_respectful `(subl : subrelation A RA' RA, subr : subrelation B RB RB') : + subrelation (RA ==> RB) (RA' ==> RB'). + Proof. simpl_crelation. Qed. + + (** And of course it is reflexive. *) + + Lemma subrelation_refl R : @subrelation A R R. + Proof. simpl_crelation. Qed. + + (** [Proper] is itself a covariant morphism for [subrelation]. + We use an unconvertible premise to avoid looping. + *) + + Lemma subrelation_proper `(mor : Proper A R' m) + `(unc : Unconvertible (crelation A) R R') + `(sub : subrelation A R' R) : Proper R m. + Proof. + intros. apply sub. apply mor. + Qed. + + Global Instance proper_subrelation_proper_arrow : + Proper (subrelation ++> eq ==> arrow) (@Proper A). + Proof. reduce. subst. firstorder. Qed. + + Global Instance pointwise_subrelation `(sub : subrelation B R R') : + subrelation (pointwise_relation R) (pointwise_relation R') | 4. + Proof. reduce. unfold pointwise_relation in *. apply sub. auto. Qed. + + (** For dependent function types. *) + Lemma forall_subrelation (P : A -> Type) (R S : forall x : A, crelation (P x)) : + (forall a, subrelation (R a) (S a)) -> + subrelation (forall_relation P R) (forall_relation P S). + Proof. reduce. firstorder. Qed. +End Relations. +Typeclasses Opaque respectful pointwise_relation forall_relation. +Arguments forall_relation {A P}%type sig%signature _ _. +Arguments pointwise_relation A%type {B}%type R%signature _ _. + +Hint Unfold Reflexive : core. +Hint Unfold Symmetric : core. +Hint Unfold Transitive : core. + +(** Resolution with subrelation: favor decomposing products over applying reflexivity + for unconstrained goals. *) +Ltac subrelation_tac T U := + (is_ground T ; is_ground U ; class_apply @subrelation_refl) || + class_apply @subrelation_respectful || class_apply @subrelation_refl. + +Hint Extern 3 (@subrelation _ ?T ?U) => subrelation_tac T U : typeclass_instances. + +CoInductive apply_subrelation : Prop := do_subrelation. + +Ltac proper_subrelation := + match goal with + [ H : apply_subrelation |- _ ] => clear H ; class_apply @subrelation_proper + end. + +Hint Extern 5 (@Proper _ ?H _) => proper_subrelation : typeclass_instances. + +(** Essential subrelation instances for [iff], [impl] and [pointwise_relation]. *) + +Instance iff_impl_subrelation : subrelation iff impl | 2. +Proof. firstorder. Qed. + +Instance iff_flip_impl_subrelation : subrelation iff (flip impl) | 2. +Proof. firstorder. Qed. + +(** Essential subrelation instances for [iffT] and [arrow]. *) + +Instance iffT_arrow_subrelation : subrelation iffT arrow | 2. +Proof. firstorder. Qed. + +Instance iffT_flip_arrow_subrelation : subrelation iffT (flip arrow) | 2. +Proof. firstorder. Qed. + +(** We use an extern hint to help unification. *) + +Hint Extern 4 (subrelation (@forall_relation ?A ?B ?R) (@forall_relation _ _ ?S)) => + apply (@forall_subrelation A B R S) ; intro : typeclass_instances. + +Section GenericInstances. + (* Share universes *) + Context {A B C : Type}. + + (** We can build a PER on the Coq function space if we have PERs on the domain and + codomain. *) + + Program Instance respectful_per `(PER A R, PER B R') : PER (R ==> R'). + + Next Obligation. + Proof with auto. + assert(R x0 x0). + transitivity y0... symmetry... + transitivity (y x0)... + Qed. + + (** The complement of a crelation conserves its proper elements. *) + + Program Definition complement_proper + `(mR : Proper (A -> A -> Prop) (RA ==> RA ==> iff) R) : + Proper (RA ==> RA ==> iff) (complement R) := _. + + Next Obligation. + Proof. + unfold complement. + pose (mR x y X x0 y0 X0). + intuition. + Qed. + + (** The [flip] too, actually the [flip] instance is a bit more general. *) + + Program Definition flip_proper + `(mor : Proper (A -> B -> C) (RA ==> RB ==> RC) f) : + Proper (RB ==> RA ==> RC) (flip f) := _. + + Next Obligation. + Proof. + apply mor ; auto. + Qed. + + + (** Every Transitive crelation gives rise to a binary morphism on [impl], + contravariant in the first argument, covariant in the second. *) + + Global Program + Instance trans_contra_co_type_morphism + `(Transitive A R) : Proper (R --> R ++> arrow) R. + + Next Obligation. + Proof with auto. + transitivity x... + transitivity x0... + Qed. + + (** Proper declarations for partial applications. *) + + Global Program + Instance trans_contra_inv_impl_type_morphism + `(Transitive A R) : Proper (R --> flip arrow) (R x) | 3. + + Next Obligation. + Proof with auto. + transitivity y... + Qed. + + Global Program + Instance trans_co_impl_type_morphism + `(Transitive A R) : Proper (R ++> arrow) (R x) | 3. + + Next Obligation. + Proof with auto. + transitivity x0... + Qed. + + Global Program + Instance trans_sym_co_inv_impl_type_morphism + `(PER A R) : Proper (R ++> flip arrow) (R x) | 3. + + Next Obligation. + Proof with auto. + transitivity y... symmetry... + Qed. + + Global Program Instance trans_sym_contra_arrow_morphism + `(PER A R) : Proper (R --> arrow) (R x) | 3. + + Next Obligation. + Proof with auto. + transitivity x0... symmetry... + Qed. + + Global Program Instance per_partial_app_type_morphism + `(PER A R) : Proper (R ==> iffT) (R x) | 2. + + Next Obligation. + Proof with auto. + split. intros ; transitivity x0... + intros. + transitivity y... + symmetry... + Qed. + + (** Every Transitive crelation induces a morphism by "pushing" an [R x y] on the left of an [R x z] proof to get an [R y z] goal. *) + + Global Program + Instance trans_co_eq_inv_arrow_morphism + `(Transitive A R) : Proper (R ==> (@eq A) ==> flip arrow) R | 2. + + Next Obligation. + Proof with auto. + transitivity y... + Qed. + + (** Every Symmetric and Transitive crelation gives rise to an equivariant morphism. *) + + Global Program + Instance PER_type_morphism `(PER A R) : Proper (R ==> R ==> iffT) R | 1. + + Next Obligation. + Proof with auto. + split ; intros. + transitivity x0... transitivity x... symmetry... + + transitivity y... transitivity y0... symmetry... + Qed. + + Lemma symmetric_equiv_flip `(Symmetric A R) : relation_equivalence R (flip R). + Proof. firstorder. Qed. + + Global Program Instance compose_proper RA RB RC : + Proper ((RB ==> RC) ==> (RA ==> RB) ==> (RA ==> RC)) (@compose A B C). + + Next Obligation. + Proof. + simpl_crelation. + unfold compose. firstorder. + Qed. + + (** Coq functions are morphisms for Leibniz equality, + applied only if really needed. *) + + Global Instance reflexive_eq_dom_reflexive `(Reflexive B R') : + Reflexive (@Logic.eq A ==> R'). + Proof. simpl_crelation. Qed. + + (** [respectful] is a morphism for crelation equivalence . *) + Set Printing All. Set Printing Universes. + Global Instance respectful_morphism : + Proper (relation_equivalence ++> relation_equivalence ++> relation_equivalence) + (@respectful A B). + Proof. + intros R R' HRR' S S' HSS' f g. + unfold respectful , relation_equivalence in *; simpl in *. + split ; intros H x y Hxy. + apply (fst (HSS' _ _)). apply H. now apply (snd (HRR' _ _)). + apply (snd (HSS' _ _)). apply H. now apply (fst (HRR' _ _)). + Qed. + + (** [R] is Reflexive, hence we can build the needed proof. *) + + Lemma Reflexive_partial_app_morphism `(Proper (A -> B) (R ==> R') m, ProperProxy A R x) : + Proper R' (m x). + Proof. simpl_crelation. Qed. + + Class Params (of : A) (arity : nat). + + Lemma flip_respectful (R : crelation A) (R' : crelation B) : + relation_equivalence (flip (R ==> R')) (flip R ==> flip R'). + Proof. + intros. + unfold flip, respectful. + split ; intros ; intuition. + Qed. + + + (** Treating flip: can't make them direct instances as we + need at least a [flip] present in the goal. *) + + Lemma flip1 `(subrelation A R' R) : subrelation (flip (flip R')) R. + Proof. firstorder. Qed. + + Lemma flip2 `(subrelation A R R') : subrelation R (flip (flip R')). + Proof. firstorder. Qed. + + (** That's if and only if *) + + Lemma eq_subrelation `(Reflexive A R) : subrelation (@eq A) R. + Proof. simpl_crelation. Qed. + + (** Once we have normalized, we will apply this instance to simplify the problem. *) + + Definition proper_flip_proper `(mor : Proper A R m) : Proper (flip R) m := mor. + + (** Every reflexive crelation gives rise to a morphism, + only for immediately solving goals without variables. *) + + Lemma reflexive_proper `{Reflexive A R} (x : A) : Proper R x. + Proof. firstorder. Qed. + + Lemma proper_eq (x : A) : Proper (@eq A) x. + Proof. intros. apply reflexive_proper. Qed. + +End GenericInstances. + +Class PartialApplication. + +CoInductive normalization_done : Prop := did_normalization. + +Ltac partial_application_tactic := + let rec do_partial_apps H m cont := + match m with + | ?m' ?x => class_apply @Reflexive_partial_app_morphism ; + [(do_partial_apps H m' ltac:idtac)|clear H] + | _ => cont + end + in + let rec do_partial H ar m := + match ar with + | 0%nat => do_partial_apps H m ltac:(fail 1) + | S ?n' => + match m with + ?m' ?x => do_partial H n' m' + end + end + in + let params m sk fk := + (let m' := fresh in head_of_constr m' m ; + let n := fresh in evar (n:nat) ; + let v := eval compute in n in clear n ; + let H := fresh in + assert(H:Params m' v) by typeclasses eauto ; + let v' := eval compute in v in subst m'; + (sk H v' || fail 1)) + || fk + in + let on_morphism m cont := + params m ltac:(fun H n => do_partial H n m) + ltac:(cont) + in + match goal with + | [ _ : normalization_done |- _ ] => fail 1 + | [ _ : @Params _ _ _ |- _ ] => fail 1 + | [ |- @Proper ?T _ (?m ?x) ] => + match goal with + | [ H : PartialApplication |- _ ] => + class_apply @Reflexive_partial_app_morphism; [|clear H] + | _ => on_morphism (m x) + ltac:(class_apply @Reflexive_partial_app_morphism) + end + end. + +(** Bootstrap !!! *) + +Instance proper_proper : Proper (relation_equivalence ==> eq ==> iffT) (@Proper A). +Proof. + intros A R R' HRR' x y <-. red in HRR'. + split ; red ; intros. + now apply (fst (HRR' _ _)). + now apply (snd (HRR' _ _)). +Qed. + +Ltac proper_reflexive := + match goal with + | [ _ : normalization_done |- _ ] => fail 1 + | _ => class_apply proper_eq || class_apply @reflexive_proper + end. + + +Hint Extern 1 (subrelation (flip _) _) => class_apply @flip1 : typeclass_instances. +Hint Extern 1 (subrelation _ (flip _)) => class_apply @flip2 : typeclass_instances. + +Hint Extern 1 (Proper _ (complement _)) => apply @complement_proper + : typeclass_instances. +Hint Extern 1 (Proper _ (flip _)) => apply @flip_proper + : typeclass_instances. +Hint Extern 2 (@Proper _ (flip _) _) => class_apply @proper_flip_proper + : typeclass_instances. +Hint Extern 4 (@Proper _ _ _) => partial_application_tactic + : typeclass_instances. +Hint Extern 7 (@Proper _ _ _) => proper_reflexive + : typeclass_instances. + +(** Special-purpose class to do normalization of signatures w.r.t. flip. *) + +Section Normalize. + Context (A : Type). + + Class Normalizes (m : crelation A) (m' : crelation A) : Prop := + normalizes : relation_equivalence m m'. + + (** Current strategy: add [flip] everywhere and reduce using [subrelation] + afterwards. *) + + Lemma proper_normalizes_proper `(Normalizes R0 R1, Proper A R1 m) : Proper R0 m. + Proof. + red in H, H0. red in H. + apply (snd (H _ _)). + assumption. + Qed. + + Lemma flip_atom R : Normalizes R (flip (flip R)). + Proof. + firstorder. + Qed. + +End Normalize. + +Lemma flip_arrow `(NA : Normalizes A R (flip R'''), NB : Normalizes B R' (flip R'')) : + Normalizes (A -> B) (R ==> R') (flip (R''' ==> R'')%signature). +Proof. + unfold Normalizes in *. intros. + rewrite NA, NB. firstorder. +Qed. + +Ltac normalizes := + match goal with + | [ |- Normalizes _ (respectful _ _) _ ] => class_apply @flip_arrow + | _ => class_apply @flip_atom + end. + +Ltac proper_normalization := + match goal with + | [ _ : normalization_done |- _ ] => fail 1 + | [ _ : apply_subrelation |- @Proper _ ?R _ ] => + let H := fresh "H" in + set(H:=did_normalization) ; class_apply @proper_normalizes_proper + end. + +Hint Extern 1 (Normalizes _ _ _) => normalizes : typeclass_instances. +Hint Extern 6 (@Proper _ _ _) => proper_normalization + : typeclass_instances. + +(** When the crelation on the domain is symmetric, we can + flip the crelation on the codomain. Same for binary functions. *) + +Lemma proper_sym_flip : + forall `(Symmetric A R1)`(Proper (A->B) (R1==>R2) f), + Proper (R1==>flip R2) f. +Proof. +intros A R1 Sym B R2 f Hf. +intros x x' Hxx'. apply Hf, Sym, Hxx'. +Qed. + +Lemma proper_sym_flip_2 : + forall `(Symmetric A R1)`(Symmetric B R2)`(Proper (A->B->C) (R1==>R2==>R3) f), + Proper (R1==>R2==>flip R3) f. +Proof. +intros A R1 Sym1 B R2 Sym2 C R3 f Hf. +intros x x' Hxx' y y' Hyy'. apply Hf; auto. +Qed. + +(** When the crelation on the domain is symmetric, a predicate is + compatible with [iff] as soon as it is compatible with [impl]. + Same with a binary crelation. *) + +Lemma proper_sym_impl_iff : forall `(Symmetric A R)`(Proper _ (R==>impl) f), + Proper (R==>iff) f. +Proof. +intros A R Sym f Hf x x' Hxx'. repeat red in Hf. split; eauto. +Qed. + +Lemma proper_sym_arrow_iffT : forall `(Symmetric A R)`(Proper _ (R==>arrow) f), + Proper (R==>iffT) f. +Proof. +intros A R Sym f Hf x x' Hxx'. repeat red in Hf. split; eauto. +Qed. + +Lemma proper_sym_impl_iff_2 : + forall `(Symmetric A R)`(Symmetric B R')`(Proper _ (R==>R'==>impl) f), + Proper (R==>R'==>iff) f. +Proof. +intros A R Sym B R' Sym' f Hf x x' Hxx' y y' Hyy'. +repeat red in Hf. split; eauto. +Qed. + +Lemma proper_sym_arrow_iffT_2 : + forall `(Symmetric A R)`(Symmetric B R')`(Proper _ (R==>R'==>arrow) f), + Proper (R==>R'==>iffT) f. +Proof. +intros A R Sym B R' Sym' f Hf x x' Hxx' y y' Hyy'. +repeat red in Hf. split; eauto. +Qed. + +(** A [PartialOrder] is compatible with its underlying equivalence. *) +Require Import Relation_Definitions. + +Instance PartialOrder_proper_type `(PartialOrder A eqA R) : + Proper (eqA==>eqA==>iffT) R. +Proof. +intros. +apply proper_sym_arrow_iffT_2; auto with *. +intros x x' Hx y y' Hy Hr. +transitivity x. +generalize (partial_order_equivalence x x'); compute; intuition. +transitivity y; auto. +generalize (partial_order_equivalence y y'); compute; intuition. +Qed. + +(** From a [PartialOrder] to the corresponding [StrictOrder]: + [lt = le /\ ~eq]. + If the order is total, we could also say [gt = ~le]. *) + +Lemma PartialOrder_StrictOrder `(PartialOrder A eqA R) : + StrictOrder (relation_conjunction R (complement eqA)). +Proof. +split; compute. +intros x (_,Hx). apply Hx, Equivalence_Reflexive. +intros x y z (Hxy,Hxy') (Hyz,Hyz'). split. +apply PreOrder_Transitive with y; assumption. +intro Hxz. +apply Hxy'. +apply partial_order_antisym; auto. +rewrite Hxz. auto. +Qed. + +(** From a [StrictOrder] to the corresponding [PartialOrder]: + [le = lt \/ eq]. + If the order is total, we could also say [ge = ~lt]. *) + +Lemma StrictOrder_PreOrder + `(Equivalence A eqA, StrictOrder A R, Proper _ (eqA==>eqA==>iffT) R) : + PreOrder (relation_disjunction R eqA). +Proof. +split. +intros x. right. reflexivity. +intros x y z [Hxy|Hxy] [Hyz|Hyz]. +left. transitivity y; auto. +left. rewrite <- Hyz; auto. +left. rewrite Hxy; auto. +right. transitivity y; auto. +Qed. + +Hint Extern 4 (PreOrder (relation_disjunction _ _)) => + class_apply StrictOrder_PreOrder : typeclass_instances. + +Lemma StrictOrder_PartialOrder + `(Equivalence A eqA, StrictOrder A R, Proper _ (eqA==>eqA==>iffT) R) : + PartialOrder eqA (relation_disjunction R eqA). +Proof. +intros. intros x y. compute. intuition. +elim (StrictOrder_Irreflexive x). +transitivity y; auto. +Qed. + +Hint Extern 4 (StrictOrder (relation_conjunction _ _)) => + class_apply PartialOrder_StrictOrder : typeclass_instances. + +Hint Extern 4 (PartialOrder _ (relation_disjunction _ _)) => + class_apply StrictOrder_PartialOrder : typeclass_instances. diff --git a/theories/Classes/CRelationClasses.v b/theories/Classes/CRelationClasses.v new file mode 100644 index 00000000..35b2b8a3 --- /dev/null +++ b/theories/Classes/CRelationClasses.v @@ -0,0 +1,359 @@ +(* -*- coding: utf-8 -*- *) +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* A -> Type. + +Definition arrow (A B : Type) := A -> B. + +Definition flip {A B C : Type} (f : A -> B -> C) := fun x y => f y x. + +Definition iffT (A B : Type) := ((A -> B) * (B -> A))%type. + +(** We allow to unfold the [crelation] definition while doing morphism search. *) + +Section Defs. + Context {A : Type}. + + (** We rebind crelational properties in separate classes to be able to overload each proof. *) + + Class Reflexive (R : crelation A) := + reflexivity : forall x : A, R x x. + + Definition complement (R : crelation A) : crelation A := + fun x y => R x y -> False. + + (** Opaque for proof-search. *) + Typeclasses Opaque complement iffT. + + (** These are convertible. *) + Lemma complement_inverse R : complement (flip R) = flip (complement R). + Proof. reflexivity. Qed. + + Class Irreflexive (R : crelation A) := + irreflexivity : Reflexive (complement R). + + Class Symmetric (R : crelation A) := + symmetry : forall {x y}, R x y -> R y x. + + Class Asymmetric (R : crelation A) := + asymmetry : forall {x y}, R x y -> (complement R y x : Type). + + Class Transitive (R : crelation A) := + transitivity : forall {x y z}, R x y -> R y z -> R x z. + + (** Various combinations of reflexivity, symmetry and transitivity. *) + + (** A [PreOrder] is both Reflexive and Transitive. *) + + Class PreOrder (R : crelation A) := { + PreOrder_Reflexive :> Reflexive R | 2 ; + PreOrder_Transitive :> Transitive R | 2 }. + + (** A [StrictOrder] is both Irreflexive and Transitive. *) + + Class StrictOrder (R : crelation A) := { + StrictOrder_Irreflexive :> Irreflexive R ; + StrictOrder_Transitive :> Transitive R }. + + (** By definition, a strict order is also asymmetric *) + Global Instance StrictOrder_Asymmetric `(StrictOrder R) : Asymmetric R. + Proof. firstorder. Qed. + + (** A partial equivalence crelation is Symmetric and Transitive. *) + + Class PER (R : crelation A) := { + PER_Symmetric :> Symmetric R | 3 ; + PER_Transitive :> Transitive R | 3 }. + + (** Equivalence crelations. *) + + Class Equivalence (R : crelation A) := { + Equivalence_Reflexive :> Reflexive R ; + Equivalence_Symmetric :> Symmetric R ; + Equivalence_Transitive :> Transitive R }. + + (** An Equivalence is a PER plus reflexivity. *) + + Global Instance Equivalence_PER {R} `(Equivalence R) : PER R | 10 := + { PER_Symmetric := Equivalence_Symmetric ; + PER_Transitive := Equivalence_Transitive }. + + (** We can now define antisymmetry w.r.t. an equivalence crelation on the carrier. *) + + Class Antisymmetric eqA `{equ : Equivalence eqA} (R : crelation A) := + antisymmetry : forall {x y}, R x y -> R y x -> eqA x y. + + Class subrelation (R R' : crelation A) := + is_subrelation : forall {x y}, R x y -> R' x y. + + (** Any symmetric crelation is equal to its inverse. *) + + Lemma subrelation_symmetric R `(Symmetric R) : subrelation (flip R) R. + Proof. hnf. intros x y H'. red in H'. apply symmetry. assumption. Qed. + + Section flip. + + Lemma flip_Reflexive `{Reflexive R} : Reflexive (flip R). + Proof. tauto. Qed. + + Program Definition flip_Irreflexive `(Irreflexive R) : Irreflexive (flip R) := + irreflexivity (R:=R). + + Program Definition flip_Symmetric `(Symmetric R) : Symmetric (flip R) := + fun x y H => symmetry (R:=R) H. + + Program Definition flip_Asymmetric `(Asymmetric R) : Asymmetric (flip R) := + fun x y H H' => asymmetry (R:=R) H H'. + + Program Definition flip_Transitive `(Transitive R) : Transitive (flip R) := + fun x y z H H' => transitivity (R:=R) H' H. + + Program Definition flip_Antisymmetric `(Antisymmetric eqA R) : + Antisymmetric eqA (flip R). + Proof. firstorder. Qed. + + (** Inversing the larger structures *) + + Lemma flip_PreOrder `(PreOrder R) : PreOrder (flip R). + Proof. firstorder. Qed. + + Lemma flip_StrictOrder `(StrictOrder R) : StrictOrder (flip R). + Proof. firstorder. Qed. + + Lemma flip_PER `(PER R) : PER (flip R). + Proof. firstorder. Qed. + + Lemma flip_Equivalence `(Equivalence R) : Equivalence (flip R). + Proof. firstorder. Qed. + + End flip. + + Section complement. + + Definition complement_Irreflexive `(Reflexive R) + : Irreflexive (complement R). + Proof. firstorder. Qed. + + Definition complement_Symmetric `(Symmetric R) : Symmetric (complement R). + Proof. firstorder. Qed. + End complement. + + + (** Rewrite crelation on a given support: declares a crelation as a rewrite + crelation for use by the generalized rewriting tactic. + It helps choosing if a rewrite should be handled + by the generalized or the regular rewriting tactic using leibniz equality. + Users can declare an [RewriteRelation A RA] anywhere to declare default + crelations. This is also done automatically by the [Declare Relation A RA] + commands. *) + + Class RewriteRelation (RA : crelation A). + + (** Any [Equivalence] declared in the context is automatically considered + a rewrite crelation. *) + + Global Instance equivalence_rewrite_crelation `(Equivalence eqA) : RewriteRelation eqA. + + (** Leibniz equality. *) + Section Leibniz. + Global Instance eq_Reflexive : Reflexive (@eq A) := @eq_refl A. + Global Instance eq_Symmetric : Symmetric (@eq A) := @eq_sym A. + Global Instance eq_Transitive : Transitive (@eq A) := @eq_trans A. + + (** Leibinz equality [eq] is an equivalence crelation. + The instance has low priority as it is always applicable + if only the type is constrained. *) + + Global Program Instance eq_equivalence : Equivalence (@eq A) | 10. + End Leibniz. + +End Defs. + +(** Default rewrite crelations handled by [setoid_rewrite]. *) +Instance: RewriteRelation impl. +Instance: RewriteRelation iff. + +(** Hints to drive the typeclass resolution avoiding loops + due to the use of full unification. *) +Hint Extern 1 (Reflexive (complement _)) => class_apply @irreflexivity : typeclass_instances. +Hint Extern 3 (Symmetric (complement _)) => class_apply complement_Symmetric : typeclass_instances. +Hint Extern 3 (Irreflexive (complement _)) => class_apply complement_Irreflexive : typeclass_instances. + +Hint Extern 3 (Reflexive (flip _)) => apply flip_Reflexive : typeclass_instances. +Hint Extern 3 (Irreflexive (flip _)) => class_apply flip_Irreflexive : typeclass_instances. +Hint Extern 3 (Symmetric (flip _)) => class_apply flip_Symmetric : typeclass_instances. +Hint Extern 3 (Asymmetric (flip _)) => class_apply flip_Asymmetric : typeclass_instances. +Hint Extern 3 (Antisymmetric (flip _)) => class_apply flip_Antisymmetric : typeclass_instances. +Hint Extern 3 (Transitive (flip _)) => class_apply flip_Transitive : typeclass_instances. +Hint Extern 3 (StrictOrder (flip _)) => class_apply flip_StrictOrder : typeclass_instances. +Hint Extern 3 (PreOrder (flip _)) => class_apply flip_PreOrder : typeclass_instances. + +Hint Extern 4 (subrelation (flip _) _) => + class_apply @subrelation_symmetric : typeclass_instances. + +Hint Resolve irreflexivity : ord. + +Unset Implicit Arguments. + +(** A HintDb for crelations. *) + +Ltac solve_crelation := + match goal with + | [ |- ?R ?x ?x ] => reflexivity + | [ H : ?R ?x ?y |- ?R ?y ?x ] => symmetry ; exact H + end. + +Hint Extern 4 => solve_crelation : crelations. + +(** We can already dualize all these properties. *) + +(** * Standard instances. *) + +Ltac reduce_hyp H := + match type of H with + | context [ _ <-> _ ] => fail 1 + | _ => red in H ; try reduce_hyp H + end. + +Ltac reduce_goal := + match goal with + | [ |- _ <-> _ ] => fail 1 + | _ => red ; intros ; try reduce_goal + end. + +Tactic Notation "reduce" "in" hyp(Hid) := reduce_hyp Hid. + +Ltac reduce := reduce_goal. + +Tactic Notation "apply" "*" constr(t) := + first [ refine t | refine (t _) | refine (t _ _) | refine (t _ _ _) | refine (t _ _ _ _) | + refine (t _ _ _ _ _) | refine (t _ _ _ _ _ _) | refine (t _ _ _ _ _ _ _) ]. + +Ltac simpl_crelation := + unfold flip, impl, arrow ; try reduce ; program_simpl ; + try ( solve [ dintuition ]). + +Local Obligation Tactic := simpl_crelation. + +(** Logical implication. *) + +Program Instance impl_Reflexive : Reflexive impl. +Program Instance impl_Transitive : Transitive impl. + +(** Logical equivalence. *) + +Instance iff_Reflexive : Reflexive iff := iff_refl. +Instance iff_Symmetric : Symmetric iff := iff_sym. +Instance iff_Transitive : Transitive iff := iff_trans. + +(** Logical equivalence [iff] is an equivalence crelation. *) + +Program Instance iff_equivalence : Equivalence iff. +Program Instance arrow_Reflexive : Reflexive arrow. +Program Instance arrow_Transitive : Transitive arrow. + +Instance iffT_Reflexive : Reflexive iffT. +Proof. firstorder. Defined. +Instance iffT_Symmetric : Symmetric iffT. +Proof. firstorder. Defined. +Instance iffT_Transitive : Transitive iffT. +Proof. firstorder. Defined. + +(** We now develop a generalization of results on crelations for arbitrary predicates. + The resulting theory can be applied to homogeneous binary crelations but also to + arbitrary n-ary predicates. *) + +Local Open Scope list_scope. + +(** A compact representation of non-dependent arities, with the codomain singled-out. *) + +(** We define the various operations which define the algebra on binary crelations *) +Section Binary. + Context {A : Type}. + + Definition relation_equivalence : crelation (crelation A) := + fun R R' => forall x y, iffT (R x y) (R' x y). + + Global Instance: RewriteRelation relation_equivalence. + + Definition relation_conjunction (R : crelation A) (R' : crelation A) : crelation A := + fun x y => prod (R x y) (R' x y). + + Definition relation_disjunction (R : crelation A) (R' : crelation A) : crelation A := + fun x y => sum (R x y) (R' x y). + + (** Relation equivalence is an equivalence, and subrelation defines a partial order. *) + + Set Automatic Introduction. + + Global Instance relation_equivalence_equivalence : + Equivalence relation_equivalence. + Proof. split; red; unfold relation_equivalence, iffT. firstorder. + firstorder. + intros. specialize (X x0 y0). specialize (X0 x0 y0). firstorder. + Qed. + + Global Instance relation_implication_preorder : PreOrder (@subrelation A). + Proof. firstorder. Qed. + + (** *** Partial Order. + A partial order is a preorder which is additionally antisymmetric. + We give an equivalent definition, up-to an equivalence crelation + on the carrier. *) + + Class PartialOrder eqA `{equ : Equivalence A eqA} R `{preo : PreOrder A R} := + partial_order_equivalence : relation_equivalence eqA (relation_conjunction R (flip R)). + + (** The equivalence proof is sufficient for proving that [R] must be a + morphism for equivalence (see Morphisms). It is also sufficient to + show that [R] is antisymmetric w.r.t. [eqA] *) + + Global Instance partial_order_antisym `(PartialOrder eqA R) : ! Antisymmetric A eqA R. + Proof with auto. + reduce_goal. + apply H. firstorder. + Qed. + + Lemma PartialOrder_inverse `(PartialOrder eqA R) : PartialOrder eqA (flip R). + Proof. unfold flip; constructor; unfold flip. intros. apply H. apply symmetry. apply X. + unfold relation_conjunction. intros [H1 H2]. apply H. constructor; assumption. Qed. +End Binary. + +Hint Extern 3 (PartialOrder (flip _)) => class_apply PartialOrder_inverse : typeclass_instances. + +(** The partial order defined by subrelation and crelation equivalence. *) + +(* Program Instance subrelation_partial_order : *) +(* ! PartialOrder (crelation A) relation_equivalence subrelation. *) +(* Obligation Tactic := idtac. *) + +(* Next Obligation. *) +(* Proof. *) +(* intros x. refine (fun x => x). *) +(* Qed. *) + +Typeclasses Opaque relation_equivalence. + + diff --git a/theories/Classes/DecidableClass.v b/theories/Classes/DecidableClass.v new file mode 100644 index 00000000..9fe3d0fe --- /dev/null +++ b/theories/Classes/DecidableClass.v @@ -0,0 +1,92 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* 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 (Decidable:=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. *) + +Require Import Bool Arith ZArith. + +Program Instance Decidable_eq_bool : forall (x y : bool), Decidable (eq x y) := { + Decidable_witness := Bool.eqb x y +}. +Next Obligation. + apply eqb_true_iff. +Qed. + +Program Instance Decidable_eq_nat : forall (x y : nat), Decidable (eq x y) := { + Decidable_witness := Nat.eqb x y +}. +Next Obligation. + apply Nat.eqb_eq. +Qed. + +Program Instance Decidable_le_nat : forall (x y : nat), Decidable (x <= y) := { + Decidable_witness := Nat.leb x y +}. +Next Obligation. + apply Nat.leb_le. +Qed. + +Program Instance Decidable_eq_Z : forall (x y : Z), Decidable (eq x y) := { + Decidable_witness := Z.eqb x y +}. +Next Obligation. + apply Z.eqb_eq. +Qed. diff --git a/theories/Classes/EquivDec.v b/theories/Classes/EquivDec.v index 8e3715ff..59e800c2 100644 --- a/theories/Classes/EquivDec.v +++ b/theories/Classes/EquivDec.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* in_right end }. - Solve Obligations using unfold equiv, complement in * ; program_simpl ; intuition (discriminate || eauto). - - Next Obligation. destruct y ; intuition eauto. Defined. + Next Obligation. destruct y ; unfold not in *; eauto. Defined. - Solve Obligations using unfold equiv, complement in * ; program_simpl ; intuition (discriminate || eauto). + Solve Obligations with unfold equiv, complement in * ; + program_simpl ; intuition (discriminate || eauto). diff --git a/theories/Classes/Equivalence.v b/theories/Classes/Equivalence.v index 0e9adf64..c281af80 100644 --- a/theories/Classes/Equivalence.v +++ b/theories/Classes/Equivalence.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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' (proj1_sig f x) (proj1_sig g y)). + Equivalence (fun (f g : respecting eqa eqb) => + forall (x y : A), R x y -> R' (proj1_sig f x) (proj1_sig g y)). - Solve Obligations using unfold respecting in * ; simpl_relation ; program_simpl. + Solve Obligations with unfold respecting in * ; simpl_relation ; program_simpl. Next Obligation. - Proof. - unfold respecting in *. program_simpl. transitivity (y y0); auto. apply H0. reflexivity. + 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]. *) -Program Instance pointwise_equivalence {A} `(eqb : Equivalence B eqB) : +Instance pointwise_reflexive {A} `(reflb : Reflexive B eqB) : + Reflexive (pointwise_relation A eqB) | 9. +Proof. firstorder. Qed. +Instance pointwise_symmetric {A} `(symb : Symmetric B eqB) : + Symmetric (pointwise_relation A eqB) | 9. +Proof. firstorder. Qed. +Instance pointwise_transitive {A} `(transb : Transitive B eqB) : + Transitive (pointwise_relation A eqB) | 9. +Proof. firstorder. Qed. +Instance pointwise_equivalence {A} `(eqb : Equivalence B eqB) : Equivalence (pointwise_relation A eqB) | 9. - - Next Obligation. - Proof. - transitivity (y a) ; auto. - Qed. +Proof. split; apply _. Qed. diff --git a/theories/Classes/Init.v b/theories/Classes/Init.v index 1a56c1a3..9574cf85 100644 --- a/theories/Classes/Init.v +++ b/theories/Classes/Init.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* B) _ _] goal, making proof-search much + slower. A cleaner solution would be to be able to set different + priorities in different hint bases and select a particular hint + database for resolution of a type class constraint. *) + + Class ProperProxy (R : relation A) (m : A) : Prop := + proper_proxy : R m m. + + Lemma eq_proper_proxy (x : A) : ProperProxy (@eq A) x. + Proof. firstorder. Qed. + + Lemma reflexive_proper_proxy `(Reflexive A R) (x : A) : ProperProxy R x. + Proof. firstorder. Qed. + + Lemma proper_proper_proxy x `(Proper R x) : ProperProxy R x. + Proof. firstorder. Qed. + + (** Respectful morphisms. *) + + (** The fully dependent version, not used yet. *) + + Definition respectful_hetero (A B : Type) (C : A -> Type) (D : B -> Type) (R : A -> B -> Prop) @@ -45,18 +69,24 @@ Definition respectful_hetero (forall x : A, C x) -> (forall x : B, D x) -> Prop := fun f g => forall x y, R x y -> R' x y (f x) (g y). -(** The non-dependent version is an instance where we forget dependencies. *) + (** The non-dependent version is an instance where we forget dependencies. *) + + Definition respectful (R : relation A) (R' : relation B) : relation (A -> B) := + Eval compute in @respectful_hetero A A (fun _ => B) (fun _ => B) R (fun _ _ => R'). -Definition respectful {A B : Type} - (R : relation A) (R' : relation B) : relation (A -> B) := - Eval compute in @respectful_hetero A A (fun _ => B) (fun _ => B) R (fun _ _ => R'). +End Proper. -(** Notations reminiscent of the old syntax for declaring morphisms. *) +(** We favor the use of Leibniz equality or a declared reflexive relation + when resolving [ProperProxy], otherwise, if the relation is given (not an evar), + we fall back to [Proper]. *) +Hint Extern 1 (ProperProxy _ _) => + class_apply @eq_proper_proxy || class_apply @reflexive_proper_proxy : typeclass_instances. -Delimit Scope signature_scope with signature. +Hint Extern 2 (ProperProxy ?R _) => + not_evar R; class_apply @proper_proper_proxy : typeclass_instances. -Arguments Proper {A}%type R%signature m. -Arguments respectful {A B}%type (R R')%signature _ _. +(** Notations reminiscent of the old syntax for declaring morphisms. *) +Delimit Scope signature_scope with signature. Module ProperNotations. @@ -66,11 +96,14 @@ Module ProperNotations. Notation " R ==> R' " := (@respectful _ _ (R%signature) (R'%signature)) (right associativity, at level 55) : signature_scope. - Notation " R --> R' " := (@respectful _ _ (inverse (R%signature)) (R'%signature)) + Notation " R --> R' " := (@respectful _ _ (flip (R%signature)) (R'%signature)) (right associativity, at level 55) : signature_scope. End ProperNotations. +Arguments Proper {A}%type R%signature m. +Arguments respectful {A B}%type (R R')%signature _ _. + Export ProperNotations. Local Open Scope signature_scope. @@ -106,80 +139,89 @@ Ltac f_equiv := assert (H : (Rx==>R)%signature f f'); unfold Rx in *; clear Rx; [ f_equiv | apply H; clear H; try reflexivity ] | |- ?R ?f ?f' => - try reflexivity; - change (Proper R f); eauto with typeclass_instances; fail + solve [change (Proper R f); eauto with typeclass_instances | reflexivity ] | _ => idtac end. -(** [forall_def] reifies the dependent product as a definition. *) - -Definition forall_def {A : Type} (B : A -> Type) : Type := forall x : A, B x. - -(** Dependent pointwise lifting of a relation on the range. *) - -Definition forall_relation {A : Type} {B : A -> Type} - (sig : forall a, relation (B a)) : relation (forall x, B x) := - fun f g => forall a, sig a (f a) (g a). - -Arguments forall_relation {A B}%type sig%signature _ _. - -(** Non-dependent pointwise lifting *) +Section Relations. + Let U := Type. + Context {A B : U} (P : A -> U). + + (** [forall_def] reifies the dependent product as a definition. *) + + Definition forall_def : Type := forall x : A, P x. + + (** Dependent pointwise lifting of a relation on the range. *) + + Definition forall_relation + (sig : forall a, relation (P a)) : relation (forall x, P x) := + fun f g => forall a, sig a (f a) (g a). + + (** Non-dependent pointwise lifting *) + Definition pointwise_relation (R : relation B) : relation (A -> B) := + fun f g => forall a, R (f a) (g a). + + Lemma pointwise_pointwise (R : relation B) : + relation_equivalence (pointwise_relation R) (@eq A ==> R). + Proof. intros. split; reduce; subst; firstorder. Qed. + + (** Subrelations induce a morphism on the identity. *) + + Global Instance subrelation_id_proper `(subrelation A RA RA') : Proper (RA ==> RA') id. + Proof. firstorder. Qed. + + (** The subrelation property goes through products as usual. *) + + Lemma subrelation_respectful `(subl : subrelation A RA' RA, subr : subrelation B RB RB') : + subrelation (RA ==> RB) (RA' ==> RB'). + Proof. unfold subrelation in *; firstorder. Qed. + + (** And of course it is reflexive. *) + + Lemma subrelation_refl R : @subrelation A R R. + Proof. unfold subrelation; firstorder. Qed. + + (** [Proper] is itself a covariant morphism for [subrelation]. + We use an unconvertible premise to avoid looping. + *) + + Lemma subrelation_proper `(mor : Proper A R' m) + `(unc : Unconvertible (relation A) R R') + `(sub : subrelation A R' R) : Proper R m. + Proof. + intros. apply sub. apply mor. + Qed. -Definition pointwise_relation (A : Type) {B : Type} (R : relation B) : relation (A -> B) := - Eval compute in forall_relation (B:=fun _ => B) (fun _ => R). + Global Instance proper_subrelation_proper : + Proper (subrelation ++> eq ==> impl) (@Proper A). + Proof. reduce. subst. firstorder. Qed. -Lemma pointwise_pointwise A B (R : relation B) : - relation_equivalence (pointwise_relation A R) (@eq A ==> R). -Proof. intros. split. simpl_relation. firstorder. Qed. - -(** We can build a PER on the Coq function space if we have PERs on the domain and - codomain. *) + Global Instance pointwise_subrelation `(sub : subrelation B R R') : + subrelation (pointwise_relation R) (pointwise_relation R') | 4. + Proof. reduce. unfold pointwise_relation in *. apply sub. apply H. Qed. + + (** For dependent function types. *) + Lemma forall_subrelation (R S : forall x : A, relation (P x)) : + (forall a, subrelation (R a) (S a)) -> subrelation (forall_relation R) (forall_relation S). + Proof. reduce. apply H. apply H0. Qed. +End Relations. +Typeclasses Opaque respectful pointwise_relation forall_relation. +Arguments forall_relation {A P}%type sig%signature _ _. +Arguments pointwise_relation A%type {B}%type R%signature _ _. + Hint Unfold Reflexive : core. Hint Unfold Symmetric : core. Hint Unfold Transitive : core. -Typeclasses Opaque respectful pointwise_relation forall_relation. - -Program Instance respectful_per `(PER A R, PER B R') : PER (R ==> R'). - - Next Obligation. - Proof with auto. - assert(R x0 x0). - transitivity y0... symmetry... - transitivity (y x0)... - Qed. - -(** Subrelations induce a morphism on the identity. *) - -Instance subrelation_id_proper `(subrelation A R₁ R₂) : Proper (R₁ ==> R₂) id. -Proof. firstorder. Qed. - -(** The subrelation property goes through products as usual. *) - -Lemma subrelation_respectful `(subl : subrelation A R₂ R₁, subr : subrelation B S₁ S₂) : - subrelation (R₁ ==> S₁) (R₂ ==> S₂). -Proof. simpl_relation. apply subr. apply H. apply subl. apply H0. Qed. - -(** And of course it is reflexive. *) - -Lemma subrelation_refl A R : @subrelation A R R. -Proof. simpl_relation. Qed. - +(** Resolution with subrelation: favor decomposing products over applying reflexivity + for unconstrained goals. *) Ltac subrelation_tac T U := (is_ground T ; is_ground U ; class_apply @subrelation_refl) || class_apply @subrelation_respectful || class_apply @subrelation_refl. Hint Extern 3 (@subrelation _ ?T ?U) => subrelation_tac T U : typeclass_instances. -(** [Proper] is itself a covariant morphism for [subrelation]. *) - -Lemma subrelation_proper `(mor : Proper A R₁ m, unc : Unconvertible (relation A) R₁ R₂, - sub : subrelation A R₁ R₂) : Proper R₂ m. -Proof. - intros. apply sub. apply mor. -Qed. - CoInductive apply_subrelation : Prop := do_subrelation. Ltac proper_subrelation := @@ -189,117 +231,112 @@ Ltac proper_subrelation := Hint Extern 5 (@Proper _ ?H _) => proper_subrelation : typeclass_instances. -Instance proper_subrelation_proper : - Proper (subrelation ++> eq ==> impl) (@Proper A). -Proof. reduce. subst. firstorder. Qed. - (** Essential subrelation instances for [iff], [impl] and [pointwise_relation]. *) Instance iff_impl_subrelation : subrelation iff impl | 2. Proof. firstorder. Qed. -Instance iff_inverse_impl_subrelation : subrelation iff (inverse impl) | 2. +Instance iff_flip_impl_subrelation : subrelation iff (flip impl) | 2. Proof. firstorder. Qed. -Instance pointwise_subrelation {A} `(sub : subrelation B R R') : - subrelation (pointwise_relation A R) (pointwise_relation A R') | 4. -Proof. reduce. unfold pointwise_relation in *. apply sub. apply H. Qed. - -(** For dependent function types. *) -Lemma forall_subrelation A (B : A -> Type) (R S : forall x : A, relation (B x)) : - (forall a, subrelation (R a) (S a)) -> subrelation (forall_relation R) (forall_relation S). -Proof. reduce. apply H. apply H0. Qed. - (** We use an extern hint to help unification. *) Hint Extern 4 (subrelation (@forall_relation ?A ?B ?R) (@forall_relation _ _ ?S)) => apply (@forall_subrelation A B R S) ; intro : typeclass_instances. -(** Any symmetric relation is equal to its inverse. *) - -Lemma subrelation_symmetric A R `(Symmetric A R) : subrelation (inverse R) R. -Proof. reduce. red in H0. symmetry. assumption. Qed. +Section GenericInstances. + (* Share universes *) + Let U := Type. + Context {A B C : U}. -Hint Extern 4 (subrelation (inverse _) _) => - class_apply @subrelation_symmetric : typeclass_instances. - -(** The complement of a relation conserves its proper elements. *) + (** We can build a PER on the Coq function space if we have PERs on the domain and + codomain. *) + + Program Instance respectful_per `(PER A R, PER B R') : PER (R ==> R'). -Program Definition complement_proper - `(mR : Proper (A -> A -> Prop) (RA ==> RA ==> iff) R) : - Proper (RA ==> RA ==> iff) (complement R) := _. + Next Obligation. + Proof with auto. + assert(R x0 x0). + transitivity y0... symmetry... + transitivity (y x0)... + Qed. - Next Obligation. + (** The complement of a relation conserves its proper elements. *) + + Program Definition complement_proper + `(mR : Proper (A -> A -> Prop) (RA ==> RA ==> iff) R) : + Proper (RA ==> RA ==> iff) (complement R) := _. + + Next Obligation. Proof. unfold complement. pose (mR x y H x0 y0 H0). intuition. Qed. -Hint Extern 1 (Proper _ (complement _)) => - apply @complement_proper : typeclass_instances. - -(** The [inverse] too, actually the [flip] instance is a bit more general. *) - -Program Definition flip_proper - `(mor : Proper (A -> B -> C) (RA ==> RB ==> RC) f) : - Proper (RB ==> RA ==> RC) (flip f) := _. + (** The [flip] too, actually the [flip] instance is a bit more general. *) + Program Definition flip_proper + `(mor : Proper (A -> B -> C) (RA ==> RB ==> RC) f) : + Proper (RB ==> RA ==> RC) (flip f) := _. + Next Obligation. Proof. apply mor ; auto. Qed. -Hint Extern 1 (Proper _ (flip _)) => - apply @flip_proper : typeclass_instances. -(** Every Transitive relation gives rise to a binary morphism on [impl], + (** Every Transitive relation gives rise to a binary morphism on [impl], contravariant in the first argument, covariant in the second. *) - -Program Instance trans_contra_co_morphism - `(Transitive A R) : Proper (R --> R ++> impl) R. - + + Global Program + Instance trans_contra_co_morphism + `(Transitive A R) : Proper (R --> R ++> impl) R. + Next Obligation. Proof with auto. transitivity x... transitivity x0... Qed. -(** Proper declarations for partial applications. *) + (** Proper declarations for partial applications. *) -Program Instance trans_contra_inv_impl_morphism - `(Transitive A R) : Proper (R --> inverse impl) (R x) | 3. + Global Program + Instance trans_contra_inv_impl_morphism + `(Transitive A R) : Proper (R --> flip impl) (R x) | 3. Next Obligation. Proof with auto. transitivity y... Qed. -Program Instance trans_co_impl_morphism - `(Transitive A R) : Proper (R ++> impl) (R x) | 3. + Global Program + Instance trans_co_impl_morphism + `(Transitive A R) : Proper (R ++> impl) (R x) | 3. Next Obligation. Proof with auto. transitivity x0... Qed. -Program Instance trans_sym_co_inv_impl_morphism - `(PER A R) : Proper (R ++> inverse impl) (R x) | 3. + Global Program + Instance trans_sym_co_inv_impl_morphism + `(PER A R) : Proper (R ++> flip impl) (R x) | 3. Next Obligation. Proof with auto. transitivity y... symmetry... Qed. -Program Instance trans_sym_contra_impl_morphism - `(PER A R) : Proper (R --> impl) (R x) | 3. + Global Program Instance trans_sym_contra_impl_morphism + `(PER A R) : Proper (R --> impl) (R x) | 3. Next Obligation. Proof with auto. transitivity x0... symmetry... Qed. -Program Instance per_partial_app_morphism + Global Program Instance per_partial_app_morphism `(PER A R) : Proper (R ==> iff) (R x) | 2. Next Obligation. @@ -310,20 +347,21 @@ Program Instance per_partial_app_morphism symmetry... Qed. -(** Every Transitive relation induces a morphism by "pushing" an [R x y] on the left of an [R x z] proof - to get an [R y z] goal. *) + (** Every Transitive relation induces a morphism by "pushing" an [R x y] on the left of an [R x z] proof to get an [R y z] goal. *) -Program Instance trans_co_eq_inv_impl_morphism - `(Transitive A R) : Proper (R ==> (@eq A) ==> inverse impl) R | 2. + Global Program + Instance trans_co_eq_inv_impl_morphism + `(Transitive A R) : Proper (R ==> (@eq A) ==> flip impl) R | 2. Next Obligation. Proof with auto. transitivity y... Qed. -(** Every Symmetric and Transitive relation gives rise to an equivariant morphism. *) + (** Every Symmetric and Transitive relation gives rise to an equivariant morphism. *) -Program Instance PER_morphism `(PER A R) : Proper (R ==> R ==> iff) R | 1. + Global Program + Instance PER_morphism `(PER A R) : Proper (R ==> R ==> iff) R | 1. Next Obligation. Proof with auto. @@ -333,11 +371,11 @@ Program Instance PER_morphism `(PER A R) : Proper (R ==> R ==> iff) R | 1. transitivity y... transitivity y0... symmetry... Qed. -Lemma symmetric_equiv_inverse `(Symmetric A R) : relation_equivalence R (flip R). -Proof. firstorder. Qed. + Lemma symmetric_equiv_flip `(Symmetric A R) : relation_equivalence R (flip R). + Proof. firstorder. Qed. -Program Instance compose_proper A B C R₀ R₁ R₂ : - Proper ((R₁ ==> R₂) ==> (R₀ ==> R₁) ==> (R₀ ==> R₂)) (@compose A B C). + Global Program Instance compose_proper RA RB RC : + Proper ((RB ==> RC) ==> (RA ==> RB) ==> (RA ==> RC)) (@compose A B C). Next Obligation. Proof. @@ -345,68 +383,84 @@ Program Instance compose_proper A B C R₀ R₁ R₂ : unfold compose. apply H. apply H0. apply H1. Qed. -(** Coq functions are morphisms for Leibniz equality, - applied only if really needed. *) - -Instance reflexive_eq_dom_reflexive (A : Type) `(Reflexive B R') : - Reflexive (@Logic.eq A ==> R'). -Proof. simpl_relation. Qed. + (** Coq functions are morphisms for Leibniz equality, + applied only if really needed. *) -(** [respectful] is a morphism for relation equivalence. *) - -Instance respectful_morphism : - Proper (relation_equivalence ++> relation_equivalence ++> relation_equivalence) (@respectful A B). -Proof. - reduce. - unfold respectful, relation_equivalence, predicate_equivalence in * ; simpl in *. - split ; intros. + Global Instance reflexive_eq_dom_reflexive `(Reflexive B R') : + Reflexive (@Logic.eq A ==> R'). + Proof. simpl_relation. Qed. + (** [respectful] is a morphism for relation equivalence. *) + + Global Instance respectful_morphism : + Proper (relation_equivalence ++> relation_equivalence ++> relation_equivalence) + (@respectful A B). + Proof. + reduce. + unfold respectful, relation_equivalence, predicate_equivalence in * ; simpl in *. + split ; intros. + rewrite <- H0. apply H1. rewrite H. assumption. - + rewrite H0. apply H1. rewrite <- H. assumption. -Qed. - -(** Every element in the carrier of a reflexive relation is a morphism for this relation. - We use a proxy class for this case which is used internally to discharge reflexivity constraints. - The [Reflexive] instance will almost always be used, but it won't apply in general to any kind of - [Proper (A -> B) _ _] goal, making proof-search much slower. A cleaner solution would be to be able - to set different priorities in different hint bases and select a particular hint database for - resolution of a type class constraint.*) - -Class ProperProxy {A} (R : relation A) (m : A) : Prop := - proper_proxy : R m m. - -Lemma eq_proper_proxy A (x : A) : ProperProxy (@eq A) x. -Proof. firstorder. Qed. - -Lemma reflexive_proper_proxy `(Reflexive A R) (x : A) : ProperProxy R x. -Proof. firstorder. Qed. - -Lemma proper_proper_proxy `(Proper A R x) : ProperProxy R x. -Proof. firstorder. Qed. - -Hint Extern 1 (ProperProxy _ _) => - class_apply @eq_proper_proxy || class_apply @reflexive_proper_proxy : typeclass_instances. -Hint Extern 2 (ProperProxy ?R _) => not_evar R; class_apply @proper_proper_proxy : typeclass_instances. + Qed. -(** [R] is Reflexive, hence we can build the needed proof. *) + (** [R] is Reflexive, hence we can build the needed proof. *) -Lemma Reflexive_partial_app_morphism `(Proper (A -> B) (R ==> R') m, ProperProxy A R x) : - Proper R' (m x). -Proof. simpl_relation. Qed. + Lemma Reflexive_partial_app_morphism `(Proper (A -> B) (R ==> R') m, ProperProxy A R x) : + Proper R' (m x). + Proof. simpl_relation. Qed. + + Lemma flip_respectful (R : relation A) (R' : relation B) : + relation_equivalence (flip (R ==> R')) (flip R ==> flip R'). + Proof. + intros. + unfold flip, respectful. + split ; intros ; intuition. + Qed. -Class Params {A : Type} (of : A) (arity : nat). + + (** Treating flip: can't make them direct instances as we + need at least a [flip] present in the goal. *) + + Lemma flip1 `(subrelation A R' R) : subrelation (flip (flip R')) R. + Proof. firstorder. Qed. + + Lemma flip2 `(subrelation A R R') : subrelation R (flip (flip R')). + Proof. firstorder. Qed. + + (** That's if and only if *) + + Lemma eq_subrelation `(Reflexive A R) : subrelation (@eq A) R. + Proof. simpl_relation. Qed. + + (** Once we have normalized, we will apply this instance to simplify the problem. *) + + Definition proper_flip_proper `(mor : Proper A R m) : Proper (flip R) m := mor. + + (** Every reflexive relation gives rise to a morphism, + only for immediately solving goals without variables. *) + + Lemma reflexive_proper `{Reflexive A R} (x : A) : Proper R x. + Proof. firstorder. Qed. + + Lemma proper_eq (x : A) : Proper (@eq A) x. + Proof. intros. apply reflexive_proper. Qed. + +End GenericInstances. Class PartialApplication. CoInductive normalization_done : Prop := did_normalization. +Class Params {A : Type} (of : A) (arity : nat). + Ltac partial_application_tactic := let rec do_partial_apps H m cont := match m with @@ -450,68 +504,6 @@ Ltac partial_application_tactic := end end. -Hint Extern 4 (@Proper _ _ _) => partial_application_tactic : typeclass_instances. - -Lemma inverse_respectful : forall (A : Type) (R : relation A) (B : Type) (R' : relation B), - relation_equivalence (inverse (R ==> R')) (inverse R ==> inverse R'). -Proof. - intros. - unfold flip, respectful. - split ; intros ; intuition. -Qed. - -(** Special-purpose class to do normalization of signatures w.r.t. inverse. *) - -Class Normalizes (A : Type) (m : relation A) (m' : relation A) : Prop := - normalizes : relation_equivalence m m'. - -(** Current strategy: add [inverse] everywhere and reduce using [subrelation] - afterwards. *) - -Lemma inverse_atom A R : Normalizes A R (inverse (inverse R)). -Proof. - firstorder. -Qed. - -Lemma inverse_arrow `(NA : Normalizes A R (inverse R'''), NB : Normalizes B R' (inverse R'')) : - Normalizes (A -> B) (R ==> R') (inverse (R''' ==> R'')%signature). -Proof. unfold Normalizes in *. intros. - rewrite NA, NB. firstorder. -Qed. - -Ltac inverse := - match goal with - | [ |- Normalizes _ (respectful _ _) _ ] => class_apply @inverse_arrow - | _ => class_apply @inverse_atom - end. - -Hint Extern 1 (Normalizes _ _ _) => inverse : typeclass_instances. - -(** Treating inverse: can't make them direct instances as we - need at least a [flip] present in the goal. *) - -Lemma inverse1 `(subrelation A R' R) : subrelation (inverse (inverse R')) R. -Proof. firstorder. Qed. - -Lemma inverse2 `(subrelation A R R') : subrelation R (inverse (inverse R')). -Proof. firstorder. Qed. - -Hint Extern 1 (subrelation (flip _) _) => class_apply @inverse1 : typeclass_instances. -Hint Extern 1 (subrelation _ (flip _)) => class_apply @inverse2 : typeclass_instances. - -(** That's if and only if *) - -Lemma eq_subrelation `(Reflexive A R) : subrelation (@eq A) R. -Proof. simpl_relation. Qed. - -(* Hint Extern 3 (subrelation eq ?R) => not_evar R ; class_apply eq_subrelation : typeclass_instances. *) - -(** Once we have normalized, we will apply this instance to simplify the problem. *) - -Definition proper_inverse_proper `(mor : Proper A R m) : Proper (inverse R) m := mor. - -Hint Extern 2 (@Proper _ (flip _) _) => class_apply @proper_inverse_proper : typeclass_instances. - (** Bootstrap !!! *) Instance proper_proper : Proper (relation_equivalence ==> eq ==> iff) (@Proper A). @@ -525,46 +517,88 @@ Proof. apply H0. Qed. -Lemma proper_normalizes_proper `(Normalizes A R0 R1, Proper A R1 m) : Proper R0 m. -Proof. - red in H, H0. - setoid_rewrite H. - assumption. -Qed. - -Ltac proper_normalization := +Ltac proper_reflexive := match goal with | [ _ : normalization_done |- _ ] => fail 1 - | [ _ : apply_subrelation |- @Proper _ ?R _ ] => let H := fresh "H" in - set(H:=did_normalization) ; class_apply @proper_normalizes_proper + | _ => class_apply proper_eq || class_apply @reflexive_proper end. -Hint Extern 6 (@Proper _ _ _) => proper_normalization : typeclass_instances. -(** Every reflexive relation gives rise to a morphism, only for immediately solving goals without variables. *) +Hint Extern 1 (subrelation (flip _) _) => class_apply @flip1 : typeclass_instances. +Hint Extern 1 (subrelation _ (flip _)) => class_apply @flip2 : typeclass_instances. -Lemma reflexive_proper `{Reflexive A R} (x : A) - : Proper R x. -Proof. firstorder. Qed. +Hint Extern 1 (Proper _ (complement _)) => apply @complement_proper + : typeclass_instances. +Hint Extern 1 (Proper _ (flip _)) => apply @flip_proper + : typeclass_instances. +Hint Extern 2 (@Proper _ (flip _) _) => class_apply @proper_flip_proper + : typeclass_instances. +Hint Extern 4 (@Proper _ _ _) => partial_application_tactic + : typeclass_instances. +Hint Extern 7 (@Proper _ _ _) => proper_reflexive + : typeclass_instances. -Lemma proper_eq A (x : A) : Proper (@eq A) x. -Proof. intros. apply reflexive_proper. Qed. +(** Special-purpose class to do normalization of signatures w.r.t. flip. *) -Ltac proper_reflexive := +Section Normalize. + Context (A : Type). + + Class Normalizes (m : relation A) (m' : relation A) : Prop := + normalizes : relation_equivalence m m'. + + (** Current strategy: add [flip] everywhere and reduce using [subrelation] + afterwards. *) + + Lemma proper_normalizes_proper `(Normalizes R0 R1, Proper A R1 m) : Proper R0 m. + Proof. + red in H, H0. + rewrite H. + assumption. + Qed. + + Lemma flip_atom R : Normalizes R (flip (flip R)). + Proof. + firstorder. + Qed. + +End Normalize. + +Lemma flip_arrow {A : Type} {B : Type} + `(NA : Normalizes A R (flip R'''), NB : Normalizes B R' (flip R'')) : + Normalizes (A -> B) (R ==> R') (flip (R''' ==> R'')%signature). +Proof. + unfold Normalizes in *. intros. + unfold relation_equivalence in *. + unfold predicate_equivalence in *. simpl in *. + unfold respectful. unfold flip in *. firstorder. + apply NB. apply H. apply NA. apply H0. + apply NB. apply H. apply NA. apply H0. +Qed. + +Ltac normalizes := match goal with - | [ _ : normalization_done |- _ ] => fail 1 - | _ => class_apply proper_eq || class_apply @reflexive_proper + | [ |- Normalizes _ (respectful _ _) _ ] => class_apply @flip_arrow + | _ => class_apply @flip_atom end. -Hint Extern 7 (@Proper _ _ _) => proper_reflexive : typeclass_instances. +Ltac proper_normalization := + match goal with + | [ _ : normalization_done |- _ ] => fail 1 + | [ _ : apply_subrelation |- @Proper _ ?R _ ] => + let H := fresh "H" in + set(H:=did_normalization) ; class_apply @proper_normalizes_proper + end. +Hint Extern 1 (Normalizes _ _ _) => normalizes : typeclass_instances. +Hint Extern 6 (@Proper _ _ _) => proper_normalization + : typeclass_instances. (** When the relation on the domain is symmetric, we can - inverse the relation on the codomain. Same for binary functions. *) + flip the relation on the codomain. Same for binary functions. *) Lemma proper_sym_flip : forall `(Symmetric A R1)`(Proper (A->B) (R1==>R2) f), - Proper (R1==>inverse R2) f. + Proper (R1==>flip R2) f. Proof. intros A R1 Sym B R2 f Hf. intros x x' Hxx'. apply Hf, Sym, Hxx'. @@ -572,7 +606,7 @@ Qed. Lemma proper_sym_flip_2 : forall `(Symmetric A R1)`(Symmetric B R2)`(Proper (A->B->C) (R1==>R2==>R3) f), - Proper (R1==>R2==>inverse R3) f. + Proper (R1==>R2==>flip R3) f. Proof. intros A R1 Sym1 B R2 Sym2 C R3 f Hf. intros x x' Hxx' y y' Hyy'. apply Hf; auto. @@ -627,8 +661,6 @@ apply partial_order_antisym; auto. rewrite Hxz; auto. Qed. -Hint Extern 4 (StrictOrder (relation_conjunction _ _)) => - class_apply PartialOrder_StrictOrder : typeclass_instances. (** From a [StrictOrder] to the corresponding [PartialOrder]: [le = lt \/ eq]. @@ -659,5 +691,8 @@ elim (StrictOrder_Irreflexive x). transitivity y; auto. Qed. +Hint Extern 4 (StrictOrder (relation_conjunction _ _)) => + class_apply PartialOrder_StrictOrder : typeclass_instances. + Hint Extern 4 (PartialOrder _ (relation_disjunction _ _)) => class_apply StrictOrder_PartialOrder : typeclass_instances. diff --git a/theories/Classes/Morphisms_Prop.v b/theories/Classes/Morphisms_Prop.v index c3737658..096c96e5 100644 --- a/theories/Classes/Morphisms_Prop.v +++ b/theories/Classes/Morphisms_Prop.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* iff ==> iff) impl. Program Instance ex_iff_morphism {A : Type} : Proper (pointwise_relation A iff ==> iff) (@ex A). - Next Obligation. - Proof. - unfold pointwise_relation in H. - split ; intros. - destruct H0 as [x1 H1]. - exists x1. rewrite H in H1. assumption. - - destruct H0 as [x1 H1]. - exists x1. rewrite H. assumption. - Qed. - Program Instance ex_impl_morphism {A : Type} : Proper (pointwise_relation A impl ==> impl) (@ex A) | 1. - Next Obligation. - Proof. - unfold pointwise_relation in H. - exists H0. apply H. assumption. - Qed. - -Program Instance ex_inverse_impl_morphism {A : Type} : - Proper (pointwise_relation A (inverse impl) ==> inverse impl) (@ex A) | 1. - - Next Obligation. - Proof. - unfold pointwise_relation in H. - exists H0. apply H. assumption. - Qed. +Program Instance ex_flip_impl_morphism {A : Type} : + Proper (pointwise_relation A (flip impl) ==> flip impl) (@ex A) | 1. Program Instance all_iff_morphism {A : Type} : Proper (pointwise_relation A iff ==> iff) (@all A). - Next Obligation. - Proof. - unfold pointwise_relation, all in *. - intuition ; specialize (H x0) ; intuition. - Qed. - Program Instance all_impl_morphism {A : Type} : Proper (pointwise_relation A impl ==> impl) (@all A) | 1. - Next Obligation. - Proof. - unfold pointwise_relation, all in *. - intuition ; specialize (H x0) ; intuition. - Qed. - -Program Instance all_inverse_impl_morphism {A : Type} : - Proper (pointwise_relation A (inverse impl) ==> inverse impl) (@all A) | 1. - - Next Obligation. - Proof. - unfold pointwise_relation, all in *. - intuition ; specialize (H x0) ; intuition. - Qed. +Program Instance all_flip_impl_morphism {A : Type} : + Proper (pointwise_relation A (flip impl) ==> flip impl) (@all A) | 1. (** Equivalent points are simultaneously accessible or not *) @@ -116,13 +75,13 @@ Instance Acc_pt_morphism {A:Type}(E R : A->A->Prop) Proof. apply proper_sym_impl_iff; auto with *. intros x y EQ WF. apply Acc_intro; intros z Hz. - rewrite <- EQ in Hz. now apply Acc_inv with x. +rewrite <- EQ in Hz. now apply Acc_inv with x. Qed. (** Equivalent relations have the same accessible points *) Instance Acc_rel_morphism {A:Type} : - Proper (@relation_equivalence A ==> Logic.eq ==> iff) (@Acc A). + Proper (relation_equivalence ==> Logic.eq ==> iff) (@Acc A). Proof. apply proper_sym_impl_iff_2. red; now symmetry. red; now symmetry. intros R R' EQ a a' Ha WF. subst a'. @@ -133,7 +92,7 @@ Qed. (** Equivalent relations are simultaneously well-founded or not *) Instance well_founded_morphism {A : Type} : - Proper (@relation_equivalence A ==> iff) (@well_founded A). + Proper (relation_equivalence ==> iff) (@well_founded A). Proof. unfold well_founded. solve_proper. Qed. diff --git a/theories/Classes/Morphisms_Relations.v b/theories/Classes/Morphisms_Relations.v index 34115e57..68a8c06a 100644 --- a/theories/Classes/Morphisms_Relations.v +++ b/theories/Classes/Morphisms_Relations.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* (* Predicate equivalence is exactly the same as the pointwise lifting of [iff]. *) -Require Import List. - Lemma predicate_equivalence_pointwise (l : Tlist) : Proper (@predicate_equivalence l ==> pointwise_lifting iff l) id. Proof. do 2 red. unfold predicate_equivalence. auto. Qed. @@ -40,7 +38,7 @@ 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 instanciation at relation allows to rewrite applications of relations +(** The instantiation at relation allows rewriting applications of relations [R x y] to [R' x y] when [R] and [R'] are in [relation_equivalence]. *) Instance relation_equivalence_pointwise : @@ -52,6 +50,6 @@ Instance subrelation_pointwise : Proof. intro. apply (predicate_implication_pointwise (Tcons A (Tcons A Tnil))). Qed. -Lemma inverse_pointwise_relation A (R : relation A) : - relation_equivalence (pointwise_relation A (inverse R)) (inverse (pointwise_relation A R)). +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/theories/Classes/RelationClasses.v b/theories/Classes/RelationClasses.v index 5c4dd532..1a40e5d5 100644 --- a/theories/Classes/RelationClasses.v +++ b/theories/Classes/RelationClasses.v @@ -1,7 +1,7 @@ (* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* R x y -> False. - -(** Opaque for proof-search. *) -Typeclasses Opaque complement. - -(** These are convertible. *) - -Lemma complement_inverse : forall A (R : relation A), complement (inverse R) = inverse (complement R). -Proof. reflexivity. Qed. +Generalizable Variables A B C D R S T U l eqA eqB eqC eqD. -(** We rebind relations in separate classes to be able to overload each proof. *) +(** We allow to unfold the [relation] definition while doing morphism search. *) -Set Implicit Arguments. -Unset Strict Implicit. +Section Defs. + Context {A : Type}. + + (** We rebind relational properties in separate classes to be able to overload each proof. *) + + Class Reflexive (R : relation A) := + reflexivity : forall x : A, R x x. + + Definition complement (R : relation A) : relation A := fun x y => R x y -> False. + + (** Opaque for proof-search. *) + Typeclasses Opaque complement. + + (** These are convertible. *) + Lemma complement_inverse R : complement (flip R) = flip (complement R). + Proof. reflexivity. Qed. + + Class Irreflexive (R : relation A) := + irreflexivity : Reflexive (complement R). + + Class Symmetric (R : relation A) := + symmetry : forall {x y}, R x y -> R y x. + + Class Asymmetric (R : relation A) := + asymmetry : forall {x y}, R x y -> R y x -> False. + + Class Transitive (R : relation A) := + transitivity : forall {x y z}, R x y -> R y z -> R x z. + + (** Various combinations of reflexivity, symmetry and transitivity. *) + + (** A [PreOrder] is both Reflexive and Transitive. *) + + Class PreOrder (R : relation A) : Prop := { + PreOrder_Reflexive :> Reflexive R | 2 ; + PreOrder_Transitive :> Transitive R | 2 }. + + (** A [StrictOrder] is both Irreflexive and Transitive. *) + + Class StrictOrder (R : relation A) : Prop := { + StrictOrder_Irreflexive :> Irreflexive R ; + StrictOrder_Transitive :> Transitive R }. + + (** By definition, a strict order is also asymmetric *) + Global Instance StrictOrder_Asymmetric `(StrictOrder R) : Asymmetric R. + Proof. firstorder. Qed. + + (** A partial equivalence relation is Symmetric and Transitive. *) + + Class PER (R : relation A) : Prop := { + PER_Symmetric :> Symmetric R | 3 ; + PER_Transitive :> Transitive R | 3 }. + + (** Equivalence relations. *) + + Class Equivalence (R : relation A) : Prop := { + Equivalence_Reflexive :> Reflexive R ; + Equivalence_Symmetric :> Symmetric R ; + Equivalence_Transitive :> Transitive R }. + + (** An Equivalence is a PER plus reflexivity. *) + + Global Instance Equivalence_PER {R} `(E:Equivalence R) : PER R | 10 := + { }. + + (** We can now define antisymmetry w.r.t. an equivalence relation on the carrier. *) + + Class Antisymmetric eqA `{equ : Equivalence eqA} (R : relation A) := + antisymmetry : forall {x y}, R x y -> R y x -> eqA x y. + + Class subrelation (R R' : relation A) : Prop := + is_subrelation : forall {x y}, R x y -> R' x y. + + (** Any symmetric relation is equal to its inverse. *) + + Lemma subrelation_symmetric R `(Symmetric R) : subrelation (flip R) R. + Proof. hnf. intros. red in H0. apply symmetry. assumption. Qed. + + Section flip. + + Lemma flip_Reflexive `{Reflexive R} : Reflexive (flip R). + Proof. tauto. Qed. + + Program Definition flip_Irreflexive `(Irreflexive R) : Irreflexive (flip R) := + irreflexivity (R:=R). + + Program Definition flip_Symmetric `(Symmetric R) : Symmetric (flip R) := + fun x y H => symmetry (R:=R) H. + + Program Definition flip_Asymmetric `(Asymmetric R) : Asymmetric (flip R) := + fun x y H H' => asymmetry (R:=R) H H'. + + Program Definition flip_Transitive `(Transitive R) : Transitive (flip R) := + fun x y z H H' => transitivity (R:=R) H' H. + + Program Definition flip_Antisymmetric `(Antisymmetric eqA R) : + Antisymmetric eqA (flip R). + Proof. firstorder. Qed. + + (** Inversing the larger structures *) + + Lemma flip_PreOrder `(PreOrder R) : PreOrder (flip R). + Proof. firstorder. Qed. + + Lemma flip_StrictOrder `(StrictOrder R) : StrictOrder (flip R). + Proof. firstorder. Qed. + + Lemma flip_PER `(PER R) : PER (flip R). + Proof. firstorder. Qed. + + Lemma flip_Equivalence `(Equivalence R) : Equivalence (flip R). + Proof. firstorder. Qed. + + End flip. + + Section complement. + + Definition complement_Irreflexive `(Reflexive R) + : Irreflexive (complement R). + Proof. firstorder. Qed. + + Definition complement_Symmetric `(Symmetric R) : Symmetric (complement R). + Proof. firstorder. Qed. + End complement. + + + (** Rewrite relation on a given support: declares a relation as a rewrite + relation for use by the generalized rewriting tactic. + It helps choosing if a rewrite should be handled + by the generalized or the regular rewriting tactic using leibniz equality. + Users can declare an [RewriteRelation A RA] anywhere to declare default + relations. This is also done automatically by the [Declare Relation A RA] + commands. *) -Class Reflexive {A} (R : relation A) := - reflexivity : forall x, R x x. + Class RewriteRelation (RA : relation A). -Class Irreflexive {A} (R : relation A) := - irreflexivity : Reflexive (complement R). + (** Any [Equivalence] declared in the context is automatically considered + a rewrite relation. *) + + Global Instance equivalence_rewrite_relation `(Equivalence eqA) : RewriteRelation eqA. + + (** Leibniz equality. *) + Section Leibniz. + Global Instance eq_Reflexive : Reflexive (@eq A) := @eq_refl A. + Global Instance eq_Symmetric : Symmetric (@eq A) := @eq_sym A. + Global Instance eq_Transitive : Transitive (@eq A) := @eq_trans A. + + (** Leibinz equality [eq] is an equivalence relation. + The instance has low priority as it is always applicable + if only the type is constrained. *) + + Global Program Instance eq_equivalence : Equivalence (@eq A) | 10. + End Leibniz. + +End Defs. + +(** Default rewrite relations handled by [setoid_rewrite]. *) +Instance: RewriteRelation impl. +Instance: RewriteRelation iff. +(** Hints to drive the typeclass resolution avoiding loops + due to the use of full unification. *) Hint Extern 1 (Reflexive (complement _)) => class_apply @irreflexivity : typeclass_instances. +Hint Extern 3 (Symmetric (complement _)) => class_apply complement_Symmetric : typeclass_instances. +Hint Extern 3 (Irreflexive (complement _)) => class_apply complement_Irreflexive : typeclass_instances. -Class Symmetric {A} (R : relation A) := - symmetry : forall x y, R x y -> R y x. +Hint Extern 3 (Reflexive (flip _)) => apply flip_Reflexive : typeclass_instances. +Hint Extern 3 (Irreflexive (flip _)) => class_apply flip_Irreflexive : typeclass_instances. +Hint Extern 3 (Symmetric (flip _)) => class_apply flip_Symmetric : typeclass_instances. +Hint Extern 3 (Asymmetric (flip _)) => class_apply flip_Asymmetric : typeclass_instances. +Hint Extern 3 (Antisymmetric (flip _)) => class_apply flip_Antisymmetric : typeclass_instances. +Hint Extern 3 (Transitive (flip _)) => class_apply flip_Transitive : typeclass_instances. +Hint Extern 3 (StrictOrder (flip _)) => class_apply flip_StrictOrder : typeclass_instances. +Hint Extern 3 (PreOrder (flip _)) => class_apply flip_PreOrder : typeclass_instances. -Class Asymmetric {A} (R : relation A) := - asymmetry : forall x y, R x y -> R y x -> False. +Hint Extern 4 (subrelation (flip _) _) => + class_apply @subrelation_symmetric : typeclass_instances. -Class Transitive {A} (R : relation A) := - transitivity : forall x y z, R x y -> R y z -> R x z. +Arguments irreflexivity {A R Irreflexive} [x] _. -Hint Resolve @irreflexivity : ord. +Hint Resolve irreflexivity : ord. Unset Implicit Arguments. @@ -72,40 +220,6 @@ Hint Extern 4 => solve_relation : relations. (** We can already dualize all these properties. *) -Generalizable Variables A B C D R S T U l eqA eqB eqC eqD. - -Lemma flip_Reflexive `{Reflexive A R} : Reflexive (flip R). -Proof. tauto. Qed. - -Hint Extern 3 (Reflexive (flip _)) => apply flip_Reflexive : typeclass_instances. - -Program Definition flip_Irreflexive `(Irreflexive A R) : Irreflexive (flip R) := - irreflexivity (R:=R). - -Program Definition flip_Symmetric `(Symmetric A R) : Symmetric (flip R) := - fun x y H => symmetry (R:=R) H. - -Program Definition flip_Asymmetric `(Asymmetric A R) : Asymmetric (flip R) := - fun x y H H' => asymmetry (R:=R) H H'. - -Program Definition flip_Transitive `(Transitive A R) : Transitive (flip R) := - fun x y z H H' => transitivity (R:=R) H' H. - -Hint Extern 3 (Irreflexive (flip _)) => class_apply flip_Irreflexive : typeclass_instances. -Hint Extern 3 (Symmetric (flip _)) => class_apply flip_Symmetric : typeclass_instances. -Hint Extern 3 (Asymmetric (flip _)) => class_apply flip_Asymmetric : typeclass_instances. -Hint Extern 3 (Transitive (flip _)) => class_apply flip_Transitive : typeclass_instances. - -Definition Reflexive_complement_Irreflexive `(Reflexive A (R : relation A)) - : Irreflexive (complement R). -Proof. firstorder. Qed. - -Definition complement_Symmetric `(Symmetric A (R : relation A)) : Symmetric (complement R). -Proof. firstorder. Qed. - -Hint Extern 3 (Symmetric (complement _)) => class_apply complement_Symmetric : typeclass_instances. -Hint Extern 3 (Irreflexive (complement _)) => class_apply Reflexive_complement_Irreflexive : typeclass_instances. - (** * Standard instances. *) Ltac reduce_hyp H := @@ -130,7 +244,7 @@ Tactic Notation "apply" "*" constr(t) := Ltac simpl_relation := unfold flip, impl, arrow ; try reduce ; program_simpl ; - try ( solve [ intuition ]). + try ( solve [ dintuition ]). Local Obligation Tactic := simpl_relation. @@ -145,54 +259,6 @@ Instance iff_Reflexive : Reflexive iff := iff_refl. Instance iff_Symmetric : Symmetric iff := iff_sym. Instance iff_Transitive : Transitive iff := iff_trans. -(** Leibniz equality. *) - -Instance eq_Reflexive {A} : Reflexive (@eq A) := @eq_refl A. -Instance eq_Symmetric {A} : Symmetric (@eq A) := @eq_sym A. -Instance eq_Transitive {A} : Transitive (@eq A) := @eq_trans A. - -(** Various combinations of reflexivity, symmetry and transitivity. *) - -(** A [PreOrder] is both Reflexive and Transitive. *) - -Class PreOrder {A} (R : relation A) : Prop := { - PreOrder_Reflexive :> Reflexive R | 2 ; - PreOrder_Transitive :> Transitive R | 2 }. - -(** A partial equivalence relation is Symmetric and Transitive. *) - -Class PER {A} (R : relation A) : Prop := { - PER_Symmetric :> Symmetric R | 3 ; - PER_Transitive :> Transitive R | 3 }. - -(** Equivalence relations. *) - -Class Equivalence {A} (R : relation A) : Prop := { - Equivalence_Reflexive :> Reflexive R ; - Equivalence_Symmetric :> Symmetric R ; - Equivalence_Transitive :> Transitive R }. - -(** An Equivalence is a PER plus reflexivity. *) - -Instance Equivalence_PER `(Equivalence A R) : PER R | 10 := - { PER_Symmetric := Equivalence_Symmetric ; - PER_Transitive := Equivalence_Transitive }. - -(** We can now define antisymmetry w.r.t. an equivalence relation on the carrier. *) - -Class Antisymmetric A eqA `{equ : Equivalence A eqA} (R : relation A) := - antisymmetry : forall {x y}, R x y -> R y x -> eqA x y. - -Program Definition flip_antiSymmetric `(Antisymmetric A eqA R) : - Antisymmetric A eqA (flip R). -Proof. firstorder. Qed. - -(** Leibinz equality [eq] is an equivalence relation. - The instance has low priority as it is always applicable - if only the type is constrained. *) - -Program Instance eq_equivalence : Equivalence (@eq A) | 10. - (** Logical equivalence [iff] is an equivalence relation. *) Program Instance iff_equivalence : Equivalence iff. @@ -203,9 +269,6 @@ Program Instance iff_equivalence : Equivalence iff. Local Open Scope list_scope. -(* Notation " [ ] " := nil : list_scope. *) -(* Notation " [ x ; .. ; y ] " := (cons x .. (cons y nil) ..) (at level 1) : list_scope. *) - (** A compact representation of non-dependent arities, with the codomain singled-out. *) (* Note, we do not use [list Type] because it imposes unnecessary universe constraints *) @@ -316,7 +379,8 @@ Notation "∙⊥∙" := false_predicate : predicate_scope. (** Predicate equivalence is an equivalence, and predicate implication defines a preorder. *) -Program Instance predicate_equivalence_equivalence : Equivalence (@predicate_equivalence l). +Program Instance predicate_equivalence_equivalence : + Equivalence (@predicate_equivalence l). Next Obligation. induction l ; firstorder. @@ -345,106 +409,66 @@ Program Instance predicate_implication_preorder : (** We define the various operations which define the algebra on binary relations, from the general ones. *) -Definition relation_equivalence {A : Type} : relation (relation A) := - @predicate_equivalence (_::_::Tnil). - -Class subrelation {A:Type} (R R' : relation A) : Prop := - is_subrelation : @predicate_implication (A::A::Tnil) R R'. - -Arguments subrelation {A} R R'. - -Definition relation_conjunction {A} (R : relation A) (R' : relation A) : relation A := - @predicate_intersection (A::A::Tnil) R R'. - -Definition relation_disjunction {A} (R : relation A) (R' : relation A) : relation A := - @predicate_union (A::A::Tnil) R R'. - -(** Relation equivalence is an equivalence, and subrelation defines a partial order. *) - -Set Automatic Introduction. - -Instance relation_equivalence_equivalence (A : Type) : - Equivalence (@relation_equivalence A). -Proof. exact (@predicate_equivalence_equivalence (A::A::Tnil)). Qed. - -Instance relation_implication_preorder A : PreOrder (@subrelation A). -Proof. exact (@predicate_implication_preorder (A::A::Tnil)). Qed. - -(** *** Partial Order. +Section Binary. + Context {A : Type}. + + Definition relation_equivalence : relation (relation A) := + @predicate_equivalence (_::_::Tnil). + + Global Instance: RewriteRelation relation_equivalence. + + Definition relation_conjunction (R : relation A) (R' : relation A) : relation A := + @predicate_intersection (A::A::Tnil) R R'. + + Definition relation_disjunction (R : relation A) (R' : relation A) : relation A := + @predicate_union (A::A::Tnil) R R'. + + (** Relation equivalence is an equivalence, and subrelation defines a partial order. *) + + Set Automatic Introduction. + + Global Instance relation_equivalence_equivalence : + Equivalence relation_equivalence. + Proof. exact (@predicate_equivalence_equivalence (A::A::Tnil)). Qed. + + Global Instance relation_implication_preorder : PreOrder (@subrelation A). + Proof. exact (@predicate_implication_preorder (A::A::Tnil)). Qed. + + (** *** Partial Order. A partial order is a preorder which is additionally antisymmetric. We give an equivalent definition, up-to an equivalence relation on the carrier. *) -Class PartialOrder {A} eqA `{equ : Equivalence A eqA} R `{preo : PreOrder A R} := - partial_order_equivalence : relation_equivalence eqA (relation_conjunction R (inverse R)). + Class PartialOrder eqA `{equ : Equivalence A eqA} R `{preo : PreOrder A R} := + partial_order_equivalence : relation_equivalence eqA (relation_conjunction R (flip R)). + + (** The equivalence proof is sufficient for proving that [R] must be a + morphism for equivalence (see Morphisms). It is also sufficient to + show that [R] is antisymmetric w.r.t. [eqA] *) + + Global Instance partial_order_antisym `(PartialOrder eqA R) : ! Antisymmetric A eqA R. + Proof with auto. + reduce_goal. + pose proof partial_order_equivalence as poe. do 3 red in poe. + apply <- poe. firstorder. + Qed. -(** The equivalence proof is sufficient for proving that [R] must be a morphism - for equivalence (see Morphisms). - It is also sufficient to show that [R] is antisymmetric w.r.t. [eqA] *) -Instance partial_order_antisym `(PartialOrder A eqA R) : ! Antisymmetric A eqA R. -Proof with auto. - reduce_goal. - pose proof partial_order_equivalence as poe. do 3 red in poe. - apply <- poe. firstorder. -Qed. + Lemma PartialOrder_inverse `(PartialOrder eqA R) : PartialOrder eqA (flip R). + Proof. firstorder. Qed. +End Binary. + +Hint Extern 3 (PartialOrder (flip _)) => class_apply PartialOrder_inverse : typeclass_instances. (** The partial order defined by subrelation and relation equivalence. *) Program Instance subrelation_partial_order : ! PartialOrder (relation A) relation_equivalence subrelation. - Next Obligation. - Proof. - unfold relation_equivalence in *. compute; firstorder. - Qed. +Next Obligation. +Proof. + unfold relation_equivalence in *. compute; firstorder. +Qed. Typeclasses Opaque arrows predicate_implication predicate_equivalence - relation_equivalence pointwise_lifting. - -(** Rewrite relation on a given support: declares a relation as a rewrite - relation for use by the generalized rewriting tactic. - It helps choosing if a rewrite should be handled - by the generalized or the regular rewriting tactic using leibniz equality. - Users can declare an [RewriteRelation A RA] anywhere to declare default - relations. This is also done automatically by the [Declare Relation A RA] - commands. *) - -Class RewriteRelation {A : Type} (RA : relation A). - -Instance: RewriteRelation impl. -Instance: RewriteRelation iff. -Instance: RewriteRelation (@relation_equivalence A). - -(** Any [Equivalence] declared in the context is automatically considered - a rewrite relation. *) - -Instance equivalence_rewrite_relation `(Equivalence A eqA) : RewriteRelation eqA. - -(** Strict Order *) - -Class StrictOrder {A : Type} (R : relation A) : Prop := { - StrictOrder_Irreflexive :> Irreflexive R ; - StrictOrder_Transitive :> Transitive R -}. - -Instance StrictOrder_Asymmetric `(StrictOrder A R) : Asymmetric R. -Proof. firstorder. Qed. - -(** Inversing a [StrictOrder] gives another [StrictOrder] *) - -Lemma StrictOrder_inverse `(StrictOrder A R) : StrictOrder (inverse R). -Proof. firstorder. Qed. - -(** Same for [PartialOrder]. *) - -Lemma PreOrder_inverse `(PreOrder A R) : PreOrder (inverse R). -Proof. firstorder. Qed. - -Hint Extern 3 (StrictOrder (inverse _)) => class_apply StrictOrder_inverse : typeclass_instances. -Hint Extern 3 (PreOrder (inverse _)) => class_apply PreOrder_inverse : typeclass_instances. - -Lemma PartialOrder_inverse `(PartialOrder A eqA R) : PartialOrder eqA (inverse R). -Proof. firstorder. Qed. - -Hint Extern 3 (PartialOrder (inverse _)) => class_apply PartialOrder_inverse : typeclass_instances. + relation_equivalence pointwise_lifting. diff --git a/theories/Classes/RelationPairs.v b/theories/Classes/RelationPairs.v index 2b010206..cbde5f9a 100644 --- a/theories/Classes/RelationPairs.v +++ b/theories/Classes/RelationPairs.v @@ -9,8 +9,8 @@ (** * Relations over pairs *) +Require Import SetoidList. Require Import Relations Morphisms. - (* NB: This should be system-wide someday, but for that we need to fix the simpl tactic, since "simpl fst" would be refused for the moment. @@ -40,7 +40,7 @@ Generalizable Variables A B RA RB Ri Ro f. (** Any function from [A] to [B] allow to obtain a relation over [A] out of a relation over [B]. *) -Definition RelCompFun {A B}(R:relation B)(f:A->B) : relation A := +Definition RelCompFun {A} {B : Type}(R:relation B)(f:A->B) : relation A := fun a a' => R (f a) (f a'). Infix "@@" := RelCompFun (at level 30, right associativity) : signature_scope. @@ -62,13 +62,13 @@ Instance snd_measure : @Measure (A * B) B Snd. (** We define a product relation over [A*B]: each components should satisfy the corresponding initial relation. *) -Definition RelProd {A B}(RA:relation A)(RB:relation B) : relation (A*B) := - relation_conjunction (RA @@1) (RB @@2). +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). Infix "*" := RelProd : signature_scope. Section RelCompFun_Instances. - Context {A B : Type} (R : relation B). + Context {A : Type} {B : Type} (R : relation B). Global Instance RelCompFun_Reflexive `(Measure A B f, Reflexive _ R) : Reflexive (R@@f). @@ -94,57 +94,61 @@ Section RelCompFun_Instances. End RelCompFun_Instances. -Instance RelProd_Reflexive {A B}(RA:relation A)(RB:relation B) - `(Reflexive _ RA, Reflexive _ RB) : Reflexive (RA*RB). -Proof. firstorder. Qed. - -Instance RelProd_Symmetric {A B}(RA:relation A)(RB:relation B) - `(Symmetric _ RA, Symmetric _ RB) : Symmetric (RA*RB). -Proof. firstorder. Qed. - -Instance RelProd_Transitive {A B}(RA:relation A)(RB:relation B) - `(Transitive _ RA, Transitive _ RB) : Transitive (RA*RB). -Proof. firstorder. Qed. - -Program Instance RelProd_Equivalence {A B}(RA:relation A)(RB:relation B) - `(Equivalence _ RA, Equivalence _ RB) : Equivalence (RA*RB). - -Lemma FstRel_ProdRel {A B}(RA:relation A) : - relation_equivalence (RA @@1) (RA*(fun _ _ : B => True)). -Proof. firstorder. Qed. - -Lemma SndRel_ProdRel {A B}(RB:relation B) : - relation_equivalence (RB @@2) ((fun _ _ : A =>True) * RB). -Proof. firstorder. Qed. - -Instance FstRel_sub {A B} (RA:relation A)(RB:relation B): - subrelation (RA*RB) (RA @@1). -Proof. firstorder. Qed. - -Instance SndRel_sub {A B} (RA:relation A)(RB:relation B): - subrelation (RA*RB) (RB @@2). -Proof. firstorder. Qed. - -Instance pair_compat { A B } (RA:relation A)(RB:relation B) : - Proper (RA==>RB==> RA*RB) (@pair _ _). -Proof. firstorder. Qed. - -Instance fst_compat { A B } (RA:relation A)(RB:relation B) : - Proper (RA*RB ==> RA) Fst. -Proof. -intros (x,y) (x',y') (Hx,Hy); compute in *; auto. -Qed. - -Instance snd_compat { A B } (RA:relation A)(RB:relation B) : - Proper (RA*RB ==> RB) Snd. -Proof. -intros (x,y) (x',y') (Hx,Hy); compute in *; auto. -Qed. - -Instance RelCompFun_compat {A B}(f:A->B)(R : relation B) - `(Proper _ (Ri==>Ri==>Ro) R) : - Proper (Ri@@f==>Ri@@f==>Ro) (R@@f)%signature. -Proof. unfold RelCompFun; firstorder. Qed. +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. Hint Unfold RelProd RelCompFun. Hint Extern 2 (RelProd _ _ _ _) => split. diff --git a/theories/Classes/SetoidClass.v b/theories/Classes/SetoidClass.v index e7b94081..f20100fe 100644 --- a/theories/Classes/SetoidClass.v +++ b/theories/Classes/SetoidClass.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* elements_aux ((x,d) :: elements_aux acc r) l end. -(** then [elements] is an instanciation with an empty [acc] *) +(** then [elements] is an instantiation with an empty [acc] *) Definition elements := elements_aux nil. @@ -342,7 +342,7 @@ Notation "t #r" := (t_right t) (at level 9, format "t '#r'"). Fixpoint map (elt elt' : Type)(f : elt -> elt')(m : t elt) : t elt' := match m with - | Leaf => Leaf _ + | Leaf _ => Leaf _ | Node l x d r h => Node (map f l) x (f d) (map f r) h end. @@ -350,7 +350,7 @@ Fixpoint map (elt elt' : Type)(f : elt -> elt')(m : t elt) : t elt' := Fixpoint mapi (elt elt' : Type)(f : key -> elt -> elt')(m : t elt) : t elt' := match m with - | Leaf => Leaf _ + | Leaf _ => Leaf _ | Node l x d r h => Node (mapi f l) x (f x d) (mapi f r) h end. @@ -359,7 +359,7 @@ Fixpoint mapi (elt elt' : Type)(f : key -> elt -> elt')(m : t elt) : t elt' := Fixpoint map_option (elt elt' : Type)(f : key -> elt -> option elt')(m : t elt) : t elt' := match m with - | Leaf => Leaf _ + | 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) @@ -370,7 +370,7 @@ Fixpoint map_option (elt elt' : Type)(f : key -> elt -> option elt')(m : t elt) (** * Optimized map2 Suggestion by B. Gregoire: a [map2] function with specialized - arguments allowing to bypass some tree traversal. Instead of one + 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] @@ -389,8 +389,8 @@ Variable mapr : t elt' -> t elt''. Fixpoint map2_opt m1 m2 := match m1, m2 with - | Leaf, _ => mapr m2 - | _, Leaf => mapl m1 + | 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 @@ -534,7 +534,7 @@ Ltac order := match goal with | _ => MX.order end. -Ltac intuition_in := repeat progress (intuition; inv In; inv MapsTo). +Ltac intuition_in := repeat (intuition; inv In; inv MapsTo). (* Function/Functional Scheme can't deal with internal fix. Let's do its job by hand: *) @@ -1247,11 +1247,11 @@ Proof. intros m1 m2; functional induction (concat m1 m2); intros; auto; try factornode _x _x0 _x1 _x2 _x3 as m1. apply join_bst; auto. - change (bst (m2',xd)#1); rewrite <-e1; eauto. + change (bst (m2',xd)#1). rewrite <-e1; eauto. intros y Hy. apply H1; auto. rewrite remove_min_in, e1; simpl; auto. - change (gt_tree (m2',xd)#2#1 (m2',xd)#1); rewrite <-e1; eauto. + change (gt_tree (m2',xd)#2#1 (m2',xd)#1). rewrite <-e1; eauto. Qed. Hint Resolve concat_bst. @@ -1270,10 +1270,10 @@ Proof. inv bst. rewrite H2, join_find; auto; clear H2. - simpl; destruct X.compare; simpl; auto. + 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 l); apply H1; auto; rewrite H3; auto. + apply (MX.lt_not_gt Hlt); apply H1; auto; rewrite H3; auto. intros z Hz; apply H1; auto; rewrite H3; auto. Qed. @@ -1367,7 +1367,7 @@ Proof. induction s; simpl; intros; auto. rewrite IHs1, IHs2. unfold elements; simpl. - rewrite 2 IHs1, IHs2, <- !app_nil_end, !app_ass; auto. + rewrite 2 IHs1, IHs2, !app_nil_r, !app_ass; auto. Qed. Lemma elements_node : @@ -1376,7 +1376,7 @@ Lemma elements_node : elements (Node t1 x e t2 z) ++ l. Proof. unfold elements; simpl; intros. - rewrite !elements_app, <- !app_nil_end, !app_ass; auto. + rewrite !elements_app, !app_nil_r, !app_ass; auto. Qed. (** * Fold *) @@ -1424,7 +1424,7 @@ Qed. i.e. the list of elements actually compared *) Fixpoint flatten_e (e : enumeration elt) : list (key*elt) := match e with - | End => nil + | End _ => nil | More x e t r => (x,e) :: elements t ++ flatten_e r end. @@ -1433,14 +1433,14 @@ Lemma flatten_e_elements : elements l ++ flatten_e (More x d r e) = elements (Node l x d r z) ++ flatten_e e. Proof. - intros; simpl; apply elements_node. + 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; simpl; auto; intros. - rewrite IHs1; apply flatten_e_elements; auto. + induction s; auto; intros. + simpl flatten_e; rewrite IHs1; apply flatten_e_elements; auto. Qed. (** Proof of correction for the comparison *) @@ -1478,7 +1478,7 @@ 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]; simpl; intros; auto. + 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]. @@ -1491,9 +1491,9 @@ Lemma equal_IfEq : forall (m1 m2:t elt), IfEq (equal cmp m1 m2) (elements m1) (elements m2). Proof. intros; unfold equal. - rewrite (app_nil_end (elements m1)). + rewrite <- (app_nil_r (elements m1)). replace (elements m2) with (flatten_e (cons m2 (End _))) - by (rewrite cons_1; simpl; rewrite <-app_nil_end; auto). + by (rewrite cons_1; simpl; rewrite app_nil_r; auto). apply equal_cont_IfEq. intros. apply equal_end_IfEq; auto. @@ -1622,8 +1622,8 @@ Lemma map_option_find : forall (m:t elt)(x:key), Proof. intros m; functional induction (map_option f m); simpl; auto; intros; inv bst; rewrite join_find || rewrite concat_find; auto; simpl; - try destruct X.compare; simpl; auto. -rewrite (f_compat d e); auto. + 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; @@ -1631,7 +1631,7 @@ intros y H; 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 e); auto. +rewrite (f_compat d Heq); auto. rewrite <- IHt0, IHt; auto; nonify (find x0 l); auto. destruct (find x0 (map_option f r)); auto. @@ -1930,7 +1930,7 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. 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. + 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. @@ -2016,7 +2016,7 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: Definition compare_more x1 d1 (cont:R.enumeration D.t -> comparison) e2 := match e2 with - | R.End => Gt + | R.End _ => Gt | R.More x2 d2 r2 e2 => match X.compare x1 x2 with | EQ _ => match D.compare d1 d2 with @@ -2033,7 +2033,7 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: Fixpoint compare_cont s1 (cont:R.enumeration D.t -> comparison) e2 := match s1 with - | R.Leaf => cont e2 + | R.Leaf _ => cont e2 | R.Node l1 x1 d1 r1 _ => compare_cont l1 (compare_more x1 d1 (compare_cont r1 cont)) e2 end. @@ -2041,7 +2041,7 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: (** Initial continuation *) Definition compare_end (e2:R.enumeration D.t) := - match e2 with R.End => Eq | _ => Lt end. + match e2 with R.End _ => Eq | _ => Lt end. (** The complete comparison *) @@ -2084,7 +2084,7 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: (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]; simpl; intros; auto. + 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. @@ -2096,9 +2096,9 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: Cmp (compare_pure s1 s2) (R.elements s1) (R.elements s2). Proof. intros; unfold compare_pure. - rewrite (app_nil_end (R.elements s1)). + 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_end; auto). + (rewrite P.cons_1; simpl; rewrite app_nil_r; auto). auto using compare_cont_Cmp, compare_end_Cmp. Qed. diff --git a/theories/FSets/FMapFacts.v b/theories/FSets/FMapFacts.v index 0c1448c9..8c6f4b64 100644 --- a/theories/FSets/FMapFacts.v +++ b/theories/FSets/FMapFacts.v @@ -437,12 +437,6 @@ intros; do 2 rewrite mem_find_b; rewrite remove_o; unfold eqb. destruct (eq_dec x y); auto. Qed. -Definition option_map (A B:Type)(f:A->B)(o:option A) : option B := - match o with - | Some a => Some (f a) - | None => None - end. - Lemma map_o : forall m x (f:elt->elt'), find x (map f m) = option_map f (find x m). Proof. @@ -519,7 +513,7 @@ Proof. intros. rewrite eq_option_alt. intro e. rewrite <- find_mapsto_iff, elements_mapsto_iff. unfold eqb. -rewrite <- findA_NoDupA; intuition; try apply elements_3w; eauto. +rewrite <- findA_NoDupA; dintuition; try apply elements_3w; eauto. Qed. Lemma elements_b : forall m x, @@ -678,9 +672,9 @@ Qed. Add Parametric Morphism elt : (@Empty elt) with signature Equal ==> iff as Empty_m. Proof. -unfold Empty; intros m m' Hm; intuition. -rewrite <-Hm in H0; eauto. -rewrite Hm in H0; eauto. +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) @@ -708,18 +702,18 @@ 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; auto. -elim n; rewrite <-Hk; auto. -elim n; rewrite Hk; auto. +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; auto. -elim n; rewrite <-Hk; auto. -elim n; rewrite Hk; auto. +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') @@ -835,8 +829,8 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E). Definition uncurry {U V W : Type} (f : U -> V -> W) : U*V -> W := fun p => f (fst p) (snd p). - Definition of_list (l : list (key*elt)) := - List.fold_right (uncurry (@add _)) (empty _) l. + Definition of_list := + List.fold_right (uncurry (@add _)) (empty elt). Definition to_list := elements. @@ -867,7 +861,7 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E). inversion_clear Hnodup as [| ? ? Hnotin Hnodup']. specialize (IH k Hnodup'); clear Hnodup'. rewrite add_o, IH. - unfold eqb; do 2 destruct eq_dec; auto; elim n; eauto. + unfold eqb; do 2 destruct eq_dec as [|?Hnot]; auto; elim Hnot; eauto. Qed. Lemma of_list_2 : forall l, NoDupA eqk l -> @@ -934,7 +928,7 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E). 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; auto; elim n; eauto. + unfold eqb. do 2 destruct eq_dec as [|?Hnot]; auto; elim Hnot; eauto. inversion_clear Hdup; auto. apply IHl. intros; eapply Hstep'; eauto. @@ -1124,6 +1118,27 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E). auto with *. 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 * ). + assert (NoDupA eqk (rev (elements m2))) by (auto with * ). + apply fold_right_equivlistA_restr2 with (R:=complement eqk)(eqA:=eqke) + ; auto with *. + - 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 *. + 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. @@ -1871,14 +1886,9 @@ Module OrdProperties (M:S). find_mapsto_iff, (H0 t0), <- find_mapsto_iff, add_mapsto_iff by (auto with *). unfold O.eqke, O.ltk; simpl. - destruct (E.compare t0 x); intuition. - right; split; auto; ME.order. - ME.order. - elim H. - exists e0; apply MapsTo_1 with t0; auto. - right; right; split; auto; ME.order. - ME.order. - right; split; auto; ME.order. + destruct (E.compare t0 x); intuition; try fold (~E.eq x t0); auto. + - elim H; exists e0; apply MapsTo_1 with t0; auto. + - fold (~E.lt t0 x); auto. Qed. Lemma elements_Add_Above : forall m m' x e, @@ -1901,7 +1911,7 @@ Module OrdProperties (M:S). find_mapsto_iff, (H0 t0), <- find_mapsto_iff, add_mapsto_iff by (auto with *). unfold O.eqke; simpl. intuition. - destruct (E.eq_dec x t0); auto. + destruct (E.eq_dec x t0) as [Heq|Hneq]; auto. exfalso. assert (In t0 m). exists e0; auto. @@ -1930,7 +1940,7 @@ Module OrdProperties (M:S). find_mapsto_iff, (H0 t0), <- find_mapsto_iff, add_mapsto_iff by (auto with *). unfold O.eqke; simpl. intuition. - destruct (E.eq_dec x t0); auto. + destruct (E.eq_dec x t0) as [Heq|Hneq]; auto. exfalso. assert (In t0 m). exists e0; auto. @@ -1986,7 +1996,7 @@ Module OrdProperties (M:S). 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). + destruct (E.eq_dec p1 x) as [Heq|Hneq]. apply ME.lt_eq with p1; auto. inversion_clear H2. inversion_clear H5. diff --git a/theories/FSets/FMapFullAVL.v b/theories/FSets/FMapFullAVL.v index e1c60351..a7be3232 100644 --- a/theories/FSets/FMapFullAVL.v +++ b/theories/FSets/FMapFullAVL.v @@ -660,7 +660,7 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: Fixpoint cardinal_e (e:Raw.enumeration D.t) := match e with - | Raw.End => 0%nat + | Raw.End _ => 0%nat | Raw.More _ _ r e => S (Raw.cardinal r + cardinal_e e) end. @@ -674,12 +674,14 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: Definition cardinal_e_2 ee := (cardinal_e (fst ee) + cardinal_e (snd ee))%nat. + Local Unset Keyed Unification. + Function 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.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 @@ -726,7 +728,7 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: intros. assert (H1:=cons_1 m1 (Raw.End _)). assert (H2:=cons_1 m2 (Raw.End _)). - simpl in *; rewrite <- app_nil_end in *; rewrite <-H1,<-H2. + 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. diff --git a/theories/FSets/FMapList.v b/theories/FSets/FMapList.v index f15ab222..13cb559b 100644 --- a/theories/FSets/FMapList.v +++ b/theories/FSets/FMapList.v @@ -403,7 +403,7 @@ Proof. apply H1 with k; destruct (X.eq_dec x k); auto. - destruct (X.compare x x'); try contradiction; clear y. + destruct (X.compare x x') as [Hlt|Heq|Hlt]; try contradiction; clear y. destruct (H0 x). assert (In x ((x',e')::l')). apply H; auto. @@ -527,7 +527,7 @@ Fixpoint mapi (f: key -> elt -> elt') (m:t elt) : t elt' := | 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 @@ -543,14 +543,13 @@ Proof. intros m x e f. (* functional induction map elt elt' f m. *) (* Marche pas ??? *) induction m. - inversion 1. + inversion 1. destruct a as (x',e'). simpl. - inversion_clear 1. + inversion_clear 1. constructor 1. unfold eqke in *; simpl in *; intuition congruence. - constructor 2. unfold MapsTo in *; auto. Qed. @@ -799,7 +798,7 @@ Proof. intros. simpl. destruct a as (k,e); destruct a0 as (k',e'). - destruct (X.compare k k'). + 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. @@ -868,8 +867,8 @@ Proof. induction m'. (* m' = nil *) intros; destruct a; simpl. - destruct (X.compare x t0); simpl; auto. - inversion_clear Hm; clear H0 l Hm' IHm t0. + 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. @@ -923,7 +922,7 @@ Proof. 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); simpl in *. + destruct (X.compare x k) as [Hlt|Heq|Hlt]; simpl in *. (* x < k *) destruct (f' (oo,oo')); simpl. elim_comp. @@ -959,7 +958,7 @@ Proof. destruct a as (k,(oo,oo')). simpl. inversion_clear H2. - destruct (X.compare x k). + destruct (X.compare x k) as [Hlt|Heq|Hlt]. (* x < k *) unfold f'; simpl. destruct (f oo oo'); simpl. @@ -1208,7 +1207,7 @@ Proof. destruct a as (x,e). destruct p as (x',e'). unfold equal; simpl. - destruct (X.compare x x'); simpl; intuition. + destruct (X.compare x x') as [Hlt|Heq|Hlt]; simpl; intuition. unfold cmp at 1. MD.elim_comp; clear H; simpl. inversion_clear Hl. @@ -1245,21 +1244,21 @@ 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); auto. - apply (MapS.Raw.MX.lt_antirefl l); auto. + 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 l); auto. + apply (MapS.Raw.MX.lt_antirefl Hlt); auto. Qed. -Lemma eq_sym : forall m1 m2 : t, eq m1 m2 -> eq m2 m1. +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'); MapS.Raw.MX.elim_comp; intuition. + destruct (X.compare x x') as [Hlt|Heq|Hlt]; MapS.Raw.MX.elim_comp; intuition. inversion_clear Hm; inversion_clear Hm'. apply (IHm H0 (Build_slist H4)); auto. Qed. @@ -1272,8 +1271,8 @@ Proof. 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'); - destruct (X.compare x' x''); + 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. @@ -1288,8 +1287,8 @@ Proof. 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'); - destruct (X.compare x' x''); + 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. @@ -1307,7 +1306,7 @@ Proof. 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'); 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. diff --git a/theories/FSets/FMapPositive.v b/theories/FSets/FMapPositive.v index c59f7c22..3eac15b0 100644 --- a/theories/FSets/FMapPositive.v +++ b/theories/FSets/FMapPositive.v @@ -8,13 +8,11 @@ (** * FMapPositive : an implementation of FMapInterface for [positive] keys. *) -Require Import Bool ZArith OrderedType OrderedTypeEx FMapInterface. +Require Import Bool OrderedType ZArith OrderedType OrderedTypeEx FMapInterface. Set Implicit Arguments. Local Open Scope positive_scope. - Local Unset Elimination Schemes. -Local Unset Case Analysis Schemes. (** This file is an adaptation to the [FMap] framework of a work by Xavier Leroy and Sandrine Blazy (used for building certified compilers). @@ -71,7 +69,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Module E:=PositiveOrderedTypeBits. Module ME:=KeyOrderedType E. - Definition key := positive. + Definition key := positive : Type. Inductive tree (A : Type) := | Leaf : tree A @@ -84,7 +82,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Section A. Variable A:Type. - Arguments Leaf [A]. + Arguments Leaf {A}. Definition empty : t A := Leaf. @@ -95,7 +93,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. | _ => false end. - Fixpoint find (i : positive) (m : t A) : option A := + Fixpoint find (i : key) (m : t A) : option A := match m with | Leaf => None | Node l o r => @@ -106,7 +104,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. end end. - Fixpoint mem (i : positive) (m : t A) : bool := + Fixpoint mem (i : key) (m : t A) : bool := match m with | Leaf => false | Node l o r => @@ -117,7 +115,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. end end. - Fixpoint add (i : positive) (v : A) (m : t A) : t A := + Fixpoint add (i : key) (v : A) (m : t A) : t A := match m with | Leaf => match i with @@ -133,7 +131,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. end end. - Fixpoint remove (i : positive) (m : t A) : t A := + Fixpoint remove (i : key) (m : t A) : t A := match i with | xH => match m with @@ -165,7 +163,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. (** [elements] *) - Fixpoint xelements (m : t A) (i : positive) : list (positive * A) := + Fixpoint xelements (m : t A) (i : key) : list (key * A) := match m with | Leaf => nil | Node l None r => @@ -192,33 +190,33 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Section CompcertSpec. Theorem gempty: - forall (i: positive), find i empty = None. + forall (i: key), find i empty = None. Proof. destruct i; simpl; auto. Qed. Theorem gss: - forall (i: positive) (x: A) (m: t A), find i (add i x m) = Some x. + 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 : positive), find i (Leaf : t A) = None. + Lemma gleaf : forall (i : key), find i (Leaf : t A) = None. Proof. exact gempty. Qed. Theorem gso: - forall (i j: positive) (x: A) (m: t A), + 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 : positive), remove i (Leaf : t A) = Leaf. + Lemma rleaf : forall (i : key), remove i Leaf = Leaf. Proof. destruct i; simpl; auto. Qed. Theorem grs: - forall (i: positive) (m: t A), find i (remove i m) = None. + forall (i: key) (m: t A), find i (remove i m) = None. Proof. induction i; destruct m. simpl; auto. @@ -238,7 +236,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Qed. Theorem gro: - forall (i j: positive) (m: t A), + 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; @@ -267,11 +265,11 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Qed. Lemma xelements_correct: - forall (m: t A) (i j : positive) (v: A), + 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; congruence. + 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. @@ -284,14 +282,14 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Qed. Theorem elements_correct: - forall (m: t A) (i: positive) (v: A), + 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 : positive) (m : t A) : option A := + 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 @@ -300,7 +298,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. end. Lemma xfind_left : - forall (j i : positive) (m1 m2 : t A) (o : option A) (v : A), + 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. @@ -308,7 +306,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Qed. Lemma xelements_ii : - forall (m: t A) (i j : positive) (v: A), + 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. @@ -324,7 +322,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Qed. Lemma xelements_io : - forall (m: t A) (i j : positive) (v: A), + forall (m: t A) (i j : key) (v: A), ~List.In (xI i, v) (xelements m (xO j)). Proof. induction m. @@ -339,7 +337,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Qed. Lemma xelements_oo : - forall (m: t A) (i j : positive) (v: A), + 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. @@ -355,7 +353,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Qed. Lemma xelements_oi : - forall (m: t A) (i j : positive) (v: A), + forall (m: t A) (i j : key) (v: A), ~List.In (xO i, v) (xelements m (xI j)). Proof. induction m. @@ -370,7 +368,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Qed. Lemma xelements_ih : - forall (m1 m2: t A) (o: option A) (i : positive) (v: A), + 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). @@ -383,7 +381,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Qed. Lemma xelements_oh : - forall (m1 m2: t A) (o: option A) (i : positive) (v: A), + 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). @@ -396,7 +394,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Qed. Lemma xelements_hi : - forall (m: t A) (i : positive) (v: A), + forall (m: t A) (i : key) (v: A), ~List.In (xH, v) (xelements m (xI i)). Proof. induction m; intros. @@ -411,7 +409,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Qed. Lemma xelements_ho : - forall (m: t A) (i : positive) (v: A), + forall (m: t A) (i : key) (v: A), ~List.In (xH, v) (xelements m (xO i)). Proof. induction m; intros. @@ -426,13 +424,13 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Qed. Lemma find_xfind_h : - forall (m: t A) (i: positive), find i m = xfind i xH m. + 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 : positive) (m: t A) (v: A), + 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. @@ -460,7 +458,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Qed. Theorem elements_complete: - forall (m: t A) (i: positive) (v: A), + 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. @@ -481,22 +479,22 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. End CompcertSpec. - Definition MapsTo (i:positive)(v:A)(m:t A) := find i m = Some v. + Definition MapsTo (i:key)(v:A)(m:t A) := find i m = Some v. - Definition In (i:positive)(m:t A) := exists e:A, MapsTo i e m. + Definition In (i:key)(m:t A) := exists e:A, MapsTo i e m. - Definition Empty m := forall (a : positive)(e:A) , ~ MapsTo a e m. + Definition Empty m := forall (a : key)(e:A) , ~ MapsTo a e m. - Definition eq_key (p p':positive*A) := E.eq (fst p) (fst p'). + Definition eq_key (p p':key*A) := E.eq (fst p) (fst p'). - Definition eq_key_elt (p p':positive*A) := + Definition eq_key_elt (p p':key*A) := E.eq (fst p) (fst p') /\ (snd p) = (snd p'). - Definition lt_key (p p':positive*A) := E.lt (fst p) (fst p'). + Definition lt_key (p p':key*A) := E.lt (fst p) (fst p'). - Global Program Instance eqk_equiv : Equivalence eq_key. - Global Program Instance eqke_equiv : Equivalence eq_key_elt. - Global Program Instance ltk_strorder : StrictOrder lt_key. + 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. @@ -717,8 +715,8 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Lemma elements_3w : NoDupA eq_key (elements m). Proof. - change eq_key with (@ME.eqk A). - apply ME.Sort_NoDupA; apply elements_3; auto. + apply ME.Sort_NoDupA. + apply elements_3. Qed. End FMapSpec. @@ -729,9 +727,9 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Section Mapi. - Variable f : positive -> A -> B. + Variable f : key -> A -> B. - Fixpoint xmapi (m : t A) (i : positive) : t 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))) @@ -748,7 +746,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. End A. Lemma xgmapi: - forall (A B: Type) (f: positive -> A -> B) (i j : positive) (m: t A), + 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. @@ -758,7 +756,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Qed. Theorem gmapi: - forall (A B: Type) (f: positive -> A -> B) (i: positive) (m: t A), + 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. @@ -814,7 +812,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Variable A B C : Type. Variable f : option A -> option B -> option C. - Arguments Leaf [A]. + Arguments Leaf {A}. Fixpoint xmap2_l (m : t A) : t C := match m with @@ -822,7 +820,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. | Node l o r => Node (xmap2_l l) (f o None) (xmap2_l r) end. - Lemma xgmap2_l : forall (i : positive) (m : t A), + 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. @@ -834,7 +832,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. | Node l o r => Node (xmap2_r l) (f None o) (xmap2_r r) end. - Lemma xgmap2_r : forall (i : positive) (m : t B), + 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. @@ -850,7 +848,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. end end. - Lemma gmap2: forall (i: positive)(m1:t A)(m2: t B), + 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. @@ -898,11 +896,11 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Section Fold. Variables A B : Type. - Variable f : positive -> A -> B -> B. + Variable f : key -> A -> B -> B. - Fixpoint xfoldi (m : t A) (v : B) (i : positive) := + Fixpoint xfoldi (m : t A) (v : B) (i : key) := match m with - | Leaf => v + | 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 => @@ -940,8 +938,8 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. 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 + | Leaf _, _ => is_empty m2 + | _, Leaf _ => is_empty m1 | Node l1 o1 r1, Node l2 o2 r2 => (match o1, o2 with | None, None => true @@ -1072,16 +1070,16 @@ Module PositiveMapAdditionalFacts. (* Derivable from the Map interface *) Theorem gsspec: - forall (A:Type)(i j: positive) (x: A) (m: t A), + 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); [ rewrite e; apply gss | apply gso; auto ]. + 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: positive) (m: t A) (v: A), + 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. @@ -1120,4 +1118,3 @@ Module PositiveMapAdditionalFacts. Qed. End PositiveMapAdditionalFacts. - diff --git a/theories/FSets/FMapWeakList.v b/theories/FSets/FMapWeakList.v index 6c1e8ca8..0f11dd7a 100644 --- a/theories/FSets/FMapWeakList.v +++ b/theories/FSets/FMapWeakList.v @@ -146,9 +146,10 @@ Proof. induction m; simpl; auto; destruct a; intros. inversion_clear Hm. rewrite (IHm H1 x x'); auto. - destruct (X.eq_dec x t0); destruct (X.eq_dec x' t0); trivial. - elim n; apply X.eq_trans with x; auto. - elim n; apply X.eq_trans with 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] *) @@ -600,18 +601,18 @@ Definition combine_l (m:t elt)(m':t elt') : t oee' := 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)(l:list (A*B))(i:C) := - List.fold_right (fun p => f (fst p) (snd p)) i l. +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')) l r. + 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')) l r). + NoDupA (eqk (elt:=oee')) (fold_right_pair (add (elt:=oee')) r l). Proof. induction l; simpl; auto. destruct a; simpl; auto. @@ -733,7 +734,7 @@ Definition option_cons (A:Type)(k:key)(o:option A)(l:list (key*A)) := 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'')) m1 nil. + 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'), @@ -787,14 +788,14 @@ Proof. 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); simpl in *. + 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); try contradict n; auto. + 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. @@ -804,7 +805,7 @@ Proof. (* k < x *) unfold f'; simpl. destruct (f oo oo'); simpl. - destruct (X.eq_dec x k); [ contradict n; auto | auto]. + 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. @@ -812,13 +813,13 @@ Proof. destruct a as (k,(oo,oo')). simpl. inversion_clear H2. - destruct (X.eq_dec x k). + 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 n; auto | auto]. + 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. diff --git a/theories/FSets/FSetBridge.v b/theories/FSets/FSetBridge.v index 1ac544e1..97f140b3 100644 --- a/theories/FSets/FSetBridge.v +++ b/theories/FSets/FSetBridge.v @@ -284,7 +284,7 @@ Module DepOfNodep (Import M: S) <: Sdep with Module E := M.E. 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' + | inleft (exist _ x _), inleft (exist _ x' _) => E.eq x x' | inright _, inright _ => True | _, _ => False end. @@ -423,7 +423,7 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E. Definition choose (s : t) : option elt := match choose s with - | inleft (exist x _) => Some x + | inleft (exist _ x _) => Some x | inright _ => None end. @@ -472,7 +472,7 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E. Definition min_elt (s : t) : option elt := match min_elt s with - | inleft (exist x _) => Some x + | inleft (exist _ x _) => Some x | inright _ => None end. @@ -500,7 +500,7 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E. Definition max_elt (s : t) : option elt := match max_elt s with - | inleft (exist x _) => Some x + | inleft (exist _ x _) => Some x | inright _ => None end. @@ -673,24 +673,24 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E. 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; intuition. - generalize (i (compat_P_aux H)); firstorder. + 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; intuition. - generalize (i (compat_P_aux H)); firstorder. + 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; intuition. - generalize (i (compat_P_aux H)); firstorder. + 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 := diff --git a/theories/FSets/FSetCompat.v b/theories/FSets/FSetCompat.v index 6b3d86d3..b1769da3 100644 --- a/theories/FSets/FSetCompat.v +++ b/theories/FSets/FSetCompat.v @@ -283,6 +283,8 @@ Module Update_WSets 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. diff --git a/theories/FSets/FSetDecide.v b/theories/FSets/FSetDecide.v index f64df9fe..ad067eb3 100644 --- a/theories/FSets/FSetDecide.v +++ b/theories/FSets/FSetDecide.v @@ -15,7 +15,7 @@ (** This file implements a decision procedure for a certain class of propositions involving finite sets. *) -Require Import Decidable DecidableTypeEx FSetFacts. +Require Import Decidable Setoid DecidableTypeEx FSetFacts. (** First, a version for Weak Sets in functorial presentation *) @@ -115,8 +115,8 @@ the above form: not affect the namespace if you import the enclosing module [Decide]. *) Module FSetLogicalFacts. - Require Export Decidable. - Require Export Setoid. + Export Decidable. + Export Setoid. (** ** Lemmas and Tactics About Decidable Propositions *) diff --git a/theories/FSets/FSetEqProperties.v b/theories/FSets/FSetEqProperties.v index ac495c04..f2f4cc2c 100644 --- a/theories/FSets/FSetEqProperties.v +++ b/theories/FSets/FSetEqProperties.v @@ -822,7 +822,7 @@ Proof. intros. rewrite for_all_exists in H; auto. rewrite negb_true_iff in H. -elim (for_all_mem_4 (fun x =>negb (f x)) Comp' s);intros;auto. +destruct (for_all_mem_4 (fun x =>negb (f x)) Comp' s) as (x,p); auto. elim p;intros. exists x;split;auto. rewrite <-negb_false_iff; auto. diff --git a/theories/FSets/FSetInterface.v b/theories/FSets/FSetInterface.v index a0361119..c791f49a 100644 --- a/theories/FSets/FSetInterface.v +++ b/theories/FSets/FSetInterface.v @@ -497,7 +497,7 @@ Module Type Sdep. 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' + | inleft (exist _ x _), inleft (exist _ x' _) => E.eq x x' | inright _, inright _ => True | _, _ => False end. diff --git a/theories/FSets/FSetPositive.v b/theories/FSets/FSetPositive.v index e5d55ac5..7398c6d6 100644 --- a/theories/FSets/FSetPositive.v +++ b/theories/FSets/FSetPositive.v @@ -19,20 +19,15 @@ Require Import Bool BinPos OrderedType OrderedTypeEx FSetInterface. Set Implicit Arguments. - Local Open Scope lazy_bool_scope. Local Open Scope positive_scope. - Local Unset Elimination Schemes. -Local Unset Case Analysis Schemes. -Local Unset Boolean Equality Schemes. - Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. Module E:=PositiveOrderedTypeBits. - Definition elt := positive. + Definition elt := positive : Type. Inductive tree := | Leaf : tree @@ -40,9 +35,9 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. Scheme tree_ind := Induction for tree Sort Prop. - Definition t := tree. + Definition t := tree : Type. - Definition empty := Leaf. + Definition empty : t := Leaf. Fixpoint is_empty (m : t) : bool := match m with @@ -50,7 +45,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. | Node l b r => negb b &&& is_empty l &&& is_empty r end. - Fixpoint mem (i : positive) (m : t) : bool := + Fixpoint mem (i : elt) (m : t) {struct m} : bool := match m with | Leaf => false | Node l o r => @@ -61,7 +56,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. end end. - Fixpoint add (i : positive) (m : t) : t := + Fixpoint add (i : elt) (m : t) : t := match m with | Leaf => match i with @@ -81,13 +76,13 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. (** helper function to avoid creating empty trees that are not leaves *) - Definition node l (b: bool) r := + 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) : t := + Fixpoint remove (i : elt) (m : t) {struct m} : t := match m with | Leaf => Leaf | Node l o r => @@ -98,7 +93,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. end end. - Fixpoint union (m m': t) := + Fixpoint union (m m': t) : t := match m with | Leaf => m' | Node l o r => @@ -108,7 +103,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. end end. - Fixpoint inter (m m': t) := + Fixpoint inter (m m': t) : t := match m with | Leaf => Leaf | Node l o r => @@ -118,7 +113,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. end end. - Fixpoint diff (m m': t) := + Fixpoint diff (m m': t) : t := match m with | Leaf => Leaf | Node l o r => @@ -150,7 +145,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. (** reverses [y] and concatenate it with [x] *) - Fixpoint rev_append y x := + Fixpoint rev_append (y x : elt) : elt := match y with | 1 => x | y~1 => rev_append y x~1 @@ -161,8 +156,8 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. Section Fold. - Variables B : Type. - Variable f : positive -> B -> B. + 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 @@ -170,7 +165,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. we also use this convention in all functions below *) - Fixpoint xfold (m : t) (v : B) (i : positive) := + Fixpoint xfold (m : t) (v : B) (i : elt) := match m with | Leaf => v | Node l true r => @@ -184,9 +179,9 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. Section Quantifiers. - Variable f : positive -> bool. + Variable f : elt -> bool. - Fixpoint xforall (m : t) (i : positive) := + Fixpoint xforall (m : t) (i : elt) := match m with | Leaf => true | Node l o r => @@ -194,21 +189,21 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. end. Definition for_all m := xforall m 1. - Fixpoint xexists (m : t) (i : positive) := + 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 : positive) := + 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 : positive) := + Fixpoint xpartition (m : t) (i : elt) : t * t := match m with | Leaf => (Leaf,Leaf) | Node l o r => @@ -226,7 +221,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. (** uses [a] to accumulate values rather than doing a lot of concatenations *) - Fixpoint xelements (m : t) (i : positive) (a: list positive) := + 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) @@ -250,7 +245,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. (** would it be more efficient to use a path like in the above functions ? *) - Fixpoint choose (m: t) := + Fixpoint choose (m: t) : option elt := match m with | Leaf => None | Node l o r => if o then Some 1 else @@ -260,7 +255,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. end end. - Fixpoint min_elt (m: t) := + Fixpoint min_elt (m: t) : option elt := match m with | Leaf => None | Node l o r => @@ -270,7 +265,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. end end. - Fixpoint max_elt (m: t) := + Fixpoint max_elt (m: t) : option elt := match m with | Leaf => None | Node l o r => @@ -311,6 +306,9 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. 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] *) @@ -355,10 +353,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. case o; trivial. destruct l; trivial. destruct r; trivial. - symmetry. destruct x. - apply mem_Leaf. - apply mem_Leaf. - reflexivity. + now destruct x. Qed. Local Opaque node. @@ -367,8 +362,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. 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. - setoid_rewrite mem_Leaf. firstorder. + 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. @@ -759,7 +753,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. 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. @@ -807,15 +801,15 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. rewrite <- andb_lazy_alt. apply andb_true_iff. Qed. - Lemma filter_1 : forall s x f, compat_bool E.eq f -> + 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 E.eq f -> + 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 E.eq f -> In x s -> + 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. @@ -826,8 +820,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. 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. - setoid_rewrite mem_Leaf. intuition discriminate. + 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. @@ -841,11 +834,11 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. apply H. assumption. Qed. - Lemma for_all_1 : forall s f, compat_bool E.eq f -> + 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 E.eq f -> + 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. @@ -857,7 +850,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. Proof. unfold Exists, In. intro f. induction s as [|l IHl o r IHr]; intros i; simpl. - setoid_rewrite mem_Leaf. firstorder. + split; [ discriminate | now intros [ _ [? _]]]. rewrite <- 2orb_lazy_alt, 2orb_true_iff, <- andb_lazy_alt, andb_true_iff. rewrite IHl, IHr. clear IHl IHr. split. @@ -868,11 +861,11 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. intros [[x|x|] H]; eauto. Qed. - Lemma exists_1 : forall s f, compat_bool E.eq f -> + 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 E.eq f -> + 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. @@ -888,11 +881,11 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. destruct o; simpl; rewrite IHl, IHr; reflexivity. Qed. - Lemma partition_1 : forall s f, compat_bool E.eq f -> + 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 E.eq f -> + 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. @@ -909,7 +902,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. induction s as [|l IHl o r IHr]; simpl. intros. split; intro H. left. assumption. - destruct H as [H|[x [Hx Hx']]]. assumption. elim (empty_1 Hx'). + 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. @@ -1000,7 +993,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. constructor. intros x H. apply E.lt_not_eq in H. apply H. reflexivity. intro. apply E.lt_trans. - intros ? ? <- ? ? <-. reflexivity. + solve_proper. apply elements_3. Qed. @@ -1111,7 +1104,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. destruct (min_elt r). injection H. intros <-. clear H. destruct y as [z|z|]. - apply (IHr p z); trivial. + apply (IHr e z); trivial. elim (Hp _ H'). discriminate. discriminate. @@ -1165,7 +1158,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. injection H. intros <-. clear H. destruct y as [z|z|]. elim (Hp _ H'). - apply (IHl p z); trivial. + apply (IHl e z); trivial. discriminate. discriminate. Qed. diff --git a/theories/FSets/FSetProperties.v b/theories/FSets/FSetProperties.v index d53ce0c8..25b042ca 100644 --- a/theories/FSets/FSetProperties.v +++ b/theories/FSets/FSetProperties.v @@ -995,8 +995,7 @@ Module OrdProperties (M:S). leb_1, gtb_1, (H0 a) by auto with *. intuition. destruct (E.compare a x); intuition. - right; right; split; auto with *. - ME.order. + fold (~E.lt a x); auto with *. Qed. Definition Above x s := forall y, In y s -> E.lt y x. diff --git a/theories/Init/Datatypes.v b/theories/Init/Datatypes.v index e7e6ed9e..de615301 100644 --- a/theories/Init/Datatypes.v +++ b/theories/Init/Datatypes.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* -> Prop. + ([Local]) [Coercion is_true : bool >-> Sortclass]. *) (** Additional rewriting lemmas about [eq_true] *) @@ -143,18 +143,20 @@ Arguments S _%nat. (********************************************************************) (** * Container datatypes *) +(* Set Universe Polymorphism. *) + (** [option A] is the extension of [A] with an extra element [None] *) Inductive option (A:Type) : Type := | Some : A -> option A | None : option A. -Arguments None [A]. +Arguments None {A}. -Definition option_map (A B:Type) (f:A->B) o := +Definition option_map (A B:Type) (f:A->B) (o : option A) : option B := match o with - | Some a => Some (f a) - | None => None + | Some a => @Some B (f a) + | None => @None B end. (** [sum A B], written [A + B], is the disjoint sum of [A] and [B] *) @@ -182,7 +184,8 @@ Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z) : core_scope. Arguments pair {A B} _ _. Section projections. - Variables A B : Type. + Context {A : Type} {B : Type}. + Definition fst (p:A * B) := match p with | (x, y) => x end. @@ -221,7 +224,7 @@ Inductive list (A : Type) : Type := | nil : list A | cons : A -> list A -> list A. -Arguments nil [A]. +Arguments nil {A}. Infix "::" := cons (at level 60, right associativity) : list_scope. Delimit Scope list_scope with list. Bind Scope list_scope with list. @@ -244,8 +247,10 @@ Definition app (A : Type) : list A -> list A -> list A := | a :: l1 => a :: app l1 m end. + Infix "++" := app (right associativity, at level 60) : list_scope. +(* Unset Universe Polymorphism. *) (********************************************************************) (** * The comparison datatype *) @@ -310,6 +315,7 @@ Defined. Definition CompSpec {A} (eq lt : A->A->Prop)(x y:A) : comparison -> Prop := CompareSpec (eq x y) (lt x y) (lt y x). + Definition CompSpecT {A} (eq lt : A->A->Prop)(x y:A) : comparison -> Type := CompareSpecT (eq x y) (lt x y) (lt y x). Hint Unfold CompSpec CompSpecT. @@ -339,6 +345,9 @@ Arguments identity_rect [A] a P f y i. Definition ID := forall A:Type, A -> A. Definition id : ID := fun A x => x. +Definition IDProp := forall A:Prop, A -> A. +Definition idProp : IDProp := fun A x => x. + (* begin hide *) diff --git a/theories/Init/Logic.v b/theories/Init/Logic.v index e5f7a78b..d2971552 100644 --- a/theories/Init/Logic.v +++ b/theories/Init/Logic.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* B" := (forall (_ : A), B) : type_scope. (** * Propositional connectives *) (** [True] is the always true proposition *) + Inductive True : Prop := I : True. (** [False] is the always false proposition *) Inductive False : Prop :=. +(** [proof_admitted] is used to implement the admit tactic *) +Axiom proof_admitted : False. + (** [not A], written [~A], is the negation of [A] *) Definition not (A:Prop) := A -> False. @@ -92,6 +98,36 @@ End Equivalence. Hint Unfold iff: extcore. +(** Backward direction of the equivalences above does not need assumptions *) + +Theorem and_iff_compat_l : forall A B C : Prop, + (B <-> C) -> (A /\ B <-> A /\ C). +Proof. + intros ? ? ? [Hl Hr]; split; intros [? ?]; (split; [ assumption | ]); + [apply Hl | apply Hr]; assumption. +Qed. + +Theorem and_iff_compat_r : forall A B C : Prop, + (B <-> C) -> (B /\ A <-> C /\ A). +Proof. + intros ? ? ? [Hl Hr]; split; intros [? ?]; (split; [ | assumption ]); + [apply Hl | apply Hr]; assumption. +Qed. + +Theorem or_iff_compat_l : forall A B C : Prop, + (B <-> C) -> (A \/ B <-> A \/ C). +Proof. + intros ? ? ? [Hl Hr]; split; (intros [?|?]; [left; assumption| right]); + [apply Hl | apply Hr]; assumption. +Qed. + +Theorem or_iff_compat_r : forall A B C : Prop, + (B <-> C) -> (B \/ A <-> C \/ A). +Proof. + intros ? ? ? [Hl Hr]; split; (intros [?|?]; [left| right; assumption]); + [apply Hl | apply Hr]; assumption. +Qed. + (** Some equivalences *) Theorem neg_false : forall A : Prop, ~ A <-> (A <-> False). @@ -104,73 +140,62 @@ Qed. Theorem and_cancel_l : forall A B C : Prop, (B -> A) -> (C -> A) -> ((A /\ B <-> A /\ C) <-> (B <-> C)). Proof. - intros; tauto. + intros A B C Hl Hr. + split; [ | apply and_iff_compat_l]; intros [HypL HypR]; split; intros. + + apply HypL; split; [apply Hl | ]; assumption. + + apply HypR; split; [apply Hr | ]; assumption. Qed. Theorem and_cancel_r : forall A B C : Prop, (B -> A) -> (C -> A) -> ((B /\ A <-> C /\ A) <-> (B <-> C)). Proof. - intros; tauto. + intros A B C Hl Hr. + split; [ | apply and_iff_compat_r]; intros [HypL HypR]; split; intros. + + apply HypL; split; [ | apply Hl ]; assumption. + + apply HypR; split; [ | apply Hr ]; assumption. Qed. Theorem and_comm : forall A B : Prop, A /\ B <-> B /\ A. Proof. - intros; tauto. + intros; split; intros [? ?]; split; assumption. Qed. Theorem and_assoc : forall A B C : Prop, (A /\ B) /\ C <-> A /\ B /\ C. Proof. - intros; tauto. + intros; split; [ intros [[? ?] ?]| intros [? [? ?]]]; repeat split; assumption. Qed. Theorem or_cancel_l : forall A B C : Prop, (B -> ~ A) -> (C -> ~ A) -> ((A \/ B <-> A \/ C) <-> (B <-> C)). Proof. - intros; tauto. + intros ? ? ? Fl Fr; split; [ | apply or_iff_compat_l]; intros [Hl Hr]; split; intros. + { destruct Hl; [ right | destruct Fl | ]; assumption. } + { destruct Hr; [ right | destruct Fr | ]; assumption. } Qed. Theorem or_cancel_r : forall A B C : Prop, (B -> ~ A) -> (C -> ~ A) -> ((B \/ A <-> C \/ A) <-> (B <-> C)). Proof. - intros; tauto. + intros ? ? ? Fl Fr; split; [ | apply or_iff_compat_r]; intros [Hl Hr]; split; intros. + { destruct Hl; [ left | | destruct Fl ]; assumption. } + { destruct Hr; [ left | | destruct Fr ]; assumption. } Qed. Theorem or_comm : forall A B : Prop, (A \/ B) <-> (B \/ A). Proof. - intros; tauto. + intros; split; (intros [? | ?]; [ right | left ]; assumption). Qed. Theorem or_assoc : forall A B C : Prop, (A \/ B) \/ C <-> A \/ B \/ C. Proof. - intros; tauto. -Qed. - -(** Backward direction of the equivalences above does not need assumptions *) - -Theorem and_iff_compat_l : forall A B C : Prop, - (B <-> C) -> (A /\ B <-> A /\ C). -Proof. - intros; tauto. -Qed. - -Theorem and_iff_compat_r : forall A B C : Prop, - (B <-> C) -> (B /\ A <-> C /\ A). -Proof. - intros; tauto. -Qed. - -Theorem or_iff_compat_l : forall A B C : Prop, - (B <-> C) -> (A \/ B <-> A \/ C). -Proof. - intros; tauto. -Qed. - -Theorem or_iff_compat_r : forall A B C : Prop, - (B <-> C) -> (B \/ A <-> C \/ A). -Proof. - intros; tauto. + intros; split; [ intros [[?|?]|?]| intros [?|[?|?]]]. + + left; assumption. + + right; left; assumption. + + right; right; assumption. + + left; left; assumption. + + left; right; assumption. + + right; assumption. Qed. - Lemma iff_and : forall A B : Prop, (A <-> B) -> (A -> B) /\ (B -> A). Proof. intros A B []; split; trivial. @@ -178,7 +203,7 @@ Qed. Lemma iff_to_and : forall A B : Prop, (A <-> B) <-> (A -> B) /\ (B -> A). Proof. - intros; tauto. + intros; split; intros [Hl Hr]; (split; intros; [ apply Hl | apply Hr]); assumption. Qed. (** [(IF_then_else P Q R)], written [IF P then Q else R] denotes @@ -204,11 +229,6 @@ Notation "'IF' c1 'then' c2 'else' c3" := (IF_then_else c1 c2 c3) is provided too. *) -(** Remark: [exists x, Q] denotes [ex (fun x => Q)] so that [exists x, - P x] is in fact equivalent to [ex (fun x => P x)] which may be not - convertible to [ex P] if [P] is not itself an abstraction *) - - Inductive ex (A:Type) (P:A -> Prop) : Prop := ex_intro : forall x:A, P x -> ex (A:=A) P. @@ -277,7 +297,8 @@ Arguments eq_ind [A] x P _ y _. Arguments eq_rec [A] x P _ y _. Arguments eq_rect [A] x P _ y _. -Hint Resolve I conj or_introl or_intror eq_refl: core. +Hint Resolve I conj or_introl or_intror : core. +Hint Resolve eq_refl: core. Hint Resolve ex_intro ex_intro2: core. Section Logic_lemmas. @@ -297,19 +318,16 @@ Section Logic_lemmas. Proof. destruct 1; trivial. Defined. - Opaque eq_sym. Theorem eq_trans : x = y -> y = z -> x = z. Proof. destruct 2; trivial. Defined. - Opaque eq_trans. Theorem f_equal : x = y -> f x = f y. Proof. destruct 1; trivial. Defined. - Opaque f_equal. Theorem not_eq_sym : x <> y -> y <> x. Proof. @@ -320,7 +338,7 @@ Section Logic_lemmas. Definition eq_ind_r : forall (A:Type) (x:A) (P:A -> Prop), P x -> forall y:A, y = x -> P y. - intros A x P H y H0; elim eq_sym with (1 := H0); assumption. + intros A x P H y H0. elim eq_sym with (1 := H0); assumption. Defined. Definition eq_rec_r : @@ -336,13 +354,40 @@ End Logic_lemmas. Module EqNotations. Notation "'rew' H 'in' H'" := (eq_rect _ _ H' _ H) - (at level 10, H' at level 10). + (at level 10, H' at level 10, + format "'[' 'rew' H in '/' H' ']'"). + Notation "'rew' [ P ] H 'in' H'" := (eq_rect _ P H' _ H) + (at level 10, H' at level 10, + format "'[' 'rew' [ P ] '/ ' H in '/' H' ']'"). Notation "'rew' <- H 'in' H'" := (eq_rect_r _ H' H) - (at level 10, H' at level 10). + (at level 10, H' at level 10, + format "'[' 'rew' <- H in '/' H' ']'"). + Notation "'rew' <- [ P ] H 'in' H'" := (eq_rect_r P H' H) + (at level 10, H' at level 10, + format "'[' 'rew' <- [ P ] '/ ' H in '/' H' ']'"). Notation "'rew' -> H 'in' H'" := (eq_rect _ _ H' _ H) (at level 10, H' at level 10, only parsing). + Notation "'rew' -> [ P ] H 'in' H'" := (eq_rect _ P H' _ H) + (at level 10, H' at level 10, only parsing). + End EqNotations. +Import EqNotations. + +Lemma rew_opp_r : forall A (P:A->Type) (x y:A) (H:x=y) (a:P y), rew H in rew <- H in a = a. +Proof. +intros. +destruct H. +reflexivity. +Defined. + +Lemma rew_opp_l : forall A (P:A->Type) (x y:A) (H:x=y) (a:P x), rew <- H in rew H in a = a. +Proof. +intros. +destruct H. +reflexivity. +Defined. + Theorem f_equal2 : forall (A1 A2 B:Type) (f:A1 -> A2 -> B) (x1 y1:A1) (x2 y2:A2), x1 = y1 -> x2 = y2 -> f x1 x2 = f y1 y2. @@ -376,6 +421,91 @@ Proof. destruct 1; destruct 1; destruct 1; destruct 1; destruct 1; reflexivity. Qed. +Theorem f_equal_compose : forall A B C (a b:A) (f:A->B) (g:B->C) (e:a=b), + f_equal g (f_equal f e) = f_equal (fun a => g (f a)) e. +Proof. + destruct e. reflexivity. +Defined. + +(** The goupoid structure of equality *) + +Theorem eq_trans_refl_l : forall A (x y:A) (e:x=y), eq_trans eq_refl e = e. +Proof. + destruct e. reflexivity. +Defined. + +Theorem eq_trans_refl_r : forall A (x y:A) (e:x=y), eq_trans e eq_refl = e. +Proof. + destruct e. reflexivity. +Defined. + +Theorem eq_sym_involutive : forall A (x y:A) (e:x=y), eq_sym (eq_sym e) = e. +Proof. + destruct e; reflexivity. +Defined. + +Theorem eq_trans_sym_inv_l : forall A (x y:A) (e:x=y), eq_trans (eq_sym e) e = eq_refl. +Proof. + destruct e; reflexivity. +Defined. + +Theorem eq_trans_sym_inv_r : forall A (x y:A) (e:x=y), eq_trans e (eq_sym e) = eq_refl. +Proof. + destruct e; reflexivity. +Defined. + +Theorem eq_trans_assoc : forall A (x y z t:A) (e:x=y) (e':y=z) (e'':z=t), + eq_trans e (eq_trans e' e'') = eq_trans (eq_trans e e') e''. +Proof. + destruct e''; reflexivity. +Defined. + +(** Extra properties of equality *) + +Theorem eq_id_comm_l : forall A (f:A->A) (Hf:forall a, a = f a), forall a, f_equal f (Hf a) = Hf (f a). +Proof. + intros. + unfold f_equal. + rewrite <- (eq_trans_sym_inv_l (Hf a)). + destruct (Hf a) at 1 2. + destruct (Hf a). + reflexivity. +Defined. + +Theorem eq_id_comm_r : forall A (f:A->A) (Hf:forall a, f a = a), forall a, f_equal f (Hf a) = Hf (f a). +Proof. + intros. + unfold f_equal. + rewrite <- (eq_trans_sym_inv_l (Hf (f (f a)))). + set (Hfsymf := fun a => eq_sym (Hf a)). + change (eq_sym (Hf (f (f a)))) with (Hfsymf (f (f a))). + pattern (Hfsymf (f (f a))). + destruct (eq_id_comm_l f Hfsymf (f a)). + destruct (eq_id_comm_l f Hfsymf a). + unfold Hfsymf. + destruct (Hf a). simpl. + rewrite eq_trans_refl_l. + reflexivity. +Defined. + +Lemma eq_trans_map_distr : forall A B x y z (f:A->B) (e:x=y) (e':y=z), f_equal f (eq_trans e e') = eq_trans (f_equal f e) (f_equal f e'). +Proof. +destruct e'. +reflexivity. +Defined. + +Lemma eq_sym_map_distr : forall A B (x y:A) (f:A->B) (e:x=y), eq_sym (f_equal f e) = f_equal f (eq_sym e). +Proof. +destruct e. +reflexivity. +Defined. + +Lemma eq_trans_sym_distr : forall A (x y z:A) (e:x=y) (e':y=z), eq_sym (eq_trans e e') = eq_trans (eq_sym e') (eq_sym e). +Proof. +destruct e, e'. +reflexivity. +Defined. + (* Aliases *) Notation sym_eq := eq_sym (compat "8.3"). @@ -474,7 +604,7 @@ Declare Right Step eq_trans. Lemma iff_stepl : forall A B C : Prop, (A <-> B) -> (A <-> C) -> (C <-> B). Proof. - intros; tauto. + intros ? ? ? [? ?] [? ?]; split; intros; auto. Qed. Declare Left Step iff_stepl. diff --git a/theories/Init/Logic_Type.v b/theories/Init/Logic_Type.v index b2f83e03..1e126463 100644 --- a/theories/Init/Logic_Type.v +++ b/theories/Init/Logic_Type.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* n + | S u => u + end. + +Fixpoint add n m := + match n with + | 0 => m + | S p => S (p + m) + end + +where "n + m" := (add n m) : nat_scope. + +Definition double n := n + n. + +Fixpoint mul n m := + match n with + | 0 => 0 + | S p => m + p * m + end + +where "n * m" := (mul n m) : nat_scope. + +(** Truncated subtraction: [n-m] is [0] if [n<=m] *) + +Fixpoint sub n m := + match n, m with + | S k, S l => k - l + | _, _ => n + end + +where "n - m" := (sub n m) : nat_scope. + +(** ** Comparisons *) + +Fixpoint eqb n m : bool := + match n, m with + | 0, 0 => true + | 0, S _ => false + | S _, 0 => false + | S n', S m' => eqb n' m' + end. + +Fixpoint leb n m : bool := + match n, m with + | 0, _ => true + | _, 0 => false + | S n', S m' => leb n' m' + end. + +Definition ltb n m := leb (S n) m. + +Infix "=?" := eqb (at level 70) : nat_scope. +Infix "<=?" := leb (at level 70) : nat_scope. +Infix " Eq + | 0, S _ => Lt + | S _, 0 => Gt + | S n', S m' => compare n' m' + end. + +Infix "?=" := compare (at level 70) : nat_scope. + +(** ** Minimum, maximum *) + +Fixpoint max n m := + match n, m with + | 0, _ => m + | S n', 0 => n + | S n', S m' => S (max n' m') + end. + +Fixpoint min n m := + match n, m with + | 0, _ => 0 + | S n', 0 => 0 + | S n', S m' => S (min n' m') + end. + +(** ** Parity tests *) + +Fixpoint even n : bool := + match n with + | 0 => true + | 1 => false + | S (S n') => even n' + end. + +Definition odd n := negb (even n). + +(** ** Power *) + +Fixpoint pow n m := + match m with + | 0 => 1 + | S m => n * (n^m) + end + +where "n ^ m" := (pow n m) : nat_scope. + +(** ** Euclidean division *) + +(** This division is linear and tail-recursive. + In [divmod], [y] is the predecessor of the actual divisor, + and [u] is [y] minus the real remainder +*) + +Fixpoint divmod x y q u := + match x with + | 0 => (q,u) + | S x' => match u with + | 0 => divmod x' y (S q) y + | S u' => divmod x' y q u' + end + end. + +Definition div x y := + match y with + | 0 => y + | S y' => fst (divmod x y' 0 y') + end. + +Definition modulo x y := + match y with + | 0 => y + | S y' => y' - snd (divmod x y' 0 y') + end. + +Infix "/" := div : nat_scope. +Infix "mod" := modulo (at level 40, no associativity) : nat_scope. + + +(** ** Greatest common divisor *) + +(** We use Euclid algorithm, which is normally not structural, + but Coq is now clever enough to accept this (behind modulo + there is a subtraction, which now preserves being a subterm) +*) + +Fixpoint gcd a b := + match a with + | O => b + | S a' => gcd (b mod (S a')) (S a') + end. + +(** ** Square *) + +Definition square n := n * n. + +(** ** Square root *) + +(** The following square root function is linear (and tail-recursive). + With Peano representation, we can't do better. For faster algorithm, + see Psqrt/Zsqrt/Nsqrt... + + We search the square root of n = k + p^2 + (q - r) + with q = 2p and 0<=r<=q. We start with p=q=r=0, hence + looking for the square root of n = k. Then we progressively + decrease k and r. When k = S k' and r=0, it means we can use (S p) + as new sqrt candidate, since (S k')+p^2+2p = k'+(S p)^2. + When k reaches 0, we have found the biggest p^2 square contained + in n, hence the square root of n is p. +*) + +Fixpoint sqrt_iter k p q r := + match k with + | O => p + | S k' => match r with + | O => sqrt_iter k' (S p) (S (S q)) (S (S q)) + | S r' => sqrt_iter k' p q r' + end + end. + +Definition sqrt n := sqrt_iter n 0 0 0. + +(** ** Log2 *) + +(** This base-2 logarithm is linear and tail-recursive. + + In [log2_iter], we maintain the logarithm [p] of the counter [q], + while [r] is the distance between [q] and the next power of 2, + more precisely [q + S r = 2^(S p)] and [r<2^p]. At each + recursive call, [q] goes up while [r] goes down. When [r] + is 0, we know that [q] has almost reached a power of 2, + and we increase [p] at the next call, while resetting [r] + to [q]. + + Graphically (numbers are [q], stars are [r]) : + +<< + 10 + 9 + 8 + 7 * + 6 * + 5 ... + 4 + 3 * + 2 * + 1 * * +0 * * * +>> + + We stop when [k], the global downward counter reaches 0. + At that moment, [q] is the number we're considering (since + [k+q] is invariant), and [p] its logarithm. +*) + +Fixpoint log2_iter k p q r := + match k with + | O => p + | S k' => match r with + | O => log2_iter k' (S p) (S q) q + | S r' => log2_iter k' p (S q) r' + end + end. + +Definition log2 n := log2_iter (pred n) 0 1 0. + +(** Iterator on natural numbers *) + +Definition iter (n:nat) {A} (f:A->A) (x:A) : A := + nat_rect (fun _ => A) x (fun _ => f) n. + +(** Bitwise operations *) + +(** We provide here some bitwise operations for unary numbers. + Some might be really naive, they are just there for fullfiling + the same interface as other for natural representations. As + soon as binary representations such as NArith are available, + it is clearly better to convert to/from them and use their ops. +*) + +Fixpoint div2 n := + match n with + | 0 => 0 + | S 0 => 0 + | S (S n') => S (div2 n') + end. + +Fixpoint testbit a n : bool := + match n with + | 0 => odd a + | S n => testbit (div2 a) n + end. + +Definition shiftl a := nat_rect _ a (fun _ => double). +Definition shiftr a := nat_rect _ a (fun _ => div2). + +Fixpoint bitwise (op:bool->bool->bool) n a b := + match n with + | 0 => 0 + | S n' => + (if op (odd a) (odd b) then 1 else 0) + + 2*(bitwise op n' (div2 a) (div2 b)) + end. + +Definition land a b := bitwise andb a a b. +Definition lor a b := bitwise orb (max a b) a b. +Definition ldiff a b := bitwise (fun b b' => andb b (negb b')) a a b. +Definition lxor a b := bitwise xorb (max a b) a b. diff --git a/theories/Init/Notations.v b/theories/Init/Notations.v index c745f9c9..424ca0c8 100644 --- a/theories/Init/Notations.v +++ b/theories/Init/Notations.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* y" (at level 99, right associativity, y at level 200). Reserved Notation "x <-> y" (at level 95, no associativity). Reserved Notation "x /\ y" (at level 80, right associativity). Reserved Notation "x \/ y" (at level 85, right associativity). @@ -79,3 +80,13 @@ Delimit Scope core_scope with core. Open Scope core_scope. Open Scope type_scope. + +(** ML Tactic Notations *) + +Declare ML Module "coretactics". +Declare ML Module "extratactics". +Declare ML Module "eauto". +Declare ML Module "g_class". +Declare ML Module "g_eqdecide". +Declare ML Module "g_rewrite". +Declare ML Module "tauto". diff --git a/theories/Init/Peano.v b/theories/Init/Peano.v index ef2d9584..7a14ab39 100644 --- a/theories/Init/Peano.v +++ b/theories/Init/Peano.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* n - | S u => u - end. -Hint Resolve (f_equal pred): v62. +Notation pred := Nat.pred (compat "8.4"). + +Definition f_equal_pred := f_equal pred. +Hint Resolve f_equal_pred: v62. Theorem pred_Sn : forall n:nat, n = pred (S n). Proof. @@ -80,16 +81,13 @@ Hint Resolve n_Sn: core. (** Addition *) -Fixpoint plus (n m:nat) : nat := - match n with - | O => m - | S p => S (p + m) - end - -where "n + m" := (plus n m) : nat_scope. +Notation plus := Nat.add (compat "8.4"). +Infix "+" := Nat.add : nat_scope. -Hint Resolve (f_equal2 plus): v62. -Hint Resolve (f_equal2 (A1:=nat) (A2:=nat)): core. +Definition f_equal2_plus := f_equal2 plus. +Hint Resolve f_equal2_plus: v62. +Definition f_equal2_nat := f_equal2 (A1:=nat) (A2:=nat). +Hint Resolve f_equal2_nat: core. Lemma plus_n_O : forall n:nat, n = n + 0. Proof. @@ -99,7 +97,7 @@ Hint Resolve plus_n_O: core. Lemma plus_O_n : forall n:nat, 0 + n = n. Proof. - auto. + reflexivity. Qed. Lemma plus_n_Sm : forall n m:nat, S (n + m) = n + S m. @@ -110,7 +108,7 @@ Hint Resolve plus_n_Sm: core. Lemma plus_Sn_m : forall n m:nat, S n + m = S (n + m). Proof. - auto. + reflexivity. Qed. (** Standard associated names *) @@ -120,15 +118,11 @@ Notation plus_succ_r_reverse := plus_n_Sm (compat "8.2"). (** Multiplication *) -Fixpoint mult (n m:nat) : nat := - match n with - | O => 0 - | S p => m + p * m - end - -where "n * m" := (mult n m) : nat_scope. +Notation mult := Nat.mul (compat "8.4"). +Infix "*" := Nat.mul : nat_scope. -Hint Resolve (f_equal2 mult): core. +Definition f_equal2_mult := f_equal2 mult. +Hint Resolve f_equal2_mult: core. Lemma mult_n_O : forall n:nat, 0 = n * 0. Proof. @@ -151,14 +145,8 @@ Notation mult_succ_r_reverse := mult_n_Sm (compat "8.2"). (** Truncated subtraction: [m-n] is [0] if [n>=m] *) -Fixpoint minus (n m:nat) : nat := - match n, m with - | O, _ => n - | S k, O => n - | S k, S l => k - l - end - -where "n - m" := (minus n m) : nat_scope. +Notation minus := Nat.sub (compat "8.4"). +Infix "-" := Nat.sub : nat_scope. (** Definition of the usual orders, the basic properties of [le] and [lt] can be found in files Le and Lt *) @@ -202,6 +190,16 @@ Proof. intros n m. exact (le_pred (S n) (S m)). Qed. +Theorem le_0_n : forall n, 0 <= n. +Proof. + induction n; constructor; trivial. +Qed. + +Theorem le_n_S : forall n m, n <= m -> S n <= S m. +Proof. + induction 1; constructor; trivial. +Qed. + (** Case analysis *) Theorem nat_case : @@ -224,73 +222,48 @@ Qed. (** Maximum and minimum : definitions and specifications *) -Fixpoint max n m : nat := - match n, m with - | O, _ => m - | S n', O => n - | S n', S m' => S (max n' m') - end. - -Fixpoint min n m : nat := - match n, m with - | O, _ => 0 - | S n', O => 0 - | S n', S m' => S (min n' m') - end. +Notation max := Nat.max (compat "8.4"). +Notation min := Nat.min (compat "8.4"). -Theorem max_l : forall n m : nat, m <= n -> max n m = n. +Lemma max_l n m : m <= n -> Nat.max n m = n. Proof. -induction n; destruct m; simpl; auto. inversion 1. -intros. apply f_equal. apply IHn. apply le_S_n. trivial. + revert m; induction n; destruct m; simpl; trivial. + - inversion 1. + - intros. apply f_equal, IHn, le_S_n; trivial. Qed. -Theorem max_r : forall n m : nat, n <= m -> max n m = m. +Lemma max_r n m : n <= m -> Nat.max n m = m. Proof. -induction n; destruct m; simpl; auto. inversion 1. -intros. apply f_equal. apply IHn. apply le_S_n. trivial. + revert m; induction n; destruct m; simpl; trivial. + - inversion 1. + - intros. apply f_equal, IHn, le_S_n; trivial. Qed. -Theorem min_l : forall n m : nat, n <= m -> min n m = n. +Lemma min_l n m : n <= m -> Nat.min n m = n. Proof. -induction n; destruct m; simpl; auto. inversion 1. -intros. apply f_equal. apply IHn. apply le_S_n. trivial. + revert m; induction n; destruct m; simpl; trivial. + - inversion 1. + - intros. apply f_equal, IHn, le_S_n; trivial. Qed. -Theorem min_r : forall n m : nat, m <= n -> min n m = m. +Lemma min_r n m : m <= n -> Nat.min n m = m. Proof. -induction n; destruct m; simpl; auto. inversion 1. -intros. apply f_equal. apply IHn. apply le_S_n. trivial. + revert m; induction n; destruct m; simpl; trivial. + - inversion 1. + - intros. apply f_equal, IHn, le_S_n; trivial. Qed. -(** [n]th iteration of the function [f] *) -Fixpoint nat_iter (n:nat) {A} (f:A->A) (x:A) : A := - match n with - | O => x - | S n' => f (nat_iter n' f x) - end. - -Lemma nat_iter_succ_r n {A} (f:A->A) (x:A) : - nat_iter (S n) f x = nat_iter n f (f x). +Lemma nat_rect_succ_r {A} (f: A -> A) (x:A) n : + nat_rect (fun _ => A) x (fun _ => f) (S n) = nat_rect (fun _ => A) (f x) (fun _ => f) n. Proof. induction n; intros; simpl; rewrite <- ?IHn; trivial. Qed. -Theorem nat_iter_plus : +Theorem nat_rect_plus : forall (n m:nat) {A} (f:A -> A) (x:A), - nat_iter (n + m) f x = nat_iter n f (nat_iter m f x). + nat_rect (fun _ => A) x (fun _ => f) (n + m) = + nat_rect (fun _ => A) (nat_rect (fun _ => A) x (fun _ => f) m) (fun _ => f) n. Proof. induction n; intros; simpl; rewrite ?IHn; trivial. Qed. - -(** Preservation of invariants : if [f : A->A] preserves the invariant [Inv], - then the iterates of [f] also preserve it. *) - -Theorem nat_iter_invariant : - forall (n:nat) {A} (f:A -> A) (P : A -> Prop), - (forall x, P x -> P (f x)) -> - forall x, P x -> P (nat_iter n f x). -Proof. - induction n; simpl; trivial. - intros A f P Hf x Hx. apply Hf, IHn; trivial. -Qed. diff --git a/theories/Init/Prelude.v b/theories/Init/Prelude.v index 2614ce40..4894eba4 100644 --- a/theories/Init/Prelude.v +++ b/theories/Init/Prelude.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* P)) : type_scope. Notation "{ x | P & Q }" := (sig2 (fun x => P) (fun x => Q)) : type_scope. -Notation "{ x : A | P }" := (sig (fun x:A => P)) : type_scope. -Notation "{ x : A | P & Q }" := (sig2 (fun x:A => P) (fun x:A => Q)) : +Notation "{ x : A | P }" := (sig (A:=A) (fun x => P)) : type_scope. +Notation "{ x : A | P & Q }" := (sig2 (A:=A) (fun x => P) (fun x => Q)) : type_scope. -Notation "{ x : A & P }" := (sigT (fun x:A => P)) : type_scope. -Notation "{ x : A & P & Q }" := (sigT2 (fun x:A => P) (fun x:A => Q)) : +Notation "{ x : A & P }" := (sigT (A:=A) (fun x => P)) : type_scope. +Notation "{ x : A & P & Q }" := (sigT2 (A:=A) (fun x => P) (fun x => Q)) : type_scope. Add Printing Let sig. @@ -65,24 +65,57 @@ Add Printing Let sigT2. [(proj1_sig y)] is the witness [a] and [(proj2_sig y)] is the proof of [(P a)] *) - +(* Set Universe Polymorphism. *) Section Subset_projections. Variable A : Type. Variable P : A -> Prop. Definition proj1_sig (e:sig P) := match e with - | exist a b => a + | exist _ a b => a end. Definition proj2_sig (e:sig P) := match e return P (proj1_sig e) with - | exist a b => b + | exist _ a b => b end. End Subset_projections. +(** [sig2] of a predicate can be projected to a [sig]. + + This allows [proj1_sig] and [proj2_sig] to be usable with [sig2]. + + The [let] statements occur in the body of the [exist] so that + [proj1_sig] of a coerced [X : sig2 P Q] will unify with [let (a, + _, _) := X in a] *) + +Definition sig_of_sig2 (A : Type) (P Q : A -> Prop) (X : sig2 P Q) : sig P + := exist P + (let (a, _, _) := X in a) + (let (x, p, _) as s return (P (let (a, _, _) := s in a)) := X in p). + +(** Projections of [sig2] + + An element [y] of a subset [{x:A | (P x) & (Q x)}] is the triple + of an [a] of type [A], a of a proof [h] that [a] satisfies [P], + and a proof [h'] that [a] satisfies [Q]. Then + [(proj1_sig (sig_of_sig2 y))] is the witness [a], + [(proj2_sig (sig_of_sig2 y))] is the proof of [(P a)], and + [(proj3_sig y)] is the proof of [(Q a)]. *) + +Section Subset_projections2. + + Variable A : Type. + Variables P Q : A -> Prop. + + Definition proj3_sig (e : sig2 P Q) := + let (a, b, c) return Q (proj1_sig (sig_of_sig2 e)) := e in c. + +End Subset_projections2. + + (** Projections of [sigT] An element [x] of a sigma-type [{y:A & P y}] is a dependent pair @@ -90,31 +123,71 @@ End Subset_projections. [(projT1 x)] is the first projection and [(projT2 x)] is the second projection, the type of which depends on the [projT1]. *) + + Section Projections. Variable A : Type. Variable P : A -> Type. Definition projT1 (x:sigT P) : A := match x with - | existT a _ => a + | existT _ a _ => a end. + Definition projT2 (x:sigT P) : P (projT1 x) := match x return P (projT1 x) with - | existT _ h => h + | existT _ _ h => h end. End Projections. +(** [sigT2] of a predicate can be projected to a [sigT]. + + This allows [projT1] and [projT2] to be usable with [sigT2]. + + The [let] statements occur in the body of the [existT] so that + [projT1] of a coerced [X : sigT2 P Q] will unify with [let (a, + _, _) := X in a] *) + +Definition sigT_of_sigT2 (A : Type) (P Q : A -> Type) (X : sigT2 P Q) : sigT P + := existT P + (let (a, _, _) := X in a) + (let (x, p, _) as s return (P (let (a, _, _) := s in a)) := X in p). + +(** Projections of [sigT2] + + An element [x] of a sigma-type [{y:A & P y & Q y}] is a dependent + pair made of an [a] of type [A], an [h] of type [P a], and an [h'] + of type [Q a]. Then, [(projT1 (sigT_of_sigT2 x))] is the first + projection, [(projT2 (sigT_of_sigT2 x))] is the second projection, + and [(projT3 x)] is the third projection, the types of which + depends on the [projT1]. *) + +Section Projections2. + + Variable A : Type. + Variables P Q : A -> Type. + + Definition projT3 (e : sigT2 P Q) := + let (a, b, c) return Q (projT1 (sigT_of_sigT2 e)) := e in c. + +End Projections2. + (** [sigT] of a predicate is equivalent to [sig] *) -Lemma sig_of_sigT : forall (A:Type) (P:A->Prop), sigT P -> sig P. -Proof. destruct 1 as (x,H); exists x; trivial. Defined. +Definition sig_of_sigT (A : Type) (P : A -> Prop) (X : sigT P) : sig P + := exist P (projT1 X) (projT2 X). + +Definition sigT_of_sig (A : Type) (P : A -> Prop) (X : sig P) : sigT P + := existT P (proj1_sig X) (proj2_sig X). -Lemma sigT_of_sig : forall (A:Type) (P:A->Prop), sig P -> sigT P. -Proof. destruct 1 as (x,H); exists x; trivial. Defined. +(** [sigT2] of a predicate is equivalent to [sig2] *) -Coercion sigT_of_sig : sig >-> sigT. -Coercion sig_of_sigT : sigT >-> sig. +Definition sig2_of_sigT2 (A : Type) (P Q : A -> Prop) (X : sigT2 P Q) : sig2 P Q + := exist2 P Q (projT1 (sigT_of_sigT2 X)) (projT2 (sigT_of_sigT2 X)) (projT3 X). + +Definition sigT2_of_sig2 (A : Type) (P Q : A -> Prop) (X : sig2 P Q) : sigT2 P Q + := existT2 P Q (proj1_sig (sig_of_sig2 X)) (proj2_sig (sig_of_sig2 X)) (proj3_sig X). (** [sumbool] is a boolean type equipped with the justification of their value *) @@ -142,6 +215,8 @@ Add Printing If sumor. Arguments inleft {A B} _ , [A] B _. Arguments inright {A B} _ , A [B] _. +(* Unset Universe Polymorphism. *) + (** Various forms of the axiom of choice for specifications *) Section Choice_lemmas. @@ -187,10 +262,10 @@ Section Dependent_choice_lemmas. (forall x:X, {y | R x y}) -> forall x0, {f : nat -> X | f O = x0 /\ forall n, R (f n) (f (S n))}. Proof. - intros H x0. + intros H x0. set (f:=fix f n := match n with O => x0 | S n' => proj1_sig (H (f n')) end). exists f. - split. reflexivity. + split. reflexivity. induction n; simpl; apply proj2_sig. Defined. @@ -203,12 +278,14 @@ End Dependent_choice_lemmas. [Inductive Exc [A:Type] : Type := value : A->(Exc A) | error : (Exc A)]. It is implemented using the option type. *) +Section Exc. + Variable A : Type. -Definition Exc := option. -Definition value := Some. -Definition error := @None. - -Arguments error [A]. + Definition Exc := option A. + Definition value := @Some A. + Definition error := @None A. +End Exc. +Arguments error {A}. Definition except := False_rec. (* for compatibility with previous versions *) diff --git a/theories/Init/Tactics.v b/theories/Init/Tactics.v index 4a7b9283..9e828e6e 100644 --- a/theories/Init/Tactics.v +++ b/theories/Init/Tactics.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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. diff --git a/theories/Init/vo.itarget b/theories/Init/vo.itarget index f53d55e7..cc62e66c 100644 --- a/theories/Init/vo.itarget +++ b/theories/Init/vo.itarget @@ -7,3 +7,4 @@ Prelude.vo Specif.vo Tactics.vo Wf.vo +Nat.vo \ No newline at end of file diff --git a/theories/Lists/List.v b/theories/Lists/List.v index f5a12b09..3cba090f 100644 --- a/theories/Lists/List.v +++ b/theories/Lists/List.v @@ -1,15 +1,16 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* default + | [] => default | x :: _ => x end. Definition hd_error (l:list A) := match l with - | nil => error + | [] => error | x :: _ => value x end. Definition tl (l:list A) := match l with - | nil => nil + | [] => nil | a :: m => m end. (** The [In] predicate *) Fixpoint In (a:A) (l:list A) : Prop := match l with - | nil => False + | [] => False | b :: m => b = a \/ In a m end. End Lists. - -(** Standard notations for lists. -In a special module to avoid conflict. *) -Module ListNotations. -Notation " [ ] " := nil : list_scope. -Notation " [ x ] " := (cons x nil) : list_scope. -Notation " [ x ; .. ; y ] " := (cons x .. (cons y nil) ..) : list_scope. -End ListNotations. - -Import ListNotations. - -(** ** Facts about lists *) - Section Facts. Variable A : Type. @@ -89,6 +87,24 @@ Section Facts. left; exists a, tail; reflexivity. Qed. + Lemma hd_error_tl_repr : forall l (a:A) r, + hd_error l = Some a /\ tl l = r <-> l = a :: r. + Proof. destruct l as [|x xs]. + - unfold hd_error, tl; intros a r. split; firstorder discriminate. + - intros. simpl. split. + * intros (H1, H2). inversion H1. rewrite H2. reflexivity. + * inversion 1. subst. auto. + Qed. + + Lemma hd_error_some_nil : forall l (a:A), hd_error l = Some a -> l <> nil. + 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. @@ -119,6 +135,12 @@ Section Facts. 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. @@ -130,7 +152,7 @@ Section Facts. subst a; auto. exists [], l; auto. destruct (IHl H) as (l1,(l2,H0)). - exists (a::l1), l2; simpl; f_equal; auto. + exists (a::l1), l2; simpl. apply f_equal. auto. Qed. (** Inversion *) @@ -173,7 +195,7 @@ Section Facts. Qed. Theorem app_nil_r : forall l:list A, l ++ [] = l. - Proof. + Proof. induction l; simpl; f_equal; auto. Qed. @@ -228,10 +250,8 @@ Section Facts. intros. injection H. intro. - cut ([] = l ++ a0 :: l0); auto. - intro. - generalize (app_cons_not_nil _ _ _ H1); intro. - elim H2. + assert ([] = l ++ a0 :: l0) by auto. + apply app_cons_not_nil in H1 as []. Qed. Lemma app_inj_tail : @@ -240,22 +260,20 @@ Section Facts. induction x as [| x l IHl]; [ destruct y as [| a l] | destruct y as [| a l0] ]; simpl; auto. - intros a b H. - injection H. - auto. - intros a0 b H. - injection H; intros. - generalize (app_cons_not_nil _ _ _ H0); destruct 1. - intros a b H. - injection H; intros. - cut ([] = l ++ [a]); auto. - intro. - generalize (app_cons_not_nil _ _ _ H2); destruct 1. - intros a0 b H. - injection H; intros. - destruct (IHl l0 a0 b H0). - split; auto. - rewrite <- H1; rewrite <- H2; reflexivity. + - intros a b H. + injection H. + auto. + - intros a0 b H. + injection H as H1 H0. + apply app_cons_not_nil in H0 as []. + - intros a b H. + injection H as H1 H0. + assert ([] = l ++ [a]) by auto. + apply app_cons_not_nil in H as []. + - intros a0 b H. + injection H as <- H0. + destruct (IHl l0 a0 b H0) as (<-,<-). + split; auto. Qed. @@ -360,13 +378,12 @@ Section Elts. Lemma nth_in_or_default : forall (n:nat) (l:list A) (d:A), {In (nth n l d) l} + {nth n l d = d}. - (* Realizer nth_ok. Program_all. *) Proof. - intros n l d; generalize n; induction l; intro n0. - right; case n0; trivial. - case n0; simpl. - auto. - intro n1; elim (IHl n1); auto. + intros n l d; revert n; induction l. + - right; destruct n; trivial. + - intros [|n]; simpl. + * left; auto. + * destruct (IHl n); auto. Qed. Lemma nth_S_cons : @@ -395,60 +412,132 @@ Section Elts. unfold nth_default; 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; induction n as [| n hn]; simpl. - destruct l; simpl; [ inversion 2 | auto ]. - destruct l as [| a l hl]; simpl. - inversion 2. - intros d ie; right; apply hn; auto with arith. + - destruct l; simpl; [ inversion 2 | auto ]. + - destruct l as [| a l hl]; simpl. + * inversion 2. + * intros d ie; right; apply hn; auto with arith. + 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 with arith. + * destruct (IH H) as (n & Hn & Hn'). + exists (S n); simpl; auto with arith. Qed. Lemma nth_overflow : forall l n d, length l <= n -> nth n l d = d. Proof. induction l; destruct n; simpl; intros; auto. - inversion H. - apply IHl; auto with arith. + - inversion H. + - apply IHl; auto with arith. Qed. Lemma nth_indep : forall l n d d', n < length l -> nth n l d = nth n l d'. Proof. - induction l; simpl; intros; auto. - inversion H. - destruct n; simpl; auto with arith. + induction l. + - inversion 1. + - intros [|n] d d'; simpl; auto with arith. Qed. Lemma app_nth1 : forall l l' d n, n < length l -> nth n (l++l') d = nth n l d. Proof. induction l. - intros. - inversion H. - intros l' d n. - case n; simpl; auto. - intros; rewrite IHl; auto with arith. + - inversion 1. + - intros l' d [|n]; simpl; auto with arith. Qed. Lemma app_nth2 : forall l l' d n, n >= length l -> nth n (l++l') d = nth (n-length l) l' d. Proof. - induction l. - intros. - simpl. - destruct n; auto. - intros l' d n. - case n; simpl; auto. - intros. - inversion H. - intros. - rewrite IHl; auto with arith. + induction l; intros l' d [|n]; auto. + - inversion 1. + - intros; simpl; rewrite IHl; auto with arith. + 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); auto with arith. + exists (a::l1); exists l2; simpl; split; now f_equal. 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|H]. + * subst; exists 0; simpl; auto with arith. + * destruct (IH H) as (n,Hn). + exists (S n); simpl; auto with arith. + Qed. + + Lemma nth_error_None l n : nth_error l n = None <-> length l <= n. + Proof. + revert n. induction l; destruct n; simpl. + - split; auto. + - split; auto with arith. + - split; now auto with arith. + - rewrite IHl; split; auto with arith. + Qed. + + Lemma nth_error_Some l n : nth_error l n <> None <-> n < length l. + Proof. + revert n. induction l; destruct n; simpl. + - split; [now destruct 1 | inversion 1]. + - split; [now destruct 1 | inversion 1]. + - split; now auto with arith. + - rewrite IHl; split; auto with arith. + 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; simpl in *; try easy. + - exists nil; exists l. injection H; clear H; intros; now subst. + - 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; intros [|a l] H; auto; try solve [inversion H]. + simpl in *. apply IHn. auto with arith. + 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; intros [|a l] H; auto; try solve [inversion H]. + simpl in *. apply IHn. auto with arith. + Qed. (*****************) (** ** Remove *) @@ -541,19 +630,29 @@ Section Elts. match l with | [] => 0 | y :: tl => - let n := count_occ tl x in - if eq_dec y x then S n else n + 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 : list A) (x : A) : In x l <-> count_occ l x > 0. + Theorem count_occ_In l x : In x l <-> count_occ l x > 0. Proof. induction l as [|y l]; simpl. - split; [destruct 1 | apply gt_irrefl]. - destruct eq_dec as [->|Hneq]; rewrite IHl; intuition. Qed. - Theorem count_occ_inv_nil (l : list A) : + 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. @@ -563,27 +662,20 @@ Section Elts. - now intros ->. Qed. - Lemma count_occ_nil : forall (x : A), count_occ [] x = 0. - Proof. - intro x; simpl; reflexivity. - Qed. - - Lemma count_occ_cons_eq : forall (l : list A) (x y : A), x = y -> count_occ (x::l) y = S (count_occ l y). + Lemma count_occ_cons_eq l x y : + x = y -> count_occ (x::l) y = S (count_occ l y). Proof. - intros l x y H; simpl. - destruct (eq_dec x y); [reflexivity | contradiction]. + intros H. simpl. now destruct (eq_dec x y). Qed. - Lemma count_occ_cons_neq : forall (l : list A) (x y : A), x <> y -> count_occ (x::l) y = count_occ l y. + Lemma count_occ_cons_neq l x y : + x <> y -> count_occ (x::l) y = count_occ l y. Proof. - intros l x y H; simpl. - destruct (eq_dec x y); [contradiction | reflexivity]. + intros H. simpl. now destruct (eq_dec x y). Qed. End Elts. - - (*******************************) (** * Manipulating whole lists *) (*******************************) @@ -739,6 +831,33 @@ Section ListOps. End Reverse_Induction. + (*************************) + (** ** Concatenation *) + (*************************) + + Fixpoint concat (l : list (list A)) : list A := + match l with + | nil => nil + | cons x l => x ++ concat l + end. + + Lemma concat_nil : concat nil = nil. + 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. + (***********************************) (** ** Decidable equality on lists *) (***********************************) @@ -759,15 +878,20 @@ End ListOps. (************) Section Map. - Variables A B : Type. + Variables (A : Type) (B : Type). Variable f : A -> B. Fixpoint map (l:list A) : list B := match l with - | nil => nil - | cons a t => cons (f a) (map t) + | [] => [] + | a :: t => (f a) :: (map t) end. + 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. @@ -815,6 +939,25 @@ Section Map. destruct l; simpl; reflexivity || discriminate. 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. + (** [flat_map] *) Definition flat_map (f:A -> list B) := @@ -826,7 +969,7 @@ Section Map. Lemma in_flat_map : forall (f:A->list B)(l:list A)(y:B), In y (flat_map f l) <-> exists x, In x l /\ In y (f x). - Proof. + Proof using A B. induction l; simpl; split; intros. contradiction. destruct H as (x,(H,_)); contradiction. @@ -843,6 +986,21 @@ Section Map. End Map. +Lemma flat_map_concat_map : forall A B (f : A -> list B) l, + flat_map f l = concat (map f l). +Proof. +intros A B f l; induction l as [|x l IH]; simpl. ++ reflexivity. ++ rewrite IH; reflexivity. +Qed. + +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 map_id : forall (A :Type) (l : list A), map (fun x => x) l = l. Proof. @@ -869,7 +1027,7 @@ Qed. (************************************) Section Fold_Left_Recursor. - Variables A B : Type. + Variables (A : Type) (B : Type). Variable f : A -> B -> A. Fixpoint fold_left (l:list B) (a0:A) : A := @@ -893,10 +1051,8 @@ End Fold_Left_Recursor. Lemma fold_left_length : forall (A:Type)(l:list A), fold_left (fun x _ => S x) l 0 = length l. Proof. - intro A. - cut (forall (l:list A) n, fold_left (fun x _ => S x) l n = n + length l). - intros. - exact (H l 0). + intros A l. + enough (H : forall n, fold_left (fun x _ => S x) l n = n + length l) by exact (H 0). induction l; simpl; auto. intros; rewrite IHl. simpl; auto with arith. @@ -907,7 +1063,7 @@ Qed. (************************************) Section Fold_Right_Recursor. - Variables A B : Type. + Variables (A : Type) (B : Type). Variable f : B -> A -> A. Variable a0 : A. @@ -939,29 +1095,17 @@ End Fold_Right_Recursor. 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 x y:A, f x y = f y x) -> - forall (a0:A) (l:list A), fold_left f l a0 = fold_right f a0 l. + 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. - destruct l as [| a l]. - reflexivity. - simpl. - rewrite <- H0. - generalize a0 a. - induction l as [| a3 l IHl]; simpl. - trivial. - intros. - rewrite H. - rewrite (H0 a2). - rewrite <- (H a1). - rewrite (H0 a1). - rewrite IHl. - reflexivity. + intros A f assoc a0 comma0 l. + induction l as [ | a1 l ]; [ simpl; reflexivity | ]. + simpl. rewrite <- IHl. clear IHl. revert a1. induction l; [ 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. *) @@ -1075,6 +1219,21 @@ End Fold_Right_Recursor. | 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. + (** [partition] *) Fixpoint partition (l:list A) : list A * list A := @@ -1084,6 +1243,53 @@ End Fold_Right_Recursor. 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. @@ -1094,14 +1300,14 @@ End Fold_Right_Recursor. (******************************************************) Section ListPairs. - Variables A B : Type. + 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 - | nil => (nil, nil) - | (x,y) :: tl => let (g,d) := split tl in (x::g, y::d) + | [] => ([], []) + | (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), @@ -1479,6 +1685,61 @@ Section Cutting. End Cutting. +(**********************************************************************) +(** ** 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. + - 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; 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; auto with arith. + 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 *) @@ -1492,31 +1753,187 @@ Section ReDun. | NoDup_nil : NoDup nil | NoDup_cons : forall x l, ~ In x l -> NoDup l -> NoDup (x::l). - Lemma NoDup_remove_1 : forall l l' a, NoDup (l++a::l') -> NoDup (l++l'). + Lemma NoDup_Add a l l' : Add a l l' -> (NoDup l' <-> NoDup l /\ ~In a l). Proof. - induction l; simpl. - inversion_clear 1; auto. - inversion_clear 1. - constructor. - contradict H0. - apply in_or_app; destruct (in_app_or _ _ _ H0); simpl; tauto. - apply IHl with a0; auto. + 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_2 : forall l l' a, NoDup (l++a::l') -> ~In a (l++l'). + Lemma NoDup_remove l l' a : + NoDup (l++a::l') -> NoDup (l++l') /\ ~In a (l++l'). Proof. - induction l; simpl. - inversion_clear 1; auto. - inversion_clear 1. - contradict H0. - destruct H0. - subst a0. - apply in_or_app; right; red; auto. - destruct (IHl _ _ H1); auto. + 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. + + (** 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_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. + * intuition; now subst. + * reflexivity. + 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. + + 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. apply IH; auto with arith. } + { induction l as [|a l]; 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. discriminate H; auto with arith. + * apply IHl. + intros i j Hi E. apply eq_add_S, H; simpl; auto with arith. } + Qed. + + Lemma NoDup_nth l d : + NoDup l <-> + (forall i j, i j + nth i l d = nth j l d -> i = j). + Proof. + split. + { intros H; induction H as [|a l Hal Hl IH]; intros i j Hi Hj E. + - inversion Hi. + - destruct i, j; simpl in *; auto. + * elim Hal. subst a. apply nth_In; auto with arith. + * elim Hal. subst a. apply nth_In; auto with arith. + * f_equal. apply IH; auto with arith. } + { induction l as [|a l]; intros H; constructor. + * intro Ha. eapply In_nth in Ha. destruct Ha as (n & Hn & Hn'). + specialize (H 0 (S n)). simpl in H. discriminate H; eauto with arith. + * apply IHl. + intros i j Hi Hj E. apply eq_add_S, H; simpl; auto with arith. } + 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. + - auto with arith. + - 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]. + - 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 le_S_n. now rewrite <- (Add_length AD). + * now apply incl_Add_inv with a 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 *) @@ -1558,149 +1975,252 @@ Section NatSeq. auto with arith. Qed. + Lemma in_seq len start n : + In n (seq start len) <-> start <= n < start+len. + Proof. + revert start. induction len; simpl; intros. + - rewrite <- plus_n_O. split;[easy|]. + intros (H,H'). apply (Lt.lt_irrefl _ (Lt.le_lt_trans _ _ _ H H')). + - rewrite IHlen, <- plus_n_Sm; simpl; split. + * intros [H|H]; subst; intuition auto with arith. + * intros (H,H'). destruct (Lt.le_lt_or_eq _ _ H); intuition. + Qed. + + Lemma seq_NoDup len start : NoDup (seq start len). + Proof. + revert start; induction len; simpl; constructor; trivial. + rewrite in_seq. intros (H,_). apply (Lt.lt_irrefl _ H). + Qed. + End NatSeq. +Section Exists_Forall. -(** * Existential and universal predicates over lists *) + (** * Existential and universal predicates over lists *) -Inductive Exists {A} (P:A->Prop) : list A -> Prop := - | Exists_cons_hd : forall x l, P x -> Exists P (x::l) - | Exists_cons_tl : forall x l, Exists P l -> Exists P (x::l). -Hint Constructors Exists. + Variable A:Type. -Lemma Exists_exists : forall A P (l:list A), - Exists P l <-> (exists x, In x l /\ P x). -Proof. -split. -induction 1; firstorder. -induction l; firstorder; subst; auto. -Qed. + 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). -Lemma Exists_nil : forall A (P:A->Prop), Exists P nil <-> False. -Proof. split; inversion 1. Qed. + Hint Constructors Exists. -Lemma Exists_cons : forall A (P:A->Prop) x l, - Exists P (x::l) <-> P x \/ Exists P l. -Proof. split; inversion 1; auto. Qed. + 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_nil : Exists nil <-> 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_dec l: + (forall x:A, {P x} + { ~ P x }) -> + {Exists l} + {~ Exists l}. + Proof. + intro Pdec. induction l as [|a l' Hrec]. + - right. 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. now inversion_clear 1. + Qed. -Inductive Forall {A} (P:A->Prop) : list A -> Prop := - | Forall_nil : Forall P nil - | Forall_cons : forall x l, P x -> Forall P l -> Forall P (x::l). + Inductive Forall : list A -> Prop := + | Forall_nil : Forall nil + | Forall_cons : forall x l, P x -> Forall l -> Forall (x::l). + + Hint Constructors Forall. + + 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. + Qed. + + Lemma Forall_inv : forall (a:A) l, Forall (a :: l) -> P a. + Proof. + intros; inversion H; trivial. + 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'; 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. + intro Pdec. 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. now inversion_clear 1. + + right. now inversion_clear 1. + Qed. + + End One_predicate. + + 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 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. + apply Exists_Forall_neg; trivial. + intro x. destruct (Pdec x); [now left|now right]. + 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. + +End Exists_Forall. + +Hint Constructors Exists. Hint Constructors Forall. -Lemma Forall_forall : forall A P (l:list A), - Forall P l <-> (forall x, In x l -> P x). -Proof. -split. -induction 1; firstorder; subst; auto. -induction l; firstorder. -Qed. +Section Forall2. -Lemma Forall_inv : forall A P (a:A) l, Forall P (a :: l) -> P a. -Proof. -intros; inversion H; trivial. -Defined. + (** [Forall2]: stating that elements of two lists are pairwise related. *) -Lemma Forall_rect : forall A (P:A->Prop) (Q : list A -> Type), - Q [] -> (forall b l, P b -> Q (b :: l)) -> forall l, Forall P l -> Q l. -Proof. -intros A P Q H H'; induction l; intro; [|eapply H', Forall_inv]; eassumption. -Defined. + Variables A B : Type. + Variable R : A -> B -> Prop. -Lemma Forall_impl : forall A (P Q : A -> Prop), (forall a, P a -> Q a) -> - forall l, Forall P l -> Forall Q l. -Proof. - intros A P Q Himp l H. - induction H; firstorder. -Qed. + 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'). -(** [Forall2]: stating that elements of two lists are pairwise related. *) + Hint Constructors Forall2. -Inductive Forall2 A B (R:A->B->Prop) : list A -> list B -> Prop := - | Forall2_nil : Forall2 R [] [] - | Forall2_cons : forall x y l l', - R x y -> Forall2 R l l' -> Forall2 R (x::l) (y::l'). -Hint Constructors Forall2. + Theorem Forall2_refl : Forall2 [] []. + Proof. intros; apply Forall2_nil. 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. + induction l1; intros. + exists [], l'; auto. + simpl in H; inversion H; subst; clear H. + apply IHl1 in H4 as (l1' & l2' & Hl1 & Hl2 & ->). + exists (y::l1'), l2'; simpl; auto. + Qed. -Theorem Forall2_refl : forall A B (R:A->B->Prop), Forall2 R [] []. -Proof. exact Forall2_nil. 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. + induction l1'; intros. + exists [], l; auto. + simpl in H; inversion H; subst; clear H. + apply IHl1' in H4 as (l1 & l2 & Hl1 & Hl2 & ->). + exists (x::l1), l2; simpl; auto. + Qed. -Theorem Forall2_app_inv_l : forall A B (R:A->B->Prop) l1 l2 l', - Forall2 R (l1 ++ l2) l' -> - exists l1' l2', Forall2 R l1 l1' /\ Forall2 R l2 l2' /\ l' = l1' ++ l2'. -Proof. - induction l1; intros. - exists [], l'; auto. - simpl in H; inversion H; subst; clear H. - apply IHl1 in H4 as (l1' & l2' & Hl1 & Hl2 & ->). - exists (y::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. induction l1 in l1', H, H0 |- *; inversion H; subst; simpl; auto. + Qed. +End Forall2. -Theorem Forall2_app_inv_r : forall A B (R:A->B->Prop) l1' l2' l, - Forall2 R l (l1' ++ l2') -> - exists l1 l2, Forall2 R l1 l1' /\ Forall2 R l2 l2' /\ l = l1 ++ l2. -Proof. - induction l1'; intros. - exists [], l; auto. - simpl in H; inversion H; subst; clear H. - apply IHl1' in H4 as (l1 & l2 & Hl1 & Hl2 & ->). - exists (x::l1), l2; simpl; auto. -Qed. +Hint Constructors Forall2. -Theorem Forall2_app : forall A B (R:A->B->Prop) l1 l2 l1' l2', - Forall2 R l1 l1' -> Forall2 R l2 l2' -> Forall2 R (l1 ++ l2) (l1' ++ l2'). -Proof. - intros. induction l1 in l1', H, H0 |- *; inversion H; subst; simpl; auto. -Qed. +Section ForallPairs. -(** [ForallPairs] : specifies that a certain relation should + (** [ForallPairs] : specifies that a certain relation should always hold when inspecting all possible pairs of elements of a list. *) -Definition ForallPairs A (R : A -> A -> Prop) l := - forall a b, In a l -> In b l -> R a b. + Variable A : Type. + Variable R : A -> A -> Prop. -(** [ForallOrdPairs] : we still check a relation over all pairs + 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 A (R : A -> A -> Prop) : list A -> Prop := - | FOP_nil : ForallOrdPairs R nil - | FOP_cons : forall a l, - Forall (R a) l -> ForallOrdPairs R l -> ForallOrdPairs R (a::l). -Hint Constructors ForallOrdPairs. + Inductive ForallOrdPairs : list A -> Prop := + | FOP_nil : ForallOrdPairs nil + | FOP_cons : forall a l, + Forall (R a) l -> ForallOrdPairs l -> ForallOrdPairs (a::l). -Lemma ForallOrdPairs_In : forall A (R:A->A->Prop) l, - ForallOrdPairs R 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; repeat subst; auto. - right; left. apply -> Forall_forall; eauto. - right; right. apply -> Forall_forall; eauto. -Qed. + Hint Constructors ForallOrdPairs. + 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; repeat subst; auto. + right; left. apply -> Forall_forall; eauto. + right; right. apply -> Forall_forall; eauto. + Qed. -(** [ForallPairs] implies [ForallOrdPairs]. The reverse implication is true + (** [ForallPairs] implies [ForallOrdPairs]. The reverse implication is true only when [R] is symmetric and reflexive. *) -Lemma ForallPairs_ForallOrdPairs : forall A (R:A->A->Prop) l, - ForallPairs R l -> ForallOrdPairs R l. -Proof. - induction l; auto. intros H. - constructor. - apply <- Forall_forall. intros; apply H; simpl; auto. - apply IHl. red; intros; apply H; simpl; auto. -Qed. + Lemma ForallPairs_ForallOrdPairs l: ForallPairs l -> ForallOrdPairs l. + Proof. + induction l; auto. intros H. + constructor. + apply <- Forall_forall. intros; apply H; simpl; auto. + apply IHl. red; intros; apply H; simpl; auto. + Qed. -Lemma ForallOrdPairs_ForallPairs : forall A (R:A->A->Prop), - (forall x, R x x) -> - (forall x y, R x y -> R y x) -> - forall l, ForallOrdPairs R l -> ForallPairs R l. -Proof. - intros A R Refl Sym l Hl x y Hx Hy. - destruct (ForallOrdPairs_In Hl _ _ Hx Hy); subst; intuition. -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. (** * Inversion of predicates over lists based on head symbol *) @@ -1767,3 +2287,28 @@ Notation AllS := Forall (only parsing). (* was formerly in TheoryList *) Hint Resolve app_nil_end : datatypes v62. (* end hide *) + +Section Repeat. + + Variable A : Type. + Fixpoint repeat (x : A) (n: nat ) := + match n with + | O => [] + | S k => x::(repeat x k) + end. + + 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. + +End Repeat. + +(* Unset Universe Polymorphism. *) diff --git a/theories/Lists/ListDec.v b/theories/Lists/ListDec.v new file mode 100644 index 00000000..8bd2daaf --- /dev/null +++ b/theories/Lists/ListDec.v @@ -0,0 +1,103 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* 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. + - 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/theories/Lists/ListSet.v b/theories/Lists/ListSet.v index 37d051a3..0a0bf0de 100644 --- a/theories/Lists/ListSet.v +++ b/theories/Lists/ListSet.v @@ -1,16 +1,18 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* Exists (eqA x) l. +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. @@ -101,10 +101,12 @@ Proof. split; induction 1; auto. Qed. (** Results concerning lists modulo [eqA] *) Hypothesis eqA_equiv : Equivalence eqA. - -Hint Resolve (@Equivalence_Reflexive _ _ eqA_equiv). -Hint Resolve (@Equivalence_Transitive _ _ eqA_equiv). -Hint Immediate (@Equivalence_Symmetric _ _ eqA_equiv). +Definition eqarefl := (@Equivalence_Reflexive _ _ eqA_equiv). +Definition eqatrans := (@Equivalence_Transitive _ _ eqA_equiv). +Definition eqasym := (@Equivalence_Symmetric _ _ eqA_equiv). + +Hint Resolve eqarefl eqatrans. +Hint Immediate eqasym. Ltac inv := invlist InA; invlist sort; invlist lelistA; invlist NoDupA. @@ -123,7 +125,6 @@ Proof. 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. *) @@ -149,7 +150,7 @@ Qed. 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. + intros l x y H H'. rewrite <- H. auto. Qed. Hint Immediate InA_eqA. @@ -496,7 +497,7 @@ Proof. apply Hrec; auto. inv; auto. eapply NoDupA_split; eauto. - invlist ForallOrdPairs; auto. + invlist ForallOrdPairs; auto. eapply equivlistA_NoDupA_split; eauto. transitivity (f y (fold_right f i (s1++s2))). apply Comp; auto. reflexivity. @@ -545,6 +546,155 @@ 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;intros. + - 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. +induction s1; simpl; auto; intros. +- 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. + rewrite Forall_forall in H0; apply H0. + apply in_or_app; simpl; auto. + reflexivity. +Qed. + +Lemma fold_right_equivlistA_restr2 : + forall s s' (i j:B) (heqij: eqB i j), + NoDupA s -> NoDupA s' -> ForallOrdPairs R s -> + eqB i j -> + equivlistA s s' -> eqB (fold_right f i s) (fold_right f j s'). +Proof. + simple induction s. + destruct s'; simpl. + intros. assumption. + unfold equivlistA; intros. + destruct (H3 a). + assert (InA a nil) by auto; inv. + intros x l Hrec s' i j heqij N N' F eqij E; simpl in *. + assert (InA x s') 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; 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. + induction s1;simpl;intros. +- 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 with (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. + 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)}. @@ -582,14 +732,14 @@ split. intro; inv. destruct 1; inv. intros. -destruct (eqA_dec x a); simpl; auto. +destruct (eqA_dec x a) as [Heq|Hnot]; simpl; auto. rewrite IHl; split; destruct 1; split; auto. inv; auto. destruct H0; transitivity a; auto. split. intro; inv. split; auto. -contradict n. +contradict Hnot. transitivity y; auto. rewrite (IHl x y) in H0; destruct H0; auto. destruct 1; inv; auto. @@ -633,7 +783,9 @@ Variable ltA : A -> A -> Prop. Hypothesis ltA_strorder : StrictOrder ltA. Hypothesis ltA_compat : Proper (eqA==>eqA==>iff) ltA. -Hint Resolve (@StrictOrder_Transitive _ _ ltA_strorder). +Let sotrans := (@StrictOrder_Transitive _ _ ltA_strorder). + +Hint Resolve sotrans. Notation InfA:=(lelistA ltA). Notation SortA:=(sort ltA). @@ -647,7 +799,7 @@ Proof. Qed. Global Instance InfA_compat : Proper (eqA==>eqlistA==>iff) InfA. -Proof. +Proof using eqA_equiv ltA_compat. (* and not ltA_strorder *) intros x x' Hxx' l l' Hll'. inversion_clear Hll'. intuition. @@ -658,7 +810,7 @@ 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. +Proof using eqA_equiv ltA_compat. intros H; now rewrite H. Qed. Hint Immediate InfA_ltA InfA_eqA. @@ -759,7 +911,7 @@ Qed. Global Instance rev_eqlistA_compat : Proper (eqlistA==>eqlistA) (@rev A). Proof. repeat red. intros. -rewrite (app_nil_end (rev x)), (app_nil_end (rev y)). +rewrite <- (app_nil_r (rev x)), <- (app_nil_r (rev y)). apply eqlistA_rev_app; auto. Qed. @@ -815,13 +967,12 @@ intros. 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. -clear ltA ltA_compat ltA_strorder. +clear sotrans ltA ltA_strorder ltA_compat. intros; do 2 rewrite InA_alt; intuition. destruct H0 as (y,(H0,H1)); rewrite filter_In in H1; exists y; intuition. destruct H0 as (y,(H0,H1)); rewrite filter_In in H1; intuition. @@ -888,9 +1039,9 @@ split; intros. invlist InA. compute in H2; destruct H2. subst b'. destruct (eqA_dec a a'); intuition. -destruct (eqA_dec a a'); simpl. +destruct (eqA_dec a a') as [HeqA|]; simpl. contradict H0. -revert e H2; clear - eqA_equiv. +revert HeqA H2; clear - eqA_equiv. induction l. intros; invlist InA. intros; invlist InA; auto. diff --git a/theories/Lists/SetoidPermutation.v b/theories/Lists/SetoidPermutation.v index b0657b63..afc7c25b 100644 --- a/theories/Lists/SetoidPermutation.v +++ b/theories/Lists/SetoidPermutation.v @@ -7,6 +7,7 @@ (***********************************************************************) Require Import SetoidList. +(* Set Universe Polymorphism. *) Set Implicit Arguments. Unset Strict Implicit. @@ -88,7 +89,7 @@ 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, <-app_assoc. + now rewrite app_comm_cons, (PermutationA_cons_append l₁ x), <- app_assoc. Qed. Lemma PermutationA_middle l₁ l₂ x : diff --git a/theories/Lists/StreamMemo.v b/theories/Lists/StreamMemo.v index fd5ab100..74d464c5 100644 --- a/theories/Lists/StreamMemo.v +++ b/theories/Lists/StreamMemo.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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. -case r; simpl. -trivial. -Qed. + +Lemma AC : forall r:retract_cond, retract -> forall a:A, r.(j2) (r.(i2) a) = a. +Proof. intros r. exact r.(inv2). Qed. End Retracts. @@ -114,7 +109,7 @@ Proof. exists g f. intro a. unfold f, g; simpl. -apply AC. +apply AC. exists (fun x:pow U => x) (fun x:pow U => x). trivial. Qed. @@ -132,9 +127,10 @@ Lemma not_has_fixpoint : R R = Not_b (R R). Proof. unfold R at 1. unfold g. -rewrite AC with (r := L1 U U) (a := fun u:U => Not_b (u U u)). +rewrite AC. +trivial. +exists (fun x:pow U => x) (fun x:pow U => x). trivial. -exists (fun x:pow U => x) (fun x:pow U => x); trivial. Qed. diff --git a/theories/Logic/ChoiceFacts.v b/theories/Logic/ChoiceFacts.v index d8fb5dd4..d2327498 100644 --- a/theories/Logic/ChoiceFacts.v +++ b/theories/Logic/ChoiceFacts.v @@ -1,7 +1,7 @@ (* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* FunctionalChoice_on A B). + (forall A B : Type, inhabited B -> FunctionalChoice_on A B). Notation FunctionalRelReification := - (forall A B, FunctionalRelReification_on A B). + (forall A B : Type, FunctionalRelReification_on A B). Notation GuardedRelationalChoice := - (forall A B, GuardedRelationalChoice_on A B). + (forall A B : Type, GuardedRelationalChoice_on A B). Notation GuardedFunctionalChoice := - (forall A B, GuardedFunctionalChoice_on A B). + (forall A B : Type, GuardedFunctionalChoice_on A B). Notation GuardedFunctionalRelReification := - (forall A B, GuardedFunctionalRelReification_on A B). + (forall A B : Type, GuardedFunctionalRelReification_on A B). Notation OmniscientRelationalChoice := - (forall A B, OmniscientRelationalChoice_on A B). + (forall A B : Type, OmniscientRelationalChoice_on A B). Notation OmniscientFunctionalChoice := - (forall A B, OmniscientFunctionalChoice_on A B). + (forall A B : Type, OmniscientFunctionalChoice_on A B). Notation ConstructiveDefiniteDescription := - (forall A, ConstructiveDefiniteDescription_on A). + (forall A : Type, ConstructiveDefiniteDescription_on A). Notation ConstructiveIndefiniteDescription := - (forall A, ConstructiveIndefiniteDescription_on A). + (forall A : Type, ConstructiveIndefiniteDescription_on A). Notation IotaStatement := - (forall A, IotaStatement_on A). + (forall A : Type, IotaStatement_on A). Notation EpsilonStatement := - (forall A, EpsilonStatement_on A). + (forall A : Type, EpsilonStatement_on A). (** Subclassical schemes *) @@ -292,7 +299,7 @@ Proof. Qed. Lemma funct_choice_imp_rel_choice : - forall A B, FunctionalChoice_on A B -> RelationalChoice_on A B. + 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). @@ -305,7 +312,7 @@ Proof. Qed. Lemma funct_choice_imp_description : - forall A B, FunctionalChoice_on A B -> FunctionalRelReification_on A B. + 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]. @@ -318,10 +325,10 @@ Proof. Qed. Corollary FunChoice_Equiv_RelChoice_and_ParamDefinDescr : - forall A B, FunctionalChoice_on A B <-> + forall A B : Type, FunctionalChoice_on A B <-> RelationalChoice_on A B /\ FunctionalRelReification_on A B. Proof. - intros A B; split. + intros A B. split. intro H; split; [ exact (funct_choice_imp_rel_choice H) | exact (funct_choice_imp_description H) ]. @@ -333,7 +340,7 @@ Qed. (** 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 independance of general premises + formulation in presence either of the independence of general premises or subset types (themselves derivable from subtypes thanks to proof- irrelevance) *) @@ -362,7 +369,7 @@ Proof. Qed. Lemma rel_choice_indep_of_general_premises_imp_guarded_rel_choice : - forall A B, inhabited B -> RelationalChoice_on A B -> + 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. @@ -374,7 +381,7 @@ Proof. Qed. Lemma guarded_rel_choice_imp_rel_choice : - forall A B, GuardedRelationalChoice_on A B -> RelationalChoice_on A B. + 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)). @@ -793,12 +800,13 @@ be applied on the same Type universes on both sides of the first Require Import Setoid. Theorem constructive_definite_descr_excluded_middle : - ConstructiveDefiniteDescription -> + (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). @@ -814,14 +822,13 @@ Corollary fun_reification_descr_computational_excluded_middle_in_prop_context : (forall P:Prop, P \/ ~ P) -> forall C:Prop, ((forall P:Prop, {P} + {~ P}) -> C) -> C. Proof. - intros FunReify EM C H. - apply relative_non_contradiction_of_definite_descr; trivial. - auto using constructive_definite_descr_excluded_middle. + intros FunReify EM C H. intuition auto using + constructive_definite_descr_excluded_middle, + (relative_non_contradiction_of_definite_descr (C:=C)). Qed. (**********************************************************************) (** * Choice => Dependent choice => Countable choice *) - (* The implications below are standard *) Require Import Arith. diff --git a/theories/Logic/Classical.v b/theories/Logic/Classical.v index 6085594b..600db472 100644 --- a/theories/Logic/Classical.v +++ b/theories/Logic/Classical.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* b1) (fun _ => b2) (em A). - Definition b2p b := b1 = b. + 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. @@ -367,16 +367,90 @@ Section Proof_irrelevance_EM_CC. Proof. refine (or_elim _ _ _ _ _ (em (b1 = b2))); intro H. trivial. - apply (paradox B p2b b2p (p2p2 H) p2p1). + apply (NoRetractFromSmallPropositionToProp.paradox B p2b b2p (p2p2 H) p2p1). Qed. End Proof_irrelevance_EM_CC. -(** Remark: 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 - proof-irrelevance. -*) +(** 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 wih 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. + 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. + 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 *) @@ -405,6 +479,23 @@ Section Proof_irrelevance_CCI. 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 diff --git a/theories/Logic/ClassicalUniqueChoice.v b/theories/Logic/ClassicalUniqueChoice.v index 1cdff497..4b0ec15e 100644 --- a/theories/Logic/ClassicalUniqueChoice.v +++ b/theories/Logic/ClassicalUniqueChoice.v @@ -1,7 +1,7 @@ (* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* B)). Qed. -(** The following proof comes from [[ChicliPottierSimpson02]] *) +(** The following proof comes from [[ChicliPottierSimpson02]] *) Require Import Setoid. Theorem classic_set_in_prop_context : @@ -78,7 +78,7 @@ destruct (f P). right. destruct HfP as [[_ Hfalse]| [Hna _]]. discriminate. - assumption. + assumption. Qed. Corollary not_not_classic_set : diff --git a/theories/Logic/Classical_Pred_Set.v b/theories/Logic/Classical_Pred_Set.v deleted file mode 100644 index d634217f..00000000 --- a/theories/Logic/Classical_Pred_Set.v +++ /dev/null @@ -1,48 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* Prop, ~ (forall n:U, P n) -> exists n : U, ~ P n. -Proof (Classical_Pred_Type.not_all_ex_not U). - -Lemma not_all_not_ex : - forall P:U -> Prop, ~ (forall n:U, ~ P n) -> exists n : U, P n. -Proof (Classical_Pred_Type.not_all_not_ex U). - -Lemma not_ex_all_not : - forall P:U -> Prop, ~ (exists n : U, P n) -> forall n:U, ~ P n. -Proof (Classical_Pred_Type.not_ex_all_not U). - -Lemma not_ex_not_all : - forall P:U -> Prop, ~ (exists n : U, ~ P n) -> forall n:U, P n. -Proof (Classical_Pred_Type.not_ex_not_all U). - -Lemma ex_not_not_all : - forall P:U -> Prop, (exists n : U, ~ P n) -> ~ (forall n:U, P n). -Proof (Classical_Pred_Type.ex_not_not_all U). - -Lemma all_not_not_ex : - forall P:U -> Prop, (forall n:U, ~ P n) -> ~ (exists n : U, P n). -Proof (Classical_Pred_Type.all_not_not_ex U). - -End Generic. diff --git a/theories/Logic/Classical_Pred_Type.v b/theories/Logic/Classical_Pred_Type.v index 78eae431..8468ced3 100644 --- a/theories/Logic/Classical_Pred_Type.v +++ b/theories/Logic/Classical_Pred_Type.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* Prop := - | stop : forall n, P n -> before_witness n - | next : forall n, before_witness (S n) -> before_witness n. +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 := @@ -67,9 +67,9 @@ 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 => - match b in before_witness n return ~ P n -> before_witness (S n) with - | stop n p => fun not_p => match (not_p p) with end - | next n b => fun _ => b + match b return ~ P n -> before_witness (S n) with + | stop _ p => fun not_p => match (not_p p) with end + | next _ b => fun _ => b end. Fixpoint linear_search m (b : before_witness m) : {n : nat | P n} := diff --git a/theories/Logic/Decidable.v b/theories/Logic/Decidable.v index 3724d8e2..545f92bd 100644 --- a/theories/Logic/Decidable.v +++ b/theories/Logic/Decidable.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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. *) diff --git a/theories/Logic/Description.v b/theories/Logic/Description.v index 69ed908f..70cc0787 100644 --- a/theories/Logic/Description.v +++ b/theories/Logic/Description.v @@ -1,13 +1,13 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* Prop => exists y : _, Q y) - (fun (Q:bool -> Prop) (y:bool) => Q y)) as (R,(HRsub,HR)). + (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)). @@ -113,23 +113,23 @@ Theorem pred_ext_and_rel_choice_imp_EM : forall P:Prop, P \/ ~ P. Proof. intro P. -(** first we exhibit the choice functional relation R *) +(* 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? *) +(* 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? *) +(* 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 *) +(* 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). @@ -145,7 +145,7 @@ rewrite <- H0''. reflexivity. rewrite Heq. assumption. -(** cases where P is true *) +(* cases where P is true *) left; assumption. left; assumption. @@ -154,7 +154,7 @@ Qed. End PredExt_RelChoice_imp_EM. (**********************************************************************) -(** * B. Proof-Irrel. + Rel. Axiom of Choice -> Excl.-Middle for Equality *) +(** * 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 *) @@ -172,7 +172,7 @@ Variables a1 a2 : A. (** We build the subset [A'] of [A] made of [a1] and [a2] *) -Definition A' := sigT (fun x => x=a1 \/ x=a2). +Definition A' := @sigT A (fun x => x=a1 \/ x=a2). Definition a1':A'. exists a1 ; auto. diff --git a/theories/Logic/Epsilon.v b/theories/Logic/Epsilon.v index e4663604..fe17cde4 100644 --- a/theories/Logic/Epsilon.v +++ b/theories/Logic/Epsilon.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* Prop) (p q:U) (x:P p) (y:P q), + 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. @@ -149,24 +151,25 @@ Proof. Qed. Lemma eq_dep_eq_sig : - forall (U:Prop) (P:U -> Prop) (p q:U) (x:P p) (y:P q), + 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:Prop) (P:U -> Prop) (p q:U) (x:P p) (y:P q), + 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 *) +(** Dependent equality is equivalent tco a dependent pair of equalities *) Set Implicit Arguments. -Lemma eq_sigT_sig_eq : forall X P (x1 x2:X) H1 H2, existT P x1 H1 = existT P x2 H2 <-> {H:x1=x2 | rew H in H1 = H2}. +Lemma eq_sigT_sig_eq : forall X P (x1 x2:X) H1 H2, existT P x1 H1 = existT P x2 H2 <-> + {H:x1=x2 | rew H in H1 = H2}. Proof. intros; split; intro H. - change x2 with (projT1 (existT P x2 H2)). @@ -234,82 +237,113 @@ Section Equivalences. (** Invariance by Substitution of Reflexive Equality Proofs *) - Definition Eq_rect_eq := - forall (p:U) (Q:U -> Type) (x:Q p) (h:p = p), x = eq_rect p Q x p h. + 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 := - forall (P:U->Type) (p:U) (x y:P p), eq_dep p x p y -> x = y. + 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_ := - forall (x y:U) (p1 p2:x = y), p1 = p2. + 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_ := - forall (x:U) (p:x = x), p = eq_refl x. + 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_ := - forall (x:U) (P:x = x -> Prop), P (eq_refl x) -> forall p:x = x, P p. + 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__eq_dep1_eq : - Eq_rect_eq -> forall (P:U->Type) (p:U) (x y:P p), eq_dep1 p x p y -> x = y. + 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__eq_dep_eq : Eq_rect_eq -> Eq_dep_eq. + 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. - apply (eq_rect_eq__eq_dep1_eq eq_rect_eq); apply eq_dep_dep1; trivial. + 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__UIP : Eq_dep_eq -> UIP_. + 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. - intros; apply eq_dep_eq with (P := fun y => x = y). - elim p2 using eq_indd. elim p1 using eq_indd. + intros; 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__UIP_refl : UIP_ -> UIP_refl_. + Lemma UIP_on__UIP_refl_on (x : U) : + UIP_on_ x x eq_refl -> UIP_refl_on_ x. Proof. - intro UIP; red; intros; apply UIP. + 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__Streicher_K : UIP_refl_ -> Streicher_K_. + 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__eq_rect_eq : Streicher_K_ -> Eq_rect_eq. + 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 with (p := h). + 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]): @@ -317,7 +351,7 @@ Section Equivalences. [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 to prove UIP and Streicher's K what + 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]. @@ -325,22 +359,55 @@ Section Equivalences. 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 with (eq_refl x). apply UIP_refl. + symmetry. 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 := - forall (P:U -> Type) (p:U) (x y:P p), existT P p x = existT P p y -> x = y. - Lemma eq_dep_eq__inj_pair2 : Eq_dep_eq U -> Inj_dep_pair. + 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. @@ -412,5 +479,27 @@ 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/theories/Logic/Eqdep_dec.v b/theories/Logic/Eqdep_dec.v index 015c7a5f..65011e8e 100644 --- a/theories/Logic/Eqdep_dec.v +++ b/theories/Logic/Eqdep_dec.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* y. - 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 x y with + match eq_dec y with | or_introl eqxy => eqxy | or_intror neqxy => False_ind _ (neqxy u) end. @@ -62,17 +63,17 @@ Section EqdepDec. Let nu_constant : forall (y:A) (u v:x = y), nu u = nu v. intros. unfold nu. - case (eq_dec x y); intros. + destruct (eq_dec y) as [Heq|Hneq]. reflexivity. - case n; trivial. + case Hneq; trivial. Qed. Let nu_inv (y:A) (v:x = y) : x = y := comp (nu (eq_refl x)) v. - Remark nu_left_inv : forall (y:A) (u:x = y), nu_inv (nu u) = u. + Remark nu_left_inv_on : forall (y:A) (u:x = y), nu_inv (nu u) = u. Proof. intros. case u; unfold nu_inv. @@ -80,20 +81,20 @@ Section EqdepDec. Qed. - Theorem eq_proofs_unicity : forall (y:A) (p1 p2:x = y), p1 = p2. + Theorem eq_proofs_unicity_on : forall (y:A) (p1 p2:x = y), p1 = p2. Proof. intros. - elim nu_left_inv with (u := p1). - elim nu_left_inv with (u := p2). + elim nu_left_inv_on with (u := p1). + elim nu_left_inv_on with (u := p2). elim nu_constant with y p1 p2. reflexivity. Qed. - Theorem K_dec : + Theorem K_dec_on : forall P:x = x -> Prop, P (eq_refl x) -> forall p:x = x, P p. Proof. intros. - elim eq_proofs_unicity with x (eq_refl x) p. + elim eq_proofs_unicity_on with x (eq_refl x) p. trivial. Qed. @@ -101,27 +102,26 @@ Section EqdepDec. Let proj (P:A -> Prop) (exP:ex P) (def:P x) : P x := match exP with - | ex_intro x' prf => - match eq_dec x' x with - | or_introl eqprf => eq_ind x' P prf x eqprf + | 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 : + Theorem inj_right_pair_on : forall (P:A -> Prop) (y y':P x), ex_intro P x y = ex_intro P x y' -> y = y'. Proof. intros. cut (proj (ex_intro P x y) y = proj (ex_intro P x y') y). simpl. - case (eq_dec x x). - intro e. - elim e using K_dec; trivial. + destruct (eq_dec x) as [Heq|Hneq]. + elim Heq using K_dec_on; trivial. intros. - case n; trivial. + case Hneq; trivial. case H. reflexivity. @@ -129,6 +129,28 @@ Section EqdepDec. 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 *) @@ -181,7 +203,7 @@ Unset Implicit Arguments. Module Type DecidableType. - Parameter U:Type. + Monomorphic Parameter U:Type. Axiom eq_dec : forall x y:U, {x = y} + {x <> y}. End DecidableType. @@ -249,7 +271,7 @@ End DecidableEqDep. Module Type DecidableSet. - Parameter U:Type. + Parameter U:Set. Axiom eq_dec : forall x y:U, {x = y} + {x <> y}. End DecidableSet. @@ -272,23 +294,23 @@ Module DecidableEqDepSet (M:DecidableSet). 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 N.eq_dep_eq. + 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 N.UIP. + 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 N.UIP_refl. + 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 N.Streicher_K. + Proof (K_dec_type eq_dec). (** Proof-irrelevance on subsets of decidable sets *) @@ -318,7 +340,53 @@ Proof. intros A eq_dec. apply eq_dep_eq__inj_pair2. apply eq_rect_eq__eq_dep_eq. - unfold Eq_rect_eq. - apply eq_rect_eq_dec. + unfold Eq_rect_eq, Eq_rect_eq_on. + intros; apply eq_rect_eq_dec. apply eq_dec. Qed. + + (** 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. + - 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. diff --git a/theories/Logic/ExtensionalityFacts.v b/theories/Logic/ExtensionalityFacts.v index 27fb147f..61ee9eb9 100644 --- a/theories/Logic/ExtensionalityFacts.v +++ b/theories/Logic/ExtensionalityFacts.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* A] with finite [A], + f injective <-> f bijective <-> f surjective. *) + +Require Import List 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 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. *) + +Definition Listing {A:Type} (l:list A) := NoDup l /\ Full l. +Definition Finite' (A:Type) := exists (l:list A), Listing l. + +Lemma Finite_alt A (d:decidable_eq A) : Finite A <-> Finite' A. +Proof. + split. + - intros (l,F). destruct (uniquify d l) as (l' & N & I). + exists l'. split; trivial. + intros x. apply I, F. + - intros (l & _ & F). now exists l. +Qed. + +(** 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_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. + 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. 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. + - apply (Finite_alt d) in F. destruct F as (l,L). + 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 map_length. + - 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 map_length. + - 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. + - 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. + - exists nil. + red;inversion a. + - 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 (Lt.le_not_lt _ _ 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/theories/Logic/FunctionalExtensionality.v b/theories/Logic/FunctionalExtensionality.v index 7d7792d5..eb50a3aa 100644 --- a/theories/Logic/FunctionalExtensionality.v +++ b/theories/Logic/FunctionalExtensionality.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* forall x, f x = g x. +Proof. +intros A B f g <- H; reflexivity. +Qed. + (** Statements of functional extensionality for simple and dependent functions. *) Axiom functional_extensionality_dep : forall {A} {B : A -> Type}, @@ -31,13 +37,35 @@ 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. + (** 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)) ; intro x + apply (@functional_extensionality_dep _ _ X Y) || + apply forall_extensionalityP || + apply forall_extensionalityS || + apply forall_extensionality) ; intro x end. (** Eta expansion follows from extensionality. *) diff --git a/theories/Logic/Hurkens.v b/theories/Logic/Hurkens.v index 95e98038..ede51f57 100644 --- a/theories/Logic/Hurkens.v +++ b/theories/Logic/Hurkens.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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: - - [Hurkens] A. J. Hurkens, "A simplification of Girard's paradox", + - [[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. - - [Geuvers] "Inconsistency of Classical Logic in Type Theory", 2001 - (see http://www.cs.kun.nl/~herman/note.ps.gz). + - [[Geuvers01]] H. Geuvers, "Inconsistency of Classical Logic in Type + Theory", 2001, revised 2007 + (see {{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 ident, 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 ident, right associativity). +Reserved Notation "f '·₁' x" (at level 5, left associativity). +Reserved Notation "'∀₂' A , F" (at level 200, A ident, right associativity). +Reserved Notation "'λ₂' x , u" (at level 200, x ident, right associativity). +Reserved Notation "f '·₁' [ A ]" (at level 5, left associativity). +Reserved Notation "'∀₀' x : A , B" (at level 200, x ident, 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 ident, right associativity). +Reserved Notation "f '·₀' x" (at level 5, left associativity). +Reserved Notation "'∀₀¹' A : U , F" (at level 200, A ident, right associativity). +Reserved Notation "'λ₀¹' x , u" (at level 200, x ident, right associativity). +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 := + refine ((fun h => _) (paradox _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ ));cycle 1. + +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. easy. + + cbn. exact (fun F => u22u1 (forall x, F x)). + + cbn. exact (fun _ x => u22u1_unit _ x). + + cbn. exact (fun _ x => u22u1_counit _ x). + + cbn. intros **. now rewrite u22u1_coherent. + (** 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. intros * x. exact (u12u0_unit _ x). + + cbn. intros * x. exact (u12u0_counit _ x). + + cbn. exact (fun u F => u12u0 (forall x:u, u02u1 (F x))). + + cbn. intros * x. exact (u12u0_unit _ x). + + cbn. intros * x. exact (u12u0_counit _ x). + + cbn. exact (u12u0 F). + + cbn in h. + exact (u12u0_counit _ h). +Qed. + +End Paradox. + +End NoRetractToImpredicativeUniverse. + +(** * 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. + +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). -Variable B : Prop. - -Definition V := forall A:Prop, ((A -> bool) -> A -> bool) -> A -> bool. -Definition U := V -> bool. -Definition sb (z:V) : V := fun A r a => r (z A r) a. -Definition le (i:U -> bool) (x:U) : bool := - x (fun A r a => i (fun v => sb v A r a)). -Definition induct (i:U -> bool) : Prop := - forall x:U, b2p (le i x) -> b2p (i x). -Definition WF : U := fun z => p2b (induct (z U le)). -Definition I (x:U) : Prop := - (forall i:U -> bool, b2p (le i x) -> b2p (i (fun v => sb v U le x))) -> B. - -Lemma Omega : forall i:U -> bool, induct i -> b2p (i WF). + +(** ** Paradox *) + +Theorem paradox : forall B:Prop, B. Proof. -intros i y. -apply y. -unfold le, WF, induct. -apply p2p2. -intros x H0. -apply y. -exact H0. + intros B. + pose proof + (NoRetractToImpredicativeUniverse.paradox@{Type Prop}) as P. + refine (P _ _ _ _ _ _ _ _ _ _);clear P. + + exact bool. + + exact (fun x => forall P:Prop, (x->P)->P). + + cbn. exact (fun _ x P k => k x). + + cbn. intros F P x. + apply P. + intros f. + exact (f x). + + cbn. easy. + + exact b2p. + + exact p2b. + + exact p2p2. + + exact p2p1. Qed. -Lemma lemma1 : induct (fun u => p2b (I u)). +End Paradox. + +End NoRetractFromSmallPropositionToProp. + +(** * 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 unit : forall A:Prop, A -> M A. +Hypothesis join : forall A:Prop, M (M A) -> M A. +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. -unfold induct. -intros x p. -apply (p2p2 (I x)). -intro q. -apply (p2p1 (I (fun v:V => sb v U le x)) (q (fun u => p2b (I u)) p)). -intro i. -apply q with (i := fun y => i (fun v:V => sb v U le y)). + eauto. Qed. -Lemma lemma2 : (forall i:U -> bool, induct i -> b2p (i WF)) -> B. +(** ** 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. -intro x. -apply (p2p1 (I WF) (x (fun u => p2b (I u)) lemma1)). -intros i H0. -apply (x (fun y => i (fun v => sb v U le y))). -apply (p2p1 _ H0). + intros [P m]. cbn. + exact m. Qed. -Theorem paradox : B. +Definition Forall {A:Type} (P:A->MProp) : MProp. +Proof. + 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. -exact (lemma2 Omega). + intros B. + Generic.paradox h. + (** Large universe *) + + exact MProp. + + exact El. + + exact (fun _ => Forall). + + cbn. exact (fun _ _ f => f). + + cbn. exact (fun _ _ f => f). + + cbn. easy. + + exact Forall. + + cbn. exact (fun _ f => f). + + cbn. exact (fun _ f => f). + + cbn. easy. + (** Small universe *) + + exact bool. + + exact (fun b => El (b2p b)). + + cbn. exact (fun _ F => p2b (Forall (fun x => b2p (F x)))). + + cbn. auto. + + cbn. intros * f. + apply p2p1 in f. cbn in f. + exact f. + + exact (fun _ F => p2b (Forall (fun x => b2p (F x)))). + + cbn. auto. + + cbn. intros * f. + apply p2p1 in f. cbn in f. + exact f. + + apply p2b. + exact B. + + cbn in h. auto. 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. + refine ((fun h => _) (NoRetractToModalProposition.paradox _ _ _ _ _ _ _ _ _ _));cycle 1. + + exact (fun P => ~~P). + + cbn. auto. + + cbn. auto. + + cbn. auto. + + exact bool. + + exact p2b. + + exact b2p. + + auto. + + auto. + + exact B. + + exact h. +Qed. + +End Paradox. + +End NoRetractToNegativeProp. + +(** * Large universes are no 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). + + cbn. easy. + + 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. + + cbn. + intros F f A. + destruct (up_down A). cbn. + reflexivity. + + exact Prop. + + cbn. exact (fun X => X). + + cbn. exact (fun A P => forall x:A, P x). + + cbn. exact (fun _ _ x => x). + + cbn. exact (fun _ _ x => x). + + cbn. exact (fun A P => forall x:A, P x). + + cbn. exact (fun _ _ x => x). + + cbn. exact (fun _ _ x => x). + + cbn. exact P. + + exact h. +Qed. + +End Paradox. + +End NoRetractFromTypeToProp. + +(** * [A<>Type] *) + +(** No Coq universe can be equal to one of its elements. *) + +Module TypeNeqSmallType. + +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). + + cbn. easy. + + 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. + + cbn. intros ? f X. + destruct (up_down X). cbn. + reflexivity. + (** 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. intros ? ? f. + rewrite up_down. + exact f. + + cbn. intros ? ? f. + rewrite up_down in f. + exact f. + + cbn. exact (fun _ F => down (forall x, up (F x))). + + cbn. intros ? ? f. + rewrite up_down. + exact f. + + cbn. intros ? ? f. + rewrite up_down in f. + exact f. + + cbn. exact (down False). + + rewrite up_down in p. + exact p. +Qed. + +End Paradox. + +End TypeNeqSmallType. + +(** * [Prop<>Type]. *) + +(** Special case of [TypeNeqSmallType]. *) + +Module PropNeqType. + +Theorem paradox : Prop <> Type. +Proof. + intros h. + refine (TypeNeqSmallType.paradox _ _). + + exact Prop. + + easy. +Qed. + +End PropNeqType. + +(* end show *) diff --git a/theories/Logic/IndefiniteDescription.v b/theories/Logic/IndefiniteDescription.v index 198b7292..9875710e 100644 --- a/theories/Logic/IndefiniteDescription.v +++ b/theories/Logic/IndefiniteDescription.v @@ -1,13 +1,13 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* JMeq y x. -Proof. -destruct 1; trivial. +Proof. +intros; destruct H; trivial. Qed. Hint Immediate JMeq_sym. diff --git a/theories/Logic/ProofIrrelevance.v b/theories/Logic/ProofIrrelevance.v index 5cd58419..eb00dedd 100644 --- a/theories/Logic/ProofIrrelevance.v +++ b/theories/Logic/ProofIrrelevance.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* Prop) (x y:U) (p:P x) (q:P y), + 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. diff --git a/theories/Logic/RelationalChoice.v b/theories/Logic/RelationalChoice.v index 1f700c6c..61598130 100644 --- a/theories/Logic/RelationalChoice.v +++ b/theories/Logic/RelationalChoice.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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 <-/le_n_0_eq. 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 le_0_n. + + eapply next_left. + * apply (HPl' 0), le_0_n. + * 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), le_0_n. + * 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 Le Lt. + +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 le_n_0_eq in Hle as <-. apply here. assumption. +- destruct n. + + apply here. assumption. + + apply next_left; auto using le_S_n. +- destruct n. + + apply here. assumption. + + apply next_right; auto using le_S_n. +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 le_Sn_0 in Hle; contradiction|]. + apply le_S_n 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 lt_le_weak, 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/theories/Logic/WeakFan.v b/theories/Logic/WeakFan.v new file mode 100644 index 00000000..49cc12b8 --- /dev/null +++ b/theories/Logic/WeakFan.v @@ -0,0 +1,105 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* 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 (X P)) as (l,(Hd,HP)). +assert (inductively_barred P l) by (apply (now P l), HP). +clear Hbar HP. +induction l. +- assumption. +- destruct Hd as (Hd,HX). + apply (IHl Hd). clear IHl. + destruct a; unfold X in HX; simpl in HX. + + apply propagate. + * apply H. + * destruct HX as (l',(Hl,(HY,Ht))); firstorder. + apply Y_approx in Hd. rewrite <- (Y_unique P l' l Hl); trivial. + + destruct HX. exists l. split; auto using Y_approx. +Qed. diff --git a/theories/Logic/vo.itarget b/theories/Logic/vo.itarget index 46046897..32359739 100644 --- a/theories/Logic/vo.itarget +++ b/theories/Logic/vo.itarget @@ -4,10 +4,8 @@ ClassicalChoice.vo ClassicalDescription.vo ClassicalEpsilon.vo ClassicalFacts.vo -Classical_Pred_Set.vo Classical_Pred_Type.vo Classical_Prop.vo -Classical_Type.vo ClassicalUniqueChoice.vo Classical.vo ConstructiveEpsilon.vo @@ -18,7 +16,10 @@ Epsilon.vo Eqdep_dec.vo EqdepFacts.vo Eqdep.vo +WeakFan.vo +WKL.vo FunctionalExtensionality.vo +ExtensionalityFacts.vo Hurkens.vo IndefiniteDescription.vo JMeq.vo @@ -26,3 +27,4 @@ ProofIrrelevanceFacts.vo ProofIrrelevance.vo RelationalChoice.vo SetIsType.vo +FinFun.vo \ No newline at end of file diff --git a/theories/MSets/MSetAVL.v b/theories/MSets/MSetAVL.v index db12ee31..e1fc454a 100644 --- a/theories/MSets/MSetAVL.v +++ b/theories/MSets/MSetAVL.v @@ -38,7 +38,6 @@ Unset Strict Implicit. (* for nicer extraction, we create inductive principles only when needed *) Local Unset Elimination Schemes. -Local Unset Case Analysis Schemes. (** * Ops : the pure functions *) @@ -307,13 +306,13 @@ Include MSetGenTree.Props X I. Local Hint Immediate MX.eq_sym. Local Hint Unfold In lt_tree gt_tree Ok. Local Hint Constructors InT bst. -Local Hint Resolve MX.eq_refl MX.eq_trans MX.lt_trans @ok. +Local Hint Resolve MX.eq_refl MX.eq_trans MX.lt_trans ok. Local Hint Resolve lt_leaf gt_leaf lt_tree_node gt_tree_node. Local Hint Resolve lt_tree_not_in lt_tree_trans gt_tree_not_in gt_tree_trans. Local Hint Resolve elements_spec2. (* Sometimes functional induction will expose too much of - a tree structure. The following tactic allows to factor back + 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 ? *) diff --git a/theories/MSets/MSetDecide.v b/theories/MSets/MSetDecide.v index eefd2951..f2555791 100644 --- a/theories/MSets/MSetDecide.v +++ b/theories/MSets/MSetDecide.v @@ -15,7 +15,7 @@ (** This file implements a decision procedure for a certain class of propositions involving finite sets. *) -Require Import Decidable DecidableTypeEx MSetFacts. +Require Import Decidable Setoid DecidableTypeEx MSetFacts. (** First, a version for Weak Sets in functorial presentation *) @@ -115,8 +115,8 @@ the above form: not affect the namespace if you import the enclosing module [Decide]. *) Module MSetLogicalFacts. - Require Export Decidable. - Require Export Setoid. + Export Decidable. + Export Setoid. (** ** Lemmas and Tactics About Decidable Propositions *) diff --git a/theories/MSets/MSetEqProperties.v b/theories/MSets/MSetEqProperties.v index 4f0d93fb..ae20edc8 100644 --- a/theories/MSets/MSetEqProperties.v +++ b/theories/MSets/MSetEqProperties.v @@ -819,8 +819,7 @@ Proof. intros. rewrite for_all_exists in H; auto. rewrite negb_true_iff in H. -elim (@for_all_mem_4 (fun x =>negb (f x)) Comp' s);intros;auto. -elim p;intros. +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. @@ -856,7 +855,7 @@ 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; auto with *). +intros. do 3 (rewrite fold_add; auto with *). do 3 rewrite fold_empty;auto. Qed. diff --git a/theories/MSets/MSetGenTree.v b/theories/MSets/MSetGenTree.v index 704ff31b..154c2384 100644 --- a/theories/MSets/MSetGenTree.v +++ b/theories/MSets/MSetGenTree.v @@ -27,14 +27,13 @@ - min_elt max_elt choose *) -Require Import Orders OrdersFacts MSetInterface NPeano. +Require Import Orders OrdersFacts MSetInterface PeanoNat. Local Open Scope list_scope. Local Open Scope lazy_bool_scope. (* For nicer extraction, we create induction principles only when needed *) Local Unset Elimination Schemes. -Local Unset Case Analysis Schemes. Module Type InfoTyp. Parameter t : Set. @@ -341,7 +340,7 @@ Module Import MX := OrderedTypeFacts X. 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. +Local Hint Resolve MX.eq_refl MX.eq_trans MX.lt_trans ok. Local Hint Immediate MX.eq_sym. Local Hint Unfold In lt_tree gt_tree. Local Hint Constructors InT bst. @@ -378,7 +377,7 @@ Ltac invtree f := Ltac inv := inv_ok; invtree InT. -Ltac intuition_in := repeat progress (intuition; inv). +Ltac intuition_in := repeat (intuition; inv). (** Helper tactic concerning order of elements. *) @@ -963,13 +962,16 @@ 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. + 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. + Instance lt_strorder : StrictOrder lt. Proof. split. @@ -1017,7 +1019,7 @@ 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; simpl. now rewrite elements_node, app_ass. + intros. now rewrite elements_node, app_ass. Qed. Lemma cons_1 : forall s e, @@ -1051,7 +1053,7 @@ 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]; simpl; intros; auto. + induction s1 as [|c1 l1 Hl1 x1 r1 Hr1]; intros; auto. rewrite elements_node, app_ass; simpl. apply Hl1; auto. clear e2. intros [|x2 r2 e2]. simpl; auto. @@ -1063,9 +1065,9 @@ Lemma compare_Cmp : forall s1 s2, Cmp (compare s1 s2) (elements s1) (elements s2). Proof. intros; unfold compare. - rewrite (app_nil_end (elements s1)). + rewrite <- (app_nil_r (elements s1)). replace (elements s2) with (flatten_e (cons s2 End)) by - (rewrite cons_1; simpl; rewrite <- app_nil_end; auto). + (rewrite cons_1; simpl; rewrite app_nil_r; auto). apply compare_cont_Cmp; auto. intros. apply compare_end_Cmp; auto. @@ -1129,14 +1131,14 @@ Proof. Qed. Lemma maxdepth_log_cardinal s : s <> Leaf -> - log2 (cardinal s) < maxdepth s. + Nat.log2 (cardinal s) < maxdepth s. Proof. intros H. apply Nat.log2_lt_pow2. destruct s; simpl; intuition. apply maxdepth_cardinal. Qed. -Lemma mindepth_log_cardinal s : mindepth s <= log2 (S (cardinal s)). +Lemma mindepth_log_cardinal s : mindepth s <= Nat.log2 (S (cardinal s)). Proof. apply Nat.log2_le_pow2. auto with arith. apply mindepth_cardinal. diff --git a/theories/MSets/MSetInterface.v b/theories/MSets/MSetInterface.v index 6778deff..bd881168 100644 --- a/theories/MSets/MSetInterface.v +++ b/theories/MSets/MSetInterface.v @@ -431,7 +431,6 @@ Module WRaw2SetsOn (E:DecidableType)(M:WRawSets E) <: WSetsOn E. (** We avoid creating induction principles for the Record *) Local Unset Elimination Schemes. - Local Unset Case Analysis Schemes. Definition elt := E.t. diff --git a/theories/MSets/MSetList.v b/theories/MSets/MSetList.v index d9b1fd9b..fb0d1ad9 100644 --- a/theories/MSets/MSetList.v +++ b/theories/MSets/MSetList.v @@ -56,7 +56,7 @@ Module Ops (X:OrderedType) <: WOps X. Definition singleton (x : elt) := x :: nil. - Fixpoint remove x s := + Fixpoint remove x s : t := match s with | nil => nil | y :: l => @@ -228,16 +228,14 @@ Module MakeRaw (X: OrderedType) <: RawSets X. Notation Inf := (lelistA X.lt). Notation In := (InA X.eq). - (* TODO: modify proofs in order to avoid these hints *) - Hint Resolve (@Equivalence_Reflexive _ _ X.eq_equiv). - Hint Immediate (@Equivalence_Symmetric _ _ X.eq_equiv). - Hint Resolve (@Equivalence_Transitive _ _ X.eq_equiv). + Existing Instance X.eq_equiv. + Hint Extern 20 => solve [order]. Definition IsOk s := Sort s. Class Ok (s:t) : Prop := ok : Sort s. - Hint Resolve @ok. + Hint Resolve ok. Hint Unfold Ok. Instance Sort_Ok s `(Hs : Sort s) : Ok s := { ok := Hs }. @@ -343,7 +341,6 @@ Module MakeRaw (X: OrderedType) <: RawSets X. induction s; simpl; intros. intuition. inv; auto. elim_compare x a; inv; rewrite !InA_cons, ?IHs; intuition. - left; order. Qed. Lemma remove_inf : @@ -402,8 +399,8 @@ Module MakeRaw (X: OrderedType) <: RawSets X. 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. + 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. @@ -412,7 +409,6 @@ Module MakeRaw (X: OrderedType) <: RawSets X. In x (union s s') <-> In x s \/ In x s'. Proof. induction2; try rewrite ?InA_cons, ?Hrec, ?Hrec'; intuition; inv; auto. - left; order. Qed. Lemma inter_inf : @@ -440,7 +436,6 @@ Module MakeRaw (X: OrderedType) <: RawSets X. Proof. induction2; try rewrite ?InA_cons, ?Hrec, ?Hrec'; intuition; inv; auto; try sort_inf_in; try order. - left; order. Qed. Lemma diff_inf : @@ -477,7 +472,7 @@ Module MakeRaw (X: OrderedType) <: RawSets X. equal s s' = true <-> Equal s s'. Proof. induction s as [ | x s IH]; intros [ | x' s'] Hs Hs'; simpl. - intuition. + 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. @@ -825,7 +820,7 @@ Module MakeRaw (X: OrderedType) <: RawSets X. 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. + induction s as [|x s IH]; intros [|x' s']; simpl; intuition. elim_compare x x'; auto. Qed. diff --git a/theories/MSets/MSetPositive.v b/theories/MSets/MSetPositive.v index e500602f..25a8c162 100644 --- a/theories/MSets/MSetPositive.v +++ b/theories/MSets/MSetPositive.v @@ -19,14 +19,9 @@ Require Import Bool BinPos Orders MSetInterface. Set Implicit Arguments. - Local Open Scope lazy_bool_scope. Local Open Scope positive_scope. - Local Unset Elimination Schemes. -Local Unset Case Analysis Schemes. -Local Unset Boolean Equality Schemes. - (** 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 @@ -98,7 +93,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. Module E:=PositiveOrderedTypeBits. - Definition elt := positive. + Definition elt := positive : Type. Inductive tree := | Leaf : tree @@ -106,9 +101,9 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. Scheme tree_ind := Induction for tree Sort Prop. - Definition t := tree. + Definition t := tree : Type. - Definition empty := Leaf. + Definition empty : t := Leaf. Fixpoint is_empty (m : t) : bool := match m with @@ -116,7 +111,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. | Node l b r => negb b &&& is_empty l &&& is_empty r end. - Fixpoint mem (i : positive) (m : t) : bool := + Fixpoint mem (i : positive) (m : t) {struct m} : bool := match m with | Leaf => false | Node l o r => @@ -147,13 +142,13 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. (** helper function to avoid creating empty trees that are not leaves *) - Definition node l (b: bool) r := + 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) : t := + Fixpoint remove (i : positive) (m : t) {struct m} : t := match m with | Leaf => Leaf | Node l o r => @@ -164,7 +159,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. end end. - Fixpoint union (m m': t) := + Fixpoint union (m m': t) : t := match m with | Leaf => m' | Node l o r => @@ -174,7 +169,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. end end. - Fixpoint inter (m m': t) := + Fixpoint inter (m m': t) : t := match m with | Leaf => Leaf | Node l o r => @@ -184,7 +179,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. end end. - Fixpoint diff (m m': t) := + Fixpoint diff (m m': t) : t := match m with | Leaf => Leaf | Node l o r => @@ -216,7 +211,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. (** reverses [y] and concatenate it with [x] *) - Fixpoint rev_append y x := + Fixpoint rev_append (y x : elt) : elt := match y with | 1 => x | y~1 => rev_append y x~1 @@ -267,14 +262,14 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. end. Definition exists_ m := xexists m 1. - Fixpoint xfilter (m : t) (i : positive) := + 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) := + Fixpoint xpartition (m : t) (i : positive) : t * t := match m with | Leaf => (Leaf,Leaf) | Node l o r => @@ -316,7 +311,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. (** would it be more efficient to use a path like in the above functions ? *) - Fixpoint choose (m: t) := + Fixpoint choose (m: t) : option elt := match m with | Leaf => None | Node l o r => if o then Some 1 else @@ -326,7 +321,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. end end. - Fixpoint min_elt (m: t) := + Fixpoint min_elt (m: t) : option elt := match m with | Leaf => None | Node l o r => @@ -336,7 +331,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. end end. - Fixpoint max_elt (m: t) := + Fixpoint max_elt (m: t) : option elt := match m with | Leaf => None | Node l o r => @@ -414,10 +409,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. case o; trivial. destruct l; trivial. destruct r; trivial. - symmetry. destruct x. - apply mem_Leaf. - apply mem_Leaf. - reflexivity. + destruct x; reflexivity. Qed. Local Opaque node. @@ -427,7 +419,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. Proof. unfold Empty, In. induction s as [|l IHl o r IHr]; simpl. - setoid_rewrite mem_Leaf. firstorder. + firstorder. rewrite <- 2andb_lazy_alt, 2andb_true_iff, IHl, IHr. clear IHl IHr. destruct o; simpl; split. intuition discriminate. @@ -813,7 +805,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. rewrite <- andb_lazy_alt. apply andb_true_iff. Qed. - Lemma filter_spec: forall s x f, compat_bool E.eq f -> + 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. @@ -824,7 +816,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. Proof. unfold For_all, In. intro f. induction s as [|l IHl o r IHr]; intros i; simpl. - setoid_rewrite mem_Leaf. intuition discriminate. + intuition discriminate. rewrite <- 2andb_lazy_alt, <- orb_lazy_alt, 2 andb_true_iff. rewrite IHl, IHr. clear IHl IHr. split. @@ -838,7 +830,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. apply H. assumption. Qed. - Lemma for_all_spec: forall s f, compat_bool E.eq f -> + 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. @@ -849,7 +841,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. Proof. unfold Exists, In. intro f. induction s as [|l IHl o r IHr]; intros i; simpl. - setoid_rewrite mem_Leaf. firstorder. + firstorder. rewrite <- 2orb_lazy_alt, 2orb_true_iff, <- andb_lazy_alt, andb_true_iff. rewrite IHl, IHr. clear IHl IHr. split. @@ -860,7 +852,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. intros [[x|x|] H]; eauto. Qed. - Lemma exists_spec : forall s f, compat_bool E.eq f -> + 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. @@ -876,11 +868,11 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. destruct o; simpl; rewrite IHl, IHr; reflexivity. Qed. - Lemma partition_spec1 : forall s f, compat_bool E.eq f -> + 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 E.eq f -> + 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. @@ -897,7 +889,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. induction s as [|l IHl o r IHr]; simpl. intros. split; intro H. left. assumption. - destruct H as [H|[x [Hx Hx']]]. assumption. elim (empty_spec Hx'). + 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. @@ -1087,7 +1079,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. destruct (min_elt r). injection H. intros <-. clear H. destruct y as [z|z|]. - apply (IHr p z); trivial. + apply (IHr e z); trivial. elim (Hp _ H'). discriminate. discriminate. @@ -1141,7 +1133,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. injection H. intros <-. clear H. destruct y as [z|z|]. elim (Hp _ H'). - apply (IHl p z); trivial. + apply (IHl e z); trivial. discriminate. discriminate. Qed. diff --git a/theories/MSets/MSetRBT.v b/theories/MSets/MSetRBT.v index b838495f..751d4f35 100644 --- a/theories/MSets/MSetRBT.v +++ b/theories/MSets/MSetRBT.v @@ -31,13 +31,12 @@ Additional suggested reading: *) Require MSetGenTree. -Require Import Bool List BinPos Pnat Setoid SetoidList NPeano. +Require Import Bool List BinPos Pnat Setoid SetoidList PeanoNat. Local Open Scope list_scope. (* For nicer extraction, we create induction principles only when needed *) Local Unset Elimination Schemes. -Local Unset Case Analysis Schemes. (** An extra function not (yet?) in MSetInterface.S *) @@ -399,7 +398,7 @@ Definition skip_black t := 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 s2x') s1' s2' (skip_black s2x') + compare_height (skip_black s1x') s1' s2' (skip_black s2x') | _, Leaf, _, Node _ _ _ _ => Lt | Node _ _ _ _, _, Leaf, _ => Gt | Node _ s1x' _ _, Node _ s1' _ _, Node _ s2' _ _, Leaf => @@ -452,7 +451,7 @@ Local Notation Bk := (Node Black). Local Hint Immediate MX.eq_sym. Local Hint Unfold In lt_tree gt_tree Ok. Local Hint Constructors InT bst. -Local Hint Resolve MX.eq_refl MX.eq_trans MX.lt_trans @ok. +Local Hint Resolve MX.eq_refl MX.eq_trans MX.lt_trans ok. Local Hint Resolve lt_leaf gt_leaf lt_tree_node gt_tree_node. Local Hint Resolve lt_tree_not_in lt_tree_trans gt_tree_not_in gt_tree_trans. Local Hint Resolve elements_spec2. @@ -980,7 +979,7 @@ Proof. { transitivity size; trivial. subst. auto with arith. } destruct acc1 as [|x acc1]. { exfalso. revert LE. apply Nat.lt_nge. subst. - rewrite <- app_nil_end, <- elements_cardinal; auto with arith. } + rewrite app_nil_r, <- elements_cardinal; auto with arith. } specialize (Hg acc1). destruct (g acc1) as (t2,acc2). destruct Hg as (Hg1,Hg2). @@ -988,7 +987,7 @@ Proof. rewrite app_length, <- elements_cardinal. simpl. rewrite Nat.add_succ_r, <- Nat.succ_le_mono. apply Nat.add_le_mono_l. } - simpl. rewrite elements_node, app_ass. now subst. + rewrite elements_node, app_ass. now subst. Qed. Lemma treeify_aux_spec n (p:bool) : @@ -1013,7 +1012,7 @@ 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; simpl; trivial. + revert p. induction l; trivial. simpl plength_aux. intros. now rewrite IHl, Pos2Nat.inj_succ, Nat.add_succ_r. Qed. @@ -1059,7 +1058,7 @@ 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]; simpl; trivial. + induction s as [|c l IHl x r IHr]; trivial. intros acc. rewrite elements_node, filter_app. simpl. destruct (f x); now rewrite IHl, IHr, app_ass. @@ -1197,7 +1196,7 @@ Lemma INV_rev l1 l2 acc : Proof. intros. rewrite rev_append_rev. apply SortA_app with X.eq; eauto with *. - intros x y. inA. eapply l1_lt_acc; eauto. + intros x y. inA. eapply @l1_lt_acc; eauto. Qed. (** ** union *) @@ -1567,7 +1566,7 @@ Proof. Qed. Lemma maxdepth_upperbound s : Rbt s -> - maxdepth s <= 2 * log2 (S (cardinal s)). + maxdepth s <= 2 * Nat.log2 (S (cardinal s)). Proof. intros (n,H). eapply Nat.le_trans; [eapply rb_maxdepth; eauto|]. @@ -1582,7 +1581,7 @@ Proof. Qed. Lemma maxdepth_lowerbound s : s<>Leaf -> - log2 (cardinal s) < maxdepth s. + Nat.log2 (cardinal s) < maxdepth s. Proof. apply maxdepth_log_cardinal. Qed. diff --git a/theories/MSets/MSetWeakList.v b/theories/MSets/MSetWeakList.v index fd4114cd..372acd56 100644 --- a/theories/MSets/MSetWeakList.v +++ b/theories/MSets/MSetWeakList.v @@ -56,8 +56,8 @@ Module Ops (X: DecidableType) <: WOps X. if X.eq_dec x y then l else y :: remove x l end. - Definition fold (B : Type) (f : elt -> B -> B) (s : t) (i : B) : B := - fold_left (flip f) s i. + Definition fold (B : Type) (f : elt -> B -> B) : t -> B -> B := + fold_left (flip f). Definition union (s : t) : t -> t := fold add s. @@ -118,16 +118,18 @@ Module MakeRaw (X:DecidableType) <: WRawSets X. Notation In := (InA X.eq). (* TODO: modify proofs in order to avoid these hints *) - Hint Resolve (@Equivalence_Reflexive _ _ X.eq_equiv). - Hint Immediate (@Equivalence_Symmetric _ _ X.eq_equiv). - Hint Resolve (@Equivalence_Transitive _ _ X.eq_equiv). + Let eqr:= (@Equivalence_Reflexive _ _ X.eq_equiv). + Let eqsym:= (@Equivalence_Symmetric _ _ X.eq_equiv). + Let eqtrans:= (@Equivalence_Transitive _ _ X.eq_equiv). + Hint Resolve eqr eqtrans. + Hint Immediate eqsym. Definition IsOk := NoDup. Class Ok (s:t) : Prop := ok : NoDup s. Hint Unfold Ok. - Hint Resolve @ok. + Hint Resolve ok. Instance NoDup_Ok s (nd : NoDup s) : Ok s := { ok := nd }. @@ -215,10 +217,10 @@ Module MakeRaw (X:DecidableType) <: WRawSets X. Proof. induction s; simpl; intros. intuition; inv; auto. - destruct X.eq_dec; inv; rewrite !InA_cons, ?IHs; intuition. + 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 n. eauto. + elim Hnot. eauto. Qed. Global Instance remove_ok s x `(Ok s) : Ok (remove x s). diff --git a/theories/NArith/BinNat.v b/theories/NArith/BinNat.v index 1023924e..641ec02f 100644 --- a/theories/NArith/BinNat.v +++ b/theories/NArith/BinNat.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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 }. @@ -138,6 +152,50 @@ 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). + +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. + +Definition 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). @@ -262,69 +320,30 @@ Qed. Include BoolOrderFacts. -(** We regroup here some results used for proving the correctness - of more advanced functions. These results will also be provided - by the generic functor of properties about natural numbers - instantiated at the end of the file. *) - -Module Import Private_BootStrap. - -Theorem add_0_r n : n + 0 = n. -Proof. -now destruct n. -Qed. - -Theorem add_comm n m : n + m = m + n. -Proof. -destruct n, m; simpl; try reflexivity. simpl. f_equal. apply Pos.add_comm. -Qed. - -Theorem add_assoc n m p : n + (m + p) = n + m + p. -Proof. -destruct n; try reflexivity. -destruct m; try reflexivity. -destruct p; try reflexivity. -simpl. f_equal. apply Pos.add_assoc. -Qed. - -Lemma sub_add n m : n <= m -> m - n + n = m. -Proof. - destruct n as [|p], m as [|q]; simpl; try easy'. intros H. - case Pos.sub_mask_spec; intros; simpl; subst; trivial. - now rewrite Pos.add_comm. - apply Pos.le_nlt in H. elim H. apply Pos.lt_add_r. -Qed. +(** Specification of minimum and maximum *) -Theorem mul_comm n m : n * m = m * n. +Theorem min_l n m : n <= m -> min n m = n. Proof. -destruct n, m; simpl; trivial. f_equal. apply Pos.mul_comm. +unfold min, le. case compare; trivial. now destruct 1. Qed. -Lemma le_0_l n : 0<=n. +Theorem min_r n m : m <= n -> min n m = m. Proof. -now destruct n. +unfold min, le. rewrite compare_antisym. +case compare_spec; trivial. now destruct 2. Qed. -Lemma leb_spec n m : BoolSpec (n<=m) (m max n m = n. Proof. - unfold le, lt, leb. rewrite (compare_antisym n m). - case compare; now constructor. +unfold max, le. rewrite compare_antisym. +case compare_spec; auto. now destruct 2. Qed. -Lemma add_lt_cancel_l n m p : p+n < p+m -> n max n m = m. Proof. - intro H. destruct p. simpl; auto. - destruct n; destruct m. - elim (Pos.lt_irrefl _ H). - red; auto. - rewrite add_0_r in H. simpl in H. - red in H. simpl in H. - elim (Pos.lt_not_add_l _ _ H). - now apply (Pos.add_lt_mono_l p). +unfold max, le. case compare; trivial. now destruct 1. Qed. -End Private_BootStrap. - (** Specification of lt and le. *) Lemma lt_succ_r n m : n < succ m <-> n<=m. @@ -334,6 +353,13 @@ 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. + + (** Properties of [double] and [succ_double] *) Lemma double_spec n : double n = 2 * n. @@ -395,30 +421,6 @@ Proof. Qed. -(** 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. - (** 0 is the least natural number *) Theorem compare_0_r n : (n ?= 0) <> Lt. @@ -560,13 +562,13 @@ Proof. (* a~1 *) destruct pos_div_eucl as (q,r); simpl in *. case leb_spec; intros H; simpl; trivial. - apply add_lt_cancel_l with b. rewrite add_comm, sub_add by 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_cancel_l with b. rewrite add_comm, sub_add by 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 *) @@ -754,7 +756,7 @@ Proof. destruct m. 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_cancel_l with 1. rewrite 2 (add_succ_l 0). simpl. + apply add_lt_mono_l with 1. rewrite 2 (add_succ_l 0). simpl. now rewrite succ_pos_pred. Qed. @@ -833,71 +835,10 @@ Proof. apply pos_ldiff_spec. Qed. -(** Specification of constants *) - -Lemma one_succ : 1 = succ 0. -Proof. reflexivity. Qed. - -Lemma two_succ : 2 = succ 1. -Proof. reflexivity. Qed. - -Definition pred_0 : pred 0 = 0. -Proof. reflexivity. Qed. - -(** 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 := _. - -(** 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). +(** Instantiation of generic properties of advanced functions + (pow, sqrt, log2, div, gcd, ...) *) -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. - -(** Instantiation of generic properties of natural numbers *) - -(** The Bind Scope prevents N to stay associated with abstract_scope. - (TODO FIX) *) - -Include NProp. Bind Scope N_scope with N. -Include UsualMinMaxLogicalProperties <+ UsualMinMaxDecProperties. +Include NExtraProp. (** In generic statements, the predicates [lt] and [le] have been favored, whereas [gt] and [ge] don't even exist in the abstract @@ -946,7 +887,7 @@ Proof. 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 n xO p) in *; clearbody u. + 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)). @@ -970,7 +911,7 @@ Proof. rewrite <- IHn. rewrite testbit_succ_r_div2 by apply le_0_l. f_equal. simpl. rewrite Pos.iter_succ. - now destruct (Pos.iter n xO p). + now destruct (Pos.iter xO p n). apply succ_le_mono. now rewrite succ_pos_pred. Qed. @@ -983,6 +924,8 @@ Qed. End N. +Bind Scope N_scope with N.t N. + (** Exportation of notations *) Infix "+" := N.add : N_scope. diff --git a/theories/NArith/BinNatDef.v b/theories/NArith/BinNatDef.v index 9abf4955..9de2e7e1 100644 --- a/theories/NArith/BinNatDef.v +++ b/theories/NArith/BinNatDef.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* double). +Definition shiftr_nat (a:N) := nat_rect _ a (fun _ => div2). Definition shiftl a n := match a with @@ -337,7 +337,7 @@ Definition shiftl a n := Definition shiftr a n := match n with | 0 => a - | pos p => Pos.iter p div2 a + | pos p => Pos.iter div2 a p end. (** Checking whether a particular bit is set or not *) @@ -375,7 +375,7 @@ Definition of_nat (n:nat) := Definition iter (n:N) {A} (f:A->A) (x:A) : A := match n with | 0 => x - | pos p => Pos.iter p f x + | pos p => Pos.iter f x p end. End N. \ No newline at end of file diff --git a/theories/NArith/NArith.v b/theories/NArith/NArith.v index ff0be4a3..43614543 100644 --- a/theories/NArith/NArith.v +++ b/theories/NArith/NArith.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* N.testbit_nat (N.shiftl_nat a n) m = N.testbit_nat a (m-n). Proof. induction n; intros m H. - now rewrite <- minus_n_O. - destruct m. inversion H. apply le_S_n in H. - simpl. rewrite <- IHn, Nshiftl_nat_S; trivial. - destruct (N.shiftl_nat a n) as [|[p|p|]]; simpl; trivial. + - now rewrite Nat.sub_0_r. + - destruct m. + + inversion H. + + apply le_S_n in H. + simpl. rewrite <- IHn; trivial. + destruct (N.shiftl_nat a n) as [|[p|p|]]; simpl; trivial. Qed. Lemma Nshiftl_nat_spec_low : forall a n m, (m @@ -123,9 +124,10 @@ Proof. induction n; intros m H. inversion H. rewrite Nshiftl_nat_S. destruct m. - destruct (N.shiftl_nat a n); trivial. - specialize (IHn m (lt_S_n _ _ H)). - destruct (N.shiftl_nat a n); trivial. + - destruct (N.shiftl_nat a n); trivial. + - apply Lt.lt_S_n in H. + specialize (IHn m H). + destruct (N.shiftl_nat a n); trivial. Qed. (** A left shift for positive numbers (used in BigN) *) @@ -148,7 +150,7 @@ Lemma Pshiftl_nat_plus : forall n m p, Pos.shiftl_nat p (m + n) = Pos.shiftl_nat (Pos.shiftl_nat p n) m. Proof. induction m; simpl; intros. reflexivity. - rewrite 2 Pshiftl_nat_S. now f_equal. + now f_equal. Qed. (** Semantics of bitwise operations with respect to [N.testbit_nat] *) @@ -446,49 +448,52 @@ Lemma Nless_trans : Nless a a' = true -> Nless a' a'' = true -> Nless a a'' = true. Proof. induction a as [|a IHa|a IHa] using N.binary_ind; intros a' a'' H H0. - case_eq (Nless N0 a'') ; intros Heqn. trivial. - rewrite (N0_less_2 a'' Heqn), (Nless_z a') in H0. discriminate H0. - induction a' as [|a' _|a' _] using N.binary_ind. - rewrite (Nless_z (N.double a)) in H. discriminate H. - rewrite (Nless_def_1 a a') in H. - induction a'' using N.binary_ind. - rewrite (Nless_z (N.double a')) in H0. discriminate H0. - rewrite (Nless_def_1 a' a'') in H0. rewrite (Nless_def_1 a a''). - exact (IHa _ _ H H0). - apply Nless_def_3. - induction a'' as [|a'' _|a'' _] using N.binary_ind. - rewrite (Nless_z (N.succ_double a')) in H0. discriminate H0. - rewrite (Nless_def_4 a' a'') in H0. discriminate H0. - apply Nless_def_3. - induction a' as [|a' _|a' _] using N.binary_ind. - rewrite (Nless_z (N.succ_double a)) in H. discriminate H. - rewrite (Nless_def_4 a a') in H. discriminate H. + - case_eq (Nless N0 a'') ; intros Heqn. + + trivial. + + rewrite (N0_less_2 a'' Heqn), (Nless_z a') in H0. discriminate H0. + - induction a' as [|a' _|a' _] using N.binary_ind. + + rewrite (Nless_z (N.double a)) in H. discriminate H. + + rewrite (Nless_def_1 a a') in H. induction a'' using N.binary_ind. - rewrite (Nless_z (N.succ_double a')) in H0. discriminate H0. - rewrite (Nless_def_4 a' a'') in H0. discriminate H0. - rewrite (Nless_def_2 a' a'') in H0. rewrite (Nless_def_2 a a') in H. - rewrite (Nless_def_2 a a''). exact (IHa _ _ H H0). + * rewrite (Nless_z (N.double a')) in H0. discriminate H0. + * rewrite (Nless_def_1 a' a'') in H0. rewrite (Nless_def_1 a a''). + exact (IHa _ _ H H0). + * apply Nless_def_3. + + induction a'' as [|a'' _|a'' _] using N.binary_ind. + * rewrite (Nless_z (N.succ_double a')) in H0. discriminate H0. + * rewrite (Nless_def_4 a' a'') in H0. discriminate H0. + * apply Nless_def_3. + - induction a' as [|a' _|a' _] using N.binary_ind. + + rewrite (Nless_z (N.succ_double a)) in H. discriminate H. + + rewrite (Nless_def_4 a a') in H. discriminate H. + + induction a'' using N.binary_ind. + * rewrite (Nless_z (N.succ_double a')) in H0. discriminate H0. + * rewrite (Nless_def_4 a' a'') in H0. discriminate H0. + * rewrite (Nless_def_2 a' a'') in H0. rewrite (Nless_def_2 a a') in H. + rewrite (Nless_def_2 a a''). exact (IHa _ _ H H0). Qed. Lemma Nless_total : forall a a', {Nless a a' = true} + {Nless a' a = true} + {a = a'}. Proof. induction a using N.binary_rec; intro a'. - case_eq (Nless N0 a') ; intros Heqb. left. left. auto. - right. rewrite (N0_less_2 a' Heqb). reflexivity. - induction a' as [|a' _|a' _] using N.binary_rec. - case_eq (Nless N0 (N.double a)) ; intros Heqb. left. right. auto. - right. exact (N0_less_2 _ Heqb). - rewrite 2!Nless_def_1. destruct (IHa a') as [ | ->]. - left. assumption. - right. reflexivity. - left. left. apply Nless_def_3. - induction a' as [|a' _|a' _] using N.binary_rec. - left. right. destruct a; reflexivity. - left. right. apply Nless_def_3. - rewrite 2!Nless_def_2. destruct (IHa a') as [ | ->]. - left. assumption. - right. reflexivity. + - case_eq (Nless N0 a') ; intros Heqb. + + left. left. auto. + + right. rewrite (N0_less_2 a' Heqb). reflexivity. + - induction a' as [|a' _|a' _] using N.binary_rec. + + case_eq (Nless N0 (N.double a)) ; intros Heqb. + * left. right. auto. + * right. exact (N0_less_2 _ Heqb). + + rewrite 2!Nless_def_1. destruct (IHa a') as [ | ->]. + * left. assumption. + * right. reflexivity. + + left. left. apply Nless_def_3. + - induction a' as [|a' _|a' _] using N.binary_rec. + + left. right. destruct a; reflexivity. + + left. right. apply Nless_def_3. + + rewrite 2!Nless_def_2. destruct (IHa a') as [ | ->]. + * left. assumption. + * right. reflexivity. Qed. (** Number of digits in a number *) @@ -512,9 +517,9 @@ Definition N2Bv (n:N) : Bvector (N.size_nat n) := Fixpoint Bv2N (n:nat)(bv:Bvector n) : N := match bv with - | Vector.nil => N0 - | Vector.cons false n bv => N.double (Bv2N n bv) - | Vector.cons true n bv => N.succ_double (Bv2N n bv) + | Vector.nil _ => N0 + | Vector.cons _ false n bv => N.double (Bv2N n bv) + | Vector.cons _ true n bv => N.succ_double (Bv2N n bv) end. Lemma Bv2N_N2Bv : forall n, Bv2N _ (N2Bv n) = n. @@ -622,7 +627,7 @@ induction bv; intros. inversion H. destruct p ; simpl. destruct (Bv2N n bv); destruct h; simpl in *; auto. - specialize IHbv with p (lt_S_n _ _ H). + specialize IHbv with p (Lt.lt_S_n _ _ H). simpl in * ; destruct (Bv2N n bv); destruct h; simpl in *; auto. Qed. @@ -641,7 +646,7 @@ Proof. destruct n as [|n]. inversion H. induction n ; destruct p ; unfold Vector.nth_order in *; simpl in * ; auto. -intros H ; destruct (lt_n_O _ (lt_S_n _ _ H)). +intros H ; destruct (Lt.lt_n_O _ (Lt.lt_S_n _ _ H)). Qed. (** Binary bitwise operations are the same in the two worlds. *) diff --git a/theories/NArith/Ndist.v b/theories/NArith/Ndist.v index 0bff1a96..5467f9cb 100644 --- a/theories/NArith/Ndist.v +++ b/theories/NArith/Ndist.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* | ->]. + left. reflexivity. + right. reflexivity. + destruct (Nat.min_dec n n0); [left|right]; assumption. Qed. Lemma ni_le_total : forall d d':natinf, ni_le d d' \/ ni_le d' d. @@ -208,11 +205,7 @@ Qed. Lemma le_ni_le : forall m n:nat, m <= n -> ni_le (ni m) (ni n). Proof. - cut (forall m n:nat, m <= n -> min m n = m). - intros. unfold ni_le, ni_min. rewrite (H m n H0). reflexivity. - simple induction m. trivial. - simple induction n0. intro. inversion H0. - intros. simpl. rewrite (H n1 (le_S_n n n1 H1)). reflexivity. + intros * H. unfold ni_le, ni_min. rewrite (Peano.min_l m n H). reflexivity. Qed. Lemma ni_le_le : forall m n:nat, ni_le (ni m) (ni n) -> m <= n. @@ -298,30 +291,28 @@ Proof. rewrite (ni_min_inf_l (Nplength a')) in H. rewrite (Nplength_infty a' H). simpl. apply ni_le_refl. intros. unfold Nplength at 1. apply Nplength_lb. intros. - cut (forall a'':N, N.lxor (Npos p) a' = a'' -> N.testbit_nat a'' k = false). - intros. apply H1. reflexivity. + enough (forall a'':N, N.lxor (Npos p) a' = a'' -> N.testbit_nat a'' k = false). + { apply H1. reflexivity. } intro a''. case a''. intro. reflexivity. intros. rewrite <- H1. rewrite (Nxor_semantics (Npos p) a' k). rewrite (Nplength_zeros (Npos p) (Pplength p) (eq_refl (Nplength (Npos p))) k H0). - generalize H. case a'. trivial. - intros. cut (N.testbit_nat (Npos p1) k = false). intros. rewrite H3. reflexivity. + destruct a'. trivial. + enough (N.testbit_nat (Npos p1) k = false) as -> by reflexivity. apply Nplength_zeros with (n := Pplength p1). reflexivity. apply (lt_le_trans k (Pplength p) (Pplength p1)). exact H0. - apply ni_le_le. exact H2. + apply ni_le_le. exact H. Qed. Lemma Nplength_ultra : forall a a':N, ni_le (ni_min (Nplength a) (Nplength a')) (Nplength (N.lxor a a')). Proof. - intros. case (ni_le_total (Nplength a) (Nplength a')). intro. - cut (ni_min (Nplength a) (Nplength a') = Nplength a). - intro. rewrite H0. apply Nplength_ultra_1. exact H. + intros. destruct (ni_le_total (Nplength a) (Nplength a')). + enough (ni_min (Nplength a) (Nplength a') = Nplength a) as -> by (apply Nplength_ultra_1; exact H). exact H. - intro. cut (ni_min (Nplength a) (Nplength a') = Nplength a'). - intro. rewrite H0. rewrite N.lxor_comm. apply Nplength_ultra_1. exact H. + enough (ni_min (Nplength a) (Nplength a') = Nplength a') as -> by (rewrite N.lxor_comm; apply Nplength_ultra_1; exact H). rewrite ni_min_comm. exact H. Qed. diff --git a/theories/NArith/Ndiv_def.v b/theories/NArith/Ndiv_def.v index d21361cd..5ae388e3 100644 --- a/theories/NArith/Ndiv_def.v +++ b/theories/NArith/Ndiv_def.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* & Hq). - simpl. apply plus_minus. now rewrite <- Hq, Pos2Nat.inj_add. + - 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) = pred (N.to_nat a). +Lemma inj_pred a : N.to_nat (N.pred a) = Nat.pred (N.to_nat a). Proof. - intros. rewrite pred_of_minus, N.pred_sub. apply inj_sub. + rewrite <- Nat.sub_1_r, N.pred_sub. apply inj_sub. Qed. -Lemma inj_div2 a : N.to_nat (N.div2 a) = div2 (N.to_nat a). +Lemma inj_div2 a : N.to_nat (N.div2 a) = Nat.div2 (N.to_nat a). Proof. destruct a as [|[p|p| ]]; trivial. - simpl N.to_nat. now rewrite Pos2Nat.inj_xI, div2_double_plus_one. - simpl N.to_nat. now rewrite Pos2Nat.inj_xO, div2_double. + - 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 = nat_compare (N.to_nat a) (N.to_nat a'). + (a ?= a')%N = (N.to_nat a ?= N.to_nat a'). Proof. destruct a, a'; simpl; trivial. - now destruct (Pos2Nat.is_succ p) as (n,->). - now destruct (Pos2Nat.is_succ p) as (n,->). - apply Pos2Nat.inj_compare. + - now destruct (Pos2Nat.is_succ p) as (n,->). + - now destruct (Pos2Nat.is_succ p) as (n,->). + - apply Pos2Nat.inj_compare. Qed. Lemma inj_max a a' : - N.to_nat (N.max a a') = max (N.to_nat a) (N.to_nat 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 H; try rewrite H; auto with arith. + 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') = min (N.to_nat a) (N.to_nat 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 H; try rewrite H; auto with arith. + 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. + N.iter a f x = Nat.iter (N.to_nat a) f x. Proof. destruct a as [|a]. trivial. apply Pos2Nat.inj_iter. Qed. @@ -166,7 +171,7 @@ 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 (pred n) = N.pred (N.of_nat n). +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. @@ -178,23 +183,23 @@ 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 (div2 n) = N.div2 (N.of_nat n). +Lemma inj_div2 n : N.of_nat (Nat.div2 n) = N.div2 (N.of_nat n). Proof. nat2N. Qed. Lemma inj_compare n n' : - nat_compare n n' = (N.of_nat n ?= N.of_nat n')%N. + (n ?= n') = (N.of_nat n ?= N.of_nat n')%N. Proof. now rewrite N2Nat.inj_compare, !id. Qed. Lemma inj_min n n' : - N.of_nat (min n n') = N.min (N.of_nat n) (N.of_nat 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 (max n n') = N.max (N.of_nat n) (N.of_nat 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. + Nat.iter n f x = N.iter (N.of_nat n) f x. Proof. now rewrite N2Nat.inj_iter, !id. Qed. End Nat2N. diff --git a/theories/NArith/Nsqrt_def.v b/theories/NArith/Nsqrt_def.v index d43c752d..da7829a9 100644 --- a/theories/NArith/Nsqrt_def.v +++ b/theories/NArith/Nsqrt_def.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* bool; (* square root *) sqrt2 : t -> t -> t * carry t; - sqrt : t -> t }. - + sqrt : t -> t; + (* bitwise operations *) + lor : t -> t -> t; + land : t -> t -> t; + lxor : t -> t -> t }. + Section Specs. Context {t : Type}{ops : Ops t}. @@ -98,10 +102,10 @@ Module ZnZ. Let wB := base digits. Notation "[+| c |]" := - (interp_carry 1 wB to_Z c) (at level 0, x at level 99). + (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, x at level 99). + (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). @@ -199,7 +203,10 @@ Module ZnZ. [||WW x y||] = [|s|] ^ 2 + [+|r|] /\ [+|r|] <= 2 * [|s|]; spec_sqrt : forall x, - [|sqrt x|] ^ 2 <= [|x|] < ([|sqrt x|] + 1) ^ 2 + [|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. @@ -283,7 +290,7 @@ Module ZnZ. intros p Hp. generalize (spec_of_pos p). case (of_pos p); intros n w1; simpl. - case n; simpl Npos; auto with zarith. + 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. diff --git a/theories/Numbers/Cyclic/Abstract/NZCyclic.v b/theories/Numbers/Cyclic/Abstract/NZCyclic.v index d9089e18..8adeda37 100644 --- a/theories/Numbers/Cyclic/Abstract/NZCyclic.v +++ b/theories/Numbers/Cyclic/Abstract/NZCyclic.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* n < wB - 1 -> B n -> B (n + 1). diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleAdd.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleAdd.v index 1b035948..a7c28862 100644 --- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleAdd.v +++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleAdd.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* y + | _, W0 => x + | WW hx lx, WW hy ly => WW (ZnZ.lor hx hy) (ZnZ.lor lx ly) + end. + + Definition land (x y : zn2z t) := + match x, y with + | W0, _ => W0 + | _, W0 => W0 + | WW hx lx, WW hy ly => WW (ZnZ.land hx hy) (ZnZ.land lx ly) + end. + + Definition lxor (x y : zn2z t) := + match x, y with + | W0, _ => y + | _, W0 => x + | WW hx lx, WW hy ly => WW (ZnZ.lxor hx hy) (ZnZ.lxor lx ly) + end. + (* ** Record of operators on 2 words *) Global Instance mk_zn2z_ops : ZnZ.Ops (zn2z t) | 1 := @@ -303,7 +324,10 @@ Section Z_2nZ. pos_mod is_even sqrt2 - sqrt. + sqrt + lor + land + lxor. Global Instance mk_zn2z_ops_karatsuba : ZnZ.Ops (zn2z t) | 2 := ZnZ.MkOps _ww_digits _ww_zdigits @@ -323,10 +347,15 @@ Section Z_2nZ. pos_mod is_even sqrt2 - sqrt. + sqrt + lor + land + lxor. (* Proof *) Context {specs : ZnZ.Specs ops}. + + Create HintDb ZnZ. Hint Resolve ZnZ.spec_to_Z @@ -370,24 +399,24 @@ Section Z_2nZ. ZnZ.spec_sqrt ZnZ.spec_WO ZnZ.spec_OW - ZnZ.spec_WW. - - Ltac wwauto := unfold ww_to_Z; auto. + ZnZ.spec_WW : ZnZ. + + Ltac wwauto := unfold ww_to_Z; eauto with ZnZ. Let wwB := base _ww_digits. Notation "[| x |]" := (to_Z x) (at level 0, x at level 99). Notation "[+| c |]" := - (interp_carry 1 wwB to_Z c) (at level 0, x at level 99). + (interp_carry 1 wwB to_Z c) (at level 0, c at level 99). Notation "[-| c |]" := - (interp_carry (-1) wwB to_Z c) (at level 0, x at level 99). + (interp_carry (-1) wwB to_Z c) (at level 0, c at level 99). Notation "[[ x ]]" := (zn2z_to_Z wwB to_Z x) (at level 0, x at level 99). Let spec_ww_to_Z : forall x, 0 <= [| x |] < wwB. - Proof. refine (spec_ww_to_Z w_digits w_to_Z _);auto. Qed. + Proof. refine (spec_ww_to_Z w_digits w_to_Z _); wwauto. Qed. Let spec_ww_of_pos : forall p, Zpos p = (Z.of_N (fst (ww_of_pos p)))*wwB + [|(snd (ww_of_pos p))|]. @@ -411,15 +440,15 @@ Section Z_2nZ. Proof. reflexivity. Qed. Let spec_ww_1 : [|ww_1|] = 1. - Proof. refine (spec_ww_1 w_0 w_1 w_digits w_to_Z _ _);auto. Qed. + Proof. refine (spec_ww_1 w_0 w_1 w_digits w_to_Z _ _);wwauto. Qed. Let spec_ww_Bm1 : [|ww_Bm1|] = wwB - 1. - Proof. refine (spec_ww_Bm1 w_Bm1 w_digits w_to_Z _);auto. Qed. + Proof. refine (spec_ww_Bm1 w_Bm1 w_digits w_to_Z _);wwauto. Qed. Let spec_ww_compare : forall x y, compare x y = Z.compare [|x|] [|y|]. Proof. - refine (spec_ww_compare w_0 w_digits w_to_Z w_compare _ _ _);auto. + refine (spec_ww_compare w_0 w_digits w_to_Z w_compare _ _ _);wwauto. Qed. Let spec_ww_eq0 : forall x, eq0 x = true -> [|x|] = 0. @@ -428,14 +457,14 @@ Section Z_2nZ. Let spec_ww_opp_c : forall x, [-|opp_c x|] = -[|x|]. Proof. refine(spec_ww_opp_c w_0 w_0 W0 w_opp_c w_opp_carry w_digits w_to_Z _ _ _ _); - auto. + wwauto. Qed. Let spec_ww_opp : forall x, [|opp x|] = (-[|x|]) mod wwB. Proof. refine(spec_ww_opp w_0 w_0 W0 w_opp_c w_opp_carry w_opp w_digits w_to_Z _ _ _ _ _); - auto. + wwauto. Qed. Let spec_ww_opp_carry : forall x, [|opp_carry x|] = wwB - [|x|] - 1. @@ -446,7 +475,7 @@ Section Z_2nZ. Let spec_ww_succ_c : forall x, [+|succ_c x|] = [|x|] + 1. Proof. - refine (spec_ww_succ_c w_0 w_0 ww_1 w_succ_c w_digits w_to_Z _ _ _ _);auto. + refine (spec_ww_succ_c w_0 w_0 ww_1 w_succ_c w_digits w_to_Z _ _ _ _);wwauto. Qed. Let spec_ww_add_c : forall x y, [+|add_c x y|] = [|x|] + [|y|]. @@ -468,7 +497,7 @@ Section Z_2nZ. Let spec_ww_add : forall x y, [|add x y|] = ([|x|] + [|y|]) mod wwB. Proof. - refine (spec_ww_add w_add_c w_add w_add_carry w_digits w_to_Z _ _ _ _);auto. + refine (spec_ww_add w_add_c w_add w_add_carry w_digits w_to_Z _ _ _ _);wwauto. Qed. Let spec_ww_add_carry : forall x y, [|add_carry x y|]=([|x|]+[|y|]+1)mod wwB. @@ -565,7 +594,7 @@ Section Z_2nZ. 0 <= [|r|] < [|b|]. Proof. refine (spec_ww_div21 w_0 w_0W div32 ww_1 compare sub w_digits w_to_Z - _ _ _ _ _ _ _);wwauto. + _ _ _ _ _ _ _);wwauto. Qed. Let spec_add2: forall x y, @@ -581,13 +610,14 @@ Section Z_2nZ. Qed. Let spec_low: forall x, - w_to_Z (low x) = [|x|] mod wB. + w_to_Z (low x) = [|x|] mod wB. intros x; case x; simpl low. - unfold ww_to_Z, w_to_Z, w_0; rewrite ZnZ.spec_0; simpl; auto. + unfold ww_to_Z, w_to_Z, w_0; rewrite ZnZ.spec_0; simpl; wwauto. intros xh xl; simpl. rewrite Z.add_comm; rewrite Z_mod_plus; auto with zarith. rewrite Zmod_small; auto with zarith. - unfold wB, base; auto with zarith. + unfold wB, base; eauto with ZnZ zarith. + unfold wB, base; eauto with ZnZ zarith. Qed. Let spec_ww_digits: @@ -605,7 +635,7 @@ Section Z_2nZ. Proof. refine (spec_ww_head00 w_0 w_0W w_compare w_head0 w_add2 w_zdigits _ww_zdigits - w_to_Z _ _ _ (eq_refl _ww_digits) _ _ _ _); auto. + w_to_Z _ _ _ (eq_refl _ww_digits) _ _ _ _); wwauto. exact ZnZ.spec_head00. exact ZnZ.spec_zdigits. Qed. @@ -688,7 +718,7 @@ refine [|a|] = [|q|] * [|b|] + [|r|] /\ 0 <= [|r|] < [|b|]. Proof. - refine (spec_ww_div w_digits ww_1 compare div_gt w_to_Z _ _ _ _);auto. + refine (spec_ww_div w_digits ww_1 compare div_gt w_to_Z _ _ _ _);wwauto. Qed. Let spec_ww_mod_gt : forall a b, @@ -708,7 +738,7 @@ refine Let spec_ww_mod : forall a b, 0 < [|b|] -> [|mod_ a b|] = [|a|] mod [|b|]. Proof. - refine (spec_ww_mod w_digits W0 compare mod_gt w_to_Z _ _ _);auto. + refine (spec_ww_mod w_digits W0 compare mod_gt w_to_Z _ _ _);wwauto. Qed. Let spec_ww_gcd_gt : forall a b, [|a|] > [|b|] -> @@ -716,7 +746,7 @@ refine Proof. refine (@spec_ww_gcd_gt t w_digits W0 w_to_Z _ w_0 w_0 w_eq0 w_gcd_gt _ww_digits - _ gcd_gt_fix _ _ _ _ gcd_cont _);auto. + _ gcd_gt_fix _ _ _ _ gcd_cont _);wwauto. refine (@spec_ww_gcd_gt_aux t w_digits w_0 w_WW w_0W w_compare w_opp_c w_opp w_opp_carry w_sub_c w_sub w_sub_carry w_gcd_gt w_add_mul_div w_head0 w_div21 div32 _ww_zdigits ww_1 add_mul_div w_zdigits w_to_Z @@ -725,13 +755,13 @@ refine exact ZnZ.spec_zdigits. exact spec_ww_add_mul_div. refine (@spec_gcd_cont t w_digits ww_1 w_to_Z _ _ w_0 w_1 w_compare - _ _);auto. + _ _);wwauto. Qed. Let spec_ww_gcd : forall a b, Zis_gcd [|a|] [|b|] [|gcd a b|]. Proof. refine (@spec_ww_gcd t w_digits W0 compare w_to_Z _ _ w_0 w_0 w_eq0 w_gcd_gt - _ww_digits _ gcd_gt_fix _ _ _ _ gcd_cont _);auto. + _ww_digits _ gcd_gt_fix _ _ _ _ gcd_cont _);wwauto. refine (@spec_ww_gcd_gt_aux t w_digits w_0 w_WW w_0W w_compare w_opp_c w_opp w_opp_carry w_sub_c w_sub w_sub_carry w_gcd_gt w_add_mul_div w_head0 w_div21 div32 _ww_zdigits ww_1 add_mul_div w_zdigits w_to_Z @@ -740,7 +770,7 @@ refine exact ZnZ.spec_zdigits. exact spec_ww_add_mul_div. refine (@spec_gcd_cont t w_digits ww_1 w_to_Z _ _ w_0 w_1 w_compare - _ _);auto. + _ _);wwauto. Qed. Let spec_ww_is_even : forall x, @@ -779,7 +809,7 @@ refine refine (@spec_ww_sqrt t w_is_even w_0 w_1 w_Bm1 w_sub w_add_mul_div w_digits w_zdigits _ww_zdigits w_sqrt2 pred add_mul_div head0 compare - _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _); wwauto. + _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _); wwauto. exact ZnZ.spec_zdigits. exact ZnZ.spec_more_than_1_digit. exact ZnZ.spec_is_even. @@ -787,6 +817,83 @@ refine exact ZnZ.spec_sqrt2. Qed. + Let wB_pos : 0 < wB. + Proof. + unfold wB, base; apply Z.pow_pos_nonneg; auto with zarith. + Qed. + + Hint Transparent ww_to_Z. + + Let ww_testbit_high n x y : Z.pos w_digits <= n -> + Z.testbit [|WW x y|] n = + Z.testbit (ZnZ.to_Z x) (n - Z.pos w_digits). + Proof. + intros Hn. + assert (E : ZnZ.to_Z x = [|WW x y|] / wB). + { simpl. + rewrite Z.div_add_l; eauto with ZnZ zarith. + now rewrite Z.div_small, Z.add_0_r; wwauto. } + rewrite E. + unfold wB, base. rewrite Z.div_pow2_bits. + - f_equal; auto with zarith. + - easy. + - auto with zarith. + Qed. + + Let ww_testbit_low n x y : 0 <= n < Z.pos w_digits -> + Z.testbit [|WW x y|] n = Z.testbit (ZnZ.to_Z y) n. + Proof. + intros (Hn,Hn'). + assert (E : ZnZ.to_Z y = [|WW x y|] mod wB). + { simpl; symmetry. + rewrite Z.add_comm, Z.mod_add; auto with zarith nocore. + apply Z.mod_small; eauto with ZnZ zarith. } + rewrite E. + unfold wB, base. symmetry. apply Z.mod_pow2_bits_low; auto. + Qed. + + Let spec_lor x y : [|lor x y|] = Z.lor [|x|] [|y|]. + Proof. + destruct x as [ |hx lx]. trivial. + destruct y as [ |hy ly]. now rewrite Z.lor_comm. + change ([|WW (ZnZ.lor hx hy) (ZnZ.lor lx ly)|] = + Z.lor [|WW hx lx|] [|WW hy ly|]). + apply Z.bits_inj'; intros n Hn. + rewrite Z.lor_spec. + destruct (Z.le_gt_cases (Z.pos w_digits) n) as [LE|GT]. + - now rewrite !ww_testbit_high, ZnZ.spec_lor, Z.lor_spec. + - rewrite !ww_testbit_low; auto. + now rewrite ZnZ.spec_lor, Z.lor_spec. + Qed. + + Let spec_land x y : [|land x y|] = Z.land [|x|] [|y|]. + Proof. + destruct x as [ |hx lx]. trivial. + destruct y as [ |hy ly]. now rewrite Z.land_comm. + change ([|WW (ZnZ.land hx hy) (ZnZ.land lx ly)|] = + Z.land [|WW hx lx|] [|WW hy ly|]). + apply Z.bits_inj'; intros n Hn. + rewrite Z.land_spec. + destruct (Z.le_gt_cases (Z.pos w_digits) n) as [LE|GT]. + - now rewrite !ww_testbit_high, ZnZ.spec_land, Z.land_spec. + - rewrite !ww_testbit_low; auto. + now rewrite ZnZ.spec_land, Z.land_spec. + Qed. + + Let spec_lxor x y : [|lxor x y|] = Z.lxor [|x|] [|y|]. + Proof. + destruct x as [ |hx lx]. trivial. + destruct y as [ |hy ly]. now rewrite Z.lxor_comm. + change ([|WW (ZnZ.lxor hx hy) (ZnZ.lxor lx ly)|] = + Z.lxor [|WW hx lx|] [|WW hy ly|]). + apply Z.bits_inj'; intros n Hn. + rewrite Z.lxor_spec. + destruct (Z.le_gt_cases (Z.pos w_digits) n) as [LE|GT]. + - now rewrite !ww_testbit_high, ZnZ.spec_lxor, Z.lxor_spec. + - rewrite !ww_testbit_low; auto. + now rewrite ZnZ.spec_lxor, Z.lxor_spec. + Qed. + Global Instance mk_zn2z_specs : ZnZ.Specs mk_zn2z_ops. Proof. apply ZnZ.MkSpecs; auto. @@ -816,6 +923,7 @@ refine End Z_2nZ. + Section MulAdd. Context {t : Type}{ops : ZnZ.Ops t}{specs : ZnZ.Specs ops}. diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleDiv.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleDiv.v index 08f05bbf..cd55f9d8 100644 --- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleDiv.v +++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleDiv.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* w -> w -> w*w. Variable ww_sub_c : zn2z w -> zn2z w -> carry (zn2z w). - Definition w_div32 a1 a2 a3 b1 b2 := - Eval lazy beta iota delta [ww_add_c_cont ww_add] in + Definition w_div32_body a1 a2 a3 b1 b2 := match w_compare a1 b1 with | Lt => let (q,r) := w_div21 a1 a2 b1 in @@ -233,6 +231,10 @@ Section DoubleDiv32. | Gt => (w_0, W0) (* cas absurde *) end. + Definition w_div32 a1 a2 a3 b1 b2 := + Eval lazy beta iota delta [ww_add_c_cont ww_add w_div32_body] in + w_div32_body a1 a2 a3 b1 b2. + (* Proof *) Variable w_digits : positive. @@ -242,14 +244,14 @@ Section DoubleDiv32. Notation wwB := (base (ww_digits w_digits)). Notation "[| x |]" := (w_to_Z x) (at level 0, x at level 99). Notation "[+| c |]" := - (interp_carry 1 wB w_to_Z c) (at level 0, x at level 99). + (interp_carry 1 wB w_to_Z c) (at level 0, c at level 99). Notation "[-| c |]" := - (interp_carry (-1) wB w_to_Z c) (at level 0, x at level 99). + (interp_carry (-1) wB w_to_Z c) (at level 0, c at level 99). Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99). Notation "[-[ c ]]" := (interp_carry (-1) wwB (ww_to_Z w_digits w_to_Z) c) - (at level 0, x at level 99). + (at level 0, c at level 99). Variable spec_w_0 : [|w_0|] = 0. @@ -312,26 +314,8 @@ Section DoubleDiv32. assert (U:= lt_0_wB w_digits); assert (U1:= lt_0_wwB w_digits). Spec_w_to_Z a1;Spec_w_to_Z a2;Spec_w_to_Z a3;Spec_w_to_Z b1;Spec_w_to_Z b2. rewrite wwB_wBwB; rewrite Z.pow_2_r; rewrite Z.mul_assoc;rewrite <- Z.mul_add_distr_r. - change (w_div32 a1 a2 a3 b1 b2) with - match w_compare a1 b1 with - | Lt => - let (q,r) := w_div21 a1 a2 b1 in - match ww_sub_c (w_WW r a3) (w_mul_c q b2) with - | C0 r1 => (q,r1) - | C1 r1 => - let q := w_pred q in - ww_add_c_cont w_WW w_add_c w_add_carry_c - (fun r2=>(w_pred q, ww_add w_add_c w_add w_add_carry r2 (WW b1 b2))) - (fun r2 => (q,r2)) - r1 (WW b1 b2) - end - | Eq => - ww_add_c_cont w_WW w_add_c w_add_carry_c - (fun r => (w_Bm2, ww_add w_add_c w_add w_add_carry r (WW b1 b2))) - (fun r => (w_Bm1,r)) - (WW (w_sub a2 b2) a3) (WW b1 b2) - | Gt => (w_0, W0) (* cas absurde *) - end. + change (w_div32 a1 a2 a3 b1 b2) with (w_div32_body a1 a2 a3 b1 b2). + unfold w_div32_body. rewrite spec_compare. case Z.compare_spec; intro Hcmp. simpl in Hlt. rewrite Hcmp in Hlt;assert ([|a2|] < [|b2|]). omega. @@ -520,7 +504,7 @@ Section DoubleDiv21. Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99). Notation "[-[ c ]]" := (interp_carry (-1) wwB (ww_to_Z w_digits w_to_Z) c) - (at level 0, x at level 99). + (at level 0, c at level 99). Variable spec_w_0 : [|w_0|] = 0. Variable spec_to_Z : forall x, 0 <= [|x|] < wB. @@ -782,7 +766,7 @@ Section DoubleDivGt. Notation wwB := (base (ww_digits w_digits)). Notation "[| x |]" := (w_to_Z x) (at level 0, x at level 99). Notation "[-| c |]" := - (interp_carry (-1) wB w_to_Z c) (at level 0, x at level 99). + (interp_carry (-1) wB w_to_Z c) (at level 0, c at level 99). Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99). diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleDivn1.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleDivn1.v index 8e179ef6..6a1d741e 100644 --- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleDivn1.v +++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleDivn1.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* generalize (spec_split x); case (split x) - end; simpl fst; simpl snd. + end; simpl @fst; simpl @snd. intros w0 w1 Hw0 w2 w3 Hw1. assert (U: wB/4 <= [|w2|]). case (Z.le_gt_cases (wB / 4) [|w2|]); auto; intros H1. @@ -761,7 +761,7 @@ intros x; case x; simpl ww_is_even. auto. split. unfold zn2z_to_Z; rewrite <- Hw1. - unfold ww_to_Z, zn2z_to_Z in H1; rewrite H1. + unfold ww_to_Z, zn2z_to_Z in H1. rewrite H1. rewrite <- Hw0. match goal with |- (?X ^2 + ?Y) * wwB + (?Z * wB + ?T) = ?U => transitivity ((X * wB) ^ 2 + (Y * wB + Z) * wB + T) @@ -1193,7 +1193,7 @@ Qed. rewrite <- wwB_4_wB_4; auto. generalize (@spec_w_sqrt2 w0 w1 V);auto with zarith. case (w_sqrt2 w0 w1); intros w2 c. - simpl ww_to_Z; simpl fst. + simpl ww_to_Z; simpl @fst. case c; unfold interp_carry; autorewrite with rm10. intros w3 (H6, H7); rewrite H6. assert (V1 := spec_to_Z w3);auto with zarith. @@ -1256,7 +1256,7 @@ Qed. generalize (@spec_w_sqrt2 w0 w1 V);auto with zarith. case (w_sqrt2 w0 w1); intros w2 c. case (spec_to_Z w2); intros HH1 HH2. - simpl ww_to_Z; simpl fst. + simpl ww_to_Z; simpl @fst. assert (Hv3: [[ww_pred ww_zdigits]] = Zpos (xO w_digits) - 1). rewrite spec_ww_pred; rewrite spec_ww_zdigits. diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleSub.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleSub.v index aaa93a21..a2df2600 100644 --- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleSub.v +++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleSub.v @@ -1,6 +1,7 @@ + (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* shiftr). Lemma nshiftr_S : - forall n x, nshiftr (S n) x = shiftr (nshiftr n x). + forall n x, nshiftr x (S n) = shiftr (nshiftr x n). Proof. reflexivity. Qed. Lemma nshiftr_S_tail : - forall n x, nshiftr (S n) x = nshiftr n (shiftr x). + forall n x, nshiftr x (S n) = nshiftr (shiftr x) n. Proof. - induction n; simpl; auto. - intros; rewrite nshiftr_S, IHn, nshiftr_S; auto. + intros n; elim n; simpl; auto. + intros; now f_equal. Qed. - Lemma nshiftr_n_0 : forall n, nshiftr n 0 = 0. + Lemma nshiftr_n_0 : forall n, nshiftr 0 n = 0. Proof. induction n; simpl; auto. - rewrite nshiftr_S, IHn; auto. + rewrite IHn; auto. Qed. - Lemma nshiftr_size : forall x, nshiftr size x = 0. + Lemma nshiftr_size : forall x, nshiftr x size = 0. Proof. destruct x; simpl; auto. Qed. Lemma nshiftr_above_size : forall k x, size<=k -> - nshiftr k x = 0. + nshiftr x k = 0. Proof. intros. replace k with ((k-size)+size)%nat by omega. induction (k-size)%nat; auto. rewrite nshiftr_size; auto. - simpl; rewrite nshiftr_S, IHn; auto. + simpl; rewrite IHn; auto. Qed. (** * Iterated shift to the left *) - Definition nshiftl n x := iter_nat n _ shiftl x. + Definition nshiftl x := nat_rect _ x (fun _ => shiftl). Lemma nshiftl_S : - forall n x, nshiftl (S n) x = shiftl (nshiftl n x). + forall n x, nshiftl x (S n) = shiftl (nshiftl x n). Proof. reflexivity. Qed. Lemma nshiftl_S_tail : - forall n x, nshiftl (S n) x = nshiftl n (shiftl x). - Proof. - induction n; simpl; auto. - intros; rewrite nshiftl_S, IHn, nshiftl_S; auto. + forall n x, nshiftl x (S n) = nshiftl (shiftl x) n. + Proof. + intros n; elim n; simpl; intros; now f_equal. Qed. - Lemma nshiftl_n_0 : forall n, nshiftl n 0 = 0. + Lemma nshiftl_n_0 : forall n, nshiftl 0 n = 0. Proof. induction n; simpl; auto. - rewrite nshiftl_S, IHn; auto. + rewrite IHn; auto. Qed. - Lemma nshiftl_size : forall x, nshiftl size x = 0. + Lemma nshiftl_size : forall x, nshiftl x size = 0. Proof. destruct x; simpl; auto. Qed. Lemma nshiftl_above_size : forall k x, size<=k -> - nshiftl k x = 0. + nshiftl x k = 0. Proof. intros. replace k with ((k-size)+size)%nat by omega. induction (k-size)%nat; auto. rewrite nshiftl_size; auto. - simpl; rewrite nshiftl_S, IHn; auto. + simpl; rewrite IHn; auto. Qed. Lemma firstr_firstl : - forall x, firstr x = firstl (nshiftl (pred size) x). + forall x, firstr x = firstl (nshiftl x (pred size)). Proof. destruct x; simpl; auto. Qed. Lemma firstl_firstr : - forall x, firstl x = firstr (nshiftr (pred size) x). + forall x, firstl x = firstr (nshiftr x (pred size)). Proof. destruct x; simpl; auto. Qed. @@ -164,23 +163,23 @@ Section Basics. (** More advanced results about [nshiftr] *) Lemma nshiftr_predsize_0_firstl : forall x, - nshiftr (pred size) x = 0 -> firstl x = D0. + nshiftr x (pred size) = 0 -> firstl x = D0. Proof. destruct x; compute; intros H; injection H; intros; subst; auto. Qed. Lemma nshiftr_0_propagates : forall n p x, n <= p -> - nshiftr n x = 0 -> nshiftr p x = 0. + nshiftr x n = 0 -> nshiftr x p = 0. Proof. intros. replace p with ((p-n)+n)%nat by omega. induction (p-n)%nat. simpl; auto. - simpl; rewrite nshiftr_S; rewrite IHn0; auto. + simpl; rewrite IHn0; auto. Qed. Lemma nshiftr_0_firstl : forall n x, n < size -> - nshiftr n x = 0 -> firstl x = D0. + nshiftr x n = 0 -> firstl x = D0. Proof. intros. apply nshiftr_predsize_0_firstl. @@ -197,15 +196,15 @@ Section Basics. forall x, P x. Proof. intros. - assert (forall n, n<=size -> P (nshiftr (size - n) x)). + assert (forall n, n<=size -> P (nshiftr x (size - n))). induction n; intros. rewrite nshiftr_size; auto. rewrite sneakl_shiftr. apply H0. - change (P (nshiftr (S (size - S n)) x)). + change (P (nshiftr x (S (size - S n)))). replace (S (size - S n))%nat with (size - n)%nat by omega. apply IHn; omega. - change x with (nshiftr (size-size) x); auto. + change x with (nshiftr x (size-size)); auto. Qed. Lemma int31_ind_twice : forall P : int31->Prop, @@ -236,19 +235,19 @@ Section Basics. Lemma recr_aux_converges : forall n p x, n <= size -> n <= p -> - recr_aux n A case0 caserec (nshiftr (size - n) x) = - recr_aux p A case0 caserec (nshiftr (size - n) x). + recr_aux n A case0 caserec (nshiftr x (size - n)) = + recr_aux p A case0 caserec (nshiftr x (size - n)). Proof. induction n. - simpl; intros. + simpl minus; intros. rewrite nshiftr_size; destruct p; simpl; auto. intros. destruct p. inversion H0. unfold recr_aux; fold recr_aux. - destruct (iszero (nshiftr (size - S n) x)); auto. + destruct (iszero (nshiftr x (size - S n))); auto. f_equal. - change (shiftr (nshiftr (size - S n) x)) with (nshiftr (S (size - S n)) x). + change (shiftr (nshiftr x (size - S n))) with (nshiftr x (S (size - S n))). replace (S (size - S n))%nat with (size - n)%nat by omega. apply IHn; auto with arith. Qed. @@ -259,7 +258,7 @@ Section Basics. Proof. intros. unfold recr. - change x with (nshiftr (size - size) x). + change x with (nshiftr x (size - size)). rewrite (recr_aux_converges size (S size)); auto with arith. rewrite recr_aux_eqn; auto. Qed. @@ -436,22 +435,22 @@ Section Basics. Lemma phibis_aux_bounded : forall n x, n <= size -> - (phibis_aux n (nshiftr (size-n) x) < 2 ^ (Z.of_nat n))%Z. + (phibis_aux n (nshiftr x (size-n)) < 2 ^ (Z.of_nat n))%Z. Proof. induction n. - simpl; unfold phibis_aux; simpl; auto with zarith. + simpl minus; unfold phibis_aux; simpl; auto with zarith. intros. unfold phibis_aux, recrbis_aux; fold recrbis_aux; - fold (phibis_aux n (shiftr (nshiftr (size - S n) x))). - assert (shiftr (nshiftr (size - S n) x) = nshiftr (size-n) x). + fold (phibis_aux n (shiftr (nshiftr x (size - S n)))). + assert (shiftr (nshiftr x (size - S n)) = nshiftr x (size-n)). replace (size - n)%nat with (S (size - (S n))) by omega. simpl; auto. rewrite H0. assert (H1 : n <= size) by omega. specialize (IHn x H1). - set (y:=phibis_aux n (nshiftr (size - n) x)) in *. + set (y:=phibis_aux n (nshiftr x (size - n))) in *. rewrite Nat2Z.inj_succ, Z.pow_succ_r; auto with zarith. - case_eq (firstr (nshiftr (size - S n) x)); intros. + case_eq (firstr (nshiftr x (size - S n))); intros. rewrite Z.double_spec; auto with zarith. rewrite Z.succ_double_spec; auto with zarith. Qed. @@ -462,12 +461,12 @@ Section Basics. rewrite <- phibis_aux_equiv. split. apply phibis_aux_pos. - change x with (nshiftr (size-size) x). + change x with (nshiftr x (size-size)). apply phibis_aux_bounded; auto. Qed. Lemma phibis_aux_lowerbound : - forall n x, firstr (nshiftr n x) = D1 -> + forall n x, firstr (nshiftr x n) = D1 -> (2 ^ Z.of_nat n <= phibis_aux (S n) x)%Z. Proof. induction n. @@ -509,7 +508,7 @@ Section Basics. (** After killing [n] bits at the left, are the numbers equal ?*) Definition EqShiftL n x y := - nshiftl n x = nshiftl n y. + nshiftl x n = nshiftl y n. Lemma EqShiftL_zero : forall x y, EqShiftL O x y <-> x = y. Proof. @@ -529,7 +528,7 @@ Section Basics. remember (k'-k)%nat as n. clear Heqn H k'. induction n; simpl; auto. - rewrite 2 nshiftl_S; f_equal; auto. + f_equal; auto. Qed. Lemma EqShiftL_firstr : forall k x y, k < size -> @@ -601,7 +600,7 @@ Section Basics. end. Lemma i2l_nshiftl : forall n x, n<=size -> - i2l (nshiftl n x) = cstlist _ D0 n ++ firstn (size-n) (i2l x). + i2l (nshiftl x n) = cstlist _ D0 n ++ firstn (size-n) (i2l x). Proof. induction n. intros. @@ -618,13 +617,13 @@ Section Basics. rewrite <- app_comm_cons; f_equal. rewrite IHn; [ | omega]. rewrite removelast_app. - f_equal. + apply f_equal. replace (size-n)%nat with (S (size - S n))%nat by omega. rewrite removelast_firstn; auto. rewrite i2l_length; omega. generalize (firstn_length (size-n) (i2l x)). rewrite i2l_length. - intros H0 H1; rewrite H1 in H0. + intros H0 H1. rewrite H1 in H0. rewrite min_l in H0 by omega. simpl length in H0. omega. @@ -636,7 +635,7 @@ Section Basics. EqShiftL k x y <-> firstn (size-k) (i2l x) = firstn (size-k) (i2l y). Proof. intros. - destruct (le_lt_dec size k). + destruct (le_lt_dec size k) as [Hle|Hlt]. split; intros. replace (size-k)%nat with O by omega. unfold firstn; auto. @@ -645,24 +644,24 @@ Section Basics. unfold EqShiftL. assert (k <= size) by omega. split; intros. - assert (i2l (nshiftl k x) = i2l (nshiftl k y)) by (f_equal; auto). + assert (i2l (nshiftl x k) = i2l (nshiftl y k)) by (f_equal; auto). rewrite 2 i2l_nshiftl in H1; auto. eapply app_inv_head; eauto. - assert (i2l (nshiftl k x) = i2l (nshiftl k y)). + assert (i2l (nshiftl x k) = i2l (nshiftl y k)). rewrite 2 i2l_nshiftl; auto. f_equal; auto. - rewrite <- (l2i_i2l (nshiftl k x)), <- (l2i_i2l (nshiftl k y)). + rewrite <- (l2i_i2l (nshiftl x k)), <- (l2i_i2l (nshiftl y k)). f_equal; auto. Qed. - (** This equivalence allows to prove easily the following delicate + (** This equivalence allows proving easily the following delicate result *) Lemma EqShiftL_twice_plus_one : forall k x y, EqShiftL k (twice_plus_one x) (twice_plus_one y) <-> EqShiftL (S k) x y. Proof. intros. - destruct (le_lt_dec size k). + destruct (le_lt_dec size k) as [Hle|Hlt]. split; intros; apply EqShiftL_size; auto. rewrite 2 EqShiftL_i2l. @@ -685,7 +684,7 @@ Section Basics. EqShiftL (S k) (shiftr x) (shiftr y). Proof. intros. - destruct (le_lt_dec size (S k)). + destruct (le_lt_dec size (S k)) as [Hle|Hlt]. apply EqShiftL_size; auto. case_eq (firstr x); intros. rewrite <- EqShiftL_twice. @@ -819,30 +818,30 @@ Section Basics. Lemma phi_inv_phi_aux : forall n x, n <= size -> - phi_inv (phibis_aux n (nshiftr (size-n) x)) = - nshiftr (size-n) x. + phi_inv (phibis_aux n (nshiftr x (size-n))) = + nshiftr x (size-n). Proof. induction n. - intros; simpl. + intros; simpl minus. rewrite nshiftr_size; auto. intros. unfold phibis_aux, recrbis_aux; fold recrbis_aux; - fold (phibis_aux n (shiftr (nshiftr (size-S n) x))). - assert (shiftr (nshiftr (size - S n) x) = nshiftr (size-n) x). + fold (phibis_aux n (shiftr (nshiftr x (size-S n)))). + assert (shiftr (nshiftr x (size - S n)) = nshiftr x (size-n)). replace (size - n)%nat with (S (size - (S n))); auto; omega. rewrite H0. - case_eq (firstr (nshiftr (size - S n) x)); intros. + case_eq (firstr (nshiftr x (size - S n))); intros. rewrite phi_inv_double. rewrite IHn by omega. rewrite <- H0. - remember (nshiftr (size - S n) x) as y. + remember (nshiftr x (size - S n)) as y. destruct y; simpl in H1; rewrite H1; auto. rewrite phi_inv_double_plus_one. rewrite IHn by omega. rewrite <- H0. - remember (nshiftr (size - S n) x) as y. + remember (nshiftr x (size - S n)) as y. destruct y; simpl in H1; rewrite H1; auto. Qed. @@ -850,7 +849,7 @@ Section Basics. Proof. intros. rewrite <- phibis_aux_equiv. - replace x with (nshiftr (size - size) x) by auto. + replace x with (nshiftr x (size - size)) by auto. apply phi_inv_phi_aux; auto. Qed. @@ -875,28 +874,28 @@ Section Basics. end. Lemma p2ibis_bounded : forall n p, - nshiftr n (snd (p2ibis n p)) = 0. + nshiftr (snd (p2ibis n p)) n = 0. Proof. induction n. simpl; intros; auto. - simpl; intros. - destruct p; simpl. + simpl p2ibis; intros. + destruct p; simpl snd. specialize IHn with p. - destruct (p2ibis n p); simpl in *. + destruct (p2ibis n p). simpl @snd in *. rewrite nshiftr_S_tail. - destruct (le_lt_dec size n). + destruct (le_lt_dec size n) as [Hle|Hlt]. rewrite nshiftr_above_size; auto. - assert (H:=nshiftr_0_firstl _ _ l IHn). + assert (H:=nshiftr_0_firstl _ _ Hlt IHn). replace (shiftr (twice_plus_one i)) with i; auto. - destruct i; simpl in *; rewrite H; auto. + destruct i; simpl in *. rewrite H; auto. specialize IHn with p. - destruct (p2ibis n p); simpl in *. + destruct (p2ibis n p); simpl @snd in *. rewrite nshiftr_S_tail. - destruct (le_lt_dec size n). + destruct (le_lt_dec size n) as [Hle|Hlt]. rewrite nshiftr_above_size; auto. - assert (H:=nshiftr_0_firstl _ _ l IHn). + assert (H:=nshiftr_0_firstl _ _ Hlt IHn). replace (shiftr (twice i)) with i; auto. destruct i; simpl in *; rewrite H; auto. @@ -946,7 +945,7 @@ Section Basics. intros. simpl p2ibis; destruct p; [ | | red; auto]; specialize IHn with p; - destruct (p2ibis n p); simpl snd in *; simpl phi_inv_positive; + destruct (p2ibis n p); simpl @snd in *; simpl phi_inv_positive; rewrite ?EqShiftL_twice_plus_one, ?EqShiftL_twice; replace (S (size - S n))%nat with (size - n)%nat by omega; apply IHn; omega. @@ -1158,7 +1157,10 @@ Instance int31_ops : ZnZ.Ops int31 := fun i => let (_,r) := i/2 in match r ?= 0 with Eq => true | _ => false end; sqrt2 := sqrt312; - sqrt := sqrt31 + sqrt := sqrt31; + lor := lor31; + land := land31; + lxor := lxor31 }. Section Int31_Specs. @@ -1175,10 +1177,10 @@ Section Int31_Specs. Qed. Notation "[+| c |]" := - (interp_carry 1 wB phi c) (at level 0, x at level 99). + (interp_carry 1 wB phi c) (at level 0, c at level 99). Notation "[-| c |]" := - (interp_carry (-1) wB phi c) (at level 0, x at level 99). + (interp_carry (-1) wB phi c) (at level 0, c at level 99). Notation "[|| x ||]" := (zn2z_to_Z wB phi x) (at level 0, x at level 99). @@ -1412,7 +1414,7 @@ Section Int31_Specs. generalize (phi_bounded a1)(phi_bounded a2)(phi_bounded b); intros. assert ([|b|]>0) by (auto with zarith). generalize (Z_div_mod (phi2 a1 a2) [|b|] H4) (Z_div_pos (phi2 a1 a2) [|b|] H4). - unfold Z.div; destruct (Z.div_eucl (phi2 a1 a2) [|b|]); simpl. + unfold Z.div; destruct (Z.div_eucl (phi2 a1 a2) [|b|]). rewrite ?phi_phi_inv. destruct 1; intros. unfold phi2 in *. @@ -1442,7 +1444,7 @@ Section Int31_Specs. unfold div31; intros. assert ([|b|]>0) by (auto with zarith). generalize (Z_div_mod [|a|] [|b|] H0) (Z_div_pos [|a|] [|b|] H0). - unfold Z.div; destruct (Z.div_eucl [|a|] [|b|]); simpl. + unfold Z.div; destruct (Z.div_eucl [|a|] [|b|]). rewrite ?phi_phi_inv. destruct 1; intros. rewrite H1, Z.mul_comm. @@ -1465,7 +1467,7 @@ Section Int31_Specs. assert ([|b|]>0) by (auto with zarith). unfold Z.modulo. generalize (Z_div_mod [|a|] [|b|] H0). - destruct (Z.div_eucl [|a|] [|b|]); simpl. + destruct (Z.div_eucl [|a|] [|b|]). rewrite ?phi_phi_inv. destruct 1; intros. generalize (phi_bounded b); intros. @@ -1478,15 +1480,14 @@ Section Int31_Specs. unfold gcd31. induction (2*size)%nat; intros. reflexivity. - simpl. + simpl euler. unfold compare31. change [|On|] with 0. generalize (phi_bounded j)(phi_bounded i); intros. case_eq [|j|]; intros. simpl; intros. generalize (Zabs_spec [|i|]); omega. - simpl. - rewrite IHn, H1; f_equal. + simpl. rewrite IHn, H1; f_equal. rewrite spec_mod, H1; auto. rewrite H1; compute; auto. rewrite H1 in H; destruct H as [H _]; compute in H; elim H; auto. @@ -1519,17 +1520,17 @@ Section Int31_Specs. simpl; auto. simpl; intros. case_eq (firstr i); intros H; rewrite 2 IHn; - unfold phibis_aux; simpl; rewrite H; fold (phibis_aux n (shiftr i)); + unfold phibis_aux; simpl; rewrite ?H; fold (phibis_aux n (shiftr i)); generalize (phibis_aux_pos n (shiftr i)); intros; set (z := phibis_aux n (shiftr i)) in *; clearbody z; - rewrite <- iter_nat_plus. + rewrite <- nat_rect_plus. f_equal. rewrite Z.double_spec, <- Z.add_diag. symmetry; apply Zabs2Nat.inj_add; auto with zarith. - change (iter_nat (S (Z.abs_nat z + Z.abs_nat z)) A f a = - iter_nat (Z.abs_nat (Z.succ_double z)) A f a); f_equal. + change (iter_nat (S (Z.abs_nat z) + (Z.abs_nat z))%nat A f a = + iter_nat (Z.abs_nat (Z.succ_double z)) A f a); f_equal. rewrite Z.succ_double_spec, <- Z.add_diag. rewrite Zabs2Nat.inj_add; auto with zarith. rewrite Zabs2Nat.inj_add; auto with zarith. @@ -1554,7 +1555,7 @@ Section Int31_Specs. intros. simpl addmuldiv31_alt. replace (S n) with (n+1)%nat by (rewrite plus_comm; auto). - rewrite iter_nat_plus; simpl; auto. + rewrite nat_rect_plus; simpl; auto. Qed. Lemma spec_add_mul_div : forall x y p, [|p|] <= Zpos 31 -> @@ -1573,10 +1574,9 @@ Section Int31_Specs. clear p H; revert x y. induction n. - simpl; intros. - change (Z.pow_pos 2 31) with (2^31). + simpl Z.of_nat; intros. rewrite Z.mul_1_r. - replace ([|y|] / 2^31) with 0. + replace ([|y|] / 2^(31-0)) with 0. rewrite Z.add_0_r. symmetry; apply Zmod_small; apply phi_bounded. symmetry; apply Zdiv_small; apply phi_bounded. @@ -1627,7 +1627,7 @@ Section Int31_Specs. Lemma spec_pos_mod : forall w p, [|ZnZ.pos_mod p w|] = [|w|] mod (2 ^ [|p|]). Proof. - unfold ZnZ.pos_mod, int31_ops, compare31. + unfold int31_ops, ZnZ.pos_mod, compare31. change [|31|] with 31%Z. assert (forall w p, 31<=p -> [|w|] = [|w|] mod 2^p). intros. @@ -1664,7 +1664,7 @@ Section Int31_Specs. Proof. intros. generalize (phi_inv_phi x). - rewrite H; simpl. + rewrite H; simpl phi_inv. intros H'; rewrite <- H'. simpl; auto. Qed. @@ -1739,7 +1739,7 @@ Section Int31_Specs. Proof. intros. rewrite head031_equiv. - assert (nshiftl size x = 0%int31). + assert (nshiftl x size = 0%int31). apply nshiftl_size. revert x H H0. unfold size at 2 5. @@ -1772,7 +1772,7 @@ Section Int31_Specs. Proof. intros. generalize (phi_inv_phi x). - rewrite H; simpl. + rewrite H; simpl phi_inv. intros H'; rewrite <- H'. simpl; auto. Qed. @@ -1837,7 +1837,7 @@ Section Int31_Specs. Proof. intros. rewrite tail031_equiv. - assert (nshiftr size x = 0%int31). + assert (nshiftr x size = 0%int31). apply nshiftr_size. revert x H H0. induction size. @@ -1957,7 +1957,7 @@ Section Int31_Specs. Lemma div31_phi i j: 0 < [|j|] -> [|fst (i/j)%int31|] = [|i|]/[|j|]. intros Hj; generalize (spec_div i j Hj). - case div31; intros q r; simpl fst. + case div31; intros q r; simpl @fst. intros (H1,H2); apply Zdiv_unique with [|r|]; auto with zarith. rewrite H1; ring. Qed. @@ -2092,7 +2092,7 @@ Section Int31_Specs. generalize (spec_div21 ih il j Hj Hj1). case div3121; intros q r (Hq, Hr). apply Zdiv_unique with (phi r); auto with zarith. - simpl fst; apply eq_trans with (1 := Hq); ring. + simpl @fst; apply eq_trans with (1 := Hq); ring. Qed. Lemma sqrt312_step_correct rec ih il j: @@ -2119,7 +2119,7 @@ Section Int31_Specs. unfold phi2; rewrite Hc1. assert (0 <= [|il|]/[|j|]) by (apply Z_div_pos; auto with zarith). rewrite Z.mul_comm, Z_div_plus_full_l; unfold base; auto with zarith. - unfold Z.pow, Z.pow_pos in Hj1; simpl in Hj1; auto with zarith. + simpl wB in Hj1. unfold Z.pow_pos in Hj1. simpl in Hj1. auto with zarith. case (Z.le_gt_cases (2 ^ 30) [|j|]); intros Hjj. rewrite spec_compare; case Z.compare_spec; rewrite div312_phi; auto; intros Hc; @@ -2213,6 +2213,9 @@ Section Int31_Specs. apply Nat2Z.is_nonneg. Qed. + (* Avoid expanding [iter312_sqrt] before variables in the context. *) + Strategy 1 [iter312_sqrt]. + Lemma spec_sqrt2 : forall x y, wB/ 4 <= [|x|] -> let (s,r) := sqrt312 x y in @@ -2230,7 +2233,7 @@ Section Int31_Specs. 2: simpl; unfold Z.pow_pos; simpl; auto with zarith. case (phi_bounded ih); case (phi_bounded il); intros H1 H2 H3 H4. unfold base, Z.pow, Z.pow_pos in H2,H4; simpl in H2,H4. - unfold phi2,Z.pow, Z.pow_pos. simpl Pos.iter; auto with zarith. } + unfold phi2. cbn [Z.pow Z.pow_pos Pos.iter]. auto with zarith. } case (iter312_sqrt_correct 31 (fun _ _ j => j) ih il Tn); auto with zarith. change [|Tn|] with 2147483647; auto with zarith. intros j1 _ HH; contradict HH. @@ -2255,9 +2258,8 @@ Section Int31_Specs. intros Hihl1. generalize (spec_sub_c il il1). case sub31c; intros il2 Hil2. - simpl interp_carry in Hil2. rewrite spec_compare; case Z.compare_spec. - unfold interp_carry. + unfold interp_carry in *. intros H1; split. rewrite Z.pow_2_r, <- Hihl1. unfold phi2; ring[Hil2 H1]. @@ -2274,7 +2276,7 @@ Section Int31_Specs. rewrite Z.mul_add_distr_r, Z.add_0_r; auto with zarith. case (phi_bounded il1); intros H3 _. apply Z.add_le_mono; auto with zarith. - unfold interp_carry; change (1 * 2 ^ Z.of_nat size) with base. + unfold interp_carry in *; change (1 * 2 ^ Z.of_nat size) with base. rewrite Z.pow_2_r, <- Hihl1, Hil2. intros H1. rewrite <- Z.le_succ_l, <- Z.add_1_r in H1. @@ -2378,8 +2380,8 @@ Qed. Lemma spec_eq0 : forall x, ZnZ.eq0 x = true -> [|x|] = 0. Proof. - clear; unfold ZnZ.eq0; simpl. - unfold compare31; simpl; intros. + clear; unfold ZnZ.eq0, int31_ops. + unfold compare31; intros. change [|0|] with 0 in H. apply Z.compare_eq. now destruct ([|x|] ?= 0). @@ -2390,7 +2392,7 @@ Qed. Lemma spec_is_even : forall x, if ZnZ.is_even x then [|x|] mod 2 = 0 else [|x|] mod 2 = 1. Proof. - unfold ZnZ.is_even; simpl; intros. + unfold ZnZ.is_even, int31_ops; intros. generalize (spec_div x 2). destruct (x/2)%int31 as (q,r); intros. unfold compare31. @@ -2403,6 +2405,51 @@ Qed. apply Zmod_unique with [|q|]; auto with zarith. Qed. + (* Bitwise *) + + Lemma log2_phi_bounded x : Z.log2 [|x|] < Z.of_nat size. + Proof. + destruct (phi_bounded x) as (H,H'). + Z.le_elim H. + - now apply Z.log2_lt_pow2. + - now rewrite <- H. + Qed. + + Lemma spec_lor x y : [| ZnZ.lor x y |] = Z.lor [|x|] [|y|]. + Proof. + unfold ZnZ.lor,int31_ops. unfold lor31. + rewrite phi_phi_inv. + apply Z.mod_small; split; trivial. + - apply Z.lor_nonneg; split; apply phi_bounded. + - apply Z.log2_lt_cancel. rewrite Z.log2_pow2 by easy. + rewrite Z.log2_lor; try apply phi_bounded. + apply Z.max_lub_lt; apply log2_phi_bounded. + Qed. + + Lemma spec_land x y : [| ZnZ.land x y |] = Z.land [|x|] [|y|]. + Proof. + unfold ZnZ.land, int31_ops. unfold land31. + rewrite phi_phi_inv. + apply Z.mod_small; split; trivial. + - apply Z.land_nonneg; left; apply phi_bounded. + - apply Z.log2_lt_cancel. rewrite Z.log2_pow2 by easy. + eapply Z.le_lt_trans. + apply Z.log2_land; try apply phi_bounded. + apply Z.min_lt_iff; left; apply log2_phi_bounded. + Qed. + + Lemma spec_lxor x y : [| ZnZ.lxor x y |] = Z.lxor [|x|] [|y|]. + Proof. + unfold ZnZ.lxor, int31_ops. unfold lxor31. + rewrite phi_phi_inv. + apply Z.mod_small; split; trivial. + - apply Z.lxor_nonneg; split; intros; apply phi_bounded. + - apply Z.log2_lt_cancel. rewrite Z.log2_pow2 by easy. + eapply Z.le_lt_trans. + apply Z.log2_lxor; try apply phi_bounded. + apply Z.max_lub_lt; apply log2_phi_bounded. + Qed. + Global Instance int31_specs : ZnZ.Specs int31_ops := { spec_to_Z := phi_bounded; spec_of_pos := positive_to_int31_spec; @@ -2446,7 +2493,10 @@ Qed. spec_pos_mod := spec_pos_mod; spec_is_even := spec_is_even; spec_sqrt2 := spec_sqrt2; - spec_sqrt := spec_sqrt }. + spec_sqrt := spec_sqrt; + spec_lor := spec_lor; + spec_land := spec_land; + spec_lxor := spec_lxor }. End Int31_Specs. diff --git a/theories/Numbers/Cyclic/Int31/Int31.v b/theories/Numbers/Cyclic/Int31/Int31.v index 73f2816a..4e28b5b9 100644 --- a/theories/Numbers/Cyclic/Int31/Int31.v +++ b/theories/Numbers/Cyclic/Int31/Int31.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* |Hneq]. + generalize (Zmax_spec a b); omega. assert (0 <= q). apply Z.mul_le_mono_pos_r with (Z.gcd a b); auto with zarith. destruct (Z.eq_dec q 0). @@ -796,6 +796,40 @@ Section ZModulo. exists 0; simpl; auto with zarith. Qed. + Definition lor := Z.lor. + Definition land := Z.land. + Definition lxor := Z.lxor. + + 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. + + 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. + + 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 *) Instance zmod_ops : ZnZ.Ops Z := ZnZ.MkOps @@ -849,7 +883,10 @@ Section ZModulo. (is_even : t -> bool) (sqrt2 : t -> t -> t * carry t) - (sqrt : t -> t). + (sqrt : t -> t) + (lor : t -> t -> t) + (land : t -> t -> t) + (lxor : t -> t -> t). Instance zmod_specs : ZnZ.Specs zmod_ops := ZnZ.MkSpecs spec_to_Z @@ -906,7 +943,10 @@ Section ZModulo. spec_is_even spec_sqrt2 - spec_sqrt. + spec_sqrt + spec_lor + spec_land + spec_lxor. End ZModulo. @@ -922,4 +962,3 @@ Module ZModuloCyclicType (P:PositiveNotOne) <: CyclicType. Instance ops : ZnZ.Ops t := zmod_ops P.p. Instance specs : ZnZ.Specs ops := zmod_specs P.not_one. End ZModuloCyclicType. - diff --git a/theories/Numbers/Integer/Abstract/ZAdd.v b/theories/Numbers/Integer/Abstract/ZAdd.v index e109948d..ec8801c4 100644 --- a/theories/Numbers/Integer/Abstract/ZAdd.v +++ b/theories/Numbers/Integer/Abstract/ZAdd.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* t. + Parameter Inline(50) succ : t -> t. + Parameter Inline pred : t -> t. End ZeroSuccPred. Module Type ZeroSuccPredNotation (T:Typ)(Import NZ:ZeroSuccPred T). diff --git a/theories/Numbers/NatInt/NZBase.v b/theories/Numbers/NatInt/NZBase.v index 56c999d4..c0afa098 100644 --- a/theories/Numbers/NatInt/NZBase.v +++ b/theories/Numbers/NatInt/NZBase.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* y==x. diff --git a/theories/Numbers/NatInt/NZBits.v b/theories/Numbers/NatInt/NZBits.v index 31e99340..1c118597 100644 --- a/theories/Numbers/NatInt/NZBits.v +++ b/theories/Numbers/NatInt/NZBits.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* nat_rect _ x (fun _ => f) n). -Local Notation "f ^ n" := (nat_iter n f). - -Instance nat_iter_wd n {A} (R:relation A) : - Proper ((R==>R)==>R==>R) (nat_iter n). +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 f f' Hf. induction n; simpl; red; auto. +intros x y eq_xy f g eq_fg; induction n; [assumption | now apply eq_fg]. Qed. Module NZDomainProp (Import NZ:NZDomainSig'). @@ -33,17 +31,24 @@ Include NZBaseProp NZ. Lemma itersucc_or_itersucc n m : exists k, n == (S^k) m \/ m == (S^k) n. Proof. -nzinduct n m. +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_iter_succ_r in R. exists k. now right. +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_iter_succ_r. +exists (Datatypes.S k). right. now rewrite nat_rect_succ_r. Qed. (** Generalized version of [pred_succ] when iterating *) @@ -53,7 +58,7 @@ 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_iter_succ_r in H; auto. +rewrite <- nat_rect_succ_r in H; auto. Qed. (** From a given point, all others are iterated successors @@ -319,7 +324,7 @@ Lemma ofnat_add : forall n m, [n+m] == [n]+[m]. Proof. intros. rewrite ofnat_add_l. induction n; simpl. reflexivity. - rewrite ofnat_succ. now f_equiv. + now f_equiv. Qed. Lemma ofnat_mul : forall n m, [n*m] == [n]*[m]. @@ -327,15 +332,15 @@ Proof. induction n; simpl; intros. symmetry. apply mul_0_l. rewrite plus_comm. - rewrite ofnat_succ, ofnat_add, mul_succ_l. + 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. - rewrite ofnat_zero. apply sub_0_r. - rewrite ofnat_succ, sub_succ_r. now f_equiv. + apply sub_0_r. + rewrite sub_succ_r. now f_equiv. Qed. Lemma ofnat_sub : forall n m, m<=n -> [n-m] == [n]-[m]. @@ -346,9 +351,10 @@ Proof. intros. destruct n. inversion H. - rewrite nat_iter_succ_r. + rewrite nat_rect_succ_r. simpl. - rewrite ofnat_succ, pred_succ; auto with arith. + etransitivity. apply IHm. auto with arith. + eapply nat_rect_wd; [symmetry;apply pred_succ|apply pred_wd]. Qed. End NZOfNatOps. diff --git a/theories/Numbers/NatInt/NZGcd.v b/theories/Numbers/NatInt/NZGcd.v index 0fd543c0..42bee315 100644 --- a/theories/Numbers/NatInt/NZGcd.v +++ b/theories/Numbers/NatInt/NZGcd.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* √a == b. Proof. intros a b (LEb,LTb). - assert (Ha : 0<=a) by (transitivity b²; trivial using square_nonneg). + 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). @@ -438,7 +438,7 @@ 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. + intros x x' Hx; unfold sqrt_up; rewrite Hx; case compare; now rewrite ?Hx. Qed. (** The spec of [sqrt_up] indeed determines it *) diff --git a/theories/Numbers/Natural/Abstract/NAdd.v b/theories/Numbers/Natural/Abstract/NAdd.v index e2dabf0e..638cfc7e 100644 --- a/theories/Numbers/Natural/Abstract/NAdd.v +++ b/theories/Numbers/Natural/Abstract/NAdd.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* dom_t n -> comparison := let op := dom_op n in - let zero := @ZnZ.zero _ op in - let compare := @ZnZ.compare _ op in + let zero := ZnZ.zero (Ops:=op) in + let compare := ZnZ.compare (Ops:=op) in let compare0 := compare zero in fun m => compare_mn_1 (dom_t n) (dom_t n) zero compare compare0 compare (S m). @@ -273,7 +273,7 @@ Module Make (W0:CyclicType) <: NType. Local Notation compare_folded := (iter_sym _ - (fun n => @ZnZ.compare _ (dom_op n)) + (fun n => ZnZ.compare (Ops:=dom_op n)) comparen_m comparenm CompOpp). @@ -358,13 +358,13 @@ Module Make (W0:CyclicType) <: NType. Definition wn_mul n : forall m, word (dom_t n) (S m) -> dom_t n -> t := let op := dom_op n in - let zero := @ZnZ.zero _ op in - let succ := @ZnZ.succ _ op in - let add_c := @ZnZ.add_c _ op in - let mul_c := @ZnZ.mul_c _ op in + let zero := ZnZ.zero in + let succ := ZnZ.succ (Ops:=op) in + let add_c := ZnZ.add_c (Ops:=op) in + let mul_c := ZnZ.mul_c (Ops:=op) in let ww := @ZnZ.WW _ op in let ow := @ZnZ.OW _ op in - let eq0 := @ZnZ.eq0 _ op in + let eq0 := ZnZ.eq0 in let mul_add := @DoubleMul.w_mul_add _ zero succ add_c mul_c in let mul_add_n1 := @DoubleMul.double_mul_add_n1 _ zero ww ow mul_add in fun m x y => @@ -464,18 +464,18 @@ Module Make (W0:CyclicType) <: NType. Definition wn_divn1 n := let op := dom_op n in let zd := ZnZ.zdigits op in - let zero := @ZnZ.zero _ op in - let ww := @ZnZ.WW _ op in - let head0 := @ZnZ.head0 _ op in - let add_mul_div := @ZnZ.add_mul_div _ op in - let div21 := @ZnZ.div21 _ op in - let compare := @ZnZ.compare _ op in - let sub := @ZnZ.sub _ op in + let zero := ZnZ.zero in + let ww := ZnZ.WW in + let head0 := ZnZ.head0 in + let add_mul_div := ZnZ.add_mul_div in + let div21 := ZnZ.div21 in + let compare := ZnZ.compare in + let sub := ZnZ.sub in let ddivn1 := DoubleDivn1.double_divn1 zd zero ww head0 add_mul_div div21 compare sub in fun m x y => let (u,v) := ddivn1 (S m) x y in (mk_t_w' n m u, mk_t n v). - Let div_gtnm n m wx wy := + Definition div_gtnm n m wx wy := let mn := Max.max n m in let d := diff n m in let op := make_op mn in @@ -522,7 +522,7 @@ Module Make (W0:CyclicType) <: NType. case (ZnZ.spec_to_Z y); auto. Qed. - Let spec_divn1 n := + Definition spec_divn1 n := DoubleDivn1.spec_double_divn1 (ZnZ.zdigits (dom_op n)) (ZnZ.zero:dom_t n) ZnZ.WW ZnZ.head0 @@ -633,17 +633,17 @@ Module Make (W0:CyclicType) <: NType. Definition wn_modn1 n := let op := dom_op n in let zd := ZnZ.zdigits op in - let zero := @ZnZ.zero _ op in - let head0 := @ZnZ.head0 _ op in - let add_mul_div := @ZnZ.add_mul_div _ op in - let div21 := @ZnZ.div21 _ op in - let compare := @ZnZ.compare _ op in - let sub := @ZnZ.sub _ op in + let zero := ZnZ.zero in + let head0 := ZnZ.head0 in + let add_mul_div := ZnZ.add_mul_div in + let div21 := ZnZ.div21 in + let compare := ZnZ.compare in + let sub := ZnZ.sub in let dmodn1 := DoubleDivn1.double_modn1 zd zero head0 add_mul_div div21 compare sub in fun m x y => reduce n (dmodn1 (S m) x y). - Let mod_gtnm n m wx wy := + Definition mod_gtnm n m wx wy := let mn := Max.max n m in let d := diff n m in let op := make_op mn in @@ -671,7 +671,7 @@ Module Make (W0:CyclicType) <: NType. reflexivity. Qed. - Let spec_modn1 n := + Definition spec_modn1 n := DoubleDivn1.spec_double_modn1 (ZnZ.zdigits (dom_op n)) (ZnZ.zero:dom_t n) ZnZ.WW ZnZ.head0 @@ -1617,40 +1617,90 @@ Module Make (W0:CyclicType) <: NType. rewrite spec_shiftr, spec_1. apply Z.div2_spec. Qed. - (** TODO : provide efficient versions instead of just converting - from/to N (see with Laurent) *) + Local Notation lorn := (fun n => + let op := dom_op n in + let lor := ZnZ.lor in + fun x y => reduce n (lor x y)). + + Definition lor : t -> t -> t := Eval red_t in same_level lorn. - Definition lor x y := of_N (N.lor (to_N x) (to_N y)). - Definition land x y := of_N (N.land (to_N x) (to_N y)). - Definition ldiff x y := of_N (N.ldiff (to_N x) (to_N y)). - Definition lxor x y := of_N (N.lxor (to_N x) (to_N y)). + Lemma lor_fold : lor = same_level lorn. + Proof. red_t; reflexivity. Qed. - Lemma spec_land: forall x y, [land x y] = Z.land [x] [y]. + Theorem spec_lor x y : [lor x y] = Z.lor [x] [y]. Proof. - intros x y. unfold land. rewrite spec_of_N. unfold to_N. - generalize (spec_pos x), (spec_pos y). - destruct [x], [y]; trivial; (now destruct 1) || (now destruct 2). + rewrite lor_fold. apply spec_same_level; clear x y. + intros n x y. simpl. rewrite spec_reduce. apply ZnZ.spec_lor. Qed. - Lemma spec_lor: forall x y, [lor x y] = Z.lor [x] [y]. + Local Notation landn := (fun n => + let op := dom_op n in + let land := ZnZ.land in + fun x y => reduce n (land x y)). + + Definition land : t -> t -> t := Eval red_t in same_level landn. + + Lemma land_fold : land = same_level landn. + Proof. red_t; reflexivity. Qed. + + Theorem spec_land x y : [land x y] = Z.land [x] [y]. Proof. - intros x y. unfold lor. rewrite spec_of_N. unfold to_N. - generalize (spec_pos x), (spec_pos y). - destruct [x], [y]; trivial; (now destruct 1) || (now destruct 2). + rewrite land_fold. apply spec_same_level; clear x y. + intros n x y. simpl. rewrite spec_reduce. apply ZnZ.spec_land. Qed. - Lemma spec_ldiff: forall x y, [ldiff x y] = Z.ldiff [x] [y]. + Local Notation lxorn := (fun n => + let op := dom_op n in + let lxor := ZnZ.lxor in + fun x y => reduce n (lxor x y)). + + Definition lxor : t -> t -> t := Eval red_t in same_level lxorn. + + Lemma lxor_fold : lxor = same_level lxorn. + Proof. red_t; reflexivity. Qed. + + Theorem spec_lxor x y : [lxor x y] = Z.lxor [x] [y]. Proof. - intros x y. unfold ldiff. rewrite spec_of_N. unfold to_N. - generalize (spec_pos x), (spec_pos y). - destruct [x], [y]; trivial; (now destruct 1) || (now destruct 2). + rewrite lxor_fold. apply spec_same_level; clear x y. + intros n x y. simpl. rewrite spec_reduce. apply ZnZ.spec_lxor. Qed. - Lemma spec_lxor: forall x y, [lxor x y] = Z.lxor [x] [y]. - Proof. - intros x y. unfold lxor. rewrite spec_of_N. unfold to_N. - generalize (spec_pos x), (spec_pos y). - destruct [x], [y]; trivial; (now destruct 1) || (now destruct 2). + Local Notation ldiffn := (fun n => + let op := dom_op n in + let lxor := ZnZ.lxor in + let land := ZnZ.land in + let m1 := ZnZ.minus_one in + fun x y => reduce n (land x (lxor y m1))). + + Definition ldiff : t -> t -> t := Eval red_t in same_level ldiffn. + + Lemma ldiff_fold : ldiff = same_level ldiffn. + Proof. red_t; reflexivity. Qed. + + Lemma ldiff_alt x y p : + 0 <= x < 2^p -> 0 <= y < 2^p -> + Z.ldiff x y = Z.land x (Z.lxor y (2^p - 1)). + Proof. + intros (Hx,Hx') (Hy,Hy'). + destruct p as [|p|p]. + - simpl in *; replace x with 0; replace y with 0; auto with zarith. + - rewrite <- Z.shiftl_1_l. change (_ - 1) with (Z.ones (Z.pos p)). + rewrite <- Z.ldiff_ones_l_low; trivial. + rewrite !Z.ldiff_land, Z.land_assoc. f_equal. + rewrite Z.land_ones; try easy. + symmetry. apply Z.mod_small; now split. + Z.le_elim Hy. + + now apply Z.log2_lt_pow2. + + now subst. + - simpl in *; omega. + Qed. + + Theorem spec_ldiff x y : [ldiff x y] = Z.ldiff [x] [y]. + Proof. + rewrite ldiff_fold. apply spec_same_level; clear x y. + intros n x y. simpl. rewrite spec_reduce. + rewrite ZnZ.spec_land, ZnZ.spec_lxor, ZnZ.spec_m1. + symmetry. apply ldiff_alt; apply ZnZ.spec_to_Z. Qed. End Make. diff --git a/theories/Numbers/Natural/BigN/NMake_gen.ml b/theories/Numbers/Natural/BigN/NMake_gen.ml index 9e4e88c5..6de77e0a 100644 --- a/theories/Numbers/Natural/BigN/NMake_gen.ml +++ b/theories/Numbers/Natural/BigN/NMake_gen.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* mk_zn2z_ops (nmake_op ww ww_op n1) end. - Let eval n m := ZnZ.to_Z (Ops:=nmake_op _ (dom_op n) m). + Definition eval n m := ZnZ.to_Z (Ops:=nmake_op _ (dom_op n) m). Theorem nmake_op_S: forall ww (w_op: ZnZ.Ops ww) x, nmake_op _ w_op (S x) = mk_zn2z_ops (nmake_op _ w_op x). @@ -326,8 +324,13 @@ pr " Lemma spec_zeron : forall n, ZnZ.to_Z (zeron n) = 0%%Z. Proof. - do_size (destruct n; [exact ZnZ.spec_0|]). - destruct n; auto. simpl. rewrite make_op_S. exact ZnZ.spec_0. + do_size (destruct n; + [match goal with + |- @eq Z (_ (zeron ?n)) _ => + apply (ZnZ.spec_0 (Specs:=dom_spec n)) + end|]). + destruct n; auto. simpl. rewrite make_op_S. fold word. + apply (ZnZ.spec_0 (Specs:=wn_spec (SizePlus 0))). Qed. (** * Digits *) @@ -533,7 +536,7 @@ pr " for i = 0 to size-1 do let pattern = (iter_str (size+1-i) "(S ") ^ "_" ^ (iter_str (size+1-i) ")") in pr -" Let mk_t_%iw m := Eval cbv beta zeta iota delta [ mk_t plus ] in +" Definition mk_t_%iw m := Eval cbv beta zeta iota delta [ mk_t plus ] in match m return word w%i (S m) -> t with | %s as p => mk_t_w %i (S p) | p => mk_t (%i+p) @@ -542,7 +545,7 @@ pr done; pr -" Let mk_t_w' n : forall m, word (dom_t n) (S m) -> t := +" Definition mk_t_w' n : forall m, word (dom_t n) (S m) -> t := match n return (forall m, word (dom_t n) (S m) -> t) with"; for i = 0 to size-1 do pr " | %i => mk_t_%iw" i i done; pr @@ -958,6 +961,11 @@ pr " end."; pr ""; pr " Ltac unfold_red := unfold reduce, %s." (iter_name 1 size "reduce_" ","); +pr ""; +for i = 0 to size do +pr " Declare Equivalent Keys reduce reduce_%i." i; +done; +pr " Declare Equivalent Keys reduce_n reduce_%i." (size + 1); pr " Ltac solve_red := diff --git a/theories/Numbers/Natural/BigN/Nbasic.v b/theories/Numbers/Natural/BigN/Nbasic.v index e545508d..8fe9ea92 100644 --- a/theories/Numbers/Natural/BigN/Nbasic.v +++ b/theories/Numbers/Natural/BigN/Nbasic.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* true - | _, O => false - | S n', S m' => leb n' m' - end. - -Definition ltb n m := leb (S n) m. - -Infix "<=?" := leb (at level 70) : nat_scope. -Infix " n <= m. -Proof. - revert m. - induction n. split; auto with arith. - destruct m; simpl. now split. - rewrite IHn. split; auto with arith. -Qed. - -Lemma ltb_lt n m : (n n < m. -Proof. - unfold ltb, lt. apply leb_le. -Qed. - -Fixpoint pow n m := - match m with - | O => 1 - | S m => n * (pow n m) - end. - -Infix "^" := pow : nat_scope. - -Lemma pow_0_r : forall a, a^0 = 1. -Proof. reflexivity. Qed. - -Lemma pow_succ_r : forall a b, 0<=b -> a^(S b) = a * a^b. -Proof. reflexivity. Qed. - -Definition square n := n * n. - -Lemma square_spec n : square n = n * n. -Proof. reflexivity. Qed. - -Definition Even n := exists m, n = 2*m. -Definition Odd n := exists m, n = 2*m+1. - -Fixpoint even n := - match n with - | O => true - | 1 => false - | S (S n') => even n' - end. - -Definition odd n := negb (even n). - -Lemma even_spec : forall n, even n = true <-> Even n. -Proof. - fix 1. - destruct n as [|[|n]]; simpl; try rewrite even_spec; split. - now exists 0. - trivial. - discriminate. - intros (m,H). destruct m. discriminate. - simpl in H. rewrite <- plus_n_Sm in H. discriminate. - intros (m,H). exists (S m). rewrite H. simpl. now rewrite plus_n_Sm. - intros (m,H). destruct m. discriminate. exists m. - simpl in H. rewrite <- plus_n_Sm in H. inversion H. reflexivity. -Qed. - -Lemma odd_spec : forall n, odd n = true <-> Odd n. -Proof. - unfold odd. - fix 1. - destruct n as [|[|n]]; simpl; try rewrite odd_spec; split. - discriminate. - intros (m,H). rewrite <- plus_n_Sm in H; discriminate. - now exists 0. - trivial. - intros (m,H). exists (S m). rewrite H. simpl. now rewrite <- (plus_n_Sm m). - intros (m,H). destruct m. discriminate. exists m. - simpl in H. rewrite <- plus_n_Sm in H. inversion H. simpl. - now rewrite <- !plus_n_Sm, <- !plus_n_O. -Qed. - -Lemma Even_equiv : forall n, Even n <-> Even.even n. -Proof. - split. intros (p,->). apply Even.even_mult_l. do 3 constructor. - intros H. destruct (even_2n n H) as (p,->). - exists p. unfold double. simpl. now rewrite <- plus_n_O. -Qed. - -Lemma Odd_equiv : forall n, Odd n <-> Even.odd n. -Proof. - split. intros (p,->). rewrite <- plus_n_Sm, <- plus_n_O. - apply Even.odd_S. apply Even.even_mult_l. do 3 constructor. - intros H. destruct (odd_S2n n H) as (p,->). - exists p. unfold double. simpl. now rewrite <- plus_n_Sm, <- !plus_n_O. -Qed. - -(* A linear, tail-recursive, division for nat. - - In [divmod], [y] is the predecessor of the actual divisor, - and [u] is [y] minus the real remainder -*) - -Fixpoint divmod x y q u := - match x with - | 0 => (q,u) - | S x' => match u with - | 0 => divmod x' y (S q) y - | S u' => divmod x' y q u' - end - end. - -Definition div x y := - match y with - | 0 => y - | S y' => fst (divmod x y' 0 y') - end. - -Definition modulo x y := - match y with - | 0 => y - | S y' => y' - snd (divmod x y' 0 y') - end. - -Infix "/" := div : nat_scope. -Infix "mod" := modulo (at level 40, no associativity) : nat_scope. - -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. - induction x. simpl. intuition. - intros y q u H. destruct u; simpl divmod. - generalize (IHx y (S q) y (le_n y)). destruct divmod as (q',u'). - intros (EQ,LE); split; trivial. - rewrite <- EQ, <- minus_n_O, minus_diag, <- plus_n_O. - now rewrite !plus_Sn_m, plus_n_Sm, <- plus_assoc, mult_n_Sm. - generalize (IHx y q u (le_Sn_le _ _ H)). destruct divmod as (q',u'). - intros (EQ,LE); split; trivial. - rewrite <- EQ. - rewrite !plus_Sn_m, plus_n_Sm. f_equal. now apply minus_Sn_m. -Qed. - -Lemma div_mod : forall x y, y<>0 -> x = y*(x/y) + x mod y. -Proof. - intros x y Hy. - destruct y; [ now elim Hy | clear Hy ]. - 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 <- mult_n_O, minus_diag, <- !plus_n_O in U. -Qed. - -Lemma mod_bound_pos : forall x y, 0<=x -> 0 0 <= x mod y < y. -Proof. - intros x y Hx Hy. split. auto with arith. - destruct y; [ now elim Hy | clear Hy ]. - unfold modulo. - apply le_n_S, le_minus. -Qed. - -(** Square root *) - -(** The following square root function is linear (and tail-recursive). - With Peano representation, we can't do better. For faster algorithm, - see Psqrt/Zsqrt/Nsqrt... - - We search the square root of n = k + p^2 + (q - r) - with q = 2p and 0<=r<=q. We start with p=q=r=0, hence - looking for the square root of n = k. Then we progressively - decrease k and r. When k = S k' and r=0, it means we can use (S p) - as new sqrt candidate, since (S k')+p^2+2p = k'+(S p)^2. - When k reaches 0, we have found the biggest p^2 square contained - in n, hence the square root of n is p. -*) - -Fixpoint sqrt_iter k p q r := - match k with - | O => p - | S k' => match r with - | O => sqrt_iter k' (S p) (S (S q)) (S (S q)) - | S r' => sqrt_iter k' p q r' - end - end. - -Definition sqrt n := sqrt_iter n 0 0 0. - -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. - induction k. - (* k = 0 *) - simpl; intros p q r Hq Hr. - split. - apply le_plus_l. - apply le_lt_n_Sm. - rewrite <- mult_n_Sm. - rewrite plus_assoc, (plus_comm p), <- plus_assoc. - apply plus_le_compat; trivial. - rewrite <- Hq. apply le_minus. - (* k = S k' *) - destruct r. - (* r = 0 *) - intros Hq _. - replace (S k + p*p + (q-0)) with (k + (S p)*(S p) + (S (S q) - S (S q))). - apply IHk. - simpl. rewrite <- plus_n_Sm. congruence. - auto with arith. - rewrite minus_diag, <- minus_n_O, <- plus_n_O. simpl. - rewrite <- plus_n_Sm; f_equal. rewrite <- plus_assoc; f_equal. - rewrite <- mult_n_Sm, (plus_comm p), <- plus_assoc. congruence. - (* r = S r' *) - intros Hq Hr. - replace (S k + p*p + (q-S r)) with (k + p*p + (q - r)). - apply IHk; auto with arith. - simpl. rewrite plus_n_Sm. f_equal. rewrite minus_Sn_m; auto. -Qed. - -Lemma sqrt_spec : forall n, - (sqrt n)*(sqrt n) <= n < S (sqrt n) * S (sqrt n). -Proof. - intros. - set (s:=sqrt n). - replace n with (n + 0*0 + (0-0)). - apply sqrt_iter_spec; auto. - simpl. now rewrite <- 2 plus_n_O. -Qed. - -(** A linear tail-recursive base-2 logarithm - - In [log2_iter], we maintain the logarithm [p] of the counter [q], - while [r] is the distance between [q] and the next power of 2, - more precisely [q + S r = 2^(S p)] and [r<2^p]. At each - recursive call, [q] goes up while [r] goes down. When [r] - is 0, we know that [q] has almost reached a power of 2, - and we increase [p] at the next call, while resetting [r] - to [q]. - - Graphically (numbers are [q], stars are [r]) : - -<< - 10 - 9 - 8 - 7 * - 6 * - 5 ... - 4 - 3 * - 2 * - 1 * * -0 * * * ->> - - We stop when [k], the global downward counter reaches 0. - At that moment, [q] is the number we're considering (since - [k+q] is invariant), and [p] its logarithm. -*) - -Fixpoint log2_iter k p q r := - match k with - | O => p - | S k' => match r with - | O => log2_iter k' (S p) (S q) q - | S r' => log2_iter k' p (S q) r' - end - end. - -Definition log2 n := log2_iter (pred n) 0 1 0. - -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. - induction k. - (* k = 0 *) - intros p q r EQ LT. simpl log2_iter. cbv zeta. - split. - rewrite plus_O_n. - apply plus_le_reg_l with (2^p). - simpl pow in EQ. rewrite <- plus_n_O in EQ. rewrite EQ. - rewrite plus_comm. apply plus_le_compat_r. now apply lt_le_S. - rewrite EQ, plus_comm. apply plus_lt_compat_l. apply lt_0_Sn. - (* k = S k' *) - intros p q r EQ LT. destruct r. - (* r = 0 *) - rewrite <- plus_n_Sm, <- plus_n_O in EQ. - rewrite plus_Sn_m, plus_n_Sm. apply IHk. - rewrite <- EQ. remember (S p) as p'; simpl. now rewrite <- plus_n_O. - unfold lt. now rewrite EQ. - (* r = S r' *) - rewrite plus_Sn_m, plus_n_Sm. apply IHk. - now rewrite plus_Sn_m, plus_n_Sm. - unfold lt. - now apply lt_le_weak. -Qed. - -Lemma log2_spec : forall 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 <- plus_n_Sm, <- plus_n_O. - symmetry. now apply S_pred with 0. -Qed. - -Lemma log2_nonpos : forall n, n<=0 -> log2 n = 0. -Proof. - inversion 1; now subst. -Qed. - -(** * Gcd *) - -(** We use Euclid algorithm, which is normally not structural, - but Coq is now clever enough to accept this (behind modulo - there is a subtraction, which now preserves being a subterm) -*) - -Fixpoint gcd a b := - match a with - | O => b - | S a' => gcd (b mod (S a')) (S a') - end. - -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 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 b a') at 2 by discriminate. - destruct H as (u,Hu), H' as (v,Hv). - rewrite mult_comm. - exists ((b/a')*v + u). - rewrite mult_plus_distr_r. - now rewrite <- mult_assoc, <- Hv, <- Hu. -Qed. - -Lemma gcd_divide_l : forall a b, (gcd a b | a). -Proof. - intros. apply gcd_divide. -Qed. - -Lemma gcd_divide_r : forall a b, (gcd a b | b). -Proof. - intros. apply gcd_divide. -Qed. - -Lemma gcd_greatest : forall a b c, (c|a) -> (c|b) -> (c|gcd a b). -Proof. - fix 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 b a') in H' by discriminate. - destruct H as (u,Hu), H' as (v,Hv). - exists (v - (b/a')*u). - rewrite mult_comm in Hv. - now rewrite mult_minus_distr_r, <- Hv, <-mult_assoc, <-Hu, minus_plus. -Qed. - -(** * Bitwise operations *) - -(** We provide here some bitwise operations for unary numbers. - Some might be really naive, they are just there for fullfiling - the same interface as other for natural representations. As - soon as binary representations such as NArith are available, - it is clearly better to convert to/from them and use their ops. -*) - -Fixpoint testbit a n := - match n with - | O => odd a - | S n => testbit (div2 a) n - end. - -Definition shiftl a n := iter_nat n _ double a. -Definition shiftr a n := iter_nat n _ div2 a. - -Fixpoint bitwise (op:bool->bool->bool) n a b := - match n with - | O => O - | S n' => - (if op (odd a) (odd b) then 1 else 0) + - 2*(bitwise op n' (div2 a) (div2 b)) - end. - -Definition land a b := bitwise andb a a b. -Definition lor a b := bitwise orb (max a b) a b. -Definition ldiff a b := bitwise (fun b b' => b && negb b') a a b. -Definition lxor a b := bitwise xorb (max a b) a b. - -Lemma double_twice : forall n, double n = 2*n. -Proof. - simpl; intros. now rewrite <- plus_n_O. -Qed. - -Lemma testbit_0_l : forall n, testbit 0 n = false. -Proof. - now induction n. -Qed. - -Lemma testbit_odd_0 a : testbit (2*a+1) 0 = true. -Proof. - unfold testbit. rewrite odd_spec. now exists a. -Qed. - -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 <- plus_n_Sm, <- plus_n_O. f_equal. - apply div2_double_plus_one. -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_spec : forall a n m, - testbit (shiftr a n) m = testbit a (m+n). -Proof. - induction n; intros m. trivial. - now rewrite <- plus_n_O. - now rewrite <- plus_n_Sm, <- plus_Sn_m, <- IHn. -Qed. - -Lemma shiftl_spec_high : forall a n m, n<=m -> - testbit (shiftl a n) m = testbit a (m-n). -Proof. - induction n; intros m H. trivial. - now rewrite <- minus_n_O. - destruct m. inversion H. - simpl. apply le_S_n in H. - change (shiftl a (S n)) with (double (shiftl a n)). - rewrite double_twice, div2_double. now apply IHn. -Qed. - -Lemma shiftl_spec_low : forall a n m, m - testbit (shiftl a n) m = false. -Proof. - induction n; 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 lt_S_n. -Qed. - -Lemma div2_bitwise : forall op n a b, - div2 (bitwise op (S n) a b) = bitwise op n (div2 a) (div2 b). -Proof. - intros. unfold bitwise; fold bitwise. - destruct (op (odd a) (odd b)). - now rewrite div2_double_plus_one. - now rewrite plus_O_n, div2_double. -Qed. - -Lemma odd_bitwise : forall op n a b, - odd (bitwise op (S n) a b) = op (odd a) (odd b). -Proof. - intros. unfold bitwise; fold bitwise. - destruct (op (odd a) (odd b)). - apply odd_spec. rewrite plus_comm. eexists; eauto. - unfold odd. apply negb_false_iff. apply even_spec. - rewrite plus_O_n; eexists; eauto. -Qed. - -Lemma div2_decr : forall a n, a <= S n -> div2 a <= n. -Proof. - destruct a; intros. apply le_0_n. - apply le_trans with a. - apply lt_n_Sm_le, lt_div2, lt_0_Sn. now apply le_S_n. -Qed. - -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. - induction n; 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. - -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. - induction n; 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. - -Lemma land_spec : forall a b n, - testbit (land a b) n = testbit a n && testbit b n. -Proof. - intros. unfold land. apply testbit_bitwise_1; trivial. -Qed. - -Lemma ldiff_spec : forall a b n, - testbit (ldiff a b) n = testbit a n && negb (testbit b n). -Proof. - intros. unfold ldiff. apply testbit_bitwise_1; trivial. -Qed. - -Lemma lor_spec : forall a b n, - testbit (lor a b) n = testbit a n || testbit b n. -Proof. - intros. unfold lor. apply testbit_bitwise_2. trivial. - destruct (le_ge_dec a b). now rewrite max_r. now rewrite max_l. - destruct (le_ge_dec a b). now rewrite max_r. now rewrite max_l. -Qed. - -Lemma lxor_spec : forall a b n, - testbit (lxor a b) n = xorb (testbit a n) (testbit b n). -Proof. - intros. unfold lxor. apply testbit_bitwise_2. trivial. - destruct (le_ge_dec a b). now rewrite max_r. now rewrite max_l. - destruct (le_ge_dec a b). now rewrite max_r. now rewrite max_l. -Qed. - -(** * Implementation of [NAxiomsSig] by [nat] *) - -Module Nat - <: NAxiomsSig <: UsualDecidableTypeFull <: OrderedTypeFull <: TotalOrder. - -(** 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. - -(** Basic operations. *) - -Definition eq_equiv : Equivalence (@eq nat) := eq_equivalence. -Local Obligation Tactic := simpl_relation. -Program Instance succ_wd : Proper (eq==>eq) S. -Program Instance pred_wd : Proper (eq==>eq) pred. -Program Instance add_wd : Proper (eq==>eq==>eq) plus. -Program Instance sub_wd : Proper (eq==>eq==>eq) minus. -Program Instance mul_wd : Proper (eq==>eq==>eq) mult. - -Theorem pred_succ : forall n : nat, pred (S n) = n. -Proof. -reflexivity. -Qed. - -Theorem one_succ : 1 = S 0. -Proof. -reflexivity. -Qed. - -Theorem two_succ : 2 = S 1. -Proof. -reflexivity. -Qed. - -Theorem add_0_l : forall n : nat, 0 + n = n. -Proof. -reflexivity. -Qed. - -Theorem add_succ_l : forall n m : nat, (S n) + m = S (n + m). -Proof. -reflexivity. -Qed. - -Theorem sub_0_r : forall n : nat, n - 0 = n. -Proof. -intro n; now destruct n. -Qed. - -Theorem sub_succ_r : forall n m : nat, n - (S m) = pred (n - m). -Proof. -induction n; destruct m; simpl; auto. apply sub_0_r. -Qed. - -Theorem mul_0_l : forall n : nat, 0 * n = 0. -Proof. -reflexivity. -Qed. - -Theorem mul_succ_l : forall n m : nat, S n * m = n * m + m. -Proof. -assert (add_S_r : forall n m, n+S m = S(n+m)) by (induction n; auto). -assert (add_comm : forall n m, n+m = m+n). - induction n; simpl; auto. intros; rewrite add_S_r; auto. -intros n m; now rewrite add_comm. -Qed. - -(** Order on natural numbers *) - -Program Instance lt_wd : Proper (eq==>eq==>iff) lt. - -Theorem lt_succ_r : forall n m : nat, n < S m <-> n <= m. -Proof. -unfold lt; split. apply le_S_n. induction 1; auto. -Qed. - - -Theorem lt_eq_cases : forall n m : nat, n <= m <-> n < m \/ n = m. -Proof. -split. -inversion 1; auto. rewrite lt_succ_r; auto. -destruct 1; [|subst; auto]. rewrite <- lt_succ_r; auto. -Qed. - -Theorem lt_irrefl : forall n : nat, ~ (n < n). -Proof. -induction n. intro H; inversion H. rewrite lt_succ_r; auto. -Qed. - -(** Facts specific to natural numbers, not integers. *) - -Theorem pred_0 : pred 0 = 0. -Proof. -reflexivity. -Qed. - -(** Recursion fonction *) - -Definition recursion {A} : A -> (nat -> A -> A) -> nat -> A := - nat_rect (fun _ => A). - -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' Hn. subst 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 *; induction n; simpl; auto. -Qed. - -(** The instantiation of operations. - Placing them at the very end avoids having indirections in above lemmas. *) - -Definition t := nat. -Definition eq := @eq nat. -Definition eqb := beq_nat. -Definition compare := nat_compare. -Definition zero := 0. -Definition one := 1. -Definition two := 2. -Definition succ := S. -Definition pred := pred. -Definition add := plus. -Definition sub := minus. -Definition mul := mult. -Definition lt := lt. -Definition le := le. -Definition ltb := ltb. -Definition leb := leb. - -Definition min := min. -Definition max := max. -Definition max_l := max_l. -Definition max_r := max_r. -Definition min_l := min_l. -Definition min_r := min_r. - -Definition eqb_eq := beq_nat_true_iff. -Definition compare_spec := nat_compare_spec. -Definition eq_dec := eq_nat_dec. -Definition leb_le := leb_le. -Definition ltb_lt := ltb_lt. - -Definition Even := Even. -Definition Odd := Odd. -Definition even := even. -Definition odd := odd. -Definition even_spec := even_spec. -Definition odd_spec := odd_spec. - -Program Instance pow_wd : Proper (eq==>eq==>eq) pow. -Definition pow_0_r := pow_0_r. -Definition pow_succ_r := pow_succ_r. -Lemma pow_neg_r : forall a b, b<0 -> a^b = 0. inversion 1. Qed. -Definition pow := pow. - -Definition square := square. -Definition square_spec := square_spec. - -Definition log2_spec := log2_spec. -Definition log2_nonpos := log2_nonpos. -Definition log2 := log2. - -Definition sqrt_spec a (Ha:0<=a) := sqrt_spec a. -Lemma sqrt_neg : forall a, a<0 -> sqrt a = 0. inversion 1. Qed. -Definition sqrt := sqrt. - -Definition div := div. -Definition modulo := modulo. -Program Instance div_wd : Proper (eq==>eq==>eq) div. -Program Instance mod_wd : Proper (eq==>eq==>eq) modulo. -Definition div_mod := div_mod. -Definition mod_bound_pos := mod_bound_pos. - -Definition divide := divide. -Definition gcd := gcd. -Definition gcd_divide_l := gcd_divide_l. -Definition gcd_divide_r := gcd_divide_r. -Definition gcd_greatest := gcd_greatest. -Lemma gcd_nonneg : forall a b, 0<=gcd a b. -Proof. intros. apply le_O_n. Qed. - -Definition testbit := testbit. -Definition shiftl := shiftl. -Definition shiftr := shiftr. -Definition lxor := lxor. -Definition land := land. -Definition lor := lor. -Definition ldiff := ldiff. -Definition div2 := div2. - -Program Instance testbit_wd : Proper (eq==>eq==>Logic.eq) testbit. -Definition testbit_odd_0 := testbit_odd_0. -Definition testbit_even_0 := testbit_even_0. -Definition testbit_odd_succ a n (_:0<=n) := testbit_odd_succ a n. -Definition testbit_even_succ a n (_:0<=n) := testbit_even_succ a n. -Lemma testbit_neg_r a n (H:n<0) : testbit a n = false. -Proof. inversion H. Qed. -Definition shiftl_spec_low := shiftl_spec_low. -Definition shiftl_spec_high a n m (_:0<=m) := shiftl_spec_high a n m. -Definition shiftr_spec a n m (_:0<=m) := shiftr_spec a n m. -Definition lxor_spec := lxor_spec. -Definition land_spec := land_spec. -Definition lor_spec := lor_spec. -Definition ldiff_spec := ldiff_spec. -Definition div2_spec a : div2 a = shiftr a 1 := eq_refl _. - -(** Generic Properties *) - -Include NProp - <+ UsualMinMaxLogicalProperties <+ UsualMinMaxDecProperties. - -End Nat. - -(** [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. - Qed. -End TestOrder. +Module Nat <: NAxiomsSig := Nat. diff --git a/theories/Numbers/Natural/SpecViaZ/NSig.v b/theories/Numbers/Natural/SpecViaZ/NSig.v index 2b52bffe..1049c156 100644 --- a/theories/Numbers/Natural/SpecViaZ/NSig.v +++ b/theories/Numbers/Natural/SpecViaZ/NSig.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* B)(g:A->A)(h:B->B), (forall a, f (g a) = h (f a)) -> forall p a, - f (iter p g a) = iter p h (f a). + f (iter g a p) = iter h (f a) p. Proof. induction p; simpl; intros; now rewrite ?H, ?IHp. Qed. Theorem iter_swap : forall p (A:Type) (f:A -> A) (x:A), - iter p f (f x) = f (iter p f x). + 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 (succ p) f x = f (iter p f x). + iter f x (succ p) = f (iter f x p). Proof. induction p as [p IHp|p IHp|]; intros; simpl; trivial. now rewrite !IHp, iter_swap. @@ -600,7 +598,7 @@ 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). + iter f x (p+q) = iter f (iter f x q) p. Proof. induction p using peano_ind; intros. now rewrite add_1_l, iter_succ. @@ -610,7 +608,7 @@ 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 p f x). + forall x:A, Inv x -> Inv (iter f x p). Proof. induction p as [p IHp|p IHp|]; simpl; trivial. intros A f Inv H x H0. apply H, IHp, IHp; trivial. @@ -651,7 +649,7 @@ 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| ]; destruct q; simpl; - try reflexivity; try rewrite IHp; + try reflexivity; rewrite ?IHp; destruct (sub_mask p q) as [|[r|r| ]|] || destruct p; auto. Qed. @@ -768,15 +766,15 @@ Definition switch_Eq c c' := end. Lemma compare_cont_spec p q c : - compare_cont p q c = switch_Eq c (p ?= q). + compare_cont c p q = switch_Eq c (p ?= q). Proof. unfold compare. revert q c. induction p; destruct q; simpl; trivial. intros c. - rewrite 2 IHp. now destruct (compare_cont p q Eq). + rewrite 2 IHp. now destruct (compare_cont Eq p q). intros c. - rewrite 2 IHp. now destruct (compare_cont p q Eq). + rewrite 2 IHp. now destruct (compare_cont Eq p q). Qed. (** From this general result, we now describe particular cases @@ -787,31 +785,31 @@ Qed. *) Theorem compare_cont_Eq p q c : - compare_cont p q c = Eq -> c = Eq. + 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 p q 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 p q 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 p q 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 p q Gt = Gt <-> p >= q. + compare_cont Gt p q = Gt <-> p >= q. Proof. rewrite compare_cont_spec. unfold ge. destruct (p ?= q); easy'. Qed. @@ -876,13 +874,13 @@ Qed. (** Basic facts about [compare_cont] *) Theorem compare_cont_refl p c : - compare_cont p p c = c. + compare_cont c p p = c. Proof. now induction p. Qed. Lemma compare_cont_antisym p q c : - CompOpp (compare_cont p q c) = compare_cont q p (CompOpp 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; @@ -1840,6 +1838,8 @@ Qed. End Pos. +Bind Scope positive_scope with Pos.t positive. + (** Exportation of notations *) Infix "+" := Pos.add : positive_scope. @@ -1903,7 +1903,7 @@ Notation Pdiv2 := Pos.div2 (compat "8.3"). Notation Pdiv2_up := Pos.div2_up (compat "8.3"). Notation Psize := Pos.size_nat (compat "8.3"). Notation Psize_pos := Pos.size (compat "8.3"). -Notation Pcompare := Pos.compare_cont (compat "8.3"). +Notation Pcompare x y m := (Pos.compare_cont m x y) (compat "8.3"). Notation Plt := Pos.lt (compat "8.3"). Notation Pgt := Pos.gt (compat "8.3"). Notation Ple := Pos.le (compat "8.3"). @@ -2062,11 +2062,11 @@ 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 p p Eq = Eq. +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 p q Eq = Eq -> p = q. +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 p q Eq = CompOpp (Pos.compare_cont q p 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)). diff --git a/theories/PArith/BinPosDef.v b/theories/PArith/BinPosDef.v index 77239660..fefd1d76 100644 --- a/theories/PArith/BinPosDef.v +++ b/theories/PArith/BinPosDef.v @@ -1,7 +1,7 @@ (* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* A) (x:A) : A := - match n with +Definition iter {A} (f:A -> A) : A -> positive -> A := + fix iter_fix x n := match n with | xH => f x - | xO n' => iter n' f (iter n' f x) - | xI n' => f (iter n' f (iter n' f x)) + | xO n' => iter_fix (iter_fix x n') n' + | xI n' => f (iter_fix (iter_fix x n') n') end. (** ** Power *) -Definition pow (x y:positive) := iter y (mul x) 1. +Definition pow (x:positive) := iter (mul x) 1. Infix "^" := pow : positive_scope. @@ -257,20 +255,20 @@ Fixpoint size p := (** ** Comparison on binary positive numbers *) -Fixpoint compare_cont (x y:positive) (r:comparison) {struct y} : comparison := +Fixpoint compare_cont (r:comparison) (x y:positive) {struct y} : comparison := match x, y with - | p~1, q~1 => compare_cont p q r - | p~1, q~0 => compare_cont p q Gt + | p~1, q~1 => compare_cont r p q + | p~1, q~0 => compare_cont Gt p q | p~1, 1 => Gt - | p~0, q~1 => compare_cont p q Lt - | p~0, q~0 => compare_cont p q r + | p~0, q~1 => compare_cont Lt p q + | p~0, q~0 => compare_cont r p q | p~0, 1 => Gt | 1, q~1 => Lt | 1, q~0 => Lt | 1, 1 => r end. -Definition compare x y := compare_cont x y Eq. +Definition compare := compare_cont Eq. Infix "?=" := compare (at level 70, no associativity) : positive_scope. @@ -377,7 +375,7 @@ Fixpoint gcdn (n : nat) (a b : positive) : positive := 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)) @@ -484,19 +482,19 @@ Fixpoint lxor (p q:positive) : N := (** Shifts. NB: right shift of 1 stays at 1. *) -Definition shiftl_nat (p:positive)(n:nat) := nat_iter n xO p. -Definition shiftr_nat (p:positive)(n:nat) := nat_iter n div2 p. +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 n xO p + | Npos n => iter xO p n end. Definition shiftr (p:positive)(n:N) := match n with | N0 => p - | Npos n => iter n div2 p + | Npos n => iter div2 p n end. (** Checking whether a particular bit is set or not *) @@ -539,7 +537,7 @@ Definition iter_op {A}(op:A->A->A) := end. Definition to_nat (x:positive) : nat := iter_op plus x (S O). - +Arguments to_nat x: simpl never. (** ** From Peano natural numbers to binary positive numbers *) (** A version preserving positive numbers, and sending 0 to 1. *) @@ -559,4 +557,4 @@ Fixpoint of_succ_nat (n:nat) : positive := | S x => succ (of_succ_nat x) end. -End Pos. \ No newline at end of file +End Pos. diff --git a/theories/PArith/PArith.v b/theories/PArith/PArith.v index eac2b99b..93352c6b 100644 --- a/theories/PArith/PArith.v +++ b/theories/PArith/PArith.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* to_nat p < to_nat q. Proof. - unfold lt. now rewrite inj_compare, nat_compare_lt. + 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. + 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. + 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. + unfold ge. now rewrite inj_compare, Nat.compare_ge_iff. Qed. (** [Pos.to_nat] is a morphism for subtraction *) @@ -138,64 +138,66 @@ Qed. Theorem inj_sub p q : (q < p)%positive -> to_nat (p - q) = to_nat p - to_nat q. Proof. - intro H; apply plus_reg_l with (to_nat q); rewrite le_plus_minus_r. - now rewrite <- inj_add, add_comm, sub_add. - now apply lt_le_weak, inj_lt. + 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) = Peano.max 1 (to_nat p - to_nat q). + to_nat (p - q) = Nat.max 1 (to_nat p - to_nat q). Proof. destruct (ltb_spec q p). - rewrite <- inj_sub by trivial. - now destruct (is_succ (p - q)) as (m,->). - rewrite sub_le by trivial. - replace (to_nat p - to_nat q) with 0; trivial. - apply le_n_0_eq. - rewrite <- (minus_diag (to_nat p)). - now apply minus_le_compat_l, inj_le. + - (* 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) = Peano.pred (to_nat p). + to_nat (pred p) = Nat.pred (to_nat p). Proof. - intros H. now rewrite <- Pos.sub_1_r, inj_sub, pred_of_minus. + intros. now rewrite <- Pos.sub_1_r, inj_sub, Nat.sub_1_r. Qed. Theorem inj_pred_max p : - to_nat (pred p) = Peano.max 1 (Peano.pred (to_nat p)). + to_nat (pred p) = Nat.max 1 (Peano.pred (to_nat p)). Proof. - rewrite <- Pos.sub_1_r, pred_of_minus. apply inj_sub_max. + 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) = Peano.min (to_nat p) (to_nat 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 Peano.min_l. now rewrite H. - now apply Peano.min_l, lt_le_weak. - now apply Peano.min_r, lt_le_weak. + 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) = Peano.max (to_nat p) (to_nat 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 Peano.max_r. now rewrite H. - now apply Peano.max_r, lt_le_weak. - now apply Peano.max_l, lt_le_weak. + 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 : forall p {A} (f:A->A) (x:A), - Pos.iter p f x = nat_iter (to_nat p) f x. + Pos.iter f x p = nat_rect _ x (fun _ => f) (to_nat p). Proof. - induction p using peano_ind. trivial. - intros. rewrite inj_succ, iter_succ. simpl. now f_equal. + induction p using peano_ind. + - trivial. + - intros. rewrite inj_succ, iter_succ. + simpl. f_equal. apply IHp. Qed. End Pos2Nat. @@ -209,7 +211,7 @@ Module Nat2Pos. 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. destruct n. trivial. + intros _. simpl Pos.of_nat. destruct n. trivial. rewrite Pos2Nat.inj_succ. f_equal. now apply H. Qed. @@ -257,11 +259,11 @@ Lemma inj_mul (n m : nat) : n<>0 -> m<>0 -> Proof. intros Hn Hm. apply Pos2Nat.inj. rewrite Pos2Nat.inj_mul, !id; trivial. -intros H. apply mult_is_O in H. destruct H. now elim Hn. now elim Hm. +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 -> - nat_compare n m = (Pos.of_nat n ?= Pos.of_nat m). + (n ?= m) = (Pos.of_nat n ?= Pos.of_nat m)%positive. Proof. intros Hn Hm. rewrite Pos2Nat.inj_compare, !id; trivial. Qed. @@ -282,8 +284,9 @@ 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 min_l || apply min_r. - rewrite H; auto. now apply lt_le_weak. now apply lt_le_weak. + 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) : @@ -292,8 +295,9 @@ 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 max_l || apply max_r. - rewrite H; auto. now apply lt_le_weak. now apply lt_le_weak. + 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. End Nat2Pos. @@ -365,7 +369,7 @@ apply Pos2Nat.inj. now rewrite Pos2Nat.inj_succ, !id_succ. Qed. Lemma inj_compare n m : - nat_compare n m = (Pos.of_succ_nat n ?= Pos.of_succ_nat m). + (n ?= m) = (Pos.of_succ_nat n ?= Pos.of_succ_nat m)%positive. Proof. rewrite Pos2Nat.inj_compare, !id_succ; trivial. Qed. @@ -410,24 +414,24 @@ Notation P_of_succ_nat_o_nat_of_P_eq_succ := Pos2SuccNat.id_succ (compat "8.3"). Notation pred_o_P_of_succ_nat_o_nat_of_P_eq_id := Pos2SuccNat.pred_id (compat "8.3"). Lemma nat_of_P_minus_morphism p q : - Pos.compare_cont p q Eq = Gt -> + 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 p q Eq = Lt -> Pos.to_nat p < Pos.to_nat 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 p q Eq = Gt -> Pos.to_nat p > Pos.to_nat 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 p q Eq = Lt. + Pos.to_nat p < Pos.to_nat q -> Pos.compare_cont Eq p q = Lt. Proof (proj2 (Pos2Nat.inj_lt p q)). Definition nat_of_P_gt_Gt_compare_complement_morphism p q : - Pos.to_nat p > Pos.to_nat q -> Pos.compare_cont p q Eq = Gt. + 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] *) @@ -438,11 +442,11 @@ Lemma Pmult_nat_mult : forall p n, Pmult_nat p n = Pos.to_nat p * n. Proof. induction p; intros n; unfold Pos.to_nat; simpl. - f_equal. rewrite 2 IHp. rewrite <- mult_assoc. - f_equal. simpl. now rewrite <- plus_n_O. - rewrite 2 IHp. rewrite <- mult_assoc. - f_equal. simpl. now rewrite <- plus_n_O. - simpl. now rewrite <- plus_n_O. + 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 : @@ -454,7 +458,7 @@ 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 mult_plus_distr_r. + intros. rewrite !Pmult_nat_mult, Pos2Nat.inj_add. apply Nat.mul_add_distr_r. Qed. Theorem Pmult_nat_plus_carry_morphism : @@ -466,19 +470,19 @@ 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 mult_plus_distr_l. + 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, mult_comm. simpl. now rewrite <- plus_n_O. + 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. rewrite Pmult_nat_mult. - apply le_trans with (1*n). now rewrite mult_1_l. - apply mult_le_compat_r. apply Pos2Nat.is_pos. + 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/theories/Program/Basics.v b/theories/Program/Basics.v index 2c0f62ad..e5be0ca9 100644 --- a/theories/Program/Basics.v +++ b/theories/Program/Basics.v @@ -1,7 +1,7 @@ (* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* Prop) (n m : sig P), n = m <-> `n = `m. Proof. - induction n. - induction m. + destruct n as (x,p). + destruct m as (x',p'). simpl. split ; intros ; subst. @@ -79,14 +79,14 @@ 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 : forall (y : A | y = x), B) : B := +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 originaly 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 : forall (y : A | y = x), B) - (y : A | 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. diff --git a/theories/Program/Syntax.v b/theories/Program/Syntax.v index 269748b5..67e9a20c 100644 --- a/theories/Program/Syntax.v +++ b/theories/Program/Syntax.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* F_sub x f = F_sub x g. + (forall y:{y : A | R y x}, f y = g y) -> F_sub x f = F_sub x g. Lemma Fix_F_eq : forall (x:A) (r:Acc R x), - F_sub x (fun (y:A|R y x) => Fix_F_sub (`y) (Acc_inv r (proj2_sig y))) = Fix_F_sub x r. + F_sub x (fun y:{y:A | R y x} => Fix_F_sub (`y) (Acc_inv r (proj2_sig y))) = Fix_F_sub x r. Proof. destruct r using Acc_inv_dep; auto. Qed. @@ -50,7 +50,7 @@ Section Well_founded. rewrite (proof_irrelevance (Acc R x) r s) ; auto. Qed. - Lemma Fix_eq : forall x:A, Fix_sub x = F_sub x (fun (y:A|R y x) => Fix_sub (proj1_sig y)). + Lemma Fix_eq : forall x:A, Fix_sub x = F_sub x (fun y:{ y:A | R y x} => Fix_sub (proj1_sig y)). Proof. intro x; unfold Fix_sub. rewrite <- (Fix_F_eq ). @@ -62,7 +62,8 @@ Section Well_founded. forall x : A, Fix_sub x = let f_sub := F_sub in - f_sub x (fun (y : A | R y x) => Fix_sub (`y)). + f_sub x (fun y: {y : A | R y x} => Fix_sub (`y)). + Proof. exact Fix_eq. Qed. @@ -153,7 +154,7 @@ Section Fix_rects. Hypothesis equiv_lowers: forall x0 (g h: forall x: {y: A | R y x0}, P (proj1_sig x)), - (forall x p p', g (exist (fun y: A => R y x0) x p) = h (exist _ x p')) -> + (forall x p p', g (exist (fun y: A => R y x0) x p) = h (exist (*FIXME shouldn't be needed *) (fun y => R y x0) x p')) -> f g = f h. (* From equiv_lowers, it follows that @@ -221,8 +222,6 @@ Ltac fold_sub f := Module WfExtensionality. - Require Import FunctionalExtensionality. - (** The two following lemmas allow to unfold a well-founded fixpoint definition without restriction using the functional extensionality axiom. *) @@ -231,10 +230,10 @@ Module WfExtensionality. Program Lemma fix_sub_eq_ext : forall (A : Type) (R : A -> A -> Prop) (Rwf : well_founded R) (P : A -> Type) - (F_sub : forall x : A, (forall (y : A | R y x), P y) -> P x), + (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 : A | R y x) => Fix_sub A R Rwf P F_sub y). + F_sub x (fun y:{y : A | R y x} => Fix_sub A R Rwf P F_sub (` y)). Proof. intros ; apply Fix_eq ; auto. intros. diff --git a/theories/QArith/QArith.v b/theories/QArith/QArith.v index 1a76d7e1..c32fb950 100644 --- a/theories/QArith/QArith.v +++ b/theories/QArith/QArith.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* positive -> Q := + pow_pos Qmult. Instance Qpower_positive_comp : Proper (Qeq==>eq==>Qeq) Qpower_positive. Proof. diff --git a/theories/QArith/QOrderedType.v b/theories/QArith/QOrderedType.v index dc820e75..fa0b9209 100644 --- a/theories/QArith/QOrderedType.v +++ b/theories/QArith/QOrderedType.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* q = q'. Proof. @@ -87,8 +86,8 @@ Proof. Qed. Hint Resolve Qc_is_canon. -Notation " 0 " := (!!0) : Qc_scope. -Notation " 1 " := (!!1) : Qc_scope. +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. @@ -144,15 +143,15 @@ Defined. (** The addition, multiplication and opposite are defined in the straightforward way: *) -Definition Qcplus (x y : Qc) := !!(x+y). +Definition Qcplus (x y : Qc) := Q2Qc (x+y). Infix "+" := Qcplus : Qc_scope. -Definition Qcmult (x y : Qc) := !!(x*y). +Definition Qcmult (x y : Qc) := Q2Qc (x*y). Infix "*" := Qcmult : Qc_scope. -Definition Qcopp (x : Qc) := !!(-x). +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) := !!(/x). +Definition Qcinv (x : Qc) := Q2Qc (/x). Notation "/ x" := (Qcinv x) : Qc_scope. Definition Qcdiv (x y : Qc) := x*/y. Infix "/" := Qcdiv : Qc_scope. @@ -434,14 +433,14 @@ 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 *. - repeat progress rewrite Qred_correct 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 *. - repeat progress rewrite Qred_correct in *. + rewrite !Qred_correct in *. eapply Qmult_lt_compat_r; eauto. Qed. @@ -460,13 +459,13 @@ Proof. induction n; simpl; auto with qarith. rewrite IHn; auto with qarith. Qed. - +Transparent Qred. Lemma Qcpower_0 : forall n, n<>O -> 0^n = 0. Proof. destruct n; simpl. destruct 1; auto. intros. - now apply Qc_is_canon. + now apply Qc_is_canon. Qed. Lemma Qcpower_pos : forall p n, 0 <= p -> 0 <= p^n. @@ -521,6 +520,7 @@ 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. diff --git a/theories/QArith/Qfield.v b/theories/QArith/Qfield.v index a1028ad9..083e40ae 100644 --- a/theories/QArith/Qfield.v +++ b/theories/QArith/Qfield.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 0 <= Qpower_positive p n. +Proof. intros p n Hp. induction n; simpl; repeat apply Qmult_le_0_compat;assumption. Qed. diff --git a/theories/QArith/Qreals.v b/theories/QArith/Qreals.v index 029ae8e3..add43b96 100644 --- a/theories/QArith/Qreals.v +++ b/theories/QArith/Qreals.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 0%R. +Proof. intros; apply not_O_IZR; auto with qarith. Qed. @@ -162,19 +163,19 @@ 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); unfold Qden, Qnum. -case x1. +unfold Qinv, Q2R, Qeq; intros (x1, x2). case x1; unfold Qnum, Qden. simpl; intros; elim H; trivial. -intros; field; auto. +intros; field; auto. intros; change (IZR (Zneg x2)) with (- IZR (' x2))%R; change (IZR (Zneg p)) with (- IZR (' p))%R; - field; (*auto 8 with real.*) + simpl; field; (*auto 8 with real.*) repeat split; auto; auto with real. Qed. @@ -187,25 +188,3 @@ rewrite Q2R_inv; auto. Qed. Hint Rewrite Q2R_plus Q2R_mult Q2R_opp Q2R_minus Q2R_inv Q2R_div : q2r_simpl. - -Section LegacyQField. - -(** In the past, the field tactic was not able to deal with setoid datatypes, - so translating from Q to R and applying field on reals was a workaround. - See now Qfield for a direct field tactic on Q. *) - -Ltac QField := apply eqR_Qeq; autorewrite with q2r_simpl; try field; auto. - -(** Examples of use: *) - -Let ex1 : forall x y z : Q, (x+y)*z == (x*z)+(y*z). -intros; QField. -Qed. - -Let ex2 : forall x y : Q, ~ y==0 -> (x/y)*y == x. -intros; QField. -intro; apply H; apply eqR_Qeq. -rewrite H0; unfold Q2R; simpl; field; auto with real. -Qed. - -End LegacyQField. diff --git a/theories/QArith/Qreduction.v b/theories/QArith/Qreduction.v index e8ccdee0..1d304964 100644 --- a/theories/QArith/Qreduction.v +++ b/theories/QArith/Qreduction.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* ). + 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)). pattern (sum_f_R0 An x1) at 1; rewrite <- Rplus_0_r; @@ -47,7 +45,7 @@ Proof. apply tech1; intros; apply H. apply Rmult_lt_0_compat; [ prove_sup0 | apply H ]. symmetry ; apply tech2; assumption. - rewrite b; pattern (sum_f_R0 An x) at 1; rewrite <- Rplus_0_r; + 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 @@ -68,7 +66,7 @@ Proof. 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_r with ((/ 2) ^ S (x1 - S x)). + 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; @@ -86,8 +84,8 @@ Proof. 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; replace (S x + S i)%nat with (S (S x + i)). - apply H6; unfold ge; apply tech8. + intro H4; replace (S x + S i)%nat with (S (S x + i)). + apply H4; unfold ge; apply tech8. apply INR_eq; rewrite S_INR; do 2 rewrite plus_INR; do 2 rewrite S_INR; ring. intros; unfold R_dist in H2; apply Rmult_lt_reg_l with (/ An n). apply Rinv_0_lt_compat; apply H. @@ -101,17 +99,17 @@ Proof. 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 ]. - red; intro; assert (H8 := H n); rewrite H7 in H8; + intro H5; assert (H8 := H n); rewrite H5 in H8; elim (Rlt_irrefl _ H8). replace (S x + 0)%nat with (S x); [ reflexivity | ring ]. symmetry ; apply tech2; assumption. exists (sum_f_R0 An 0); unfold EUn; exists 0%nat; reflexivity. - intro X; elim X; intros. + 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 p ]. + | apply H1 ]. Defined. Lemma Alembert_C2 : @@ -127,14 +125,12 @@ Proof. intro; cut (forall n:nat, 0 < Wn n). intro; cut (Un_cv (fun n:nat => Rabs (Vn (S n) / Vn n)) 0). intro; cut (Un_cv (fun n:nat => Rabs (Wn (S n) / Wn n)) 0). - intro; assert (H5 := Alembert_C1 Vn H1 H3). - assert (H6 := Alembert_C1 Wn H2 H4). - elim H5; intros. - elim H6; intros. + intro; 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; cut (0 < eps / 2). - intro; elim (p (eps / 2) H8); clear p; intros. - elim (p0 (eps / 2) H8); clear p0; intros. + intro H6; 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). @@ -146,9 +142,9 @@ Proof. apply Rabs_triang. rewrite Rabs_Ropp; apply Rlt_le_trans with (eps / 2 + eps / 2). apply Rplus_lt_compat. - unfold R_dist in H9; apply H9; unfold ge; apply le_trans with N; + unfold R_dist in H8; apply H8; unfold ge; apply le_trans with N; [ unfold N; apply le_max_l | assumption ]. - unfold R_dist in H10; apply H10; unfold ge; apply le_trans with N; + unfold R_dist in H9; apply H9; unfold ge; apply le_trans with N; [ unfold N; apply le_max_r | assumption ]. right; symmetry ; apply double_var. symmetry ; apply tech11; intro; unfold Vn, Wn; @@ -315,7 +311,7 @@ Proof. intro; unfold Wn; 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_r with (An n); rewrite Rplus_0_r; unfold Rminus; + apply Rplus_lt_reg_l with (An n); rewrite Rplus_0_r; unfold Rminus; rewrite (Rplus_comm (An n)); rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r; apply Rle_lt_trans with (Rabs (An n)). @@ -325,7 +321,7 @@ Proof. intro; unfold Vn; 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_r with (- An n); rewrite Rplus_0_r; unfold Rminus; + apply Rplus_lt_reg_l with (- An n); rewrite Rplus_0_r; unfold Rminus; rewrite (Rplus_comm (- An n)); rewrite Rplus_assoc; rewrite Rplus_opp_r; rewrite Rplus_0_r; apply Rle_lt_trans with (Rabs (An n)). @@ -344,9 +340,8 @@ Proof. intros; set (Bn := fun i:nat => An i * x ^ i). cut (forall n:nat, Bn n <> 0). intro; cut (Un_cv (fun n:nat => Rabs (Bn (S n) / Bn n)) 0). - intro; assert (H4 := Alembert_C2 Bn H2 H3). - elim H4; intros. - exists x0; unfold Bn in p; apply tech12; assumption. + 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). intro; elim (H1 (eps / Rabs x) H4); intros. exists x0; intros; unfold R_dist; unfold Rminus; @@ -400,15 +395,14 @@ Theorem Alembert_C3 : Un_cv (fun n:nat => Rabs (An (S n) / An n)) 0 -> { l:R | Pser An x l }. Proof. - intros; case (total_order_T x 0); intro. - elim s; intro. + intros; destruct (total_order_T x 0) as [[Hlt|Heq]|Hgt]. cut (x <> 0). intro; apply AlembertC3_step1; assumption. - red; intro; rewrite H1 in a; elim (Rlt_irrefl _ a). + 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 r; elim (Rlt_irrefl _ r). + red; intro; rewrite H1 in Hgt; elim (Rlt_irrefl _ Hgt). Defined. Lemma Alembert_C4 : @@ -432,9 +426,7 @@ Proof. unfold is_upper_bound; intros; unfold EUn in H6. elim H6; intros. rewrite H7. - assert (H8 := lt_eq_lt_dec x2 x0). - elim H8; intros. - elim a; intro. + 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)). pattern (sum_f_R0 An x2) at 1; rewrite <- Rplus_0_r. @@ -443,14 +435,14 @@ Proof. apply tech1. intros; apply H. apply Rmult_lt_0_compat. - apply Rinv_0_lt_compat; apply Rplus_lt_reg_r with x; rewrite Rplus_0_r; + apply Rinv_0_lt_compat; apply Rplus_lt_reg_l with x; rewrite Rplus_0_r; replace (x + (1 - x)) with 1; [ elim H3; intros; assumption | ring ]. apply H. symmetry ; apply tech2; assumption. - rewrite b; pattern (sum_f_R0 An x0) at 1; rewrite <- Rplus_0_r; + 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_r with x; rewrite Rplus_0_r; + apply Rinv_0_lt_compat; apply Rplus_lt_reg_l with x; rewrite Rplus_0_r; replace (x + (1 - x)) with 1; [ elim H3; intros; assumption | ring ]. apply H. replace (sum_f_R0 An x2) with @@ -466,7 +458,7 @@ Proof. left; apply H. rewrite tech3. unfold Rdiv; apply Rmult_le_reg_l with (1 - x). - apply Rplus_lt_reg_r with x; rewrite Rplus_0_r. + apply Rplus_lt_reg_l with x; rewrite Rplus_0_r. replace (x + (1 - x)) with 1; [ elim H3; intros; assumption | ring ]. do 2 rewrite (Rmult_comm (1 - x)). rewrite Rmult_assoc; rewrite <- Rinv_l_sym. @@ -480,11 +472,11 @@ Proof. elim Hyp; intros; assumption. elim H3; intros; assumption. apply Rminus_eq_contra. - red; intro. - elim H3; intros. + red; intro H10. + elim H3; intros H11 H12. rewrite H10 in H12; elim (Rlt_irrefl _ H12). - red; intro. - elim H3; intros. + red; intro H10. + elim H3; intros H11 H12. rewrite H10 in H12; elim (Rlt_irrefl _ H12). replace (An (S x0)) with (An (S x0 + 0)%nat). apply (tech6 (fun i:nat => An (S x0 + i)%nat) x). @@ -493,7 +485,7 @@ Proof. elim H3; intros; assumption. intro. cut (forall n:nat, (n >= x0)%nat -> An (S n) < x * An n). - intro. + intro H9. replace (S x0 + S i)%nat with (S (S x0 + i)). apply H9. unfold ge. @@ -515,18 +507,18 @@ Proof. apply Rmult_lt_0_compat. apply H. apply Rinv_0_lt_compat; apply H. - red; intro. + red; intro H10. assert (H11 := H n). rewrite H10 in H11; elim (Rlt_irrefl _ H11). replace (S x0 + 0)%nat with (S x0); [ reflexivity | ring ]. symmetry ; apply tech2; assumption. exists (sum_f_R0 An 0); unfold EUn; exists 0%nat; reflexivity. - intro X; elim X; intros. + 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 p ]. + | apply H1]. Qed. Lemma Alembert_C5 : @@ -586,14 +578,13 @@ Lemma Alembert_C6 : elim X; intros. exists x0. apply tech12; assumption. - case (total_order_T x 0); intro. - elim s; intro. + destruct (total_order_T x 0) as [[Hlt|Heq]|Hgt]. eapply Alembert_C5 with (k * Rabs x). split. unfold Rdiv; apply Rmult_le_pos. left; assumption. left; apply Rabs_pos_lt. - red; intro; rewrite H3 in a; elim (Rlt_irrefl _ a). + red; intro; rewrite H3 in Hlt; elim (Rlt_irrefl _ Hlt). apply Rmult_lt_reg_l with (/ k). apply Rinv_0_lt_compat; assumption. rewrite <- Rmult_assoc. @@ -604,7 +595,7 @@ Lemma Alembert_C6 : intro; apply prod_neq_R0. apply H0. apply pow_nonzero. - red; intro; rewrite H3 in a; elim (Rlt_irrefl _ a). + red; intro; rewrite H3 in Hlt; elim (Rlt_irrefl _ Hlt). unfold Un_cv; unfold Un_cv in H1. intros. cut (0 < eps / Rabs x). @@ -621,7 +612,7 @@ Lemma Alembert_C6 : rewrite Rabs_Rabsolu. apply Rmult_lt_reg_l with (/ Rabs x). apply Rinv_0_lt_compat; apply Rabs_pos_lt. - red; intro; rewrite H7 in a; elim (Rlt_irrefl _ a). + red; intro; rewrite H7 in Hlt; elim (Rlt_irrefl _ Hlt). rewrite <- Rmult_assoc. rewrite <- Rinv_l_sym. rewrite Rmult_1_l. @@ -629,7 +620,7 @@ Lemma Alembert_C6 : unfold R_dist in H5. unfold Rdiv; unfold Rdiv in H5; apply H5; assumption. apply Rabs_no_R0. - red; intro; rewrite H7 in a; elim (Rlt_irrefl _ a). + red; intro; rewrite H7 in Hlt; elim (Rlt_irrefl _ Hlt). unfold Rdiv; replace (S n) with (n + 1)%nat; [ idtac | ring ]. rewrite pow_add. simpl. @@ -641,14 +632,14 @@ Lemma Alembert_C6 : rewrite <- Rinv_r_sym. rewrite Rmult_1_r; reflexivity. apply pow_nonzero. - red; intro; rewrite H7 in a; elim (Rlt_irrefl _ a). + red; intro; rewrite H7 in Hlt; elim (Rlt_irrefl _ Hlt). apply H0. apply pow_nonzero. - red; intro; rewrite H7 in a; elim (Rlt_irrefl _ a). + red; intro; rewrite H7 in Hlt; elim (Rlt_irrefl _ Hlt). unfold Rdiv; apply Rmult_lt_0_compat. assumption. apply Rinv_0_lt_compat; apply Rabs_pos_lt. - red; intro H7; rewrite H7 in a; elim (Rlt_irrefl _ a). + red; intro H7; rewrite H7 in Hlt; elim (Rlt_irrefl _ Hlt). exists (An 0%nat). unfold Un_cv. intros. @@ -661,14 +652,14 @@ Lemma Alembert_C6 : simpl; ring. rewrite tech5. rewrite <- Hrecn. - rewrite b; simpl; ring. + rewrite Heq; simpl; ring. unfold ge; apply le_O_n. eapply Alembert_C5 with (k * Rabs x). split. unfold Rdiv; apply Rmult_le_pos. left; assumption. left; apply Rabs_pos_lt. - red; intro; rewrite H3 in r; elim (Rlt_irrefl _ r). + red; intro; rewrite H3 in Hgt; elim (Rlt_irrefl _ Hgt). apply Rmult_lt_reg_l with (/ k). apply Rinv_0_lt_compat; assumption. rewrite <- Rmult_assoc. @@ -679,7 +670,7 @@ Lemma Alembert_C6 : intro; apply prod_neq_R0. apply H0. apply pow_nonzero. - red; intro; rewrite H3 in r; elim (Rlt_irrefl _ r). + red; intro; rewrite H3 in Hgt; elim (Rlt_irrefl _ Hgt). unfold Un_cv; unfold Un_cv in H1. intros. cut (0 < eps / Rabs x). @@ -696,7 +687,7 @@ Lemma Alembert_C6 : rewrite Rabs_Rabsolu. apply Rmult_lt_reg_l with (/ Rabs x). apply Rinv_0_lt_compat; apply Rabs_pos_lt. - red; intro; rewrite H7 in r; elim (Rlt_irrefl _ r). + red; intro; rewrite H7 in Hgt; elim (Rlt_irrefl _ Hgt). rewrite <- Rmult_assoc. rewrite <- Rinv_l_sym. rewrite Rmult_1_l. @@ -704,7 +695,7 @@ Lemma Alembert_C6 : unfold R_dist in H5. unfold Rdiv; unfold Rdiv in H5; apply H5; assumption. apply Rabs_no_R0. - red; intro; rewrite H7 in r; elim (Rlt_irrefl _ r). + red; intro; rewrite H7 in Hgt; elim (Rlt_irrefl _ Hgt). unfold Rdiv; replace (S n) with (n + 1)%nat; [ idtac | ring ]. rewrite pow_add. simpl. @@ -716,12 +707,12 @@ Lemma Alembert_C6 : rewrite <- Rinv_r_sym. rewrite Rmult_1_r; reflexivity. apply pow_nonzero. - red; intro; rewrite H7 in r; elim (Rlt_irrefl _ r). + red; intro; rewrite H7 in Hgt; elim (Rlt_irrefl _ Hgt). apply H0. apply pow_nonzero. - red; intro; rewrite H7 in r; elim (Rlt_irrefl _ r). + red; intro; rewrite H7 in Hgt; elim (Rlt_irrefl _ Hgt). unfold Rdiv; apply Rmult_lt_0_compat. assumption. apply Rinv_0_lt_compat; apply Rabs_pos_lt. - red; intro H7; rewrite H7 in r; elim (Rlt_irrefl _ r). + red; intro H7; rewrite H7 in Hgt; elim (Rlt_irrefl _ Hgt). Qed. diff --git a/theories/Reals/AltSeries.v b/theories/Reals/AltSeries.v index 6d54b791..3e99c989 100644 --- a/theories/Reals/AltSeries.v +++ b/theories/Reals/AltSeries.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* (-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 H2; assumption. +apply H0; assumption. apply sum_eq. intros. replace ((x * x) ^ i) with (x ^ (2 * i)). reflexivity. apply pow_sqr. -unfold cos. -case (exist_cos (Rsqr x)). -unfold Rsqr; intros. -unfold cos_in in p_i. -unfold cos_in in c. -apply uniqueness_sum with (fun i:nat => cos_n i * (x * x) ^ i); assumption. Qed. Lemma C1_cvg : forall x y:R, Un_cv (C1 x y) (cos (x + y)). intros. -assert (H := exist_cos ((x + y) * (x + y))). -elim H; intros. -assert (p_i := p). -unfold cos_in in p. -unfold cos_n, infinite_sum in p. -unfold R_dist in p. -cut (cos (x + y) = x0). -intro. -rewrite H0. -unfold Un_cv; unfold R_dist; intros. -elim (p eps H1); intros. +unfold cos. +destruct (exist_cos (Rsqr (x + y))) as (x0,p). +unfold cos_in, cos_n, infinite_sum, R_dist in p. +unfold Un_cv, R_dist; intros. +destruct (p eps H) as (x1,H0). exists x1; intros. unfold C1. replace @@ -307,19 +289,12 @@ replace with (sum_f_R0 (fun i:nat => (-1) ^ i / INR (fact (2 * i)) * ((x + y) * (x + y)) ^ i) n). -apply H2; assumption. +apply H0; assumption. apply sum_eq. intros. replace (((x + y) * (x + y)) ^ i) with ((x + y) ^ (2 * i)). reflexivity. apply pow_sqr. -unfold cos. -case (exist_cos (Rsqr (x + y))). -unfold Rsqr; intros. -unfold cos_in in p_i. -unfold cos_in in c. -apply uniqueness_sum with (fun i:nat => cos_n i * ((x + y) * (x + y)) ^ i); - assumption. Qed. Lemma B1_cvg : forall x:R, Un_cv (B1 x) (sin x). @@ -338,21 +313,14 @@ simpl; ring. rewrite tech5; rewrite <- Hrecn. simpl; ring. unfold ge; apply le_O_n. -assert (H0 := exist_sin (x * x)). -elim H0; intros. -assert (p_i := p). -unfold sin_in in p. -unfold sin_n, infinite_sum in p. -unfold R_dist in p. -cut (sin x = x * x0). -intro. -rewrite H1. -unfold Un_cv; unfold R_dist; intros. +unfold sin. destruct (exist_sin (Rsqr x)) as (x0,p). +unfold sin_in, sin_n, infinite_sum, R_dist in p. +unfold Un_cv, R_dist; 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 ] ]. -elim (p (eps / Rabs x) H3); intros. +destruct (p (eps / Rabs x) H1) as (x1,H2). exists x1; intros. unfold B1. replace @@ -370,9 +338,7 @@ replace rewrite Rabs_mult. apply Rmult_lt_reg_l with (/ Rabs x). apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption. -rewrite <- Rmult_assoc. -rewrite <- Rinv_l_sym. -rewrite Rmult_1_l; rewrite <- (Rmult_comm eps); unfold Rdiv in H4; apply H4; +rewrite <- Rmult_assoc, <- Rinv_l_sym, Rmult_1_l, <- (Rmult_comm eps). apply H2; assumption. apply Rabs_no_R0; assumption. rewrite scal_sum. @@ -382,12 +348,4 @@ rewrite pow_add. rewrite pow_sqr. simpl. ring. -unfold sin. -case (exist_sin (Rsqr x)). -unfold Rsqr; intros. -unfold sin_in in p_i. -unfold sin_in in s. -assert - (H1 := uniqueness_sum (fun i:nat => sin_n i * (x * x) ^ i) x0 x1 p_i s). -rewrite H1; reflexivity. Qed. diff --git a/theories/Reals/DiscrR.v b/theories/Reals/DiscrR.v index 3a2d51f9..75fd4c0a 100644 --- a/theories/Reals/DiscrR.v +++ b/theories/Reals/DiscrR.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* IZR z1 = IZR z2. +Proof. intros; rewrite H; reflexivity. Qed. Lemma IZR_neq : forall z1 z2:Z, z1 <> z2 -> IZR z1 <> IZR z2. +Proof. intros; red; intro; elim H; apply eq_IZR; assumption. Qed. diff --git a/theories/Reals/Exp_prop.v b/theories/Reals/Exp_prop.v index 0d418bc3..be96b94e 100644 --- a/theories/Reals/Exp_prop.v +++ b/theories/Reals/Exp_prop.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* (0 < div2 N)%nat. Proof. - intros; induction N as [| N HrecN]. - elim (lt_n_O _ H). - cut ((1 < N)%nat \/ N = 1%nat). - intro; elim H0; intro. - assert (H2 := even_odd_dec N). - elim H2; intro. - rewrite <- (even_div2 _ a); apply HrecN; assumption. - rewrite <- (odd_div2 _ b); apply lt_O_Sn. - rewrite H1; simpl; apply lt_O_Sn. - inversion H. - right; reflexivity. - left; apply lt_le_trans with 2%nat; [ apply lt_n_Sn | apply H1 ]. + intros; induction N as [| N HrecN]. + - elim (lt_n_O _ H). + - cut ((1 < N)%nat \/ N = 1%nat). + { intro; elim H0; intro. + + destruct (even_odd_dec N) as [Heq|Heq]. + * rewrite <- (even_div2 _ Heq); apply HrecN; assumption. + * rewrite <- (odd_div2 _ Heq); apply lt_O_Sn. + + rewrite H1; simpl; apply lt_O_Sn. } + inversion H. + right; reflexivity. + left; apply lt_le_trans with 2%nat; [ apply lt_n_Sn | apply H1 ]. Qed. Lemma Reste_E_maj : @@ -173,8 +173,7 @@ Proof. 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 Rle_Rinv. - apply INR_fact_lt_0. + apply Rinv_le_contravar. apply INR_fact_lt_0. apply le_INR; apply fact_le; apply le_n_S. apply le_plus_l. @@ -254,8 +253,7 @@ Proof. 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 Rle_Rinv. - apply INR_fact_lt_0. + apply Rinv_le_contravar. apply INR_fact_lt_0. apply le_INR. apply fact_le. @@ -724,15 +722,14 @@ Qed. (**********) Lemma exp_pos : forall x:R, 0 < exp x. Proof. - intro; case (total_order_T 0 x); intro. - elim s; intro. - apply (exp_pos_pos _ a). - rewrite <- b; rewrite exp_0; apply Rlt_0_1. + 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 _ r). + 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_sym. @@ -773,10 +770,10 @@ Proof. apply (not_eq_sym H6). rewrite Rminus_0_r; apply H7. unfold SFL. - case (cv 0); intros. + case (cv 0) as (x,Hu). eapply UL_sequence. - apply u. - unfold Un_cv, SP. + apply Hu. + unfold Un_cv, SP in |- *. intros; exists 1%nat; intros. unfold R_dist; rewrite decomp_sum. rewrite (Rplus_comm (fn 0%nat 0)). @@ -793,14 +790,13 @@ Proof. unfold Rdiv; rewrite Rinv_1; rewrite Rmult_1_r; reflexivity. apply lt_le_trans with 1%nat; [ apply lt_n_Sn | apply H9 ]. unfold SFL, exp. - case (cv h); case (exist_exp h); simpl; intros. + case (cv h) as (x0,Hu); case (exist_exp h) as (x,Hexp); simpl. eapply UL_sequence. - apply u. + apply Hu. unfold Un_cv; intros. - unfold exp_in in e. - unfold infinite_sum in e. + unfold exp_in, infinite_sum in Hexp. cut (0 < eps0 * Rabs h). - intro; elim (e _ H9); intros N0 H10. + intro; elim (Hexp _ H9); intros N0 H10. exists N0; intros. unfold R_dist. apply Rmult_lt_reg_l with (Rabs h). @@ -860,8 +856,7 @@ Proof. Un_cv (fun n:nat => sum_f_R0 (fun k:nat => Rabs (r ^ k / INR (fact (S k)))) n) l }. - intro X. - elim X; intros. + intros (x,p). exists x; intros. split. apply p. diff --git a/theories/Reals/Integration.v b/theories/Reals/Integration.v index 50b57374..222d106f 100644 --- a/theories/Reals/Integration.v +++ b/theories/Reals/Integration.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* false). - split. - exact Rplus_comm. - symmetry ; apply Rplus_assoc. - exact Rmult_comm. - symmetry ; apply Rmult_assoc. - intro; apply Rplus_0_l. - intro; apply Rmult_1_l. - exact Rplus_opp_r. - intros. - rewrite Rmult_comm. - rewrite (Rmult_comm n p). - rewrite (Rmult_comm m p). - apply Rmult_plus_distr_l. - intros; contradiction. -Defined. - -End LegacyRfield. - -Add Legacy Field -R Rplus Rmult 1%R 0%R Ropp (fun x y:R => false) Rinv RLegacyTheory Rinv_l - with minus := Rminus div := Rdiv. diff --git a/theories/Reals/MVT.v b/theories/Reals/MVT.v index d3970069..59976957 100644 --- a/theories/Reals/MVT.v +++ b/theories/Reals/MVT.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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). - elim H2; intros c H3; elim H3; intros. + destruct H2 as (c & P & H4). exists c; split. - cut (derive_pt id c (X0 c x) = derive_pt id c (derivable_pt_id c)); - [ intro | apply pr_nu ]. + 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 x)) with (derive_pt f c (pr c)); + 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 x. + apply P. Qed. Theorem MVT_cor2 : @@ -173,14 +173,14 @@ Proof. intro; cut (forall c:R, a <= c <= b -> derivable_pt id c). intro X1; cut (forall c:R, a < c < b -> derivable_pt id c). 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; elim H3; clear H3; intros; - exists x; split. - cut (derive_pt id x (X2 x x0) = 1). - cut (derive_pt f x (X0 x x0) = f' x). + 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). + 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 x0; intros; split; left; 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. @@ -217,12 +217,12 @@ Proof. 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. - elim (H3 H4); intros; elim H5; intros; exists x; exists x0; 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; rewrite H7 in H0; - elim (Rlt_irrefl _ H0) ]. + 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. (**********) @@ -233,21 +233,18 @@ Proof. intros. unfold increasing. intros. - case (total_order_T x y); intro. - elim s; intro. + destruct (total_order_T x y) as [[H1| ->]|H1]. apply Rplus_le_reg_l with (- f x). rewrite Rplus_opp_l; rewrite Rplus_comm. - assert (H1 := MVT_cor1 f _ _ pr a). - elim H1; intros. - elim H2; intros. + 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 ]. - rewrite b; right; reflexivity. - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H0 r)). + right; reflexivity. + elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H0 H1)). Qed. (**********) @@ -269,7 +266,7 @@ Proof. cut ((f (x + delta / 2) - f x) / (delta / 2) <= 0). 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)). + case (Rcase_abs ((f (x + delta / 2) - f x) / (delta / 2) - l)) as [Hlt|Hge]. intros; generalize (Rplus_lt_compat_r (- l) (- ((f (x + delta / 2) - f x) / (delta / 2) - l)) @@ -294,7 +291,7 @@ Proof. ring. intros. generalize - (Ropp_ge_le_contravar ((f (x + delta / 2) - f x) / (delta / 2) - l) 0 r). + (Ropp_ge_le_contravar ((f (x + delta / 2) - f x) / (delta / 2) - l) _ Hge). rewrite Ropp_0. intro. elim @@ -412,7 +409,7 @@ Proof. intros. unfold strict_increasing. intros. - apply Rplus_lt_reg_r with (- f x). + 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. @@ -421,7 +418,7 @@ Proof. rewrite H3. apply Rmult_lt_0_compat. apply H. - apply Rplus_lt_reg_r with x. + apply Rplus_lt_reg_l with x. rewrite Rplus_0_r; replace (x + (y + - x)) with y; [ assumption | ring ]. Qed. @@ -517,7 +514,7 @@ Lemma derive_increasing_interv_ax : Proof. intros. split; intros. - apply Rplus_lt_reg_r with (- f x). + 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. @@ -532,7 +529,7 @@ Proof. apply Rle_lt_trans with x; assumption. elim H2; intros. apply Rlt_le_trans with y; assumption. - apply Rplus_lt_reg_r with x. + apply Rplus_lt_reg_l with x. rewrite Rplus_0_r; replace (x + (y + - x)) with y; [ assumption | ring ]. apply Rplus_le_reg_l with (- f x). rewrite Rplus_opp_l; rewrite Rplus_comm. @@ -587,12 +584,8 @@ Theorem IAF : f b - f a <= k * (b - a). Proof. intros. - case (total_order_T a b); intro. - elim s; intro. - assert (H1 := MVT_cor1 f _ _ pr a0). - elim H1; intros. - elim H2; intros. - rewrite H3. + 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. @@ -600,10 +593,9 @@ Proof. apply H0. elim H4; intros. split; left; assumption. - rewrite b0. unfold Rminus; do 2 rewrite Rplus_opp_r. rewrite Rmult_0_r; right; reflexivity. - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H r)). + elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H H1)). Qed. Lemma IAF_var : @@ -648,8 +640,7 @@ Lemma null_derivative_loc : (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; case (total_order_T a b); intro. - elim s; intro. + 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). @@ -664,24 +655,25 @@ Proof. 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). - elim H7; intros; elim H8; intros; assert (H10 : a < x0 < b). - elim x1; intros; split. - assumption. - apply Rlt_le_trans with x; assumption. - assert (H11 : derive_pt f x0 (H4 x0 x1) = 0). - replace (derive_pt f x0 (H4 x0 x1)) with (derive_pt f x0 (pr x0 H10)); + 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 x0 (H2 x0 x1) = 1). + 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 <- b0 in H1; elim H1; intros; apply Rle_antisym; assumption. + 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) r)). + elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ (Rle_trans _ _ _ H2 H3) Hgt)). Qed. (* Unicity of the antiderivative *) @@ -718,3 +710,32 @@ Proof. 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/theories/Reals/Machin.v b/theories/Reals/Machin.v index 40a857e3..1a94f6a8 100644 --- a/theories/Reals/Machin.v +++ b/theories/Reals/Machin.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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. @@ -44,6 +46,7 @@ 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). @@ -67,6 +70,7 @@ 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)). @@ -77,6 +81,7 @@ 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; fourier | apply tech; try split; fourier | @@ -105,6 +110,7 @@ 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; fourier | apply tech; try split; fourier | diff --git a/theories/Reals/NewtonInt.v b/theories/Reals/NewtonInt.v index 8faf3b41..832e7adc 100644 --- a/theories/Reals/NewtonInt.v +++ b/theories/Reals/NewtonInt.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* R) (a:R), NewtonInt f a a (NewtonInt_P1 f a) = 0. Proof. intros; unfold NewtonInt; simpl; - unfold mult_fct, fct_cte, id; ring. + 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 *) @@ -87,42 +89,7 @@ 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; unfold Newton_integrable in pr; elim pr; intros; elim p; intro. - unfold NewtonInt; - case - (NewtonInt_P3 f a b - (exist - (fun g:R -> R => antiderivative f g a b \/ antiderivative f g b a) x - p)). - intros; elim o; intro. - unfold antiderivative in H0; elim H0; intros; elim H2; intro. - unfold antiderivative in H; elim H; intros; - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H5 H3)). - rewrite H3; ring. - assert (H1 := antiderivative_Ucte f x x0 a b H H0); elim H1; intros; - unfold antiderivative in H0; elim H0; clear H0; intros _ H0. - assert (H3 : a <= a <= b). - split; [ right; reflexivity | assumption ]. - assert (H4 : a <= b <= b). - split; [ assumption | right; reflexivity ]. - assert (H5 := H2 _ H3); assert (H6 := H2 _ H4); rewrite H5; rewrite H6; ring. - unfold NewtonInt; - case - (NewtonInt_P3 f a b - (exist - (fun g:R -> R => antiderivative f g a b \/ antiderivative f g b a) x - p)); intros; elim o; intro. - assert (H1 := antiderivative_Ucte f x x0 b a H H0); elim H1; intros; - unfold antiderivative in H0; elim H0; clear H0; intros _ H0. - assert (H3 : b <= a <= a). - split; [ assumption | right; reflexivity ]. - assert (H4 : b <= b <= a). - split; [ right; reflexivity | assumption ]. - assert (H5 := H2 _ H3); assert (H6 := H2 _ H4); rewrite H5; rewrite H6; ring. - unfold antiderivative in H0; elim H0; intros; elim H2; intro. - unfold antiderivative in H; elim H; intros; - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H5 H3)). - rewrite H3; ring. + intros f a b (x,H). unfold NewtonInt, NewtonInt_P3; simpl; ring. Qed. (* The set of Newton integrable functions is a vectorial space *) @@ -133,7 +100,7 @@ Lemma NewtonInt_P5 : 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; elim X0; intros; + 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. @@ -227,10 +194,8 @@ Lemma NewtonInt_P6 : l * NewtonInt f a b pr1 + NewtonInt g a b pr2. Proof. intros f g l a b pr1 pr2; unfold NewtonInt; - case (NewtonInt_P5 f g l a b pr1 pr2); intros; case pr1; - intros; case pr2; intros; case (total_order_T a b); - intro. - elim s; intro. + 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. elim o0; intro. elim o1; intro. @@ -242,21 +207,21 @@ Proof. split; [ left; assumption | right; reflexivity ]. assert (H7 := H4 _ H5); assert (H8 := H4 _ H6); rewrite H7; rewrite H8; ring. unfold antiderivative in H1; elim H1; intros; - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H3 a0)). + elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H3 Hlt)). unfold antiderivative in H0; elim H0; intros; - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H2 a0)). + elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H2 Hlt)). unfold antiderivative in H; elim H; intros; - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H1 a0)). - rewrite b0; ring. + elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H1 Hlt)). + rewrite Heq; ring. elim o; intro. unfold antiderivative in H; elim H; intros; - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H1 r)). + 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 r)). + 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 r)). + 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). @@ -277,14 +242,12 @@ Lemma antiderivative_P2 : | right _ => F1 x + (F0 b - F1 b) end) a c. Proof. - unfold antiderivative; intros; elim H; clear H; intros; elim H0; - clear H0; intros; split. + intros; destruct H as (H,H1), H0 as (H0,H2); split. 2: apply Rle_trans with b; assumption. - intros; elim H3; clear H3; intros; case (total_order_T x b); intro. - elim s; intro. + intros x (H3,H4); destruct (total_order_T x b) as [[Hlt|Heq]|Hgt]. assert (H5 : a <= x <= b). split; [ assumption | left; assumption ]. - assert (H6 := H _ H5); elim H6; clear H6; intros; + destruct (H _ H5) as (x0,H6). assert (H7 : derivable_pt_lim @@ -293,27 +256,26 @@ Proof. | left _ => F0 x | right _ => F1 x + (F0 b - F1 b) end) x (f x)). - unfold derivable_pt_lim; assert (H7 : derive_pt F0 x x0 = f x). - symmetry ; assumption. - assert (H8 := derive_pt_eq_1 F0 x (f x) x0 H7); unfold derivable_pt_lim in H8; - intros; elim (H8 _ H9); intros; set (D := Rmin x1 (b - 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; unfold Rmin; case (Rle_dec x1 (b - x)); intro. + unfold D, Rmin; case (Rle_dec x1 (b - x)); intro. apply (cond_pos x1). apply Rlt_Rminus; assumption. - exists (mkposreal _ H11); intros; case (Rle_dec x b); intro. - case (Rle_dec (x + h) b); intro. + exists (mkposreal _ H11); intros h H12 H13. case (Rle_dec x b) as [|[]]. + case (Rle_dec (x + h) b) as [|[]]. apply H10. assumption. apply Rlt_le_trans with D; [ assumption | unfold D; apply Rmin_l ]. - elim n; left; apply Rlt_le_trans with (x + D). + 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. - elim n; left; assumption. + left; assumption. assert (H8 : derivable_pt @@ -348,7 +310,7 @@ Proof. 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); intro. + exists (mkposreal _ H16); intros; case (Rle_dec x b) as [|[]]. case (Rle_dec (x + h) b); intro. apply H15. assumption. @@ -357,8 +319,8 @@ Proof. apply H14. assumption. apply Rlt_le_trans with D; [ assumption | unfold D; apply Rmin_l ]. - rewrite b0; ring. - elim n; right; assumption. + rewrite Heq; ring. + right; assumption. assert (H14 : derivable_pt @@ -388,12 +350,12 @@ Proof. unfold D; unfold Rmin; case (Rle_dec x1 (x - b)); intro. apply (cond_pos x1). apply Rlt_Rminus; assumption. - exists (mkposreal _ H11); intros; case (Rle_dec x b); intro. - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r0 r)). - case (Rle_dec (x + h) b); intro. + 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 _ _ _ r0 H14)). - apply Rplus_lt_reg_r with (- h - b); replace (- h - b + b) with (- 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. @@ -425,8 +387,7 @@ Lemma antiderivative_P3 : 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; case (total_order_T a c); intro. - elim s; intro. + 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 ]. @@ -448,8 +409,7 @@ Lemma antiderivative_P4 : 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; case (total_order_T c b); intro. - elim s; intro. + 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 ]. @@ -499,10 +459,8 @@ Proof. intros. elim X; intros F0 H0. elim X0; intros F1 H1. - case (total_order_T a b); intro. - elim s; intro. - case (total_order_T b c); intro. - elim s0; intro. + destruct (total_order_T a b) as [[Hlt|Heq]|Hgt]. + destruct (total_order_T b c) as [[Hlt'|Heq']|Hgt']. (* ac *) - case (total_order_T a c); intro. - elim s0; intro. + 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 r)). + 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 a1)). + 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 a0)). - rewrite b0; apply NewtonInt_P1. + 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 r)). + 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 r0)). + 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 a0)). + elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H2 Hlt)). (* a=b *) - rewrite b0; apply X0. - case (total_order_T b c); intro. - elim s; intro. + rewrite Heq; apply X0. + destruct (total_order_T b c) as [[Hlt'|Heq']|Hgt']. (* a>b & bb & b=c *) - rewrite b0 in X; apply X. + 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. -Defined. +Qed. (* Chasles' relation *) Lemma NewtonInt_P9 : @@ -602,17 +557,15 @@ Lemma NewtonInt_P9 : NewtonInt f a b pr1 + NewtonInt f b c pr2. Proof. intros; unfold NewtonInt. - case (NewtonInt_P8 f a b c pr1 pr2); intros. - case pr1; intros. - case pr2; intros. - case (total_order_T a b); intro. - elim s; intro. - case (total_order_T b c); intro. - elim s0; intro. + 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']. (* ac *) - elim o1; intro. + elim Hor1; intro. unfold antiderivative in H; elim H; clear H; intros _ H. - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H r)). - elim o0; intro. - elim o; intro. + elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H Hgt')). + elim Hor0; intro. + 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). - case (Rle_dec b c); intro. - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r0 r)). - case (Rle_dec a c); intro. + 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 n0; unfold antiderivative in H1; elim H1; intros; assumption. + 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). @@ -679,19 +632,19 @@ Proof. elim H3; intros. rewrite (H4 c). rewrite (H4 b). - case (Rle_dec b a); intro. - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r0 a0)). - case (Rle_dec c a); intro. + destruct (Rle_dec b a) as [Hle|Hnle]. + elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ Hle Hlt)). + destruct (Rle_dec c a) as [Hle'|[]]. ring. - elim n0; unfold antiderivative in H1; elim H1; intros; assumption. + unfold antiderivative in H1; elim H1; intros; assumption. split; [ left; assumption | right; reflexivity ]. split; [ right; reflexivity | left; assumption ]. unfold antiderivative in H0; elim H0; clear H0; intros _ H0. - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H0 a0)). + elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H0 Hlt)). (* a=b *) - rewrite b0 in o; rewrite b0. - elim o; intro. - elim o1; intro. + 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). @@ -705,7 +658,7 @@ Proof. unfold antiderivative in H, H0; elim H; elim H0; intros; apply Rle_antisym; assumption. rewrite H1; ring. - elim o1; intro. + elim Hor1; intro. assert (H1 : b = c). unfold antiderivative in H, H0; elim H; elim H0; intros; apply Rle_antisym; assumption. @@ -720,25 +673,24 @@ Proof. split; [ assumption | right; reflexivity ]. split; [ right; reflexivity | assumption ]. (* a>b & bb & b=c *) - rewrite <- b0. + rewrite <- Heq'. unfold Rminus; rewrite Rplus_opp_r; rewrite Rplus_0_r. - rewrite <- b0 in o. - elim o0; intro. + rewrite <- Heq' in Hor. + elim Hor0; intro. unfold antiderivative in H; elim H; clear H; intros _ H. - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H r)). - elim o; intro. + 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 r)). + 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). @@ -775,15 +727,15 @@ Proof. split; [ left; assumption | right; reflexivity ]. split; [ right; reflexivity | left; assumption ]. (* a>b & b>c *) - elim o0; intro. + elim Hor0; intro. unfold antiderivative in H; elim H; clear H; intros _ H. - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H r)). - elim o1; intro. + 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 r0)). - elim o; intro. + 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 _ _ _ r0 r))). + 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. @@ -791,11 +743,11 @@ Proof. unfold antiderivative in H1; elim H1; intros; assumption. rewrite (H4 c). rewrite (H4 a). - case (Rle_dec a b); intro. - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r1 r)). - case (Rle_dec c b); intro. + destruct (Rle_dec a b) as [Hle|Hnle]. + elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ Hle Hgt)). + destruct (Rle_dec c b) as [|[]]. ring. - elim n0; left; assumption. + left; assumption. split; [ assumption | right; reflexivity ]. split; [ right; reflexivity | assumption ]. Qed. diff --git a/theories/Reals/PSeries_reg.v b/theories/Reals/PSeries_reg.v index 199c2014..30a26f77 100644 --- a/theories/Reals/PSeries_reg.v +++ b/theories/Reals/PSeries_reg.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* Boule c d y -> x <= z <= y -> Boule c d z. +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}}. +exists ((x + y)/2). +assert (radius : 0 < (y - x)/2). + unfold Rdiv; apply Rmult_lt_0_compat. + apply Rlt_Rminus; 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}. +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_Rminus; 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 := @@ -153,7 +257,7 @@ Proof. 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_r with (- Rabs (x - y)). + 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)). replace (- Rabs (x - y) + (Rabs h + Rabs (x - y))) with (Rabs h). @@ -161,7 +265,7 @@ Proof. ring. ring. unfold Boule in H1; rewrite <- (Rabs_Ropp (x - y)); rewrite Ropp_minus_distr'; - apply Rplus_lt_reg_r with (Rabs (y - x)). + 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 ]. Qed. @@ -258,3 +362,242 @@ Proof. rewrite <- Rplus_0_r; apply Rplus_lt_compat_l; apply Rlt_0_1. apply Rplus_le_lt_0_compat; [ apply Rabs_pos | apply Rlt_0_1 ]. 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). +intros f g c d cvu x bx eps ep; destruct (cvu eps ep) as [N Pn]. + exists N; intros n nN; rewrite R_dist_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. +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). +intros f f' g g' c d cvu cvp dff' x bx. +set (rho_ := + fun n y => + if Req_EM_T y x then + f' n x + else ((f n y - f n x)/ (y - x))). +set (rho := fun y => + if Req_EM_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_EM_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_EM_T z' x) as [abs | _]. + case xnz'; symmetry; exact abs. + destruct (Req_EM_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, + R_dist 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_EM_T y x) as [xy | xny]. + rewrite xy in dyz. + destruct (Rle_dec delta (Rabs (z - x))). + rewrite Rmin_left, R_dist_sym in dyz; unfold R_dist in dyz; fourier. + rewrite Rmin_right, R_dist_sym in dyz; unfold R_dist 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. + apply continuity_pt_minus. + apply derivable_continuous_pt; eapply exist; apply dff'; assumption. + apply continuity_pt_const; intro; intro; reflexivity. + apply continuity_pt_minus; + [apply derivable_continuous_pt; exists 1; apply derivable_pt_lim_id + | apply continuity_pt_const; intro; reflexivity]. + intros zx0; case xnz; replace z with (z - x + x) by ring. + rewrite zx0, Rplus_0_l; reflexivity. +assert (CVU rho_ rho c d ). + intros eps ep. + assert (ep8 : 0 < eps/8). + fourier. + 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 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 := R_dist_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 R_dist_sym; apply Rlt_le, Pd;split;[split;[exact I | ] | ]. + apply Rminus_not_eq_right; rewrite Rplus_comm; unfold Rminus; + rewrite Rplus_assoc, Rplus_opp_r, Rplus_0_r; apply Rgt_not_eq; assumption. + simpl; unfold R_dist. + 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);[fourier | ]. + apply Rle_trans with (Rmin d' d2); apply Rmin_l. + apply Rle_trans with (1 := R_dist_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)). + 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)). + apply step_2; auto; try fourier. + 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 fourier; auto. + split; try fourier. + apply Rplus_le_compat_l, Rmult_le_compat_r;[ | apply Rmin_r]. + now apply Rlt_le, Rinv_0_lt_compat, Rlt_0_2. + apply Rminus_not_eq_right; rewrite xy; apply Rgt_not_eq; fourier. + unfold rho_. + destruct (Req_EM_T (y + Rmin (Rmin d' d2) delta/2) x) as [ymx | ymnx]. + case (RIneq.Rle_not_lt _ _ (Req_le _ _ ymx)); fourier. + reflexivity. + unfold rho_. + destruct (Req_EM_T (y + Rmin (Rmin d' d2) delta / 2) x) as [ymx | ymnx]. + case (RIneq.Rle_not_lt _ _ (Req_le _ _ ymx)); fourier. + reflexivity. + apply Rlt_le, Pd2; split;[split;[exact I | apply Rlt_not_eq; fourier] | ]. + simpl; unfold R_dist. + unfold Rminus; rewrite (Rplus_comm y), Rplus_assoc, Rplus_opp_r, Rplus_0_r. + rewrite Rabs_pos_eq;[ | fourier]. + apply Rlt_le_trans with (Rmin (Rmin d' d2) delta); [fourier |]. + apply Rle_trans with (Rmin d' d2). + solve[apply Rmin_l]. + solve[apply Rmin_r]. + apply Rlt_le, Rlt_le_trans with (eps/4);[ | fourier]. + unfold rho_; destruct (Req_EM_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_EM_T y x). + intros eps' ep'; destruct (cvu eps' ep') as [N2 Pn2]. + exists N2; intros n nN2; rewrite R_dist_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 R_dist_eq; assumption. + intros p pN y b_y. + replace eps with (eps/2 + eps/2) by field. + assert (ep2 : 0 < eps/2) by fourier. + destruct (cvrho y b_y _ ep2) as [N2 Pn2]. + apply Rle_lt_trans with (1 := R_dist_tri _ _ (rho_ (max N N2) y)). + apply Rplus_lt_le_compat. + solve[rewrite R_dist_sym; apply Pn2, Max.le_max_r]. + apply unif_ac; auto; solve [apply Max.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 R_dist; replace (x + h - x) with h by ring; exact dh. + unfold rho; destruct (Req_EM_T x x) as [ _ | abs];[ | case abs]; reflexivity. +unfold rho; destruct (Req_EM_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/theories/Reals/PartSum.v b/theories/Reals/PartSum.v index 364d72cb..b710c75c 100644 --- a/theories/Reals/PartSum.v +++ b/theories/Reals/PartSum.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* Rabs (An i)) m)). assumption. apply H1; assumption. - assert (H4 := lt_eq_lt_dec n m). - elim H4; intro. - elim a; intro. + 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 R_dist. @@ -418,7 +413,6 @@ Proof. apply Rle_ge. apply cond_pos_sum. intro; apply Rabs_pos. - rewrite b. unfold R_dist. unfold Rminus; do 2 rewrite Rplus_opp_r. rewrite Rabs_R0; right; reflexivity. @@ -451,8 +445,7 @@ Lemma cv_cauchy_1 : { l:R | Un_cv (fun N:nat => sum_f_R0 An N) l } -> Cauchy_crit_series An. Proof. - intros An X. - elim X; intros. + intros An (x,p). unfold Un_cv in p. unfold Cauchy_crit_series; unfold Cauchy_crit. intros. @@ -508,12 +501,11 @@ Lemma sum_incr : 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; case (total_order_T (sum_f_R0 An N) l); intro. - elim s; intro. - left; apply a. - right; apply b. + 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 r. + 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. @@ -522,21 +514,21 @@ Proof. intro; unfold R_dist 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_r with (- l). + 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 r. + 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 le_max_r. unfold ge, N0; apply le_max_l. - apply Rplus_lt_reg_r with l; rewrite Rplus_0_r; - replace (l + (l1 - l)) with l1; [ apply r | ring ]. + 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. @@ -549,10 +541,9 @@ Lemma sum_cv_maj : 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; case (total_order_T (Rabs l1) l2); intro. - elim s; intro. - left; apply a. - right; apply b. + 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. @@ -568,17 +559,17 @@ Proof. intro; assert (H11 := H2 N). elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H11 H10)). apply Rlt_trans with ((Rabs l1 + l2) / 2); assumption. - case (Rcase_abs (Rabs l1 - Rabs (SP fn N x))); intro. + 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_sym. - rewrite Rmult_1_r; rewrite double; apply Rplus_lt_compat_l; apply r. + rewrite Rmult_1_r; rewrite double; apply Rplus_lt_compat_l; apply Hgt. discrR. - apply (Rminus_lt _ _ r0). - rewrite (Rabs_right _ r0) in H7. - apply Rplus_lt_reg_r with ((Rabs l1 - l2) / 2 - Rabs (SP fn N x)). + 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; @@ -586,18 +577,18 @@ Proof. 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 double_var; unfold Rdiv; ring. - case (Rcase_abs (sum_f_R0 An N - l2)); intro. + rewrite double_var; unfold Rdiv in |- *; ring. + destruct (Rcase_abs (sum_f_R0 An N - l2)) as [Hlt|Hge]. apply Rlt_trans with l2. - apply (Rminus_lt _ _ r0). + apply (Rminus_lt _ _ Hlt). apply Rmult_lt_reg_l with 2. prove_sup0. rewrite (double l2); unfold Rdiv; rewrite (Rmult_comm 2); rewrite Rmult_assoc; rewrite <- Rinv_l_sym. rewrite Rmult_1_r; rewrite (Rplus_comm (Rabs l1)); apply Rplus_lt_compat_l; - apply r. + apply Hgt. discrR. - rewrite (Rabs_right _ r0) in H6; apply Rplus_lt_reg_r with (- l2). + 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)); @@ -610,9 +601,9 @@ Proof. apply H4; unfold ge, N; apply le_max_l. apply H5; unfold ge, N; apply le_max_r. unfold Rdiv; apply Rmult_lt_0_compat. - apply Rplus_lt_reg_r with l2. + apply Rplus_lt_reg_l with l2. rewrite Rplus_0_r; replace (l2 + (Rabs l1 - l2)) with (Rabs l1); - [ apply r | ring ]. + [ apply Hgt | ring ]. apply Rinv_0_lt_compat; prove_sup0. intros; induction n0 as [| n0 Hrecn0]. unfold SP; simpl; apply H1. diff --git a/theories/Reals/RIneq.v b/theories/Reals/RIneq.v index b881250f..8dca0197 100644 --- a/theories/Reals/RIneq.v +++ b/theories/Reals/RIneq.v @@ -1,7 +1,7 @@ (* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* r2 -> r1 <> r2. Proof. - generalize Rlt_not_eq Rgt_not_eq. intuition eauto. + intuition. + - apply Rlt_not_eq in H1. eauto. + - apply Rgt_not_eq in H1. eauto. Qed. Hint Resolve Rlt_dichotomy_converse: real. @@ -74,7 +76,7 @@ Hint Resolve Rlt_dichotomy_converse: real. Lemma Req_dec : forall r1 r2, r1 = r2 \/ r1 <> r2. Proof. intros; generalize (total_order_T r1 r2) Rlt_dichotomy_converse; - intuition eauto 3. + unfold not; intuition eauto 3. Qed. Hint Resolve Req_dec: real. @@ -175,7 +177,7 @@ Proof. eauto using Rnot_gt_ge with rorders. Qed. Lemma Rlt_not_le : forall r1 r2, r2 < r1 -> ~ r1 <= r2. Proof. generalize Rlt_asym Rlt_dichotomy_converse; unfold Rle. - intuition eauto 3. + unfold not; intuition eauto 3. Qed. Hint Immediate Rlt_not_le: real. @@ -407,11 +409,20 @@ Proof. rewrite Rplus_assoc; rewrite H; ring. Qed. -Hint Resolve (f_equal (A:=R)): real. +Definition f_equal_R := (f_equal (A:=R)). + +Hint Resolve f_equal_R : real. Lemma Rplus_eq_compat_l : forall r r1 r2, r1 = r2 -> r + r1 = r + r2. Proof. - auto with real. + intros r r1 r2. + apply f_equal. +Qed. + +Lemma Rplus_eq_compat_r : forall r r1 r2, r1 = r2 -> r1 + r = r2 + r. +Proof. + intros r r1 r2. + apply (f_equal (fun v => v + r)). Qed. (*i Old i*)Hint Resolve Rplus_eq_compat_l: v62. @@ -427,6 +438,13 @@ Proof. Qed. 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. + apply Rplus_eq_reg_l with r. + now rewrite 2!(Rplus_comm r). +Qed. + (**********) Lemma Rplus_0_r_uniq : forall r r1, r + r1 = r -> r1 = 0. Proof. @@ -664,6 +682,11 @@ Hint Resolve Ropp_plus_distr: real. (** ** Opposite and multiplication *) (*********************************************************) +Lemma Ropp_mult_distr_l : forall r1 r2, - (r1 * r2) = - r1 * r2. +Proof. + intros; ring. +Qed. + Lemma Ropp_mult_distr_l_reverse : forall r1 r2, - r1 * r2 = - (r1 * r2). Proof. intros; ring. @@ -677,13 +700,18 @@ Proof. Qed. Hint Resolve Rmult_opp_opp: real. +Lemma Ropp_mult_distr_r : forall r1 r2, - (r1 * r2) = r1 * - r2. +Proof. + intros; ring. +Qed. + Lemma Ropp_mult_distr_r_reverse : forall r1 r2, r1 * - r2 = - (r1 * r2). Proof. intros; ring. Qed. (*********************************************************) -(** ** Substraction *) +(** ** Subtraction *) (*********************************************************) Lemma Rminus_0_r : forall r, r - 0 = r. @@ -794,7 +822,7 @@ Hint Resolve Rinv_involutive: real. Lemma Rinv_mult_distr : forall r1 r2, r1 <> 0 -> r2 <> 0 -> / (r1 * r2) = / r1 * / r2. Proof. - intros; field; auto. + intros; field; auto. Qed. (*********) @@ -969,7 +997,7 @@ Qed. (** *** Cancellation *) -Lemma Rplus_lt_reg_r : forall r r1 r2, r + r1 < r + r2 -> r1 < r2. +Lemma Rplus_lt_reg_l : forall r r1 r2, r + r1 < r + r2 -> r1 < r2. Proof. intros; cut (- r + r + r1 < - r + r + r2). rewrite Rplus_opp_l. @@ -979,10 +1007,17 @@ Proof. apply (Rplus_lt_compat_l (- r) (r + r1) (r + r2) H). Qed. +Lemma Rplus_lt_reg_r : forall r r1 r2, r1 + r < r2 + r -> r1 < r2. +Proof. + intros. + apply (Rplus_lt_reg_l r). + now rewrite 2!(Rplus_comm r). +Qed. + Lemma Rplus_le_reg_l : forall r r1 r2, r + r1 <= r + r2 -> r1 <= r2. Proof. unfold Rle; intros; elim H; intro. - left; apply (Rplus_lt_reg_r r r1 r2 H0). + left; apply (Rplus_lt_reg_l r r1 r2 H0). right; apply (Rplus_eq_reg_l r r1 r2 H0). Qed. @@ -995,7 +1030,7 @@ Qed. Lemma Rplus_gt_reg_l : forall r r1 r2, r + r1 > r + r2 -> r1 > r2. Proof. - unfold Rgt; intros; apply (Rplus_lt_reg_r r r2 r1 H). + unfold Rgt; intros; apply (Rplus_lt_reg_l r r2 r1 H). Qed. Lemma Rplus_ge_reg_l : forall r r1 r2, r + r1 >= r + r2 -> r1 >= r2. @@ -1047,12 +1082,10 @@ Qed. Lemma Ropp_gt_lt_contravar : forall r1 r2, r1 > r2 -> - r1 < - r2. Proof. unfold Rgt; intros. - apply (Rplus_lt_reg_r (r2 + r1)). - replace (r2 + r1 + - r1) with r2. - replace (r2 + r1 + - r2) with r1. - trivial. - ring. - ring. + apply (Rplus_lt_reg_l (r2 + r1)). + replace (r2 + r1 + - r1) with r2 by ring. + replace (r2 + r1 + - r2) with r1 by ring. + exact H. Qed. Hint Resolve Ropp_gt_lt_contravar. @@ -1324,19 +1357,22 @@ Qed. Lemma Rlt_minus : forall r1 r2, r1 < r2 -> r1 - r2 < 0. Proof. - intros; apply (Rplus_lt_reg_r r2). - replace (r2 + (r1 - r2)) with r1. - replace (r2 + 0) with r2; auto with real. - ring. + intros; apply (Rplus_lt_reg_l r2). + replace (r2 + (r1 - r2)) with r1 by ring. + now rewrite Rplus_0_r. Qed. Hint Resolve Rlt_minus: real. Lemma Rgt_minus : forall r1 r2, r1 > r2 -> r1 - r2 > 0. Proof. - intros; apply (Rplus_lt_reg_r r2). - replace (r2 + (r1 - r2)) with r1. - replace (r2 + 0) with r2; auto with real. - ring. + intros; apply (Rplus_lt_reg_l r2). + replace (r2 + (r1 - r2)) with r1 by ring. + now rewrite Rplus_0_r. +Qed. + +Lemma Rlt_Rminus : forall a b:R, a < b -> 0 < b - a. +Proof. + intros a b; apply Rgt_minus. Qed. (**********) @@ -1368,6 +1404,9 @@ Proof. ring. Qed. +Lemma Rminus_gt_0_lt : forall a b, 0 < b - a -> a < b. +Proof. intro; intro; apply Rminus_gt. Qed. + (**********) Lemma Rminus_le : forall r1 r2, r1 - r2 <= 0 -> r1 <= r2. Proof. @@ -1625,7 +1664,7 @@ Proof. apply (Rlt_irrefl 0); auto. do 2 rewrite S_INR in H1; cut (INR n1 < INR n0). intro H2; generalize (H0 n0 H2); intro; auto with arith. - apply (Rplus_lt_reg_r 1 (INR n1) (INR n0)). + apply (Rplus_lt_reg_l 1 (INR n1) (INR n0)). rewrite Rplus_comm; rewrite (Rplus_comm 1 (INR n0)); trivial. Qed. Hint Resolve INR_lt: real. @@ -1931,18 +1970,26 @@ Proof. apply (Rmult_le_compat_l x 0 y H H0). Qed. +Lemma Rinv_le_contravar : + forall x y, 0 < x -> x <= y -> / y <= / x. +Proof. + intros x y H1 [H2|H2]. + apply Rlt_le. + apply Rinv_lt_contravar with (2 := H2). + apply Rmult_lt_0_compat with (1 := H1). + now apply Rlt_trans with x. + rewrite H2. + apply Rle_refl. +Qed. + Lemma Rle_Rinv : forall x y:R, 0 < x -> 0 < y -> x <= y -> / y <= / x. Proof. - intros; apply Rmult_le_reg_l with x. - apply H. - rewrite <- Rinv_r_sym. - apply Rmult_le_reg_l with y. - apply H0. - rewrite Rmult_1_r; rewrite Rmult_comm; rewrite Rmult_assoc; - rewrite <- Rinv_l_sym. - rewrite Rmult_1_r; apply H1. - red; intro; rewrite H2 in H0; elim (Rlt_irrefl _ H0). - red; intro; rewrite H2 in H; elim (Rlt_irrefl _ H). + intros x y H _. + apply Rinv_le_contravar with (1 := H). +Qed. + +Lemma Ropp_div : forall x y, -x/y = - (x / y). +intros x y; unfold Rdiv; ring. Qed. Lemma double : forall r1, 2 * r1 = r1 + r1. @@ -2018,6 +2065,29 @@ Proof. intros; elim (completeness E H H0); intros; split with x; assumption. Qed. +Lemma Rdiv_lt_0_compat : forall a b, 0 < a -> 0 < b -> 0 < a/b. +Proof. +intros; apply Rmult_lt_0_compat;[|apply Rinv_0_lt_compat]; assumption. +Qed. + +Lemma Rdiv_plus_distr : forall a b c, (a + b)/c = a/c + b/c. +intros a b c; apply Rmult_plus_distr_r. +Qed. + +Lemma Rdiv_minus_distr : forall a b c, (a - b)/c = a/c - b/c. +intros a b c; unfold Rminus, Rdiv; rewrite Rmult_plus_distr_r; ring. +Qed. + +(* A test for equality function. *) +Lemma Req_EM_T : forall r1 r2:R, {r1 = r2} + {r1 <> r2}. +Proof. + intros; destruct (total_order_T r1 r2) as [[H|]|H]. + - right; red; intros ->; elim (Rlt_irrefl r2 H). + - left; assumption. + - right; red; intros ->; elim (Rlt_irrefl r2 H). +Qed. + + (*********************************************************) (** * Definitions of new types *) (*********************************************************) @@ -2035,6 +2105,7 @@ Record negreal : Type := mknegreal {neg :> R; cond_neg : neg < 0}. Record nonzeroreal : Type := mknonzeroreal {nonzero :> R; cond_nonzero : nonzero <> 0}. + (** Compatibility *) Notation prod_neq_R0 := Rmult_integral_contrapositive_currified (only parsing). diff --git a/theories/Reals/RList.v b/theories/Reals/RList.v index ad3002b4..abf8a99d 100644 --- a/theories/Reals/RList.v +++ b/theories/Reals/RList.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* |]. + simpl in H2; left; assumption. + right; elim Hrecl; intros H4 H5; apply H5; assert (H6 : S (pred x0) = x0). symmetry ; apply S_pred with 0%nat; assumption. exists (pred x0); split; - [ simpl in H1; apply lt_S_n; rewrite H5; assumption - | rewrite <- H5 in H2; simpl in H2; assumption ]. + [ simpl in H1; apply lt_S_n; rewrite H6; assumption + | rewrite <- H6 in H2; simpl in H2; assumption ]. Qed. Lemma Rlist_P1 : @@ -208,11 +208,11 @@ Proof. assert (H3 := Hrecl H2); elim H1; intros; elim H3; intros; exists (cons x x0); intros; elim H5; clear H5; intros; split. simpl; rewrite H5; reflexivity. - intros; elim (zerop i); intro. - rewrite a; simpl; assumption. - assert (H8 : i = S (pred i)). + intros; destruct (zerop i) as [->|]. + simpl; assumption. + assert (H9 : i = S (pred i)). apply S_pred with 0%nat; assumption. - rewrite H8; simpl; apply H6; simpl in H7; apply lt_S_n; rewrite <- H8; + rewrite H9; simpl; apply H6; simpl in H7; apply lt_S_n; rewrite <- H9; assumption. Qed. diff --git a/theories/Reals/ROrderedType.v b/theories/Reals/ROrderedType.v index 1e92edd6..0531bd0a 100644 --- a/theories/Reals/ROrderedType.v +++ b/theories/Reals/ROrderedType.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* r2}. Proof. intros; generalize (total_order_T r1 r2) Rlt_dichotomy_converse; - intuition eauto 3. + intuition eauto. Qed. Definition Reqb r1 r2 := if Req_dec r1 r2 then true else false. diff --git a/theories/Reals/R_Ifp.v b/theories/Reals/R_Ifp.v index 4f4293f3..57ee1d9a 100644 --- a/theories/Reals/R_Ifp.v +++ b/theories/Reals/R_Ifp.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 0 <= x -> 0 <= y -> x <= y. Proof. - intros; case (Rle_dec x y); intro; + intros; destruct (Rle_dec x y) as [Hle|Hnle]; [ assumption | cut (y < x); [ intro; unfold Rsqr in H; @@ -109,7 +109,7 @@ Qed. Lemma Rsqr_incr_0_var : forall x y:R, Rsqr x <= Rsqr y -> 0 <= y -> x <= y. Proof. - intros; case (Rle_dec x y); intro; + intros; destruct (Rle_dec x y) as [Hle|Hnle]; [ assumption | cut (y < x); [ intro; unfold Rsqr in H; @@ -146,8 +146,8 @@ Qed. Lemma Rsqr_neg_pos_le_0 : forall x y:R, Rsqr x <= Rsqr y -> 0 <= y -> - y <= x. Proof. - intros; case (Rcase_abs x); intro. - generalize (Ropp_lt_gt_contravar x 0 r); rewrite Ropp_0; intro; + 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; @@ -160,25 +160,23 @@ Qed. Lemma Rsqr_neg_pos_le_1 : forall x y:R, - y <= x -> x <= y -> 0 <= y -> Rsqr x <= Rsqr y. Proof. - intros; case (Rcase_abs x); intro. - generalize (Ropp_lt_gt_contravar x 0 r); rewrite Ropp_0; intro; - generalize (Rlt_le 0 (- x) H2); intro; - generalize (Ropp_le_ge_contravar (- y) x H); rewrite Ropp_involutive; - intro; generalize (Rge_le y (- x) H4); intro; rewrite (Rsqr_neg x); - apply Rsqr_incr_1; assumption. - generalize (Rge_le x 0 r); intro; apply Rsqr_incr_1; assumption. + 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; case (Rcase_abs x); intro. - generalize (Ropp_lt_gt_contravar x 0 r); rewrite Ropp_0; intro; - generalize (Ropp_le_ge_contravar (- y) x H); rewrite Ropp_involutive; - intro; generalize (Rge_le y (- x) H2); intro; generalize (Rlt_le 0 (- x) H1); - intro; generalize (Rle_trans 0 (- x) y H4 H3); intro; - rewrite (Rsqr_neg x); apply Rsqr_incr_1; assumption. - generalize (Rge_le x 0 r); intro; generalize (Rle_trans 0 x y H1 H0); intro; - apply Rsqr_incr_1; assumption. + 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 Rsqr_abs : forall x:R, Rsqr x = Rsqr (Rabs x). @@ -220,22 +218,22 @@ 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); case (Rcase_abs y); intros. - rewrite (Rsqr_neg x) in H; rewrite (Rsqr_neg y) in H; - generalize (Ropp_lt_gt_contravar y 0 r); - generalize (Ropp_lt_gt_contravar x 0 r0); rewrite Ropp_0; + 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 r); intro; - generalize (Ropp_lt_gt_contravar x 0 r0); rewrite Ropp_0; + 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 r0); intro; - generalize (Ropp_lt_gt_contravar y 0 r); rewrite Ropp_0; + 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. - generalize (Rge_le x 0 r0); generalize (Rge_le y 0 r); intros; 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. diff --git a/theories/Reals/R_sqrt.v b/theories/Reals/R_sqrt.v index 38a38400..20319a2b 100644 --- a/theories/Reals/R_sqrt.v +++ b/theories/Reals/R_sqrt.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* sqrt x * sqrt x = x. Proof. intros. unfold sqrt. - case (Rcase_abs x); intro. - elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ r H)). + case (Rcase_abs x) as [Hlt|Hge]. + elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ Hlt H)). rewrite Rsqrt_Rsqrt; reflexivity. Qed. @@ -94,6 +94,10 @@ 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 sqrt_Rsqr_abs : forall x:R, sqrt (Rsqr x) = Rabs x. Proof. intro x; rewrite Rsqr_abs; apply sqrt_Rsqr; apply Rabs_pos. @@ -517,3 +521,4 @@ Proof. reflexivity. reflexivity. Qed. + diff --git a/theories/Reals/Ranalysis.v b/theories/Reals/Ranalysis.v index d656817e..3cda675a 100644 --- a/theories/Reals/Ranalysis.v +++ b/theories/Reals/Ranalysis.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* (forall y, R_dist 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 R_dist_eq; assumption. +apply Rlt_le_trans with (Rmin a a');[ | apply Rmin_l]; tauto. +Qed. + + (**********) Lemma continuity_pt_plus : forall f1 f2 (x0:R), @@ -477,6 +494,47 @@ Proof. 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_Rminus; 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 *) @@ -639,6 +697,24 @@ Proof. 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_id : forall x:R, derivable_pt_lim id x 1. Proof. intro; unfold derivable_pt_lim. @@ -1066,15 +1142,8 @@ 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. - unfold derivable_pt in pr1. - unfold derivable_pt in pr2. - elim pr1; intros. - elim pr2; intros. - unfold derivable_pt_abs in p. - unfold derivable_pt_abs in p0. - simpl. - apply (uniqueness_limite f x x0 x1 p p0). + intros f x (x0,H0) (x1,H1). + apply (uniqueness_limite f x x0 x1 H0 H1). Qed. @@ -1123,7 +1192,7 @@ Proof. case (Rcase_abs ((f (c + Rmin (delta / 2) ((b + - c) / 2)) + - f c) / - Rmin (delta / 2) ((b + - c) / 2) + - l)); intro. + Rmin (delta / 2) ((b + - c) / 2) + - l)) as [Hlt|Hge]. replace (- ((f (c + Rmin (delta / 2) ((b + - c) / 2)) + - f c) / @@ -1165,7 +1234,7 @@ Proof. (H20 := Rge_le ((f (c + Rmin (delta / 2) ((b + - c) / 2)) + - f c) / - Rmin (delta / 2) ((b + - c) / 2) + - l) 0 r). + Rmin (delta / 2) ((b + - c) / 2) + - l) 0 Hge). elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H20 H18)). assumption. rewrite <- Ropp_0; @@ -1242,17 +1311,16 @@ Proof. (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))). - intro. + 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 r)). + 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 ]. - intro; apply Rle_lt_trans with (delta / 2). + apply Rle_lt_trans with (delta / 2). apply Rmin_l. unfold Rdiv; apply Rmult_lt_reg_l with 2. prove_sup0. @@ -1311,13 +1379,12 @@ Proof. case (Rcase_abs ((f (c + Rmax (- (delta / 2)) ((a + - c) / 2)) + - f c) / - Rmax (- (delta / 2)) ((a + - c) / 2) + - l)). - intro; - elim + 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 r)). + Rmax (- (delta / 2)) ((a + - c) / 2) + - l) 0 H19 Hlt)). intros; generalize (Rplus_lt_compat_r l @@ -1380,8 +1447,8 @@ Proof. apply Rplus_lt_compat_l; assumption. field; discrR. assumption. - unfold Rabs; case (Rcase_abs (Rmax (- (delta / 2)) ((a - c) / 2))). - intro; generalize (RmaxLess1 (- (delta / 2)) ((a - c) / 2)); intro; + 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; @@ -1402,7 +1469,7 @@ Proof. 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 r); + intro; generalize (Rge_le (Rmax (- (delta / 2)) ((a - c) / 2)) 0 Hge); intro; elim (Rlt_irrefl 0 @@ -1494,11 +1561,10 @@ Proof. cut (0 <= (f (x + delta / 2) - f x) / (delta / 2)). 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)). - intro; - elim + 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 r)). + (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) @@ -1555,7 +1621,7 @@ Proof. [ 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_r with l. + 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/theories/Reals/Ranalysis2.v b/theories/Reals/Ranalysis2.v index b070cdaa..eb646913 100644 --- a/theories/Reals/Ranalysis2.v +++ b/theories/Reals/Ranalysis2.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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. - elim pr1; intros. - elim pr2; intros. - simpl. - rewrite H in p. + unfold derivable_pt, derive_pt; intros f g x (x0,p0) (x1,p1) ->. apply uniqueness_limite with g x; assumption. Qed. @@ -54,14 +51,11 @@ 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. - elim pr1; intros. - elim pr2; intros. - simpl. - assert (H0 := uniqueness_step2 _ _ _ p). - assert (H1 := uniqueness_step2 _ _ _ p0). + 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; assert (H3 := uniqueness_step1 _ _ _ _ H0 H2). + intro H2; assert (H3 := uniqueness_step1 _ _ _ _ H0 H2). assumption. unfold limit1_in; unfold limit_in; unfold dist; simpl; unfold R_dist; unfold limit1_in in H1; @@ -117,14 +111,14 @@ Proof. rewrite Rplus_opp_r; rewrite Rabs_R0; apply H0. apply H1. apply Rle_ge. - case (Rcase_abs h); intro. - rewrite (Rabs_left h r) in H2. - left; rewrite Rplus_comm; apply Rplus_lt_reg_r with (- h); rewrite Rplus_0_r; + 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 r. + apply Rge_le; apply Hgt. left; apply H. Qed. @@ -145,13 +139,13 @@ Proof. rewrite <- Rinv_r_sym. rewrite Ropp_involutive; rewrite Rplus_opp_l; rewrite Rabs_R0; apply H0. apply H2. - case (Rcase_abs h); intro. + 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 r. - rewrite (Rabs_right h r) in H3. - apply Rplus_lt_reg_r with (- x); rewrite Rplus_0_r; rewrite <- Rplus_assoc; + 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. @@ -161,13 +155,12 @@ Qed. Lemma Rderivable_pt_abs : forall x:R, x <> 0 -> derivable_pt Rabs x. Proof. intros. - case (total_order_T x 0); intro. - elim s; intro. + destruct (total_order_T x 0) as [[Hlt|Heq]|Hgt]. unfold derivable_pt; exists (-1). - apply (Rabs_derive_2 x a). - elim H; exact b. + apply (Rabs_derive_2 x Hlt). + elim H; exact Heq. unfold derivable_pt; exists 1. - apply (Rabs_derive_1 x r). + apply (Rabs_derive_1 x Hgt). Qed. (** Rabsolu is continuous for all x *) @@ -406,3 +399,14 @@ 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_Rminus; assumption. +Qed. + diff --git a/theories/Reals/Ranalysis5.v b/theories/Reals/Ranalysis5.v index 5c3b03fa..27615c59 100644 --- a/theories/Reals/Ranalysis5.v +++ b/theories/Reals/Ranalysis5.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* (derivable_pt_abs f x l <-> derivable_pt_abs 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. - elim Prg; intros. + 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. @@ -294,8 +295,8 @@ intros. (* f x y f_cont_interv x_lt_y fx_neg fy_pos.*) 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. - elim X0; intros. + elim X; intros x0 p. + elim X0; intros x1 p0. assert (H4 := cv_dicho _ _ _ _ _ H3 p0 p). rewrite H4 in p0. exists x0. @@ -337,14 +338,14 @@ intros. (* f x y f_cont_interv x_lt_y fx_neg fy_pos.*) left; assumption. intro. unfold cond_positivity in |- *. - case (Rle_dec 0 z); intro. + destruct (Rle_dec 0 z) as [|Hnotle]. split. intro; assumption. intro; reflexivity. split. intro feqt;discriminate feqt. intro. - elim n0; assumption. + elim Hnotle; assumption. unfold Vn in |- *. cut (forall z:R, cond_positivity z = false <-> z < 0). intros. @@ -358,10 +359,10 @@ intros. (* f x y f_cont_interv x_lt_y fx_neg fy_pos.*) assumption. intro. unfold cond_positivity in |- *. - case (Rle_dec 0 z); intro. + destruct (Rle_dec 0 z) as [Hle|]. split. intro feqt; discriminate feqt. - intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r H7)). + intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ Hle H7)). split. intro; auto with real. intro; reflexivity. @@ -370,10 +371,9 @@ intros. (* f x y f_cont_interv x_lt_y fx_neg fy_pos.*) 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). - case (total_order_T 0 (f x0)); intro. - elim s; intro. + destruct (total_order_T 0 (f x0)) as [[Hlt|<-]|Hgt]. left; assumption. - rewrite <- b; right; reflexivity. + right; reflexivity. unfold Un_cv in H7; unfold R_dist in H7. cut (0 < - f x0). intro. @@ -383,7 +383,7 @@ intros. (* f x y f_cont_interv x_lt_y fx_neg fy_pos.*) 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_r _ _ _ 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. @@ -396,29 +396,28 @@ intros. (* f x y f_cont_interv x_lt_y fx_neg fy_pos.*) 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). - case (total_order_T 0 (f x0)); intro. - elim s; intro. + destruct (total_order_T 0 (f x0)) as [[Hlt|Heq]|]. unfold Un_cv in H7; unfold R_dist in H7. - elim (H7 (f x0) a); intros. - cut (x2 >= x2)%nat; [ intro | unfold ge in |- *; apply le_n ]. + 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_r _ _ _ 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_r with (f x0 - f (Vn x2)). + 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 <- b; reflexivity. + right; rewrite <- Heq; reflexivity. left; assumption. unfold Vn in |- *; assumption. Qed. @@ -695,7 +694,7 @@ intros f g lb ub x Prf g_cont_pur lb_lt_ub x_encad Prg_incr f_eq_g df_neq. exists deltatemp ; exact Htemp. elim (Hf_deriv eps eps_pos). intros deltatemp Htemp. - red in Hlinv ; red in Hlinv ; simpl dist in Hlinv ; unfold R_dist in Hlinv. + red in Hlinv ; red in Hlinv ; unfold dist in Hlinv ; unfold R_dist 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 R_dist in Hlinv'. assert (Premisse : (forall eps : R, @@ -1038,62 +1037,6 @@ Definition mkposreal_lb_ub (x lb ub:R) (lb_lt_x:lb Boule c2 r2 x -> - {r3 : posreal | forall y, Boule x r3 y -> Boule c1 r1 y /\ Boule c2 r2 y}. -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; fourier. -assert (x < Rmin (c1 + r1) (c2 + r2)). - apply Rmin_glb_lt;[revert in1 | revert in2]; intros h; - apply Rabs_def2 in h; destruct h; fourier. -assert (t: 0 < Rmin (x - Rmax (c1 - r1) (c2 - r2)) - (Rmin (c1 + r1) (c2 + r2) - x)). - apply Rmin_glb_lt; fourier. -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;split; apply Rabs_def1; fourier. -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. - Lemma derivable_pt_lim_CVU : forall (fn fn':nat -> R -> R) (f g:R->R) (x:R) c r, Boule c r x -> (forall y n, Boule c r y -> derivable_pt_lim (fn n) y (fn' n y)) -> diff --git a/theories/Reals/Ranalysis_reg.v b/theories/Reals/Ranalysis_reg.v index ea3899fc..4cf90886 100644 --- a/theories/Reals/Ranalysis_reg.v +++ b/theories/Reals/Ranalysis_reg.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* r -> r1 > r /\ r2 > r. Proof. - intros r1 r2 r; unfold Rmin; case (Rle_dec r1 r2); intros. + intros r1 r2 r; unfold Rmin; case (Rle_dec r1 r2) as [Hle|Hnle]; intros. split. assumption. - unfold Rgt; unfold Rgt in H; exact (Rlt_le_trans r r1 r2 H r0). + unfold Rgt; exact (Rlt_le_trans r r1 r2 H Hle). split. - generalize (Rnot_le_lt r1 r2 n); intro; exact (Rgt_trans r1 r2 r H0 H). + generalize (Rnot_le_lt r1 r2 Hnle); intro; exact (Rgt_trans r1 r2 r H0 H). assumption. Qed. @@ -168,10 +168,10 @@ 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); elim H; clear H; intros; + 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 n); clear n; intro; unfold Rgt in H0; + 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. @@ -262,6 +262,16 @@ 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. @@ -276,9 +286,9 @@ Qed. (*********) Lemma Rcase_abs : forall r, {r < 0} + {r >= 0}. Proof. - intro; generalize (Rle_dec 0 r); intro X; elim X; intro; clear X. - right; apply (Rle_ge 0 r a). - left; fold (0 > r); apply (Rnot_le_lt 0 r b). + 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. (*********) @@ -320,9 +330,9 @@ Qed. (*********) Lemma Rabs_right : forall r, r >= 0 -> Rabs r = r. Proof. - intros; unfold Rabs; case (Rcase_abs r); intro. + intros; unfold Rabs; case (Rcase_abs r) as [Hlt|Hge]. absurd (r >= 0). - exact (Rlt_not_ge r 0 r0). + exact (Rlt_not_ge r 0 Hlt). assumption. trivial. Qed. @@ -337,9 +347,9 @@ Qed. (*********) Lemma Rabs_pos : forall x:R, 0 <= Rabs x. Proof. - intros; unfold Rabs; case (Rcase_abs x); intro. - generalize (Ropp_lt_gt_contravar x 0 r); intro; unfold Rgt in H; - rewrite Ropp_0 in H; unfold Rle; left; assumption. + 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. @@ -350,11 +360,18 @@ 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); intro; - [ generalize (Rgt_not_le 0 x r); intro; exfalso; auto | trivial ]. + intros; unfold Rabs; case (Rcase_abs x) as [Hlt|Hge]; + [ generalize (Rgt_not_le 0 x Hlt); intro; exfalso; auto | trivial ]. Qed. (*********) @@ -366,100 +383,70 @@ Qed. (*********) Lemma Rabs_pos_lt : forall x:R, x <> 0 -> 0 < Rabs x. Proof. - intros; generalize (Rabs_pos x); intro; unfold Rle in H0; elim H0; intro; - auto. - exfalso; clear H0; elim H; clear H; generalize H1; unfold Rabs; - case (Rcase_abs x); intros; auto. - clear r H1; generalize (Rplus_eq_compat_l x 0 (- x) H0); - rewrite (let (H1, H2) := Rplus_ne x in H1); rewrite (Rplus_opp_r x); - trivial. + 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)); - case (Rcase_abs (y - x)); intros. - generalize (Rminus_lt y x r); generalize (Rminus_lt x y r0); intros; - generalize (Rlt_asym x y H); intro; exfalso; - auto. + 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. - unfold Rge in r, r0; elim r; elim r0; intros; clear r r0. - generalize (Ropp_lt_gt_0_contravar (x - y) H); rewrite (Ropp_minus_distr x y); - intro; unfold Rgt in H0; generalize (Rlt_asym 0 (y - x) H0); - intro; exfalso; auto. - rewrite (Rminus_diag_uniq x y H); trivial. - rewrite (Rminus_diag_uniq y x H0); trivial. - rewrite (Rminus_diag_uniq y x H0); 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)); case (Rcase_abs x); - case (Rcase_abs y); intros; auto. - generalize (Rmult_lt_gt_compat_neg_l y x 0 r r0); intro; - rewrite (Rmult_0_r y) in H; generalize (Rlt_asym (x * y) 0 r1); - intro; unfold Rgt in H; exfalso; rewrite (Rmult_comm y x) in H; - auto. + 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. - unfold Rge in r, r0; elim r; elim r0; clear r r0; intros; unfold Rgt in H, H0. - generalize (Rmult_lt_compat_l x 0 y H H0); intro; rewrite (Rmult_0_r x) in H1; - generalize (Rlt_asym (x * y) 0 r1); intro; exfalso; - auto. - rewrite H in r1; rewrite (Rmult_0_l y) in r1; generalize (Rlt_irrefl 0); - intro; exfalso; auto. - rewrite H0 in r1; rewrite (Rmult_0_r x) in r1; generalize (Rlt_irrefl 0); - intro; exfalso; auto. - rewrite H0 in r1; rewrite (Rmult_0_r x) in r1; generalize (Rlt_irrefl 0); - intro; exfalso; auto. + 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. - unfold Rge in r, r1; elim r; elim r1; clear r r1; intros; unfold Rgt in H0, H. - generalize (Rmult_lt_compat_l y x 0 H0 r0); intro; - rewrite (Rmult_0_r y) in H1; rewrite (Rmult_comm y x) in H1; - generalize (Rlt_asym (x * y) 0 H1); intro; exfalso; - auto. - generalize (Rlt_dichotomy_converse x 0 (or_introl (x > 0) r0)); - generalize (Rlt_dichotomy_converse y 0 (or_intror (y < 0) H0)); - intros; generalize (Rmult_integral x y H); intro; - elim H3; intro; exfalso; auto. - rewrite H0 in H; rewrite (Rmult_0_r x) in H; unfold Rgt in H; - generalize (Rlt_irrefl 0); intro; exfalso; - auto. - rewrite H0; rewrite (Rmult_0_r x); rewrite (Rmult_0_r (- x)); trivial. - unfold Rge in r0, r1; elim r0; elim r1; clear r0 r1; intros; - unfold Rgt in H0, H. - generalize (Rmult_lt_compat_l x y 0 H0 r); intro; rewrite (Rmult_0_r x) in H1; - generalize (Rlt_asym (x * y) 0 H1); intro; exfalso; - auto. - generalize (Rlt_dichotomy_converse y 0 (or_introl (y > 0) r)); - generalize (Rlt_dichotomy_converse 0 x (or_introl (0 > x) H0)); - intros; generalize (Rmult_integral x y H); intro; - elim H3; intro; exfalso; auto. - rewrite H0 in H; rewrite (Rmult_0_l y) in H; unfold Rgt in H; - generalize (Rlt_irrefl 0); intro; exfalso; - auto. - rewrite H0; rewrite (Rmult_0_l y); rewrite (Rmult_0_l (- 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_Rinv : forall r, r <> 0 -> Rabs (/ r) = / Rabs r. Proof. - intro; unfold Rabs; case (Rcase_abs r); case (Rcase_abs (/ r)); auto; + intro; unfold Rabs; case (Rcase_abs r) as [Hlt|Hge]; + case (Rcase_abs (/ r)) as [Hlt'|Hge']; auto; intros. apply Ropp_inv_permute; auto. - generalize (Rinv_lt_0_compat r r1); intro; unfold Rge in r0; elim r0; intros. - unfold Rgt in H1; generalize (Rlt_asym 0 (/ r) H1); intro; exfalso; - auto. - generalize (Rlt_dichotomy_converse (/ r) 0 (or_introl (/ r > 0) H0)); intro; - exfalso; auto. - unfold Rge in r1; elim r1; clear r1; intro. - unfold Rgt in H0; generalize (Rlt_asym 0 (/ r) (Rinv_0_lt_compat r H0)); - intro; exfalso; auto. - exfalso; auto. + rewrite <- Ropp_inv_permute; trivial. + destruct Hge' as [| ->]. + apply Rinv_lt_0_compat, Rlt_asym in Hlt; contradiction. + rewrite Ropp_0; trivial. + destruct Hge as [| ->]. + apply Rinv_0_lt_compat, Rlt_asym in H0; contradiction. + contradiction (refl_equal 0). Qed. Lemma Rabs_Ropp : forall x:R, Rabs (- x) = Rabs x. @@ -483,13 +470,14 @@ 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)); case (Rcase_abs a); - case (Rcase_abs b); intros. + 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; unfold Rge in r; elim r; intro. + 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). @@ -497,24 +485,24 @@ Proof. (**) 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; unfold Rge in r0; elim r0; intro. + 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 r); intro; + 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 r0); intro; clear H; + 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 r1); intro; auto. + 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 r); intro; + 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 r0); intro; clear H; - unfold Rge in r1; elim r1; clear r1; intro. + 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. @@ -522,16 +510,16 @@ Proof. 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 r0); clear r r1; + 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 r0); + 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 r); clear r0 r1; + 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 r); + clear v w; generalize (Rlt_trans (b + b) b 0 H Hltb); intro; apply (Rlt_le (b + b) 0 H0). (**) unfold Rle; right; reflexivity. @@ -585,15 +573,15 @@ Qed. (*********) Lemma Rabs_def2 : forall x a:R, Rabs x < a -> x < a /\ - a < x. Proof. - unfold Rabs; intro x; case (Rcase_abs x); intros. - generalize (Ropp_gt_lt_0_contravar x r); unfold Rgt; intro; + 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 r H1). + 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 r); intro; + 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) r H1); unfold Rgt; + generalize (Rge_gt_trans x 0 (- a) Hge H1); unfold Rgt; intro; split; assumption. Qed. @@ -637,3 +625,51 @@ 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/theories/Reals/Rcomplete.v b/theories/Reals/Rcomplete.v index 9b896bdd..1766f377 100644 --- a/theories/Reals/Rcomplete.v +++ b/theories/Reals/Rcomplete.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* Un (N + k)%nat) (min_ss Un N (cauchy_min Un H))). - intros. - rewrite <- H9; rewrite <- H10. - rewrite <- H9 in H8. - rewrite <- H10 in H7. - elim (H7 (eps / 5) H3); intros k2 H11. - elim (H8 (eps / 5) H3); intros k1 H12. + intros H9 H10. + 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 diff --git a/theories/Reals/Rdefinitions.v b/theories/Reals/Rdefinitions.v index 19cc2166..50eb59b2 100644 --- a/theories/Reals/Rdefinitions.v +++ b/theories/Reals/Rdefinitions.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 1 @@ -744,10 +747,10 @@ Qed. Lemma R_dist_sym : forall x y:R, R_dist x y = R_dist y x. Proof. unfold R_dist; intros; split_Rabs; try ring. - generalize (Ropp_gt_lt_0_contravar (y - x) r); intro; - rewrite (Ropp_minus_distr y x) in H; generalize (Rlt_asym (x - y) 0 r0); + 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 r); intro; generalize (minus_Rge x y r0); intro; + 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. @@ -786,6 +789,13 @@ Proof. ring. Qed. +Lemma R_dist_mult_l : forall a b c, + R_dist (a * b) (a * c) = Rabs a * R_dist b c. +Proof. +unfold R_dist. +intros a b c; rewrite <- Rmult_minus_distr_l, Rabs_mult; reflexivity. +Qed. + (*******************************) (** * Infinite Sum *) (*******************************) diff --git a/theories/Reals/Rgeom.v b/theories/Reals/Rgeom.v index afdf148e..d930c5aa 100644 --- a/theories/Reals/Rgeom.v +++ b/theories/Reals/Rgeom.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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; exists (mkStepFun (StepFun_P6 (pre x))); + 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; @@ -110,12 +108,10 @@ Proof. 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; case (Rle_dec a b); intro; - [ reflexivity | elim n0; assumption ]. + unfold Rmin; decide (Rle_dec a b) with H0; reflexivity. assert (H13 : Rmax a b = b). - unfold Rmax; case (Rle_dec a b); intro; - [ reflexivity | elim n0; assumption ]. - rewrite <- H12 in H11; pattern b at 2 in H11; rewrite <- H13 in H11; + 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. @@ -142,7 +138,7 @@ Lemma RiemannInt_P3 : Rabs (RiemannInt_SF (wn n)) < un n) -> { l:R | Un_cv (fun N:nat => RiemannInt_SF (vn N)) l }. Proof. - intros; case (Rle_dec a b); intro. + 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)))); @@ -153,49 +149,48 @@ Proof. (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 n0); intros; split. - intros; apply (H2 t); elim H4; clear H4; intros; split; + 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 ]; - (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 H3; unfold RiemannInt_SF; case (Rle_dec a b); - case (Rle_dec b a); unfold wn'; intros; + 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 n0))))) - (subdivision (mkStepFun (StepFun_P6 (pre (wn n0)))))) with - (Int_SF (subdivision_val (wn n0)) (subdivision (wn n0))); + (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 n0)) a b; + | apply StepFun_P17 with (fe (wn n)) a b; [ apply StepFun_P1 | apply StepFun_P2; - apply (StepFun_P1 (mkStepFun (StepFun_P6 (pre (wn n0))))) ] ]). + 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; + 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 R_dist, RiemannInt_SF; - case (Rle_dec b a); case (Rle_dec a b); intros. - elim n; assumption. + destruct (Rle_dec b a) as [Hle'|Hnle']; destruct (Rle_dec a b) as [Hle''|Hnle'']; + intros. + elim Hnle; assumption. unfold vn' in H7; - replace (Int_SF (subdivision_val (vn n0)) (subdivision (vn n0))) with - (Int_SF (subdivision_val (mkStepFun (StepFun_P6 (pre (vn n0))))) - (subdivision (mkStepFun (StepFun_P6 (pre (vn n0)))))); + 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 n0)) a b; + | symmetry ; apply StepFun_P17 with (fe (vn n)) a b; [ apply StepFun_P1 | apply StepFun_P2; - apply (StepFun_P1 (mkStepFun (StepFun_P6 (pre (vn n0))))) ] ]. - elim n1; assumption. - elim n2; assumption. + apply (StepFun_P1 (mkStepFun (StepFun_P6 (pre (vn n))))) ] ]. + elim Hnle'; assumption. + elim Hnle'; assumption. Qed. Lemma RiemannInt_exists : @@ -244,7 +239,7 @@ Proof. (RiemannInt_SF (phi_sequence vn pr2 n) + -1 * RiemannInt_SF (phi_sequence un pr1 n)); [ idtac | ring ]; rewrite <- StepFun_P30. - case (Rle_dec a b); intro. + destruct (Rle_dec a b) as [Hle|Hnle]. apply Rle_lt_trans with (RiemannInt_SF (mkStepFun @@ -263,13 +258,11 @@ Proof. (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; case (Rle_dec a b); intro; - [ reflexivity | elim n0; assumption ]. + unfold Rmin; decide (Rle_dec a b) with Hle; reflexivity. assert (H11 : Rmax a b = b). - unfold Rmax; case (Rle_dec a b); intro; - [ reflexivity | elim n0; assumption ]. + 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; elim H5; intros; apply H8. + 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. @@ -319,11 +312,9 @@ Proof. (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; case (Rle_dec a b); intro; - [ elim n0; assumption | reflexivity ]. + unfold Rmin; decide (Rle_dec a b) with Hnle; reflexivity. assert (H11 : Rmax a b = a). - unfold Rmax; case (Rle_dec a b); intro; - [ elim n0; assumption | reflexivity ]. + 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. @@ -388,11 +379,9 @@ Proof. [ idtac | left; change (0 < / (INR n + 1)); apply Rinv_0_lt_compat; assumption ]; apply Rle_lt_trans with (/ (INR x + 1)). - apply Rle_Rinv. + apply Rinv_le_contravar. apply Rplus_le_lt_0_compat; [ apply pos_INR | apply Rlt_0_1 ]. - assumption. - do 2 rewrite <- (Rplus_comm 1); apply Rplus_le_compat_l; apply le_INR; - apply H4. + apply Rplus_le_compat_r; apply le_INR; apply H4. rewrite <- (Rinv_involutive eps). apply Rinv_lt_contravar. apply Rmult_lt_0_compat. @@ -405,6 +394,15 @@ Proof. red; intro; rewrite H6 in H; elim (Rlt_irrefl _ H). 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. @@ -414,10 +412,10 @@ Lemma RiemannInt_P5 : RiemannInt pr1 = RiemannInt pr2. Proof. intros; unfold RiemannInt; - case (RiemannInt_exists pr1 RinvN RinvN_cv); - case (RiemannInt_exists pr2 RinvN RinvN_cv); intros; + case (RiemannInt_exists pr1 RinvN RinvN_cv) as (x,HUn); + case (RiemannInt_exists pr2 RinvN RinvN_cv) as (x0,HUn0); eapply UL_sequence; - [ apply u0 + [ apply HUn | apply RiemannInt_P4 with pr2 RinvN; apply RinvN_cv || assumption ]. Qed. @@ -434,14 +432,13 @@ Proof. 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; exists x; elim p; intros; + intro; assert (H2 := Nzorn H0 H1); elim H2; intros x p; exists x; elim p; intros; split. apply H3. - case (total_order_T (a + INR (S x) * del) b); intro. - elim s; intro. - assert (H5 := H4 (S x) a0); elim (le_Sn_n _ H5). + destruct (total_order_T (a + INR (S x) * del) b) as [[Hlt|Heq]|Hgt]. + assert (H5 := H4 (S x) Hlt); elim (le_Sn_n _ H5). right; symmetry ; assumption. - left; apply r. + 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 @@ -509,22 +506,24 @@ Proof. | 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; cut (0 < x <= b - a). + 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)); elim (classic (exists y : R, D < y /\ E y)); - intro. + 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 (H12 := not_ex_all_not _ (fun y:R => D < y /\ E y) H11); - assert (H13 : is_upper_bound E D). + assert (H13 : is_upper_bound E D). unfold is_upper_bound; intros; assert (H14 := H12 x1); - elim (not_and_or (D < x1) (E x1) H14); intro. - case (Rle_dec x1 D); intro. - assumption. - elim H15; auto with real. - elim H15; assumption. + 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. @@ -544,17 +543,16 @@ Lemma Heine_cor2 : a <= x <= b -> a <= y <= b -> Rabs (x - y) < delta -> Rabs (f x - f y) < eps }. Proof. - intro f; intros; case (total_order_T a b); intro. - elim s; intro. - assert (H0 := Heine_cor1 a0 H eps); elim H0; intros; exists x; + 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 b0 in H3; rewrite b0 in H5; + [ 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) r)). + elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ (Rle_trans _ _ _ H3 H4) Hgt)). Qed. Lemma SubEqui_P1 : @@ -567,7 +565,7 @@ Lemma SubEqui_P2 : forall (a b:R) (del:posreal) (h:a < b), pos_Rl (SubEqui del h) (pred (Rlength (SubEqui del h))) = b. Proof. - intros; unfold SubEqui; case (maxN del h); intros; clear a0; + 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) @@ -623,8 +621,8 @@ Proof. simpl in H; inversion H. rewrite (SubEqui_P6 del h (i:=(max_N del h))). replace (S (max_N del h)) with (pred (Rlength (SubEqui del h))). - rewrite SubEqui_P2; unfold max_N; case (maxN del h); intros; left; - elim a0; intros; assumption. + rewrite SubEqui_P2; unfold max_N; case (maxN del h) as (?&?&?); left; + assumption. rewrite SubEqui_P5; reflexivity. apply lt_n_Sn. repeat rewrite SubEqui_P6. @@ -678,11 +676,11 @@ Proof. | apply Rinv_0_lt_compat; apply Rmult_lt_0_compat; [ prove_sup0 | apply Rlt_Rminus; assumption ] ]. assert (H2 : Rmin a b = a). - unfold Rmin; case (Rle_dec a b); intro; - [ reflexivity | elim n; left; assumption ]. + apply Rlt_le in H. + unfold Rmin; decide (Rle_dec a b) with H; reflexivity. assert (H3 : Rmax a b = b). - unfold Rmax; case (Rle_dec a b); intro; - [ reflexivity | elim n; left; assumption ]. + 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))))); @@ -727,7 +725,7 @@ Proof. elim (lt_n_O _ 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_r with (pos_Rl (SubEqui del H) (max_N del H)). + 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; @@ -738,10 +736,10 @@ Proof. rewrite H13 in H12; rewrite SubEqui_P2 in H12; apply H12. rewrite SubEqui_P6. 2: apply lt_n_Sn. - unfold max_N; case (maxN del H); intros; elim a0; clear a0; - intros _ H13; replace (a + INR x * del + del) with (a + INR (S x) * del); + 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_r with (pos_Rl (SubEqui del H) I); + 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)). @@ -759,7 +757,7 @@ Proof. intros; assumption. assert (H4 : Nbound I). unfold Nbound; exists (S (max_N del H)); intros; unfold max_N; - case (maxN del H); intros; elim a0; clear a0; intros _ H5; + 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); @@ -767,12 +765,12 @@ Proof. 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); intros; apply INR_lt; + 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_r with a; do 2 rewrite (Rmult_comm 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; - elim a0; intros; apply Rlt_le_trans with b; try assumption; + apply Rlt_le_trans with b; try assumption; elim H8; intros. elim H11; intro. assumption. @@ -791,8 +789,8 @@ Proof. elim H0; assumption. rewrite SubEqui_P5; reflexivity. rewrite SubEqui_P6. - case (Rle_dec (a + INR (S N) * del) t0); intro. - assert (H11 := H6 (S N) r); elim (le_Sn_n _ H11). + destruct (Rle_dec (a + INR (S N) * del) t0) as [Hle|Hnle]. + assert (H11 := H6 (S N) Hle); elim (le_Sn_n _ H11). auto with real. apply le_lt_n_Sm; assumption. Qed. @@ -805,8 +803,8 @@ Proof. 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; case (Rle_dec a a); intros; elim H0; - intros; apply Rle_antisym; assumption. + 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. @@ -815,10 +813,9 @@ Lemma continuity_implies_RiemannInt : a <= b -> (forall x:R, a <= x <= b -> continuity_pt f x) -> Riemann_integrable f a b. Proof. - intros; case (total_order_T a b); intro; - [ elim s; intro; - [ apply RiemannInt_P6; assumption | rewrite b0; apply RiemannInt_P7 ] - | elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H r)) ]. + 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 : @@ -826,9 +823,9 @@ Lemma RiemannInt_P8 : (pr2:Riemann_integrable f b a), RiemannInt pr1 = - RiemannInt pr2. Proof. intro f; intros; eapply UL_sequence. - unfold RiemannInt; case (RiemannInt_exists pr1 RinvN RinvN_cv); - intros; apply u. - unfold RiemannInt; case (RiemannInt_exists pr2 RinvN RinvN_cv); + 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, @@ -857,7 +854,7 @@ Proof. [ assumption | unfold Rminus; rewrite Ropp_0; rewrite Rplus_0_r; apply Rabs_right; left; apply (cond_pos (RinvN n)) ]. - clear H1; unfold Un_cv in u; elim (u _ H3); clear u; intros N1 H1; + clear H1; destruct (HUn _ H3) as (N1,H1); exists (max N0 N1); intros; unfold R_dist; apply Rle_lt_trans with (Rabs @@ -881,7 +878,7 @@ Proof. -1 * RiemannInt_SF (mkStepFun (StepFun_P6 (pre (phi_sequence RinvN pr2 n))))); [ idtac | ring ]; rewrite <- StepFun_P30. - case (Rle_dec a b); intro. + destruct (Rle_dec a b) as [Hle|Hnle]. apply Rle_lt_trans with (RiemannInt_SF (mkStepFun @@ -903,11 +900,9 @@ Proof. (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; case (Rle_dec a b); intro; - [ reflexivity | elim n0; assumption ]. + unfold Rmin; decide (Rle_dec a b) with Hle; reflexivity. assert (H8 : Rmax a b = b). - unfold Rmax; case (Rle_dec a b); intro; - [ reflexivity | elim n0; assumption ]. + 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. @@ -956,11 +951,9 @@ Proof. (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; case (Rle_dec a b); intro; - [ elim n0; assumption | reflexivity ]. + unfold Rmin; decide (Rle_dec a b) with Hnle; reflexivity. assert (H8 : Rmax a b = a). - unfold Rmax; case (Rle_dec a b); intro; - [ elim n0; assumption | reflexivity ]. + 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. @@ -1007,15 +1000,6 @@ Proof. | discrR ]. Qed. -Lemma Req_EM_T : forall r1 r2:R, {r1 = r2} + {r1 <> r2}. -Proof. - intros; elim (total_order_T r1 r2); intros; - [ elim a; intro; - [ right; red; intro; rewrite H in a0; elim (Rlt_irrefl r2 a0) - | left; assumption ] - | right; red; intro; rewrite H in b; elim (Rlt_irrefl r2 b) ]. -Qed. - (* L1([a,b]) is a vectorial space *) Lemma RiemannInt_P10 : forall (f g:R -> R) (a b l:R), @@ -1023,10 +1007,9 @@ Lemma RiemannInt_P10 : 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; case (Req_EM_T l 0); - intro. - elim (X eps); intros; split with x; elim p; intros; split with x0; elim p0; - intros; split; try assumption; rewrite e; intros; + unfold Riemann_integrable; intros f g; intros; destruct (Req_EM_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; @@ -1036,9 +1019,9 @@ Proof. [ 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; elim (X0 (mkposreal _ H0)); intros; + 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; split with (mkStepFun (StepFun_P28 (Rabs l) x1 x2)); + 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))). @@ -1113,18 +1096,14 @@ Proof. 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; case (Rle_dec a b); intro; - [ reflexivity | elim n0; assumption ]. + unfold Rmin; decide (Rle_dec a b) with Hyp; reflexivity. assert (H11 : Rmax a b = b). - unfold Rmax; case (Rle_dec a b); intro; - [ reflexivity | elim n0; assumption ]. + 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; case (Rle_dec a b); intro; - [ reflexivity | elim n0; assumption ]. + unfold Rmin; decide (Rle_dec a b) with Hyp; reflexivity. assert (H11 : Rmax a b = b). - unfold Rmax; case (Rle_dec a b); intro; - [ reflexivity | elim n0; assumption ]. + 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 double; apply Rplus_lt_compat. apply Rlt_trans with (pos (un n)). @@ -1256,10 +1235,10 @@ Lemma RiemannInt_P12 : 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; case (RiemannInt_exists pr3 RinvN RinvN_cv); - case (RiemannInt_exists pr1 RinvN RinvN_cv); intros; + 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 u0 + [ 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; @@ -1278,22 +1257,22 @@ Proof. [ apply H2; assumption | rewrite H0; ring ] ] | assumption ] ]. eapply UL_sequence. - unfold RiemannInt; case (RiemannInt_exists pr3 RinvN RinvN_cv); - intros; apply u. + 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); - case (RiemannInt_exists pr2 RinvN RinvN_cv); unfold Un_cv; + 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 (u0 _ H2); clear u0; intros N0 H3; assert (H4 := RinvN_cv); + 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 (u _ H5); clear u; intros N2 H6; assert (H7 := RinvN_cv); + 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 R_dist 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). @@ -1381,11 +1360,9 @@ Proof. (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; case (Rle_dec a b); intro; - [ reflexivity | elim n0; assumption ]. + unfold Rmin; decide (Rle_dec a b) with H; reflexivity. assert (H11 : Rmax a b = b). - unfold Rmax; case (Rle_dec a b); intro; - [ reflexivity | elim n0; assumption ]. + 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 @@ -1495,7 +1472,7 @@ Lemma RiemannInt_P13 : (pr3:Riemann_integrable (fun x:R => f x + l * g x) a b), RiemannInt pr3 = RiemannInt pr1 + l * RiemannInt pr2. Proof. - intros; case (Rle_dec a b); intro; + intros; destruct (Rle_dec a b) as [Hle|Hnle]; [ apply RiemannInt_P12; assumption | assert (H : b <= a); [ auto with real @@ -1526,9 +1503,9 @@ 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; case (RiemannInt_exists pr RinvN RinvN_cv); + intros; unfold RiemannInt; destruct (RiemannInt_exists pr RinvN RinvN_cv) as (?,HUn_cv); intros; eapply UL_sequence. - apply u. + 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); @@ -1574,18 +1551,18 @@ 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; case (Rle_dec l1 l2); intro. + intros; destruct (Rle_dec l1 l2) as [Hle|Hnle]. assumption. assert (H2 : l2 < l1). auto with real. - clear n; assert (H3 : 0 < (l1 - l2) / 2). + assert (H3 : 0 < (l1 - l2) / 2). unfold Rdiv; apply Rmult_lt_0_compat; [ apply Rlt_Rminus; assumption | apply Rinv_0_lt_compat; prove_sup0 ]. elim (H1 _ H3); elim (H0 _ H3); clear H0 H1; unfold R_dist; 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_r with (- l2); + 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. @@ -1596,7 +1573,7 @@ Proof. repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym; [ ring | discrR ] | discrR ]. - apply Ropp_lt_cancel; apply Rplus_lt_reg_r with l1; + 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. @@ -1615,9 +1592,9 @@ Lemma RiemannInt_P17 : a <= b -> Rabs (RiemannInt pr1) <= RiemannInt pr2. Proof. intro f; intros; unfold RiemannInt; - case (RiemannInt_exists pr1 RinvN RinvN_cv); - case (RiemannInt_exists pr2 RinvN RinvN_cv); intros; - set (phi1 := phi_sequence RinvN pr1) in u0; + 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))) @@ -1672,10 +1649,10 @@ Lemma RiemannInt_P18 : (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); - case (RiemannInt_exists pr2 RinvN RinvN_cv); intros; + 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 u0. + 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 @@ -1718,48 +1695,48 @@ Proof. apply RinvN_cv. intro; elim (H2 n); intros; split; try assumption. intros; unfold phi2_m; simpl; unfold phi2_aux; - case (Req_EM_T t a); case (Req_EM_T t b); intros. - rewrite e0; unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0; + destruct (Req_EM_T t a) as [Heqa|Hneqa]; destruct (Req_EM_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 <- e0; apply H3; assumption. - rewrite e; unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0; + 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 <- e; apply H3; assumption. - rewrite e; unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0; + 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 <- e; apply H3; assumption. + 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; case (Rle_dec a b); intro; - [ reflexivity | elim n2; assumption ]. + unfold Rmin; destruct (Rle_dec a b) as [Heqab|Hneqab]; + [ reflexivity | elim Hneqab; assumption ]. assert (H8 : Rmax a b = b). - unfold Rmax; case (Rle_dec a b); intro; - [ reflexivity | elim n2; assumption ]. + 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 n1; symmetry ; assumption ]. - elim H6; intro; [ assumption | elim n0; assumption ]. + 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 (u _ H4); intros; exists x1; intros; + 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; - case (Req_EM_T x1 a); case (Req_EM_T x1 b); intros. - elim H3; intros; rewrite e0 in H4; elim (Rlt_irrefl _ H4). - elim H3; intros; rewrite e in H4; elim (Rlt_irrefl _ H4). - elim H3; intros; rewrite e in H5; elim (Rlt_irrefl _ H5). + destruct (Req_EM_T x1 a) as [Heqa|Hneqa]; destruct (Req_EM_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; - case (Req_EM_T x1 a); case (Req_EM_T x1 b); intros. - elim H3; intros; rewrite e0 in H4; elim (Rlt_irrefl _ H4). - elim H3; intros; rewrite e in H4; elim (Rlt_irrefl _ H4). - elim H3; intros; rewrite e in H5; elim (Rlt_irrefl _ H5). + destruct (Req_EM_T x1 a) as [ -> |Hneqa]. + elim H3; intros; elim (Rlt_irrefl _ H4). + destruct (Req_EM_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]; @@ -1775,21 +1752,19 @@ Proof. apply le_O_n. apply lt_trans with (pred (Rlength l)); [ assumption | apply lt_pred_n_n ]. apply neq_O_lt; intro; rewrite <- H12 in H6; discriminate. - unfold Rmin; case (Rle_dec a b); intro; - [ reflexivity | elim n; assumption ]. + 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 lt_le_S; assumption. apply lt_pred_n_n; apply neq_O_lt; intro; rewrite <- H13 in H6; discriminate. - unfold Rmax; case (Rle_dec a b); intro; - [ reflexivity | elim n; assumption ]. - elim H7; clear H7; intros; unfold phi2_aux; case (Req_EM_T x1 a); - case (Req_EM_T x1 b); intros. - rewrite e in H12; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H11 H12)). - rewrite e in H7; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H10 H7)). - rewrite e in H12; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H11 H12)). + unfold Rmax; decide (Rle_dec a b) with H; reflexivity. + elim H7; clear H7; intros; unfold phi2_aux; destruct (Req_EM_T x1 a) as [Heq|Hneq]; + destruct (Req_EM_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. @@ -1852,17 +1827,17 @@ Proof. intros; replace (primitive h pr a) with 0. replace (RiemannInt pr0) with (primitive h pr b). ring. - unfold primitive; case (Rle_dec a b); case (Rle_dec b b); intros; + unfold primitive; destruct (Rle_dec a b) as [Hle|[]]; destruct (Rle_dec b b) as [Hle'|Hnle']; [ apply RiemannInt_P5 - | elim n; right; reflexivity - | elim n; assumption - | elim n0; assumption ]. - symmetry ; unfold primitive; case (Rle_dec a a); - case (Rle_dec a b); intros; + | 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 n; assumption - | elim n; right; reflexivity - | elim n0; right; reflexivity ]. + | elim Hnle'; assumption + | right; reflexivity + | right; reflexivity ]. Qed. Lemma RiemannInt_P21 : @@ -1906,34 +1881,29 @@ Proof. intro; cut (IsStepFun psi3 a c). intro; split with (mkStepFun X); split with (mkStepFun X2); simpl; split. - intros; unfold phi3, psi3; case (Rle_dec t b); case (Rle_dec a t); - intros. + 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; case (Rle_dec a b); intro; - [ reflexivity | elim n; assumption ]. - unfold Rmin; case (Rle_dec a b); intro; - [ reflexivity | elim n; assumption ]. - elim n; replace a with (Rmin a c). + 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); intro; - [ reflexivity | elim n0; apply Rle_trans with b; 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; case (Rle_dec b c); intro; - [ reflexivity | elim n0; assumption ]. - unfold Rmax; case (Rle_dec a c); case (Rle_dec b c); intros; - try (elim n0; assumption || elim n0; apply Rle_trans with b; assumption). - reflexivity. - elim n; replace a with (Rmin a c). + 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); intro; - [ reflexivity | elim n1; apply Rle_trans with b; 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))). @@ -1947,33 +1917,33 @@ Proof. apply Rle_antisym. apply StepFun_P37; try assumption. simpl; intros; unfold psi3; elim H0; clear H0; intros; - case (Rle_dec a x); case (Rle_dec x b); intros; - [ elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r H0)) + 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 n; apply Rle_trans with b; [ assumption | left; assumption ] - | elim n0; apply Rle_trans with b; [ assumption | left; assumption ] ]. + | 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; - case (Rle_dec a x); case (Rle_dec x b); intros; - [ elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r H0)) + 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 n; apply Rle_trans with b; [ assumption | left; assumption ] - | elim n0; apply Rle_trans with b; [ assumption | left; assumption ] ]. + | 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; - case (Rle_dec a x); case (Rle_dec x b); intros; + destruct (Rle_dec a x) as [Hle|Hnle]; destruct (Rle_dec x b) as [Hle'|Hnle']; [ right; reflexivity - | elim n; left; assumption - | elim n; left; assumption - | elim n0; left; assumption ]. + | 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; - case (Rle_dec a x); case (Rle_dec x b); intros; + destruct (Rle_dec a x) as [Hle|Hnle]; destruct (Rle_dec x b) as [Hle'|Hnle']; [ right; reflexivity - | elim n; left; assumption - | elim n; left; assumption - | elim n0; left; assumption ]. + | elim Hnle'; left; assumption + | elim Hnle; left; assumption + | elim Hnle; left; assumption ]. apply StepFun_P46 with b; 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; @@ -1990,14 +1960,14 @@ Proof. apply lt_trans with (pred (Rlength l1)); try assumption; apply lt_pred_n_n; apply neq_O_lt; red; intro; rewrite <- H12 in H6; discriminate. - unfold Rmin; case (Rle_dec b c); intro; - [ reflexivity | elim n; assumption ]. + unfold Rmin; decide (Rle_dec b c) with Hyp2; + reflexivity. elim H7; intros; assumption. - case (Rle_dec a x); case (Rle_dec x b); intros; - [ elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r H10)) + 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 n; apply Rle_trans with b; [ assumption | left; assumption ] - | elim n0; apply Rle_trans with b; [ assumption | left; assumption ] ]. + | 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; @@ -2012,8 +1982,7 @@ Proof. rewrite <- H4; elim (RList_P6 l1); intros; apply H10; try assumption. apply lt_pred_n_n; apply neq_O_lt; red; intro; rewrite <- H12 in H6; discriminate. - unfold Rmax; case (Rle_dec a b); intro; - [ reflexivity | elim n; assumption ]. + 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). @@ -2022,11 +1991,9 @@ Proof. apply lt_trans with (pred (Rlength l1)); try assumption; apply lt_pred_n_n; apply neq_O_lt; red; intro; rewrite <- H13 in H6; discriminate. - unfold Rmin; case (Rle_dec a b); intro; - [ reflexivity | elim n; assumption ]. + unfold Rmin; decide (Rle_dec a b) with Hyp1; reflexivity. left; elim H7; intros; assumption. - case (Rle_dec a x); case (Rle_dec x b); intros; reflexivity || elim n; - 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; @@ -2042,8 +2009,7 @@ Proof. rewrite <- H4; elim (RList_P6 l1); intros; apply H10; try assumption. apply lt_pred_n_n; apply neq_O_lt; red; intro; rewrite <- H12 in H6; discriminate. - unfold Rmax; case (Rle_dec a b); intro; - [ reflexivity | elim n; assumption ]. + 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). @@ -2052,10 +2018,9 @@ Proof. apply lt_trans with (pred (Rlength l1)); try assumption; apply lt_pred_n_n; apply neq_O_lt; red; intro; rewrite <- H13 in H6; discriminate. - unfold Rmin; case (Rle_dec a b); intro; - [ reflexivity | elim n; assumption ]. + unfold Rmin; decide (Rle_dec a b) with Hyp1; reflexivity. left; elim H7; intros; assumption. - unfold phi3; case (Rle_dec a x); case (Rle_dec x b); intros; + 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; @@ -2072,14 +2037,13 @@ Proof. apply lt_trans with (pred (Rlength l1)); try assumption; apply lt_pred_n_n; apply neq_O_lt; red; intro; rewrite <- H12 in H6; discriminate. - unfold Rmin; case (Rle_dec b c); intro; - [ reflexivity | elim n; assumption ]. + unfold Rmin; decide (Rle_dec b c) with Hyp2; reflexivity. elim H7; intros; assumption. - unfold phi3; case (Rle_dec a x); case (Rle_dec x b); intros; - [ elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r H10)) + 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 n; apply Rle_trans with b; [ assumption | left; assumption ] - | elim n0; apply Rle_trans with b; [ assumption | left; assumption ] ]. + | elim Hnle; apply Rle_trans with b; [ assumption | left; assumption ] + | elim Hnle; apply Rle_trans with b; [ assumption | left; assumption ] ]. Qed. Lemma RiemannInt_P22 : @@ -2098,21 +2062,10 @@ Proof. split; assumption. split with (mkStepFun H3); split with (mkStepFun H4); split. simpl; intros; apply H. - replace (Rmin a b) with (Rmin a c). - elim H5; intros; split; try assumption. + 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. - replace (Rmax a b) with b. - replace (Rmax a c) with c. - assumption. - unfold Rmax; case (Rle_dec a c); intro; - [ reflexivity | elim n; assumption ]. - unfold Rmax; case (Rle_dec a b); intro; - [ reflexivity | elim n; apply Rle_trans with c; assumption ]. - unfold Rmin; case (Rle_dec a c); case (Rle_dec a b); intros; - [ reflexivity - | elim n; apply Rle_trans with c; assumption - | elim n; assumption - | elim n0; assumption ]. + apply Rle_max_compat_l; assumption. rewrite Rabs_right. assert (H5 : IsStepFun psi c b). apply StepFun_P46 with a. @@ -2130,15 +2083,11 @@ Proof. apply Rle_trans with (Rabs (f x - phi x)). apply Rabs_pos. apply H. - replace (Rmin a b) with a. - replace (Rmax a b) with b. - elim H6; intros; split; left. + 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. - unfold Rmax; case (Rle_dec a b); intro; - [ reflexivity | elim n; apply Rle_trans with c; assumption ]. - unfold Rmin; case (Rle_dec a b); intro; - [ reflexivity | elim n; apply Rle_trans with c; assumption ]. rewrite StepFun_P18; ring. apply Rle_lt_trans with (Rabs (RiemannInt_SF psi)). apply RRle_abs. @@ -2160,15 +2109,11 @@ Proof. apply Rle_trans with (Rabs (f x - phi x)). apply Rabs_pos. apply H. - replace (Rmin a b) with a. - replace (Rmax a b) with b. - elim H5; intros; split; left. + 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. - unfold Rmax; case (Rle_dec a b); intro; - [ reflexivity | elim n; apply Rle_trans with c; assumption ]. - unfold Rmin; case (Rle_dec a b); intro; - [ reflexivity | elim n; apply Rle_trans with c; assumption ]. rewrite StepFun_P18; ring. Qed. @@ -2191,18 +2136,10 @@ Proof. replace (Rmax a b) with (Rmax c b). elim H5; intros; split; try assumption. apply Rle_trans with (Rmin c b); try assumption. - replace (Rmin a b) with a. - replace (Rmin c b) with c. - assumption. - unfold Rmin; case (Rle_dec c b); intro; - [ reflexivity | elim n; assumption ]. - unfold Rmin; case (Rle_dec a b); intro; - [ reflexivity | elim n; apply Rle_trans with c; assumption ]. - unfold Rmax; case (Rle_dec c b); case (Rle_dec a b); intros; - [ reflexivity - | elim n; apply Rle_trans with c; assumption - | elim n; assumption - | elim n0; 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. @@ -2220,15 +2157,11 @@ Proof. apply Rle_trans with (Rabs (f x - phi x)). apply Rabs_pos. apply H. - replace (Rmin a b) with a. - replace (Rmax a b) with b. - elim H6; intros; split; left. + 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. - unfold Rmax; case (Rle_dec a b); intro; - [ reflexivity | elim n; apply Rle_trans with c; assumption ]. - unfold Rmin; case (Rle_dec a b); intro; - [ reflexivity | elim n; apply Rle_trans with c; assumption ]. rewrite StepFun_P18; ring. apply Rle_lt_trans with (Rabs (RiemannInt_SF psi)). apply RRle_abs. @@ -2250,15 +2183,11 @@ Proof. apply Rle_trans with (Rabs (f x - phi x)). apply Rabs_pos. apply H. - replace (Rmin a b) with a. - replace (Rmax a b) with b. - elim H5; intros; split; left. + 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. - unfold Rmax; case (Rle_dec a b); intro; - [ reflexivity | elim n; apply Rle_trans with c; assumption ]. - unfold Rmin; case (Rle_dec a b); intro; - [ reflexivity | elim n; apply Rle_trans with c; assumption ]. rewrite StepFun_P18; ring. Qed. @@ -2291,16 +2220,15 @@ Lemma RiemannInt_P25 : 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); - case (RiemannInt_exists pr2 RinvN RinvN_cv); - case (RiemannInt_exists pr3 RinvN RinvN_cv); intros; + 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 u. + 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 ]. - elim (u1 _ H0); clear u1; intros N1 H1; elim (u0 _ H0); clear u0; - intros N2 H2; + 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 => @@ -2357,7 +2285,7 @@ Proof. do 2 rewrite (Rmult_comm 3); repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym; [ ring | discrR ] | discrR ]. - clear x u x0 x1 eps H H0 N1 H1 N2 H2; + clear x HUn_cv x0 x1 eps H H0 N1 H1 N2 H2; assert (H1 : exists psi1 : nat -> StepFun a b, @@ -2477,25 +2405,17 @@ Proof. apply Rplus_le_compat. apply H1. elim H14; intros; split. - replace (Rmin a c) with a. + rewrite Rmin_left; eauto using Rle_trans. apply Rle_trans with b; try assumption. left; assumption. - unfold Rmin; case (Rle_dec a c); intro; - [ reflexivity | elim n0; apply Rle_trans with b; assumption ]. - replace (Rmax a c) with c. + rewrite Rmax_right; eauto using Rle_trans. left; assumption. - unfold Rmax; case (Rle_dec a c); intro; - [ reflexivity | elim n0; apply Rle_trans with b; assumption ]. apply H3. elim H14; intros; split. - replace (Rmin b c) with b. + rewrite Rmin_left; eauto using Rle_trans. left; assumption. - unfold Rmin; case (Rle_dec b c); intro; - [ reflexivity | elim n0; assumption ]. - replace (Rmax b c) with c. + rewrite Rmax_right; eauto using Rle_trans. left; assumption. - unfold Rmax; case (Rle_dec b c); intro; - [ reflexivity | elim n0; assumption ]. do 2 rewrite <- (Rplus_comm @@ -2509,26 +2429,18 @@ Proof. apply Rplus_le_compat. apply H1. elim H14; intros; split. - replace (Rmin a c) with a. + rewrite Rmin_left; eauto using Rle_trans. left; assumption. - unfold Rmin; case (Rle_dec a c); intro; - [ reflexivity | elim n0; apply Rle_trans with b; assumption ]. - replace (Rmax a c) with c. + rewrite Rmax_right; eauto using Rle_trans. apply Rle_trans with b. left; assumption. assumption. - unfold Rmax; case (Rle_dec a c); intro; - [ reflexivity | elim n0; apply Rle_trans with b; assumption ]. apply H8. elim H14; intros; split. - replace (Rmin a b) with a. + rewrite Rmin_left; trivial. left; assumption. - unfold Rmin; case (Rle_dec a b); intro; - [ reflexivity | elim n0; assumption ]. - replace (Rmax a b) with b. + rewrite Rmax_right; trivial. left; assumption. - unfold Rmax; case (Rle_dec a b); intro; - [ reflexivity | elim n0; assumption ]. do 2 rewrite StepFun_P30. do 2 rewrite Rmult_1_l; replace @@ -2571,27 +2483,27 @@ Lemma RiemannInt_P26 : (pr2:Riemann_integrable f b c) (pr3:Riemann_integrable f a c), RiemannInt pr1 + RiemannInt pr2 = RiemannInt pr3. Proof. - intros; case (Rle_dec a b); case (Rle_dec b c); intros. + intros; destruct (Rle_dec a b) as [Hle|Hnle]; destruct (Rle_dec b c) as [Hle'|Hnle']. apply RiemannInt_P25; assumption. - case (Rle_dec a c); intro. + destruct (Rle_dec a c) as [Hle''|Hnle'']. assert (H : c <= b). auto with real. - rewrite <- (RiemannInt_P25 pr3 (RiemannInt_P1 pr2) pr1 r0 H); + 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 r); + 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. - case (Rle_dec a c); intro. - rewrite <- (RiemannInt_P25 (RiemannInt_P1 pr1) pr3 pr2 H r0); + 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) r H0); + 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)); @@ -2616,13 +2528,13 @@ Proof. assert (H4 : 0 < del). unfold del; unfold Rmin; case (Rle_dec (b - x) (x - a)); intro. - case (Rle_dec x0 (b - x)); intro; + destruct (Rle_dec x0 (b - x)) as [Hle|Hnle]; [ elim H3; intros; assumption | apply Rlt_Rminus; assumption ]. - case (Rle_dec x0 (x - a)); intro; + destruct (Rle_dec x0 (x - a)) as [Hle'|Hnle']; [ elim H3; intros; assumption | apply Rlt_Rminus; assumption ]. split with (mkposreal _ H4); intros; assert (H7 : Riemann_integrable f x (x + h0)). - case (Rle_dec x (x + h0)); intro. + 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 ]. @@ -2659,7 +2571,7 @@ Proof. with ((RiemannInt H7 - RiemannInt (RiemannInt_P14 x (x + h0) (f x))) / h0). replace (RiemannInt H7 - RiemannInt (RiemannInt_P14 x (x + h0) (f x))) with (RiemannInt (RiemannInt_P10 (-1) H7 (RiemannInt_P14 x (x + h0) (f x)))). - unfold Rdiv; rewrite Rabs_mult; case (Rle_dec x (x + h0)); intro. + unfold Rdiv; rewrite Rabs_mult; destruct (Rle_dec x (x + h0)) as [Hle|Hnle]. apply Rle_lt_trans with (RiemannInt (RiemannInt_P16 @@ -2678,14 +2590,14 @@ Proof. 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; case (Req_dec x x1); intro. + 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. + elim H3; intros; left; apply H11. repeat split. assumption. rewrite Rabs_right. - apply Rplus_lt_reg_r with x; replace (x + (x1 - x)) with x1; [ idtac | ring ]. + 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. @@ -2707,8 +2619,8 @@ Proof. apply Rinv_r_sym. assumption. apply Rle_ge; left; apply Rinv_0_lt_compat. - elim r; intro. - apply Rplus_lt_reg_r with x; rewrite Rplus_0_r; assumption. + 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 @@ -2748,7 +2660,7 @@ Proof. repeat split. assumption. rewrite Rabs_left. - apply Rplus_lt_reg_r with (x1 - x0); replace (x1 - x0 + x0) with x1; + apply Rplus_lt_reg_l with (x1 - x0); replace (x1 - x0 + x0) with x1; [ idtac | ring ]. replace (x1 - x0 + - (x1 - x)) with (x - x0); [ idtac | ring ]. apply Rle_lt_trans with (x + h0). @@ -2758,7 +2670,7 @@ Proof. apply Rle_trans with del; [ left; assumption | unfold del; apply Rmin_l ]. elim H8; intros; assumption. - apply Rplus_lt_reg_r with x; rewrite Rplus_0_r; + apply Rplus_lt_reg_l with x; rewrite Rplus_0_r; replace (x + (x1 - x)) with x1; [ elim H8; intros; assumption | ring ]. unfold fct_cte; ring. rewrite RiemannInt_P15. @@ -2778,7 +2690,7 @@ Proof. apply Rinv_lt_0_compat. assert (H8 : x + h0 < x). auto with real. - apply Rplus_lt_reg_r with x; rewrite Rplus_0_r; assumption. + apply Rplus_lt_reg_l with x; rewrite Rplus_0_r; assumption. rewrite (RiemannInt_P13 H7 (RiemannInt_P14 x (x + h0) (f x)) (RiemannInt_P10 (-1) H7 (RiemannInt_P14 x (x + h0) (f x)))) @@ -2792,9 +2704,11 @@ Proof. cut (a <= x + h0). cut (x + h0 <= b). intros; unfold primitive. - case (Rle_dec a (x + h0)); case (Rle_dec (x + h0) b); case (Rle_dec a x); - case (Rle_dec x b); intros; try (elim n; assumption || left; assumption). - rewrite <- (RiemannInt_P26 (FTC_P1 h C0 r0 r) H7 (FTC_P1 h C0 r2 r1)); ring. + 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). @@ -2854,11 +2768,11 @@ Proof. unfold R_dist; intros; set (del := Rmin x0 (Rmin x1 (b - a))); assert (H10 : 0 < del). unfold del; unfold Rmin; case (Rle_dec x1 (b - a)); intros. - case (Rle_dec x0 x1); intro; + destruct (Rle_dec x0 x1) as [Hle|Hnle]; [ apply (cond_pos x0) | elim H9; intros; assumption ]. - case (Rle_dec x0 (b - a)); intro; + destruct (Rle_dec x0 (b - a)) as [Hle'|Hnle']; [ apply (cond_pos x0) | apply Rlt_Rminus; assumption ]. - split with (mkposreal _ H10); intros; case (Rcase_abs h0); intro. + 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. @@ -2914,7 +2828,7 @@ Proof. repeat split. assumption. rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; rewrite Rabs_right. - apply Rplus_lt_reg_r with (x2 - x1); + 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). @@ -2957,11 +2871,11 @@ Proof. | assumption ]. cut (a <= b + h0). cut (b + h0 <= b). - intros; unfold primitive; case (Rle_dec a (b + h0)); - case (Rle_dec (b + h0) b); case (Rle_dec a b); case (Rle_dec b b); - intros; try (elim n; right; reflexivity) || (elim n; left; assumption). - rewrite <- (RiemannInt_P26 (FTC_P1 h C0 r3 r2) H13 (FTC_P1 h C0 r1 r0)); ring. - elim n; 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. left; assumption. apply Rplus_le_reg_l with (- a - h0). replace (- a - h0 + a) with (- h0); [ idtac | ring ]. @@ -2979,22 +2893,22 @@ Proof. [ 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 _ _ r); elim H14; intro. + assert (H14 := Rge_le _ _ Hnle); elim H14; intro. assumption. elim H11; symmetry ; assumption. - unfold primitive; case (Rle_dec a (b + h0)); - case (Rle_dec (b + h0) b); intros; - [ elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r0 H14)) + 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 - | elim n; left; apply Rlt_trans with b; assumption - | elim n0; left; apply Rlt_trans with b; assumption ]. + | 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; - case (Rle_dec a b); case (Rle_dec b b); intros; + destruct (Rle_dec a b) as [Hle'|Hnle']; destruct (Rle_dec b b) as [Hle''|[]]; [ apply RiemannInt_P5 - | elim n; right; reflexivity - | elim n; left; assumption - | elim n; right; reflexivity ]. + | 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)). @@ -3028,16 +2942,18 @@ Proof. apply (cond_pos x0). apply Rlt_Rminus; assumption. split with (mkposreal _ H9). - intros; case (Rcase_abs h0); intro. + 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. - case (Rle_dec a (a + h0)); case (Rle_dec (a + h0) b); case (Rle_dec a a); - case (Rle_dec a b); intros; - try (elim n; left; assumption) || (elim n; right; reflexivity). - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r3 H12)). - elim n; left; apply Rlt_trans with a; assumption. + 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. @@ -3045,10 +2961,10 @@ Proof. [ assumption | unfold del; apply Rmin_l ]. unfold f_a; ring. unfold f_a; ring. - elim n; left; apply Rlt_trans with a; assumption. + 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 _ _ r); elim H12; intro. + assert (H12 := Rge_le _ _ Hnle); elim H12; intro. assumption. elim H10; symmetry ; assumption. assert (H13 : Riemann_integrable f a (a + h0)). @@ -3097,7 +3013,7 @@ Proof. elim H8; intros; left; apply H17; repeat split. assumption. rewrite Rabs_right. - apply Rplus_lt_reg_r with a; replace (a + (x2 - a)) with x2; [ idtac | ring ]. + 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). @@ -3121,7 +3037,7 @@ Proof. rewrite Rplus_comm; unfold Rminus; rewrite Rplus_assoc; rewrite Rplus_opp_r; rewrite Rplus_0_r; rewrite <- Rinv_r_sym; [ reflexivity | assumption ]. - apply Rle_ge; left; apply Rinv_0_lt_compat; assert (H14 := Rge_le _ _ r); + apply Rle_ge; left; apply Rinv_0_lt_compat; assert (H14 := Rge_le _ _ Hnle); elim H14; intro. assumption. elim H10; symmetry ; assumption. @@ -3136,13 +3052,13 @@ Proof. rewrite Rmult_assoc; rewrite <- Rinv_r_sym; [ ring | assumption ]. cut (a <= a + h0). cut (a + h0 <= b). - intros; unfold primitive; case (Rle_dec a (a + h0)); - case (Rle_dec (a + h0) b); case (Rle_dec a a); case (Rle_dec a b); - intros; try (elim n; right; reflexivity) || (elim n; left; assumption). + 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. - elim n; assumption. - elim n; assumption. 2: left; assumption. apply Rplus_le_reg_l with (- a); replace (- a + (a + h0)) with h0; [ idtac | ring ]. @@ -3189,18 +3105,18 @@ Proof. 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; case (Rle_dec x0 x1); intro. + 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; case (Rcase_abs h0); intro. + 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; case (Rle_dec a (a + h0)); - case (Rle_dec (a + h0) b); case (Rle_dec a a); case (Rle_dec a b); - intros; try (elim n; right; assumption || reflexivity). - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r3 H10)). - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r2 H10)). + 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. @@ -3208,27 +3124,26 @@ Proof. unfold del; apply Rmin_l. unfold f_a; ring. unfold f_a; ring. - elim n; rewrite <- H0; left; assumption. assert (H10 : a < a + h0). pattern a at 1; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l. - assert (H10 := Rge_le _ _ r); elim H10; intro. + assert (H10 := Rge_le _ _ Hnle); elim H10; intro. assumption. elim H8; symmetry ; assumption. - rewrite H0 in H1; rewrite H1; unfold primitive; - case (Rle_dec a (b + h0)); case (Rle_dec (b + h0) b); - case (Rle_dec a b); case (Rle_dec b b); intros; - try (elim n; right; assumption || reflexivity). - rewrite H0 in H10; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r2 H10)). - repeat rewrite RiemannInt_P9. - replace (RiemannInt (FTC_P1 h C0 r1 r0)) with (f_b b). + 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. - elim n; rewrite <- H0; left; assumption. - elim n0; rewrite <- H0; left; assumption. Qed. Lemma RiemannInt_P29 : @@ -3266,7 +3181,7 @@ Qed. Lemma RiemannInt_P32 : forall (f:C1_fun) (a b:R), Riemann_integrable (derive f (diff0 f)) a b. Proof. - intro f; intros; case (Rle_dec a b); intro; + 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); @@ -3296,10 +3211,45 @@ 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; case (Rle_dec a b); intro; + 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/theories/Reals/RiemannInt_SF.v b/theories/Reals/RiemannInt_SF.v index 8eb49bf3..1484ab2a 100644 --- a/theories/Reals/RiemannInt_SF.v +++ b/theories/Reals/RiemannInt_SF.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* y <= x - 1). - intro; assert (H14 := H5 _ H13); cut (x - 1 < x). - intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H14 H15)). + intro H13; assert (H14 := H5 _ H13); cut (x - 1 < x). + intro H15; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H14 H15)). apply Rminus_lt; replace (x - 1 - x) with (-1); [ idtac | ring ]; rewrite <- Ropp_0; apply Ropp_lt_gt_contravar; apply Rlt_0_1. - intros; assert (H14 := H4 _ H13); elim H14; intro; unfold E in H13; elim H13; - intros; elim H16; intros; apply Rplus_le_reg_l with 1. + 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. 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; rewrite H19; apply le_INR; apply lt_le_S; apply INR_lt; rewrite H18; + intro H19; rewrite H19; apply le_INR; apply lt_le_S; apply INR_lt; rewrite H18; rewrite <- H19; assumption. - rewrite H10; rewrite p; rewrite <- INR_IZR_INZ; replace 1 with (INR 1); + rewrite H10; rewrite H8; rewrite <- INR_IZR_INZ; replace 1 with (INR 1); [ idtac | reflexivity ]; rewrite <- minus_INR. replace (x0 - 1)%nat with (pred x0); [ reflexivity | case x0; [ reflexivity | intro; simpl; apply minus_n_O ] ]. - induction x0 as [| x0 Hrecx0]; - [ rewrite p in H7; rewrite <- INR_IZR_INZ in H7; simpl in H7; - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H6 H7)) - | apply le_n_S; apply le_O_n ]. - rewrite H15 in H13; elim H12; assumption. + 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 le_O_n. + rewrite H15 in H13; elim H12; assumption. split with (pred x0); unfold E in H13; elim H13; intros; elim H12; intros; - rewrite H10 in H15; rewrite p in H15; rewrite <- INR_IZR_INZ in H15; + 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; @@ -144,7 +143,7 @@ Definition subdivision (a b:R) (f:StepFun a b) : Rlist := projT1 (pre f). Definition subdivision_val (a b:R) (f:StepFun a b) : Rlist := match projT2 (pre f) with - | existT a b => a + | existT _ a b => a end. Fixpoint Int_SF (l k:Rlist) : R := @@ -173,8 +172,8 @@ 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)); intros; - apply a0. + intros a b f; unfold subdivision_val; case (projT2 (pre f)) as (x,H); + apply H. Qed. Lemma StepFun_P2 : @@ -201,19 +200,17 @@ Proof. intros; unfold adapted_couple; repeat split. unfold ordered_Rlist; intros; simpl in H0; inversion H0; [ simpl; assumption | elim (le_Sn_O _ H2) ]. - simpl; unfold Rmin; case (Rle_dec a b); intro; - [ reflexivity | elim n; assumption ]. - simpl; unfold Rmax; case (Rle_dec a b); intro; - [ reflexivity | elim n; assumption ]. + 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 (le_Sn_O _ H3) ]. Qed. Lemma StepFun_P4 : forall a b c:R, IsStepFun (fct_cte c) a b. Proof. - intros; unfold IsStepFun; case (Rle_dec a b); intro. + 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 r). + 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. @@ -244,17 +241,15 @@ Lemma StepFun_P7 : Proof. unfold adapted_couple; intros; decompose [and] H0; clear H0; assert (H5 : Rmax a b = b). - unfold Rmax; case (Rle_dec a b); intro; - [ reflexivity | elim n; assumption ]. + 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; case (Rle_dec r2 b); intro; - [ reflexivity | elim n; assumption ]. - unfold Rmax; case (Rle_dec r2 b); intro; - [ rewrite H5 in H2; rewrite <- H2; reflexivity | elim n; 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. @@ -340,33 +335,28 @@ Proof. 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; case (Rle_dec a b); intro; - [ reflexivity | elim n; assumption ]. + 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 (le_Sn_O _ H10) ]. - simpl; unfold Rmin; case (Rle_dec a b); intro; - [ reflexivity | elim n; assumption ]. - simpl; unfold Rmax; case (Rle_dec a b); intro; - [ reflexivity | elim n; assumption ]. + 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 lt_O_Sn. unfold open_interval; simpl; rewrite H7; simpl in H13; - rewrite H13; unfold Rmin; case (Rle_dec a b); - intro; [ assumption | elim n; assumption ]. + rewrite H13; unfold Rmin; decide (Rle_dec a b) with H0; assumption. elim (le_Sn_O _ H10). intros; simpl in H8; elim (lt_n_O _ H8). intros; simpl in H8; inversion H8; [ simpl; assumption | elim (le_Sn_O _ H10) ]. assert (Hyp_min : Rmin t2 b = t2). - unfold Rmin; case (Rle_dec t2 b); intro; - [ reflexivity | elim n; assumption ]. + unfold Rmin; decide (Rle_dec t2 b) with H5; reflexivity. 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']. @@ -391,18 +381,16 @@ Proof. apply (H16 (S i)); simpl; assumption. simpl; simpl in H14; rewrite H14; reflexivity. simpl; simpl in H18; rewrite H18; unfold Rmax; - case (Rle_dec a b); case (Rle_dec t2 b); intros; reflexivity || elim n; - assumption. + 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; case (total_order_T x t2); intro. - elim s; intro. + simpl; simpl in H6; destruct (total_order_T x t2) as [[Hlt|Heq]|Hgt]. apply (H17 0%nat); [ simpl; apply lt_O_Sn | unfold open_interval; simpl; elim H6; intros; split; assumption ]. - rewrite b0; assumption. + rewrite Heq; assumption. rewrite H10; apply (H22 0%nat); [ simpl; apply lt_O_Sn | unfold open_interval; simpl; replace s1 with t2; @@ -440,8 +428,7 @@ Proof. assumption. simpl; simpl in H19; apply H19. rewrite H9; simpl; simpl in H13; rewrite H13; unfold Rmax; - case (Rle_dec t2 b); case (Rle_dec a b); intros; reflexivity || elim n; - assumption. + 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]. @@ -483,8 +470,7 @@ Proof. assumption. simpl; simpl in H18; apply H18. rewrite H9; simpl; simpl in H12; rewrite H12; unfold Rmax; - case (Rle_dec t2 b); case (Rle_dec a b); intros; reflexivity || elim n; - assumption. + 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]. @@ -511,8 +497,7 @@ Proof. 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; case (Rle_dec a b); intro; - [ reflexivity | elim n; assumption ] ]. + | unfold Rmax; decide (Rle_dec a b) with H0; reflexivity ]. Qed. Lemma StepFun_P11 : @@ -528,7 +513,7 @@ Proof. simpl in H10; simpl in H5; rewrite H10; rewrite H5; reflexivity. assert (H14 := H3 0%nat (lt_O_Sn _)); simpl in H14; elim H14; intro. assert (H15 := H7 0%nat (lt_O_Sn _)); simpl in H15; elim H15; intro. - rewrite <- H12 in H1; case (Rle_dec r1 s2); intro; try assumption. + rewrite <- H12 in H1; destruct (Rle_dec r1 s2) as [Hle|Hnle]; try assumption. assert (H16 : s2 < r1); auto with real. induction s3 as [| r0 s3 Hrecs3]. simpl in H9; rewrite H9 in H16; cut (r1 <= Rmax a b). @@ -662,12 +647,11 @@ Lemma StepFun_P13 : 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; case (total_order_T a b); intro. - elim s; intro. - eapply StepFun_P11; [ apply a0 | apply H0 | apply H1 ]. + 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 r0 | apply StepFun_P2; apply H0 | apply StepFun_P12; apply H1 ]. + [ apply Hgt | apply StepFun_P2; apply H0 | apply StepFun_P12; apply H1 ]. Qed. Lemma StepFun_P14 : @@ -689,11 +673,9 @@ Proof. 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; case (Rle_dec a b); intro; - [ reflexivity | elim n; assumption ]. + unfold Rmin; decide (Rle_dec a b) with H1; reflexivity. assert (Hyp_max : Rmax a b = b). - unfold Rmax; case (Rle_dec a b); intro; - [ reflexivity | elim n; assumption ]. + 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; @@ -883,8 +865,8 @@ Lemma StepFun_P15 : 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; case (Rle_dec a b); intro; - [ apply (StepFun_P14 r H H0) + 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; @@ -897,8 +879,8 @@ Lemma StepFun_P16 : exists l' : Rlist, (exists lf' : Rlist, adapted_couple_opt f a b l' lf'). Proof. - intros; case (Rle_dec a b); intro; - [ apply (StepFun_P10 r H) + 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; @@ -961,9 +943,8 @@ Lemma StepFun_P21 : forall (a b:R) (f:R -> R) (l:Rlist), is_subdivision f a b l -> adapted_couple f a b l (FF l f). Proof. - intros; unfold adapted_couple; unfold is_subdivision in X; - unfold adapted_couple in X; elim X; clear X; intros; - decompose [and] p; clear p; repeat split; try assumption. + intros * (x & H & H1 & H0 & H2 & H4). + repeat split; try assumption. apply StepFun_P20; rewrite H2; apply lt_O_Sn. intros; assert (H5 := H4 _ H3); unfold constant_D_eq, open_interval in H5; unfold constant_D_eq, open_interval; intros; @@ -1003,11 +984,9 @@ Lemma StepFun_P22 : 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; case (Rle_dec a b); intro; - [ reflexivity | elim n; assumption ]. + unfold Rmin; decide (Rle_dec a b) with Hyp; reflexivity. assert (Hyp_max : Rmax a b = b). - unfold Rmax; case (Rle_dec a b); intro; - [ reflexivity | elim n; assumption ]. + 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; @@ -1221,13 +1200,13 @@ Proof. [ apply lt_n_S; assumption | symmetry ; apply S_pred with 0%nat; apply neq_O_lt; red; intro; rewrite <- H22 in H21; elim (lt_n_O _ H21) ]. - elim (Rle_dec (pos_Rl lf (S x0)) (pos_Rl (cons_ORlist lf lg) i)); intro. + 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 (le_Sn_n _ H23). assert (H23 : pos_Rl (cons_ORlist lf lg) i < pos_Rl lf (S x0)). auto with real. - clear b0; apply RList_P17; try assumption. + 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; @@ -1255,11 +1234,9 @@ Lemma StepFun_P24 : 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; case (Rle_dec a b); intro; - [ reflexivity | elim n; assumption ]. + unfold Rmin; decide (Rle_dec a b) with Hyp; reflexivity. assert (Hyp_max : Rmax a b = b). - unfold Rmax; case (Rle_dec a b); intro; - [ reflexivity | elim n; assumption ]. + 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; @@ -1471,12 +1448,12 @@ Proof. apply lt_n_S; assumption. symmetry ; apply S_pred with 0%nat; apply neq_O_lt; red; intro; rewrite <- H22 in H21; elim (lt_n_O _ H21). - elim (Rle_dec (pos_Rl lg (S x0)) (pos_Rl (cons_ORlist lf lg) i)); intro. + 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 (le_Sn_n _ H23) ]. assert (H23 : pos_Rl (cons_ORlist lf lg) i < pos_Rl lg (S x0)). auto with real. - clear b0; apply RList_P17; try assumption; + 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; @@ -1652,7 +1629,7 @@ Lemma StepFun_P34 : a <= b -> Rabs (RiemannInt_SF f) <= RiemannInt_SF (mkStepFun (StepFun_P32 f)). Proof. - intros; unfold RiemannInt_SF; case (Rle_dec a b); intro. + 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 @@ -1663,7 +1640,6 @@ Proof. 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))) ]. - elim n; assumption. Qed. Lemma StepFun_P35 : @@ -1741,24 +1717,21 @@ Lemma StepFun_P36 : (forall x:R, a < x < b -> f x <= g x) -> RiemannInt_SF f <= RiemannInt_SF g. Proof. - intros; unfold RiemannInt_SF; case (Rle_dec a b); intro. + 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; case (Rle_dec a b); intro; - [ reflexivity | elim n; assumption ] + [ unfold Rmin; decide (Rle_dec a b) with H; reflexivity | assert (H7 : Rmax a b = b); - [ unfold Rmax; case (Rle_dec a b); intro; - [ reflexivity | elim n; assumption ] + [ 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 ]. - elim n; assumption. Qed. Lemma StepFun_P37 : @@ -1819,8 +1792,7 @@ Proof. 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 lt_O_Sn. - unfold Rmin; case (Rle_dec r1 b); intro; - [ reflexivity | elim n; assumption ]. + unfold Rmin; decide (Rle_dec r1 b) with H7; reflexivity. apply (H10 i); apply lt_S_n. replace (S (pred (Rlength lg))) with (Rlength lg). apply H9. @@ -1829,8 +1801,7 @@ Proof. simpl; assert (H14 : a <= b). rewrite <- H1; simpl in H0; rewrite <- H0; apply RList_P7; [ assumption | left; reflexivity ]. - unfold Rmin; case (Rle_dec a b); intro; - [ reflexivity | elim n; assumption ]. + 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 ]. @@ -1838,14 +1809,13 @@ Proof. rewrite <- H11; induction lg as [| r0 lg Hreclg]. simpl in H13; discriminate. reflexivity. - unfold Rmax; case (Rle_dec a b); case (Rle_dec r1 b); intros; - reflexivity || elim n; assumption. + 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; case (Rle_dec r1 b); intro; - [ reflexivity | elim n; assumption ]. + 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)). @@ -1862,9 +1832,9 @@ Proof. 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); intro. + case (Rle_dec r1 x) as [|[]]. reflexivity. - elim n; replace r1 with (Rmin r1 b). + 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. @@ -1874,12 +1844,9 @@ Proof. apply lt_trans with (pred (Rlength lg)); try assumption. apply lt_pred_n_n; apply neq_O_lt; red; intro; rewrite <- H22 in H17; elim (lt_n_O _ H17). - unfold Rmin; case (Rle_dec r1 b); intro; - [ reflexivity | elim n0; assumption ]. + unfold Rmin; decide (Rle_dec r1 b) with H7; reflexivity. exists (mkStepFun H8); split. - simpl; unfold g'; case (Rle_dec r1 b); intro. - assumption. - elim n; assumption. + 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'; @@ -1896,9 +1863,9 @@ Proof. 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); intro. + case (Rle_dec r1 x) as [|[]]. reflexivity. - elim n; elim H13; clear H13; intros; + 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; @@ -1954,24 +1921,22 @@ Proof. 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); - case (Rle_dec b c); intros; - (right; reflexivity) || (elim n; left; 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 b); case (Rle_dec a c); - intros; + rewrite H5; unfold Rmin, Rmax; case (Rle_dec a c) as [|[]]; case (Rle_dec a b) as [|[]]; [ reflexivity - | elim n; apply Rle_trans with b; left; assumption - | elim n; left; assumption - | elim n0; left; assumption ]. + | 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 b c); case (Rle_dec a c); - intros; + rewrite H9; unfold Rmin, Rmax; case (Rle_dec a c) as [|[]]; case (Rle_dec b c) as [|[]]; [ reflexivity - | elim n; apply Rle_trans with b; left; assumption - | elim n; left; assumption - | elim n0; left; assumption ]. + | left; assumption + | apply Rle_trans with b; left; assumption + | left; assumption ]. red; intro; rewrite H1 in H11; discriminate. apply StepFun_P20. rewrite RList_P23; apply neq_O_lt; red; intro. @@ -2061,7 +2026,7 @@ Proof. assert (H16 : pos_Rl (cons_Rlist l1 l2) (S i) = b). rewrite RList_P29. rewrite H15; rewrite <- minus_n_n; rewrite H10; unfold Rmin; - case (Rle_dec b c); intro; [ reflexivity | elim n; left; assumption ]. + case (Rle_dec b c) as [|[]]; [ reflexivity | left; assumption ]. rewrite H15; apply le_n. induction l1 as [| r l1 Hrecl1]. simpl in H15; discriminate. @@ -2069,8 +2034,8 @@ Proof. assert (H17 : pos_Rl (cons_Rlist l1 l2) i = b). rewrite RList_P26. replace i with (pred (Rlength l1)); - [ rewrite H4; unfold Rmax; case (Rle_dec a b); intro; - [ reflexivity | elim n; left; assumption ] + [ rewrite H4; unfold Rmax; case (Rle_dec a b) as [|[]]; + [ reflexivity | left; assumption ] | rewrite H15; reflexivity ]. rewrite H15; apply lt_n_Sn. rewrite H16 in H2; rewrite H17 in H2; elim H2; intros; @@ -2095,8 +2060,8 @@ Proof. 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); intro; - [ assumption | elim n; left; assumption ]. + 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 le_n_S; apply le_O_n. elim (RList_P20 _ H18); intros r1 [r2 [r3 H19]]; rewrite H19; @@ -2222,9 +2187,9 @@ Proof. | left _ => Int_SF lf3 l3 | right _ => - Int_SF lf3 l3 end. - case (Rle_dec a b); case (Rle_dec b c); case (Rle_dec a c); intros. - elim r1; intro. - elim r0; intro. + 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. + elim Hle'; intro. replace (Int_SF lf3 l3) with (Int_SF (FF (cons_Rlist l1 l2) f) (cons_Rlist l1 l2)). replace (Int_SF lf1 l1) with (Int_SF (FF l1 f) l1). @@ -2232,8 +2197,7 @@ Proof. 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; - case (Rle_dec a b); case (Rle_dec b c); intros; reflexivity || elim n; - assumption. + 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 @@ -2250,13 +2214,13 @@ Proof. rewrite Rplus_0_l; eapply StepFun_P17; [ apply H2 | rewrite H in H3; apply H3 ]. symmetry ; eapply StepFun_P8; [ apply H1 | assumption ]. - elim n; apply Rle_trans with b; 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 r; intro. + elim Hle''; intro. rewrite Rplus_comm; replace (Int_SF lf1 l1) with (Int_SF (FF (cons_Rlist l3 l2) f) (cons_Rlist l3 l2)). @@ -2264,12 +2228,9 @@ Proof. 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; - case (Rle_dec a c); case (Rle_dec b c); intros; - [ elim n; assumption - | reflexivity - | elim n0; assumption - | elim n1; assumption ]. + 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 ]. @@ -2284,7 +2245,7 @@ Proof. symmetry ; eapply StepFun_P8; [ apply H3 | assumption ]. replace (Int_SF lf2 l2) with (Int_SF lf3 l3 + Int_SF lf1 l1). ring. - elim r; intro. + elim Hle; intro. replace (Int_SF lf2 l2) with (Int_SF (FF (cons_Rlist l3 l1) f) (cons_Rlist l3 l1)). replace (Int_SF lf3 l3) with (Int_SF (FF l3 f) l3). @@ -2292,11 +2253,7 @@ Proof. 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; - case (Rle_dec a c); case (Rle_dec a b); intros; - [ elim n; assumption - | elim n1; assumption - | reflexivity - | elim n1; assumption ]. + 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 ]. @@ -2316,7 +2273,7 @@ Proof. auto with real. replace (Int_SF lf2 l2) with (Int_SF lf3 l3 + Int_SF lf1 l1). ring. - rewrite Rplus_comm; elim r; intro. + rewrite Rplus_comm; elim Hle''; intro. replace (Int_SF lf2 l2) with (Int_SF (FF (cons_Rlist l1 l3) f) (cons_Rlist l1 l3)). replace (Int_SF lf3 l3) with (Int_SF (FF l3 f) l3). @@ -2324,11 +2281,8 @@ Proof. 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; - case (Rle_dec a c); case (Rle_dec a b); intros; - [ elim n; assumption - | reflexivity - | elim n0; assumption - | elim n1; assumption ]. + 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 ]. @@ -2346,7 +2300,7 @@ Proof. auto with real. replace (Int_SF lf1 l1) with (Int_SF lf2 l2 + Int_SF lf3 l3). ring. - elim r; intro. + elim Hle'; intro. replace (Int_SF lf1 l1) with (Int_SF (FF (cons_Rlist l2 l3) f) (cons_Rlist l2 l3)). replace (Int_SF lf3 l3) with (Int_SF (FF l3 f) l3). @@ -2354,11 +2308,8 @@ Proof. 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; - case (Rle_dec a c); case (Rle_dec b c); intros; - [ elim n; assumption - | elim n1; assumption - | reflexivity - | elim n1; assumption ]. + 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 ]. @@ -2371,8 +2322,8 @@ Proof. 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 n; apply Rle_trans with a; try assumption. + 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. @@ -2387,11 +2338,8 @@ Proof. 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; - case (Rle_dec a b); case (Rle_dec b c); intros; - [ elim n1; assumption - | elim n1; assumption - | elim n0; assumption - | reflexivity ]. + 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 ]. @@ -2463,10 +2411,8 @@ Proof. replace a with (Rmin a b). pattern b at 2; replace b with (Rmax a b). rewrite <- H2; rewrite H3; reflexivity. - unfold Rmax; case (Rle_dec a b); intro; - [ reflexivity | elim n; assumption ]. - unfold Rmin; case (Rle_dec a b); intro; - [ reflexivity | elim n; assumption ]. + 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. @@ -2475,20 +2421,18 @@ Proof. discriminate. clear Hreclf1; assert (H1 : {c <= r1} + {r1 < c}). case (Rle_dec c r1); intro; [ left; assumption | right; auto with real ]. - elim H1; intro. + 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); intro; + simpl in H4; rewrite H4; unfold Rmin; case (Rle_dec a b) as [|[]]; [ reflexivity - | elim n; elim H0; intros; apply Rle_trans with c; assumption ]. + | 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 (le_Sn_O _ H10) ]. - simpl; unfold Rmin; case (Rle_dec a c); intro; - [ assumption | elim n; assumption ]. - simpl; unfold Rmax; case (Rle_dec a c); intro; - [ reflexivity | elim n; assumption ]. + 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); @@ -2508,8 +2452,8 @@ Proof. assert (H14 : a <= b). elim H0; intros; apply Rle_trans with c; assumption. assert (H16 : r = a). - simpl in H7; rewrite H7; unfold Rmin; case (Rle_dec a b); intro; - [ reflexivity | elim n; assumption ]. + 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. @@ -2517,18 +2461,18 @@ Proof. simpl; replace r4 with r1. apply (H5 0%nat). simpl; apply lt_O_Sn. - simpl in H12; rewrite H12; unfold Rmin; case (Rle_dec r1 c); intro; - [ reflexivity | elim n; left; assumption ]. + simpl in H12; rewrite H12; unfold Rmin; case (Rle_dec r1 c) as [|[]]; + [ reflexivity | left; assumption ]. apply (H9 i); simpl; apply lt_S_n; assumption. - simpl; unfold Rmin; case (Rle_dec a c); intro; - [ assumption | elim n; elim H0; intros; 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 r1 c); case (Rle_dec a c); intros; - [ reflexivity - | elim n; elim H0; intros; assumption - | elim n; left; assumption - | elim n0; left; assumption ]. + 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]. @@ -2539,8 +2483,8 @@ Proof. 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); intro; - [ reflexivity | elim n; left; assumption ]. + simpl in H12; rewrite H12; unfold Rmin; case (Rle_dec r1 c) as [|[]]; + [ reflexivity | left; assumption ]. clear Hreci; simpl; apply H15. simpl; apply lt_S_n; assumption. unfold open_interval; apply H4. @@ -2578,10 +2522,8 @@ Proof. replace a with (Rmin a b). pattern b at 2; replace b with (Rmax a b). rewrite <- H2; rewrite H3; reflexivity. - unfold Rmax; case (Rle_dec a b); intro; - [ reflexivity | elim n; assumption ]. - unfold Rmin; case (Rle_dec a b); intro; - [ reflexivity | elim n; assumption ]. + 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. @@ -2590,22 +2532,22 @@ Proof. discriminate. clear Hreclf1; assert (H1 : {c <= r1} + {r1 < c}). case (Rle_dec c r1); intro; [ left; assumption | right; auto with real ]. - elim H1; intro. + 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); intro; - [ reflexivity | elim n; elim H0; intros; 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 a b); case (Rle_dec c b); intros; + unfold Rmax; case (Rle_dec c b) as [|[]]; case (Rle_dec a b) as [|[]]; [ reflexivity - | elim n; elim H0; intros; assumption - | elim n; elim H0; intros; apply Rle_trans with c; assumption - | elim n0; elim H0; intros; apply Rle_trans with c; assumption ]. + | 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; @@ -2615,9 +2557,9 @@ Proof. 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); intros; + simpl in H4; rewrite H4; unfold Rmin; case (Rle_dec a b) as [|[]]; [ reflexivity - | elim n; elim H0; intros; apply Rle_trans with c; assumption ]. + | 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). diff --git a/theories/Reals/Rlimit.v b/theories/Reals/Rlimit.v index c3020611..c8887dfb 100644 --- a/theories/Reals/Rlimit.v +++ b/theories/Reals/Rlimit.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* Base X') eps > 0 -> exists alp : R, alp > 0 /\ - (forall x:Base X, D x /\ dist X x x0 < alp -> dist X' (f x) l < eps). + (forall x:Base X, D x /\ X.(dist) x x0 < alp -> X'.(dist) (f x) l < eps). (*******************************) (** ** R is a metric space *) @@ -174,6 +174,8 @@ Definition limit_in (X X':Metric_Space) (f:Base X -> Base X') Definition R_met : Metric_Space := Build_Metric_Space R R_dist R_dist_pos R_dist_sym R_dist_refl R_dist_tri. +Declare Equivalent Keys dist R_dist. + (*******************************) (** * Limit 1 arg *) (*******************************) @@ -191,9 +193,9 @@ Lemma tech_limit : 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). + absurd (R_met.(@dist) (f x0) l < R_met.(@dist) (f x0) l). apply Rlt_irrefl. - case (H0 (dist R_met (f x0) l)); auto. + case (H0 (R_met.(@dist) (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. @@ -312,7 +314,7 @@ Proof. rewrite (Rplus_comm 1 (Rabs l)); unfold Rgt; apply Rle_lt_0_plus_1; exact (Rabs_pos l). unfold R_dist in H9; - apply (Rplus_lt_reg_r (- Rabs l) (Rabs (f x2)) (1 + Rabs l)). + 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)); @@ -345,18 +347,19 @@ Lemma single_limit : 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; unfold R_met; unfold R_dist; - unfold Rabs; case (Rcase_abs (l - l')); intros. + clear H0 H1; unfold dist in |- *; unfold R_met; unfold R_dist 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') r); 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. + 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; @@ -374,7 +377,7 @@ Proof. intros a b; clear b; apply (Rminus_diag_uniq l l'); apply a; split. assumption. - apply (Rge_le (l - l') 0 r). + 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). diff --git a/theories/Reals/Rlogic.v b/theories/Reals/Rlogic.v index 14dea1c6..07792942 100644 --- a/theories/Reals/Rlogic.v +++ b/theories/Reals/Rlogic.v @@ -1,261 +1,137 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* Prop. Hypothesis HP : forall n, {P n} + {~P n}. -Let ge_fun_sums_ge_lemma : (forall (m n : nat) (f : nat -> R), (lt m n) -> (forall i : nat, 0 <= f i) -> sum_f_R0 f m <= sum_f_R0 f n). -Proof. -intros m n f mn fpos. -replace (sum_f_R0 f m) with (sum_f_R0 f m + 0) by ring. -rewrite (tech2 f m n mn). -apply Rplus_le_compat_l. - induction (n - S m)%nat; simpl in *. - apply fpos. -replace 0 with (0 + 0) by ring. -apply (Rplus_le_compat _ _ _ _ IHn0 (fpos (S (m + S n0)%nat))). -Qed. - -Let ge_fun_sums_ge : (forall (m n : nat) (f : nat -> R), (le m n) -> (forall i : nat, 0 <= f i) -> sum_f_R0 f m <= sum_f_R0 f n). -Proof. -intros m n f mn pos. - elim (le_lt_or_eq _ _ mn). - intro; apply ge_fun_sums_ge_lemma; assumption. -intro H; rewrite H; auto with *. -Qed. - -Let f:=fun n => (if HP n then (1/2)^n else 0)%R. - -Lemma cauchy_crit_geometric_dec_fun : Cauchy_crit_series f. +Lemma sig_forall_dec : {n | ~P n} + {forall n, P n}. Proof. -intros e He. -assert (X:(Pser (fun n:nat => 1) (1/2) (/ (1 - (1/2))))%R). - apply GP_infinite. - apply Rabs_def1; fourier. -assert (He':e/2 > 0) by fourier. -destruct (X _ He') as [N HN]. -clear X. -exists N. -intros n m Hn Hm. -replace e with (e/2 + e/2)%R by field. -set (g:=(fun n0 : nat => 1 * (1 / 2) ^ n0)) in *. -assert (R_dist (sum_f_R0 g n) (sum_f_R0 g m) < e / 2 + e / 2). - apply Rle_lt_trans with (R_dist (sum_f_R0 g n) 2+R_dist 2 (sum_f_R0 g m))%R. - apply R_dist_tri. - replace (/(1 - 1/2)) with 2 in HN by field. - cut (forall n, (n >= N)%nat -> R_dist (sum_f_R0 g n) 2 < e/2)%R. - intros Z. - apply Rplus_lt_compat. - apply Z; assumption. - rewrite R_dist_sym. - apply Z; assumption. - clear - HN He. - intros n Hn. - apply HN. - auto. -eapply Rle_lt_trans;[|apply H]. -clear -ge_fun_sums_ge n. -cut (forall n m, (m <= n)%nat -> R_dist (sum_f_R0 f n) (sum_f_R0 f m) <= R_dist (sum_f_R0 g n) (sum_f_R0 g m)). - intros H. - destruct (le_lt_dec m n). - apply H; assumption. - rewrite R_dist_sym. - rewrite (R_dist_sym (sum_f_R0 g n)). - apply H; auto with *. -clear n m. -intros n m Hnm. -unfold R_dist. -cut (forall i : nat, (1 / 2) ^ i >= 0). intro RPosPow. -rewrite Rabs_pos_eq. - rewrite Rabs_pos_eq. - cut (sum_f_R0 g m - sum_f_R0 f m <= sum_f_R0 g n - sum_f_R0 f n). - intros; fourier. - do 2 rewrite <- minus_sum. - apply (ge_fun_sums_ge m n (fun i : nat => g i - f i) Hnm). - intro i. - unfold f, g. - elim (HP i); intro; ring_simplify; auto with *. - cut (sum_f_R0 g m <= sum_f_R0 g n). - intro; fourier. - apply (ge_fun_sums_ge m n g Hnm). - intro. unfold g. - ring_simplify. - apply Rge_le. - apply RPosPow. - cut (sum_f_R0 f m <= sum_f_R0 f n). - intro; fourier. - apply (ge_fun_sums_ge m n f Hnm). - intro; unfold f. - elim (HP i); intro; simpl. - apply Rge_le. - apply RPosPow. - auto with *. -intro i. -apply Rle_ge. -apply pow_le. -fourier. -Qed. - -Lemma forall_dec : {forall n, P n} + {~forall n, P n}. -Proof. -destruct (cv_cauchy_2 _ cauchy_crit_geometric_dec_fun). - cut (2 <= x <-> forall n : nat, P n). - intro H. - elim (Rle_dec 2 x); intro X. - left; tauto. - right; tauto. -assert (A:Rabs(1/2) < 1) by (apply Rabs_def1; fourier). -assert (A0:=(GP_infinite (1/2) A)). -symmetry. - split; intro. - replace 2 with (/ (1 - (1 / 2))) by field. - unfold Pser, infinite_sum in A0. - eapply Rle_cv_lim;[|unfold Un_cv; apply A0 |apply u]. - intros n. - clear -n H. - induction n; unfold f;simpl. - destruct (HP 0); auto with *. - elim n; auto. - apply Rplus_le_compat; auto. - destruct (HP (S n)); auto with *. - elim n0; auto. -intros n. -destruct (HP n); auto. -elim (RIneq.Rle_not_lt _ _ H). -assert (B:0< (1/2)^n). - apply pow_lt. - fourier. -apply Rle_lt_trans with (2-(1/2)^n);[|fourier]. -replace (/(1-1/2))%R with 2 in A0 by field. -set (g:= fun m => if (eq_nat_dec m n) then (1/2)^n else 0). -assert (Z: Un_cv (fun N : nat => sum_f_R0 g N) ((1/2)^n)). - intros e He. - exists n. - intros a Ha. - replace (sum_f_R0 g a) with ((1/2)^n). - rewrite (R_dist_eq); assumption. - symmetry. - cut (forall a : nat, ((a >= n)%nat -> sum_f_R0 g a = (1 / 2) ^ n) /\ ((a < n)%nat -> sum_f_R0 g a = 0))%R. - intros H0. - destruct (H0 a). - auto. - clear - g. - induction a. - split; - intros H; - simpl; unfold g; - destruct (eq_nat_dec 0 n) as [t|f]; try reflexivity. - elim f; auto with *. - exfalso; omega. - destruct IHa as [IHa0 IHa1]. - split; - intros H; - simpl; unfold g at 2; - destruct (eq_nat_dec (S a) n). - rewrite IHa1. - ring. - omega. - ring_simplify. - apply IHa0. - omega. - exfalso; omega. - ring_simplify. - apply IHa1. - omega. -assert (C:=CV_minus _ _ _ _ A0 Z). -eapply Rle_cv_lim;[|apply u |apply C]. -clear - n0 B. -intros m. -simpl. -induction m. - simpl. - unfold f, g. - destruct (eq_nat_dec 0 n). - destruct (HP 0). - elim n0. - congruence. - clear -n. - induction n; simpl; fourier. - destruct (HP); simpl; fourier. -cut (f (S m) <= 1 * ((1 / 2) ^ (S m)) - g (S m)). - intros L. - eapply Rle_trans. +assert (Hi: (forall n, 0 < INR n + 1)%R). + intros n. + apply Rle_lt_0_plus_1, pos_INR. +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), le_n_S, le_0_n. +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 := Zabs_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 Zabs_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. - apply Rplus_le_compat. - apply IHm. - apply L. - simpl; fourier. -unfold f, g. -destruct (eq_nat_dec (S m) n). - destruct (HP (S m)). - elim n0. - congruence. - rewrite e. - fourier. -destruct (HP (S m)). - fourier. + ring. +assert (Hl': (/ (INR (S N) + 1) < l)%R). + rewrite <- (Rinv_involutive l) by now apply Rgt_not_eq. + apply Rinv_1_lt_contravar with (1 := H1l). + 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 (le_or_lt n N) as [Hn|Hn]. + 2: now apply lt_le_S. +exfalso. +destruct (le_lt_or_eq _ _ Hn) as [Hn'| ->]. +2: now apply Hp. +apply Rlt_not_le with (2 := Hnp _ Hp). +rewrite <- (Rinv_involutive l) by now apply Rgt_not_eq. +apply Rinv_1_lt_contravar. +rewrite <- S_INR. +apply (le_INR 1), le_n_S, le_0_n. +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 pow_le. -fourier. -Qed. - -Lemma sig_forall_dec : {n | ~P n}+{forall n, P n}. -Proof. -destruct forall_dec. - right; assumption. -left. -apply constructive_indefinite_ground_description_nat; auto. - clear - HP. - firstorder. -apply Classical_Pred_Type.not_all_ex_not. -assumption. +apply archimed. Qed. End Arithmetical_dec. -(** 2- Derivability of the Archimedean axiom *) +(** * Derivability of the Archimedean axiom *) -(* This is a standard proof (it has been taken from PlanetMath). It is +(** 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} (the one above or a -variant of it that does not need classical axioms) , we can in -principle also derive [up] and its [specification] *) +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). @@ -296,3 +172,33 @@ 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/theories/Reals/Rminmax.v b/theories/Reals/Rminmax.v index 9121ccc2..ba1fe90f 100644 --- a/theories/Reals/Rminmax.v +++ b/theories/Reals/Rminmax.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* Prop) (x y:R), P x -> P y -> P (Rmin x y). @@ -43,7 +45,7 @@ Proof. rewrite Rmult_1_r; rewrite <- (Rmult_comm 3); rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym. rewrite Rmult_1_l; replace (/ exp 1) with (exp (-1)). - unfold exp; case (exist_exp (-1)); intros; simpl; + 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 @@ -137,7 +139,7 @@ Qed. Lemma exp_ineq1 : forall x:R, 0 < x -> 1 + x < exp x. Proof. - intros; apply Rplus_lt_reg_r with (- exp 0); rewrite <- (Rplus_comm (exp x)); + intros; apply Rplus_lt_reg_l with (- exp 0); rewrite <- (Rplus_comm (exp x)); assert (H0 := MVT_cor1 exp 0 x derivable_exp H); elim H0; intros; elim H1; intros; unfold Rminus in H2; rewrite H2; rewrite Ropp_0; rewrite Rplus_0_r; @@ -178,13 +180,13 @@ Qed. (**********) Lemma ln_exists : forall y:R, 0 < y -> { z:R | y = exp z }. Proof. - intros; case (Rle_dec 1 y); intro. - apply (ln_exists1 _ r). + 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_sym. - rewrite Rmult_1_r; left; apply (Rnot_le_lt _ _ n). + 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). @@ -213,12 +215,10 @@ Definition ln (x:R) : R := Lemma exp_ln : forall x:R, 0 < x -> exp (ln x) = x. Proof. - intros; unfold ln; case (Rlt_dec 0 x); intro. + intros; unfold ln; decide (Rlt_dec 0 x) with H. unfold Rln; - case (ln_exists (mkposreal x r) (cond_pos (mkposreal x r))); - intros. - simpl in e; symmetry ; apply e. - elim n; apply H. + 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. @@ -313,12 +313,12 @@ Proof. red; apply P_Rmin. apply Rmult_lt_0_compat. assumption. - apply Rplus_lt_reg_r with 1. + apply Rplus_lt_reg_l with 1. rewrite Rplus_0_r; replace (1 + (exp eps - 1)) with (exp eps); [ apply H1 | ring ]. apply Rmult_lt_0_compat. assumption. - apply Rplus_lt_reg_r with (exp (- eps)). + apply Rplus_lt_reg_l with (exp (- eps)). rewrite Rplus_0_r; replace (exp (- eps) + (1 - exp (- eps))) with 1; [ apply H2 | ring ]. unfold dist, R_met, R_dist; simpl. @@ -335,7 +335,7 @@ Proof. apply H. rewrite Hxyy. apply Ropp_lt_cancel. - apply Rplus_lt_reg_r with (r := y). + 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)). @@ -358,7 +358,7 @@ Proof. apply Rmult_lt_reg_l with (r := y). apply H. rewrite Hxyy. - apply Rplus_lt_reg_r with (r := - y). + 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)). apply Rlt_le_trans with (1 := H5); apply Rmin_l. @@ -610,7 +610,7 @@ Proof. replace h with (x + h - x); [ idtac | ring ]. apply H3; split. unfold D_x; split. - case (Rcase_abs h); intro. + destruct (Rcase_abs h) as [Hlt|Hgt]. assert (H7 : Rabs h < x / 2). apply Rlt_le_trans with alp. apply H6. @@ -619,13 +619,13 @@ Proof. unfold Rdiv; apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup0 ]. rewrite Rabs_left in H7. - apply Rplus_lt_reg_r with (- h - x / 2). + apply Rplus_lt_reg_l with (- h - x / 2). replace (- h - x / 2 + x / 2) with (- h); [ idtac | ring ]. pattern x at 2; rewrite double_var. replace (- h - x / 2 + (x / 2 + x / 2 + h)) with (x / 2); [ apply H7 | ring ]. - apply r. - apply Rplus_lt_le_0_compat; [ assumption | apply Rge_le; apply r ]. - apply (not_eq_sym (A:=R)); apply Rminus_not_eq; replace (x + h - x) with h; + apply Hlt. + apply Rplus_lt_le_0_compat; [ assumption | apply Rge_le; apply Hgt ]. + apply (sym_not_eq (A:=R)); apply Rminus_not_eq; replace (x + h - x) with h; [ apply H5 | ring ]. replace (x + h - x) with h; [ apply Rlt_le_trans with alp; @@ -703,3 +703,128 @@ Proof. 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 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]]. + left; apply exp_increasing. + now apply Rmult_lt_compat_l; auto; apply ln_increasing; fourier. + 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). +pattern 1 at 5; 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 | ]; fourier. + pattern x at 1; replace x with (- (sqrt ((- x) ^ 2))). + assert (t:= sqrt_pos ((-x)^2)); fourier. + simpl; rewrite Rmult_1_r, sqrt_square, Ropp_involutive;[reflexivity | fourier]. + 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]]. +assert (pow2_sqrt : forall x, 0 <= x -> sqrt x ^ 2 = x) by + (intros; simpl; rewrite Rmult_1_r, sqrt_sqrt; auto). +field_simplify;[rewrite pow2_sqrt;[field | ] | apply Rgt_not_eq; fourier]. +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|]; fourier. + pattern x at 1; replace x with (- (sqrt ((- x) ^ 2))). + assert (t:= sqrt_pos ((-x)^2)); fourier. + simpl; rewrite Rmult_1_r, sqrt_square, Ropp_involutive; auto; fourier. +assert (0 < x ^ 2 + 1). + apply Rplus_le_lt_0_compat;[simpl; rewrite Rmult_1_r; apply Rle_0_sqr|fourier]. +replace (/sqrt (x ^ 2 + 1)) with + (/(x + sqrt (x ^ 2 + 1)) * + (1 + (/(2 * sqrt (x ^ 2 + 1)) * (INR 2 * x ^ 1 + 0)))). +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. + 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]. +rewrite <- Rmult_assoc, Rinv_r;[field | ]; apply Rgt_not_eq; auto; + apply sqrt_lt_R0; 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; fourier]. +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/theories/Reals/Rprod.v b/theories/Reals/Rprod.v index 341ec8fd..1ee9410f 100644 --- a/theories/Reals/Rprod.v +++ b/theories/Reals/Rprod.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* bound EUn -> exists l : R, Un_cv l. Proof. intros Hug Heub. - exists (projT1 (completeness EUn Heub EUn_noempty)). + exists (proj1_sig (completeness EUn Heub EUn_noempty)). destruct (completeness EUn Heub EUn_noempty) as (l, H). now apply Un_cv_crit_lub. Qed. @@ -404,3 +404,26 @@ Proof. 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 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/theories/Reals/Rsigma.v b/theories/Reals/Rsigma.v index 0dcb4b25..458d1f8c 100644 --- a/theories/Reals/Rsigma.v +++ b/theories/Reals/Rsigma.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* ]|Hgt]. unfold Un_cv in H4; unfold R_dist in H4. cut (0 < y - x). intro Hyp. @@ -373,19 +370,18 @@ Proof. assumption. unfold Rdiv; apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; assumption ]. - apply Rplus_lt_reg_r with x; rewrite Rplus_0_r. + apply Rplus_lt_reg_l with x; rewrite Rplus_0_r. replace (x + (y - x)) with y; [ assumption | ring ]. exists 0%nat; 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 ]. + 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. - rewrite b. unfold Rminus, Rdiv; rewrite Rplus_opp_r; rewrite Rmult_0_l; rewrite Rabs_R0; assumption. assumption. - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H r)). + elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H Hgt)). Qed. Definition cond_positivity (x:R) : bool := @@ -427,18 +423,15 @@ Lemma dicho_lb_car : P x = false -> P (dicho_lb x y P n) = false. Proof. intros. - induction n as [| n Hrecn]. - simpl. - assumption. - simpl. - assert - (X := - sumbool_of_bool (P ((Dichotomy_lb x y P n + Dichotomy_ub x y P n) / 2))). - elim X; intro. - rewrite a. - unfold dicho_lb in Hrecn; assumption. - rewrite b. - assumption. + 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 : @@ -446,18 +439,23 @@ Lemma dicho_up_car : P y = true -> P (dicho_up x y P n) = true. Proof. intros. - induction n as [| n Hrecn]. - simpl. - assumption. - simpl. - assert - (X := - sumbool_of_bool (P ((Dichotomy_lb x y P n + Dichotomy_ub x y P n) / 2))). - elim X; intro. - rewrite a. - unfold dicho_lb in Hrecn; assumption. - rewrite b. - assumption. + 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 R_dist_eq; intros n _; assumption. +exact (cv_infty_cv_R0 pow_2_n pow_2_n_neq_R0 pow_2_n_infty). Qed. (** Intermediate Value Theorem *) @@ -467,13 +465,9 @@ Lemma IVT : x < y -> f x < 0 -> 0 < f y -> { z:R | x <= z <= y /\ f z = 0 }. Proof. intros. - cut (x <= y). - intro. - 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. - elim X0; 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. @@ -490,7 +484,6 @@ Proof. apply dicho_up_decreasing; assumption. assumption. right; reflexivity. - 2: left; assumption. 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). @@ -515,14 +508,14 @@ Proof. left; assumption. intro. unfold cond_positivity. - case (Rle_dec 0 z); intro. + case (Rle_dec 0 z) as [Hle|Hnle]. split. intro; assumption. intro; reflexivity. split. intro feqt;discriminate feqt. intro. - elim n0; assumption. + contradiction. unfold Vn. cut (forall z:R, cond_positivity z = false <-> z < 0). intros. @@ -536,20 +529,19 @@ Proof. assumption. intro. unfold cond_positivity. - case (Rle_dec 0 z); intro. + case (Rle_dec 0 z) as [Hle|Hnle]. split. intro feqt; discriminate feqt. - intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r H7)). + intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ Hle H7)). split. intro; auto with real. intro; reflexivity. cut (Un_cv Wn x0). intros. assert (H7 := continuity_seq f Wn x0 (H x0) H5). - case (total_order_T 0 (f x0)); intro. - elim s; intro. + destruct (total_order_T 0 (f x0)) as [[Hlt|<-]|Hgt]. left; assumption. - rewrite <- b; right; reflexivity. + right; reflexivity. unfold Un_cv in H7; unfold R_dist in H7. cut (0 < - f x0). intro. @@ -559,7 +551,7 @@ Proof. 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_r _ _ _ 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; apply Rplus_le_lt_0_compat. @@ -570,29 +562,28 @@ Proof. cut (Un_cv Vn x0). intros. assert (H7 := continuity_seq f Vn x0 (H x0) H5). - case (total_order_T 0 (f x0)); intro. - elim s; intro. + destruct (total_order_T 0 (f x0)) as [[Hlt|<-]|Hgt]. unfold Un_cv in H7; unfold R_dist in H7. - elim (H7 (f x0) a); intros. + 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_r _ _ _ 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_r with (f x0 - f (Vn x2)). + 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. - right; rewrite <- b; reflexivity. + right; reflexivity. left; assumption. unfold Vn; assumption. Qed. @@ -603,31 +594,23 @@ Lemma IVT_cor : x <= y -> f x * f y <= 0 -> { z:R | x <= z <= y /\ f z = 0 }. Proof. intros. - case (total_order_T 0 (f x)); intro. - case (total_order_T 0 (f y)); intro. - elim s; intro. - elim s0; intro. + destruct (total_order_T 0 (f x)) as [[Hltx|Heqx]|Hgtx]. + 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 b. - exists x. - split. - split; [ right; reflexivity | assumption ]. - symmetry ; exact b. - elim s; intro. + 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. - elim (H3 H5 H4); intros. + destruct (H3 H5 H4) as (x0,[]). exists x0. - elim p; intros. split. assumption. unfold opp_fct in H7. @@ -635,25 +618,24 @@ Proof. apply Ropp_eq_0_compat; assumption. unfold opp_fct; apply Ropp_0_gt_lt_contravar; assumption. unfold opp_fct. - apply Rplus_lt_reg_r with (f x); rewrite Rplus_opp_r; rewrite Rplus_0_r; + apply Rplus_lt_reg_l with (f x); rewrite Rplus_opp_r; rewrite Rplus_0_r; assumption. inversion H0. assumption. - rewrite H2 in a. - elim (Rlt_irrefl _ (Rlt_trans _ _ _ r a)). + rewrite H2 in Hltx. + elim (Rlt_irrefl _ (Rlt_trans _ _ _ Hgty Hltx)). exists x. split. split; [ right; reflexivity | assumption ]. symmetry ; assumption. - case (total_order_T 0 (f y)); intro. - elim s; intro. + destruct (total_order_T 0 (f y)) as [[Hlty|Heqy]|Hgty]. cut (x < y). intro. apply IVT; assumption. inversion H0. assumption. - rewrite H2 in r. - elim (Rlt_irrefl _ (Rlt_trans _ _ _ r a)). + rewrite H2 in Hgtx. + elim (Rlt_irrefl _ (Rlt_trans _ _ _ Hlty Hgtx)). exists y. split. split; [ assumption | right; reflexivity ]. @@ -676,8 +658,7 @@ Proof. intro. cut (continuity f). intro. - case (total_order_T y 1); intro. - elim s; intro. + destruct (total_order_T y 1) as [[Hlt| -> ]|Hgt]. cut (0 <= f 1). intro. cut (f 0 * f 1 <= 0). @@ -701,7 +682,7 @@ Proof. exists 1. split. left; apply Rlt_0_1. - rewrite b; symmetry ; apply Rsqr_1. + symmetry; apply Rsqr_1. cut (0 <= f y). intro. cut (f 0 * f y <= 0). @@ -723,7 +704,7 @@ Proof. pattern y at 1; rewrite <- Rmult_1_r. unfold Rsqr; apply Rmult_le_compat_l. assumption. - left; exact r. + left; exact Hgt. replace f with (Rsqr - fct_cte y)%F. apply continuity_minus. apply derivable_continuous; apply derivable_Rsqr. @@ -743,39 +724,31 @@ Definition Rsqrt (y:nonnegreal) : R := Lemma Rsqrt_positivity : forall x:nonnegreal, 0 <= Rsqrt x. Proof. intro. - assert (X := Rsqrt_exists (nonneg x) (cond_nonneg x)). - elim X; intros. + destruct (Rsqrt_exists (nonneg x) (cond_nonneg x)) as (x0 & H1 & H2). cut (x0 = Rsqrt x). intros. - elim p; intros. - rewrite H in H0; assumption. + rewrite <- H; assumption. unfold Rsqrt. - case (Rsqrt_exists x (cond_nonneg x)). - intros. - elim p; elim a; intros. + case (Rsqrt_exists x (cond_nonneg x)) as (?,[]). apply Rsqr_inj. assumption. assumption. - rewrite <- H0; rewrite <- H2; reflexivity. + rewrite <- H0, <- H2; reflexivity. Qed. (**********) Lemma Rsqrt_Rsqrt : forall x:nonnegreal, Rsqrt x * Rsqrt x = x. Proof. intros. - assert (X := Rsqrt_exists (nonneg x) (cond_nonneg x)). - elim X; intros. + destruct (Rsqrt_exists (nonneg x) (cond_nonneg x)) as (x0 & H1 & H2). cut (x0 = Rsqrt x). intros. rewrite <- H. - elim p; intros. - rewrite H1; reflexivity. + rewrite H2; reflexivity. unfold Rsqrt. - case (Rsqrt_exists x (cond_nonneg x)). - intros. - elim p; elim a; intros. + case (Rsqrt_exists x (cond_nonneg x)) as (x1 & ? & ?). apply Rsqr_inj. assumption. assumption. - rewrite <- H0; rewrite <- H2; reflexivity. + rewrite <- H0, <- H2; reflexivity. Qed. diff --git a/theories/Reals/Rtopology.v b/theories/Reals/Rtopology.v index 9a345153..72e4142b 100644 --- a/theories/Reals/Rtopology.v +++ b/theories/Reals/Rtopology.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* a <= c <= b). Proof. - intros; case (Rle_dec a b); intro. - unfold compact; intros; + 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; cut (bound A). - intro; cut (exists a0 : R, A a0). - intro; assert (H3 := completeness A H1 H2); elim H3; clear H3; intros m H3; - unfold is_lub in H3; cut (a <= m <= b). - intro; unfold covering_open_set in H; elim H; clear H; intros; - unfold covering in H; assert (H6 := H m H4); elim H6; - clear H6; intros y0 H6; unfold family_open_set in H5; - assert (H7 := H5 y0); unfold open_set in H7; assert (H8 := H7 m H6); - unfold neighbourhood in H8; elim H8; clear H8; intros eps H8; - cut (exists x : R, A x /\ m - eps < x <= m). - intro; elim H9; clear H9; intros x H9; elim H9; clear H9; intros; - case (Req_dec m b); intro. - rewrite H11 in H10; rewrite H11 in H8; unfold A in H9; elim H9; clear H9; - intros; elim H12; clear H12; intros Dx H12; - set (Db := fun x:R => Dx x \/ x = y0); exists Db; - unfold covering_finite; split. - unfold covering; unfold covering_finite in H12; elim H12; clear H12; - intros; unfold covering in H12; case (Rle_dec x0 x); - intro. - cut (a <= x0 <= x). - intro; assert (H16 := H12 x0 H15); elim H16; clear H16; intros; exists x1; - simpl in H16; simpl; unfold Db; elim H16; - clear H16; intros; split; [ apply H16 | left; apply H17 ]. - split. - elim H14; intros; assumption. - assumption. + covering_finite (fun c:R => a <= c <= x) (subfamily f0 D))). + cut (A a); [intro H0|]. + cut (bound A); [intro H1|]. + cut (exists a0 : R, A a0); [intro H2|]. + pose proof (completeness A H1 H2) as (m,H3); unfold is_lub in H3. + cut (a <= m <= b); [intro H4|]. + unfold covering in H; pose proof (H m H4) as (y0,H6). + unfold family_open_set in H5; pose proof (H5 y0 m H6) as (eps,H8). + 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; rewrite Ropp_minus_distr; - rewrite Rabs_right. + 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; apply Ropp_lt_gt_contravar; + unfold Rminus; apply Rplus_lt_compat_l, Ropp_lt_gt_contravar; auto with real. - elim H10; intros H15 _; apply Rplus_lt_reg_r with (x - eps); + apply Rplus_lt_reg_l with (x - eps); replace (x - eps + (b - x)) with (b - eps); - [ replace (x - eps + eps) with x; [ apply H15 | ring ] | ring ]. - apply Rge_minus; apply Rle_ge; elim H14; intros _ H15; apply H15. + [ replace (x - eps + eps) with x; [ apply Hltx | ring ] | ring ]. + apply Rge_minus, Rle_ge, H18. unfold Db; right; reflexivity. - unfold family_finite; unfold domain_finite; - unfold covering_finite in H12; elim H12; clear H12; + unfold family_finite, domain_finite. intros; unfold family_finite in H13; unfold domain_finite in H13; - elim H13; clear H13; intros l H13; exists (cons y0 l); + destruct H13 as (l,H13); exists (cons y0 l); intro; split. - intro; simpl in H14; unfold intersection_domain in H14; elim (H13 x0); - clear H13; intros; case (Req_dec x0 y0); intro. + 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; apply H16. simpl; right; apply H13. simpl; unfold intersection_domain; unfold Db in H14; decompose [and or] H14. split; assumption. elim H16; assumption. - intro; simpl in H14; elim H14; intro; simpl; + intro H14; simpl in H14; destruct H14 as [H15|H15]; simpl; unfold intersection_domain. split. - apply (cond_fam f0); rewrite H15; exists m; apply H6. + apply (cond_fam f0); rewrite H15; exists b; apply H6. unfold Db; right; 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; elim H3; intros; unfold is_upper_bound in H13; - assert (H15 := H13 m' H12); cut (m < m'). - intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H15 H16)). - unfold m'; unfold Rmin; case (Rle_dec (m + eps / 2) b); intro. - 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 ]. - elim H4; intros. - elim H17; intro. - assumption. - elim H11; 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. @@ -712,38 +704,32 @@ Proof. 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 ]. - elim H4; intros. - elim H13; intro. + destruct H4. assumption. - elim H11; assumption. unfold m'; apply Rmin_r. - unfold A in H9; elim H9; clear H9; intros; elim H12; clear H12; intros Dx H12; - set (Db := fun x:R => Dx x \/ x = y0); exists Db; - unfold covering_finite; split. - unfold covering; unfold covering_finite in H12; elim H12; clear H12; - intros; unfold covering in H12; case (Rle_dec x0 x); - intro. - cut (a <= x0 <= x). - intro; assert (H16 := H12 x0 H15); elim H16; clear H16; intros; exists x1; - simpl in H16; simpl; unfold Db. - elim H16; clear H16; intros; split; [ apply H16 | left; apply H17 ]. - elim H14; intros; split; assumption. + 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; unfold Rabs; case (Rcase_abs (x0 - m)); - intro. + 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_r with (x - eps); + apply Rplus_lt_reg_l with (x - eps); replace (x - eps + (m - x)) with (m - eps). replace (x - eps + eps) with x. - elim H10; intros; assumption. + assumption. ring. ring. 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_r with m; replace (m + (m' - m)) with m'. + apply Rplus_lt_reg_l with m; replace (m + (m' - m)) with m'. 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. @@ -755,22 +741,20 @@ Proof. discrR. ring. unfold Db; right; reflexivity. - unfold family_finite; unfold domain_finite; - unfold covering_finite in H12; elim H12; clear H12; - intros; unfold family_finite in H13; unfold domain_finite in H13; - elim H13; clear H13; intros l H13; exists (cons y0 l); + unfold family_finite, domain_finite; + unfold family_finite, domain_finite in H13; + destruct H13 as (l,H13); exists (cons y0 l); intro; split. - intro; simpl in H14; unfold intersection_domain in H14; elim (H13 x0); - clear H13; intros; case (Req_dec x0 y0); intro. - simpl; left; apply H16. + 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; apply Heq. simpl; right; apply H13; simpl; unfold intersection_domain; unfold Db in H14; decompose [and or] H14. split; assumption. - elim H16; assumption. - intro; simpl in H14; elim H14; intro; simpl; - unfold intersection_domain. - split. + elim Hneq; assumption. + intros [H15|H15]. split. apply (cond_fam f0); rewrite H15; exists m; apply H6. unfold Db; right; assumption. elim (H13 x0); intros _ H16. @@ -780,22 +764,22 @@ Proof. split. elim H17; intros; assumption. unfold Db; left; elim H17; intros; assumption. - elim (classic (exists x : R, A x /\ m - eps < x <= m)); intro. + elim (classic (exists x : R, A x /\ m - eps < x <= m)); intro H9. assumption. - elim H3; intros; cut (is_upper_bound A (m - eps)). - intro; assert (H13 := H11 _ H12); cut (m - eps < m). - intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H13 H14)). + 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; + unfold is_upper_bound; intros x H13; assert (H14 := not_and_or _ _ (H12 x)); elim H14; - intro. + intro H15. elim H15; apply H13. - elim (not_and_or _ _ H15); intro. - case (Rle_dec x (m - eps)); intro. + 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. @@ -803,7 +787,8 @@ Proof. unfold is_upper_bound in H3. split. apply (H3 _ H0). - apply (H4 b); unfold is_upper_bound; intros; unfold A in H5; elim H5; + 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. @@ -811,30 +796,28 @@ Proof. 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 r ]. - unfold covering_open_set in H; elim H; clear H; intros; unfold covering in H; - cut (a <= a <= b). - intro; elim (H _ H1); intros y0 H2; set (D' := fun x:R => x = y0); exists D'; + 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; cut (x = a). - intro; exists y0; 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; intro; elim H3; clear H3; - intros; unfold D' in H4; left; apply H4. - simpl; unfold intersection_domain; intro; elim H3; intro. + simpl; unfold intersection_domain; intros (H3,H4). + unfold D' in H4; left; apply H4. + simpl; unfold intersection_domain; intros [H4|[]]. split; [ rewrite H4; apply (cond_fam f0); exists a; apply H2 | apply H4 ]. - elim H4. - split; [ right; reflexivity | apply r ]. + 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 n; apply H1. + assert (H1 := Rle_trans _ _ _ H H0); elim Hnle; apply H1. Qed. Lemma compact_P4 : @@ -982,12 +965,6 @@ Proof. intros; exists (f0 x0); apply H4. Qed. -Lemma Rlt_Rminus : forall a b:R, a < b -> 0 < b - a. -Proof. - intros; apply Rplus_lt_reg_r with a; rewrite Rplus_0_r; - replace (a + (b - a)) with b; [ assumption | ring ]. -Qed. - Lemma prolongement_C0 : forall (f:R -> R) (a b:R), a <= b -> @@ -1017,14 +994,14 @@ Proof. split. change (0 < a - x); apply Rlt_Rminus; assumption. intros; elim H5; clear H5; intros _ H5; unfold h. - case (Rle_dec x a); intro. - case (Rle_dec x0 a); intro. - unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0; assumption. - elim n; left; apply Rplus_lt_reg_r with (- x); + 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. - elim n; left; assumption. + left; assumption. elim H3; intro. assert (H5 : a <= a <= b). split; [ right; reflexivity | left; assumption ]. @@ -1039,20 +1016,20 @@ Proof. elim H8; intros; assumption. change (0 < b - a); apply Rlt_Rminus; assumption. intros; elim H9; clear H9; intros _ H9; cut (x1 < b). - intro; unfold h; case (Rle_dec x a); intro. - case (Rle_dec x1 a); intro. + 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); intro. + case (Rle_dec x1 b) as [Hleb|[]]. elim H8; intros; apply H12; split. unfold D_x, no_cond; split. trivial. - red; intro; elim n; right; symmetry ; assumption. + 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. - elim n0; left; assumption. - elim n; right; assumption. - apply Rplus_lt_reg_r with (- a); do 2 rewrite (Rplus_comm (- a)); + 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)). @@ -1073,30 +1050,29 @@ Proof. assert (H12 : 0 < b - x). apply Rlt_Rminus; assumption. exists (Rmin x0 (Rmin (x - a) (b - x))); split. - unfold Rmin; case (Rle_dec (x - a) (b - x)); intro. - case (Rle_dec x0 (x - a)); intro. + unfold Rmin; case (Rle_dec (x - a) (b - x)) as [Hle|Hnle]. + case (Rle_dec x0 (x - a)) as [Hlea|Hnlea]. assumption. assumption. - case (Rle_dec x0 (b - x)); intro. + case (Rle_dec x0 (b - x)) as [Hleb|Hnleb]. assumption. assumption. - intros; elim H13; clear H13; intros; cut (a < x1 < b). - intro; elim H15; clear H15; intros; unfold h; case (Rle_dec x a); - intro. - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r H4)). - case (Rle_dec x b); intro. - case (Rle_dec x1 a); intro. - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r0 H15)). - case (Rle_dec x1 b); intro. + 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. - elim n1; left; assumption. - elim n0; left; assumption. + left; assumption. + left; assumption. split. - apply Ropp_lt_cancel; apply Rplus_lt_reg_r with x; + 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))). @@ -1104,7 +1080,7 @@ Proof. apply Rle_trans with (Rmin (x - a) (b - x)). apply Rmin_r. apply Rmin_l. - apply Rplus_lt_reg_r with (- x); do 2 rewrite (Rplus_comm (- x)); + 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))). @@ -1124,13 +1100,13 @@ Proof. elim H10; intros; assumption. change (0 < b - a); apply Rlt_Rminus; assumption. intros; elim H11; clear H11; intros _ H11; cut (a < x1). - intro; unfold h; case (Rle_dec x a); intro. - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r H4)). - case (Rle_dec x1 a); intro. - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r H12)). - case (Rle_dec x b); intro. - case (Rle_dec x1 b); intro. - rewrite H6; elim H10; intros; elim r0; intro. + 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. @@ -1142,8 +1118,8 @@ Proof. assumption. rewrite H6; unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0; assumption. - elim n1; right; assumption. - rewrite H6 in H11; apply Ropp_lt_cancel; apply Rplus_lt_reg_r with b; + 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)). @@ -1156,26 +1132,25 @@ Proof. change (0 < x - b); apply Rlt_Rminus; assumption. intros; elim H8; clear H8; intros. assert (H10 : b < x0). - apply Ropp_lt_cancel; apply Rplus_lt_reg_r with x; + 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); intro. - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r H4)). - case (Rle_dec x b); intro. - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r H6)). - case (Rle_dec x0 a); intro. - elim (Rlt_irrefl _ (Rlt_trans _ _ _ H1 (Rlt_le_trans _ _ _ H10 r))). - case (Rle_dec x0 b); intro. - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r H10)). + 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); intro. - elim r; intro. + 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); intro. + case (Rle_dec c b) as [|[]]. reflexivity. - elim n0; assumption. + 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). @@ -1229,11 +1204,11 @@ Proof. 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; case (Rle_dec x (M - eps)); intro. - apply r. + 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_r with (x - eps); + apply Rplus_lt_reg_l with (x - eps); replace (x - eps + (M - x)) with (M - eps). replace (x - eps + eps) with x. auto with real. @@ -1615,13 +1590,12 @@ Proof. 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; case (total_order_T x x0); - intro. - elim s; intro. + elim H10; intros; elim H11; intros; + destruct (total_order_T x x0) as [[|H15]|H15]. assumption. - rewrite b in H13; rewrite b in H7; elim H9; apply Rle_antisym; + 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) r)). + 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; @@ -1675,9 +1649,9 @@ Proof. 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 ]. - assert (H8 := completeness _ H6 H7); elim H8; clear H8; intros; + destruct (completeness _ H6 H7) as (x1,p). cut (0 < x1 <= M - m). - intro; elim H8; clear H8; intros; exists (mkposreal _ H8); split. + 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. @@ -1831,7 +1805,7 @@ Proof. 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 ] ]. - assert (H13 := completeness _ H11 H12); elim H13; clear H13; intros; + destruct (completeness _ H11 H12) as (x0,p). cut (0 < x0 <= M - m). intro; elim H13; clear H13; intros; exists x0; split. assumption. diff --git a/theories/Reals/Rtrigo.v b/theories/Reals/Rtrigo.v index 6818e9a1..44058358 100644 --- a/theories/Reals/Rtrigo.v +++ b/theories/Reals/Rtrigo.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* sum_f_R0 (fun k:nat => Rabs (/ INR (fact (2 * k)) * r ^ (2 * k))) n) l }. - intro X; elim X; intros. + intros (x,p). exists x. split. apply p. @@ -148,11 +147,11 @@ Proof. apply H4. intros; rewrite (H0 x); rewrite (H0 x1); apply H5; apply H6. intro; unfold cos, SFL in |- *. - case (cv x); case (exist_cos (Rsqr x)); intros. - symmetry in |- *; eapply UL_sequence. - apply u. - unfold cos_in in c; unfold infinite_sum in c; unfold Un_cv in |- *; intros. - elim (c _ H0); intros N0 H1. + 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 R_dist in H1; unfold R_dist, SP in |- *. replace (sum_f_R0 (fun k:nat => fn k x) n) with @@ -586,8 +585,8 @@ Qed. Lemma SIN_bound : forall x:R, -1 <= sin x <= 1. Proof. - intro; case (Rle_dec (-1) (sin x)); intro. - case (Rle_dec (sin x) 1); intro. + 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; @@ -670,11 +669,11 @@ Proof. 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_r with (Un 1%nat); + 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_r with (Un 3%nat); + 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. @@ -722,7 +721,7 @@ Proof. unfold INR in |- *. replace ((2 * x + 1 + 1 + 1) * (2 * x + 1 + 1)) with (4 * x * x + 10 * x + 6); [ idtac | ring ]. - apply Rplus_lt_reg_r with (-4); rewrite Rplus_opp_l; + apply Rplus_lt_reg_l with (-4); rewrite Rplus_opp_l; replace (-4 + (4 * x * x + 10 * x + 6)) with (4 * x * x + 10 * x + 2); [ idtac | ring ]. apply Rplus_le_lt_0_compat. @@ -1201,7 +1200,7 @@ Proof. replace (- (PI - x)) with (x - PI). replace (- (PI - y)) with (y - PI). intros; change (sin (y - PI) < sin (x - PI)) in H8; - apply Rplus_lt_reg_r with (- PI); rewrite Rplus_comm; + apply Rplus_lt_reg_l with (- PI); rewrite Rplus_comm; replace (y + - PI) with (y - PI). rewrite Rplus_comm; replace (x + - PI) with (x - PI). apply (sin_increasing_0 (y - PI) (x - PI) H4 H5 H6 H7 H8). @@ -1273,7 +1272,7 @@ Proof. replace (-3 * (PI / 2) + 2 * PI) with (PI / 2). replace (-3 * (PI / 2) + PI) with (- (PI / 2)). clear H1 H2 H3 H4; intros H1 H2 H3 H4; - apply Rplus_lt_reg_r with (-3 * (PI / 2)); + apply Rplus_lt_reg_l with (-3 * (PI / 2)); replace (-3 * (PI / 2) + x) with (x - 3 * (PI / 2)). replace (-3 * (PI / 2) + y) with (y - 3 * (PI / 2)). apply (sin_increasing_0 (x - 3 * (PI / 2)) (y - 3 * (PI / 2)) H4 H3 H2 H1 H5). @@ -1352,7 +1351,7 @@ Proof. generalize (Rplus_le_compat_l PI 0 y H1); generalize (Rplus_le_compat_l PI y PI H2); rewrite Rplus_0_r. rewrite <- double. - clear H H0 H1 H2 H3; intros; apply Rplus_lt_reg_r with PI; + 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. @@ -1919,7 +1918,7 @@ Proof. 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_r in GT. } + now apply Rplus_lt_reg_l in GT. } omega. Qed. diff --git a/theories/Reals/Rtrigo_alt.v b/theories/Reals/Rtrigo_alt.v index cdc96f98..3d36cb34 100644 --- a/theories/Reals/Rtrigo_alt.v +++ b/theories/Reals/Rtrigo_alt.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* mult_le_compat_l p n m); apply le_n_S; assumption. apply le_n_Sn. ring. - assert (X := exist_sin (Rsqr a)); elim X; intros. - cut (x = sin a / a). - intro; rewrite H3 in p; unfold sin_in in p; unfold infinite_sum in p; - unfold R_dist in p; unfold Un_cv; unfold R_dist; + unfold sin. + destruct (exist_sin (Rsqr a)) as (x,p). + unfold sin_in, infinite_sum, R_dist in p; + unfold Un_cv, R_dist; intros. cut (0 < eps / Rabs a). - intro; elim (p _ H5); intros N H6. + intro H4; 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))). @@ -151,12 +151,12 @@ Proof. 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_Rinv a Hyp_a). - rewrite <- Rabs_mult; rewrite Rmult_plus_distr_l; rewrite <- Rmult_assoc; - rewrite <- Rinv_l_sym; [ rewrite Rmult_1_l | assumption ]; - rewrite (Rmult_comm (/ a)); rewrite (Rmult_comm (/ Rabs a)); - rewrite <- Rabs_Ropp; rewrite Ropp_plus_distr; rewrite Ropp_involutive; - unfold Rminus, Rdiv in H6; apply H6; unfold ge; - apply le_trans with n0; [ exact H7 | apply le_n_Sn ]. + rewrite <- Rabs_mult, Rmult_plus_distr_l, <- 2!Rmult_assoc, <- Rinv_l_sym; + [ 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 le_trans with n0; [ exact H5 | apply le_n_Sn ]. rewrite (decomp_sum (fun i:nat => sin_n i * Rsqr a ^ i) (S n0)). replace (sin_n 0) with 1. simpl; rewrite Rmult_1_r; unfold Rminus; @@ -176,13 +176,6 @@ Proof. unfold Rdiv; apply Rmult_lt_0_compat. assumption. apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption. - unfold sin; case (exist_sin (Rsqr a)). - intros; cut (x = x0). - intro; rewrite H3; unfold Rdiv. - symmetry ; apply Rinv_r_simpl_m; assumption. - unfold sin_in in p; unfold sin_in in s; eapply uniqueness_sum. - apply p. - apply s. intros; elim H2; intros. replace (sin a - a) with (- (a - sin a)); [ idtac | ring ]. split; apply Ropp_le_contravar; assumption. @@ -318,12 +311,10 @@ Proof. apply le_n_2n. apply (fun m n p:nat => mult_le_compat_l p n m); apply le_n_Sn. apply (fun m n p:nat => mult_le_compat_l p n m); apply le_n_S; assumption. - assert (X := exist_cos (Rsqr a0)); elim X; intros. - cut (x = cos a0). - intro; rewrite H4 in p; unfold cos_in in p; unfold infinite_sum in p; - unfold R_dist in p; unfold Un_cv; unfold R_dist; - intros. - elim (p _ H5); intros N H6. + unfold cos. destruct (exist_cos (Rsqr a0)) as (x,p). + unfold cos_in, infinite_sum, R_dist in p; + unfold Un_cv, R_dist; 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)). @@ -334,7 +325,7 @@ Proof. rewrite Ropp_plus_distr; rewrite Ropp_involutive; unfold Rminus in H6; apply H6. unfold ge; apply le_trans with n1. - exact H7. + exact H5. apply le_n_Sn. rewrite (decomp_sum (fun i:nat => cos_n i * Rsqr a0 ^ i) (S n1)). replace (cos_n 0) with 1. @@ -354,10 +345,6 @@ Proof. unfold cos_n; unfold Rdiv; simpl; rewrite Rinv_1; rewrite Rmult_1_r; reflexivity. apply lt_O_Sn. - unfold cos; case (exist_cos (Rsqr a0)); intros; unfold cos_in in p; - unfold cos_in in c; eapply uniqueness_sum. - apply p. - apply c. intros; elim H3; intros; replace (cos a0 - 1) with (- (1 - cos a0)); [ idtac | ring ]. split; apply Ropp_le_contravar; assumption. @@ -394,8 +381,7 @@ Proof. replace (2 * n0 + 1)%nat with (S (2 * n0)). apply lt_O_Sn. ring. - intros; case (total_order_T 0 a); intro. - elim s; intro. + intros; destruct (total_order_T 0 a) as [[Hlt|Heq]|Hgt]. apply H; [ left; assumption | assumption ]. apply H; [ right; assumption | assumption ]. cut (0 < - a). diff --git a/theories/Reals/Rtrigo_calc.v b/theories/Reals/Rtrigo_calc.v index 2ad65a92..281c152b 100644 --- a/theories/Reals/Rtrigo_calc.v +++ b/theories/Reals/Rtrigo_calc.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 0. +Proof. intro; unfold cos_n; unfold Rdiv; apply prod_neq_R0. apply pow_nonzero; discrR. apply Rinv_neq_0_compat. @@ -233,6 +234,7 @@ Definition cos_in (x l:R) : Prop := (**********) 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. @@ -338,7 +340,7 @@ Proof. apply INR_eq; repeat rewrite S_INR; rewrite plus_INR; repeat rewrite mult_INR; rewrite plus_INR; rewrite mult_INR; repeat rewrite S_INR; replace (INR 0) with 0; [ ring | reflexivity ]. -Defined. +Qed. Lemma sin_no_R0 : forall n:nat, sin_n n <> 0. Proof. diff --git a/theories/Reals/Rtrigo_fun.v b/theories/Reals/Rtrigo_fun.v index bc2f62a8..b921ee7b 100644 --- a/theories/Reals/Rtrigo_fun.v +++ b/theories/Reals/Rtrigo_fun.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* Rabs (/ INR (fact (S n)) * / / INR (fact n))) 0. Proof. - unfold Un_cv; intros; elim (Rgt_dec eps 1); intro. - split with 0%nat; intros; rewrite (simpl_fact n); unfold R_dist; - 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; 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 a; 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 lt_O_Sn. -(**) - cut (0 <= up (/ eps - 1))%Z. - intro; elim (IZN (up (/ eps - 1)) H0); intros; split with x; intros; - rewrite (simpl_fact n); unfold R_dist; + unfold Un_cv; intros; destruct (Rgt_dec eps 1) as [Hgt|Hnotgt]. + - split with 0%nat; intros; rewrite (simpl_fact n); unfold R_dist; 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 lt_O_Sn. - apply (le_O_IZR (up (/ eps - 1))); - apply (Rle_trans 0 (/ eps - 1) (IZR (up (/ eps - 1)))). - generalize (Rnot_gt_le eps 1 b); clear b; 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. + 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 lt_O_Sn. + - cut (0 <= up (/ eps - 1))%Z. + intro; elim (IZN (up (/ eps - 1)) H0); intros; split with x; intros; + rewrite (simpl_fact n); unfold R_dist; + 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 lt_O_Sn. + 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/theories/Reals/Rtrigo_reg.v b/theories/Reals/Rtrigo_reg.v index 4e3d41e3..7845e6c4 100644 --- a/theories/Reals/Rtrigo_reg.v +++ b/theories/Reals/Rtrigo_reg.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* Rabs (/ INR (fact (2 * k + 1)) * r ^ (2 * k))) n) l }. - intro X; elim X; intros. + intros (x,p). exists x. split. apply p. @@ -176,14 +176,14 @@ Proof. intro; rewrite H9 in H8; rewrite H10 in H8. apply H8. unfold SFL, sin. - case (cv h); intros. - case (exist_sin (Rsqr h)); intros. + case (cv h) as (x,HUn). + case (exist_sin (Rsqr h)) as (x0,Hsin). unfold Rdiv; rewrite (Rinv_r_simpl_m h x0 H6). eapply UL_sequence. - apply u. - unfold sin_in in s; unfold sin_n, infinite_sum in s; + apply HUn. + unfold sin_in in Hsin; unfold sin_n, infinite_sum in Hsin; unfold SP, fn, Un_cv; intros. - elim (s _ H10); intros N0 H11. + elim (Hsin _ H10); intros N0 H11. exists N0; intros. unfold R_dist; unfold R_dist in H11. replace @@ -194,9 +194,9 @@ Proof. apply sum_eq; intros; apply Rmult_eq_compat_l; unfold Rsqr; rewrite pow_sqr; reflexivity. unfold SFL, sin. - case (cv 0); intros. + case (cv 0) as (?,HUn). eapply UL_sequence. - apply u. + apply HUn. unfold SP, fn; unfold Un_cv; intros; exists 1%nat; intros. unfold R_dist; replace diff --git a/theories/Reals/SeqProp.v b/theories/Reals/SeqProp.v index fb2eacee..9a6fb945 100644 --- a/theories/Reals/SeqProp.v +++ b/theories/Reals/SeqProp.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* R, Un_growing Un -> has_ub Un -> { l:R | Un_cv Un l }. Proof. intros Un Hug Heub. - exists (projT1 (completeness (EUn Un) Heub (EUn_noempty Un))). + 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. @@ -52,8 +53,7 @@ Proof. apply growing_cv. apply decreasing_growing; assumption. exact H0. - intro X. - elim X; intros. + intros (x,p). exists (- x). unfold Un_cv in p. unfold R_dist in p. @@ -150,7 +150,7 @@ Definition sequence_lb (Un:nat -> R) (pr:has_lb Un) (* Compatibility *) Notation sequence_majorant := sequence_ub (only parsing). Notation sequence_minorant := sequence_lb (only parsing). - +Unset Standard Proposition Elimination Names. Lemma Wn_decreasing : forall (Un:nat -> R) (pr:has_ub Un), Un_decreasing (sequence_ub Un pr). Proof. @@ -158,21 +158,15 @@ Proof. unfold Un_decreasing. intro. unfold sequence_ub. - assert (H := ub_to_lub (fun k:nat => Un (S n + k)%nat) (maj_ss Un (S n) pr)). - assert (H0 := ub_to_lub (fun k:nat => Un (n + k)%nat) (maj_ss Un n pr)). - elim H; intros. - elim H0; intros. + 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 ]. cut (lub (fun k:nat => Un (n + k)%nat) (maj_ss Un n pr) = x0); [ intro Maj2; rewrite Maj2 | idtac ]. - unfold is_lub in p. - unfold is_lub in p0. - elim p; intros. apply H2. - elim p0; intros. unfold is_upper_bound. - intros. + intros x1 H5. unfold is_upper_bound in H3. apply H3. elim H5; intros. @@ -183,12 +177,10 @@ Proof. cut (is_lub (EUn (fun k:nat => Un (n + k)%nat)) (lub (fun k:nat => Un (n + k)%nat) (maj_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). + intros (H5,H6). + assert (H7 := H6 x0 H3). assert - (H7 := H3 (lub (fun k:nat => Un (n + k)%nat) (maj_ss Un n pr)) H4). + (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)). @@ -196,13 +188,11 @@ Proof. 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))). - intro. - unfold is_lub in p; unfold is_lub in H1. - elim p; intros; elim H1; intros. - assert (H6 := H5 x H2). + intros (H5,H6). + assert (H7 := H6 x H1). assert - (H7 := - H3 (lub (fun k:nat => Un (S n + k)%nat) (maj_ss Un (S n) pr)) H4). + (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)). @@ -460,8 +450,7 @@ Lemma cond_eq : forall x y:R, (forall eps:R, 0 < eps -> Rabs (x - y) < eps) -> x = y. Proof. intros. - case (total_order_T x y); intro. - elim s; intro. + destruct (total_order_T x y) as [[Hlt|Heq]|Hgt]. cut (0 < y - x). intro. assert (H1 := H (y - x) H0). @@ -470,7 +459,7 @@ Proof. rewrite Rabs_right in H1. elim (Rlt_irrefl _ H1). left; assumption. - apply Rplus_lt_reg_r with x. + apply Rplus_lt_reg_l with x. rewrite Rplus_0_r; replace (x + (y - x)) with y; [ assumption | ring ]. assumption. cut (0 < x - y). @@ -479,7 +468,7 @@ Proof. rewrite Rabs_right in H1. elim (Rlt_irrefl _ H1). left; assumption. - apply Rplus_lt_reg_r with y. + apply Rplus_lt_reg_l with y. rewrite Rplus_0_r; replace (y + (x - y)) with x; [ assumption | ring ]. Qed. @@ -860,7 +849,7 @@ Proof. 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_r with k; rewrite Rplus_0_r; replace (k + (1 - k)) with 1; + 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. @@ -881,12 +870,12 @@ Proof. 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_r with (- k); rewrite <- (Rplus_comm 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_r with k; rewrite Rplus_0_r; elim H; intros; + 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. @@ -896,8 +885,7 @@ Lemma growing_ineq : forall (Un:nat -> R) (l:R), Un_growing Un -> Un_cv Un l -> forall n:nat, Un n <= l. Proof. - intros; case (total_order_T (Un n) l); intro. - elim s; intro. + intros; destruct (total_order_T (Un n) l) as [[Hlt|Heq]|Hgt]. left; assumption. right; assumption. cut (0 < Un n - l). @@ -916,7 +904,7 @@ Proof. apply tech9. assumption. unfold N; apply le_max_l. - apply Rplus_lt_reg_r with l. + apply Rplus_lt_reg_l with l. rewrite Rplus_0_r. replace (l + (Un n - l)) with (Un n); [ assumption | ring ]. Qed. @@ -1102,11 +1090,11 @@ Proof. apply (cv_infty_cv_R0 (fun n:nat => INR (S n))). intro; apply not_O_INR; discriminate. assumption. - unfold cv_infty; intro; case (total_order_T M0 0); intro. - elim s; intro. + 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 lt_O_Sn ]. - exists 0%nat; intros; rewrite b; apply lt_INR_0; apply lt_O_Sn. + exists 0%nat; intros; rewrite Heq; apply lt_INR_0; apply lt_O_Sn. set (M0_z := up M0). assert (H10 := archimed M0). cut (0 <= M0_z)%Z. diff --git a/theories/Reals/SeqSeries.v b/theories/Reals/SeqSeries.v index 5f2173c7..25fe4848 100644 --- a/theories/Reals/SeqSeries.v +++ b/theories/Reals/SeqSeries.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* ]|]. + - rewrite (tech2 An n m); [ idtac | assumption ]. + rewrite (tech2 Bn n m); [ idtac | assumption ]. + unfold R_dist; 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 R_dist; 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 R_dist; 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; 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. + - rewrite (tech2 An m n); [ idtac | assumption ]. + rewrite (tech2 Bn m n); [ idtac | assumption ]. + unfold R_dist; 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 *) @@ -361,7 +359,7 @@ Proof with trivial. 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... + rewrite <- (scal_sum An n (- l)); field... rewrite <- plus_sum; apply sum_eq; intros; ring... Qed. @@ -375,11 +373,11 @@ Proof with trivial. assert (H1 : forall n:nat, 0 < sum_f_R0 An n)... intro; apply tech1... assert (H2 : cv_infty (fun n:nat => sum_f_R0 An n))... - unfold cv_infty; intro; case (Rle_dec M 0); intro... + unfold cv_infty; intro; destruct (Rle_dec M 0) as [Hle|Hnle]... exists 0%nat; intros; apply Rle_lt_trans with 0... assert (H2 : 0 < M)... auto with real... - clear n; set (m := up M); elim (archimed M); intros; + 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... elim (IZN _ H5); intros; exists x; intros; unfold An; rewrite sum_cte; diff --git a/theories/Reals/SplitAbsolu.v b/theories/Reals/SplitAbsolu.v index 3557e2e9..64f4f1c9 100644 --- a/theories/Reals/SplitAbsolu.v +++ b/theories/Reals/SplitAbsolu.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* - case (Rcase_abs X1); try split_case_Rabs + destruct (Rcase_abs X1) as [?Hlt|?Hge]; try split_case_Rabs end. diff --git a/theories/Reals/SplitRmult.v b/theories/Reals/SplitRmult.v index 7380f8ad..fec28518 100644 --- a/theories/Reals/SplitRmult.v +++ b/theories/Reals/SplitRmult.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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 with (y:=d); auto. + constructor. auto. + Qed. + (** Correctness of the reflexive-symmetric-transitive closure *) Lemma clos_rst_is_equiv : equivalence A (clos_refl_sym_trans R). @@ -382,6 +404,13 @@ Section Properties. 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 *) diff --git a/theories/Relations/Relation_Definitions.v b/theories/Relations/Relation_Definitions.v index 390d38b5..a187f955 100644 --- a/theories/Relations/Relation_Definitions.v +++ b/theories/Relations/Relation_Definitions.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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. @@ -204,7 +218,7 @@ Section Lexicographic_Exponentiation. | d_nil : Desc Nil | d_one (x:A) : Desc (x :: Nil) | d_conc (x y:A) (l:List) : - leA x y -> Desc (l ++ y :: Nil) -> Desc ((l ++ y :: Nil) ++ x :: Nil). + clos_refl A leA x y -> Desc (l ++ y :: Nil) -> Desc ((l ++ y :: Nil) ++ x :: Nil). Definition Pow : Set := sig Desc. diff --git a/theories/Relations/Relations.v b/theories/Relations/Relations.v index 6e634db3..ce849a16 100644 --- a/theories/Relations/Relations.v +++ b/theories/Relations/Relations.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* Aeq y x. +Proof. unfold Setoid_Theory in s. intros ; symmetry ; assumption. Defined. Definition Seq_trans A Aeq (s : Setoid_Theory A Aeq) : forall x y z:A, Aeq x y -> Aeq y z -> Aeq x z. +Proof. unfold Setoid_Theory in s. intros ; transitivity y ; assumption. Defined. diff --git a/theories/Sets/Classical_sets.v b/theories/Sets/Classical_sets.v index 44af113e..aa2c144b 100644 --- a/theories/Sets/Classical_sets.v +++ b/theories/Sets/Classical_sets.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* Rel_of U D y z -> Strict_Rel_of U D x z. + 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. @@ -77,7 +77,7 @@ Section Partial_order_facts. 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. + @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. diff --git a/theories/Sets/Permut.v b/theories/Sets/Permut.v index 93d96ef3..c9c1e5b7 100644 --- a/theories/Sets/Permut.v +++ b/theories/Sets/Permut.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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''. +| perm_trans l l' l'' : + Permutation l l' -> Permutation l' l'' -> Permutation l l''. Local Hint Constructors Permutation. @@ -41,7 +40,8 @@ Proof. induction HF; discriminate || auto. Qed. -Theorem Permutation_nil_cons : forall (l : list A) (x : A), ~ Permutation nil (x::l). +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. @@ -54,13 +54,15 @@ Proof. induction l; constructor. exact IHl. Qed. -Theorem Permutation_sym : forall l l' : list A, Permutation l l' -> Permutation l' l. +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''. +Theorem Permutation_trans : forall l l' l'' : list A, + Permutation l l' -> Permutation l' l'' -> Permutation l l''. Proof. exact perm_trans. Qed. @@ -83,11 +85,10 @@ Instance Permutation_Equivalence A : Equivalence (@Permutation A) | 10 := { Equivalence_Symmetric := @Permutation_sym A ; Equivalence_Transitive := @Permutation_trans A }. -Add Parametric Morphism A (a:A) : (cons a) - with signature @Permutation A ==> @Permutation A - as Permutation_cons. +Instance Permutation_cons A : + Proper (Logic.eq ==> @Permutation A ==> @Permutation A) (@cons A) | 10. Proof. - auto using perm_skip. + repeat intro; subst; auto using perm_skip. Qed. Section Permutation_properties. @@ -99,35 +100,48 @@ 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'. +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. -Lemma Permutation_app_tail : forall (l l' tl : list A), Permutation l l' -> Permutation (l++tl) (l'++tl). +Global Instance Permutation_in' : + Proper (Logic.eq ==> @Permutation A ==> iff) (@In A) | 10. +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'). +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]. + 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'). +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. + 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. + [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. -Add Parametric Morphism : (@app A) - with signature @Permutation A ==> @Permutation A ==> @Permutation A - as Permutation_app'. - auto using Permutation_app. +Global Instance Permutation_app' : + Proper (@Permutation A ==> @Permutation A ==> @Permutation A) (@app A) | 10. +Proof. + repeat intro; now apply Permutation_app. Qed. Lemma Permutation_add_inside : forall a (l l' tl tl' : list A), @@ -146,20 +160,27 @@ 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. + 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. 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. +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. +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. @@ -169,18 +190,27 @@ Local Hint Resolve Permutation_middle. Theorem Permutation_rev : forall (l : list A), Permutation l (rev l). Proof. - induction l as [| x l]; simpl; trivial. now rewrite IHl at 1. + induction l as [| x l]; simpl; trivial. now rewrite IHl at 1. Qed. -Add Parametric Morphism : (@rev A) - with signature @Permutation A ==> @Permutation A as Permutation_rev'. -Proof. intros. now do 2 rewrite <- Permutation_rev. Qed. +Global Instance Permutation_rev' : + Proper (@Permutation A ==> @Permutation A) (@rev A) | 10. +Proof. + repeat intro; now rewrite <- 2 Permutation_rev. +Qed. -Theorem Permutation_length : forall (l l' : list A), Permutation l l' -> length l = length l'. +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. + Theorem Permutation_ind_bis : forall P : list A -> list A -> Prop, P [] [] -> @@ -200,73 +230,62 @@ Proof. eauto. Qed. -Ltac break_list l x l' H := - destruct l as [|x l']; simpl in *; - injection H; intros; subst; clear H. - -Theorem Permutation_nil_app_cons : forall (l l' : list A) (x : A), ~ Permutation nil (l++x::l'). +Theorem Permutation_nil_app_cons : forall (l l' : list A) (x : A), + ~ Permutation nil (l++x::l'). Proof. - intros l l' x HF. + intros l l' x HF. apply Permutation_nil in HF. destruct l; discriminate. Qed. -Theorem Permutation_app_inv : forall (l1 l2 l3 l4:list A) a, +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. - set (P l l' := - forall a l1 l2 l3 l4, l=l1++a::l2 -> l'=l3++a::l4 -> Permutation (l1++l2) (l3++l4)). - cut (forall l l', Permutation l l' -> P l l'). - intros; apply (H _ _ H0 a); auto. - intros; apply (Permutation_ind_bis P); unfold P; clear P; try clear H l l'; simpl; auto. -(* nil *) - intros; destruct l1; simpl in *; discriminate. - (* skip *) - intros x l l' H IH; intros. - break_list l1 b l1' H0; break_list l3 c l3' H1. - auto. - now rewrite H. - now rewrite <- H. - now rewrite (IH a _ _ _ _ eq_refl eq_refl). - (* contradict *) - intros x y l l' Hp IH; intros. - break_list l1 b l1' H; break_list l3 c l3' H0. - auto. - break_list l3' b l3'' H. - auto. - rewrite <- Permutation_middle in Hp. now rewrite Hp. - break_list l1' c l1'' H1. - auto. - rewrite <- Permutation_middle in Hp. now rewrite Hp. - break_list l3' d l3'' H; break_list l1' e l1'' H1. - auto. - rewrite <- Permutation_middle in Hp. rewrite perm_swap. auto. - rewrite perm_swap, Permutation_middle. auto. - now rewrite perm_swap, (IH a _ _ _ _ eq_refl eq_refl). - (*trans*) - intros. - destruct (In_split a l') as (l'1,(l'2,H6)). - apply (Permutation_in a H). - subst l. - apply in_or_app; right; red; auto. - apply perm_trans with (l'1++l'2). - apply (H0 _ _ _ _ _ H3 H6). - apply (H2 _ _ _ _ _ H6 H4). + intros. eapply Permutation_Add_inv; eauto using Add_app. Qed. -Theorem Permutation_cons_inv : - forall l l' a, Permutation (a::l) (a::l') -> Permutation l l'. +Theorem Permutation_cons_inv l l' a : + Permutation (a::l) (a::l') -> Permutation l l'. Proof. - intros; exact (Permutation_app_inv [] l [] l' a H). + intro. eapply Permutation_Add_inv; eauto using Add_head. Qed. -Theorem Permutation_cons_app_inv : - forall l l1 l2 a, Permutation (a :: l) (l1 ++ a :: l2) -> Permutation l (l1 ++ l2). +Theorem Permutation_cons_app_inv l l1 l2 a : + Permutation (a :: l) (l1 ++ a :: l2) -> Permutation l (l1 ++ l2). Proof. - intros; exact (Permutation_app_inv [] l l1 l2 a H). + 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. +Theorem Permutation_app_inv_l : forall l l1 l2, + Permutation (l ++ l1) (l ++ l2) -> Permutation l1 l2. Proof. induction l; simpl; auto. intros. @@ -274,20 +293,16 @@ Proof. apply Permutation_cons_inv with a; auto. Qed. -Theorem Permutation_app_inv_r : - forall l l1 l2, Permutation (l1 ++ l) (l2 ++ l) -> Permutation l1 l2. +Theorem Permutation_app_inv_r l l1 l2 : + Permutation (l1 ++ l) (l2 ++ l) -> Permutation l1 l2. Proof. - induction l. - intros l1 l2; do 2 rewrite app_nil_r; auto. - intros. - apply IHl. - apply Permutation_app_inv with a; auto. + rewrite 2 (Permutation_app_comm _ l). apply Permutation_app_inv_l. 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 -> ->; clear Heqm); + induction H; try (injection Heqm as -> ->); discriminate || auto. apply Permutation_nil in H as ->; trivial. Qed. @@ -318,32 +333,47 @@ Proof. apply Permutation_length_2_inv in H as [H|H]; injection H as -> ->; auto. Qed. -Lemma NoDup_Permutation : forall l l', - NoDup l -> NoDup l' -> (forall x:A, In x l <-> In x l') -> Permutation l l'. +Lemma NoDup_Permutation l l' : NoDup l -> NoDup l' -> + (forall x:A, In x l <-> In x l') -> Permutation l l'. Proof. - induction l. - destruct l'; simpl; intros. - apply perm_nil. - destruct (H1 a) as (_,H2); destruct H2; auto. - intros. - destruct (In_split a l') as (l'1,(l'2,H2)). - destruct (H1 a) as (H2,H3); simpl in *; auto. - subst l'. - apply Permutation_cons_app. - inversion_clear H. - apply IHl; auto. - apply NoDup_remove_1 with a; auto. - intro x; split; intros. - assert (In x (l'1++a::l'2)). - destruct (H1 x); simpl in *; auto. - apply in_or_app; destruct (in_app_or _ _ _ H4); auto. - destruct H5; auto. - subst x; destruct H2; auto. - assert (In x (l'1++a::l'2)). - apply in_or_app; destruct (in_app_or _ _ _ H); simpl; auto. - destruct (H1 x) as (_,H5); destruct H5; auto. - subst x. - destruct (NoDup_remove_2 _ _ _ H0 H). + 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 -> NoDup l' -> + length l' <= length l -> incl l l' -> Permutation l l'. +Proof. + intros. apply NoDup_Permutation; auto. + split; auto. apply NoDup_length_incl; trivial. +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) | 10. +Proof. + repeat red; eauto using Permutation_NoDup. Qed. End Permutation_properties. @@ -353,20 +383,194 @@ Section Permutation_map. Variable A B : Type. Variable f : A -> B. -Add Parametric Morphism : (map f) - with signature (@Permutation A) ==> (@Permutation B) as Permutation_map_aux. +Lemma Permutation_map l l' : + Permutation l l' -> Permutation (map f l) (map f l'). Proof. - induction 1; simpl; eauto using Permutation. + induction 1; simpl; eauto. Qed. -Lemma Permutation_map : - forall l l', Permutation l l' -> Permutation (map f l) (map f l'). +Global Instance Permutation_map' : + Proper (@Permutation A ==> @Permutation B) (map f) | 10. Proof. - exact Permutation_map_aux_Proper. + exact Permutation_map. Qed. End Permutation_map. +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 map_length. + * intros x. rewrite in_map_iff. intros (y & <- & Hy'). + rewrite in_seq in *. simpl in *. + destruct Hy' as (_,Hy'). auto with arith. +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. + +Let 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 Lt.le_lt_or_eq in LE. + destruct LE as [LT|EQ']; [|now apply Hf in EQ']. + unfold lt in LT. rewrite EQ in LT. + rewrite <- (Lt.S_pred _ _ LT') in LT. + elim (Lt.lt_not_le _ _ LT' LT). + - apply Lt.le_lt_or_eq in LE'. + destruct LE' as [LT'|EQ']; [|now apply Hf in EQ']. + unfold lt in LT'. rewrite <- EQ in LT'. + rewrite <- (Lt.S_pred _ _ LT) in LT'. + elim (Lt.lt_not_le _ _ LT LT'). + - apply eq_add_S, Hf. + now rewrite (Lt.S_pred _ _ LT), (Lt.S_pred _ _ LT'), EQ. +Qed. + +Let 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 Lt.le_lt_or_eq in LE. + destruct LE as [LT|EQ]; [|now apply Hf in EQ]. + rewrite <- E in LT. + rewrite 2 nth_error_app1; auto. + - rewrite (Lt.S_pred _ _ LT) at 1. + rewrite <- E, (Lt.S_pred _ _ LT) in LT. + rewrite 2 nth_error_app2; auto with arith. + rewrite <- Minus.minus_Sn_m; auto with arith. +Qed. + +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, !app_length. 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 (Lt.le_or_lt (length l) (f n)) as [LE|LT]; trivial. + rewrite <- nth_error_None, <- Hf', nth_error_None, <- E in LE. + elim (Lt.lt_not_le _ _ Hn LE). + - intros (f & Hf & Hf2 & Hf3); split; [|exists f; auto]. + assert (H : length l' <= length l') by auto with arith. + rewrite <- nth_error_None, Hf3, nth_error_None in H. + destruct (Lt.le_or_lt (length l) (length l')) as [LE|LT]; + [|apply Hf2 in LT; elim (Lt.lt_not_le _ _ LT H)]. + apply Lt.le_lt_or_eq 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 (Lt.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 (Lt.lt_irrefl (f y)). eapply Lt.lt_le_trans; eauto. + + apply Hf1 in LT. intros <-. + elim (Lt.lt_irrefl (f x)). eapply Lt.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. + (* begin hide *) Notation Permutation_app_swap := Permutation_app_comm (only parsing). -(* end hide *) \ No newline at end of file +(* end hide *) diff --git a/theories/Sorting/Sorted.v b/theories/Sorting/Sorted.v index fde796af..dc4a1e0a 100644 --- a/theories/Sorting/Sorted.v +++ b/theories/Sorting/Sorted.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* P l -> HdRel a l -> P (a :: l)) -> forall l:list A, Sorted l -> P l. Proof. - induction l; firstorder using Sorted_inv. + induction l. firstorder using Sorted_inv. firstorder using Sorted_inv. Qed. Lemma Sorted_LocallySorted_iff : forall l, Sorted l <-> LocallySorted l. diff --git a/theories/Sorting/Sorting.v b/theories/Sorting/Sorting.v index 6a9105ab..712b8fd6 100644 --- a/theories/Sorting/Sorting.v +++ b/theories/Sorting/Sorting.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* b}. +Proof. decide equality; apply bool_dec. Defined. @@ -115,7 +116,7 @@ Proof. unfold N.lt. change 256%N with (N.of_nat 256). rewrite <- Nat2N.inj_compare. - rewrite <- Compare_dec.nat_compare_lt. auto. + now apply Nat.compare_lt_iff. Qed. diff --git a/theories/Strings/String.v b/theories/Strings/String.v index 34adf332..ac1f158a 100644 --- a/theories/Strings/String.v +++ b/theories/Strings/String.v @@ -1,7 +1,7 @@ (* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* s2}. +Proof. decide equality; apply ascii_dec. Defined. @@ -41,7 +42,6 @@ Fixpoint append (s1 s2 : string) : string := | EmptyString => s2 | String c s1' => String c (s1' ++ s2) end - where "s1 ++ s2" := (append s1 s2) : string_scope. (******************************) @@ -379,7 +379,7 @@ Definition findex n s1 s2 := (** The concrete syntax for strings in scope string_scope follows the Coq convention for strings: all ascii characters of code less than - 128 are litteral to the exception of the character `double quote' + 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 diff --git a/theories/Structures/DecidableType.v b/theories/Structures/DecidableType.v index 79e81771..f85222df 100644 --- a/theories/Structures/DecidableType.v +++ b/theories/Structures/DecidableType.v @@ -80,13 +80,13 @@ Module KeyDecidableType(D:DecidableType). Lemma InA_eqke_eqk : forall x m, InA eqke x m -> InA eqk x m. Proof. - unfold eqke; induction 1; intuition. + unfold eqke; induction 1; intuition. Qed. Hint Resolve InA_eqke_eqk. Lemma InA_eqk : forall p q m, eqk p q -> InA eqk p m -> InA eqk q m. Proof. - intros; apply InA_eqA with p; auto with *. + intros; apply InA_eqA with p; auto with *. Qed. Definition MapsTo (k:key)(e:elt):= InA eqke (k,e). diff --git a/theories/Structures/DecidableTypeEx.v b/theories/Structures/DecidableTypeEx.v index 971fcd7f..163a40f2 100644 --- a/theories/Structures/DecidableTypeEx.v +++ b/theories/Structures/DecidableTypeEx.v @@ -88,7 +88,7 @@ Module PairUsualDecidableType(D1 D2:UsualDecidableType) <: UsualDecidableType. 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; intro H; injection H; auto). + (right; injection; auto). Defined. End PairUsualDecidableType. diff --git a/theories/Structures/Equalities.v b/theories/Structures/Equalities.v index eb537385..747d03f8 100644 --- a/theories/Structures/Equalities.v +++ b/theories/Structures/Equalities.v @@ -126,14 +126,14 @@ Module Type DecidableTypeFull' := DecidableTypeFull <+ EqNotation. [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. + Definition eq_refl := F.eq_equiv.(@Equivalence_Reflexive _ _). + Definition eq_sym := F.eq_equiv.(@Equivalence_Symmetric _ _). + Definition eq_trans := F.eq_equiv.(@Equivalence_Transitive _ _). End BackportEq. Module UpdateEq (E:Eq)(F:IsEqOrig E) <: IsEq E. Instance eq_equiv : Equivalence E.eq. - Proof. exact (Build_Equivalence _ _ F.eq_refl F.eq_sym F.eq_trans). Qed. + Proof. exact (Build_Equivalence _ F.eq_refl F.eq_sym F.eq_trans). Qed. End UpdateEq. Module Backport_ET (E:EqualityType) <: EqualityTypeBoth diff --git a/theories/Structures/EqualitiesFacts.v b/theories/Structures/EqualitiesFacts.v index c69885b4..11d94c11 100644 --- a/theories/Structures/EqualitiesFacts.v +++ b/theories/Structures/EqualitiesFacts.v @@ -166,7 +166,7 @@ Module PairUsualDecidableType(D1 D2:UsualDecidableType) <: UsualDecidableType. 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; intro H; injection H; auto). + (right; intros [=]; auto). Defined. End PairUsualDecidableType. diff --git a/theories/Structures/GenericMinMax.v b/theories/Structures/GenericMinMax.v index ffd0649a..ac52d1bb 100644 --- a/theories/Structures/GenericMinMax.v +++ b/theories/Structures/GenericMinMax.v @@ -110,7 +110,7 @@ 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 *. + rewrite <- Hx, <- Hy in *. destruct (lt_total x y); intuition order. Qed. @@ -440,7 +440,7 @@ Qed. Lemma max_min_antimono f : Proper (eq==>eq) f -> - Proper (le==>inverse le) f -> + Proper (le==>flip le) f -> forall x y, max (f x) (f y) == f (min x y). Proof. intros Eqf Lef x y. @@ -452,7 +452,7 @@ Qed. Lemma min_max_antimono f : Proper (eq==>eq) f -> - Proper (le==>inverse le) f -> + Proper (le==>flip le) f -> forall x y, min (f x) (f y) == f (max x y). Proof. intros Eqf Lef x y. @@ -557,11 +557,11 @@ Module UsualMinMaxLogicalProperties 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 ==> inverse le) f -> + 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 ==> inverse le) f -> + 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. diff --git a/theories/Structures/OrderedType.v b/theories/Structures/OrderedType.v index 75578195..cc8c2261 100644 --- a/theories/Structures/OrderedType.v +++ b/theories/Structures/OrderedType.v @@ -49,7 +49,7 @@ Module Type OrderedType. Include MiniOrderedType. (** A [eq_dec] can be deduced from [compare] below. But adding this - redundant field allows to see an OrderedType as a DecidableType. *) + redundant field allows seeing an OrderedType as a DecidableType. *) Parameter eq_dec : forall x y, { eq x y } + { ~ eq x y }. End OrderedType. @@ -85,16 +85,16 @@ Module OrderedTypeFacts (Import O: OrderedType). Lemma lt_eq : forall x y z, lt x y -> eq y z -> lt x z. Proof. - intros; destruct (compare x z); auto. + intros; destruct (compare x z) as [Hlt|Heq|Hlt]; auto. elim (lt_not_eq H); apply eq_trans with z; auto. - elim (lt_not_eq (lt_trans l H)); auto. + elim (lt_not_eq (lt_trans Hlt H)); auto. Qed. Lemma eq_lt : forall x y z, eq x y -> lt y z -> lt x z. Proof. - intros; destruct (compare x z); auto. + intros; destruct (compare x z) as [Hlt|Heq|Hlt]; auto. elim (lt_not_eq H0); apply eq_trans with x; auto. - elim (lt_not_eq (lt_trans H0 l)); auto. + elim (lt_not_eq (lt_trans H0 Hlt)); auto. Qed. Instance lt_compat : Proper (eq==>eq==>iff) lt. @@ -225,7 +225,7 @@ 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_strorder lt_compat). Qed. +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. @@ -398,7 +398,7 @@ Module KeyOrderedType(O:OrderedType). Qed. Lemma Inf_eq : forall l x x', eqk x x' -> Inf x' l -> Inf x l. - Proof. exact (InfA_eqA eqk_equiv ltk_strorder ltk_compat). Qed. + 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. diff --git a/theories/Structures/OrderedTypeEx.v b/theories/Structures/OrderedTypeEx.v index 83130deb..3c6afc7b 100644 --- a/theories/Structures/OrderedTypeEx.v +++ b/theories/Structures/OrderedTypeEx.v @@ -279,7 +279,7 @@ Module PositiveOrderedTypeBits <: UsualOrderedType. Proof. induction x; destruct y. - (* I I *) - destruct (IHx y). + destruct (IHx y) as [l|e|g]. apply LT; auto. apply EQ; rewrite e; red; auto. apply GT; auto. @@ -290,7 +290,7 @@ Module PositiveOrderedTypeBits <: UsualOrderedType. - (* O I *) apply LT; simpl; auto. - (* O O *) - destruct (IHx y). + destruct (IHx y) as [l|e|g]. apply LT; auto. apply EQ; rewrite e; red; auto. apply GT; auto. diff --git a/theories/Structures/Orders.v b/theories/Structures/Orders.v index 1d025439..724690b4 100644 --- a/theories/Structures/Orders.v +++ b/theories/Structures/Orders.v @@ -15,11 +15,11 @@ Unset Strict Implicit. (** First, signatures with only the order relations *) Module Type HasLt (Import T:Typ). - Parameter Inline lt : t -> t -> Prop. + Parameter Inline(40) lt : t -> t -> Prop. End HasLt. Module Type HasLe (Import T:Typ). - Parameter Inline le : t -> t -> Prop. + Parameter Inline(40) le : t -> t -> Prop. End HasLe. Module Type EqLt := Typ <+ HasEq <+ HasLt. @@ -95,7 +95,7 @@ Module Type OrderedTypeFull' := OrderedTypeFull <+ EqLtLeNotation <+ CmpNotation. (** NB: in [OrderedType], an [eq_dec] could be deduced from [compare]. - But adding this redundant field allows to see an [OrderedType] as a + But adding this redundant field allows seeing an [OrderedType] as a [DecidableType]. *) (** * Versions with [eq] being the usual Leibniz equality of Coq *) diff --git a/theories/Structures/OrdersEx.v b/theories/Structures/OrdersEx.v index e071d053..acc7c767 100644 --- a/theories/Structures/OrdersEx.v +++ b/theories/Structures/OrdersEx.v @@ -11,16 +11,16 @@ * Institution: LRI, CNRS UMR 8623 - Université Paris Sud * 91405 Orsay, France *) -Require Import Orders NPeano POrderedType NArith - ZArith RelationPairs EqualitiesFacts. +Require Import Orders PeanoNat POrderedType BinNat BinInt + RelationPairs EqualitiesFacts. (** * Examples of Ordered Type structures. *) (** Ordered Type for [nat], [Positive], [N], [Z] with the usual order. *) -Module Nat_as_OT := NPeano.Nat. -Module Positive_as_OT := POrderedType.Positive_as_OT. +Module Nat_as_OT := PeanoNat.Nat. +Module Positive_as_OT := BinPos.Pos. Module N_as_OT := BinNat.N. Module Z_as_OT := BinInt.Z. diff --git a/theories/Structures/OrdersFacts.v b/theories/Structures/OrdersFacts.v index 2e9c0cf5..88fbd8c1 100644 --- a/theories/Structures/OrdersFacts.v +++ b/theories/Structures/OrdersFacts.v @@ -31,7 +31,7 @@ Module Type CompareFacts (Import O:DecStrOrder'). Lemma compare_lt_iff x y : (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_strorder lt_compat). Qed. +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. diff --git a/theories/Structures/OrdersTac.v b/theories/Structures/OrdersTac.v index 68ffc379..475a25a4 100644 --- a/theories/Structures/OrdersTac.v +++ b/theories/Structures/OrdersTac.v @@ -29,7 +29,7 @@ Set Implicit Arguments. [le x y -> le y z -> le x z]. *) -Inductive ord := OEQ | OLT | OLE. +Inductive ord : Set := OEQ | OLT | OLE. Definition trans_ord o o' := match o, o' with | OEQ, _ => o' @@ -70,7 +70,7 @@ Lemma le_refl : forall x, x<=x. Proof. intros; rewrite P.le_lteq; right; reflexivity. Qed. Lemma lt_irrefl : forall x, ~ x #o' y z -> #(o+o') x z. Proof. -destruct o, o'; simpl; intros x y z; rewrite ?P.le_lteq; intuition; - subst_eqns; eauto using (StrictOrder_Transitive x y z) with *. +destruct o, o'; simpl; intros x y z; +rewrite ?P.le_lteq; intuition auto; +subst_eqns; eauto using (StrictOrder_Transitive x y z) with *. Qed. Definition eq_trans x y z : x==y -> y==z -> x==z := @trans OEQ OEQ x y z. diff --git a/theories/Unicode/Utf8.v b/theories/Unicode/Utf8.v index f9041aad..3b4beda9 100644 --- a/theories/Unicode/Utf8.v +++ b/theories/Unicode/Utf8.v @@ -1,7 +1,7 @@ (* -*- coding:utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* y) - (at level 90, y at level 200, right associativity): type_scope. + (at level 99, y at level 200, right associativity): type_scope. Notation "x ↔ y" := (x <-> y) (at level 95, no associativity): type_scope. Notation "¬ x" := (~x) (at level 75, right associativity) : type_scope. diff --git a/theories/Vectors/Fin.v b/theories/Vectors/Fin.v index a5e37f34..b9bf6c7f 100644 --- a/theories/Vectors/Fin.v +++ b/theories/Vectors/Fin.v @@ -8,13 +8,14 @@ Require Arith_base. -(** [fin n] is a convinient way to represent \[1 .. n\] +(** [fin n] is a convenient way to represent \[1 .. n\] -[fin n] can be seen as a n-uplet of unit where [F1] is the first element of -the n-uplet and [FS] set (n-1)-uplet of all the element but the first. +[fin n] can be seen as a n-uplet of unit. [F1] is the first element of +the n-uplet. If [f] is the k-th element of the (n-1)-uplet, [FS f] is the +(k+1)-th element of the n-uplet. Author: Pierre Boutillier - Institution: PPS, INRIA 12/2010-01/2012 + Institution: PPS, INRIA 12/2010-01/2012-07/2012 *) Inductive t : nat -> Set := @@ -23,76 +24,68 @@ Inductive t : nat -> Set := Section SCHEMES. Definition case0 P (p: t 0): P p := - match p as p' in t n return - match n as n' return t n' -> Type - with |0 => fun f0 => P f0 |S _ => fun _ => @ID end p' - with |F1 _ => @id |FS _ _ => @id end. + match p with | F1 | FS _ => fun devil => False_rect (@IDProp) devil (* subterm !!! *) end. -Definition caseS (P: forall {n}, t (S n) -> Type) - (P1: forall n, @P n F1) (PS : forall {n} (p: t n), P (FS p)) - {n} (p: t (S n)): P p := +Definition caseS' {n : nat} (p : t (S n)) : forall (P : t (S n) -> Type) + (P1 : P F1) (PS : forall (p : t n), P (FS p)), P p := match p with - |F1 k => P1 k - |FS k pp => PS pp + | @F1 k => fun P P1 PS => P1 + | FS pp => fun P P1 PS => PS pp end. +Definition caseS (P: forall {n}, t (S n) -> Type) + (P1: forall n, @P n F1) (PS : forall {n} (p: t n), P (FS p)) + {n} (p: t (S n)) : P p := caseS' p P (P1 n) PS. + Definition rectS (P: forall {n}, t (S n) -> Type) (P1: forall n, @P n F1) (PS : forall {n} (p: t (S n)), P p -> P (FS p)): forall {n} (p: t (S n)), P p := fix rectS_fix {n} (p: t (S n)): P p:= match p with - |F1 k => P1 k - |FS 0 pp => case0 (fun f => P (FS f)) pp - |FS (S k) pp => PS pp (rectS_fix pp) + | @F1 k => P1 k + | @FS 0 pp => case0 (fun f => P (FS f)) pp + | @FS (S k) pp => PS pp (rectS_fix pp) end. -Definition rect2 (P: forall {n} (a b: t n), Type) - (H0: forall n, @P (S n) F1 F1) - (H1: forall {n} (f: t n), P F1 (FS f)) - (H2: forall {n} (f: t n), P (FS f) F1) - (HS: forall {n} (f g : t n), P f g -> P (FS f) (FS g)): - forall {n} (a b: t n), P a b := -fix rect2_fix {n} (a: t n): forall (b: t n), P a b := -match a with - |F1 m => fun (b: t (S m)) => match b as b' in t n' - return match n',b' with - |0,_ => @ID - |S n0,b0 => P F1 b0 - end with - |F1 m' => H0 m' - |FS m' b' => H1 b' - end - |FS m a' => fun (b: t (S m)) => match b with - |F1 m' => fun aa: t m' => H2 aa - |FS m' b' => fun aa: t m' => HS aa b' (rect2_fix aa b') - end a' -end. +Definition rect2 (P : forall {n} (a b : t n), Type) + (H0 : forall n, @P (S n) F1 F1) + (H1 : forall {n} (f : t n), P F1 (FS f)) + (H2 : forall {n} (f : t n), P (FS f) F1) + (HS : forall {n} (f g : t n), P f g -> P (FS f) (FS g)) : + forall {n} (a b : t n), P a b := + fix rect2_fix {n} (a : t n) {struct a} : forall (b : t n), P a b := + match a with + | @F1 m => fun (b : t (S m)) => caseS' b (P F1) (H0 _) H1 + | @FS m a' => fun (b : t (S m)) => + caseS' b (fun b => P (@FS m a') b) (H2 a') (fun b' => HS _ _ (rect2_fix a' b')) + end. + End SCHEMES. Definition FS_inj {n} (x y: t n) (eq: FS x = FS y): x = y := match eq in _ = a return match a as a' in t m return match m with |0 => Prop |S n' => t n' -> Prop end - with @F1 _ => fun _ => True |@FS _ y => fun x' => x' = y end x with + with F1 => fun _ => True |FS y => fun x' => x' = y end x with eq_refl => eq_refl end. (** [to_nat f] = p iff [f] is the p{^ th} element of [fin m]. *) Fixpoint to_nat {m} (n : t m) : {i | i < m} := - match n in t k return {i | i< k} with - |F1 j => exist (fun i => i< S j) 0 (Lt.lt_0_Sn j) - |FS _ p => match to_nat p with |exist i P => exist _ (S i) (Lt.lt_n_S _ _ P) end + match n with + |@F1 j => exist _ 0 (Lt.lt_0_Sn j) + |FS p => match to_nat p with |exist _ i P => exist _ (S i) (Lt.lt_n_S _ _ P) end end. (** [of_nat p n] answers the p{^ th} element of [fin n] if p < n or a proof of p >= n else *) Fixpoint of_nat (p n : nat) : (t n) + { exists m, p = n + m } := match n with - |0 => inright _ (ex_intro (fun x => p = 0 + x) p (@eq_refl _ p)) + |0 => inright _ (ex_intro _ p eq_refl) |S n' => match p with |0 => inleft _ (F1) |S p' => match of_nat p' n' with |inleft f => inleft _ (FS f) - |inright arg => inright _ (match arg with |ex_intro m e => + |inright arg => inright _ (match arg with |ex_intro _ m e => ex_intro (fun x => S p' = S n' + x) m (f_equal S e) end) end end @@ -109,13 +102,35 @@ Fixpoint of_nat_lt {p n : nat} : p < n -> t n := end end. +Lemma of_nat_ext {p}{n} (h h' : p < n) : of_nat_lt h = of_nat_lt h'. +Proof. + now rewrite (Peano_dec.le_unique _ _ h h'). +Qed. + Lemma of_nat_to_nat_inv {m} (p : t m) : of_nat_lt (proj2_sig (to_nat p)) = p. Proof. -induction p. - reflexivity. - simpl; destruct (to_nat p). simpl. subst p; repeat f_equal. apply Peano_dec.le_unique. +induction p; simpl. +- reflexivity. +- destruct (to_nat p); simpl in *. f_equal. subst p. apply of_nat_ext. +Qed. + +Lemma to_nat_of_nat {p}{n} (h : p < n) : to_nat (of_nat_lt h) = exist _ p h. +Proof. + revert n h. + induction p; (destruct n ; intros h; [ destruct (Lt.lt_n_O _ h) | cbn]); + [ | rewrite (IHp _ (Lt.lt_S_n p n h))]; f_equal; apply Peano_dec.le_unique. +Qed. + +Lemma to_nat_inj {n} (p q : t n) : + proj1_sig (to_nat p) = proj1_sig (to_nat q) -> p = q. +Proof. + intro H. + rewrite <- (of_nat_to_nat_inv p), <- (of_nat_to_nat_inv q). + destruct (to_nat p) as (np,hp), (to_nat q) as (nq,hq); simpl in *. + revert hp hq. rewrite H. apply of_nat_ext. Qed. + (** [weak p f] answers a function witch is the identity for the p{^ th} first element of [fin (p + m)] and [FS (FS .. (FS (f k)))] for [FS (FS .. (FS k))] with p FSs *) @@ -124,15 +139,15 @@ Fixpoint weak {m}{n} p (f : t m -> t n) : match p as p' return t (p' + m) -> t (p' + n) with |0 => f |S p' => fun x => match x with - |F1 n' => fun eq : n' = p' + m => F1 - |FS n' y => fun eq : n' = p' + m => FS (weak p' f (eq_rect _ t y _ eq)) + |@F1 n' => fun eq : n' = p' + m => F1 + |@FS n' y => fun eq : n' = p' + m => FS (weak p' f (eq_rect _ t y _ eq)) end (eq_refl _) end. (** The p{^ th} element of [fin m] viewed as the p{^ th} element of [fin (m + n)] *) Fixpoint L {m} n (p : t m) : t (m + n) := - match p with |F1 _ => F1 |FS _ p' => FS (L n p') end. + match p with |F1 => F1 |FS p' => FS (L n p') end. Lemma L_sanity {m} n (p : t m) : proj1_sig (to_nat (L n p)) = proj1_sig (to_nat p). Proof. @@ -145,12 +160,13 @@ Qed. [fin (n + m)] Really really ineficient !!! *) Definition L_R {m} n (p : t m) : t (n + m). +Proof. induction n. exact p. exact ((fix LS k (p: t k) := match p with - |F1 k' => @F1 (S k') - |FS _ p' => FS (LS _ p') + |@F1 k' => @F1 (S k') + |FS p' => FS (LS _ p') end) _ IHn). Defined. @@ -168,8 +184,8 @@ Qed. Fixpoint depair {m n} (o : t m) (p : t n) : t (m * n) := match o with - |F1 m' => L (m' * n) p - |FS m' o' => R n (depair o' p) + |@F1 m' => L (m' * n) p + |FS o' => R n (depair o' p) end. Lemma depair_sanity {m n} (o : t m) (p : t n) : @@ -182,3 +198,55 @@ induction o ; simpl. rewrite Plus.plus_assoc. destruct (to_nat o); simpl; rewrite Mult.mult_succ_r. now rewrite (Plus.plus_comm n). Qed. + +Fixpoint eqb {m n} (p : t m) (q : t n) := +match p, q with +| @F1 m', @F1 n' => EqNat.beq_nat m' n' +| FS _, F1 => false +| F1, FS _ => false +| FS p', FS q' => eqb p' q' +end. + +Lemma eqb_nat_eq : forall m n (p : t m) (q : t n), eqb p q = true -> m = n. +Proof. +intros m n p; revert n; induction p; destruct q; simpl; intros; f_equal. ++ now apply EqNat.beq_nat_true. ++ easy. ++ easy. ++ eapply IHp. eassumption. +Qed. + +Lemma eqb_eq : forall n (p q : t n), eqb p q = true <-> p = q. +Proof. +apply rect2; simpl; intros. +- split; intros ; [ reflexivity | now apply EqNat.beq_nat_true_iff ]. +- now split. +- now split. +- eapply iff_trans. + + eassumption. + + split. + * intros; now f_equal. + * apply FS_inj. +Qed. + +Lemma eq_dec {n} (x y : t n): {x = y} + {x <> y}. +Proof. + case_eq (eqb x y); intros. + + left; now apply eqb_eq. + + right. intros Heq. apply <- eqb_eq in Heq. congruence. +Defined. + +Definition cast: forall {m} (v: t m) {n}, m = n -> t n. +Proof. +refine (fix cast {m} (v: t m) {struct v} := + match v in t m' return forall n, m' = n -> t n with + |F1 => fun n => match n with + | 0 => fun H => False_rect _ _ + | S n' => fun H => F1 + end + |FS f => fun n => match n with + | 0 => fun H => False_rect _ _ + | S n' => fun H => FS (cast f n' (f_equal pred H)) + end +end); discriminate. +Defined. diff --git a/theories/Vectors/Vector.v b/theories/Vectors/Vector.v index f3e5e338..672858fa 100644 --- a/theories/Vectors/Vector.v +++ b/theories/Vectors/Vector.v @@ -18,5 +18,7 @@ Based on contents from Util/VecUtil of the CoLoR contribution *) Require Fin. Require VectorDef. Require VectorSpec. +Require VectorEq. Include VectorDef. Include VectorSpec. +Include VectorEq. \ No newline at end of file diff --git a/theories/Vectors/VectorDef.v b/theories/Vectors/VectorDef.v index 32ffcb3d..45c13e5c 100644 --- a/theories/Vectors/VectorDef.v +++ b/theories/Vectors/VectorDef.v @@ -21,6 +21,8 @@ Require Vectors.Fin. Import EqNotations. Local Open Scope nat_scope. +(* Set Universe Polymorphism. *) + (** A vector is a list of size n whose elements belong to a set A. *) @@ -40,72 +42,61 @@ Definition rectS {A} (P:forall {n}, t A (S n) -> Type) (rect: forall a {n} (v: t A (S n)), P v -> P (a :: v)) := fix rectS_fix {n} (v: t A (S n)) : P v := match v with - |nil => fun devil => False_rect (@ID) devil - |cons a 0 v => - match v as vnn in t _ nn - return - match nn,vnn with - |0,vm => P (a :: vm) - |S _,_ => _ - end - with - |nil => bas a - |_ :: _ => fun devil => False_rect (@ID) devil - end - |cons a (S nn') v => rect a v (rectS_fix v) + |@cons _ a 0 v => + match v with + |nil _ => bas a + |_ => fun devil => False_ind (@IDProp) devil (* subterm !!! *) + end + |@cons _ a (S nn') v => rect a v (rectS_fix v) + |_ => fun devil => False_ind (@IDProp) devil (* subterm !!! *) end. -(** An induction scheme for 2 vectors of same length *) -Definition rect2 {A B} (P:forall {n}, t A n -> t B n -> Type) - (bas : P [] []) (rect : forall {n v1 v2}, P v1 v2 -> - forall a b, P (a :: v1) (b :: v2)) := -fix rect2_fix {n} (v1:t A n): - forall v2 : t B n, P v1 v2 := -match v1 as v1' in t _ n1 - return forall v2 : t B n1, P v1' v2 with - |[] => fun v2 => - match v2 with - |[] => bas - |_ :: _ => fun devil => False_rect (@ID) devil - end - |h1 :: t1 => fun v2 => - match v2 with - |[] => fun devil => False_rect (@ID) devil - |h2 :: t2 => fun t1' => - rect (rect2_fix t1' t2) h1 h2 - end t1 -end. - (** A vector of length [0] is [nil] *) Definition case0 {A} (P:t A 0 -> Type) (H:P (nil A)) v:P v := match v with |[] => H + |_ => fun devil => False_ind (@IDProp) devil (* subterm !!! *) end. (** A vector of length [S _] is [cons] *) Definition caseS {A} (P : forall {n}, t A (S n) -> Type) (H : forall h {n} t, @P n (h :: t)) {n} (v: t A (S n)) : P v := -match v as v' in t _ m return match m, v' with |0, _ => False -> True |S _, v0 => P v' end with - |[] => fun devil => False_rect _ devil (* subterm !!! *) +match v with |h :: t => H h t + |_ => fun devil => False_ind (@IDProp) devil (* subterm !!! *) end. + +Definition caseS' {A} {n : nat} (v : t A (S n)) : forall (P : t A (S n) -> Type) + (H : forall h t, P (h :: t)), P v := + match v with + | h :: t => fun P H => H h t + | _ => fun devil => False_rect (@IDProp) devil + end. + +(** An induction scheme for 2 vectors of same length *) +Definition rect2 {A B} (P:forall {n}, t A n -> t B n -> Type) + (bas : P [] []) (rect : forall {n v1 v2}, P v1 v2 -> + forall a b, P (a :: v1) (b :: v2)) := + fix rect2_fix {n} (v1 : t A n) : forall v2 : t B n, P v1 v2 := + match v1 with + | [] => fun v2 => case0 _ bas v2 + | @cons _ h1 n' t1 => fun v2 => + caseS' v2 (fun v2' => P (h1::t1) v2') (fun h2 t2 => rect (rect2_fix t1 t2) h1 h2) + end. + End SCHEMES. Section BASES. (** The first element of a non empty vector *) -Definition hd {A} {n} (v:t A (S n)) := Eval cbv delta beta in -(caseS (fun n v => A) (fun h n t => h) v). +Definition hd {A} := @caseS _ (fun n v => A) (fun h n t => h). +Global Arguments hd {A} {n} v. (** The last element of an non empty vector *) -Definition last {A} {n} (v : t A (S n)) := Eval cbv delta in -(rectS (fun _ _ => A) (fun a => a) (fun _ _ _ H => H) v). +Definition last {A} := @rectS _ (fun _ _ => A) (fun a => a) (fun _ _ _ H => H). +Global Arguments last {A} {n} v. (** Build a vector of n{^ th} [a] *) -Fixpoint const {A} (a:A) (n:nat) := - match n return t A n with - | O => nil A - | S n => a :: (const a n) - end. +Definition const {A} (a:A) := nat_rect _ [] (fun n x => cons _ a n x). (** The [p]{^ th} element of a vector of length [m]. @@ -114,8 +105,8 @@ ocaml function. *) Definition nth {A} := fix nth_fix {m} (v' : t A m) (p : Fin.t m) {struct v'} : A := match p in Fin.t m' return t A m' -> A with - |Fin.F1 q => fun v => caseS (fun n v' => A) (fun h n t => h) v - |Fin.FS q p' => fun v => (caseS (fun n v' => Fin.t n -> A) + |Fin.F1 => caseS (fun n v' => A) (fun h n t => h) + |Fin.FS p' => fun v => (caseS (fun n v' => Fin.t n -> A) (fun h n t p0 => nth_fix t p0) v) p' end v'. @@ -126,9 +117,9 @@ Definition nth_order {A} {n} (v: t A n) {p} (H: p < n) := (** Put [a] at the p{^ th} place of [v] *) Fixpoint replace {A n} (v : t A n) (p: Fin.t n) (a : A) {struct p}: t A n := match p with - |Fin.F1 k => fun v': t A (S k) => caseS (fun n _ => t A (S n)) (fun h _ t => a :: t) v' - |Fin.FS k p' => fun v' => - (caseS (fun n _ => Fin.t n -> t A (S n)) (fun h _ t p2 => h :: (replace t p2 a)) v') p' + | @Fin.F1 k => fun v': t A (S k) => caseS' v' _ (fun h t => a :: t) + | @Fin.FS k p' => fun v' : t A (S k) => + (caseS' v' (fun _ => t A (S k)) (fun h t => h :: (replace t p' a))) end v. (** Version of replace with [lt] *) @@ -136,13 +127,13 @@ Definition replace_order {A n} (v: t A n) {p} (H: p < n) := replace v (Fin.of_nat_lt H). (** Remove the first element of a non empty vector *) -Definition tl {A} {n} (v:t A (S n)) := Eval cbv delta beta in -(caseS (fun n v => t A n) (fun h n t => t) v). +Definition tl {A} := @caseS _ (fun n v => t A n) (fun h n t => t). +Global Arguments tl {A} {n} v. (** Remove last element of a non-empty vector *) -Definition shiftout {A} {n:nat} (v:t A (S n)) : t A n := -Eval cbv delta beta in (rectS (fun n _ => t A n) (fun a => []) - (fun h _ _ H => h :: H) v). +Definition shiftout {A} := @rectS _ (fun n _ => t A n) (fun a => []) + (fun h _ _ H => h :: H). +Global Arguments shiftout {A} {n} v. (** Add an element at the end of a vector *) Fixpoint shiftin {A} {n:nat} (a : A) (v:t A n) : t A (S n) := @@ -152,9 +143,9 @@ match v with end. (** Copy last element of a vector *) -Definition shiftrepeat {A} {n} (v:t A (S n)) : t A (S (S n)) := -Eval cbv delta beta in (rectS (fun n _ => t A (S (S n))) - (fun h => h :: h :: []) (fun h _ _ H => h :: H) v). +Definition shiftrepeat {A} := @rectS _ (fun n _ => t A (S (S n))) + (fun h => h :: h :: []) (fun h _ _ H => h :: H). +Global Arguments shiftrepeat {A} {n} v. (** Remove [p] last elements of a vector *) Lemma trunc : forall {A} {n} (p:nat), n > p -> t A n @@ -221,10 +212,10 @@ Definition map {A} {B} (f : A -> B) : forall {n} (v:t A n), t B n := end. (** map2 g [x1 .. xn] [y1 .. yn] = [(g x1 y1) .. (g xn yn)] *) -Definition map2 {A B C} (g:A -> B -> C) {n} (v1:t A n) (v2:t B n) - : t C n := -Eval cbv delta beta in rect2 (fun n _ _ => t C n) (nil C) - (fun _ _ _ H a b => (g a b) :: H) v1 v2. +Definition map2 {A B C} (g:A -> B -> C) : + forall (n : nat), t A n -> t B n -> t C n := +@rect2 _ _ (fun n _ _ => t C n) (nil C) (fun _ _ _ H a b => (g a b) :: H). +Global Arguments map2 {A B C} g {n} v1 v2. (** fold_left f b [x1 .. xn] = f .. (f (f b x1) x2) .. xn *) Definition fold_left {A B:Type} (f:B->A->B): forall (b:B) {n} (v:t A n), B := @@ -242,24 +233,19 @@ Definition fold_right {A B : Type} (f : A->B->B) := | a :: w => f a (fold_right_fix w b) end. -(** fold_right2 g [x1 .. xn] [y1 .. yn] c = g x1 y1 (g x2 y2 .. (g xn yn c) .. ) *) -Definition fold_right2 {A B C} (g:A -> B -> C -> C) {n} (v:t A n) - (w : t B n) (c:C) : C := -Eval cbv delta beta in rect2 (fun _ _ _ => C) c - (fun _ _ _ H a b => g a b H) v w. +(** fold_right2 g c [x1 .. xn] [y1 .. yn] = g x1 y1 (g x2 y2 .. (g xn yn c) .. ) + c is before the vectors to be compliant with "refolding". *) +Definition fold_right2 {A B C} (g:A -> B -> C -> C) (c: C) := +@rect2 _ _ (fun _ _ _ => C) c (fun _ _ _ H a b => g a b H). + (** fold_left2 f b [x1 .. xn] [y1 .. yn] = g .. (g (g a x1 y1) x2 y2) .. xn yn *) Definition fold_left2 {A B C: Type} (f : A -> B -> C -> A) := fix fold_left2_fix (a : A) {n} (v : t B n) : t C n -> A := match v in t _ n0 return t C n0 -> A with - |[] => fun w => match w in t _ n1 - return match n1 with |0 => A |S _ => @ID end with - |[] => a - |_ :: _ => @id end - |cons vh vn vt => fun w => match w in t _ n1 - return match n1 with |0 => @ID |S n => t B n -> A end with - |[] => @id - |wh :: wt => fun vt' => fold_left2_fix (f a vh wh) vt' wt end vt + |[] => fun w => case0 (fun _ => A) a w + |@cons _ vh vn vt => fun w => + caseS' w (fun _ => A) (fun wh wt => fold_left2_fix (f a vh wh) vt wt) end. End ITERATORS. diff --git a/theories/Vectors/VectorEq.v b/theories/Vectors/VectorEq.v new file mode 100644 index 00000000..04c57073 --- /dev/null +++ b/theories/Vectors/VectorEq.v @@ -0,0 +1,80 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* A -> bool). + Hypothesis A_eqb_eq: forall x y, A_beq x y = true <-> x = y. + + Definition eqb: + forall {m n} (v1: t A m) (v2: t A n), bool := + fix fix_beq {m n} v1 v2 := + match v1, v2 with + |[], [] => true + |_ :: _, [] |[], _ :: _ => false + |h1 :: t1, h2 :: t2 => A_beq h1 h2 && fix_beq t1 t2 + end%bool. + + Lemma eqb_nat_eq: forall m n (v1: t A m) (v2: t A n) + (Hbeq: eqb v1 v2 = true), m = n. + Proof. + intros m n v1; revert n. + induction v1; destruct v2; + [now constructor | discriminate | discriminate | simpl]. + intros Hbeq; apply andb_prop in Hbeq; destruct Hbeq. + f_equal; eauto. + Qed. + + Lemma eqb_eq: forall n (v1: t A n) (v2: t A n), + eqb v1 v2 = true <-> v1 = v2. + Proof. + refine (@rect2 _ _ _ _ _); [now constructor | simpl]. + intros ? ? ? Hrec h1 h2; destruct Hrec; destruct (A_eqb_eq h1 h2); split. + + intros Hbeq. apply andb_prop in Hbeq; destruct Hbeq. + f_equal; now auto. + + intros Heq. destruct (cons_inj Heq). apply andb_true_intro. + split; now auto. + Qed. + + Definition eq_dec n (v1 v2: t A n): {v1 = v2} + {v1 <> v2}. + Proof. + case_eq (eqb v1 v2); intros. + + left; now apply eqb_eq. + + right. intros Heq. apply <- eqb_eq in Heq. congruence. + Defined. + +End BEQ. + +Section CAST. + + Definition cast: forall {A m} (v: t A m) {n}, m = n -> t A n. + Proof. + refine (fix cast {A m} (v: t A m) {struct v} := + match v in t _ m' return forall n, m' = n -> t A n with + |[] => fun n => match n with + | 0 => fun _ => [] + | S _ => fun H => False_rect _ _ + end + |h :: w => fun n => match n with + | 0 => fun H => False_rect _ _ + | S n' => fun H => h :: (cast w n' (f_equal pred H)) + end + end); discriminate. + Defined. + +End CAST. diff --git a/theories/Vectors/VectorSpec.v b/theories/Vectors/VectorSpec.v index 2f4086e5..7f4228dd 100644 --- a/theories/Vectors/VectorSpec.v +++ b/theories/Vectors/VectorSpec.v @@ -16,7 +16,7 @@ Require Fin. Require Import VectorDef. Import VectorNotations. -Definition cons_inj A a1 a2 n (v1 v2 : t A n) +Definition cons_inj {A} {a1 a2} {n} {v1 v2 : t A n} (eq : a1 :: v1 = a2 :: v2) : a1 = a2 /\ v1 = v2 := match eq in _ = x return caseS _ (fun a2' _ v2' => fun v1' => a1 = a2' /\ v1' = v2') x v1 with | eq_refl => conj eq_refl eq_refl @@ -59,15 +59,15 @@ Qed. Lemma shiftrepeat_nth A: forall n k (v: t A (S n)), nth (shiftrepeat v) (Fin.L_R 1 k) = nth v k. Proof. -refine (@Fin.rectS _ _ _); intros. +refine (@Fin.rectS _ _ _); lazy beta; [ intros n v | intros n p H v ]. revert n v; refine (@caseS _ _ _); simpl; intros. now destruct t. revert p H. - refine (match v as v' in t _ m return match m as m' return t A m' -> Type with + refine (match v as v' in t _ m return match m as m' return t A m' -> Prop with |S (S n) => fun v => forall p : Fin.t (S n), (forall v0 : t A (S n), (shiftrepeat v0) [@ Fin.L_R 1 p ] = v0 [@p]) -> (shiftrepeat v) [@Fin.L_R 1 (Fin.FS p)] = v [@Fin.FS p] - |_ => fun _ => @ID end v' with - |[] => @id |h :: t => _ end). destruct n0. exact @id. now simpl. + |_ => fun _ => True end v' with + |[] => I |h :: t => _ end). destruct n0. exact I. now simpl. Qed. Lemma shiftrepeat_last A: forall n (v: t A (S n)), last (shiftrepeat v) = last v. @@ -105,7 +105,7 @@ Proof. assert (forall n h (v: t B n) a, fold_left f (f a h) v = f (fold_left f a v) h). induction v0. now simpl. - intros; simpl. rewrite<- IHv0. now f_equal. + intros; simpl. rewrite<- IHv0, assoc. now f_equal. induction v. reflexivity. simpl. intros; now rewrite<- (IHv). diff --git a/theories/Vectors/vo.itarget b/theories/Vectors/vo.itarget index 7f00d016..779b1821 100644 --- a/theories/Vectors/vo.itarget +++ b/theories/Vectors/vo.itarget @@ -1,4 +1,5 @@ Fin.vo VectorDef.vo VectorSpec.vo +VectorEq.vo Vector.vo diff --git a/theories/Wellfounded/Disjoint_Union.v b/theories/Wellfounded/Disjoint_Union.v index c1a5f1b2..ee4329bd 100644 --- a/theories/Wellfounded/Disjoint_Union.v +++ b/theories/Wellfounded/Disjoint_Union.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* A -> Prop. @@ -25,14 +28,11 @@ Section Wf_Lexicographic_Exponentiation. Notation Descl := (Desc A leA). Notation List := (list A). - Notation Nil := (nil (A:=A)). - (* useless but symmetric *) - Notation Cons := (cons (A:=A)). Notation "<< x , y >>" := (exist Descl x y) (at level 0, x, y at level 100). (* Hint Resolve d_one d_nil t_step. *) - Lemma left_prefix : forall x y z:List, ltl (x ++ y) z -> ltl x z. + Lemma left_prefix : forall x y z : List, ltl (x ++ y) z -> ltl x z. Proof. simple induction x. simple induction z. @@ -50,8 +50,9 @@ Section Wf_Lexicographic_Exponentiation. Lemma right_prefix : - forall x y z:List, - ltl x (y ++ z) -> ltl x y \/ (exists y' : List, x = y ++ y' /\ ltl y' z). + forall x y z : List, + ltl x (y ++ z) -> + ltl x y \/ (exists y' : List, x = y ++ y' /\ ltl y' z). Proof. intros x y; generalize x. elim y; simpl. @@ -70,172 +71,98 @@ Section Wf_Lexicographic_Exponentiation. right; exists x2; auto with sets. Qed. - Lemma desc_prefix : forall (x:List) (a:A), Descl (x ++ Cons a Nil) -> Descl x. + Lemma desc_prefix : forall (x : List) (a : A), Descl (x ++ [a]) -> Descl x. Proof. intros. inversion H. - generalize (app_cons_not_nil _ _ _ H1); simple induction 1. - cut (x ++ Cons a Nil = Cons x0 Nil); auto with sets. - intro. - generalize (app_eq_unit _ _ H0). - simple induction 1; simple induction 1; intros. - rewrite H4; auto using d_nil with sets. - discriminate H5. - generalize (app_inj_tail _ _ _ _ H0). - simple induction 1; intros. - rewrite <- H4; auto with sets. + - apply app_cons_not_nil in H1 as (). + - assert (x ++ [a] = [x0]) by auto with sets. + apply app_eq_unit in H0 as [(->, _)| (_, [=])]. + auto using d_nil. + - apply app_inj_tail in H0 as (<-, _). + assumption. Qed. Lemma desc_tail : - forall (x:List) (a b:A), - Descl (Cons b (x ++ Cons a Nil)) -> clos_trans A leA a b. + forall (x : List) (a b : A), + Descl (b :: x ++ [a]) -> clos_refl_trans A leA a b. Proof. intro. apply rev_ind with - (A := A) - (P := fun x:List => - forall a b:A, - Descl (Cons b (x ++ Cons a Nil)) -> clos_trans A leA a b). - intros. - - inversion H. - cut (Cons b (Cons a Nil) = (Nil ++ Cons b Nil) ++ Cons a Nil); - auto with sets; intro. - generalize H0. - intro. - generalize (app_inj_tail (l ++ Cons y Nil) (Nil ++ Cons b Nil) _ _ H4); - simple induction 1. - intros. - - generalize (app_inj_tail _ _ _ _ H6); simple induction 1; intros. - generalize H1. - rewrite <- H10; rewrite <- H7; intro. - apply (t_step A leA); auto with sets. - - intros. - inversion H0. - generalize (app_cons_not_nil _ _ _ H3); intro. - elim H1. - - generalize H0. - generalize (app_comm_cons (l ++ Cons x0 Nil) (Cons a Nil) b); - simple induction 1. - intro. - generalize (desc_prefix (Cons b (l ++ Cons x0 Nil)) a H5); intro. - generalize (H x0 b H6). - intro. - apply t_trans with (A := A) (y := x0); auto with sets. - - apply t_step. - generalize H1. - rewrite H4; intro. - - generalize (app_inj_tail _ _ _ _ H8); simple induction 1. - intros. - generalize H2; generalize (app_comm_cons l (Cons x0 Nil) b). - intro. - generalize H10. - rewrite H12; intro. - generalize (app_inj_tail _ _ _ _ H13); simple induction 1. - intros. - rewrite <- H11; rewrite <- H16; auto with sets. + (P := + fun x : List => + forall a b : A, Descl (b :: x ++ [a]) -> clos_refl_trans A leA a b); + intros. + - inversion H. + assert ([b; a] = ([] ++ [b]) ++ [a]) by auto with sets. + destruct (app_inj_tail (l ++ [y]) ([] ++ [b]) _ _ H0) as ((?, <-)/app_inj_tail, <-). + inversion H1; subst; [ apply rt_step; assumption | apply rt_refl ]. + - inversion H0. + + apply app_cons_not_nil in H3 as (). + + rewrite app_comm_cons in H0, H1. apply desc_prefix in H0. + pose proof (H x0 b H0). + apply rt_trans with (y := x0); auto with sets. + enough (H5 : clos_refl A leA a x0) + by (inversion H5; subst; [ apply rt_step | apply rt_refl ]; + assumption). + apply app_inj_tail in H1 as (H1, ->). + rewrite app_comm_cons in H1. + apply app_inj_tail in H1 as (_, <-). + assumption. Qed. Lemma dist_aux : - forall z:List, Descl z -> forall x y:List, z = x ++ y -> Descl x /\ Descl y. + forall z : List, + Descl z -> forall x y : List, z = x ++ y -> Descl x /\ Descl y. Proof. intros z D. - elim D. - intros. - cut (x ++ y = Nil); auto with sets; intro. - generalize (app_eq_nil _ _ H0); simple induction 1. - intros. - rewrite H2; rewrite H3; split; apply d_nil. - - intros. - cut (x0 ++ y = Cons x Nil); auto with sets. - intros E. - generalize (app_eq_unit _ _ E); simple induction 1. - simple induction 1; intros. - rewrite H2; rewrite H3; split. - apply d_nil. - - apply d_one. - - simple induction 1; intros. - rewrite H2; rewrite H3; split. - apply d_one. - - apply d_nil. - - do 5 intro. - intros Hind. - do 2 intro. - generalize x0. - apply rev_ind with - (A := A) - (P := fun y0:List => - forall x0:List, - (l ++ Cons y Nil) ++ Cons x Nil = x0 ++ y0 -> - Descl x0 /\ Descl y0). - - intro. - generalize (app_nil_end x1); simple induction 1; simple induction 1. - split. apply d_conc; auto with sets. - - apply d_nil. - - do 3 intro. - generalize x1. - apply rev_ind with - (A := A) - (P := fun l0:List => - forall (x1:A) (x0:List), - (l ++ Cons y Nil) ++ Cons x Nil = x0 ++ l0 ++ Cons x1 Nil -> - Descl x0 /\ Descl (l0 ++ Cons x1 Nil)). - - - simpl. - split. - generalize (app_inj_tail _ _ _ _ H2); simple induction 1. - simple induction 1; auto with sets. - - apply d_one. - do 5 intro. - generalize (app_ass x4 (l1 ++ Cons x2 Nil) (Cons x3 Nil)). - simple induction 1. - generalize (app_ass x4 l1 (Cons x2 Nil)); simple induction 1. - intro E. - generalize (app_inj_tail _ _ _ _ E). - simple induction 1; intros. - generalize (app_inj_tail _ _ _ _ H6); simple induction 1; intros. - rewrite <- H7; rewrite <- H10; generalize H6. - generalize (app_ass x4 l1 (Cons x2 Nil)); intro E1. - rewrite E1. - intro. - generalize (Hind x4 (l1 ++ Cons x2 Nil) H11). - simple induction 1; split. - auto with sets. - - generalize H14. - rewrite <- H10; intro. - apply d_conc; auto with sets. + induction D as [| | * H D Hind]; intros. + - assert (H0 : x ++ y = []) by auto with sets. + apply app_eq_nil in H0 as (->, ->). + split; apply d_nil. + - assert (E : x0 ++ y = [x]) by auto with sets. + apply app_eq_unit in E as [(->, ->)| (->, ->)]. + + split. + apply d_nil. + apply d_one. + + split. + apply d_one. + apply d_nil. + - induction y0 using rev_ind in x0, H0 |- *. + + rewrite <- app_nil_end in H0. + rewrite <- H0. + split. + apply d_conc; auto with sets. + apply d_nil. + + induction y0 using rev_ind in x1, x0, H0 |- *. + * simpl. + split. + apply app_inj_tail in H0 as (<-, _). assumption. + apply d_one. + * rewrite <- 2!app_assoc_reverse in H0. + apply app_inj_tail in H0 as (H0, <-). + pose proof H0 as H0'. + apply app_inj_tail in H0' as (_, ->). + rewrite app_assoc_reverse in H0. + apply Hind in H0 as (). + split. + assumption. + apply d_conc; auto with sets. Qed. Lemma dist_Desc_concat : - forall x y:List, Descl (x ++ y) -> Descl x /\ Descl y. + forall x y : List, Descl (x ++ y) -> Descl x /\ Descl y. Proof. intros. apply (dist_aux (x ++ y) H x y); auto with sets. Qed. Lemma desc_end : - forall (a b:A) (x:List), - Descl (x ++ Cons a Nil) /\ ltl (x ++ Cons a Nil) (Cons b Nil) -> - clos_trans A leA a b. + forall (a b : A) (x : List), + Descl (x ++ [a]) /\ ltl (x ++ [a]) [b] -> clos_trans A leA a b. Proof. intros a b x. case x. @@ -246,11 +173,11 @@ Section Wf_Lexicographic_Exponentiation. inversion H3. simple induction 1. - generalize (app_comm_cons l (Cons a Nil) a0). + generalize (app_comm_cons l [a] a0). intros E; rewrite <- E; intros. generalize (desc_tail l a a0 H0); intro. inversion H1. - apply t_trans with (y := a0); auto with sets. + eapply clos_rt_t; [ eassumption | apply t_step; assumption ]. inversion H4. Qed. @@ -259,9 +186,8 @@ Section Wf_Lexicographic_Exponentiation. Lemma ltl_unit : - forall (x:List) (a b:A), - Descl (x ++ Cons a Nil) -> - ltl (x ++ Cons a Nil) (Cons b Nil) -> ltl x (Cons b Nil). + forall (x : List) (a b : A), + Descl (x ++ [a]) -> ltl (x ++ [a]) [b] -> ltl x [b]. Proof. intro. case x. @@ -276,9 +202,10 @@ Section Wf_Lexicographic_Exponentiation. Lemma acc_app : - forall (x1 x2:List) (y1:Descl (x1 ++ x2)), + forall (x1 x2 : List) (y1 : Descl (x1 ++ x2)), Acc Lex_Exp << x1 ++ x2, y1 >> -> - forall (x:List) (y:Descl x), ltl x (x1 ++ x2) -> Acc Lex_Exp << x, y >>. + forall (x : List) (y : Descl x), + ltl x (x1 ++ x2) -> Acc Lex_Exp << x, y >>. Proof. intros. apply (Acc_inv (R:=Lex_Exp) (x:=<< x1 ++ x2, y1 >>)). @@ -297,8 +224,10 @@ Section Wf_Lexicographic_Exponentiation. unfold lex_exp at 1; simpl. apply rev_ind with (A := A) - (P := fun x:List => - forall (x0:List) (y:Descl x0), ltl x0 x -> Acc Lex_Exp << x0, y >>). + (P := + fun x : List => + forall (x0 : List) (y : Descl x0), + ltl x0 x -> Acc Lex_Exp << x0, y >>). intros. inversion_clear H0. @@ -306,14 +235,15 @@ Section Wf_Lexicographic_Exponentiation. generalize (well_founded_ind (wf_clos_trans A leA H)). intros GR. apply GR with - (P := fun x0:A => - forall l:List, - (forall (x1:List) (y:Descl x1), - ltl x1 l -> Acc Lex_Exp << x1, y >>) -> - forall (x1:List) (y:Descl x1), - ltl x1 (l ++ Cons x0 Nil) -> Acc Lex_Exp << x1, y >>). + (P := + fun x0 : A => + forall l : List, + (forall (x1 : List) (y : Descl x1), + ltl x1 l -> Acc Lex_Exp << x1, y >>) -> + forall (x1 : List) (y : Descl x1), + ltl x1 (l ++ [x0]) -> Acc Lex_Exp << x1, y >>). intro; intros HInd; intros. - generalize (right_prefix x2 l (Cons x1 Nil) H1). + generalize (right_prefix x2 l [x1] H1). simple induction 1. intro; apply (H0 x2 y1 H3). @@ -324,9 +254,10 @@ Section Wf_Lexicographic_Exponentiation. rewrite H2. apply rev_ind with (A := A) - (P := fun x3:List => - forall y1:Descl (l ++ x3), - ltl x3 (Cons x1 Nil) -> Acc Lex_Exp << l ++ x3, y1 >>). + (P := + fun x3 : List => + forall y1 : Descl (l ++ x3), + ltl x3 [x1] -> Acc Lex_Exp << l ++ x3, y1 >>). intros. generalize (app_nil_end l); intros Heq. generalize y1. @@ -340,15 +271,15 @@ Section Wf_Lexicographic_Exponentiation. apply (H0 x4 y3); auto with sets. intros. - generalize (dist_Desc_concat l (l0 ++ Cons x4 Nil) y1). + generalize (dist_Desc_concat l (l0 ++ [x4]) y1). simple induction 1. intros. generalize (desc_end x4 x1 l0 (conj H8 H5)); intros. generalize y1. - rewrite <- (app_ass l l0 (Cons x4 Nil)); intro. + rewrite <- (app_assoc_reverse l l0 [x4]); intro. generalize (HInd x4 H9 (l ++ l0)); intros HInd2. generalize (ltl_unit l0 x4 x1 H8 H5); intro. - generalize (dist_Desc_concat (l ++ l0) (Cons x4 Nil) y2). + generalize (dist_Desc_concat (l ++ l0) [x4] y2). simple induction 1; intros. generalize (H4 H12 H10); intro. generalize (Acc_inv H14). diff --git a/theories/Wellfounded/Lexicographic_Product.v b/theories/Wellfounded/Lexicographic_Product.v index 7e3035d0..0d8ed8dd 100644 --- a/theories/Wellfounded/Lexicographic_Product.v +++ b/theories/Wellfounded/Lexicographic_Product.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* eq) succ := _. +Program Definition pred_wd : Proper (eq==>eq) pred := _. +Program Definition opp_wd : Proper (eq==>eq) opp := _. +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 quot_wd : Proper (eq==>eq==>eq) quot := _. +Program Definition rem_wd : Proper (eq==>eq==>eq) rem := _. +Program Definition pow_wd : Proper (eq==>eq==>eq) pow := _. +Program Definition testbit_wd : Proper (eq==>eq==>Logic.eq) testbit := _. + (** * Properties of [pos_sub] *) (** [pos_sub] can be written in term of positive comparison @@ -138,15 +155,23 @@ Qed. Module Import Private_BootStrap. -(** * Properties of addition *) - -(** ** Zero is neutral for addition *) +(** ** Operations and constants *) Lemma add_0_r n : n + 0 = n. Proof. now destruct n. Qed. +Lemma mul_0_r n : n * 0 = 0. +Proof. + now destruct n. +Qed. + +Lemma mul_1_l n : 1 * n = n. +Proof. + now destruct n. +Qed. + (** ** Addition is commutative *) Lemma add_comm n m : n + m = m + n. @@ -196,28 +221,25 @@ Proof. symmetry. now apply Pos.add_sub_assoc. Qed. -Lemma add_assoc n m p : n + (m + p) = n + m + p. +Local Arguments add !x !y. + +Lemma add_assoc_pos p n m : pos p + (n + m) = pos p + n + m. Proof. - assert (AUX : forall x y z, pos x + (y + z) = pos x + y + z). - { intros x [|y|y] [|z|z]; rewrite ?add_0_r; trivial. - - simpl. now rewrite Pos.add_assoc. - - simpl (_ + neg _). symmetry. apply pos_sub_add. - - simpl (neg _ + _); simpl (_ + neg _). - now rewrite (add_comm _ (pos _)), <- 2 pos_sub_add, Pos.add_comm. - - apply opp_inj. rewrite !opp_add_distr. simpl opp. - simpl (neg _ + _); simpl (_ + neg _). - rewrite add_comm, Pos.add_comm. apply pos_sub_add. } - destruct n. - - trivial. - - apply AUX. - - apply opp_inj. rewrite !opp_add_distr. simpl opp. apply AUX. + destruct n as [|n|n], m as [|m|m]; simpl; trivial. + - now rewrite Pos.add_assoc. + - symmetry. apply pos_sub_add. + - symmetry. apply add_0_r. + - now rewrite <- pos_sub_add, add_comm, <- pos_sub_add, Pos.add_comm. + - apply opp_inj. rewrite !opp_add_distr, !pos_sub_opp. + rewrite add_comm, Pos.add_comm. apply pos_sub_add. Qed. -(** ** Subtraction and successor *) - -Lemma sub_succ_l n m : succ n - m = succ (n - m). +Lemma add_assoc n m p : n + (m + p) = n + m + p. Proof. - unfold sub, succ. now rewrite <- 2 add_assoc, (add_comm 1). + destruct n. + - trivial. + - apply add_assoc_pos. + - apply opp_inj. rewrite !opp_add_distr. simpl. apply add_assoc_pos. Qed. (** ** Opposite is inverse for addition *) @@ -227,132 +249,34 @@ Proof. destruct n; simpl; trivial; now rewrite pos_sub_diag. Qed. -Lemma add_opp_diag_l n : - n + n = 0. -Proof. - rewrite add_comm. apply add_opp_diag_r. -Qed. - -(** ** Commutativity of multiplication *) - -Lemma mul_comm n m : n * m = m * n. -Proof. - destruct n, m; simpl; trivial; f_equal; apply Pos.mul_comm. -Qed. - -(** ** Associativity of multiplication *) - -Lemma mul_assoc n m p : n * (m * p) = n * m * p. -Proof. - destruct n, m, p; simpl; trivial; f_equal; apply Pos.mul_assoc. -Qed. - -(** Multiplication and constants *) - -Lemma mul_1_l n : 1 * n = n. -Proof. - now destruct n. -Qed. - -Lemma mul_1_r n : n * 1 = n. -Proof. - destruct n; simpl; now rewrite ?Pos.mul_1_r. -Qed. - (** ** Multiplication and Opposite *) -Lemma mul_opp_l n m : - n * m = - (n * m). -Proof. - now destruct n, m. -Qed. - Lemma mul_opp_r n m : n * - m = - (n * m). Proof. now destruct n, m. Qed. -Lemma mul_opp_opp n m : - n * - m = n * m. -Proof. - now destruct n, m. -Qed. - -Lemma mul_opp_comm n m : - n * m = n * - m. -Proof. - now destruct n, m. -Qed. - (** ** Distributivity of multiplication over addition *) Lemma mul_add_distr_pos (p:positive) n m : - pos p * (n + m) = pos p * n + pos p * m. -Proof. - destruct n as [|n|n], m as [|m|m]; simpl; trivial; - rewrite ?pos_sub_spec, ?Pos.mul_compare_mono_l; try case Pos.compare_spec; - intros; now rewrite ?Pos.mul_add_distr_l, ?Pos.mul_sub_distr_l. -Qed. - -Lemma mul_add_distr_l n m p : n * (m + p) = n * m + n * p. + (n + m) * pos p = n * pos p + m * pos p. Proof. - destruct n as [|n|n]. trivial. - apply mul_add_distr_pos. - change (neg n) with (- pos n). - rewrite !mul_opp_l, <- opp_add_distr. f_equal. - apply mul_add_distr_pos. + destruct n as [|n|n], m as [|m|m]; simpl; trivial. + - now rewrite Pos.mul_add_distr_r. + - rewrite ?pos_sub_spec, ?Pos.mul_compare_mono_r; case Pos.compare_spec; + simpl; trivial; intros; now rewrite Pos.mul_sub_distr_r. + - rewrite ?pos_sub_spec, ?Pos.mul_compare_mono_r; case Pos.compare_spec; + simpl; trivial; intros; now rewrite Pos.mul_sub_distr_r. + - now rewrite Pos.mul_add_distr_r. Qed. Lemma mul_add_distr_r n m p : (n + m) * p = n * p + m * p. Proof. - rewrite !(mul_comm _ p). apply mul_add_distr_l. -Qed. - -(** ** Basic properties of divisibility *) - -Lemma divide_Zpos p q : (pos p|pos q) <-> (p|q)%positive. -Proof. - split. - intros ([ |r|r],H); simpl in *; destr_eq H. exists r; auto. - intros (r,H). exists (pos r); simpl; now f_equal. -Qed. - -Lemma divide_Zpos_Zneg_r n p : (n|pos p) <-> (n|neg p). -Proof. - split; intros (m,H); exists (-m); now rewrite mul_opp_l, <- H. -Qed. - -Lemma divide_Zpos_Zneg_l n p : (pos p|n) <-> (neg p|n). -Proof. - split; intros (m,H); exists (-m); now rewrite mul_opp_l, <- mul_opp_r. -Qed. - -(** ** Conversions between [Z.testbit] and [N.testbit] *) - -Lemma testbit_of_N a n : - testbit (of_N a) (of_N n) = N.testbit a n. -Proof. - destruct a as [|a], n; simpl; trivial. now destruct a. -Qed. - -Lemma testbit_of_N' a n : 0<=n -> - testbit (of_N a) n = N.testbit a (to_N n). -Proof. - intro Hn. rewrite <- testbit_of_N. f_equal. - destruct n; trivial; now destruct Hn. -Qed. - -Lemma testbit_Zpos a n : 0<=n -> - testbit (pos a) n = N.testbit (N.pos a) (to_N n). -Proof. - intro Hn. now rewrite <- testbit_of_N'. -Qed. - -Lemma testbit_Zneg a n : 0<=n -> - testbit (neg a) n = negb (N.testbit (Pos.pred_N a) (to_N n)). -Proof. - intro Hn. - rewrite <- testbit_of_N' by trivial. - destruct n as [ |n|n]; - [ | simpl; now destruct (Pos.pred_N a) | now destruct Hn]. - unfold testbit. - now destruct a as [|[ | | ]| ]. + destruct p as [|p|p]. + - now rewrite !mul_0_r. + - apply mul_add_distr_pos. + - apply opp_inj. rewrite opp_add_distr, <- !mul_opp_r. + apply mul_add_distr_pos. Qed. End Private_BootStrap. @@ -397,6 +321,8 @@ Qed. (** ** Specification of successor and predecessor *) +Local Arguments pos_sub : simpl nomatch. + Lemma succ_pred n : succ (pred n) = n. Proof. unfold succ, pred. now rewrite <- add_assoc, add_opp_diag_r, add_0_r. @@ -511,6 +437,45 @@ Proof. rewrite (compare_antisym n m). case compare_spec; intuition. Qed. +(** ** Induction principles based on successor / predecessor *) + +Lemma peano_ind (P : Z -> Prop) : + P 0 -> + (forall x, P x -> P (succ x)) -> + (forall x, P x -> P (pred x)) -> + forall z, P z. +Proof. + intros H0 Hs Hp z; destruct z. + assumption. + induction p using Pos.peano_ind. + now apply (Hs 0). + rewrite <- Pos.add_1_r. + now apply (Hs (pos p)). + induction p using Pos.peano_ind. + now apply (Hp 0). + rewrite <- Pos.add_1_r. + now apply (Hp (neg p)). +Qed. + +Lemma bi_induction (P : Z -> Prop) : + Proper (eq ==> iff) P -> + P 0 -> + (forall x, P x <-> P (succ x)) -> + forall z, P z. +Proof. + intros _ H0 Hs. induction z using peano_ind. + assumption. + now apply -> Hs. + apply Hs. now rewrite succ_pred. +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 ZBasicProp <+ UsualMinMaxLogicalProperties <+ UsualMinMaxDecProperties. + + (** ** Specification of absolute value *) Lemma abs_eq n : 0 <= n -> abs n = n. @@ -693,7 +658,7 @@ Lemma div_eucl_eq a b : b<>0 -> Proof. destruct a as [ |a|a], b as [ |b|b]; unfold div_eucl; trivial; (now destruct 1) || intros _; - generalize (pos_div_eucl_eq a (pos b) (eq_refl _)); + generalize (pos_div_eucl_eq a (pos b) Logic.eq_refl); destruct pos_div_eucl as (q,r); rewrite mul_comm. - (* pos pos *) trivial. @@ -756,7 +721,7 @@ Proof. destruct a as [|a|a]; unfold modulo, div_eucl. now split. now apply pos_div_eucl_bound. - generalize (pos_div_eucl_bound a (pos b) (eq_refl _)). + generalize (pos_div_eucl_bound a (pos b) Logic.eq_refl). destruct pos_div_eucl as (q,r); unfold snd; intros (Hr,Hr'). destruct r as [|r|r]; (now destruct Hr) || clear Hr. now split. @@ -773,7 +738,7 @@ Proof. destruct b as [|b|b]; try easy; intros _. destruct a as [|a|a]; unfold modulo, div_eucl. now split. - generalize (pos_div_eucl_bound a (pos b) (eq_refl _)). + generalize (pos_div_eucl_bound a (pos b) Logic.eq_refl). destruct pos_div_eucl as (q,r); unfold snd; intros (Hr,Hr'). destruct r as [|r|r]; (now destruct Hr) || clear Hr. now split. @@ -783,7 +748,7 @@ Proof. change (neg b - neg r <= 0). unfold le, lt in *. rewrite <- compare_sub. simpl in *. now rewrite <- Pos.compare_antisym, Hr'. - generalize (pos_div_eucl_bound a (pos b) (eq_refl _)). + generalize (pos_div_eucl_bound a (pos b) Logic.eq_refl). destruct pos_div_eucl as (q,r); unfold snd; intros (Hr,Hr'). split; destruct r; try easy. red; simpl; now rewrite <- Pos.compare_antisym. @@ -839,6 +804,25 @@ Proof. intros _. apply rem_opp_l'. Qed. Lemma rem_opp_r a b : b<>0 -> rem a (-b) = rem a b. Proof. intros _. apply rem_opp_r'. Qed. +(** ** Extra properties about [divide] *) + +Lemma divide_Zpos p q : (pos p|pos q) <-> (p|q)%positive. +Proof. + split. + intros ([ |r|r],H); simpl in *; destr_eq H. exists r; auto. + intros (r,H). exists (pos r); simpl; now f_equal. +Qed. + +Lemma divide_Zpos_Zneg_r n p : (n|pos p) <-> (n|neg p). +Proof. + split; intros (m,H); exists (-m); now rewrite mul_opp_l, <- H. +Qed. + +Lemma divide_Zpos_Zneg_l n p : (pos p|n) <-> (neg p|n). +Proof. + split; intros (m,H); exists (-m); now rewrite mul_opp_l, <- mul_opp_r. +Qed. + (** ** Correctness proofs for gcd *) Lemma ggcd_gcd a b : fst (ggcd a b) = gcd a b. @@ -898,6 +882,38 @@ Proof. destruct (Pos.ggcd a b) as (g,(aa,bb)); auto. Qed. +(** ** Extra properties about [testbit] *) + +Lemma testbit_of_N a n : + testbit (of_N a) (of_N n) = N.testbit a n. +Proof. + destruct a as [|a], n; simpl; trivial. now destruct a. +Qed. + +Lemma testbit_of_N' a n : 0<=n -> + testbit (of_N a) n = N.testbit a (to_N n). +Proof. + intro Hn. rewrite <- testbit_of_N. f_equal. + destruct n; trivial; now destruct Hn. +Qed. + +Lemma testbit_Zpos a n : 0<=n -> + testbit (pos a) n = N.testbit (N.pos a) (to_N n). +Proof. + intro Hn. now rewrite <- testbit_of_N'. +Qed. + +Lemma testbit_Zneg a n : 0<=n -> + testbit (neg a) n = negb (N.testbit (Pos.pred_N a) (to_N n)). +Proof. + intro Hn. + rewrite <- testbit_of_N' by trivial. + destruct n as [ |n|n]; + [ | simpl; now destruct (Pos.pred_N a) | now destruct Hn]. + unfold testbit. + now destruct a as [|[ | | ]| ]. +Qed. + (** ** Proofs of specifications for bitwise operations *) Lemma div2_spec a : div2 a = shiftr a 1. @@ -959,7 +975,7 @@ Proof. destruct m; easy || now destruct Hm. destruct a as [ |a|a]. (* a = 0 *) - replace (Pos.iter n div2 0) with 0 + replace (Pos.iter div2 0 n) with 0 by (apply Pos.iter_invariant; intros; subst; trivial). now rewrite 2 testbit_0_l. (* a > 0 *) @@ -982,7 +998,7 @@ Proof. rewrite ?Pos.iter_succ; apply testbit_even_0. destruct a as [ |a|a]. (* a = 0 *) - replace (Pos.iter n (mul 2) 0) with 0 + replace (Pos.iter (mul 2) 0 n) with 0 by (apply Pos.iter_invariant; intros; subst; trivial). apply testbit_0_l. (* a > 0 *) @@ -1013,7 +1029,7 @@ Proof. f_equal. now rewrite Pos.add_comm, Pos.add_sub. destruct a; unfold shiftl. (* ... a = 0 *) - replace (Pos.iter n (mul 2) 0) with 0 + replace (Pos.iter (mul 2) 0 n) with 0 by (apply Pos.iter_invariant; intros; subst; trivial). now rewrite 2 testbit_0_l. (* ... a > 0 *) @@ -1103,61 +1119,10 @@ Proof. now rewrite N.lxor_spec, xorb_negb_negb. Qed. -(** ** Induction principles based on successor / predecessor *) -Lemma peano_ind (P : Z -> Prop) : - P 0 -> - (forall x, P x -> P (succ x)) -> - (forall x, P x -> P (pred x)) -> - forall z, P z. -Proof. - intros H0 Hs Hp z; destruct z. - assumption. - induction p using Pos.peano_ind. - now apply (Hs 0). - rewrite <- Pos.add_1_r. - now apply (Hs (pos p)). - induction p using Pos.peano_ind. - now apply (Hp 0). - rewrite <- Pos.add_1_r. - now apply (Hp (neg p)). -Qed. +(** Generic properties of advanced functions. *) -Lemma bi_induction (P : Z -> Prop) : - Proper (eq ==> iff) P -> - P 0 -> - (forall x, P x <-> P (succ x)) -> - forall z, P z. -Proof. - intros _ H0 Hs. induction z using peano_ind. - assumption. - now apply -> Hs. - apply Hs. now rewrite succ_pred. -Qed. - - -(** * 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 opp_wd : Proper (eq==>eq) opp := _. -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 quot_wd : Proper (eq==>eq==>eq) quot := _. -Program Definition rem_wd : Proper (eq==>eq==>eq) rem := _. -Program Definition pow_wd : Proper (eq==>eq==>eq) pow := _. -Program Definition testbit_wd : Proper (eq==>eq==>Logic.eq) testbit := _. - -(** The Bind Scope prevents Z to stay associated with abstract_scope. - (TODO FIX) *) - -Include ZProp. Bind Scope Z_scope with Z. -Include UsualMinMaxLogicalProperties <+ UsualMinMaxDecProperties. +Include ZExtraProp. (** In generic statements, the predicates [lt] and [le] have been favored, whereas [gt] and [ge] don't even exist in the abstract @@ -1277,6 +1242,8 @@ Qed. End Z. +Bind Scope Z_scope with Z.t Z. + (** Re-export Notations *) Infix "+" := Z.add : Z_scope. @@ -1394,11 +1361,11 @@ Lemma inj_gcd p q : Z.pos (Pos.gcd p q) = Z.gcd (Z.pos p) (Z.pos q). Proof. reflexivity. Qed. Definition inj_divide p q : (Z.pos p|Z.pos q) <-> (p|q)%positive. -Proof. apply Z.Private_BootStrap.divide_Zpos. Qed. +Proof. apply Z.divide_Zpos. Qed. Lemma inj_testbit a n : 0<=n -> Z.testbit (Z.pos a) n = N.testbit (N.pos a) (Z.to_N n). -Proof. apply Z.Private_BootStrap.testbit_Zpos. Qed. +Proof. apply Z.testbit_Zpos. Qed. (** Some results concerning Z.neg *) @@ -1436,14 +1403,14 @@ Lemma add_neg_pos p q : Z.neg p + Z.pos q = Z.pos_sub q p. Proof. reflexivity. Qed. Lemma divide_pos_neg_r n p : (n|Z.pos p) <-> (n|Z.neg p). -Proof. apply Z.Private_BootStrap.divide_Zpos_Zneg_r. Qed. +Proof. apply Z.divide_Zpos_Zneg_r. Qed. Lemma divide_pos_neg_l n p : (Z.pos p|n) <-> (Z.neg p|n). -Proof. apply Z.Private_BootStrap.divide_Zpos_Zneg_l. Qed. +Proof. apply Z.divide_Zpos_Zneg_l. Qed. Lemma testbit_neg a n : 0<=n -> Z.testbit (Z.neg a) n = negb (N.testbit (Pos.pred_N a) (Z.to_N n)). -Proof. apply Z.Private_BootStrap.testbit_Zneg. Qed. +Proof. apply Z.testbit_Zneg. Qed. End Pos2Z. diff --git a/theories/ZArith/BinIntDef.v b/theories/ZArith/BinIntDef.v index 00387eec..9bb86fd5 100644 --- a/theories/ZArith/BinIntDef.v +++ b/theories/ZArith/BinIntDef.v @@ -1,7 +1,7 @@ (* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* A) (x:A) := match n with - | pos p => Pos.iter p f x + | pos p => Pos.iter f x p | _ => x end. @@ -568,8 +568,8 @@ Definition testbit a n := Definition shiftl a n := match n with | 0 => a - | pos p => Pos.iter p (mul 2) a - | neg p => Pos.iter p div2 a + | pos p => Pos.iter (mul 2) a p + | neg p => Pos.iter div2 a p end. Definition shiftr a n := shiftl a (-n). diff --git a/theories/ZArith/Wf_Z.v b/theories/ZArith/Wf_Z.v index 5350f86d..09909bdb 100644 --- a/theories/ZArith/Wf_Z.v +++ b/theories/ZArith/Wf_Z.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* Prop, (forall x:Z, (forall y:Z, 0 <= y < x -> P y) -> 0 <= x -> P x) -> forall x:Z, 0 <= x -> P x. - Proof. - exact Zlt_0_rec. - Qed. + Proof. intros; now apply Zlt_0_rec. Qed. (** Obsolete version of [Z.lt] induction principle on non-negative numbers *) @@ -170,7 +168,7 @@ Section Efficient_Rec. (forall x:Z, (forall y:Z, 0 <= y < x -> P y) -> P x) -> forall x:Z, 0 <= x -> P x. Proof. - exact Z_lt_rec. + intros; now apply Z_lt_rec. Qed. (** An even more general induction principle using [Z.lt]. *) @@ -196,7 +194,7 @@ Section Efficient_Rec. (forall x:Z, (forall y:Z, z <= y < x -> P y) -> z <= x -> P x) -> forall x:Z, z <= x -> P x. Proof. - exact Zlt_lower_bound_rec. + intros; now apply Zlt_lower_bound_rec with z. Qed. End Efficient_Rec. diff --git a/theories/ZArith/ZArith.v b/theories/ZArith/ZArith.v index e9cac8e1..04cccd04 100644 --- a/theories/ZArith/ZArith.v +++ b/theories/ZArith/ZArith.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 0 <= z -> P z * P (- z)) in *. - cut (Q (Z.abs p)); [ intros | apply (Z_lt_rec Q); auto with zarith ]. - elim (Zabs_dec p); intro eq; rewrite eq; elim H; auto with zarith. - unfold Q; clear Q; intros. + set (Q := fun z => 0 <= z -> P z * P (- z)). + enough (H:Q (Z.abs p)) by + (destruct (Zabs_dec p) as [-> | ->]; elim H; auto with zarith). + apply (Z_lt_rec Q); auto with zarith. + subst Q; intros x H. split; apply HP. - rewrite Z.abs_eq; auto; intros. - elim (H (Z.abs m)); intros; auto with zarith. - elim (Zabs_dec m); intro eq; rewrite eq; trivial. - rewrite Z.abs_neq, Z.opp_involutive; auto with zarith; intros. - elim (H (Z.abs m)); intros; auto with zarith. - elim (Zabs_dec m); intro eq; rewrite eq; trivial. + - rewrite Z.abs_eq; auto; intros. + destruct (H (Z.abs m)); auto with zarith. + destruct (Zabs_dec m) as [-> | ->]; trivial. + - rewrite Z.abs_neq, Z.opp_involutive; auto with zarith; intros. + destruct (H (Z.abs m)); auto with zarith. + destruct (Zabs_dec m) as [-> | ->]; trivial. Qed. Theorem Z_lt_abs_induction : @@ -73,16 +74,17 @@ Theorem Z_lt_abs_induction : Proof. intros P HP p. set (Q := fun z => 0 <= z -> P z /\ P (- z)) in *. - cut (Q (Z.abs p)); [ intros | apply (Z_lt_induction Q); auto with zarith ]. - elim (Zabs_dec p); intro eq; rewrite eq; elim H; auto with zarith. - unfold Q; clear Q; intros. + enough (Q (Z.abs p)) by + (destruct (Zabs_dec p) as [-> | ->]; elim H; auto with zarith). + apply (Z_lt_induction Q); auto with zarith. + subst Q; intros. split; apply HP. - rewrite Z.abs_eq; auto; intros. - elim (H (Z.abs m)); intros; auto with zarith. - elim (Zabs_dec m); intro eq; rewrite eq; trivial. - rewrite Z.abs_neq, Z.opp_involutive; auto with zarith; intros. - elim (H (Z.abs m)); intros; auto with zarith. - elim (Zabs_dec m); intro eq; rewrite eq; trivial. + - rewrite Z.abs_eq; auto; intros. + elim (H (Z.abs m)); intros; auto with zarith. + elim (Zabs_dec m); intro eq; rewrite eq; trivial. + - rewrite Z.abs_neq, Z.opp_involutive; auto with zarith; intros. + destruct (H (Z.abs m)); auto with zarith. + destruct (Zabs_dec m) as [-> | ->]; trivial. Qed. (** To do case analysis over the sign of [z] *) diff --git a/theories/ZArith/Zdigits.v b/theories/ZArith/Zdigits.v index bf19c8ec..b5d04719 100644 --- a/theories/ZArith/Zdigits.v +++ b/theories/ZArith/Zdigits.v @@ -1,7 +1,7 @@ (* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* Z. Proof. - simple induction n; intros. + refine (nat_rect _ _ _); intros. exact 0%Z. inversion H0. @@ -152,7 +152,7 @@ Section Z_BRIC_A_BRAC. Lemma binary_value_pos : forall (n:nat) (bv:Bvector n), (binary_value n bv >= 0)%Z. Proof. - induction bv as [| a n v IHbv]; simpl. + induction bv as [| a n v IHbv]; cbn. omega. destruct a; destruct (binary_value n v); simpl; auto. @@ -212,14 +212,11 @@ Section Z_BRIC_A_BRAC. (z < two_power_nat (S n))%Z -> (Z.div2 z < two_power_nat n)%Z. Proof. intros. - cut (2 * Z.div2 z < 2 * two_power_nat n)%Z; intros. - omega. - + enough (2 * Z.div2 z < 2 * two_power_nat n)%Z by omega. rewrite <- two_power_nat_S. - destruct (Zeven.Zeven_odd_dec z); intros. + destruct (Zeven.Zeven_odd_dec z) as [Heven|Hodd]; intros. rewrite <- Zeven.Zeven_div2; auto. - - generalize (Zeven.Zodd_div2 z z0); omega. + generalize (Zeven.Zodd_div2 z Hodd); omega. Qed. Lemma Z_to_two_compl_Sn_z : diff --git a/theories/ZArith/Zdiv.v b/theories/ZArith/Zdiv.v index 2e3a2280..d0d10891 100644 --- a/theories/ZArith/Zdiv.v +++ b/theories/ZArith/Zdiv.v @@ -1,7 +1,7 @@ (* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 0); [ intro Hb'' | omega ]. - rewrite Z.abs_eq; [ apply Zdiv_eucl_exist; assumption | assumption ]. - cut (- b > 0); [ intro Hb'' | omega ]. - elim (Zdiv_eucl_exist Hb'' a); intros qr. - elim qr; intros q r Hqr. - exists (- q, r). - elim Hqr; intros. - split. - rewrite <- Z.mul_opp_comm; assumption. - rewrite Z.abs_neq; [ assumption | omega ]. + destruct (Z_le_gt_dec 0 b) as [Hb'|Hb']. + - assert (Hb'' : b > 0) by omega. + rewrite Z.abs_eq; [ apply Zdiv_eucl_exist; assumption | assumption ]. + - assert (Hb'' : - b > 0) by omega. + destruct (Zdiv_eucl_exist Hb'' a) as ((q,r),[]). + exists (- q, r). + split. + + rewrite <- Z.mul_opp_comm; assumption. + + rewrite Z.abs_neq; [ assumption | omega ]. Qed. Arguments Zdiv_eucl_extended : default implicits. (** * Division and modulo in Z agree with same in nat: *) -Require Import NPeano. +Require Import PeanoNat. Lemma div_Zdiv (n m: nat): m <> O -> Z.of_nat (n / m) = Z.of_nat n / Z.of_nat m. diff --git a/theories/ZArith/Zeuclid.v b/theories/ZArith/Zeuclid.v index 39e846a0..f5cacc7e 100644 --- a/theories/ZArith/Zeuclid.v +++ b/theories/ZArith/Zeuclid.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* Z.quot2 m = m ÷ 2). - { intros m Hm. + { + intros m Hm. apply Z.quot_unique with (if Z.odd m then Z.sgn m else 0). now apply Z.lt_le_incl. rewrite Z.sgn_pos by trivial. destruct (Z.odd m); now split. - apply Zquot2_odd_eqn. } + apply Zquot2_odd_eqn. + } destruct (Z.lt_trichotomy 0 n) as [POS|[NUL|NEG]]. - now apply AUX. - now subst. diff --git a/theories/ZArith/Zgcd_alt.v b/theories/ZArith/Zgcd_alt.v index 1e19479e..14286bde 100644 --- a/theories/ZArith/Zgcd_alt.v +++ b/theories/ZArith/Zgcd_alt.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 0<=fibonacci n). - eauto. + enough (forall N n, (n 0<=fibonacci n) by eauto. induction N. inversion 1. intros. diff --git a/theories/ZArith/Zhints.v b/theories/ZArith/Zhints.v index 411fec67..1942c2ab 100644 --- a/theories/ZArith/Zhints.v +++ b/theories/ZArith/Zhints.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* Z.testbit (Z.of_N a) n = N.testbit a (Z.to_N n). -Proof. apply Z.Private_BootStrap.testbit_of_N'. Qed. +Proof. apply Z.testbit_of_N'. Qed. End Z2N. @@ -637,7 +637,7 @@ Qed. (** [Z.of_nat] and usual operations *) -Lemma inj_compare n m : (Z.of_nat n ?= Z.of_nat m) = nat_compare n m. +Lemma inj_compare n m : (Z.of_nat n ?= Z.of_nat m) = (n ?= m)%nat. Proof. now rewrite <-!nat_N_Z, N2Z.inj_compare, <- Nat2N.inj_compare. Qed. @@ -690,23 +690,23 @@ Proof. now rewrite <- !nat_N_Z, Nat2N.inj_sub, N2Z.inj_sub. Qed. -Lemma inj_pred_max n : Z.of_nat (pred n) = Z.max 0 (Z.pred (Z.of_nat n)). +Lemma inj_pred_max n : Z.of_nat (Nat.pred n) = Z.max 0 (Z.pred (Z.of_nat n)). Proof. now rewrite <- !nat_N_Z, Nat2N.inj_pred, N2Z.inj_pred_max. Qed. -Lemma inj_pred n : (0 Z.of_nat (pred n) = Z.pred (Z.of_nat n). +Lemma inj_pred n : (0 Z.of_nat (Nat.pred n) = Z.pred (Z.of_nat n). Proof. rewrite nat_compare_lt, Nat2N.inj_compare. intros. now rewrite <- !nat_N_Z, Nat2N.inj_pred, N2Z.inj_pred. Qed. -Lemma inj_min n m : Z.of_nat (min n m) = Z.min (Z.of_nat n) (Z.of_nat m). +Lemma inj_min n m : Z.of_nat (Nat.min n m) = Z.min (Z.of_nat n) (Z.of_nat m). Proof. now rewrite <- !nat_N_Z, Nat2N.inj_min, N2Z.inj_min. Qed. -Lemma inj_max n m : Z.of_nat (max n m) = Z.max (Z.of_nat n) (Z.of_nat m). +Lemma inj_max n m : Z.of_nat (Nat.max n m) = Z.max (Z.of_nat n) (Z.of_nat m). Proof. now rewrite <- !nat_N_Z, Nat2N.inj_max, N2Z.inj_max. Qed. @@ -777,13 +777,13 @@ Proof. intros. now rewrite <- !Z_N_nat, Z2N.inj_sub, N2Nat.inj_sub. Qed. -Lemma inj_pred n : Z.to_nat (Z.pred n) = pred (Z.to_nat n). +Lemma inj_pred n : Z.to_nat (Z.pred n) = Nat.pred (Z.to_nat n). Proof. now rewrite <- !Z_N_nat, Z2N.inj_pred, N2Nat.inj_pred. Qed. Lemma inj_compare n m : 0<=n -> 0<=m -> - nat_compare (Z.to_nat n) (Z.to_nat m) = (n ?= m). + (Z.to_nat n ?= Z.to_nat m)%nat = (n ?= m). Proof. intros Hn Hm. now rewrite <- Nat2Z.inj_compare, !id. Qed. @@ -798,12 +798,12 @@ Proof. intros Hn Hm. unfold Z.lt. now rewrite nat_compare_lt, inj_compare. Qed. -Lemma inj_min n m : Z.to_nat (Z.min n m) = min (Z.to_nat n) (Z.to_nat m). +Lemma inj_min n m : Z.to_nat (Z.min n m) = Nat.min (Z.to_nat n) (Z.to_nat m). Proof. now rewrite <- !Z_N_nat, Z2N.inj_min, N2Nat.inj_min. Qed. -Lemma inj_max n m : Z.to_nat (Z.max n m) = max (Z.to_nat n) (Z.to_nat m). +Lemma inj_max n m : Z.to_nat (Z.max n m) = Nat.max (Z.to_nat n) (Z.to_nat m). Proof. now rewrite <- !Z_N_nat, Z2N.inj_max, N2Nat.inj_max. Qed. @@ -876,13 +876,13 @@ Proof. intros. now rewrite <- !Zabs_N_nat, Zabs2N.inj_sub, N2Nat.inj_sub. Qed. -Lemma inj_pred n : 0 Z.abs_nat (Z.pred n) = pred (Z.abs_nat n). +Lemma inj_pred n : 0 Z.abs_nat (Z.pred n) = Nat.pred (Z.abs_nat n). Proof. intros. now rewrite <- !Zabs_N_nat, Zabs2N.inj_pred, N2Nat.inj_pred. Qed. Lemma inj_compare n m : 0<=n -> 0<=m -> - nat_compare (Z.abs_nat n) (Z.abs_nat m) = (n ?= m). + (Z.abs_nat n ?= Z.abs_nat m)%nat = (n ?= m). Proof. intros. now rewrite <- !Zabs_N_nat, <- N2Nat.inj_compare, Zabs2N.inj_compare. Qed. @@ -898,13 +898,13 @@ Proof. Qed. Lemma inj_min n m : 0<=n -> 0<=m -> - Z.abs_nat (Z.min n m) = min (Z.abs_nat n) (Z.abs_nat m). + Z.abs_nat (Z.min n m) = Nat.min (Z.abs_nat n) (Z.abs_nat m). Proof. intros. now rewrite <- !Zabs_N_nat, Zabs2N.inj_min, N2Nat.inj_min. Qed. Lemma inj_max n m : 0<=n -> 0<=m -> - Z.abs_nat (Z.max n m) = max (Z.abs_nat n) (Z.abs_nat m). + Z.abs_nat (Z.max n m) = Nat.max (Z.abs_nat n) (Z.abs_nat m). Proof. intros. now rewrite <- !Zabs_N_nat, Zabs2N.inj_max, N2Nat.inj_max. Qed. diff --git a/theories/ZArith/Znumtheory.v b/theories/ZArith/Znumtheory.v index 0f58f524..f69cf315 100644 --- a/theories/ZArith/Znumtheory.v +++ b/theories/ZArith/Znumtheory.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* forall a:Z, ~ (p | a) -> rel_prime p a. Proof. - simple induction 1; intros. - constructor; intuition. - elim (prime_divisors p H x H3); intuition; subst; auto with zarith. - absurd (p | a); auto with zarith. - absurd (p | a); intuition. + intros; constructor; intros; auto with zarith. + apply prime_divisors in H1; intuition; subst; auto with zarith. + - absurd (p | a); auto with zarith. + - absurd (p | a); intuition. Qed. Hint Resolve prime_rel_prime: zarith. diff --git a/theories/ZArith/Zorder.v b/theories/ZArith/Zorder.v index 39cf87fa..e090302e 100644 --- a/theories/ZArith/Zorder.v +++ b/theories/ZArith/Zorder.v @@ -1,7 +1,7 @@ (* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* - forall p k, Pos.iter p f k = (Pos.iter p f 1)*k. + 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 p f 1) in *. now rewrite !IHp, Hf, Z.mul_assoc. - - set (g := Pos.iter p f 1) in *. now rewrite !IHp, Z.mul_assoc. + - 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. diff --git a/theories/ZArith/Zpow_def.v b/theories/ZArith/Zpow_def.v index 2fbb70ba..740c45fd 100644 --- a/theories/ZArith/Zpow_def.v +++ b/theories/ZArith/Zpow_def.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 0 -> Zpow_mod a m n = (a ^ m) mod n. Proof. - intros Hn. destruct m; simpl. - - trivial. + intros Hn. destruct m; simpl; trivial. - apply Zpow_mod_pos_correct; auto with zarith. - - rewrite Z.mod_0_l; auto with zarith. Qed. (* Complements about power and number theory. *) diff --git a/theories/ZArith/Zpower.v b/theories/ZArith/Zpower.v index 27f0cfd2..747bd4fd 100644 --- a/theories/ZArith/Zpower.v +++ b/theories/ZArith/Zpower.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* Z.mul z). Lemma Zpower_nat_0_r z : Zpower_nat z 0 = 1. Proof. reflexivity. Qed. @@ -42,7 +42,7 @@ Lemma Zpower_nat_is_exp : Proof. induction n. - intros. now rewrite Zpower_nat_0_r, Z.mul_1_l. - - intros. simpl. now rewrite 2 Zpower_nat_succ_r, IHn, Z.mul_assoc. + - intros. simpl. now rewrite IHn, Z.mul_assoc. Qed. (** Conversions between powers of unary and binary integers *) @@ -94,12 +94,12 @@ Section Powers_of_2. 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_iter n xO z. - Definition shift_pos (n z:positive) := Pos.iter n xO z. + 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 p xO z + | Zpos p => Pos.iter xO z p | Zneg p => z end. @@ -154,7 +154,7 @@ Section Powers_of_2. Lemma shift_nat_plus n m x : shift_nat (n + m) x = shift_nat n (shift_nat m x). Proof. - apply iter_nat_plus. + induction n; simpl; now f_equal. Qed. Theorem shift_nat_correct n x : @@ -247,20 +247,20 @@ Section power_div_with_rest. end, 2 * d). Definition Zdiv_rest (x:Z) (p:positive) := - let (qr, d) := Pos.iter p Zdiv_rest_aux (x, 0, 1) in qr. + 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 p Zdiv_rest_aux (x, 0, 1) in + 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_iter n Zdiv_rest_aux (x,0,1)) as ((q,r),d). + 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 p Zdiv_rest_aux (x, 0, 1) in + 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; [|omega]. @@ -287,7 +287,7 @@ Section power_div_with_rest. 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 p Zdiv_rest_aux (x, 0, 1)) as ((q,r),d). + destruct (Pos.iter Zdiv_rest_aux (x, 0, 1) p) as ((q,r),d). intros (H1,(H2,H3)) ->. now exists q r. Qed. @@ -299,7 +299,7 @@ Section power_div_with_rest. Proof. unfold Zdiv_rest. generalize (Zdiv_rest_correct1 x p); generalize (Zdiv_rest_correct2 x p). - destruct (Pos.iter p Zdiv_rest_aux (x, 0, 1)) as ((q,r),d). + 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. diff --git a/theories/ZArith/Zquot.v b/theories/ZArith/Zquot.v index 7f064c2b..3ef11189 100644 --- a/theories/ZArith/Zquot.v +++ b/theories/ZArith/Zquot.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* c_sqrt 3 1 2 _ _ | xO (xO p') => match sqrtrempos p' with - | c_sqrt s' r' Heq Hint => + | c_sqrt _ s' r' Heq Hint => match Z_le_gt_dec (4 * s' + 1) (4 * r') with | left Hle => c_sqrt (Zpos (xO (xO p'))) (2 * s' + 1) @@ -63,7 +63,7 @@ Definition sqrtrempos : forall p:positive, sqrt_data (Zpos p). end | xO (xI p') => match sqrtrempos p' with - | c_sqrt s' r' Heq Hint => + | c_sqrt _ s' r' Heq Hint => match Z_le_gt_dec (4 * s' + 1) (4 * r' + 2) with | left Hle => c_sqrt (Zpos (xO (xI p'))) (2 * s' + 1) @@ -74,7 +74,7 @@ Definition sqrtrempos : forall p:positive, sqrt_data (Zpos p). end | xI (xO p') => match sqrtrempos p' with - | c_sqrt s' r' Heq Hint => + | c_sqrt _ s' r' Heq Hint => match Z_le_gt_dec (4 * s' + 1) (4 * r' + 1) with | left Hle => c_sqrt (Zpos (xI (xO p'))) (2 * s' + 1) @@ -85,7 +85,7 @@ Definition sqrtrempos : forall p:positive, sqrt_data (Zpos p). end | xI (xI p') => match sqrtrempos p' with - | c_sqrt s' r' Heq Hint => + | c_sqrt _ s' r' Heq Hint => match Z_le_gt_dec (4 * s' + 1) (4 * r' + 3) with | left Hle => c_sqrt (Zpos (xI (xI p'))) (2 * s' + 1) @@ -114,7 +114,7 @@ Definition Zsqrt : | Zpos p => fun h => match sqrtrempos p with - | c_sqrt s r Heq Hint => + | c_sqrt _ s r Heq Hint => existT (fun s:Z => {r : Z | @@ -150,7 +150,7 @@ Definition Zsqrt_plain (x:Z) : Z := match x with | Zpos p => match Zsqrt (Zpos p) (Pos2Z.is_nonneg p) with - | existT s _ => s + | existT _ s _ => s end | Zneg p => 0 | Z0 => 0 diff --git a/theories/ZArith/Zwf.v b/theories/ZArith/Zwf.v index 9d2e9cab..cba709e8 100644 --- a/theories/ZArith/Zwf.v +++ b/theories/ZArith/Zwf.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(*